!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     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(version 2);
!
!
!     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.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calcmatwavspeed(ne0,elcon,nelcon,
     &           rhcon,nrhcon,alcon,nalcon,orab,ntmat_,ithermal,alzero,
     &           plicon,nplicon,plkcon,nplkcon,npmat_,mi,dtime,
     &           xstiff,ncmat_,vold,ielmat,t0,t1,
     &           matname,lakon,wavespeed,nmat,ipkon)
!
!     **************
!     Calculates the propagation wave speed in a material, selecting
!     appropiate procedure between isotropic, single crystals, and
!     anisotropic materials. All other cases of orthotropy are treated
!     as anisotropic.

!     Based on the procedure in:
!     C. Lane. The Development of a 2D Ultrasonic Array Inspection
!     for Single Crystal Turbine Blades.
!     Switzerland: Springer International Publishing, 2014.
!
      implicit none
!
      character*80 matname(*),amat
      character*8 lakon(*),lakonl
!
      integer i,i1,nelem,ne0,nelcon(2,*),nrhcon(*),nalcon(2,*),imat,
     &     ntmat_,ithermal,mattyp,ihyper,istiff,kode,mi(*),kk,
     &     nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),ncmat_,iorth,
     &     ielmat(mi(3),*),nope,iorien,ipkon(*),null,
     &     konl(26),nopered,npmat_,nmat
!
      real*8 elas(21),wavespeed(*),rhcon(0:1,ntmat_,*)  ,
     &     alcon(0:6,ntmat_,*),coords(3),orab(7,*),rho,alzero(*),
     &     t0l,t1l,elconloc(21),eth(6),plicon(0:2*npmat_,ntmat_,*),
     &     plkcon(0:2*npmat_,ntmat_,*),plconloc(802),dtime,
     &     xstiff(27,mi(1),*),elcon(0:ncmat_,ntmat_,*),
     &     t0(*),t1(*),shp(4,26),vold(0:mi(2),*),tt,
     &     e,un,um,al,wavspd
!
      write(*,*)'++CMT: Calculating Material Wave Speeds...'
      write(*,*)
!
      null=0
!
!     initialization of wavespeed
!
      do i=1,nmat
         wavespeed(i)=-1.d0
      enddo
!
!     ** DO per element
!
      do nelem=1,ne0
         if(ipkon(nelem).lt.0) cycle
!
         lakonl=lakon(nelem)
         imat=ielmat(1,nelem)
         amat=matname(imat)
         wavspd=wavespeed(imat)
!
         if(lakonl(1:2).ne.'ES') then
!
!     orientation is not important for the wave speed
!
            iorien=0
!
            if(nelcon(1,imat).lt.0) then
               ihyper=1
            else
               ihyper=0
            endif
!
!     calculating the temperature in the integration
!     point
!
            kk=1                ! Only 1 integration point is considered, CENTER
            t0l=0.d0
            t1l=0.d0
            if(ithermal.eq.1) then
               if(lakonl(4:5).eq.'8 ') then
                  do i1=1,nope
                     t0l=t0l+t0(konl(i1))/8.d0
                     t1l=t1l+t1(konl(i1))/8.d0
                  enddo
               elseif(lakonl(4:6).eq.'20 ')then
                  nopered=20
                  call lintemp(t0,t1,konl,nopered,kk,t0l,t1l)
               elseif(lakonl(4:6).eq.'10T') then
                  call linscal10(t0,konl,t0l,null,shp)
                  call linscal10(t1,konl,t1l,null,shp)
               else
                  do i1=1,nope
                     t0l=t0l+shp(4,i1)*t0(konl(i1))
                     t1l=t1l+shp(4,i1)*t1(konl(i1))
                  enddo
               endif
            elseif(ithermal.ge.2) then
               if(lakonl(4:5).eq.'8 ') then
                  do i1=1,nope
                     t0l=t0l+t0(konl(i1))/8.d0
                     t1l=t1l+vold(0,konl(i1))/8.d0
                  enddo
               elseif(lakonl(4:6).eq.'20 ')then
                  nopered=20
                  call lintemp_th(t0,vold,konl,nopered,kk,t0l,t1l,mi)
               elseif(lakonl(4:6).eq.'10T') then
                  call linscal10(t0,konl,t0l,null,shp)
                  call linscal10(vold,konl,t1l,mi(2),shp)
               else
                  do i1=1,nope
                     t0l=t0l+shp(4,i1)*t0(konl(i1))
                     t1l=t1l+shp(4,i1)*vold(0,konl(i1))
                  enddo
               endif
            endif
            tt=t1l-t0l
!
            kode=nelcon(1,imat)

!     material data and local stiffness matrix
!
            istiff=1
            call materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon,nalcon,
     &           imat,amat,iorien,coords,orab,ntmat_,elas,rho,
     &           nelem,ithermal,alzero,mattyp,t0l,t1l,
     &           ihyper,istiff,elconloc,eth,kode,plicon,
     &           nplicon,plkcon,nplkcon,npmat_,
     &           plconloc,mi(1),dtime,kk,
     &           xstiff,ncmat_)
!
            if(mattyp.eq.1) then
               e=elas(1)
               un=elas(2)
               um=e/(1.d0+un)
               al=un*um/(1.d0-2.d0*un)
               um=um/2.d0
               wavspd=max(wavspd,
     &             dsqrt((e*(1-un))/((1+un)*(1-2*un)*rho)))
            elseif(mattyp.eq.2) then
!
!     single crystal
!
               if(((elas(1).eq.elas(3)).and.(elas(1).eq.elas(6)).and.
     &              (elas(3).eq.elas(6))).and.
     &              ((elas(2).eq.elas(4)).and.(elas(2).eq.elas(5)).and.
     &              (elas(4).eq.elas(5))).and.
     &              ((elas(7).eq.elas(8)).and.(elas(7).eq.elas(9)).and.
     &              (elas(8).eq.elas(9)))) then
                  wavspd=max(wavspd,dsqrt((1/3.d0)*(elas(1)+2.0*elas(2)+
     &                 4.0d0*elas(7))/rho))
                  wavspd=max(wavspd,dsqrt((1/2.d0)*
     &                 (elas(1)+elas(2)+2.0*elas(7))/rho))
                  wavspd=max(wavspd,dsqrt(elas(1)/rho))
               else
                  iorth=1
                  call anisomaxwavspd(elas,rho,iorth,wavspd )
               endif
            elseif(mattyp.eq.3) then
               iorth=0
               call anisomaxwavspd(elas,rho,iorth,wavspd)
            endif
            wavespeed(imat)=wavspd
         endif
      enddo
!
      do i=1,nmat
         write(*,*) 'Wave Speed for mat. ',i,wavespeed(i)
      enddo
      write(*,*)
!
      return
      end


submodule(nf_base_layer) nf_base_layer_submodule

  use nf_activation, only: activation_function, &
                           elu, elu_prime, &
                           exponential, &
                           gaussian, gaussian_prime, &
                           relu, relu_prime, &
                           sigmoid, sigmoid_prime, &
                           softplus, softplus_prime, &
                           step, step_prime, &
                           tanhf, tanh_prime

  implicit none

contains

  elemental module subroutine set_activation(self, activation)
    class(base_layer), intent(in out) :: self
    character(*), intent(in) :: activation

    select case(trim(activation))

      ! TODO need to figure out how to handle the alpha param
      !case('elu')
      !  self % activation => elu
      !  self % activation_prime => elu_prime
      !  self % activation_name = 'elu'

      case('exponential')
        self % activation => exponential
        self % activation_prime => exponential
        self % activation_name = 'exponential'

      case('gaussian')
        self % activation => gaussian
        self % activation_prime => gaussian_prime
        self % activation_name = 'gaussian'

      case('relu')
        self % activation => relu
        self % activation_prime => relu_prime
        self % activation_name = 'relu'

      case('sigmoid')
        self % activation => sigmoid
        self % activation_prime => sigmoid_prime
        self % activation_name = 'sigmoid'

      case('softplus')
        self % activation => softplus
        self % activation_prime => softplus_prime
        self % activation_name = 'softplus'

      case('step')
        self % activation => step
        self % activation_prime => step_prime
        self % activation_name = 'step'

      case('tanh')
        self % activation => tanhf
        self % activation_prime => tanh_prime
        self % activation_name = 'tanh'

      case default
        error stop 'Activation must be one of: ' // &
          '"elu", "exponential", "gaussian", "relu", ' // &
          '"sigmoid", "softplus", "step", or "tanh".'

    end select

  end subroutine set_activation

end submodule nf_base_layer_submodule


program main

    use constants
    use io
    use shell_prompts

    ! use omp_lib                                                                                ! CHANGE DUE TO -fopenmp

    implicit none
    ! parameter
    integer, parameter :: unit_out=10
    integer, parameter :: T_diff=T_max-T_min
    ! dynamic
    character(len=char_max) :: output_file
    integer :: i,j,k
    integer(kind=iter) :: t1,t2
    integer :: threads
    integer :: lattice_dim                                                                                ! CHANGE DUE TO -fopenmp
    ! integer :: lattice_dim, lattice_dim_max                                     ! lattice dimension
    ! integer, dimension(6) :: lattice_array                         ! lattice array (loop through)                       ! CHANGE DUE TO -fopenmp
    ! integer, dimension(128,128) :: lattice                             ! 2D Ising Lattice                               ! CHANGE DUE TO -fopenmp
    real(kind=p) :: time_start, time_end, time_diff
    real(kind=p) :: T, beta                                                     ! temperature, inverse temperature
    real(kind=p), dimension(5) :: M                                             ! magnetisation

    ! M(1) = M̅
    ! M(2) = <|M|>
    ! M(3) = <|M^2|>
    ! M(4) = <|M^4|>                1  <|M^4|>
    ! M(5) = Binder parameter = 1 - - ---------
    !                               3 <|M^2|>^2

    ! ########## PROGRAM START ############

    call program_prompt(title, '-')                                             ! shell_prompts

    ! threads = omp_get_max_threads()

    ! write(*, fmt='(a,i2,a,/)') 'Using up to ', threads, ' threads.'                                                     ! CHANGE DUE TO -fopenmp

    ! lattice_array = set_lattice_array(default_lattice_array)                  ! main                                  ! CHANGE DUE TO -fopenmp

    ! allocate max dim size to use same matrix for all dims
    ! lattice_dim_max = maxval(lattice_array, 1)                                                                        ! CHANGE DUE TO -fopenmp
    ! lattice_dim_max = 128
    ! allocate(lattice(lattice_dim_max,lattice_dim_max))                                                                ! CHANGE DUE TO -fopenmp
    ! lattice_array = (/ 4, 8, 16, 32, 64, 128/)

    write (*,fmt='(a,/)') 'Commencing sweeps...'

    do i = 1, size(lattice_array)

        lattice_dim = lattice_array(i)

        if (output) then
            output_file = create_path(dirname, lattice_dim)                     ! main
            call open_file_w(unit_out, output_file)                             ! io
        end if

        ! call cpu_time(time_start)
        call system_clock(t1)
        do j = 0, T_diff*100

            ! temperature is incremented by .1 every loop
            T = T_min + j*0.01_p
            beta = 1._p / T
            M = 0._p

            if (.not. verbose .and.  (mod(j, T_diff) .eq. 0)) then
                ! if one 10th share of workload is done
                call progress(                                              &   ! shell_prompts
                    int(j/T_diff, kind=iter),  &
                    lattice_dim                                             &
                )
            endif

            ! Initialize lattice with random magnetization (-1,1)
            call lattice_randomize(lattice, lattice_dim, lattice_dim_max)       ! main

            ! --- Start sweeps ---
            !$OMP PARALLEL DO PRIVATE(K)                                                                                ! CHANGE DUE TO -fopenmp
            do k = 1, pre_sweeps
                call sweep(                                                 &   ! main
                    lattice,lattice_dim,lattice_dim_max,                    &
                    method, beta                                            &
                )
            end do
            !$OMP END PARALLEL DO                                                                                ! CHANGE DUE TO -fopenmp

            !$OMP PARALLEL DO PRIVATE(K)                                                                                ! CHANGE DUE TO -fopenmp
            do k = 1, sweeps
                call sweep(                                                 &   ! main
                    lattice,lattice_dim,lattice_dim_max,                    &
                    method, beta                                            &
                )

                M(1) = sum(lattice(:lattice_dim,:lattice_dim)) /            &
                    lattice_dim**2._p
                M(2) = M(2) + abs(M(1)) / sweeps
                M(3) = M(3) + abs(M(1))**2._p / sweeps
                M(4) = M(4) + abs(M(1))**4._p / sweeps
            end do
            !$OMP END PARALLEL DO                                                                                ! CHANGE DUE TO -fopenmp

            M(5) = 1._p - M(4) / (3._p * M(3)**2._p)

            ! --- End sweeps ---

            if (output) then
                write (unit_out,*)                                          &
                    T, M(2:),                                               &
                    calcE(lattice,lattice_dim,lattice_dim_max)                  ! main
            end if

            if (verbose) then
                call visualize_magnetization(lattice, lattice_dim_max)          ! shell_prompts
                write (*, fmt='(a, f14.6)')                                 &
                    'Average energy:',                                      &
                    calcE(lattice,lattice_dim,lattice_dim_max)                  ! main
                write (*,*)   &
                    '<|M|> =', M(2),' <|M^2|> =', M(3),                     &
                    ' <|M^4|> =', M(4),' BK =', M(5)
            end if

        end do
        ! call cpu_time(time_end)
        call system_clock(t2)

        ! write(*,*) time_end-time_start

        if (.not. verbose) then
            time_diff = (t2 - t1) / 1000._p
            write (*, fmt='(a,i3,a,f6.3,a)') ' ✓ in ',                      &
                int(time_diff/60, kind=4), ' min ',                         &
                mod(time_diff,60._p), ' s'
        endif

        if (output) call close_file(unit_out)

    end do

    call program_prompt('Program ended successully', '-', len(trim(title)) + 2) ! shell_prompts

    return ! ########### PROGRAM END #############

    contains ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! function set_lattice_array(use_default) ! --------------------------------> FUNC set_lattice_array()
    !     ! set array of lattice dimensions through which to parse through

    !     integer(kind=iter) :: i
    !     integer :: lattice_n, default_lattice_n                                 ! lattice array length, default length
    !     integer, dimension(:), allocatable :: lattice_array_default             ! default lattice-dim-array
    !     integer, dimension(:), allocatable :: set_lattice_array                 ! lattice-dim-array
    !     logical, intent(in) :: use_default                                      ! use default or enter via input

    !     ! set default values
    !     default_lattice_n = 6                                                   ! makes sure allocate correctly!
    !     allocate(lattice_array_default(default_lattice_n))
    !     lattice_array_default = (/ 4, 8, 16, 32, 64, 128 /)                     ! ATTENTION: 64 ~50min, 128 ~5h

    !     if (use_default) then
    !         allocate(set_lattice_array(default_lattice_n))
    !         do i = 1, default_lattice_n
    !             set_lattice_array(i) = lattice_array_default(i)
    !         end do
    !     else
    !         call user_input(lattice_array, lattice_n)
    !     endif

    ! end function set_lattice_array

    subroutine lattice_randomize(lattice, dim, dim_max) ! --------------------> SUBR lattice_randomize()
        ! populate lattice with ranomized spin orientations (-1, 1)

        integer, intent(in) :: dim, dim_max                                     ! dim_max = allocated size, dim = actual used size
        integer, intent(inout) :: lattice(dim_max,dim_max)
        integer :: i,j
        real, save :: rand

        do i = 1, dim
            do j = 1, dim
                call random_number(rand)
                if (rand .gt. 0.5_p) then
                    lattice(i,j) = 1
                else
                    lattice(i,j) = -1
                endif
            enddo
        enddo

    end subroutine lattice_randomize

    function create_path(dirname, lattice_dim) ! -----------------------------> FUNC create_path()

        character(len=char_max), intent(in) :: dirname
        character(len=char_max) :: create_path, dim_formatted
        integer, intent(in) :: lattice_dim

        write(dim_formatted, fmt='(i3.3)') lattice_dim
        create_path = trim(adjustl(dirname)) // "/ising_lattice-"           &
                        // trim(dim_formatted) // ".dat"

    end function create_path

    subroutine sweep(lattice,dim,dim_max,method,beta) ! ----------------------> SUBR sweep()
        ! perform sweep routine

        character(len=*), intent(in) :: method
        integer, intent(in) :: dim, dim_max                                     ! dim_max = allocated size, dim = actual used size
        integer, intent(inout) :: lattice(dim_max,dim_max)
        integer :: i,j
        real, save :: rand
        real(kind=p), intent(in) :: beta
        real(kind=p) :: delta_E, r
        ! real(kind=p) :: E_n, E_ij

        do i=1,dim
            do j=1,dim

                ! E_n = calcE(lattice,dim,dim_max)
                ! E_ij = calc_dE(i,j,lattice,dim,dim_max)
                !
                ! delta_E = E_n - E_ij

                ! get energy delta
                delta_E = calc_dE(i,j,lattice,dim,dim_max)        ! main
                ! transition probability
                r = exp(-beta * delta_E)
                ! optional spin-flip
                call random_number(rand)
                if (rand .lt. acceptance_probability(method,r)) then
                    lattice(i,j) = -lattice(i,j)
                endif

            end do
        end do

    end subroutine sweep

    function acceptance_probability(method, r) ! -----------------------------> FUNC acceptance_probability()
        ! calculate acceptance probibilty based on passed method

        character(len=*) :: method
        real(kind=p) :: acceptance_probability, r

        select case (method)
            case ('metropolis')
                acceptance_probability =  min(1._p, r)
            case ('heat_bath')
                acceptance_probability = r / (1 + r)
            case default
                acceptance_probability =  min(1._p, r)
        end select

    end function acceptance_probability

    function calcE(lattice, dim, dim_max) ! ----------------------------------> FUNC calcE()
        ! calculate energy of current state

        integer, intent(in) :: dim, dim_max
        integer, intent(in) :: lattice(dim_max,dim_max)
        integer :: i,j,k
        integer :: Inew, Jnew
        real(kind=p) :: calcE, energy

        ! Determine the initial energy
        energy = 0.0

        do i = 1, dim
            do j = 1, dim

                ! Loop over nearest neighbors
                do k = 1, NN
                    Inew = i + Inn(k)
                    Jnew = j + Jnn(k)

                    ! periodic boundary conditions
                    if (Inew .le. 0) then
                            Inew = dim
                    else if(Inew .gt. dim) then
                        Inew = 1
                    endif

                    ! periodic boundary conditions
                    if (Jnew .le. 0) then
                        Jnew = dim
                    else if(Jnew .gt. dim) then
                        Jnew = 1
                    endif

                    ! Update the energy
                    energy = energy - JJ * lattice(i,j) * lattice(Inew,Jnew)
                    enddo
                ! Calculate the contribution from the field H
                energy = energy - 2.d0 * HH * lattice(i,j)

            enddo
        enddo

        ! Account for double counting
        energy = energy / 2._p
        calcE = energy

    end function calcE

    function calc_dE(i, j, lattice, dim, dim_max) ! --------------------------> FUNC calc_dE()
        ! calculate energy delta between previous and flipped state

        integer, intent(in) :: dim, dim_max
        integer, intent(in) :: lattice(dim_max,dim_max)
        integer :: i,j,k
        integer :: Inew, Jnew
        real(kind=p) :: calc_dE, energy_flipped, energy_prev

        energy_flipped = 0._p
        energy_prev = 0._p

        ! Loop over nearest neighbors
        do k = 1, NN
            Inew = i + Inn(k)
            Jnew = j + Jnn(k)

            ! periodic boundary conditions
            if (Inew .le. 0) then
                    Inew = dim
            else if (Inew .gt. dim) then
                Inew = 1
            endif

            ! periodic boundary conditions
            if (Jnew .le. 0) then
                Jnew = dim
            else if (Jnew .gt. dim) then
                Jnew = 1
            endif

            ! Calculate delta E, flip lattice(i,j) on site
            energy_prev =                                                   &
                energy_prev - JJ * lattice(i,j) * lattice(Inew,Jnew)
            energy_flipped =                                                &
                energy_flipped + JJ * lattice(i,j) * lattice(Inew,Jnew)
        enddo

        ! -> H part cancels for delta E calculation
        ! energy_prev = energy_prev - 2.d0 * HH * lattice(i,j)
        ! energy_flipped = energy_flipped - 2.d0 * HH * lattice(i,j)
        calc_dE = energy_flipped - energy_prev

    end function calc_dE

end program main


module slf_rk4integr

    use iso_fortran_env, only: r64 => real64
    use ieee_arithmetic

    implicit none

    interface rk4integr
        module procedure rk4integr_full
        module procedure rk4integr_simple
    end interface

contains

    subroutine rk4integr_full(x, y0, fder, na, y, dy, a, nmax)

        real(r64), intent(in) :: x(:), y0(:)
        integer, intent(in) :: na
        real(r64), intent(out) :: y(size(y0),size(x))
        real(r64), intent(out) :: dy(size(y0),size(x))
        real(r64), intent(out) :: a(na,size(x))
        integer, intent(out), optional :: nmax

        interface
            subroutine fder(x,y,dy,a,abort)
                import r64
                real(r64), intent(in) :: x, y(:)
                real(r64), intent(inout) :: dy(size(y)), a(:)
                logical, intent(inout) :: abort
            end subroutine
        end interface

        real(r64) :: dx, dy1(size(y0)), dy2(size(y0)), dy3(size(y0)), dy4(size(y0))
        logical :: abort
        integer :: i

        y(:,1) = y0
        a(:,1) = 0
        dy(:,1) = 0

        abort = .false.
        nmax = 0

        integr_loop : do i = 1,size(x)

            if ( i > 1 ) then
                a(:,i) = a(:,i-1)
                dy(:,i) = dy(:,i-1)
            end if

            call fder(x(i), y(:,i), dy1, a(:,i), abort)
            if (abort) exit integr_loop

            if ( i < size(x) ) then
                dx = x(i+1) - x(i)
                a(:,i+1) = a(:,i)

                call fder(x(i) + (dx/2), y(:,i) + dy1 * (dx/2), dy2, a(:,i+1), abort)
                if (abort) exit integr_loop
                call fder(x(i) + (dx/2), y(:,i) + dy2 * (dx/2), dy3, a(:,i+1), abort)
                if (abort) exit integr_loop
                call fder(x(i+1), y(:,i) + dy3 * dx, dy4, a(:,i+1), abort)
                if (abort) exit integr_loop

                dy(:,i) = ( dy1 + 2*dy2 + 2*dy3 + dy4 ) / 6
                if ( any(.not.ieee_is_normal(dy(:,i))) ) exit integr_loop

                y(:,i+1) = y(:,i) + dx * dy(:,i)
            else
                dy(:,i) = dy1
            end if

            if (present(nmax)) nmax = i

        end do integr_loop

    end subroutine

    subroutine rk4integr_simple(x, y0, fder, y, dy, nmax)

        real(r64), intent(in) :: x(:), y0(:)
        real(r64), intent(out) :: y(size(y0),size(x))
        real(r64), intent(out) :: dy(size(y0),size(x))
        integer, intent(out), optional :: nmax

        interface
            subroutine fder(x,y,dy,abort)
                import r64
                real(r64), intent(in) :: x, y(:)
                real(r64), intent(inout) :: dy(size(y))
                logical, intent(inout) :: abort
            end subroutine
        end interface

        real(r64) :: dx, dy1(size(y0)), dy2(size(y0)), dy3(size(y0)), dy4(size(y0))
        logical :: abort
        integer :: i

        y(:,1) = y0
        dy(:,1) = 0

        abort = .false.
        nmax = 0

        integr_loop : do i = 1,size(x)

            if ( i > 1 ) then
                dy(:,i) = dy(:,i-1)
            end if

            call fder(x(i), y(:,i), dy1, abort)
            if (abort) exit integr_loop

            if ( i < size(x) ) then
                dx = x(i+1) - x(i)

                call fder(x(i) + (dx/2), y(:,i) + dy1 * (dx/2), dy2, abort)
                if (abort) exit integr_loop
                call fder(x(i) + (dx/2), y(:,i) + dy2 * (dx/2), dy3, abort)
                if (abort) exit integr_loop
                call fder(x(i+1), y(:,i) + dy3 * dx, dy4, abort)
                if (abort) exit integr_loop

                dy(:,i) = ( dy1 + 2*dy2 + 2*dy3 + dy4 ) / 6
                if ( any(.not.ieee_is_normal(dy(:,i))) ) exit integr_loop

                y(:,i+1) = y(:,i) + dx * dy(:,i)
            else
                dy(:,i) = dy1
            end if

            if (present(nmax)) nmax = i

        end do integr_loop

    end subroutine

end module


      PROGRAM xmnbrak
C     driver for routine mnbrak
      INTEGER i
      REAL ax,bx,cx,fa,fb,fc
      EXTERNAL bessj0
      do 11 i=1,10
        ax=i*0.5
        bx=(i+1.0)*0.5
        call mnbrak(ax,bx,cx,fa,fb,fc,bessj0)
        write(*,'(1x,t13,a,t25,a,t37,a)') 'A','B','C'
        write(*,'(1x,a3,t5,3f12.6)') 'X',ax,bx,cx
        write(*,'(1x,a3,t5,3f12.6)') 'F',fa,fb,fc
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xmnbrak.for


! Copyright (C) Dmitry Korotin dmitry@korotin.name

module parameters

  implicit none
  save

  integer, parameter :: &
    dp = selected_real_kind(14,200), &
    maxnnbrs = 300 ! maximum number of nearest neighbours

  real(dp), parameter :: pi               = 3.14159265358979323846_dp
  real(dp), parameter :: tpi              = 2.0_dp * pi
  real(dp), parameter :: kb_ev = 8.6173324d-5

end module parameters


      program enterdata

      implicit none

       integer :: i,j,k
       integer :: iter,count_rate, count_max,count
       integer :: t_start,t_final
       integer, parameter :: nx=8192,ny=nx,max_iter=2000
       double precision, parameter    :: pi=4d0*dtan(1d0)
       real, parameter    :: error=0.001
       double precision               :: max_err,time_s,&
                                         d2fx,d2fy
       double precision, allocatable  :: f(:,:), f_k(:,:),f0(:,:)

       allocate(f(nx,ny)); allocate(f_k(nx,ny)); allocate(f0(nx,ny))

       call system_clock(count_max=count_max, count_rate=count_rate)

       call system_clock(t_start)

!generate a random vector to define the initial conditions
!       call system_clock(count, count_rate, count_max)

       do i=1,nx
          f(i,1)  = dsin(pi*(i-1)/(nx-1))
          f(i,ny) =0d0
       enddo
       do j=1,ny
          f(1,j) = dsin(pi*(j-1)/(ny-1))
          f(nx,j) = 0d0
       enddo

        write(*,*)'--sum before loop:', sum(f(:,:))

!offload data to the device
      do iter=1,5

         do j=1,ny
            do i=1,nx

               f_k(i,j) = 2*f(i,j)

             enddo
          enddo

!offload data to the device
         do j=1,ny
            do i=1,nx

               f0(i,j) = 2*f(i,j) + f_k(i,j)

             enddo
          enddo
       enddo

       write(*,*)'--sum after end data fk:', sum(f_k(:,:))
       write(*,*)'--sum after end data f0:',sum(f0(:,:))

       call system_clock(t_final)

       time_s = real(t_final - t_start)/real(count_rate)

       !print*, '--Time it takes (s)', time_s
       end

       subroutine arrayf_new(nx,ny,f,f_k)

         implicit none

         integer :: i,j,nx,ny
         double precision :: f(nx,ny),f_k(nx,ny)

         do j=2,ny-1
            do i=2,nx-1

               f_k(i,j) = 2*f(i,j)

             enddo
          enddo

          end subroutine arrayf_new


function tau_sobol ( dim_num )

!*****************************************************************************80
!
!! TAU_SOBOL defines favorable starting seeds for Sobol sequences.
!
!  Discussion:
!
!    For spatial dimensions 1 through 13, this routine returns
!    a "favorable" value TAU by which an appropriate starting point
!    in the Sobol sequence can be determined.
!
!    These starting points have the form N = 2**K, where
!    for integration problems, it is desirable that
!      TAU + DIM_NUM - 1 <= K
!    while for optimization problems, it is desirable that
!      TAU < K.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 July 2006
!
!  Author:
!
!    Original FORTRAN77 version by Bennett Fox.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    IA Antonov, VM Saleev,
!    USSR Computational Mathematics and Mathematical Physics,
!    Volume 19, 1980, pages 252 - 256.
!
!    Paul Bratley, Bennett Fox,
!    Algorithm 659:
!    Implementing Sobol's Quasirandom Sequence Generator,
!    ACM Transactions on Mathematical Software,
!    Volume 14, Number 1, pages 88-100, 1988.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Stephen Joe, Frances Kuo
!    Remark on Algorithm 659:
!    Implementing Sobol's Quasirandom Sequence Generator,
!    ACM Transactions on Mathematical Software,
!    Volume 29, Number 1, pages 49-57, March 2003.
!
!    Ilya Sobol,
!    USSR Computational Mathematics and Mathematical Physics,
!    Volume 16, pages 236-242, 1977.
!
!    Ilya Sobol, YL Levitan,
!    The Production of Points Uniformly Distributed in a Multidimensional
!    Cube (in Russian),
!    Preprint IPM Akad. Nauk SSSR,
!    Number 40, Moscow 1976.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension.  Only values
!    of 1 through 13 will result in useful responses.
!
!    Output, integer ( kind = 4 ) TAU_SOBOL, the value TAU.
!
  implicit none

  integer ( kind = 4 ), parameter :: dim_max = 13

  integer ( kind = 4 ) dim_num
  integer ( kind = 4 ), save, dimension ( dim_max ) :: tau_table = (/ &
     0,  0,  1,  3,  5, &
     8, 11, 15, 19, 23, &
    27, 31, 35 /)
  integer ( kind = 4 ) tau_sobol

  if ( 1 <= dim_num .and. dim_num <= dim_max ) then
    tau_sobol = tau_table(dim_num)
  else
    tau_sobol = - 1
  end if

  return
end


	subroutine transpose(M,N)
	real M(N,N)

	do i = 1, N-1
		do j = i+1, N
			M(i,j) = M(j,i)
		enddo
	enddo

	end


subroutine preProcessAtThisfrec(J)
use glovars
use modelVars
use refSolMatrixVars
use matrizGlobal
use sourceVars, only: PSV,SH
implicit none
integer, intent(in) :: J
integer :: i,l,ik,tam,k0
complex*16, dimension(:,:), pointer :: pointAp

        FREC=DFREC*real(J-1); if (J .eq. 1)  FREC = 0.5_8 * DFREC  ! Hz
        OME=2.0*PI*FREC !rad/s
        COME = CMPLX(OME, OMEI,8)!periodic sources damping
        COME = COME * cmplx(1.0, -1.0/2.0/Qq,8) !histeretic damping
        pt_come_i => COME
        ik = N+1; i = 1
        if (useAzimi) then
        ! Azimi attenuation: see Kennett, The seismic wavefield, vol1 pag 148-150
          do l=i,ik !N+1 estratos y una inclusión
          ! "Normally we expect that loss in dilatation is very small compared
          ! with that in shear so that Qp^-1 << Qs^-1 , and then "
!         Qs(l) = Qq !* 4./3. * (beta0(l)/alfa0(l))**2. !; print*,"Qs ",Qs(l)
!         Qp(l) = Qq !; print*,"Qp ",Qp(l)
          ! alfa0 y beta0 son velocidades de referencia a T=1sec
           beta(l) = cmplx((beta0(l))*(1.+1./pi/Qq*log(ome/2./pi)),-1./2./Qq,8)
           alfa(l) = cmplx((alfa0(l))*(1.+1./pi/Qq*log(ome/2./pi)),-1./2./Qq,8)
           aMU(l) = RHO(l) * beta(l)**2.
           Lambda(l) = RHO(l)*alfa(l)**2. - real(2.)*aMU(l)
          end do
        else
          do l=i,ik !N+1 estratos y una inclusión
           beta(l) = beta0(l); alfa(l) = alfa0(l)
           aMU(l) = RHO(l) * beta(l)**2.
           Lambda(l) = RHO(l)*alfa(l)**2. - real(2.)*aMU(l)
          end do
        end if

         ! apuntadores a la matriz global
         pt_ipivA => ipivA
         pt_workA => workA
         call makeGANU (J) !los numeros de onda horizontales para P y S

         if (PSV) then
         tam = size(Ak,1)
       do ik = 1,vecNK(J) ! k positivo (Aorig -> nmax+1)
         pointAp => Ak(1:tam,1:tam,ik)
         pt_k => k_vec(ik)
         call gloMat_PSV(pointAp,pt_k,ik)
         call inverseA(pointAp,pt_ipivA,pt_workA,tam)
       end do ! ik
       k0 = vecNK(J);
       call intrplr_gloMat(k0,15,pt_cOME_i,pt_ipivA,pt_workA)
!      do ik = 1,min(int(vecNK(J)*SpliK),nmax)+1
!        print*,ik,sum(Ak(1:tam,1:tam,ik))
!      end do
!      print*,"sum=",sum(Ak(1:tam,1:tam,1:min(int(vecNK(J)*SpliK),nmax)+1))
!      stop
       call parImpar_gloMat ! k negativo

       ! Funciones de Green para propagar a la frontera de cada estrato
       ! (sin fase vertical, la fase vertical se agrega para cada fuente)
       if(.not. allocated(BparaGa)) allocate(BparaGa(tam,N+1,2*nmax,2));BparaGa=0
       if(.not. allocated(BparaNu)) allocate(BparaNu(tam,N+1,2*nmax,2));BparaNu=0
       call PSVpaGaNU(J)
       ! Multiplicar partes de la m
       if(.not. allocated(CoefparGa)) allocate(CoefparGa(tam,N+1,2*nmax,2,2))
       if(.not. allocated(CoefparNu)) allocate(CoefparNu(tam,N+1,2*nmax,2,2))
       call PSVMatAporGaNU(J)

      end if!psv ............................................
      if (SH) then
         tam = size(Ak,1)
      Do ik = 1,vecNK(J)!k0!nmax+1
      ! k positivo
         pointAp => Ak(1:tam,1:tam,ik)
         pt_k => k_vec(ik)!        print*,ik, 2*nmax - (ik-2)
         call globalmatrix_SH(pointAp,pt_k,ik)
         call inverseA(pointAp,pt_ipivA,pt_workA,tam)
      end do ! ik
       k0 = vecNK(J);
      call intrplr_gloMat(k0,15,pt_cOME_i,pt_ipivA,pt_workA)
      ! k negativo (es simétrico)
         Ak(1:tam,1:tam,Nmax+2:2*nmax) = &
         Ak(1:tam,1:tam,Nmax:2:-1)
      end if!sh

      ! barra de avance
        write(6,'(A)', ADVANCE = "NO") repeat(char(8),60)
        write(6,'(A)', ADVANCE = "NO") repeat(char(8),17) !eta
        write(6,'(A)', ADVANCE = "NO") "["
        write(6,'(A,A)', ADVANCE = "NO") &
        repeat("X",int((58.0/NFREC)*(NFREC+1-J))),&
        repeat("_",58-int((58.0/NFREC)*(NFREC+1-J)))
        write(6,'(A)', ADVANCE = "NO") "]"
end subroutine preProcessAtThisfrec


 subroutine resample(  &
    nsmax,         ns_elas,     dnu,          &
    filter_radius, nstart,      nend,         &
    nwave_1cm,     wavenr_1cm,  spectrum_1cm, &
    nwave_aux,     wavenr_aux,  spectrum_aux)

!-----------------------------------------------------------
! Subroutine:
!   resample
!
! Purpose:
!   Resample input spectrum
!   to obtain output spectrum on desired grid
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8)!double precision

  integer,intent(in):: &
     nsmax,     &
     ns_elas,   &
     nstart,    &
     nend,      &
     nwave_aux, &
     nwave_1cm

  real(kind=dp),intent(in):: &
     dnu,                    &
     filter_radius,  & !width of sample function (how many times dnu)
     wavenr_1cm(nwave_1cm),           &
     spectrum_1cm(nwave_1cm),         &
     wavenr_aux(nwave_aux)

  integer::   &
    n,        &  !wavenr index for destination spectrum
    l,        &  !wavenr index for original (1cm-1) spectrum
    lcenter,  &  !points to wavenr index l that corresponds to n
    lstart,   &
    lend,     &
    ll,       &  !l-lcenter
    llcenter, &
    llstart,  &
    llend,    &
    resample_switch

  real(kind=dp):: &
    samplefunk, &
    normsamplefunk

! functions
  real(kind=dp):: &
    Lancosz,      &
    Gaussian,     &
    CubicSpline,  &
    Tent,         &
    Near

  real(kind=dp),intent(out):: &
     spectrum_aux(nwave_aux)

!----------------------------------------------------------
! resample_switch = 1 Lanczos resampling
!                 = 2 with Gaussian
!                 = 3 bicubic interpolation
!                 = 4 with tent function
!                 = 5 downsample (select nearest datapoint)
!-----------------------------------------------------------

  resample_switch = 5

  do n=1,nwave_aux

! loop over destination spectrum

!    collect around n:
!    n-filter_radius, ..., n, ... , n+filter_radius

!    index 1cm-1 wavenr lcenter that corresponds to wavenr_aux(n)
     lcenter  = nstart + (n-1) * int(dnu)

!    +/- filter_radius * dnu around lcenter
     lstart  = lcenter -int(filter_radius) * int(dnu)
     lend    = lcenter +int(filter_radius) * int(dnu)

!    more points required for resampling with Gaussian
     if(resample_switch.eq.2)then
        lstart  = lcenter -2*int(filter_radius) * int(dnu)
        lend    = lcenter +2*int(filter_radius) * int(dnu)
     endif

!    more points required for cubic spline resampling
     if(resample_switch.eq.3)then
        lstart  = lcenter -2*int(filter_radius) * int(dnu)
        lend    = lcenter +2*int(filter_radius) * int(dnu)
     endif

!    only 1 point required for downsampling
     if(resample_switch.eq.5)then
        lstart  = lcenter
        lend    = lcenter
     endif

     llcenter = 0
     llstart  = lstart - lcenter
     llend    = lend   - lcenter

     spectrum_aux(n) = 0.d0

     normsamplefunk = 0.d0

     do l=lstart,lend

        ll = l-lcenter

!-------------------------------------------------------------
!       Lancosz resampling
!-------------------------------------------------------------

        if(resample_switch.eq.1) &
           samplefunk = Lancosz(dble(ll),filter_radius)

!-------------------------------------------------------------
!       Resampling with Gaussian
!-------------------------------------------------------------

        if(resample_switch.eq.2) &
           samplefunk = Gaussian(dble(ll),filter_radius)

!-------------------------------------------------------------
!       Cubic spline
!       (slower, wider wavenr range needed)
!-------------------------------------------------------------

        if(resample_switch.eq.3) &
           samplefunk = CubicSpline(dble(ll),filter_radius)

!-------------------------------------------------------------
!       Resample with tent function
!-------------------------------------------------------------

        if(resample_switch.eq.4) &
           samplefunk = Tent(dble(ll),filter_radius)

!-------------------------------------------------------------
!       Downsample, throw away data
!       Use for testing only
!-------------------------------------------------------------

        if(resample_switch.eq.5) &
          samplefunk = Near(dble(ll))

!-----------------------------------------------------------

        normsamplefunk = normsamplefunk + samplefunk

        spectrum_aux(n) = spectrum_aux(n) + &
                            samplefunk * spectrum_1cm(l)
    enddo

    if(normsamplefunk.ne.0.d0)then
       spectrum_aux(n) = spectrum_aux(n)/normsamplefunk
    else
       spectrum_aux(n) = 0.d0
    endif

  enddo

  return
  end subroutine resample

!------------------------------------------------------------
! Lanczos resampling function
! http://en.wikipedia.org/wiki/Lanczos_resampling
!
!          sinc(x)*sinc(x/a) for -a < x < a and x.ne.0
!  W(x) =  1                 for x=0
!          0                 otherwise
!
! where a is radius of the filter and
! sin(x)sinc(x/a) can be expanded as
! a * sin(pi*x) * sin(pi*x/a) / (x**2 * pi**2)
!------------------------------------------------------------
  function Lancosz(x,a)
  implicit none
  integer,parameter::dp=selected_real_kind(8)!double precision
  real(kind=dp),intent(in):: &
    x, & !coordinate
    a    !radius
  real(kind=dp)::pi,tmp
  real(kind=dp)::Lancosz
  if(x.eq.0.d0)then
     Lancosz = 1.d0
     return
  endif
  if((x.le.a).or.(x.ge.a))then
     Lancosz = 0.d0
     return
  endif
  pi = 2.d0*asin(1.d0)
  tmp = x*pi
  Lancosz = a*sin(tmp)*sin(tmp/x)/(tmp*tmp)
  return
  end function Lancosz

!------------------------------------------------------------
! Resampling with Gaussian function
!------------------------------------------------------------
  function Gaussian(x,fwhm)
  implicit none
  integer,parameter::dp=selected_real_kind(8)!double precision
  real(kind=dp),intent(in):: &
    x,    & !coordinate
    fwhm    !fwhm
  real(kind=dp)::pi,sigma
  real(kind=dp)::Gaussian
  if(abs(x).ge.4.d0*fwhm)then
     Gaussian = 0.d0
     return
  endif
  pi = 2.d0*asin(1.d0)
  sigma = fwhm/(2.d0*sqrt(2.d0*log(2.d0)))
  Gaussian = exp(-x*x/(2.d0*sigma*sigma))/(sigma*sqrt(2.d0*pi))
  return
  end function Gaussian

!-------------------------------------------------------------
! Bicubic convolution algorithm (Keys, 1981)
! http:/en.wikipedia.org/wiki/Bicubic_interpolation
!
!        (b+2)|x/a|^3 - (b+3)|x/a|^2          + 1    for 0 < |x| =< a
! W(x) =    b |x/a|^3 -   5b |x/a|^2 + 8b |x/a| - 4b for a < |x| =< 2a
!              0                               otherwise
!
! where b is usually set to -0.5 or -0.75
!-------------------------------------------------------------
  function CubicSpline(x,a)
  implicit none
  integer,parameter::dp=selected_real_kind(8)!double precision
  real(kind=dp),intent(in):: &
    x, & !coordinate
    a    !radius
  real(kind=dp)::b
  real(kind=dp)::CubicSpline
  b = -0.5d0
  if((abs(x).gt.0).or.(abs(x).le.a))then
     CubicSpline = (b+2.d0)*abs(x)**3 - (b+3.d0)*abs(x)**2 + 1.d0
     return
  endif
  if((abs(x).gt.a).or.(abs(x).le.2.d0*a))then
     CubicSpline = b*abs(x)**3 - 5.d0*b*abs(x)**2 + 8.d0*b*abs(x) - 4.d0*b
     return
  endif
  CubicSpline = 0.d0
  return
  end function CubicSpline

!------------------------------------------------------
! Tent function
!
! W(x) = 1-|x/a|  |x| < a
!        0         otherwise
! a=2
!-----------------------------------------------------
  function Tent(x,a)
  implicit none
  integer,parameter::dp=selected_real_kind(8)!double precision
  real(kind=dp),intent(in):: &
    x, & !coordinate
    a    !radius
  real(kind=dp)::Tent
  if(abs(x).lt.a)then
     Tent = 1.d0-abs(x/a)
     return
  endif
  Tent = 0.d0
  return
  end function Tent

!------------------------------------------------------
! Near
! for testing
!-----------------------------------------------------
  function Near(x)
  implicit none
  integer,parameter::dp=selected_real_kind(8)!double precision
  real(kind=dp),intent(in):: &
    x !coordinate
  real(kind=dp)::Near
  if(x.eq.0.d0)then
     Near = 1.d0
     return
  endif
  Near = 0.d0
  return
  end function Near


c=======================================================================
c
c     subroutine SKTHGENOPT
c
c     Computing the function and gradient of
c
c     Theta(dual) = 0.5*[wopt'*Q*wopt] + wopt'*plin + cste
c
c-----------------------------------------------------------------------
      SUBROUTINE skthgenopt ( n, Q, kapplin, rho, omega, omega0,
     &                        ndual, ydual, delta, mu, dist,
     &                        dwork, funct, grad )
c-----------------------------------------------------------------------
c
c     INPUT
c       n       : number of values                               integer
c       Q       : semi definite matrix (n*n)                      double
c       kapplin : vector(n) linear part of the objective funtcion double
c       rho     : mean returns (n)                                double
c       omega   : vector(n) wights of the portfolio               double
c       omega0  : vector(n) second order portfolio                double
c       ndual   : number of variables                            integer
c       ydual   : dual solution lambda (ndual)                    double
c       delta   : maximal distance (with respect to the L2 norm)
c                 between omega0 and the optimal portfolio        double
c       mu      : value of the target return                      double
c       dist    : distance (with respect to the L2 norm)
c                 between omega0 and omega                        double
c
c     WORKSPACE
c       dwork   : n                                               double
c
c     OUTPUT
c       funct   : dual function value                             double
c       grad    : (2)-array gradient value                        double
c
c     CALL
c       OVTMCV, XV, SVVX
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, ndual
      DOUBLE PRECISION funct, cste, delta, mu, dist, Q(*), kapplin(*),
     &                 omega(*), rho(*), ydual(*), omega0(*), grad(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER pdw
      DOUBLE PRECISION var, scal, lin, perf, NEGONE
      PARAMETER (NEGONE = -1.E0)
c
c     external functions
      EXTERNAL OVTMCV, XV, SVVX
c
c-----------------------------------------------------------------------
c
c     pointers for double precision work space : dwork
c     ------------------------------------------------
c     Double workspace
      pdw = 1
c
c     Total size of iwork array = n
c
c----------------------------------------------------------------
c
      CALL OVTMCV(n, Q, omega, var)  ! w'*Q*w
      CALL XV(n, omega, kapplin, lin)
      funct = 0.5*var + lin + ydual(1)*mu + ydual(2)*dist
      funct = -funct
      CALL XV(n, rho, omega, perf)
      grad(1) = -(mu - perf)
      CALL SVVX (n, omega, omega0, NEGONE, dwork(pdw))
      CALL XV(n, dwork(pdw), dwork(pdw), scal)
      grad(2)= -(scal - delta*delta)
      RETURN
      END


module test_varn
  use, intrinsic :: ieee_arithmetic, only: ieee_is_nan
  use stdlib_kinds, only: sp, dp, int32
  use stdlib_stats, only: var
  use testdrive, only: new_unittest, unittest_type, error_type, check
  implicit none

  private
  public :: collect_varn, initialize_test_data

  real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
  real(dp), parameter :: dptol = 1000 * epsilon(1._dp)

  integer(int32) :: i321(5) = [1, 2, 3, 4, 5]

  integer(int32), allocatable :: i32(:,:), i323(:,:,:)

  real(sp) :: s1(5) = [1._sp, 2._sp, 3._sp, 4._sp, 5._sp]
  real(dp) :: d1(5) = [1._dp, 2._dp, 3._dp, 4._dp, 5._dp]

  real(sp), allocatable :: s(:,:), s3(:,:,:)
  real(dp), allocatable :: d3(:,:,:)
  real(dp) :: d(4,3) = reshape([1._dp, 3._dp, 5._dp, 7._dp, &
                                2._dp, 4._dp, 6._dp, 8._dp, &
                                9._dp, 10._dp, 11._dp, 12._dp], [4, 3])

  complex(dp) :: cd1(5) = [(0.57706_dp, 0.00000_dp), &
                           (0.00000_dp, 1.44065_dp), &
                           (1.26401_dp, 0.00000_dp), &
                           (0.00000_dp, 0.88833_dp), &
                           (1.14352_dp, 0.00000_dp)]
  complex(dp) :: cd(5,3)

contains

  subroutine initialize_test_data()

    s = d
    i32 = d

    allocate(s3(size(s, 1),size(s, 2),3))
    s3(:,:,1) = s
    s3(:,:,2) = s * 2
    s3(:,:,3) = s * 4

    allocate(d3(size(d, 1),size(d, 2),3))
    d3(:,:,1) = d
    d3(:,:,2) = d * 2
    d3(:,:,3) = d * 4

    allocate(i323(size(i32, 1),size(i32, 2),3))
    i323(:,:,1) = i32
    i323(:,:,2) = i32 * 2
    i323(:,:,3) = i32 * 4

    cd(:,1) = cd1
    cd(:,2) = cd1 * 3_sp
    cd(:,3) = cd1 * 1.5_sp

  end subroutine initialize_test_data

  !> Collect all exported unit tests
  subroutine collect_varn(testsuite)
    !> Collection of tests
    type(unittest_type), allocatable, intent(out) :: testsuite(:)

    testsuite = [ &
      new_unittest('varn_sp_1dim', test_sp_1dim), &
      new_unittest('varn_sp_1dim_mask', test_sp_1dim_mask), &
      new_unittest('varn_sp_1dim_mask_array', test_sp_1dim_mask_array), &
      new_unittest('varn_sp_2dim', test_sp_2dim), &
      new_unittest('varn_sp_2dim_mask', test_sp_2dim_mask), &
      new_unittest('varn_sp_2dim_mask_array', test_sp_2dim_mask_array), &
      new_unittest('varn_sp_3dim', test_sp_3dim), &
      new_unittest('varn_sp_3dim_mask', test_sp_3dim_mask), &
      new_unittest('varn_sp_3dim_mask_array', test_sp_3dim_mask_array), &
      new_unittest('varn_dp_1dim', test_dp_1dim), &
      new_unittest('varn_dp_1dim_mask', test_dp_1dim_mask), &
      new_unittest('varn_dp_1dim_mask_array', test_dp_1dim_mask_array), &
      new_unittest('varn_dp_2dim', test_dp_2dim), &
      new_unittest('varn_dp_2dim_mask', test_dp_2dim_mask), &
      new_unittest('varn_dp_2dim_mask_array', test_dp_2dim_mask_array), &
      new_unittest('varn_dp_3dim', test_dp_3dim), &
      new_unittest('varn_dp_3dim_mask', test_dp_3dim_mask), &
      new_unittest('varn_dp_3dim_mask_array', test_dp_3dim_mask_array), &
      new_unittest('varn_int32_1dim', test_int32_1dim), &
      new_unittest('varn_int32_1dim_mask', test_int32_1dim_mask), &
      new_unittest('varn_int32_1dim_mask_array', test_int32_1dim_mask_array), &
      new_unittest('varn_int32_2dim', test_int32_2dim), &
      new_unittest('varn_int32_2dim_mask', test_int32_2dim_mask), &
      new_unittest('varn_int32_2dim_mask_array', test_int32_2dim_mask_array), &
      new_unittest('varn_int32_3dim', test_int32_3dim), &
      new_unittest('varn_int32_3dim_mask', test_int32_3dim_mask), &
      new_unittest('varn_int32_3dim_mask_array', test_int32_3dim_mask_array), &
      new_unittest('varn_cdp_1dim', test_cdp_1dim), &
      new_unittest('varn_cdp_1dim_mask', test_cdp_1dim_mask), &
      new_unittest('varn_cdp_1dim_mask_array', test_cdp_1dim_mask_array), &
      new_unittest('varn_cdp_2dim', test_cdp_2dim), &
      new_unittest('varn_cdp_2dim_mask', test_cdp_2dim_mask), &
      new_unittest('varn_cdp_2dim_mask_array', test_cdp_2dim_mask_array) &
    ]

  end

  subroutine test_sp_1dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(s1, corrected=.false.) - 2.5*(4./5.)) < sptol)
    call check(error, abs(var(s1, dim=1, corrected=.false.) - 2.5*(4./5.)) < sptol)
  end

  subroutine test_sp_1dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(s1, .false., corrected=.false.)))
    call check(error, ieee_is_nan(var(s1, 1, .false., corrected=.false.)))
  end

  subroutine test_sp_1dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(s1, s1 < 5, corrected=.false.) - 5./4.) < sptol)
    call check(error, ieee_is_nan((var(s1, s1 < 0., corrected=.false.))))
    call check(error, abs(var(s1, s1 == 1., corrected=.false.)) < sptol)
    call check(error, abs(var(s1, 1, s1 < 5, corrected=.false.) - 5./4.) < sptol)
  end

  subroutine test_sp_2dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(s, corrected=.false.) - 13.*11./12.) < sptol)
    call check(error, all(abs(var(s, 1, corrected=.false.) &
                              - [20., 20., 5.]/4.) < sptol))
    call check(error, all(abs(var(s, 2, corrected=.false.) &
                              - [19., 43./3., 31./ 3., 7.0]*2./3.) < sptol))
  end

  subroutine test_sp_2dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(s, .false., corrected=.false.)))
    call check(error, any(ieee_is_nan(var(s, 1, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(s, 2, .false., corrected=.false.))))
  end

  subroutine test_sp_2dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(s, s < 11, corrected=.false.) - 2.75*3.) < sptol)
    call check(error, all(abs(var(s, 1, s < 11, corrected=.false.) &
                              - [5., 5., 0.25]) < sptol))
    call check(error, all(abs(var(s, 2, s < 11, corrected=.false.) &
                              - [19.0*2./3., 43./9.*2., 0.25 , 0.25]) < sptol))
  end

  subroutine test_sp_3dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(s3, corrected=.false.) - 153.4*35./36.) < sptol)
    call check(error, all(abs(var(s3, 1, corrected=.false.) -&
                 reshape([20. / 3., 20. / 3., 5. / 3.,&
                          4* 20. / 3., 4* 20. / 3., 4* 5. / 3.,&
                          16* 20. / 3., 16* 20. / 3., 16* 5. / 3.],&
                          [size(s3, 2), size(s3, 3)])*3./4.)&
                 < sptol))
    call check(error, all(abs(var(s3, 2, corrected=.false.) -&
                 reshape([19.0, 43. / 3., 31. / 3. , 7.0,&
                          4* 19.0, 4* 43. / 3., 4* 31. / 3. , 4* 7.0,&
                          16* 19.0, 16* 43. / 3., 16* 31. / 3. , 16* 7.0],&
                          [size(s3, 1), size(s3, 3)])*2./3.)&
                 < sptol))
    call check(error, all(abs(var(s3, 3, corrected=.false.) -&
                 reshape([ 7./3., 21., 175./3.,&
                           343./3., 28./3., 112./3.,&
                           84., 448./3., 189.,&
                           700./3., 847./3., 336.], [size(s3,1), size(s3,2)] )*2./3.)&
                 < sptol))
  end

  subroutine test_sp_3dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(s3, .false., corrected=.false.)))
    call check(error, any(ieee_is_nan(var(s3, 1, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(s3, 2, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(s3, 3, .false., corrected=.false.))))
  end

  subroutine test_sp_3dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(s3, s3 < 11, corrected=.false.) - 7.73702383_sp) < sptol)
    call check(error, all( abs( var(s3, 1, s3 < 45, corrected=.false.) -&
                  reshape([5., 5., 1.25,  20., 20., 5., 80., 80., 32./3.],&
                  [size(s3, 2), size(s3, 3)])) < sptol ))
    call check(error, all( abs( var(s3, 2, s3 < 45, corrected=.false.) -&
                  reshape([ 38./3., 86./9., 6.88888931, 14./3., 152./3.,&
                            38.2222214, 27.5555573, 18.6666660, 202.666672,&
                            152.888885, 110.222229, 4.&
                           ],&
                  [size(s3, 1), size(s3, 3)])) < sptol ))
    call check(error, all( abs( var(s3, 3, s3 < 45, corrected=.false.) -&
                 reshape([1.555555, 14., 38.888888, 76.222222, 6.2222222,&
                          24.888888, 56., 99.5555, 126., 155.555555, 188.22222, 36.&
                           ], [size(s3,1), size(s3,2)] ))&
                 < sptol ))
  end

  subroutine test_dp_1dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(d1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
    call check(error, abs(var(d1, dim=1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
  end

  subroutine test_dp_1dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(d1, .false., corrected=.false.)))
    call check(error, ieee_is_nan(var(d1, 1, .false., corrected=.false.)))
  end

  subroutine test_dp_1dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(d1, d1 < 5, corrected=.false.) - 5._dp/4.) < dptol)
    call check(error, ieee_is_nan((var(d1, d1 < 0, corrected=.false.))))
    call check(error, abs(var(d1, d1 == 1, corrected=.false.)) < dptol)
    call check(error, abs(var(d1, 1, d1 < 5, corrected=.false.) - 5._dp/4.) < dptol)
  end

  subroutine test_dp_2dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(d, corrected=.false.) - 13._dp*11./12.) < dptol)
    call check(error, all( abs( var(d, 1, corrected=.false.) - [20., 20., 5.]/4._dp) < dptol))
    call check(error, all( abs( var(d, 2, corrected=.false.) -&
                      [38._dp, 86._dp / 3._dp, 62._dp / 3._dp , 14._dp]/3._dp) < dptol))
  end

  subroutine test_dp_2dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(d, .false., corrected=.false.)))
    call check(error, any(ieee_is_nan(var(d, 1, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(d, 2, .false., corrected=.false.))))
  end

  subroutine test_dp_2dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(d, d < 11, corrected=.false.) - 2.75_dp*3._dp) < dptol)
    call check(error, all( abs( var(d, 1, d < 11, corrected=.false.) -&
                      [5._dp, 5._dp, 0.25_dp]) < dptol))
    call check(error, all( abs( var(d, 2, d < 11, corrected=.false.) -&
                      [38._dp/3., 86._dp/9., 0.25_dp , 0.25_dp]) < dptol))
  end

  subroutine test_dp_3dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(d3, corrected=.false.) - 153.4_dp*35._dp/36._dp) < dptol)
    call check(error, all( abs( var(d3, 1, corrected=.false.) -&
                 reshape([20._dp , 20._dp , 5._dp ,&
                          4* 20._dp , 4* 20._dp , 4* 5._dp ,&
                          16* 20._dp , 16* 20._dp , 16* 5._dp ],&
                          [size(d3,2), size(d3,3)])/4._dp)&
                 < dptol))
    call check(error, all( abs( var(d3, 2, corrected=.false.) -&
                 reshape([38._dp, 86. / 3._dp, 62. / 3._dp , 14._dp,&
                          8* 19._dp, 8* 43. / 3._dp, 8* 31. / 3._dp, 8* 7._dp,&
                          32* 19._dp, 32* 43. / 3._dp, 32* 31. / 3._dp, 32* 7._dp],&
                          [size(d3,1), size(d3,3)] )/3._dp)&
                 < dptol))
    call check(error, all(abs( var(d3, 3, corrected=.false.) -&
                 reshape([7._dp/3., 21._dp, 175._dp/3.,&
                          343._dp/3., 28._dp/3., 112._dp/3.,&
                          84._dp, 448._dp/3., 189._dp,&
                          700._dp/3., 847._dp/3., 336._dp],&
                          [size(d3, 1), size(d3, 2)] )*2._dp/3._dp)&
                 < dptol))
  end

  subroutine test_dp_3dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(d3, .false., corrected=.false.)))
    call check(error, any(ieee_is_nan(var(d3, 1, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(d3, 2, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(d3, 3, .false., corrected=.false.))))
  end

  subroutine test_dp_3dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(d3, d3 < 11, corrected=.false.) -&
                     7.7370242214532876_dp) < dptol)
    call check(error, all(abs(var(d3, 1, d3 < 45, corrected=.false.) -&
                  reshape([5._dp, 5._dp, 1.25_dp,  20._dp, 20._dp, 5._dp,&
                           80._dp, 80._dp, 32._dp/3.],&
                           [size(d3, 2), size(d3, 3)])) < dptol))
    call check(error, all(abs( var(d3, 2, d3 < 45, corrected=.false.) -&
                  reshape([38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
                           344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
                           1376._dp/9., 992._dp/9., 4._dp&
                           ],&
                  [size(d3, 1), size(d3, 3)])) < dptol))
    call check(error, all(abs(var(d3, 3, d3 < 45, corrected=.false.) -&
                 reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
                          224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
                          1694._dp/9., 36._dp&
                           ], [size(d3, 1), size(d3, 2)]))&
                 < dptol ))
  end

  subroutine test_int32_1dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(i321, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
    call check(error, abs(var(i321, dim=1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
  end

  subroutine test_int32_1dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(i321, .false., corrected=.false.)))
    call check(error, ieee_is_nan(var(i321, 1, .false., corrected=.false.)))
  end

  subroutine test_int32_1dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(i321, i321 < 5, corrected=.false.) - 5._dp/4.) < dptol)
    call check(error, ieee_is_nan((var(i321, i321 < 0, corrected=.false.))))
    call check(error, abs(var(i321, i321 == 1, corrected=.false.)) < dptol)
    call check(error, abs(var(i321, 1, i321 < 5, corrected=.false.) - 5._dp/4.) < dptol)
  end

  subroutine test_int32_2dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(i32, corrected=.false.) - 13._dp*11./12.) < dptol)
    call check(error, all(abs(var(i32, 1, corrected=.false.) -&
                      [20., 20., 5.]/4._dp) < dptol))
    call check(error, all(abs(var(i32, 2, corrected=.false.) -&
                      [38._dp, 86._dp / 3._dp, 62._dp / 3._dp , 14._dp]/3._dp) < dptol))
  end

  subroutine test_int32_2dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(i32, .false., corrected=.false.)))
    call check(error, any(ieee_is_nan(var(i32, 1, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(i32, 2, .false., corrected=.false.))))
  end

  subroutine test_int32_2dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(i32, i32 < 11, corrected=.false.) - 2.75_dp*3._dp) < dptol)
    call check(error, all(abs(var(i32, 1, i32 < 11, corrected=.false.) -&
                      [5._dp, 5._dp, 0.25_dp]) < dptol))
    call check(error, all(abs(var(i32, 2, i32 < 11, corrected=.false.) -&
                      [38._dp/3., 86._dp/9., 0.25_dp , 0.25_dp]) < dptol))
  end

  subroutine test_int32_3dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(i323, corrected=.false.) - 153.4_dp*35._dp/36._dp) < dptol)
    call check(error, all(abs(var(i323, 1, corrected=.false.) -&
                 reshape([20._dp , 20._dp , 5._dp ,&
                          4* 20._dp , 4* 20._dp , 4* 5._dp ,&
                          16* 20._dp , 16* 20._dp , 16* 5._dp ],&
                          [size(i323,2), size(i323,3)])/4._dp)&
                 < dptol))
    call check(error, all(abs(var(i323, 2, corrected=.false.) -&
                 reshape([38._dp, 86. / 3._dp, 62. / 3._dp , 14._dp,&
                          8* 19._dp, 8* 43. / 3._dp, 8* 31. / 3._dp, 8* 7._dp,&
                          32* 19._dp, 32* 43. / 3._dp, 32* 31. / 3._dp, 32* 7._dp],&
                          [size(i323,1), size(i323,3)] )/3._dp)&
                 < dptol))
    call check(error, all(abs(var(i323, 3, corrected=.false.) -&
                 reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
                           343._dp/3., 28._dp/3., 112._dp/3.,&
                           84._dp, 448._dp/3., 189._dp,&
                           700._dp/3., 847._dp/3., 336._dp],&
                           [size(i323,1), size(i323,2)] )*2._dp/3._dp)&
                 < dptol))
  end

  subroutine test_int32_3dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(i323, .false., corrected=.false.)))
    call check(error, any(ieee_is_nan(var(i323, 1, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(i323, 2, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(i323, 3, .false., corrected=.false.))))
  end

  subroutine test_int32_3dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(i323, i323 < 11, corrected=.false.) -&
                     7.7370242214532876_dp) < dptol)
    call check(error, all(abs(var(i323, 1, i323 < 45, corrected=.false.) -&
                  reshape([5._dp, 5._dp, 1.25_dp,  20._dp, 20._dp, 5._dp,&
                           80._dp, 80._dp, 32._dp/3.],&
                           [size(i323, 2), size(i323, 3)])) < dptol ))
    call check(error, all(abs(var(i323, 2, i323 < 45, corrected=.false.) -&
                  reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
                            344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
                            1376._dp/9., 992._dp/9., 4._dp&
                           ],&
                  [size(i323, 1), size(i323, 3)])) < dptol ))
    call check(error, all(abs(var(i323, 3, i323 < 45, corrected=.false.) -&
                 reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
                          224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
                          1694._dp/9., 36._dp&
                           ], [size(i323,1), size(i323,2)] ))&
                 < dptol ))
  end

  subroutine test_cdp_1dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(cd1, corrected=.false.) -&
                 (var(real(cd1), corrected=.false.) +&
                  var(aimag(cd1), corrected=.false.))) < dptol)
    call check(error, abs(var(cd1, dim=1, corrected=.false.) -&
                 (var(real(cd1), dim=1, corrected=.false.) +&
                  var(aimag(cd1), dim=1, corrected=.false.))) < dptol)
  end

  subroutine test_cdp_1dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(cd1, .false., corrected=.false.)))
    call check(error, ieee_is_nan(var(cd1, 1, .false., corrected=.false.)))
  end

  subroutine test_cdp_1dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(cd1, cd1%im == 0, corrected=.false.) &
                          - var(cd1%re, cd1%im == 0, corrected=.false.)) < dptol)
    call check(error, abs(var(cd1, 1, cd1%im == 0, corrected=.false.) &
                          - var(cd1%re, 1, cd1%im == 0, corrected=.false.)) < dptol)
    call check(error, ieee_is_nan((var(cd1, all([cd1%re, cd1%im] == 0), &
                                       corrected=.false.))))
    call check(error, abs(var(cd1, (cd1%re > 1.2 .and. cd1%im == 0), &
                              corrected=.false.)) < dptol)
  end

  subroutine test_cdp_2dim(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(cd, corrected=.false.) &
                          - (var(cd%re, corrected=.false.) &
                          + var(cd%im, corrected=.false.))) < dptol)
    call check(error, all(abs(var(cd, 1, corrected=.false.) &
                          - (var(cd%re, 1, corrected=.false.) &
                          + var(cd%im, 1, corrected=.false.))) < dptol))
    call check(error, all(abs(var(cd, 2, corrected=.false.) &
                          - (var(cd%re, 2, corrected=.false.) &
                          + var(cd%im, 2, corrected=.false.))) < dptol))
  end

  subroutine test_cdp_2dim_mask(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, ieee_is_nan(var(cd, .false., corrected=.false.)))
    call check(error, any(ieee_is_nan(var(cd, 1, .false., corrected=.false.))))
    call check(error, any(ieee_is_nan(var(cd, 2, .false., corrected=.false.))))
  end

  subroutine test_cdp_2dim_mask_array(error)
    !> Error handling
    type(error_type), allocatable, intent(out) :: error
    call check(error, abs(var(cd, cd%im == 0, corrected=.false.) &
                          - var(cd%re, cd%im == 0, corrected=.false.)) < dptol)
    call check(error, all(abs(var(cd, 1, cd%im == 0, corrected=.false.) &
                          - var(cd%re, 1, cd%im == 0, corrected=.false.)) < dptol))
    call check(error, any(ieee_is_nan(var(cd, 2, cd%im == 0, corrected=.false.))))
  end

end module test_varn

program tester
  use, intrinsic :: iso_fortran_env, only: error_unit
  use testdrive, only: run_testsuite, new_testsuite, testsuite_type
  use test_varn, only: collect_varn, initialize_test_data
  implicit none
  integer :: stat, is
  type(testsuite_type), allocatable :: testsuites(:)
  character(len=*), parameter :: fmt = '("#", *(1x, a))'

  stat = 0

  testsuites = [ &
    new_testsuite('varn', collect_varn) &
  ]

  call initialize_test_data()

  do is = 1, size(testsuites)
    write(error_unit, fmt) "Testing:", testsuites(is)%name
    call run_testsuite(testsuites(is)%collect, error_unit, stat)
  end do

  if (stat > 0) then
    write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
    error stop
  end if

end program tester


c**********************************************************************
c   twod.f - a solution to the Poisson problem by using Jacobi
c   interation on a 2-d decomposition
c
c   .... the rest of this is from pi3.f to show the style ...
c
c   Each node:
c    1) receives the number of rectangles used in the approximation.
c    2) calculates the areas of it's rectangles.
c    3) Synchronizes for a global summation.
c   Node 0 prints the result.
c
c  Variables:
c
c    pi  the calculated result
c    n   number of points of integration.
c    x           midpoint of each rectangle's interval
c    f           function to integrate
c    sum,pi      area of rectangles
c    tmp         temporary scratch space for global summation
c    i           do loop index
c
c     This code is included (without the prints) because one version of
c     MPICH SEGV'ed (probably because of errors in handling send/recv of
c     MPI_PROC_NULL source/destination).
c
c****************************************************************************
      program main
      include "mpif.h"
      integer maxn
      parameter (maxn = 128)
      double precision  a(maxn,maxn), b(maxn,maxn), f(maxn,maxn)
      integer nx, ny
      integer myid, numprocs, it, rc, comm2d, ierr, stride
      integer nbrleft, nbrright, nbrtop, nbrbottom
      integer sx, ex, sy, ey
      integer dims(2)
      logical periods(2)
      double precision diff2d, diffnorm, dwork
      double precision t1, t2
      external diff2d
      data periods/2*.false./

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
c      print *, "Process ", myid, " of ", numprocs, " is alive"
      if (myid .eq. 0) then
c
c         Get the size of the problem
c
c          print *, 'Enter nx'
c          read *, nx
           nx = 10
      endif
c      print *, 'About to do bcast on ', myid
      call MPI_BCAST(nx,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
      ny   = nx
c
c Get a new communicator for a decomposition of the domain.  Let MPI
c find a "good" decomposition
c
      dims(1) = 0
      dims(2) = 0
      call MPI_DIMS_CREATE( numprocs, 2, dims, ierr )
      call MPI_CART_CREATE( MPI_COMM_WORLD, 2, dims, periods, .true.,
     *                    comm2d, ierr )
c
c Get my position in this communicator
c
      call MPI_COMM_RANK( comm2d, myid, ierr )
c      print *, "Process ", myid, " of ", numprocs, " is alive"
c
c My neighbors are now +/- 1 with my rank.  Handle the case of the
c boundaries by using MPI_PROCNULL.
      call fnd2dnbrs( comm2d, nbrleft, nbrright, nbrtop, nbrbottom )
c      print *, "Process ", myid, ":",
c     *     nbrleft, nbrright, nbrtop, nbrbottom
c
c Compute the decomposition
c
      call fnd2ddecomp( comm2d, nx, sx, ex, sy, ey )
c      print *, "Process ", myid, ":", sx, ex, sy, ey
c
c Create a new, "strided" datatype for the exchange in the "non-contiguous"
c direction
c
      call mpi_Type_vector( ey-sy+1, 1, ex-sx+3,
     $                      MPI_DOUBLE_PRECISION, stride, ierr )
      call mpi_Type_commit( stride, ierr )
c
c
c Initialize the right-hand-side (f) and the initial solution guess (a)
c
      call twodinit( a, b, f, nx, sx, ex, sy, ey )
c
c Actually do the computation.  Note the use of a collective operation to
c check for convergence, and a do-loop to bound the number of iterations.
c
      call MPI_BARRIER( MPI_COMM_WORLD, ierr )
      t1 = MPI_WTIME()
      do 10 it=1, 100
	call exchng2( b, sx, ex, sy, ey, comm2d, stride,
     $                nbrleft, nbrright, nbrtop, nbrbottom )
	call sweep2d( b, f, nx, sx, ex, sy, ey, a )
	call exchng2( a, sx, ex, sy, ey, comm2d, stride,
     $                nbrleft, nbrright, nbrtop, nbrbottom )
	call sweep2d( a, f, nx, sx, ex, sy, ey, b )
	dwork = diff2d( a, b, nx, sx, ex, sy, ey )
	call MPI_Allreduce( dwork, diffnorm, 1, MPI_DOUBLE_PRECISION,
     $                     MPI_SUM, comm2d, ierr )
        if (diffnorm .lt. 1.0e-5) goto 20
        if (myid .eq. 0) print *, 2*it, ' Difference is ', diffnorm
10     continue
      if (myid .eq. 0) print *, 'Failed to converge'
20    continue
      t2 = MPI_WTIME()
c      if (myid .eq. 0) then
c         print *, 'Converged after ', 2*it, ' Iterations in ', t2 - t1,
c     $        ' secs '
c      endif
c
c
      call MPI_Type_free( stride, ierr )
      call MPI_Comm_free( comm2d, ierr )
      call MPI_FINALIZE(rc)
      end
c
c Perform a Jacobi sweep for a 2-d decomposition
c
      subroutine sweep2d( a, f, n, sx, ex, sy, ey, b )
      integer n, sx, ex, sy, ey
      double precision a(sx-1:ex+1, sy-1:ey+1), f(sx-1:ex+1, sy-1:ey+1),
     +                 b(sx-1:ex+1, sy-1:ey+1)
c
      integer i, j
      double precision h
c
      h = 1.0d0 / dble(n+1)
      do 10 j=sy, ey
         do 10 i=sx, ex
            b(i,j) = 0.25 * (a(i-1,j)+a(i,j+1)+a(i,j-1)+a(i+1,j)) -
     +               h * h * f(i,j)
 10   continue
      return
      end
c
       subroutine exchng2( a, sx, ex, sy, ey,
     $                     comm2d, stride,
     $                     nbrleft, nbrright, nbrtop, nbrbottom  )
       include "mpif.h"
       integer sx, ex, sy, ey, stride
       double precision a(sx-1:ex+1, sy-1:ey+1)
       integer nbrleft, nbrright, nbrtop, nbrbottom, comm2d
       integer status(MPI_STATUS_SIZE), ierr, nx
c
       nx = ex - sx + 1
c  These are just like the 1-d versions, except for less data
	call MPI_SENDRECV( a(sx,ey),  nx, MPI_DOUBLE_PRECISION,
     $ 	                  nbrtop, 0,
     $                    a(sx,sy-1), nx, MPI_DOUBLE_PRECISION,
     $                    nbrbottom, 0, comm2d, status, ierr )
	call MPI_SENDRECV( a(sx,sy),  nx, MPI_DOUBLE_PRECISION,
     $                    nbrbottom, 1,
     $                    a(sx,ey+1), nx, MPI_DOUBLE_PRECISION,
     $                    nbrtop, 1, comm2d, status, ierr )
c
c This uses the "strided" datatype
	call MPI_SENDRECV( a(ex,sy),  1, stride, nbrright,  0,
     $                     a(sx-1,sy), 1, stride, nbrleft,  0,
     $                     comm2d, status, ierr )
	call MPI_SENDRECV( a(sx,sy),  1, stride, nbrleft,   1,
     $                     a(ex+1,sy), 1, stride, nbrright, 1,
     $                     comm2d, status, ierr )
	return
	end

c
c  The rest of the 2-d program
c
      double precision function diff2d( a, b, nx, sx, ex, sy, ey )
      integer nx, sx, ex, sy, ey
      double precision a(sx-1:ex+1, sy-1:ey+1), b(sx-1:ex+1, sy-1:ey+1)
c
      double precision sum
      integer i, j
c
      sum = 0.0d0
      do 10 j=sy,ey
         do 10 i=sx,ex
            sum = sum + (a(i,j) - b(i,j)) ** 2
 10      continue
c
      diff2d = sum
      return
      end
      subroutine twodinit( a, b, f, nx, sx, ex, sy, ey )
      integer nx, sx, ex, sy, ey
      double precision a(sx-1:ex+1, sy-1:ey+1), b(sx-1:ex+1, sy-1:ey+1),
     &                 f(sx-1:ex+1, sy-1:ey+1)
c
      integer i, j
c
      do 10 j=sy-1,ey+1
         do 10 i=sx-1,ex+1
            a(i,j) = 0.0d0
            b(i,j) = 0.0d0
            f(i,j) = 0.0d0
 10      continue
c
c    Handle boundary conditions
c
      if (sx .eq. 1) then
         do 20 j=sy,ey
            a(0,j) = 1.0d0
            b(0,j) = 1.0d0
 20      continue
      endif
      if (ex .eq. nx) then
         do 21 j=sy,ey
            a(nx+1,j) = 0.0d0
            b(nx+1,j) = 0.0d0
 21      continue
      endif
      if (sy .eq. 1) then
         do 30 i=sx,ex
            a(i,0) = 1.0d0
            b(i,0) = 1.0d0
 30      continue
      endif
c
      return
      end

c
c  This file contains a routine for producing a decomposition of a 1-d array
c  when given a number of processors.  It may be used in "direct" product
c  decomposition.  The values returned assume a "global" domain in [1:n]
c
      subroutine MPE_DECOMP1D( n, numprocs, myid, s, e )
      integer n, numprocs, myid, s, e
      integer nlocal
      integer deficit
c
      nlocal  = n / numprocs
      s	      = myid * nlocal + 1
      deficit = mod(n,numprocs)
      s	      = s + min(myid,deficit)
      if (myid .lt. deficit) then
          nlocal = nlocal + 1
      endif
      e = s + nlocal - 1
      if (e .gt. n .or. myid .eq. numprocs-1) e = n
      return
      end
c
c This routine show how to determine the neighbors in a 2-d decomposition of
c the domain. This assumes that MPI_Cart_create has already been called
c
      subroutine fnd2dnbrs( comm2d,
     $                      nbrleft, nbrright, nbrtop, nbrbottom )
      integer comm2d, nbrleft, nbrright, nbrtop, nbrbottom
c
      integer ierr
c
      call MPI_Cart_shift( comm2d, 0,  1, nbrleft,   nbrright, ierr )
      call MPI_Cart_shift( comm2d, 1,  1, nbrbottom, nbrtop,   ierr )
c
      return
      end
c
c Note: THIS IS A TEST PROGRAM.  THE ACTUAL VALUES MOVED ARE NOT
c CORRECT FOR A POISSON SOLVER.
c
      subroutine fnd2ddecomp( comm2d, n, sx, ex, sy, ey )
      integer comm2d
      integer n, sx, ex, sy, ey
      integer dims(2), coords(2), ierr
      logical periods(2)
c
      call MPI_Cart_get( comm2d, 2, dims, periods, coords, ierr )

      call MPE_DECOMP1D( n, dims(1), coords(1), sx, ex )
      call MPE_DECOMP1D( n, dims(2), coords(2), sy, ey )
c
      return
      end


! Forran program to show format specifications for read
! print statements

program formats
    implicit none

    integer :: a
    real :: ar, br
    CHARACTER*10 :: ac

    !read 5, a, ar, br
    read '(i6, f8.3, e12.5)', a, ar, br
    read '(A40)', ac
    !5 format(i6,f8.3)

    10 format("with formatting", i5, 4X, f6.2, 4X, e13.6)

    print 10, a, ar, br
    print*, "Without formatting", a, ar, br
    print '(A10)', ac

end program formats


      subroutine evolve_eqipsi(n_a1,n_alpha,n_beta,n_iPHI,n_iPI,n_ipsi,n
     &p1_a1,np1_alpha,np1_beta,np1_iPHI,np1_iPI,np1_ipsi,x,Nx,ht,myzero,
     &zepsdis,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 myzero
      real*8 zepsdis
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_iPHI(Nx)
      real*8 n_iPI(Nx)
      real*8 n_ipsi(Nx)
      real*8 np1_a1(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_iPHI(Nx)
      real*8 np1_iPI(Nx)
      real*8 np1_ipsi(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = 0.1333333333333333D1 * np1_ipsi(i + 1) - 0.3333333333333333D0
     # * np1_ipsi(i + 2)
      res(i)=qb
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = np1_ipsi(i) - 0.32D2 / (0.32D2 + 0.7D1 * zepsdis) * ht * ((-0
     #.1D1 * n_ipsi(i) + np1_ipsi(i)) / ht - 0.5000000000000000D0 * np1_
     #alpha(i) / np1_a1(i) * np1_iPI(i) - 0.5000000000000000D0 * np1_bet
     #a(i) * np1_iPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n_a1(i) *
     # n_iPI(i) - 0.5000000000000000D0 * n_beta(i) * n_iPHI(i) + 0.31250
     #00000000000D-1 * zepsdis / ht * (0.7D1 * np1_ipsi(i) + np1_ipsi(i
     #+ 2) - 0.4D1 * np1_ipsi(i + 1) - 0.4D1 * np1_ipsi(i - 1)) + 0.3125
     #000000000000D-1 * zepsdis / ht * (0.7D1 * n_ipsi(i) + n_ipsi(i + 2
     #) - 0.4D1 * n_ipsi(i + 1) - 0.4D1 * n_ipsi(i - 1)))
      res(i)=qb
      end do
      endif
      do i=3, Nx-2, 1
      qb = np1_ipsi(i) - 0.16D2 / (0.16D2 + 0.3D1 * zepsdis) * ht * ((-0
     #.1D1 * n_ipsi(i) + np1_ipsi(i)) / ht - 0.5000000000000000D0 * np1_
     #alpha(i) / np1_a1(i) * np1_iPI(i) - 0.5000000000000000D0 * np1_bet
     #a(i) * np1_iPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n_a1(i) *
     # n_iPI(i) - 0.5000000000000000D0 * n_beta(i) * n_iPHI(i) + 0.31250
     #00000000000D-1 * zepsdis / ht * (0.6D1 * np1_ipsi(i) + np1_ipsi(i
     #+ 2) + np1_ipsi(i - 2) - 0.4D1 * np1_ipsi(i + 1) - 0.4D1 * np1_ips
     #i(i - 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.6D1 * n_ipsi
     #(i) + n_ipsi(i + 2) + n_ipsi(i - 2) - 0.4D1 * n_ipsi(i + 1) - 0.4D
     #1 * n_ipsi(i - 1)))
      res(i)=qb
      end do
      do i=Nx-1, Nx-1, 1
      qb = np1_ipsi(i) - 0.1D1 * ht * ((-0.1D1 * n_ipsi(i) + np1_ipsi(i)
     #) / ht - 0.5000000000000000D0 * np1_alpha(i) / np1_a1(i) * np1_iPI
     #(i) - 0.5000000000000000D0 * np1_beta(i) * np1_iPHI(i) - 0.5000000
     #000000000D0 * n_alpha(i) / n_a1(i) * n_iPI(i) - 0.5000000000000000
     #D0 * n_beta(i) * n_iPHI(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_ipsi(i) - 0.1D1 * ht * ((-0.1D1 * n_ipsi(i) + np1_ipsi(i)
     #) / ht - 0.1D1 * myzero * x(i))
      res(i)=qb
      end do
      endif
      END


program hmipt_2dsquare
  !########################################################
  !     Program  : HMIPT
  !     TYPE     : Main program
  !     PURPOSE  : Solve the Hubbard model using DMFT-IPT
  !     AUTHORS  : Adriano Amaricci
  !########################################################
  !LOCAL:
  USE DMFT_IPT
  USE SQUARE_LATTICE
  USE IOTOOLS
  implicit none

  logical                :: converged
  real(8)                :: n
  integer                :: i,Lk,iloop
  complex(8)             :: zeta
  complex(8),allocatable :: sigma(:),fg(:),fg0(:)
  real(8),allocatable    :: wr(:),wt(:),epsik(:),nk(:)

  call read_input("inputIPT.in")
  !allocate functions:
  allocate(fg(L))
  allocate(sigma(L))
  allocate(fg0(L))
  allocate(wr(L))

  !build freq. array
  wr = linspace(-wmax,wmax,L,mesh=fmesh)

  !build square lattice structure:
  Lk   = square_lattice_dimension(Nx)
  allocate(wt(Lk),epsik(Lk),nk(Lk))
  wt   = square_lattice_structure(Lk,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)

  !dmft loop:
  n=0.5d0
  sigma=u*(n-0.5d0) ; iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     do i=1,L
        zeta = cmplx(wr(i)+xmu,eps) - sigma(i)
        fg(i) = sum_overk_zeta(zeta,epsik,wt)
     enddo
     n   = sum(aimag(fg)*fermi(wr,beta))/sum(aimag(fg))
     fg0 = one/(one/fg + sigma - U*(n-0.5d0))
     sigma= solve_ipt_sopt(fg0,wr) + U*(n-0.5d0)
     converged=check_convergence(sigma,eps_error,nsuccess,nloop)
     call splot("nVSiloop.ipt",iloop,n,append=TT)
  enddo
  call close_file("nVSiloop.ipt")
  call splot("DOS.ipt",wr,-aimag(fg)/pi,append=printf)
  call splot("G_realw.ipt",wr,fg,append=printf)
  call splot("G0_realw.ipt",wr,fg0,append=printf)
  call splot("Sigma_realw.ipt",wr,sigma,append=printf)
  nk = square_lattice_momentum_distribution(Lk)
  call splot("nkVSepsk.ipt",epsik,nk,append=printf)

contains

  function square_lattice_momentum_distribution(Lk) result(nk)
    integer            :: Lk
    integer,parameter  :: M=1024
    integer            :: ik,i
    type(matsubara_gf) :: gm,sm
    real(8)            :: nk(Lk),wm(M),w
    call allocate_gf(gm,M)
    call allocate_gf(sm,M)
    wm   = pi/beta*real(2*arange(1,M)-1,8)
    call get_matsubara_gf_from_DOS(wr,sigma,sm%iw,beta)
    do ik=1,Lk
       gm%iw=one/(xi*wm - epsik(ik) - sm%iw)
       call fftgf_iw2tau(gm%iw,gm%tau,beta)
       nk(ik)=-gm%tau(M)
    enddo
  end function square_lattice_momentum_distribution

end program hmipt_2dsquare