PROGRAM MAIN
    USE ISO_FORTRAN_ENV, ONLY : output_unit,real64
    IMPLICIT NONE
    REAL*8, ALLOCATABLE :: var(:,:,:), tmp(:,:,:)
    INTEGER ::  nx,ny,nz,nt
    REAL( real64) :: ct_one, ct_two, ct_three
    REAL( real64) :: elapsed_time, loop_time, init_time
    INTEGER :: i,j,k,n, nq
    CALL cpu_time( time= ct_one)
    !////////////////////////////////////////////////////
    ! Set some default values for the problem parameters.
    nx = 256   ! x-dimension of our 3-D array
    ny = 256   ! y-dimension of our 3-D array
    nz = 256   ! z-dimension of our 3-D array
    nt = 100   ! number of time steps to integrate over
    nq = 4     ! The number of OpenACC queues to employ

    !////////////////////////////////////////////////////
    ! Check to see if the user has specified anything
    ! different at the command line.
    ! Command line calling syntax:
    ! ./ex5.gpu -nx 256 -ny 256 -nz 256 -nt 100 -nq 4
    CALL grab_args(nx,ny,nz,nt,nq)

    WRITE(output_unit,'(a)') ' ///////////////////////////'
    WRITE(output_unit,'(a)') '  3-D Diffusion Equation   '
    WRITE(output_unit,'(a)') '  --Problem Parameters-- '
    WRITE(output_unit,'(a,i0)')'   nx =', nx
    WRITE(output_unit,'(a,i0)')'   ny =', ny
    WRITE(output_unit,'(a,i0)')'   nz =', nz
    WRITE(output_unit,'(a,i0)')'   nt =', nt
    WRITE(output_unit,'(a,i0)')'   nq =', nq
    WRITE(output_unit,'(a)') ' ///////////////////////////'
    WRITE(output_unit,'(a)') ' '
    !/////////////////////////////////////////////////////
    ! Initialize var and the work array
    ALLOCATE(var(1:nx,1:ny,1:nz))
    ALLOCATE(tmp(1:nx,1:ny,1:nz))

    var(:,:,:) = 0.0d0
    tmp(:,:,:)   = 0.0d0
    CALL INIT_ARR(var, 1.0d0, 2, 2, 2) ! single sine wave in each dimension

    ! Create an initial copy of var and tmp on the GPU
    !$ACC enter data copyin(var, tmp)
    !/////////////////////////////////////////////////////
    ! Evolve the system:
    CALL cpu_time( time= ct_two)
    DO n = 1, nt

        IF (MOD(n,10) .eq. 0) Write(output_unit,'(a,i5)')' Timestep: ',n
        CALL Laplacian(var,tmp,nq)

        !/////////////////////////////////////
        ! This piece is carried out on the CPU
        CALL GHOST_ZONE_COMM(var)

    ENDDO

    CALL cpu_time( time= ct_three)
    ! At the end, copy out the entire var array and delete var & tmp on the GPU
    !$ACC exit data copyout(var) delete(var,tmp)

    Write(output_unit,*) var(8,8,8), var(nx-8,ny-8,nz-8)

    elapsed_time = ct_three-ct_one
    init_time = ct_two-ct_one
    loop_time = ct_three-ct_two
    WRITE(output_unit,'(a)')' Complete!'
    WRITE(output_unit,'( a, ES14.4, a)')'         Elapsed time: ', elapsed_time, ' seconds.'
    WRITE(output_unit, fmt= '( a, ES14.4, a)') '  Initialization time: ', init_time, ' seconds.'
    WRITE(output_unit, fmt= '( a, ES14.4, a)') '            Loop time: ', loop_time, ' seconds.'

CONTAINS

    SUBROUTINE Laplacian(arrin, work,numq)
        IMPLICIT NONE
        REAL*8, INTENT(InOut) :: arrin(:,:,:)
        REAL*8, INTENT(InOut) :: work(:,:,:)
        Real*8 :: one_sixth
        INTEGER :: dims(3), ni, nj, nk, queue
        INTEGER, INTENT(In) :: numq
        dims = shape(arrin)
        nk = dims(3)
        nj = dims(2)
        ni = dims(1)
        one_sixth = 1.0d0/6.0d0

        !///////////////////////////////////////////////////////////////
        ! Our strategy here is to overlap communication and computation
        ! on the GPU.  This is accomplished via the async directive
        ! The strategy is as follows:

        ! 1)  We copy over the z-boundaries before initiating coputation

        ! 2)  On each iteration in z-level k, we copy the necessary boundary
        !     values over to the GPU, and assign them one of the numq queues
        !     specified by the user.  We also assign the loop instructions for
        !     that k-value to the same queue.   We cycle through queues as we
        !     iterate through k.  The idea is that data transmission in queue 2
        !     can be performed while calculation in queue 1 is happening and so on.

        ! 3)  arrin cannot be updated until the work calculation is complete,
        !     and so we institute an ACC WAIT after the derivative loop.  This
        !     forces all processes (both CPU and GPU) to wait until

        ! 4)  Similar logic is applied to the arrin update loop.
        !     We invoke another ACC WAIT after the arrin update loop before pulling
        !     over the ghost-zone values needed for communication

        !$acc update device(var(1:nx,1:ny,1), var(1:nx,1:ny,nz))
        DO k = 2, nk-1
            queue = MOD(k,numq)+1

            !$acc  update device(var(nx,1:ny,k),var(1,1:ny,k), &
            !$acc    var(1:nx,1,k), var(1:nx,ny,k)) async(queue)

            !$acc parallel loop present(arrin,work) collapse(2) async(queue)
            DO j = 2, nj-1
                DO i = 2, ni-1
                    work(i,j,k) =  &
                            arrin(i-1,j,k) + arrin(i+1,j,k) + &
                            arrin(i,j-1,k) + arrin(i,j+1,k) + &
                            arrin(i,j,k-1) + arrin(i,j,k+1)
                ENDDO
            ENDDO
            !$acc end parallel loop
        ENDDO

        !$ACC WAIT

        DO k = 2, nk-1
            queue = MOD(k,numq)+1
            !$acc parallel loop present(arrin,work) collapse(2) async(queue)
            DO j = 2, nj-1
                DO i = 2, ni-1
                    arrin(i,j,k) = work(i,j,k)*one_sixth
                ENDDO
            ENDDO
            !$acc end parallel loop

            !$acc  update host(var(nx-1,1:ny,k),var(2,1:ny,k), &
            !$acc    var(1:nx,2,k), var(1:nx,ny-1,k)) async(queue)
        ENDDO
        !$ACC WAIT
        !$acc update host(var(1:nx,1:ny,2), var(1:nx,1:ny,nz-1))
    END SUBROUTINE Laplacian

    SUBROUTINE grab_args(numx, numy, numz, numiter, numq)
            IMPLICIT NONE

            INTEGER, INTENT(OUT)   :: numx
            INTEGER, INTENT(OUT)   :: numy
            INTEGER, INTENT(OUT)   :: numz
            INTEGER, INTENT(OUT)   :: numiter
            INTEGER, INTENT(INOUT) :: numq

            INTEGER :: n                    ! Number of command-line arguments
            INTEGER :: i
            CHARACTER(len=1024) :: argname  ! Argument key
            CHARACTER(len=1024) :: val      ! Argument value

            n = command_argument_count()
            DO i=1,n,2
                    CALL get_command_argument(i, argname)
                    CALL get_command_argument(i+1, val)
                    SELECT CASE(argname)
                            CASE('-nx')
                                    read(val, '(I8)') numx
                            CASE('-ny')
                                    read(val, '(I8)') numy
                            CASE('-nz')
                                    read(val, '(I8)') numz
                            CASE('-nt')
                                    read(val, '(I8)') numiter
                            CASE('-nq')
                                    read(val, '(I8)') numq
                            CASE DEFAULT
                                    WRITE(output_unit,'(a)') ' '
                                    WRITE(output_unit,'(a)') &
                                    ' Unrecognized option: '// trim(argname)
                    END SELECT
            ENDDO

    END SUBROUTINE grab_args

    SUBROUTINE GHOST_ZONE_COMM(arr)
        IMPLICIT NONE
        REAL*8, INTENT(INOUT) :: arr(:,:,:)
        INTEGER :: dims(3)
        INTEGER :: i, j, k
        INTEGER :: ni, nj, nk
        dims = shape(arr)
        ni = dims(1)
        nj = dims(2)
        nk = dims(3)
        ! This is where we would normally communicate boundary
        ! information.
        ! Rather than invoking MPI for this example,
        ! we simply copy the rightmost boundary to the leftmost boundary...

        DO k = 2, nk-1
            arr(1,:,k) = arr(ni-1,:,k)*0
            arr(:,1,k) = arr(:,nj-1,k)*0
            arr(ni,:,k) = arr(2,:,k)*0
            arr(:,nj,k) = arr(:,2,k)*0
        ENDDO
        arr(:,:,1) = arr(:,:,nk-1)*0
        arr(:,:,nk) = arr(:,:,2)*0

    END SUBROUTINE GHOST_ZONE_COMM

    SUBROUTINE INIT_ARR(arr, amp, orderx, ordery, orderz)
        IMPLICIT NONE
        REAL*8, INTENT(INOUT) :: arr(:,:,:)
        REAL*8, INTENT(IN) :: amp
        INTEGER, INTENT(IN) :: orderx, ordery, orderz
        REAL*8 :: sinkx, sinky, sinkz
        REAL*8 :: kx, ky, kz
        REAL*8, PARAMETER :: pi = 3.1415926535897932384626433832795028841972d0
        INTEGER :: i,j,k, dims(3), ni,nj,nk
        dims = shape(arr)
        nk = dims(3)
        nj = dims(2)
        ni = dims(1)

        kx = orderx*(pi/(ni-1))
        ky = ordery*(pi/(nj-1))
        kz = orderz*(pi/(nk-1))

        DO k = 1, nk
            sinkz = sin(kz*(k-1))
            DO j = 1, nj
                sinky = sin(ky*(j-1))
                DO i = 1, ni
                    sinkx = sin(kx*(i-1))
                    arr(i,j,k) = arr(i,j,k)+amp*sinkx*sinky*sinkz
                ENDDO
            ENDDO
        ENDDO
    END SUBROUTINE INIT_ARR

END PROGRAM MAIN


 INTEGER A, B
 PRINT *, 'Type in two integer numbers separated by white space',
+         ' and press ENTER'
 READ *, A, B
 PRINT *, '   A + B = ', (A + B)
 PRINT *, '   A - B = ', (A - B)
 PRINT *, '   A * B = ', (A * B)
 PRINT *, '   A / B = ', (A / B)
 PRINT *, 'MOD(A,B) = ', MOD(A,B)
 PRINT *
 PRINT *, 'Even though you did not ask, ',
+         'exponentiation is an intrinsic op in Fortran, so...'
 PRINT *, '  A ** B = ', (A ** B)
 END


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine exact( i, j, k, u000ijk )

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   compute the exact solution at (i,j,k)
c
c---------------------------------------------------------------------

      implicit none

      include 'applu.incl'

c---------------------------------------------------------------------
c  input parameters
c---------------------------------------------------------------------
      integer i, j, k
      double precision u000ijk(*)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer m
      double precision xi, eta, zeta

      xi  = ( dble ( i - 1 ) ) / ( nx0 - 1 )
      eta  = ( dble ( j - 1 ) ) / ( ny0 - 1 )
      zeta = ( dble ( k - 1 ) ) / ( nz - 1 )

      do m = 1, 5
         u000ijk(m) =  ce(m,1)
     >        + ce(m,2) * xi
     >        + ce(m,3) * eta
     >        + ce(m,4) * zeta
     >        + ce(m,5) * xi * xi
     >        + ce(m,6) * eta * eta
     >        + ce(m,7) * zeta * zeta
     >        + ce(m,8) * xi * xi * xi
     >        + ce(m,9) * eta * eta * eta
     >        + ce(m,10) * zeta * zeta * zeta
     >        + ce(m,11) * xi * xi * xi * xi
     >        + ce(m,12) * eta * eta * eta * eta
     >        + ce(m,13) * zeta * zeta * zeta * zeta
      end do

      return
      end


!TODO: Might need to normalize all angles
!Sufficiently test for accuracy

MODULE almagest
  IMPLICIT NONE

  REAL*8, PARAMETER :: PI  = ATAN(1.d0) * 4.d0
  REAL*8, PARAMETER :: RAD = (180.d0/PI)

CONTAINS
  !Valid for all Gregorian calendar dates after November 23, 4713 B.C.
  SUBROUTINE computeSolarTimeValues(m, d, y, hh, mm, ss, utc_offset, lon, sma, sml, ooe, LST, JDN)
    IMPLICIT NONE

    REAL*8,  INTENT(IN)  :: lon
    INTEGER, INTENT(IN)  :: m, d, y, hh, mm, ss, utc_offset
    REAL*8,  INTENT(OUT) :: sma, sml, ooe, LST, JDN

    INTEGER :: UT
    REAL*8  :: lo, ma

    !Initial time values
    UT = (hh-utc_offset) + (mm/60) + (ss/3600)
    JDN = REAL((367*Y - 7*(Y+(M+9)/12)/4 - 3*((Y+(M-9)/7)/100 + 1)/4 + 275*M/9 + D-730515) + UT/24)

    !Solar values
    lo  = 282.9404d0 + 4.70935E-5     * JDN !Longitude of the perihelion
    ma  = 356.0470d0 + 0.9856002585d0 * JDN !Mean anomaly
    ooe = 23.4393d0  - 3.563E-7       * JDN !Obliquity of the Ecliptic

    sma = normAng(ma)     !Normalized mean anomaly; might need to be normalized everywhere
    sml = normAng(lo + ma) !Solar mean longitude

    !Sidereal Time at Greenwich + UT + lon = Local SideREAL*8 Time
    LST = (sml/15.d0 + 12.d0) + REAL(UT) + (lon/15.d0)

    !Normalize time value
    IF (LST .LT. 0.d0) THEN
       LST =  LST + 24.d0
    ELSE IF (LST .GT. 24.d0) THEN
       LST = LST - 24.d0
    END IF
  END SUBROUTINE computeSolarTimeValues

  FUNCTION computeSolarPosition(lat, sma, ooe, LST, JDN) RESULT(altazm) !=> [Azm, Alt]
    REAL*8 :: LST, JDN
    REAL*8 :: lat, sma, ooe

    REAL*8, DIMENSION(2) :: altazm

    REAL*8 :: w, e, ea, L
    REAL*8 :: x, xe, y, ye, z, ze, r, v
    REAL*8 :: HA, RA, Decl, alt, azm

    w = 282.9404d0 + 4.70935E-5     * JDN !Longitude of perihelion)
    e = 0.016709d0 - 1.151E-9       * JDN !Eccentricity)

    ea = calculateEA0(e, sma)   !Calculate eccentric anomaly

    !Sun's coordinates in ecliptic plane
    x = COSD(ea) - e
    y = SIND(ea) * SQRT(1.d0 - e**2)

    r = SQRT(x**2 + y**2)
    v = ATAN2D(y, x)

    !Longitude of the Sun
    L = normAng(w + v)

    !Sun's ecliptic rectuangular coordinates
    x = r * COSD(L)
    y = r * SIND(L)
    z = 0.d0

    !Rotate coordinates
    xe = x
    ye = y * COSD(ooe) - z * SIND(ooe)
    ze = y * SIND(ooe) + z * COSD(ooe)

    !Convert to Geocentric RA/Decl/Dist
    RA   = ATAN2D(ye, xe)
    Decl = ATAN2D(ze, SQRT(xe**2 + ye**2))
    r    = SQRT(xe**2 + ye**2 + ze**2)

    HA = (LST - (RA/15.d0)) * 15    !Hour angle

    !Convert HA and Decl to rectangular coordinates
    x = COSD(HA) * COSD(Decl) ! -> South celestial equator
    y = SIND(HA) * COSD(Decl) ! -> Western horizon
    z = SIND(Decl)            ! -> North celestial pole

    !Rotate coordinates along an East-West axis
    xe = x * SIND(lat) - z * COSD(lat) ! -> North-South
    ye = y                             ! -> East-West
    ze = x * COSD(lat) + z * SIND(lat) ! -> Zenith

    !Convert to Topocentric azimuth/altitude
    alt = ASIND(ze)
    azm = ATAN2D(ye, xe) + 180.d0

    !Account for Atmospheric reftaction
    IF ((alt .LT. 85.d0) .AND. (alt .GT. 5.d0)) THEN
       alt = alt + 1.d0/3600.d0 * ((58.1d0/TAND(alt)) - (0.07d0/(TAND(alt)**3)) + (0.000086d0/(TAND(alt)**5)))
    ELSE IF ((alt .LT. 5.d0) .AND. (alt .GT. -0.575d0)) THEN
       alt = alt + 1.d0/3600.d0 * (1735.d0 - 518.2d0*TAND(alt) + 12.79d0*(alt**3) + 0.711d0*(alt**4))
    ELSE IF (alt .LT. -0.575d0) THEN
       alt = alt + 1.d0/3600.d0 * (-20.774d0/TAND(alt))
    END IF

    altazm = [alt, azm]
  END FUNCTION computeSolarPosition

  FUNCTION computeLunarPosition(olat, sma, sml, ooe, LST, JDN) RESULT(radecl) !=> [RA, Decl]
    REAL*8 :: LST, JDN
    REAL*8 :: olat, sma, sml, ooe

    REAL*8, DIMENSION(2) :: radecl

    REAL*8 :: n, i, w, a, e, m, d, l, f, ea
    REAL*8 :: RA, Decl, glat, HA, rho, g, lp, lat, lon
    REAL*8 :: x, xe, xeq, y, ye, yeq, ze, zeq, r, v

    !Calculate lunar orbital elements
    i = 5.1454d0   !Inclination
    e = 0.0549d0   !Eccentricity
    a = 60.2666d0  !Mean distance

    n = normAng(125.1228d0 - 0.0529538083d0  * JDN)  !Longitude of the ascending node
    w = normAng(318.0634d0 + 0.1643573223d0  * JDN)  !Argument of the perigee
    m = normAng(115.3654d0 + 13.0649929509d0 * JDN)  !Mean anomaly

    l = n + w + m !Mean longitude
    d = l - sml   !Mean elongation
    f = l - n     !Argument of Latitude

    !Compute eccentric anomaly
    ea = calculateEA(e, m, 0.005d0)

    !Compute rectanglar coordinates
    x = a * (COSD(ea) - e)
    y = a * SQRT(1 - e**2) * SIND(ea)

    !Convert to polar coordinatesx
    r = SQRT(x**2 + y**2)  !Distance
    v = ATAN2D(y, x)       !True anomaly

    !Compute ecliptic coordinates
    xe = r * (COSD(n)   * COSD(v+w) - SIND(n) * SIND(v+w) * COSD(i))
    ye = r * (SIND(n)   * COSD(v+w) + COSD(n) * SIND(v+w) * COSD(i))
    ze = r * SIND(v+w) * SIND(i)

    !Convert to lat, lon, dist
    lon = normAng(ATAN2D(ye, xe))
    lat = ATAN2D(ze, SQRT(xe**2 + ye**2))
    r   = SQRT(xe**2 + ye**2 + ze**2)

    !Account for lunar perturbations (Might need to be SIND)
    lon = lon -1.274d0 * SIND(m - 2*d)       & !(Evection)
              +0.658d0 * SIND(2*d)           & !(Variation)
              -0.186d0 * SIND(sma)           & !(Yearly equation)
              -0.059d0 * SIND(2*m - 2*d)     &
              -0.057d0 * SIND(m - 2*d + sma) &
              +0.053d0 * SIND(m + 2*d)       &
              +0.046d0 * SIND(2*d - sma)     &
              +0.041d0 * SIND(m - sma)       &
              -0.035d0 * SIND(d)             & !(Parallactic equation)
              -0.031d0 * SIND(m + sma)       &
              -0.015d0 * SIND(2*F - 2*D)     &
              +0.011d0 * SIND(m - 4*D)

    lat = lat -0.173d0 * SIND(f - 2*d)       &
              -0.055d0 * SIND(m - F - 2*d)   &
              -0.046d0 * SIND(m + F - 2*d)   &
              +0.033d0 * SIND(d + 2*d)       &
              +0.017d0 * SIND(2*m + f)

    r   =   r -0.58d0 * COSD(m - 2*d)        &
              -0.46d0 * COSD(2*d)

    !Compute rectangular ecliptic coordinates
    xe = r * COSD(lon) * COSD(lat)
    ye = r * SIND(lon) * COSD(lat)
    ze = r * SIND(lat)

    !Rotate coordinates to equatorial
    xeq = xe
    yeq = ye * COSD(ooe) - ze * SIND(ooe)
    zeq = ye * SIND(ooe) + ze * COSD(ooe)

    !Compute geocentric Right Acension and Declination
    RA = normAng(ATAN2D(yeq, xeq))
    Decl = ATAN2D(zeq, SQRT(xeq**2 + yeq**2))

    !Transalte RA, Decl into topocentic values
    lp = ASIND(1.d0/r) !Lunar parallax

    !Account for flattening of the Earth
    glat = olat - 0.1924d0 * SIND(2*olat)        !Geocentric latitude
    rho  = 0.99833d0 + 0.00167d0 * COSD(2*olat) !Distance from the center of the Earth

    HA = normAng((LST * 15) - RA) !Hour Angle (LST * 15 converts to degrees)
    g  = ATAND(TAND(glat) / COSD(HA)) ! Auxillary angle

    !Convert geocentric RA,Decl to topocentric RA,Decl
    RA   = RA   - lp * rho * COSD(glat) * SIND(HA) / COSD(Decl)
    Decl = Decl - lp * rho * SIND(glat) * SIND(g - Decl) / SIND(g)

    radecl = [RA, Decl]
  END FUNCTION computeLunarPosition

  FUNCTION calculateEA0(e, M) !Calculate inital eccentric anomaly
    REAL*8 :: e, M, calculateEA0

    calculateEA0 = M + to_rad(e) * SIND(M) * (1.0 + e * COSD(M))
  END FUNCTION calculateEA0

  FUNCTION calculateEA(e, M, accu) !Iteratively calculate a more accurate eccentric anomaly
    REAL*8  :: e, M, EA0, EA1, accu, calculateEA

    EA0 = calculateEA0(e, M)
    DO WHILE (.TRUE.)
       EA1 = EA0 - (EA0 - to_rad(e) * SIND(EA0) - M) / (1 - e * COSD(EA0))
       IF (ABS(EA1 - EA0) .LE. accu) THEN
          EXIT
       ELSE
          EA0 = EA1
       END IF
    END DO

    calculateEA = EA0
  END FUNCTION calculateEA

  FUNCTION fromHours(h, m, s)
    INTEGER :: fromHours
    INTEGER  :: h, m, s

    fromHours = h + (m/60) + (s/3600)
  END FUNCTION fromHours

  !General math functions
  FUNCTION normAng(x) !Keeps degree value within proper range
    REAL*8 :: x, normAng

    normAng = x - FLOOR(x/360.d0)*360.d0
  END FUNCTION normAng

  FUNCTION to_rad(x) !Convert to radians
    REAL*8 :: x, to_rad

    to_rad = x * RAD
  END FUNCTION to_rad

  FUNCTION to_deg(x) !Convert to degrees
    REAL*8 :: x, to_deg

    to_deg = x * (PI/180.d0)
  END FUNCTION to_deg
END MODULE almagest


! ------------------------------------------------------ !
! Bubel - poisson2d.f90 - Krzysztof Kolasinski 2016
!
! This example shows how to use Bubel to solve sparse
! system of linear equations with PARDISO. As example we
! solve poisson equaion in 2D:
!       \nabla^2 psi(x,y) = rho(x,y)
! where: rho(x,y) is the density at point (x,y)
!        psi(x,y) is the potential generated by this density
! ------------------------------------------------------ !
program poisson2d
use modunits
use modscatter
implicit none
character(*),parameter :: output_folder = "poisson2d_output/"
type(qscatter)             :: qt
doubleprecision            :: a_dx,x,y,hx,hy
integer ,parameter         :: nx = 100
integer ,parameter         :: ny = 100
doubleprecision,parameter  :: dx = 5.0 ! [nm]
integer , dimension(nx,ny) :: gindex ! converts local index (i,j) to global index
doubleprecision ,dimension(nx*ny) :: rho , phi ! density and potentials arrays, must be 1D array
integer :: i,j,k

QSYS_DEBUG_LEVEL = 0 ! Disable DEBUG

! Use atomic units in effective band model -> see modunit.f90 for more details
call modunits_set_GaAs_params()
a_dx = dx * L2LA ! convert it to atomic units
hx = dx * nx / 2 ! center of the box
hy = dx * ny / 2

! Initalize system
call qt%init_system()

! ----------------------------------------------------------
! 1. Create mesh - loop over width and height of the lattice
! ----------------------------------------------------------
k      = 0
gindex = 0
do i = 1 , nx
do j = 1 , ny
    x = (i-1) * dx
    y = (j-1) * dx
    call qt%qatom%init((/ x , y , 0.0 * dx /))
    ! Add atom to the system.
    call qt%qsystem%add_atom(qt%qatom)
    k           = k + 1
    gindex(i,j) = k
    ! As an example we use two gaussians with different sign for electron density
    rho(k) = exp( -0.01*( (x-hx+50)**2 + (y-hy)**2 ) ) - exp( -0.01*( (x-hx-50)**2 + (y-hy)**2 ) )
enddo
enddo

! ----------------------------------------------------------
! 2. Construct logical connections between sites on the mesh.
! ----------------------------------------------------------
! Set criterium for the nearest neightbours "radius" search algorithm.
! Same as above qt%qnnbparam is a auxiliary variable of type(nnb_params) - more details in modsys.f90
! This structure is responsible for different criteria of nearest neighbour searching
qt%qnnbparam%box = (/2*dx,2*dx,0.0D0/) ! do not search for the sites far than (-dx:+dx) direction
! Setup connections between sites with provided by you function "connect", see below for example.
call qt%qsystem%make_lattice(qt%qnnbparam,c_simple=connect)

! ----------------------------------------------------------
! 3. Use calc_linsys to solve system of equations. Our matrix
! is symmetric thus we use matrix type to be QSYS_LINSYS_PARDISO_REAL_STRUCT_SYM
! dvec - is the left hand vector, its value will be replaced by solution
! ----------------------------------------------------------
phi = rho
call qt%qsystem%calc_linsys(dvec=phi,pardiso_mtype=QSYS_LINSYS_PARDISO_REAL_STRUCT_SYM)
call qt%save_system(output_folder//"system.xml")
call qt%qsystem%save_data(output_folder//"psi.xml",array1d=phi)

! Print solution.
open(unit=11,file=output_folder//"Potential.dat")
do i = 1 , nx
do j = 1 , ny
    x = (i-1) * dx
    y = (j-1) * dx
    write(11,"(4f)"),x,y,rho(gindex(i,j)),phi(gindex(i,j))
enddo
    write(11,*),""
enddo
! ----------------------------------------------------------
! X. Clean memory...
! ----------------------------------------------------------
call qt%destroy_system()
print*,"Generating plots..."
print*,"Plotting solution..."
call system("cd "//output_folder//"; python plot_Sol.py")
print*,"Use Viewer program to see the structure and created leads."
contains

! ---------------------------------------------------------------------------
! This function decides if site A (called here atomA)  has hoping
! to atom B, and what is the value of the coupling.
! If there is no interaction between them returns false, otherwise true.
! Poisson equation after discretization leads to the tight-biding like
! problem, thus we can use matrix creation using connect function.
! ---------------------------------------------------------------------------
logical function connect(atomA,atomB,coupling_val)
    use modcommons
    implicit none
    type(qatom) :: atomA,atomB

    complex*16  :: coupling_val ! you must overwrite this variable
    ! local variables
    integer         :: xdiff,ydiff
    doubleprecision :: dydiff,dxdiff,t0,y

    ! Calculate distance between atoms in units of dx.
    dxdiff = (atomA%atom_pos(1)-atomB%atom_pos(1))/dx
    dydiff = (atomA%atom_pos(2)-atomB%atom_pos(2))/dx
    ! Convert it to integers
    xdiff = NINT(dxdiff)
    ydiff = NINT(dydiff)
    ! default return value
    connect = .false.
    ! hoping parameter
    t0 = 1/(2*m_eff*a_dx**2)
    if( xdiff == 0 .and. ydiff == 0 ) then
        connect      = .true.
        coupling_val = 4*t0
    else if( abs(xdiff) ==  1 .and. ydiff == 0 ) then
        connect = .true.
        coupling_val = -t0
    else if( xdiff ==  0 .and. abs(ydiff) == 1 ) then
        connect = .true.
        coupling_val = -t0
    endif
end function connect
end program poisson2d


c 12/11/2007
c by Liao
c example for function definition and calling
c note:
c   add return type, argument type specification is
c   no forward declaration is needed by default
c------------------------------------------------
c definition of function
      REAL FUNCTION AREA3(A,B,C)
      REAL A,B,C
      S = (A+B+C)/2.0
c return value is assigned to a variable named as the function name
      AREA3 = SQRT (S*(S-A)*(S-B)*(S-C))
      END

      PROGRAM TRIANG
      WRITE(*,*) 'AREA is ', AREA3(10.0,8.2,9.9)
c implicit data type by variable name, I, N integer, all other are real
c warning of mismatched types for parameter by g77
c      WRITE(*,*) 'AREA is ', AREA3(10,8,9)
      END


C
C      **********************************************************************
C      ********************* SUBROUTINE SUMRY  ******************************
C      **********************************************************************
C
       SUBROUTINE SUMRY(U,IU,S,NTOT,FINT)
C
C      *       THIS SUBROUTINE CALCULATES AND PRINTS 75, 50, AND            *
C      *       25, PERCENTILES  OF SURVIVAL FOR A SURVIVAL CURVE.           *
C      *       S AND U ARE ARRAYS CONTAINING POINTS FOR WHICH VALUES OF THE *
C      *       SURVIVAL CURVE WERE CALCULATED, IU IS THE NUMBER OF          *
C      *       UNCENSORED POINTS.  ADOPTED FROM ELISA T. LEE, "STATISTICAL  *
C      *       METHODS FOR SURVIVAL DATA ANALYSIS", 1980, LIFETIME LEARNING *
C      *       PUBLICATIONS (BELMONT:CA).                                   *
C      *                                                                    *
C      *       INPUT       U : UNCENSORED DATA                              *
C      *                   S : PL ESTIMATOR                                 *
C      *       WORK       TY : PERCENTILE INDICATOR AT 75, 50, 25           *
C      *       OUTPUT    FINT: VALUES AT 75, 50, 25 PERCENTILES             *
C      *                                                                    *
C      *     THIS SUBROUTINE IS FROM SMSDA, EXCEPT PRINTING COMMAND.        *
C      *                                                                    *
C
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)
       DIMENSION U(IU),S(NTOT),TY(3),FINT(3)
C
C
       TY(1)=0.75
       TY(2)=0.50
       TY(3)=0.25

C      *       IF THE NUMBER OF DATA POINTS IS SMALLER THAN 4, NO          *
C      *       PERCENTILES CAN BE OBTAINED.                                *
C
       DO 40 I=1,3
          FINT(I)=0.0
  40   CONTINUE

       L=1
       IF(IU.LE.3) RETURN
       NN=IU-1

       DO 100 I=1,3
          IF(S(1).LT.TY(I)) THEN
             FINT(I) = U(1)-(TY(I)-S(1))/(1-S(1))*(U(1)-0)
          ELSE
             DO  90 J=L,NN
                IF((S(J).GE.TY(I)) .AND. (S(J+1).LE.TY(I))) THEN
                   FINT(I)=U(J)-(S(J)-TY(I))/(S(J)-S(J+1))*(U(J)-U(J+1))
                   L=J+1
                   GOTO 100
                ENDIF
  90         CONTINUE
          ENDIF
 100   CONTINUE

       RETURN
       END


program test

    use iso_fortran_env
    use omp_lib

    implicit none

    ! for argument parsing
    integer :: err
    integer :: arglen
    character(len=32) :: argtmp

    ! timing repetitions
    integer :: reps = 20

    ! matrix dimension
    integer :: n
    ! matrix input, output and work arrays
    double precision, allocatable ::  a0(:,:), a(:,:) ! n,n
    double precision, allocatable ::  e(:) ! n
    double precision, allocatable ::  w(:) ! 3*n

    double precision :: t0, t1, dt, esum

    ! LAPACK error code
    integer :: info

    ! loop indices
    integer :: i,j,k

    call random_seed()

    ! parse matrix dimension argument
    n = 4
    call get_command_argument(1,argtmp,arglen,err)
    if (err.eq.0) read(argtmp,'(i32)') n
    if (n .lt. 1) then
        write(*,'(a,i5)') 'ERROR: n must be a positive number : ', n
        stop
    endif

    ! allocate arrays
    allocate( a0(n,n), stat=err)
    if (err .ne. 0) then
        write(*,'(a,i3)') 'allocation of A0 returned ',err
        stop
    endif
    allocate( a(n,n), stat=err)
    if (err .ne. 0) then
        write(*,'(a,i3)') 'allocation of A returned ',err
        stop
    endif
    allocate( e(n), stat=err)
    if (err .ne. 0) then
        write(*,'(a,i3)') 'allocation of E returned ',err
        stop
    endif
    allocate( w(3*n), stat=err)
    if (err .ne. 0) then
        write(*,'(a,i3)') 'allocation of W returned ',err
        stop
    endif

    ! initialize A
    call random_number(a0)
    do j=1,n
        do i=1,j-1
            a0(j,i) = a0(i,j)
        enddo
    enddo

    if (n.lt.100) then
        print*,'A=',a0
    endif

    ! UPLO should not matter
    do k=0,reps
        a = a0
        t0 = omp_get_wtime()
        call dsyev('V','U',n,a,n,e,w,3*n,info)
        if (info.ne.0) stop
        t1 = omp_get_wtime()
        if (k.ge.1) dt = dt + (t1-t0)
    enddo

    if (n.lt.100) then
        print*,'A=',a
        print*,'lambda=',e
    endif
    print*,'dt=',dt/reps

    esum = 0.0d0
    do i=1,n
        esum = esum + e(i)
    enddo
    print*,'esum=',esum

end program test


module circular

    implicit none

    complex(kind=8),allocatable :: P1(:,:), P2(:,:), &
                                   Pinv1(:,:), Pinv2(:,:)
contains

    subroutine set_pmatrix(n,nb,G,R,P,Pinv)

    use config
    use util

    implicit none

    integer(kind=4),intent(in) :: n
    integer(kind=4),intent(in) :: nb
    real(kind=8),intent(in) :: G(3)
    real(kind=8),intent(in) :: R(3)
    integer(kind=4) :: na
    integer(kind=4) :: i,j,k
    complex(kind=8),intent(out) :: P(n,n),Pinv(n,n)
    na = n/nb
    P = 0.0d0
    Pinv = 0.0d0
    do i = 1,nb
        do j = 1,nb
             do k = 1,na
                 P((i-1)*na+k,&
                   (j-1)*na+k) = &
                 exp(i_imag*dot_product(&
                 G*dble(j-1)/dble(nb),&
                 dble(i-1)*R))/dsqrt(dble(nb))
            end do
        end do
    end do

    ! P is unitary matrix
    Pinv = dconjg(transpose(P))
    end subroutine set_pmatrix

    function circular_g(Es_in0,e_in1,alpha_in,&
             beta_in,convergence,&
             n,nb,nc,G1,R1,G2,R2) result(green1)

    ! We have a difference of 1d-10 compared with
    ! direct matrix inversion

    use util

    implicit none

    complex(kind=8),intent(in) :: Es_in0(:,:)
    complex(kind=8),intent(in) :: e_in1(:,:)
    complex(kind=8),intent(in) :: alpha_in(:,:)
    complex(kind=8),intent(in) :: beta_in(:,:)
    real(kind=8),intent(in) :: convergence
    integer(kind=4),intent(in) :: n, nb, nc
    real(kind=8),intent(in) :: G1(3),G2(3)
    real(kind=8),intent(in) :: R1(3),R2(3)
    integer(kind=4) :: i,j,na,nac
    complex(kind=8) :: Es0(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: e1(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: alpha(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: beta(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: green1(size(Es0,1),size(Es0,2))
    complex(kind=8),allocatable :: green2(:,:)
    complex(kind=8),allocatable :: Esy0(:,:)
    complex(kind=8),allocatable :: ey1(:,:)
    complex(kind=8),allocatable :: alphay(:,:)
    complex(kind=8),allocatable :: betay(:,:)

    na = n/nb
    allocate(green2(na,na),Esy0(na,na),ey1(na,na),&
             alphay(na,na),betay(na,na))

    nac = na/nc
    green1 = 0.0d0

    Es0 = fourier_transform(Es_in0,n,nb,G1,R1)
    e1 = fourier_transform(e_in1,n,nb,G1,R1)
    alpha = fourier_transform(alpha_in,n,nb,G1,R1)
    beta = fourier_transform(beta_in,n,nb,G1,R1)

    do i = 1,nb
        Esy0 = fourier_transform(Es0((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
               na,nc,G2,R2)
        ey1 = fourier_transform(e1((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
              na,nc,G2,R2)
        alphay = fourier_transform(alpha((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
                 na,nc,G2,R2)
        betay = fourier_transform(beta((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
                na,nc,G2,R2)
        green2 = 0.0d0
        do j = 1,nc
            green2((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac) = &
                 decimation(Esy0((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac),&
                 ey1((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac),&
                 alphay((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac),&
                 betay((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac),convergence)
        end do
        green1((i-1)*na+1:i*na,(i-1)*na+1:i*na) = &
            matmul(matmul(P2,green2),Pinv2)
    end do
    green1 = matmul(matmul(P1,green1),Pinv1)

    end function circular_g

    function circular_inv(H,n,nb,nc,&
             G1,R1,G2,R2) result(Hinv1)

    use util

    implicit none

    integer(kind=4),intent(in) :: n, nb, nc
    real(kind=8),intent(in) :: G1(3),G2(3)
    real(kind=8),intent(in) :: R1(3),R2(3)
    complex(kind=8),intent(in) :: H(:,:)
    complex(kind=8) :: Hinv1(size(H,1),size(H,2))
    complex(kind=8) :: Hinv2(size(H,1)/nb,size(H,2)/nb)
    complex(kind=8) :: H1(size(H,1),size(H,2))
    complex(kind=8) :: H2(size(H,1)/nb,size(H,2)/nb)
    integer(kind=4) :: i,j, na, nac

    na = n/nb
    nac = na/nc
    Hinv1 = 0.0d0

    H1 = fourier_transform(H,n,nb,G1,R1)
    do i = 1,nb
        H2 = fourier_transform(H1((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
            na,nc,G2,R2)
        Hinv2 = 0.0d0
        do j = 1,nc
            Hinv2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac) = &
            inv(H2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac))
        end do
        Hinv1((i-1)*na+1:i*na,(i-1)*na+1:i*na)&
        = matmul(matmul(P2,Hinv2),Pinv2)
    end do
    Hinv1 = matmul(matmul(P1,Hinv1),Pinv1)

    end function circular_inv

end module circular


program partition
implicit none

!---------------------------------------
! calculates the rate constant
! for the reaction DH + H -> D + H2
!---------------------------------------

integer, parameter :: dp = SELECTED_REAL_KIND(15)
integer :: i !counter

!-----------
!constants:
!-----------

real(dp), parameter :: boltzmann = 1.380648813D-23 ![m^(2)kg/(s^(2)K)]
real(dp), parameter :: h = 6.626069573D-34 ![m^(2)kg/s]
real(dp), parameter :: pi = 3.141592654
real(dp), parameter :: c = 299792458  !speed of light - [m/s]
real(dp), parameter :: Ea = 9.7 ![kcal/mol]
real(dp), parameter :: kcaltoJ = 4184 !conversion factor
real(dp), parameter :: angstrom = 1D-10 !convert angstroms to meters
real(dp), parameter :: mp = 1.672621777D-27 !mass of proton - [kg]
real(dp), parameter :: mn = 1.674927351D-27 !mass of neutron - [kg]
real(dp), parameter :: me = 9.10938291D-31 !mass of electron - [kg]
real(dp), parameter :: symm = 2 !statistical factor.
real(dp), parameter :: R = 8.314462175 !gas constant [J/(Kmol)]
real(dp), parameter :: N = 6.0221412927D+23!avogadro's number - [mole^(-1)]

!-----------
!variables:
!-----------

real, parameter :: V = 1 !volume -> [m^3]
real(dp) :: E, vim, elec !Energy to cross the barrier and
                                 !imaginary frequency
                                 !and electronic partition function
real(dp), dimension(701) :: k, Q, T, trans, vib, rot! rate constant,
                                          !temperature and partition
                                          !functions for the reaction
real(dp), parameter :: eD = 2, eH2 = 1, eDHH = 2 !electronic partition
                                                         !functions
real(dp), dimension(701) :: dG, dH, dS, KC, wigner, kcorr
                                 !Gibbs free energy, enthalpy and
                                 !entropy of the transition state
                                 !reaction, the equilibrium constant
                                 !and the wigner correction.

!Hydrogen:
real(dp) :: mH !mass of deuterium
real(dp), dimension(701) :: qtrans !translational
                                 !partition function of deuterium.

!HD:
real(dp), dimension(701) :: vibHD, rotHD, transHD
                  !translational, rotational and vibrational partition
                  !function of HD
real(dp) :: f !vibrational frequency [s^(-1)].
real(dp) :: mD, mHD, rHD !mass and radius of HD molecule
real(dp) :: IHD ! angular momentum
real(dp) :: ZPEHD !ZP correction

!D-H-H:
real(dp), dimension(701) :: DHHrot, DHHvib, DHHtrans, QDHH
real(dp) :: IDHH, rDHH, mDHH !rotational momentum, distances and
                                    !mass for the transition state
real(dp) :: vDHH1, vDHH2 ! vibrational frequencies,
                                 !ali toa vtoroto moze da bide greska
real(dp) :: ZPEDHH !zero point correction

!---------------------------------
! Define some values first:
!---------------------------------

vim = (850.)*c *(100.) !imaginary frequency of the
                                          !transition state [s^(-1)]
elec = eDHH/(eH2*eD) !electronic partition f-tion.
mH = mp + me ![kg] - mass of hydrogen
f = (3100.) * c * (100.)
mD = mp + mn + me
mHD = mH + mD ![kg]
rHD = 0.741*angstrom !distance between hydrogen atoms - [m]
IHD = ((mH*mD)/(mH+mD))*(rHD**(2.)) !moment of inertia of hydrogen molecule
ZPEHD = (h*f*N)/(2.)

! moment of inertia and mass of transition state:
rDHH = 0.929*angstrom
IDHH = mD*(rDHH**(2.)) + mH*(rDHH**(2.)) - ((mD*rDHH-mH*rDHH)**(2.))/(mD+mH+mH)
mDHH = mD + mH + mH
vDHH1 = (1780.)*c*(100.)
vDHH2 = (861.)*c*(100.)
ZPEDHH = Ea*kcaltoJ + N*(0.5)*(h*vDHH1 + (2.)*h*vDHH2)

E = (ZPEDHH-ZPEHD)

open (unit=1, file='results_HD.txt', status='new', action='write')
write(1,*) 'T', '	', 'k', '	', 'Kc', '	', 'G', '	', 'H', '	', 'S', &
   '	', 'wigner', '	', 'kcorr'

!-------------------------------------
! calculate partition function:
!-------------------------------------

do i = 1, 701
   T(i) = i + 299

   !-------------------------------------------------------------Deuterium:
   !-----------------------------------------------------------------------

   qtrans(i) = ((((2.)*pi*mD*boltzmann*T(i))**(3./2.))/(h**(3.)))*V

   !-----------------------------------------------------Hydrogen molecule:
   !-----------------------------------------------------------------------

   vibHD(i) = (1.) / ((1.) - exp(-h*f/(boltzmann*T(i))))
   rotHD(i) = ((8.)*(pi**(2.))*IHD*boltzmann*T(i))/h !In the presentation
   !(8.)*(pi**(2.))*IH2*boltzmann*T(i) is under aroot
   !but everywhere else I looked, it wasn't, so
   !I used that formula.
   transHD(i) = (((2.)*pi*mHD*boltzmann*T(i))**(3./2.))/(h**(3.))*V

   !-----------------------------------------------------------------D-H-H:
   !-----------------------------------------------------------------------

   DHHrot(i) = ((8.)*(pi**(2.))*IDHH*boltzmann*T(i))/h
   DHHvib(i) = ((1.) / ((1.) - exp(-h*vDHH2/(boltzmann*T(i))))**(2.))*&
   ((1.) / ((1.) - exp(-h*vDHH1/(boltzmann*T(i)))))
   DHHtrans(i) = (((2.)*pi*mDHH*boltzmann*T(i))**(.3/.2))/(h**(3.))*V

   !------------------------------------------------------------value of k:
   !-----------------------------------------------------------------------

   rot(i) = DHHrot(i)/rotHD(i)
   trans(i) = DHHtrans(i)/(qtrans(i)*transHD(i))
   vib(i) = DHHvib(i)/vibHD(i)
   Q(i) = rot(i)*vib(i)*trans(i)*elec
   KC(i) = Q(i)*N*(1000.)*exp(-(E/(R*T(i)))) !L/mol
   k(i) = symm*((boltzmann*T(i))/h)*Q(i)*exp(-(E/(R*T(i))))*N*1000
   dG(i) = -R*T(i)*LOG(KC(i))
   dH(i) = E - (2.)*R*T(i)
   dS(i) = (dH(i)-dG(i))/T(i)
   wigner(i) = (1.) + ((1./24.))*((h*vim)/(boltzmann*T(i)))**(2.)
   kcorr(i) = k(i)*wigner(i)

   write(1,*) T(i), k(i), Kc(i), dG(i), dH(i), dS(i), wigner(i), kcorr(i)
end do

end program partition


!===============================================================================
!> Fundamental constants in CGS and SI units
!===============================================================================
MODULE math_mod
  implicit none
  private
  !---------------------------------------------------------------------
  ! Data type holding fundamental constants of nature
  !---------------------------------------------------------------------
  type, public:: math_t
    character(len=16):: name='not set'
    real(kind=8):: pi  =         acos(-1.0_8)
    real(kind=8):: pi2 = 2.0_8 * acos(-1.0_8)
    real(kind=8):: pi4 = 4.0_8 * acos(-1.0_8)
    real(kind=8):: e = exp(1d0)
    real(kind=8):: ln10 = log(10d0)
  contains
    procedure:: init
  end type
  type(math_t), public:: math
CONTAINS

SUBROUTINE init (self)
  class(math_t):: self
  self%name    = 'math'
END SUBROUTINE init

END MODULE math_mod


module mod_monolis_c3d10_shape
  use mod_monolis_prm
  use mod_monolis_shape_util
  implicit none

  private

  real(kdouble), parameter :: gsp(3,4) = reshape([ &
     0.138196601125011d0, 0.138196601125011d0, 0.138196601125011d0, &
     0.585410196624968d0, 0.138196601125011d0, 0.138196601125011d0, &
     0.138196601125011d0, 0.585410196624968d0, 0.138196601125011d0, &
     0.138196601125011d0, 0.138196601125011d0, 0.585410196624968d0  &
    ], [3,4])

  !real(kdouble), parameter :: np(3,4) = reshape([ &
  !   -1.0d0, -1.0d0,-1.0d0, &
  !    1.0d0, -1.0d0,-1.0d0, &
  !    1.0d0,  1.0d0, 1.0d0, &
  !   -1.0d0,  1.0d0, 1.0d0  &
  !  ], [3,4])

    public :: monolis_C3D10_num_gauss_point
    public :: monolis_C3D10_weight
    public :: monolis_C3D10_integral_point
    !public :: monolis_C3D10_node_point
    public :: monolis_C3D10_get_global_deriv
    public :: monolis_C3D10_shapefunc
    public :: monolis_C3D10_shapefunc_deriv

contains

  function monolis_C3D10_num_gauss_point()
    implicit none
    integer(kint) :: monolis_C3D10_num_gauss_point
    monolis_C3D10_num_gauss_point = 4
  end function monolis_C3D10_num_gauss_point

  function monolis_C3D10_weight(i)
    implicit none
    integer(kint), optional :: i
    real(kdouble) :: monolis_C3D10_weight
    monolis_C3D10_weight = 0.041666666666667d0
  end function monolis_C3D10_weight

  subroutine monolis_C3D10_integral_point(i, r)
    implicit none
    integer(kint) :: i
    real(kdouble) :: r(3)

    r(1) = gsp(1,i)
    r(2) = gsp(2,i)
    r(3) = gsp(3,i)
  end subroutine monolis_C3D10_integral_point

  !subroutine monolis_C3D10_node_point(i, r)
  !  implicit none
  !  integer(kint) :: i
  !  real(kdouble) :: r(3)

  !  r(1) = np(1,i)
  !  r(2) = np(2,i)
  !  r(3) = np(3,i)
  !end subroutine monolis_C3D10_node_point

  subroutine monolis_C3D10_get_global_deriv(node, r, dndx, det)
    implicit none
    real(kdouble) :: node(3,10), r(3), dndx(10,3), deriv(10,3)
    real(kdouble) :: xj(3,3), inv(3,3), det

    call monolis_C3D10_shapefunc_deriv(r, deriv)
    xj = matmul(node, deriv)
    call monolis_get_inverse_matrix_3d(xj, inv, det)
    dndx = matmul(deriv, inv)
  end subroutine monolis_C3D10_get_global_deriv

  subroutine monolis_C3D10_shapefunc(local, func)
    implicit none
    real(kdouble) :: local(3), func(10)
    real(kdouble) :: xi, et, st, a

    xi = local(1)
    et = local(2)
    st = local(3)
    a = 1.0d0 - xi - et - st

    func(1) = (2.0d0*a - 1.0d0)*a
    func(2) = xi*(2.0d0*xi - 1.0d0)
    func(3) = et*(2.0d0*et - 1.0d0)
    func(4) = st*(2.0d0*st - 1.0d0)
    func(5) = 4.0d0*xi*a
    func(6) = 4.0d0*xi*et
    func(7) = 4.0d0*et*a
    func(8) = 4.0d0*st*a
    func(9) = 4.0d0*xi*st
    func(10)= 4.0d0*et*st
  end subroutine monolis_C3D10_shapefunc

  subroutine monolis_C3D10_shapefunc_deriv(local, func)
    implicit none
    real(kdouble) :: local(3), func(10,3)
    real(kdouble) :: xi, et, st, a

    xi = local(1)
    et = local(2)
    st = local(3)
    a = 1.0d0 - xi - et - st

    func(1,1) = 1.0d0 - 4.0d0*a
    func(2,1) = 4.0d0*xi - 1.0d0
    func(3,1) = 0.0d0
    func(4,1) = 0.0d0
    func(5,1) = 4.0d0*(1.0d0 - 2.0d0*xi - et - st)
    func(6,1) = 4.0d0*et
    func(7,1) =-4.0d0*et
    func(8,1) =-4.0d0*st
    func(9,1) = 4.0d0*st
    func(10,1)= 0.0d0

    func(1,2) = 1.0d0 - 4.0d0*a
    func(2,2) = 0.0d0
    func(3,2) = 4.0d0*et - 1.0d0
    func(4,2) = 0.0d0
    func(5,2) =-4.0d0*xi
    func(6,2) = 4.0d0*xi
    func(7,2) = 4.0d0*(1.0d0 - xi - 2.0d0*et - st)
    func(8,2) =-4.0d0*st
    func(9,2) = 0.0d0
    func(10,2)= 4.0d0*st

    func(1,3) = 1.0d0 - 4.0d0*a
    func(2,3) = 0.0d0
    func(3,3) = 0.0d0
    func(4,3) = 4.0d0*st - 1.0d0
    func(5,3) =-4.0d0*xi
    func(6,3) = 0.0d0
    func(7,3) =-4.0d0*et
    func(8,3) = 4.0d0*(1.0d0 - xi - et - 2.0d0*st)
    func(9,3) = 4.0d0*xi
    func(10,3)= 4.0d0*et
  end subroutine monolis_C3D10_shapefunc_deriv

end module mod_monolis_c3d10_shape


	SUBROUTINE PD_CAPE ( zbot, ztop, thbot, thtop, thpbot, thptop,
     +                          cape, cins )
C************************************************************************
C* PD_CAPE  ( ZBOT, ZTOP, THBOT, THTOP, THPBOT, THPTOP, CAPE, CINS )	*
C*									*
C* This routine calculates CAPE & CINS for a specified layer. The input	*
C* CAPE and CINS values are updated with the sum of computed layer.	*
C*									*
C* A trapezoidal integration will be performed. The layer will be	*
C* divided into depths with a maximum of 100m. Only positive area will	*
C* be accumulated for CAPE, and negative area for CINS.			*
C*									*
C* Input parameters:							*
C*	ZBOT		REAL		Z bottom			*
C*	ZTOP		REAL		Z top				*
C*	THBOT		REAL		THTA (environment) bottom	*
C*	THTOP		REAL		THTA (environment) top		*
C*	THPBOT		REAL		THTA (parcel) bottom		*
C*	THPTOP		REAL		THTA (parcel) top		*
C*									*
C* Input and Output Parameters:						*
C*	CAPE		REAL		Updated CAPE sum		*
C*	CINS		REAL		Updated CINS sum		*
C************************************************************************
	REAL		adata(3), bdata(3), outdat(3)
	LOGICAL		intflg(3), angflg(3)
C
	adata (1) = zbot
	bdata (1) = ztop
	adata (2) = thbot
	bdata (2) = thtop
	adata (3) = thpbot
	bdata (3) = thptop
	intflg(1) = .true.
	intflg(2) = .true.
	intflg(3) = .true.
	angflg(1) = .false.
	angflg(2) = .false.
	angflg(3) = .false.
C
C*	Integrate using 100m maximum depth
C
	DO WHILE ( zbot .lt. ztop )
	    IF ( ( zbot + 100. ) .lt. ztop ) THEN
		zup = zbot + 100.
	        CALL PC_INTH ( zup, adata, bdata,
     +		      3, intflg, angflg, 1, outdat, ier )
		IF ( ier .ne. 0 ) THEN
		   CALL ER_WMSG ( 'PC', ier, ' ', ier2 )
		END IF
		th_up = outdat(2)
		thp_up = outdat(3)
	    ELSE
		zup = ztop
		th_up = thtop
		thp_up = thptop
	    END IF
C
	    CALL PD_SUML ( zbot, zup, thbot, th_up,
     +				thpbot, thp_up, cape, cins )
C
	    thbot = th_up
	    thpbot = thp_up
	    zbot = zup
	END DO
C
	RETURN
	END


module rand
  ! Module for different random number utilities
  ! (c) 2005, Mikko Orispaa <mikko.orispaa@oulu.fi>
  ! Licensed under GPL version 2

 ! private

  interface nrand
     module procedure nrands_s, nrands_d,nrandv_s,nrandv_d,nrandm_s,nrandm_d
  end interface

 ! public :: set_rand_seed, nrand, intrand

contains

  subroutine set_rand_seed()
    ! Sets random seed using system clock
    implicit none

    integer :: s
    integer, dimension(8) :: t
    integer, dimension(:), allocatable :: seed

    call random_seed(size = s)
    allocate(seed(s))
    call date_and_time(values = t)
    seed = 100*t(7) + t(8)/10
    call random_seed(put = seed)
  end subroutine set_rand_seed

  !  subroutine nrands_d(num)
  !    ! returns normally distributed (pseudo) random number
  !    implicit none

  !    real(8), parameter :: pi = 3.141592653589793238462643

  !    real(8) :: num

  !    real(8), dimension(2) :: x

  !    call random_number(x)

  !    num = sqrt(-2*log(x(1)))*cos(2*pi*x(2))

  !  end subroutine nrands_d

  subroutine nrands_s(num)
    ! Returns normally distributed random number (polar-form of the
    ! Box-Muller transformation). More robust numerically and faster.
    implicit none

    real(4) :: num
    real(4) :: x_1,x_2,w

    w = 2.0D0

    do while ( w >= 1.0D0 )
       call random_number(x_1)
       call random_number(x_2)
       x_1 = 2.0D0*x_1 - 1.0D0
       x_2 = 2.0D0*x_2 - 1.0D0
       w = x_1**2 + x_2**2
    end do

    w = sqrt((-2.0D0*log(w))/w)
    num = x_1 * w
  end subroutine nrands_s

  subroutine nrands_d(num)
    ! Returns normally distributed random number (polar-form of the
    ! Box-Muller transformation). More robust numerically and faster.
    implicit none

    real(8) :: num
    real(8) :: x_1,x_2,w

    w = 2.0D0

    do while ( w >= 1.0D0 )
       call random_number(x_1)
       call random_number(x_2)
       x_1 = 2.0D0*x_1 - 1.0D0
       x_2 = 2.0D0*x_2 - 1.0D0
       w = x_1**2 + x_2**2
    end do

    w = sqrt((-2.0D0*log(w))/w)
    num = x_1 * w
  end subroutine nrands_d

  subroutine nrandv_d(vec)
    ! Returns normally distributed random vector
    implicit none

    real(8), dimension(:) :: vec
    real(8) :: rnum
    integer :: i, n

    n = size(vec)

    do i=1,n
       call nrands_d(rnum)
       vec(i) = rnum
    end do

  end subroutine nrandv_d

  subroutine nrandv_s(vec)
    ! Returns normally distributed random vector
    implicit none

    real(4), dimension(:) :: vec
    real(4) :: rnum
    integer :: i, n

    n = size(vec)

    do i=1,n
       call nrands_s(rnum)
       vec(i) = rnum
    end do

  end subroutine nrandv_s

  subroutine nrandm_d(mat)
    ! Returns normally distributed random matrix
    real(8), dimension(:,:) :: mat
    real(8) :: rnum
    integer :: m,n,i,j

    m = size(mat,1)
    n = size(mat,2)

    do i = 1,m
       do j = 1,n
          call nrands_d(rnum)
          mat(i,j) = rnum
       end do
    end do
  end subroutine nrandm_d

  subroutine nrandm_s(mat)
    ! Returns normally distributed random matrix
    real(4), dimension(:,:) :: mat
    real(4) :: rnum
    integer :: m,n,i,j

    m = size(mat,1)
    n = size(mat,2)

    do i = 1,m
       do j = 1,n
          call nrands_s(rnum)
          mat(i,j) = rnum
       end do
    end do
  end subroutine nrandm_s

  function randi(min,max) result(rnum)
    ! Gives a random integer between min and max
    implicit none

    integer :: min, max, rnum
    real(4) :: rand_num

    call random_number(rand_num)

    rnum = floor(rand_num * (max+1 - min) + min)

  end function randi
!!$

end module rand


program EP1
    use     methods, only: grad, newt, bfgs
    use         mgh, only: setprob, getdim, gettries, getname, getinit, mgh_f, mgh_g, mgh_h
    use          ls, only: lsquad, lscube
    use  rosenbrock, only: rosef, roseg, roseh
    use  paraboloid, only: paraf, parag, parah
    use       stats, only: f, g, h, &
                           setf, setg, seth, &
                           iteration, armijo, norm, angle, &
                           initstat, printheader, printstat, setmethod
    implicit none

    integer                       :: p, s
    integer                       :: n, nprob, ntries, i
    character(len=30)             :: name
    double precision              :: factor = 1.d0
    double precision, allocatable :: x(:), x0(:)
    double precision              :: gamma, sigma, theta, eps

    ! Chamadas do sistema para criar processos independentes
    ! Útil para matar uma conta específica sem afetar as outras
    interface
       function fork() bind(C)
         use iso_c_binding, only: c_int
         integer(c_int) :: fork
       end function fork

       function wait(i) bind(C)
         use iso_c_binding, only: c_int
         integer(c_int), VALUE :: i
         integer(c_int)        :: wait
       end function wait
    end interface

    s = 0
    gamma = 1e-4
    sigma = 1e-4
    theta = 1e-5
    eps   = 1e-5

    call printheader()

    ! !!!!!!!!!!!!!!!!!!!!!!!!!!! Parabolóide !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    print *, "Paraboloid"
    call initstat()
    call setf(paraf)
    call setg(parag)
    call seth(parah)

    n = 2
    allocate(x(2))
    allocate(x0(2))
    x0(1) = 100
    x0(2) = 100

    INCLUDE 'runmethods.f08'
    deallocate(x)
    deallocate(x0)

    !!!!!!!!!!!!!!!!!!!!!!!!!!! Rosenbrock !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    print *, "Rosenbrock"
    call initstat()
    call setf(rosef)
    call setg(roseg)
    call seth(roseh)

    n = 2
    allocate(x(2))
    allocate(x0(2))
    x0(1) = 1
    x0(2) = 2

    INCLUDE 'runmethods.f08'
    deallocate(x)
    deallocate(x0)

    !!!!!!!!!!!!!!!!!!!!!!! Moré-Garbow-Hillstrom !!!!!!!!!!!!!!!!!!!!!!!!!
    call initstat()
    call setf(mgh_f)
    call setg(mgh_g)
    call seth(mgh_h)

    do nprob = 1, 18
        call setprob(nprob)
        ntries = gettries()
        factor = 1.d0

        name = getname()
        n    = getdim()

        print '(i2, x, a)', nprob, name
        allocate( x(n))
        allocate(x0(n))
        call getinit(x0, factor)

        INCLUDE 'runmethods.f08'

        deallocate(x)
        deallocate(x0)
     end do
end program EP1


SUBROUTINE hexahedron_xz(iel,x_coords,y_coords,z_coords,coord,num)
!
! This subroutine generates nodal coordinates and numbering for
! 8, 14 or 20-node "bricks" counting x-z planes in the y-direction.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::iel
 REAL(iwp),INTENT(IN)::x_coords(:),y_coords(:),z_coords(:)
 REAL(iwp),INTENT(OUT)::coord(:,:)
 INTEGER,INTENT(OUT)::num(:)
 REAL(iwp)::pt5=0.5_iwp
 INTEGER::fac1,fac2,ip,iq,is,iplane,nod,nxe,nze
 nxe=UBOUND(x_coords,1)-1
 nze=UBOUND(z_coords,1)-1
 nod=UBOUND(num,1)
 iq=(iel-1)/(nxe*nze)+1
 iplane=iel-(iq-1)*nxe*nze
 is=(iplane-1)/nxe+1
 ip=iplane-(is-1)*nxe
 SELECT CASE(nod)
 CASE(8)
   fac1=(nxe+1)*(nze+1)*(iq-1)
   num(1)=fac1+is*(nxe+1)+ip
   num(2)=fac1+(is-1)*(nxe+1)+ip
   num(3)=num(2)+1
   num(4)=num(1)+1
   num(5)=(nxe+1)*(nze+1)*iq+is*(nxe+1)+ip
   num(6)=(nxe+1)*(nze+1)*iq+(is-1)*(nxe+1)+ip
   num(7)=num(6)+1
   num(8)=num(5)+1
!
   coord(1:2,1)=x_coords(ip)
   coord(5:6,1)=x_coords(ip)
   coord(3:4,1)=x_coords(ip+1)
   coord(7:8,1)=x_coords(ip+1)
!
   coord(1:4,2)=y_coords(iq)
   coord(5:8,2)=y_coords(iq+1)
!
   coord(2:3,3)=z_coords(is)
   coord(6:7,3)=z_coords(is)
   coord(1:4:3,3)=z_coords(is+1)
   coord(5:8:3,3)=z_coords(is+1)
!
 CASE(14)
   fac1=(2*nxe+1)*(2*nze+1)*(iq-1)
   fac2=(2*nxe+1)*(2*nze+1)*iq
   num(1)=fac1+is*(2*nxe+1)+ip
   num(2)=num(1)-(2*nxe+1)
   num(3)=num(2)+1
   num(4)=num(1)+1
   num(5)=num(2)+nxe+1
   num(6)=fac1+(nxe+1)*(nze+1)+nxe*nze+(is-1)*(2*nxe+1)+nxe+ip
   num(7)=num(6)-nxe
   num(8)=num(6)+1
   num(9)=num(8)+nxe
   num(10)=fac2+is*(2*nxe+1)+ip
   num(11)=num(10)-(2*nxe+1)
   num(12)=num(11)+1
   num(13)=num(10)+1
   num(14)=num(11)+nxe+1
!
   coord(1:2,1)=x_coords(ip)
   coord(6,1)=x_coords(ip)
   coord(10:11,1)=x_coords(ip)
   coord(5:9:2,1)=pt5*(x_coords(ip)+x_coords(ip+1))
   coord(14,1)=pt5*(x_coords(ip)+x_coords(ip+1))
   coord(3:4,1)=x_coords(ip+1)
   coord(8,1)=x_coords(ip+1)
   coord(12:13,1)=x_coords(ip+1)
!
   coord(1:5,2)=y_coords(iq)
   coord(6:9,2)=pt5*(y_coords(iq)+y_coords(iq+1))
   coord(10:14,2)=y_coords(iq+1)
!
   coord(2:3,3)=z_coords(is)
   coord(7,3)=z_coords(is)
   coord(11:12,3)=z_coords(is)
   coord(5:6,3)=pt5*(z_coords(is)+z_coords(is+1))
   coord(8:14:6,3)=pt5*(z_coords(is)+z_coords(is+1))
   coord(1:4:3,3)=z_coords(is+1)
   coord(9,3)=z_coords(is+1)
   coord(10:13:3,3)=z_coords(is+1)
!
 CASE(20)
   fac1=((2*nxe+1)*(nze+1)+(2*nze+1)*(nxe+1))*(iq-1)
   fac2=((2*nxe+1)*(nze+1)+(2*nze+1)*(nxe+1))*iq
   num(1)=fac1+(3*nxe+2)*is+2*ip-1
   num(2)=fac1+(3*nxe+2)*is-nxe+ip-1
   num(3)=num(1)-3*nxe-2
   num(4)=num(3)+1
   num(5)=num(4)+1
   num(6)=num(2)+1
   num(7)=num(1)+2
   num(8)=num(1)+1
   num(9)=fac2-(nxe+1)*(nze+1)+(nxe+1)*is+ip
   num(10)=num(9)-nxe-1
   num(11)=num(10)+1
   num(12)=num(9)+1
   num(13)=fac2+(3*nxe+2)*is+2*ip-1
   num(14)=fac2+(3*nxe+2)*is-nxe+ip-1
   num(15)=num(13)-3*nxe-2
   num(16)=num(15)+1
   num(17)=num(16)+1
   num(18)=num(14)+1
   num(19)=num(13)+2
   num(20)=num(13)+1
!
   coord(1:3,1)=x_coords(ip)
   coord(9:10,1)=x_coords(ip)
   coord(13:15,1)=x_coords(ip)
   coord(5:7,1)=x_coords(ip+1)
   coord(11:12,1)=x_coords(ip+1)
   coord(17:19,1)=x_coords(ip+1)
   coord(4:8:4,1)=pt5*(x_coords(ip)+x_coords(ip+1))
   coord(16:20:4,1)=pt5*(x_coords(ip)+x_coords(ip+1))
!
   coord(1:8,2)=y_coords(iq)
   coord(13:20,2)=y_coords(iq+1)
   coord(9:12,2)=pt5*(y_coords(iq)+y_coords(iq+1))
!
   coord(1,3)=z_coords(is+1)
   coord(7:9,3)=z_coords(is+1)
   coord(12:13,3)=z_coords(is+1)
   coord(19:20,3)=z_coords(is+1)
   coord(3:5,3)=z_coords(is)
   coord(10:11,3)=z_coords(is)
   coord(15:17,3)=z_coords(is)
   coord(2:6:4,3)=pt5*(z_coords(is)+z_coords(is+1))
   coord(14:18:4,3)=pt5*(z_coords(is)+z_coords(is+1))
!
 CASE DEFAULT
   WRITE(11,'(a)')"Wrong number of nodes for hexahedral element"
   STOP
 END SELECT
RETURN
END SUBROUTINE hexahedron_xz


! Copyright 2013 Francisco Souza. All rights reserved.
! Use of this source code is governed by a BSD-style
! license that can be found in the LICENSE file.

program vecaddition
   use omp_lib
   use vectors, only: vecadd
   implicit none
   integer, parameter :: n = 10
   integer :: i
   integer, dimension(n) :: a, b, c
   !$omp parallel do
   do i=1,n
      a(i) = i ** 2
      b(i) = i * 2
   end do
   call vecadd(a, b, c, n)
   print *, c
end program


PROGRAM p17

    IMPLICIT NONE
    REAL a,b,c,x,y,z,f1
    DATA c / 5./

    f1(x,y) = a+b*x**2+c*y

    a = 1
    b = 2
    z = f1(2.,2.0)
    PRINT *, 'f1(2.,2.): ', z

    z = f1(b,b)
    PRINT *, 'f1(b,b): ', z

    z = f2(2.,2.0)
    PRINT *, 'f2(2.,2.): ', z

    z = f2(b,b)
    PRINT *, 'f2(b,b): ', z

    CONTAINS
        FUNCTION f2(x,y)
        REAL x,y,f2
        f2 = a+b*x**2+c*y
        RETURN
        END FUNCTION f2

END PROGRAM p17


C     LAST UPDATE 03/03/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE MATCAL(ICSTPZ,PHIZ,PHIX,RCELL,AMAT)
      IMPLICIT NONE
C
C Purpose: Calculates a matrix AMAT = PHI.A where PHI is the orientation
C          matrix, defined by PHIZ and PHIX,  with respect to one of two
C          standard settings, and A is the matrix corresponding to the
C          components of the reciprocal cell vectors in one of the
C          standard orientations. The standard orientations are:
C          c parallel to Z and a* parallel to X (ICSTPZ=0) or
C          c* parallel to Z and a* perpendicular to Y (ICSTPZ=1).
C
C
C Calls   0:
C Called by: DRAGON, FBRAG, BRGOUT
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Arguments:
C
      INTEGER ICSTPZ
      REAL RCELL(6),AMAT(3,3)
      REAL PHIZ,PHIX
C
C Local variables:
C
      INTEGER I,J,K
      DOUBLE PRECISION SA,CA,SB,CB,SG,CG,SPZ,CPZ,SPX,CPX
      DOUBLE PRECISION A(3,3),PHI(3,3)
C
C-----------------------------------------------------------------------
C
C========Set up sin and cos of reciprocal cell angles
C
      SA = SIN(RCELL(4))
      CA = COS(RCELL(4))
      SB = SIN(RCELL(5))
      CB = COS(RCELL(5))
      SG = SIN(RCELL(6))
      CG = COS(RCELL(6))
C
C========Set up A matrix
C
      IF(ICSTPZ.EQ.0)THEN
         A(1,1) = RCELL(1)
         A(1,2) = RCELL(2)*CG
         A(1,3) = RCELL(3)*CB
         A(2,1) = 0.0
         A(2,2) = RCELL(2)*SG
         A(2,3) = RCELL(3)*(CA-CB*CG)/SG
         A(3,1) = 0.0
         A(3,2) = 0.0
         A(3,3) = SQRT(RCELL(3)**2-A(1,3)**2-A(2,3)**2)
      ELSE
         A(1,1) = RCELL(1)*SB
         A(1,2) = RCELL(2)*(CG-CA*CB)/SB
         A(1,3) = 0.0
         A(2,1) = 0.0
         A(2,3) = 0.0
         A(3,1) = RCELL(1)*CB
         A(3,2) = RCELL(2)*CA
         A(2,2) = SQRT(RCELL(2)**2-A(1,2)**2-A(3,2)**2)
         A(3,3) = RCELL(3)
      ENDIF
C
C========Set up sin and cos of orientation angles
C
      SPZ = SIN(PHIZ)
      CPZ = COS(PHIZ)
      SPX = SIN(PHIX)
      CPX = COS(PHIX)
C
C========Set up PHI
C
      PHI(1,1) = CPZ
      PHI(1,2) = -SPZ
      PHI(1,3) = 0.0
      PHI(2,1) = CPX*SPZ
      PHI(2,2) = CPX*CPZ
      PHI(2,3) = -SPX
      PHI(3,1) = SPX*SPZ
      PHI(3,2) = SPX*CPZ
      PHI(3,3) = CPX
C
C========Calculate PHI.A
C
      DO 30 I=1,3
         DO 20 J=1,3
            AMAT(I,J) = 0.0
            DO 10 K=1,3
               AMAT(I,J) = AMAT(I,J) + PHI(I,K)*A(K,J)
 10         CONTINUE
 20      CONTINUE
 30   CONTINUE
      RETURN
C
      END


module test_linalg
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_kinds, only: sp, dp, qp, int8, int16, int32, int64
    use stdlib_linalg, only: diag, eye, trace, outer_product

    implicit none

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

contains

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

        testsuite = [ &
            new_unittest("eye", test_eye), &
            new_unittest("diag_rsp", test_diag_rsp), &
            new_unittest("diag_rsp_k", test_diag_rsp_k), &
            new_unittest("diag_rdp", test_diag_rdp), &
            new_unittest("diag_rqp", test_diag_rqp), &
            new_unittest("diag_csp", test_diag_csp), &
            new_unittest("diag_cdp", test_diag_cdp), &
            new_unittest("diag_cqp", test_diag_cqp), &
            new_unittest("diag_int8", test_diag_int8), &
            new_unittest("diag_int16", test_diag_int16), &
            new_unittest("diag_int32", test_diag_int32), &
            new_unittest("diag_int64", test_diag_int64), &
            new_unittest("trace_rsp", test_trace_rsp), &
            new_unittest("trace_rsp_nonsquare", test_trace_rsp_nonsquare), &
            new_unittest("trace_rdp", test_trace_rdp), &
            new_unittest("trace_rdp_nonsquare", test_trace_rdp_nonsquare), &
            new_unittest("trace_rqp", test_trace_rqp), &
            new_unittest("trace_csp", test_trace_csp), &
            new_unittest("trace_cdp", test_trace_cdp), &
            new_unittest("trace_cqp", test_trace_cqp), &
            new_unittest("trace_int8", test_trace_int8), &
            new_unittest("trace_int16", test_trace_int16), &
            new_unittest("trace_int32", test_trace_int32), &
            new_unittest("trace_int64", test_trace_int64), &
            new_unittest("outer_product_rsp", test_outer_product_rsp), &
            new_unittest("outer_product_rdp", test_outer_product_rdp), &
            new_unittest("outer_product_rqp", test_outer_product_rqp), &
            new_unittest("outer_product_csp", test_outer_product_csp), &
            new_unittest("outer_product_cdp", test_outer_product_cdp), &
            new_unittest("outer_product_cqp", test_outer_product_cqp), &
            new_unittest("outer_product_int8", test_outer_product_int8), &
            new_unittest("outer_product_int16", test_outer_product_int16), &
            new_unittest("outer_product_int32", test_outer_product_int32), &
            new_unittest("outer_product_int64", test_outer_product_int64) &
            ]

    end subroutine collect_linalg

    subroutine test_eye(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(sp), allocatable :: rye(:,:)
        complex(sp) :: cye(7,7)
        integer :: i

        call check(error, all(eye(3,3) == diag([(1,i=1,3)])), &
            "all(eye(3,3) == diag([(1,i=1,3)])) failed.")
        if (allocated(error)) return

        rye = eye(3,4)
        call check(error, sum(abs(rye(:,1:3) - diag([(1.0_sp,i=1,3)]))) < sptol, &
            "sum(abs(rye(:,1:3) - diag([(1.0_sp,i=1,3)]))) < sptol failed")
        if (allocated(error)) return

        call check(error, all(eye(5) == diag([(1,i=1,5)])), &
            "all(eye(5) == diag([(1,i=1,5)] failed.")
        if (allocated(error)) return

        rye = eye(6)
        call check(error, sum(rye - diag([(1.0_sp,i=1,6)])) < sptol, &
            "sum(rye - diag([(1.0_sp,i=1,6)])) < sptol failed.")
        if (allocated(error)) return

        cye = eye(7)
        call check(error, abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol, &
            "abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol failed.")

    end subroutine test_eye

    subroutine test_diag_rsp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        real(sp) :: v(n), a(n,n), b(n,n)
        integer :: i,j

        v = [(i,i=1,n)]
        a = diag(v)
        b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
        call check(error, all(a == b), &
            "all(a == b) failed.")
        if (allocated(error)) return

        call check(error, all(diag(3*a) == 3*v), &
            "all(diag(3*a) == 3*v) failed.")
    end subroutine test_diag_rsp

    subroutine test_diag_rsp_k(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 4
        real(sp) :: a(n,n), b(n,n)
        integer :: i,j

        a = diag([(1._sp,i=1,n-1)],-1)

        b = reshape([((merge(1,0,i==j+1), i=1,n), j=1,n)], [n,n])

        call check(error, all(a == b), &
            "all(a == b) failed.")
        if (allocated(error)) return

        call check(error, sum(diag(a,-1)) - (n-1) < sptol, &
            "sum(diag(a,-1)) - (n-1) < sptol failed.")
        if (allocated(error)) return

        call check(error, all(a == transpose(diag([(1._sp,i=1,n-1)],1))), &
            "all(a == transpose(diag([(1._sp,i=1,n-1)],1))) failed")
        if (allocated(error)) return

        call random_number(a)
        do i = 1, n
            call check(error, size(diag(a,i)) == n-i, &
                "size(diag(a,i)) == n-i failed.")
            if (allocated(error)) return
        end do
        call check(error, size(diag(a,n+1)) == 0, &
            "size(diag(a,n+1)) == 0 failed.")
    end subroutine test_diag_rsp_k

    subroutine test_diag_rdp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        real(dp) :: v(n), a(n,n), b(n,n)
        integer :: i,j

        v = [(i,i=1,n)]
        a = diag(v)
        b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
        call check(error, all(a == b), &
            "all(a == b) failed.")
        if (allocated(error)) return

        call check(error, all(diag(3*a) == 3*v), &
            "all(diag(3*a) == 3*v) failed.")
    end subroutine test_diag_rdp

    subroutine test_diag_rqp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        real(qp) :: v(n), a(n,n), b(n,n)
        integer :: i,j

        v = [(i,i=1,n)]
        a = diag(v)
        b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
        call check(error, all(a == b), &
            "all(a == b) failed.")
        if (allocated(error)) return

        call check(error, all(diag(3*a) == 3*v), &
            "all(diag(3*a) == 3*v) failed.")
    end subroutine test_diag_rqp

    subroutine test_diag_csp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        complex(sp) :: a(n,n), b(n,n)
        complex(sp), parameter :: i_ = cmplx(0,1,kind=sp)
        integer :: i,j

        a = diag([(i,i=1,n)]) + diag([(i_,i=1,n)])
        b = reshape([((merge(i + 1*i_,0*i_,i==j), i=1,n), j=1,n)], [n,n])
        call check(error, all(a == b), &
            "all(a == b) failed.")
        if (allocated(error)) return

        call check(error, all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol), &
            "all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol)")
        if (allocated(error)) return
        call check(error, all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol), &
            "all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol)")
    end subroutine test_diag_csp

    subroutine test_diag_cdp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        complex(dp) :: a(n,n)
        complex(dp), parameter :: i_ = cmplx(0,1,kind=dp)

        a = diag([i_],-2) + diag([i_],2)
        call check(error, a(3,1) == i_ .and. a(1,3) == i_, &
            "a(3,1) == i_ .and. a(1,3) == i_ failed.")
    end subroutine test_diag_cdp

    subroutine test_diag_cqp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        complex(qp) :: a(n,n)
        complex(qp), parameter :: i_ = cmplx(0,1,kind=qp)

        a = diag([i_,i_],-1) + diag([i_,i_],1)
        call check(error, all(diag(a,-1) == i_) .and. all(diag(a,1) == i_), &
            "all(diag(a,-1) == i_) .and. all(diag(a,1) == i_) failed.")
    end subroutine test_diag_cqp

    subroutine test_diag_int8(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        integer(int8), allocatable :: a(:,:)
        integer :: i
        logical, allocatable :: mask(:,:)

        a = reshape([(i,i=1,n**2)],[n,n])
        mask = merge(.true.,.false.,eye(n) == 1)
        call check(error, all(diag(a) == pack(a,mask)), &
            "all(diag(a) == pack(a,mask)) failed.")
        if (allocated(error)) return
        call check(error, all(diag(diag(a)) == merge(a,0_int8,mask)), &
            "all(diag(diag(a)) == merge(a,0_int8,mask)) failed.")
    end subroutine test_diag_int8
    subroutine test_diag_int16(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 4
        integer(int16), allocatable :: a(:,:)
        integer :: i
        logical, allocatable :: mask(:,:)

        a = reshape([(i,i=1,n**2)],[n,n])
        mask = merge(.true.,.false.,eye(n) == 1)
        call check(error, all(diag(a) == pack(a,mask)), &
            "all(diag(a) == pack(a,mask))")
        if (allocated(error)) return
        call check(error, all(diag(diag(a)) == merge(a,0_int16,mask)), &
            "all(diag(diag(a)) == merge(a,0_int16,mask)) failed.")
    end subroutine test_diag_int16
    subroutine test_diag_int32(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        integer(int32) :: a(n,n)
        logical :: mask(n,n)
        integer :: i, j

        mask = reshape([((merge(.true.,.false.,i==j+1), i=1,n), j=1,n)], [n,n])
        a = 0
        a = unpack([1_int32,1_int32],mask,a)
        call check(error, all(diag([1,1],-1) == a), &
            "all(diag([1,1],-1) == a) failed.")
        if (allocated(error)) return
        call check(error, all(diag([1,1],1) == transpose(a)), &
            "all(diag([1,1],1) == transpose(a)) failed.")
    end subroutine test_diag_int32
    subroutine test_diag_int64(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 4
        integer(int64) :: a(n,n), c(0:2*n-1)
        logical :: mask(n,n)
        integer :: i, j

        mask = reshape([((merge(.true.,.false.,i+1==j), i=1,n), j=1,n)], [n,n])
        a = 0
        a = unpack([1_int64,1_int64,1_int64],mask,a)

        call check(error, all(diag([1,1,1],1) == a), &
            "all(diag([1,1,1],1) == a) failed.")
        if (allocated(error)) return
        call check(error, all(diag([1,1,1],-1) == transpose(a)), &
            "all(diag([1,1,1],-1) == transpose(a)) failed.")
        if (allocated(error)) return

        ! Fill array c with Catalan numbers
        do i = 0, 2*n-1
            c(i) = catalan_number(i)
        end do
        ! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1)
        do i = 1, n
            do j = 1, n
                a(i,j) = c(i-1 + (j-1))
            end do
        end do
        call check(error, all(diag(a,-2) == diag(a,2)), &
            "all(diag(a,-2) == diag(a,2))")
    end subroutine test_diag_int64

    subroutine test_trace_rsp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 5
        real(sp) :: a(n,n)
        integer :: i

        a = reshape([(i,i=1,n**2)],[n,n])
        call check(error, abs(trace(a) - sum(diag(a))) < sptol, &
            "abs(trace(a) - sum(diag(a))) < sptol failed.")
    end subroutine test_trace_rsp

    subroutine test_trace_rsp_nonsquare(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 4
        real(sp) :: a(n,n+1), ans
        integer :: i

        ! 1   5   9  13  17
        ! 2   6  10  14  18
        ! 3   7  11  15  19
        ! 4   8  12  16  20
        a = reshape([(i,i=1,n*(n+1))],[n,n+1])
        ans = sum([1._sp,6._sp,11._sp,16._sp])

        call check(error, abs(trace(a) - ans) < sptol, &
            "abs(trace(a) - ans) < sptol failed.")
    end subroutine test_trace_rsp_nonsquare

    subroutine test_trace_rdp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 4
        real(dp) :: a(n,n)
        integer :: i

        a = reshape([(i,i=1,n**2)],[n,n])
        call check(error, abs(trace(a) - sum(diag(a))) < dptol, &
            "abs(trace(a) - sum(diag(a))) < dptol failed.")
    end subroutine test_trace_rdp

    subroutine test_trace_rdp_nonsquare(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 4
        real(dp) :: a(n,n-1), ans
        integer :: i

        !  1   25   81
        !  4   36  100
        !  9   49  121
        ! 16   64  144
        a = reshape([(i**2,i=1,n*(n-1))],[n,n-1])
        ans = sum([1._dp,36._dp,121._dp])

        call check(error, abs(trace(a) - ans) < dptol, &
            "abs(trace(a) - ans) < dptol failed.")
    end subroutine test_trace_rdp_nonsquare

    subroutine test_trace_rqp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        real(qp) :: a(n,n)
        integer :: i

        a = reshape([(i,i=1,n**2)],[n,n])
        call check(error, abs(trace(a) - sum(diag(a))) < qptol, &
            "abs(trace(a) - sum(diag(a))) < qptol failed.")
    end subroutine test_trace_rqp

    subroutine test_trace_csp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 5
        real(sp) :: re(n,n), im(n,n)
        complex(sp) :: a(n,n), b(n,n)
        complex(sp), parameter :: i_ = cmplx(0,1,kind=sp)

        call random_number(re)
        call random_number(im)
        a = re + im*i_

        call random_number(re)
        call random_number(im)
        b = re + im*i_

        ! tr(A + B) = tr(A) + tr(B)
        call check(error, abs(trace(a+b) - (trace(a) + trace(b))) < sptol, &
            "abs(trace(a+b) - (trace(a) + trace(b))) < sptol failed.")
    end subroutine test_trace_csp

    subroutine test_trace_cdp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        complex(dp) :: a(n,n), ans
        complex(dp), parameter :: i_ = cmplx(0,1,kind=dp)
        integer :: j

        a = reshape([(j + (n**2 - (j-1))*i_,j=1,n**2)],[n,n])
        ans = cmplx(15,15,kind=dp) !(1 + 5 + 9) + (9 + 5 + 1)i

        call check(error, abs(trace(a) - ans) < dptol, &
            "abs(trace(a) - ans) < dptol failed.")
    end subroutine test_trace_cdp

    subroutine test_trace_cqp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        complex(qp) :: a(n,n)
        complex(qp), parameter :: i_ = cmplx(0,1,kind=qp)

        a = 3*eye(n) + 4*eye(n)*i_ ! pythagorean triple
        call check(error, abs(trace(a)) - 3*5.0_qp < qptol, &
            "abs(trace(a)) - 3*5.0_qp < qptol failed.")
    end subroutine test_trace_cqp

    subroutine test_trace_int8(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        integer(int8) :: a(n,n)
        integer :: i

        a = reshape([(i**2,i=1,n**2)],[n,n])
        call check(error, trace(a) == (1 + 25 + 81), &
            "trace(a) == (1 + 25 + 81) failed.")
    end subroutine test_trace_int8

    subroutine test_trace_int16(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        integer(int16) :: a(n,n)
        integer :: i

        a = reshape([(i**3,i=1,n**2)],[n,n])
        call check(error, trace(a) == (1 + 125 + 729), &
            "trace(a) == (1 + 125 + 729) failed.")
    end subroutine test_trace_int16

    subroutine test_trace_int32(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 3
        integer(int32) :: a(n,n)
        integer :: i

        a = reshape([(i**4,i=1,n**2)],[n,n])
        call check(error, trace(a) == (1 + 625 + 6561), &
            "trace(a) == (1 + 625 + 6561) failed.")
    end subroutine test_trace_int32

    subroutine test_trace_int64(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 5
        integer, parameter :: nd = 2*n-1 ! number of diagonals
        integer :: i, j
        integer(int64) :: c(0:nd), H(n,n)

        ! Fill array with Catalan numbers
        do i = 0, nd
            c(i) = catalan_number(i)
        end do

        ! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1)
        do i = 1, n
            do j = 1, n
                H(i,j) = c(i-1 + (j-1))
            end do
        end do

        call check(error, trace(h) == sum(c(0:nd:2)), &
            "trace(h) == sum(c(0:nd:2)) failed.")

    end subroutine test_trace_int64

    subroutine test_outer_product_rsp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        real(sp) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [1.,2.]
        v = [1.,3.]
        expected = reshape([1.,2.,3.,6.],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) < sptol), &
            "all(abs(diff) < sptol) failed.")
    end subroutine test_outer_product_rsp

    subroutine test_outer_product_rdp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        real(dp) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [1.,2.]
        v = [1.,3.]
        expected = reshape([1.,2.,3.,6.],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) < dptol), &
            "all(abs(diff) < dptol) failed.")
    end subroutine test_outer_product_rdp

    subroutine test_outer_product_rqp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        real(qp) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [1.,2.]
        v = [1.,3.]
        expected = reshape([1.,2.,3.,6.],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) < qptol), &
            "all(abs(diff) < qptol) failed.")
    end subroutine test_outer_product_rqp

    subroutine test_outer_product_csp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        complex(sp) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [cmplx(1.,1.),cmplx(2.,0.)]
        v = [cmplx(1.,0.),cmplx(3.,1.)]
        expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) < sptol), &
            "all(abs(diff) < sptol) failed.")
    end subroutine test_outer_product_csp

    subroutine test_outer_product_cdp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        complex(dp) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [cmplx(1.,1.),cmplx(2.,0.)]
        v = [cmplx(1.,0.),cmplx(3.,1.)]
        expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) < dptol), &
            "all(abs(diff) < dptol) failed.")
    end subroutine test_outer_product_cdp

    subroutine test_outer_product_cqp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        complex(qp) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [cmplx(1.,1.),cmplx(2.,0.)]
        v = [cmplx(1.,0.),cmplx(3.,1.)]
        expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) < qptol), &
            "all(abs(diff) < qptol) failed.")
    end subroutine test_outer_product_cqp

    subroutine test_outer_product_int8(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        integer(int8) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [1,2]
        v = [1,3]
        expected = reshape([1,2,3,6],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) == 0), &
            "all(abs(diff) == 0) failed.")
    end subroutine test_outer_product_int8

    subroutine test_outer_product_int16(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        integer(int16) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [1,2]
        v = [1,3]
        expected = reshape([1,2,3,6],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) == 0), &
            "all(abs(diff) == 0) failed.")
    end subroutine test_outer_product_int16

    subroutine test_outer_product_int32(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        integer(int32) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [1,2]
        v = [1,3]
        expected = reshape([1,2,3,6],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) == 0), &
            "all(abs(diff) == 0) failed.")
    end subroutine test_outer_product_int32

    subroutine test_outer_product_int64(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 2
        integer(int64) :: u(n), v(n), expected(n,n), diff(n,n)

        u = [1,2]
        v = [1,3]
        expected = reshape([1,2,3,6],[n,n])
        diff = expected - outer_product(u,v)
        call check(error, all(abs(diff) == 0), &
            "all(abs(diff) == 0) failed.")
    end subroutine test_outer_product_int64

    pure recursive function catalan_number(n) result(value)
        integer, intent(in) :: n
        integer :: value
        integer :: i
        if (n <= 1) then
            value = 1
        else
            value = 0
            do i = 0, n-1
                value = value + catalan_number(i)*catalan_number(n-i-1)
            end do
        end if
    end function

end module

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

    stat = 0

    testsuites = [ &
        new_testsuite("linalg", collect_linalg) &
        ]

    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


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This example calculates the divergency of a random field using
!   (1) global transposition
!   (2) halo-cell exchange
! The two method should give identical results
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program halo_test

  use decomp_2d
  use decomp_2d_io

  implicit none

  integer, parameter :: nx=171, ny=132, nz=113
  integer, parameter :: p_row=4, p_col=3

  real(mytype), allocatable, dimension(:,:,:) :: u1, u2, u3
  real(mytype), allocatable, dimension(:,:,:) :: v1, v2, v3
  real(mytype), allocatable, dimension(:,:,:) :: w1, w2, w3
  real(mytype), allocatable, dimension(:,:,:) :: wk2, wk3
  real(mytype), allocatable, dimension(:,:,:) :: uh, vh, wh
  real(mytype), allocatable, dimension(:,:,:) :: div1, div2, div3, div4

  integer :: i,j,k, ierror, n

  integer, allocatable, dimension(:) :: seed

  call MPI_INIT(ierror)
  call decomp_2d_init(nx,ny,nz,p_row,p_col)

  ! initialise u,v,w with random numbers in X-pencil
#ifdef HALO_GLOBAL
  allocate(u1(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
  allocate(v1(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
  allocate(w1(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
#else
  allocate(u1(xsize(1), xsize(2), xsize(3)))
  allocate(v1(xsize(1), xsize(2), xsize(3)))
  allocate(w1(xsize(1), xsize(2), xsize(3)))
#endif

  call random_seed(size = n)
  allocate(seed(n))
  seed = nrank
  call random_seed(put=seed)
  call random_number(u1)
  call random_number(v1)
  call random_number(w1)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Calculate divergency using global transposition
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! du/dx calculated on X-pencil
#ifdef HALO_GLOBAL
  allocate(div1(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
#else
  allocate(div1(xsize(1), xsize(2), xsize(3)))
#endif

  div1 = 0.

#ifdef HALO_GLOBAL
  do k=xstart(3),xend(3)
     do j=xstart(2),xend(2)
#else
  do k=1,xsize(3)
     do j=1,xsize(2)
#endif
        do i=2,xsize(1)-1
           div1(i,j,k) = u1(i+1,j,k)-u1(i-1,j,k)
        end do
     end do
  end do

  ! dv/dy calculated on Y-pencil
#ifdef HALO_GLOBAL
  allocate(v2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
  allocate(wk2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
#else
  allocate(v2(ysize(1), ysize(2), ysize(3)))
  allocate(wk2(ysize(1), ysize(2), ysize(3)))
#endif
  call transpose_x_to_y(v1,v2)
  call transpose_x_to_y(div1,wk2)
#ifdef HALO_GLOBAL
  do k=ystart(3),yend(3)
     do i=ystart(1),yend(1)
#else
  do k=1,ysize(3)
     do i=1,ysize(1)
#endif
        do j=2,ysize(2)-1
           wk2(i,j,k) = wk2(i,j,k) + v2(i,j+1,k)-v2(i,j-1,k)
        end do
     end do
  end do

  ! dw/dz calculated on Z-pencil
#ifdef HALO_GLOBAL
  allocate(w2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
  allocate(w3(zstart(1):zend(1), zstart(2):zend(2), zstart(3):zend(3)))
  allocate(wk3(zstart(1):zend(1), zstart(2):zend(2), zstart(3):zend(3)))
#else
  allocate(w2(ysize(1), ysize(2), ysize(3)))
  allocate(w3(zsize(1), zsize(2), zsize(3)))
  allocate(wk3(zsize(1), zsize(2), zsize(3)))
#endif
  call transpose_x_to_y(w1,w2)
  call transpose_y_to_z(w2,w3)
  call transpose_y_to_z(wk2,wk3)
#ifdef HALO_GLOBAL
  do j=zstart(2),zend(2)
     do i=zstart(1),zend(1)
#else
  do j=1,zsize(2)
     do i=1,zsize(1)
#endif
        do k=2,zsize(3)-1
           wk3(i,j,k) = wk3(i,j,k) + w3(i,j,k+1)-w3(i,j,k-1)
        end do
     end do
  end do

  ! result in X-pencil
  call transpose_z_to_y(wk3,wk2)
  call transpose_y_to_x(wk2,div1)

  if (nrank==0) then
     write(*,*) 'Calculated via global transposition'
     write(*,*) (div1(i,i,i), i=2,13)
  end if
#ifdef HALO_GLOBAL
  call decomp_2d_write_one(1,div1,'div1g.dat')
#else
  call decomp_2d_write_one(1,div1,'div1.dat')
#endif

  deallocate(v2,w2,w3,wk2,wk3)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Calculate divergency using halo-cell exchange (data in X-pencil)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

#ifdef HALO_GLOBAL
  allocate(div2(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
#else
  allocate(div2(xsize(1), xsize(2), xsize(3)))
#endif
  ! du/dx
#ifdef HALO_GLOBAL
  do k=xstart(3),xend(3)
     do j=xstart(2),xend(2)
#else
  do k=1,xsize(3)
     do j=1,xsize(2)
#endif
        do i=2,xsize(1)-1
           div2(i,j,k) = u1(i+1,j,k)-u1(i-1,j,k)
        end do
     end do
  end do

  ! dv/dy
#ifdef HALO_GLOBAL
  call update_halo(v1,vh,1,opt_global=.true.)
#else
  call update_halo(v1,vh,1)
#endif
#ifdef HALO_GLOBAL
  do k=xstart(3),xend(3)
     do j=xstart(2),xend(2)
#else
  do k=1,xsize(3)
     do j=1,xsize(2)
#endif
        do i=2,xsize(1)-1
           div2(i,j,k) = div2(i,j,k) + vh(i,j+1,k)-vh(i,j-1,k)
        end do
     end do
  end do

  ! dw/dz
#ifdef HALO_GLOBAL
  call update_halo(w1,wh,1,opt_global=.true.)
#else
  call update_halo(w1,wh,1)
#endif
#ifdef HALO_GLOBAL
  do k=xstart(3),xend(3)
     do j=xstart(2),xend(2)
#else
  do k=1,xsize(3)
     do j=1,xsize(2)
#endif
        do i=2,xsize(1)-1
           div2(i,j,k) = div2(i,j,k) + wh(i,j,k+1)-wh(i,j,k-1)
        end do
     end do
  end do

  if (nrank==0) then
     write(*,*) '-----------------------------------------------'
     write(*,*) 'Calculated via halo exchange (data in X-pencil)'
     write(*,*) (div2(i,i,i), i=2,13)
  end if
#ifdef HALO_GLOBAL
  call decomp_2d_write_one(1,div1,'div2g.dat')
#else
  call decomp_2d_write_one(1,div1,'div2.dat')
#endif

  deallocate(vh,wh)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Calculate divergency using halo-cell exchange (data in Y-pencil)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

#ifdef HALO_GLOBAL
  allocate(u2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
  allocate(v2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
  allocate(w2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
#else
  allocate(u2(ysize(1), ysize(2), ysize(3)))
  allocate(v2(ysize(1), ysize(2), ysize(3)))
  allocate(w2(ysize(1), ysize(2), ysize(3)))
#endif
  call transpose_x_to_y(u1,u2)
  call transpose_x_to_y(v1,v2)
  call transpose_x_to_y(w1,w2)

#ifdef HALO_GLOBAL
  allocate(div3(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
  allocate(wk2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
#else
  allocate(div3(xsize(1), xsize(2), xsize(3)))
  allocate(wk2(ysize(1), ysize(2), ysize(3)))
#endif

  ! du/dx
#ifdef HALO_GLOBAL
  call update_halo(u2,uh,1,opt_global=.true.)
#else
  call update_halo(u2,uh,1)
#endif
#ifdef HALO_GLOBAL
  do k=ystart(3),yend(3)
     do i=ystart(1),yend(1)
#else
  do k=1,ysize(3)
     do i=1,ysize(1)
#endif
        do j=2,ysize(2)-1
           wk2(i,j,k) = uh(i+1,j,k)-uh(i-1,j,k)
        end do
     end do
  end do

  ! dv/dy
#ifdef HALO_GLOBAL
  do k=ystart(3),yend(3)
     do i=ystart(1),yend(1)
#else
  do k=1,ysize(3)
     do i=1,ysize(1)
#endif
        do j=2,ysize(2)-1
           wk2(i,j,k) = wk2(i,j,k) + v2(i,j+1,k)-v2(i,j-1,k)
        end do
     end do
  end do

  ! dw/dz
#ifdef HALO_GLOBAL
  call update_halo(w2,wh,1,opt_global=.true.)
#else
  call update_halo(w2,wh,1)
#endif
#ifdef HALO_GLOBAL
  do k=ystart(3),yend(3)
     do i=ystart(1),yend(1)
#else
  do k=1,ysize(3)
     do i=1,ysize(1)
#endif
        do j=2,ysize(2)-1
           wk2(i,j,k) = wk2(i,j,k) + wh(i,j,k+1)-wh(i,j,k-1)
        end do
     end do
  end do

  call transpose_y_to_x(wk2,div3)

  if (nrank==0) then
     write(*,*) '-----------------------------------------------'
     write(*,*) 'Calculated via halo exchange (data in Y-pencil)'
     write(*,*) (div3(i,i,i), i=2,13)
  end if
#ifdef HALO_GLOBAL
  call decomp_2d_write_one(1,div1,'div3g.dat')
#else
  call decomp_2d_write_one(1,div1,'div3.dat')
#endif

  deallocate(uh,wh,wk2)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Calculate divergency using halo-cell exchange (data in Z-pencil)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

#ifdef HALO_GLOBAL
  allocate(u3(zstart(1):zend(1), zstart(2):zend(2), zstart(3):zend(3)))
  allocate(v3(zstart(1):zend(1), zstart(2):zend(2), zstart(3):zend(3)))
  allocate(w3(zstart(1):zend(1), zstart(2):zend(2), zstart(3):zend(3)))
#else
  allocate(u3(zsize(1), zsize(2), zsize(3)))
  allocate(v3(zsize(1), zsize(2), zsize(3)))
  allocate(w3(zsize(1), zsize(2), zsize(3)))
#endif
  call transpose_y_to_z(u2,u3)
  call transpose_y_to_z(v2,v3)
  call transpose_y_to_z(w2,w3)

#ifdef HALO_GLOBAL
  allocate(div4(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
  allocate(wk2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
  allocate(wk3(zstart(1):zend(1), zstart(2):zend(2), zstart(3):zend(3)))
#else
  allocate(div4(xsize(1), xsize(2), xsize(3)))
  allocate(wk2(ysize(1), ysize(2), ysize(3)))
  allocate(wk3(zsize(1), zsize(2), zsize(3)))
#endif

  ! du/dx
#ifdef HALO_GLOBAL
  call update_halo(u3,uh,1,opt_global=.true.)
#else
  call update_halo(u3,uh,1)
#endif
#ifdef HALO_GLOBAL
  do j=zstart(2),zend(2)
     do i=zstart(1),zend(1)
#else
  do j=1,zsize(2)
     do i=1,zsize(1)
#endif
        do k=2,zsize(3)-1
           wk3(i,j,k) = uh(i+1,j,k)-uh(i-1,j,k)
        end do
     end do
  end do

  ! dv/dy
#ifdef HALO_GLOBAL
  call update_halo(v3,vh,1,opt_global=.true.)
#else
  call update_halo(v3,vh,1)
#endif
#ifdef HALO_GLOBAL
  do j=zstart(2),zend(2)
     do i=zstart(1),zend(1)
#else
  do j=1,zsize(2)
     do i=1,zsize(1)
#endif
        do k=2,zsize(3)-1
           wk3(i,j,k) = wk3(i,j,k) + vh(i,j+1,k)-vh(i,j-1,k)
        end do
     end do
  end do

  ! dw/dz
#ifdef HALO_GLOBAL
  do j=zstart(2),zend(2)
     do i=zstart(1),zend(1)
#else
  do j=1,zsize(2)
     do i=1,zsize(1)
#endif
        do k=2,zsize(3)-1
           wk3(i,j,k) = wk3(i,j,k) + w3(i,j,k+1)-w3(i,j,k-1)
        end do
     end do
  end do

  call transpose_z_to_y(wk3,wk2)
  call transpose_y_to_x(wk2,div4)

  if (nrank==0) then
     write(*,*) '-----------------------------------------------'
     write(*,*) 'Calculated via halo exchange (data in Z-pencil)'
     write(*,*) (div4(i,i,i), i=2,13)
  end if
#ifdef HALO_GLOBAL
  call decomp_2d_write_one(1,div1,'div4g.dat')
#else
  call decomp_2d_write_one(1,div1,'div4.dat')
#endif

  deallocate(uh,vh,wk2,wk3,u1,v1,w1,u2,v2,w2,u3,v3,w3)

  deallocate(div1,div2,div3,div4)

  call decomp_2d_finalize
  call MPI_FINALIZE(ierror)

end program halo_test


subroutine remeshing()

common/ray/ nodes,xray(1000),yray(1000),zray(1000)
real xtmp(1000),ytmp(1000),ztmp(1000)
common/ray_param/ds_ini

ntmp=nodes
xtmp=xray
ytmp=yray
ztmp=zray

nodes=0

do inode=1,ntmp-1
	x1=xtmp(inode)
	x2=xtmp(inode+1)

	y1=ytmp(inode)
	y2=ytmp(inode+1)

	z1=ztmp(inode)
	z2=ztmp(inode+1)

	dz1=ztmp(inode)
	dz2=ztmp(inode+1)

	nodes=nodes+1
	xray(nodes)=x1
	yray(nodes)=y1
	zray(nodes)=z1

	ds=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)+(z2-z1)*(z2-z1))
	!write(*,*)' normal: ',ds,xray(nodes),yray(nodes),zray(nodes)

	if(ds.gt.ds_ini*1.5) then
		nmid = ds/ds_ini + 1
		dsmid = ds/nmid
		do imid=1,nmid-1

			xmid=x1+((x2-x1)/ds)*(dsmid*imid)
			ymid=y1+((y2-y1)/ds)*(dsmid*imid)
			zmid=z1+((z2-z1)/ds)*(dsmid*imid)

			nodes=nodes+1
			xray(nodes)=xmid
			yray(nodes)=ymid
			zray(nodes)=zmid
		!write(*,*)'  mid: ',dsmid,xray(nodes),yray(nodes),zray(nodes)
		end do
	end if
end do

nodes=nodes+1
xray(nodes)=xtmp(ntmp)
yray(nodes)=ytmp(ntmp)
zray(nodes)=ztmp(ntmp)

return
end