module IntegratorM
  use UtilitiesM
  use DebuggerM
  implicit none
  private
  public :: IntegratorDT, integrator
  type :: IntegratorDT
     integer(ikind)                               :: gaussOrder
     integer(ikind)                               :: integTerms
     real(rkind), dimension(:)      , allocatable :: weight
     real(rkind), dimension(:,:)    , allocatable :: gPoint
     real(rkind), dimension(:,:)    , allocatable :: shapeFunc
     real(rkind), dimension(:,:,:)  , allocatable :: dShapeFunc
     real(rkind), dimension(:,:,:,:), allocatable :: ddShapeFunc
   contains
     procedure, public  :: init
     procedure, public  :: valueGPoints
     procedure, private :: getG1D
     procedure, private :: getGTriangle
     procedure, private :: getGSquare
     procedure, private :: getGTetrahedron
     procedure, private :: getGHexahedron

     procedure, public :: getGaussOrder
     procedure, public :: getIntegTerms
     procedure, public :: getWeight
     procedure, public :: getGPoint
     procedure, public :: getShapeFunc
     procedure, public :: getDShapeFunc
     procedure, public :: getDDShapeFunc
     procedure, public :: getWeightFull
     procedure, public :: getGPointFull
     procedure, public :: getShapeFuncFull
     procedure, public :: getDShapeFuncFull
     procedure, public :: getDDShapeFuncFull
  end type IntegratorDT

  interface integrator
     procedure constructor
  end interface integrator

contains

  type(IntegratorDT) function constructor(gaussOrder, type)
    implicit none
    integer(ikind), intent(in) :: gaussOrder
    character(*), intent(in) :: type
    call constructor%init(gaussOrder, type)
  end function constructor

  subroutine init(this, gaussOrder, type)
    implicit none
    class(IntegratorDT), intent(inout) :: this
    integer(ikind), intent(in) :: gaussOrder
    character(*), intent(in) :: type
    this%gaussOrder = gaussOrder
    call this%valueGPoints(type)
  end subroutine init

  subroutine valueGPoints(this, type)
    implicit none
    class(IntegratorDT), intent(inout) :: this
    character(*), intent(in) :: type
    if     (trim(type) == 'Line'          .or. &
            trim(type) == 'line'          .or. &
            trim(type) == 'LINE')           then
       call this%getG1D()
    else if(trim(type) == 'Triangle'      .or. &
            trim(type) == 'triangle'      .or. &
            trim(type) == 'triang'        .or. &
            trim(type) == 'TRIANGLE')       then
       call this%getGTriangle()
    else if(trim(type) == 'Quadrilateral' .or. &
            trim(type) == 'quadrilateral' .or. &
            trim(type) == 'QUADRILATERAL' .or. &
            trim(type) == 'quad')           then
       call this%getGSquare()
    else if(trim(type) == 'Tetrahedron'   .or. &
            trim(type) == 'tetrahedron'   .or. &
            trim(type) == 'TETRAHEDRON'   .or. &
            trim(type) == 'tetra')          then
       call this%getGTetrahedron()
    else if(trim(type) == 'Hexahedron'    .or. &
            trim(type) == 'hexahedron'    .or. &
            trim(type) == 'HEXAHEDRON'    .or. &
            trim(type) == 'hexa')           then
       call this%getGHexahedron()
    end if
  end subroutine valueGPoints

  subroutine getG1D(this)
    implicit none
    class(IntegratorDT), intent(inout) :: this
    real(rkind), parameter :: pi = dacos(-1._rkind)
    real(rkind) :: f, df, dx, r
    integer(ikind) :: i, j, iter, k, counter
    real(rkind), dimension(:), allocatable :: p0, p1, tmp
    real(rkind), dimension(:,:), allocatable :: G
    this%integTerms = this%gaussOrder
    allocate(G(2,this%gaussOrder))
    p0 = [1._rkind]
    p1 = [1._rkind, 0._rkind]
    do k = 2, this%gaussOrder
       tmp = ((2*k-1)*[p1,0._rkind]-(k-1)*[0._rkind, 0._rkind,p0])/k
       p0 = p1; p1 = tmp
    end do
    do i = 1, this%gaussOrder
       r = cos(pi*(i-0.25)/(this%gaussOrder+0.5))
       do iter = 1, 10
          f = p1(1); df = 0.
          do k = 2, size(p1)
             df = f + r*df
             f  = p1(k) + r * f
          end do
          dx =  f / df
          r = r - dx
          if (abs(dx)<10*epsilon(dx)) exit
       end do
       G(1,i) = r
       G(2,i) = 2/((1-r**2)*df**2)
    end do
    allocate(this%weight(this%integTerms))
    allocate(this%gPoint(this%integTerms,1))
    this%weight(:) = G(2,:)
    this%gPoint(:,1) = G(1,:)
    call debugLog('        Allocated weights: ', size(this%weight))
    call debugLog('        Allocated gPoints: ', size(this%gPoint))
    deallocate(G)
  end subroutine getG1D

  subroutine getGTriangle(this)
    implicit none
    class(IntegratorDT), intent(inout) :: this
    if(this%gaussOrder == 1) then
       this%integTerms  = 1
       allocate(this%weight(this%integTerms))
       allocate(this%gPoint(this%integTerms,2))
       this%weight(1)   = 1._rkind/2._rkind
       this%gPoint(1,1) = 1._rkind/3._rkind
       this%gPoint(1,2) = 1._rkind/3._rkind
    else if(this%gaussOrder == 2) then
       this%integTerms  = 3
       allocate(this%weight(this%integTerms))
       allocate(this%gPoint(this%integTerms,2))
       this%weight(1)   = 1._rkind/6._rkind
       this%weight(2)   = 1._rkind/6._rkind
       this%weight(3)   = 1._rkind/6._rkind
       this%gPoint(1,1) = 1._rkind/2._rkind
       this%gPoint(1,2) = 0._rkind
       this%gPoint(2,1) = 1._rkind/2._rkind
       this%gPoint(2,2) = 1._rkind/2._rkind
       this%gPoint(3,1) = 0._rkind
       this%gPoint(3,2) = 1._rkind/2._rkind
    else if(this%gaussOrder == 3) then
       this%integTerms  = 4
       allocate(this%weight(this%integTerms))
       allocate(this%gPoint(this%integTerms,2))
       this%weight(1)   = -27._rkind/96._rkind
       this%weight(2)   = 25._rkind/96._rkind
       this%weight(3)   = 25._rkind/96._rkind
       this%weight(4)   = 25._rkind/96._rkind
       this%gPoint(1,1) = 1._rkind/3._rkind
       this%gPoint(1,2) = 1._rkind/3._rkind
       this%gPoint(2,1) = 1._rkind/5._rkind
       this%gPoint(2,2) = 1._rkind/5._rkind
       this%gPoint(3,1) = 3._rkind/5._rkind
       this%gPoint(3,2) = 1._rkind/5._rkind
       this%gPoint(4,1) = 1._rkind/5._rkind
       this%gPoint(4,2) = 3._rkind/5._rkind
    else
       print'(A)', '** Input Gauss Order not supported for triangular elements! **'
    end if
    call debugLog('        Allocated weights: ', size(this%weight))
    call debugLog('        Allocated gPoints: ', size(this%gPoint))
  end subroutine getGTriangle

  subroutine getGSquare(this)
    implicit none
    class(IntegratorDT), intent(inout) :: this
    real(rkind), parameter :: pi = dacos(-1._rkind)
    real(rkind) :: f, df, dx, r
    integer(ikind) :: i, j, iter, k, counter
    real(rkind), dimension(:), allocatable :: p0, p1, tmp
    real(rkind), dimension(:,:), allocatable :: G
    this%integTerms = this%gaussOrder**2
    allocate(G(2,this%gaussOrder))
    p0 = [1._rkind]
    p1 = [1._rkind, 0._rkind]
    do k = 2, this%gaussOrder
       tmp = ((2*k-1)*[p1,0._rkind]-(k-1)*[0._rkind, 0._rkind,p0])/k
       p0 = p1; p1 = tmp
    end do
    do i = 1, this%gaussOrder
       r = cos(pi*(i-0.25)/(this%gaussOrder+0.5))
       do iter = 1, 10
          f = p1(1); df = 0.
          do k = 2, size(p1)
             df = f + r*df
             f  = p1(k) + r * f
          end do
          dx =  f / df
          r = r - dx
          if (abs(dx)<10*epsilon(dx)) exit
       end do
       G(1,i) = r
       G(2,i) = 2/((1-r**2)*df**2)
    end do
    allocate(this%weight(this%integTerms))
    allocate(this%gPoint(this%integTerms,2))
    counter = 0
    do i = 1, this%gaussOrder
       do j = 1, this%gaussOrder
          counter = counter + 1
          this%weight(counter) = G(2,i)*G(2,j)
          this%gPoint(counter,1) = G(1,i)
          this%gPoint(counter,2) = G(1,j)
       end do
    end do
    call debugLog('        Allocated weights: ', size(this%weight))
    call debugLog('        Allocated gPoints: ', size(this%gPoint))
    deallocate(G)
  end subroutine getGSquare

  subroutine getGTetrahedron(this)
    implicit none
    class(IntegratorDT), intent(inout) :: this
    if(this%gaussOrder == 1) then
       this%integTerms  = 1
       allocate(this%weight(this%integTerms))
       allocate(this%gPoint(this%integTerms,3))
       this%weight(1)   = 1
       this%gPoint(1,1) = .25
       this%gPoint(1,2) = .25
       this%gPoint(1,3) = .25
    else if(this%gaussOrder == 2) then
       this%integTerms  = 5
       allocate(this%weight(this%integTerms))
       allocate(this%gPoint(this%integTerms,3))
       this%weight(1)   = -.8
       this%weight(2)   = .45
       this%weight(3)   = .45
       this%weight(4)   = .45
       this%weight(5)   = .45
       this%gPoint(1,1) = .25
       this%gPoint(1,2) = .25
       this%gPoint(1,3) = .25
       this%gPoint(2,1) = .166666666666667
       this%gPoint(2,2) = .166666666666667
       this%gPoint(2,3) = .166666666666667
       this%gPoint(3,1) = .5
       this%gPoint(3,2) = .166666666666667
       this%gPoint(3,3) = .166666666666667
       this%gPoint(4,1) = .166666666666667
       this%gPoint(4,2) = .5
       this%gPoint(4,3) = .166666666666667
       this%gPoint(5,1) = .166666666666667
       this%gPoint(5,2) = .166666666666667
       this%gPoint(5,3) = .5
    else if(this%gaussOrder == 3) then
       this%integTerms  = 11
       allocate(this%weight(this%integTerms))
       allocate(this%gPoint(this%integTerms,3))
       this%weight(1)   = 0.013155555555555
       this%weight(2)   = 0.007622222222222
       this%weight(3)   = 0.007622222222222
       this%weight(4)   = 0.007622222222222
       this%weight(5)   = 0.007622222222222
       this%weight(6)   = 0.024888888888888
       this%weight(7)   = 0.024888888888888
       this%weight(8)   = 0.024888888888888
       this%weight(9)   = 0.024888888888888
       this%weight(10)  = 0.024888888888888
       this%weight(11)  = 0.024888888888888
       this%gPoint(1,1) = .25
       this%gPoint(1,2) = .25
       this%gPoint(1,3) = .25
       this%gPoint(2,1) = .0714285714285714
       this%gPoint(2,2) = .0714285714285714
       this%gPoint(2,3) = .785714285714286
       this%gPoint(3,1) = .0714285714285714
       this%gPoint(3,2) = .0714285714285714
       this%gPoint(3,3) = .0714285714285714
       this%gPoint(4,1) = .785714285714286
       this%gPoint(4,2) = .0714285714285714
       this%gPoint(4,3) = .0714285714285714
       this%gPoint(5,1) = .0714285714285714
       this%gPoint(5,2) = .785714285714286
       this%gPoint(5,3) = .0714285714285714
       this%gPoint(6,1) = 0.399403576166799
       this%gPoint(6,2) = 0.100596423833201
       this%gPoint(6,3) = 0.100596423833201
       this%gPoint(7,1) = 0.399403576166799
       this%gPoint(7,2) = 0.399403576166799
       this%gPoint(7,3) = 0.100596423833201
       this%gPoint(8,1) = 0.100596423833201
       this%gPoint(8,2) = 0.399403576166799
       this%gPoint(8,3) = 0.399403576166799
       this%gPoint(9,1) = 0.100596423833201
       this%gPoint(9,2) = 0.100596423833201
       this%gPoint(9,3) = 0.399403576166799
       this%gPoint(10,1) = 0.100596423833201
       this%gPoint(10,2) = 0.399403576166799
       this%gPoint(10,3) = 0.100596423833201
       this%gPoint(11,1) = 0.399403576166799
       this%gPoint(11,2) = 0.100596423833201
       this%gPoint(11,3) = 0.399403576166799
    else
       print'(A)', '** Input Gauss Order not supported for tetrahedral elements! **'
    end if
    call debugLog('        Allocated weights: ', size(this%weight))
    call debugLog('        Allocated gPoints: ', size(this%gPoint))
  end subroutine getGTetrahedron

  subroutine getGHexahedron(this)
    implicit none
    class(IntegratorDT), intent(inout) :: this
    real(rkind), parameter :: pi = dacos(-1._rkind)
    real(rkind) :: f, df, dx, r
    integer(ikind) :: i, j, iter, k, counter
    real(rkind), dimension(:), allocatable :: p0, p1, tmp
    real(rkind), dimension(:,:), allocatable :: G
    this%integTerms = this%gaussOrder**3
    allocate(G(2,this%gaussOrder))
    p0 = [1._rkind]
    p1 = [1._rkind, 0._rkind]
    do k = 2, this%gaussOrder
       tmp = ((2*k-1)*[p1,0._rkind]-(k-1)*[0._rkind, 0._rkind,p0])/k
       p0 = p1; p1 = tmp
    end do
    do i = 1, this%gaussOrder
       r = cos(pi*(i-0.25)/(this%gaussOrder+0.5))
       do iter = 1, 10
          f = p1(1); df = 0.
          do k = 2, size(p1)
             df = f + r*df
             f  = p1(k) + r * f
          end do
          dx =  f / df
          r = r - dx
          if (abs(dx)<10*epsilon(dx)) exit
       end do
       G(1,i) = r
       G(2,i) = 2/((1-r**2)*df**2)
    end do
    allocate(this%weight(this%integTerms))
    allocate(this%gPoint(this%integTerms,3))
    counter = 0
    do i = 1, this%gaussOrder
       do j = 1, this%gaussOrder
          do k = 1, this%gaussOrder
             counter = counter + 1
             this%weight(counter) = G(2,i)*G(2,j)*G(2,k)
             this%gPoint(counter,1) = G(1,i)
             this%gPoint(counter,2) = G(1,j)
             this%gPoint(counter,3) = G(1,k)
          end do
       end do
    end do
    call debugLog('        Allocated weights: ', size(this%weight))
    call debugLog('        Allocated gPoints: ', size(this%gPoint))
    deallocate(G)
  end subroutine getGHexahedron

  integer(ikind) pure function getGaussOrder(this)
    implicit none
    class(IntegratorDT), intent(in) :: this
    getGaussOrder = this%gaussOrder
  end function getGaussOrder

  integer(ikind) pure function getIntegTerms(this)
    implicit none
    class(IntegratorDT), intent(in) :: this
    getIntegTerms = this%integTerms
  end function getIntegTerms

  real(rkind) pure function getWeight(this, i)
    implicit none
    class(IntegratorDT), intent(in) :: this
    integer(ikind)     , intent(in) :: i
    getWeight = this%weight(i)
  end function getWeight

  real(rkind) pure function getGPoint(this, i, j)
    implicit none
    class(IntegratorDT), intent(in) :: this
    integer(ikind)     , intent(in) :: i
    integer(ikind)     , intent(in) :: j
    getGPoint = this%gPoint(i,j)
  end function getGPoint

  real(rkind) pure function getShapeFunc(this, i, j)
    implicit none
    class(IntegratorDT), intent(in) :: this
    integer(ikind)     , intent(in) :: i
    integer(ikind)     , intent(in) :: j
    getShapeFunc = this%shapeFunc(i,j)
  end function getShapeFunc

  real(rkind) pure function getDShapeFunc(this, i, j, k)
    implicit none
    class(IntegratorDT), intent(in) :: this
    integer(ikind)     , intent(in) :: i
    integer(ikind)     , intent(in) :: j
    integer(ikind)     , intent(in) :: k
    getDShapeFunc = this%dShapeFunc(i,j,k)
  end function getDShapeFunc

  real(rkind) pure function getDDShapeFunc(this, i, j, k, l)
    implicit none
    class(IntegratorDT), intent(in) :: this
    integer(ikind)     , intent(in) :: i
    integer(ikind)     , intent(in) :: j
    integer(ikind)     , intent(in) :: k
    integer(ikind)     , intent(in) :: l
    getDDShapeFunc = this%ddShapeFunc(i,j,k,l)
  end function getDDShapeFunc

  pure function getWeightFull(this)
    implicit none
    class(IntegratorDT)              , intent(in)  :: this
    real(rkind)        , dimension(:), allocatable :: getWeightFull
    getWeightFull = this%weight
  end function getWeightFull

  pure function getGPointFull(this)
    implicit none
    class(IntegratorDT)                , intent(in)  :: this
    real(rkind)        , dimension(:,:), allocatable :: getGPointFull
    getGPointFull = this%gPoint
  end function getGPointFull

  pure function getShapeFuncFull(this)
    implicit none
    class(IntegratorDT)                , intent(in)  :: this
    real(rkind)        , dimension(:,:), allocatable :: getShapeFuncFull
    getShapeFuncFull = this%shapeFunc
  end function getShapeFuncFull

  pure function getDShapeFuncFull(this)
    implicit none
    class(IntegratorDT)                  , intent(in)  :: this
    real(rkind)        , dimension(:,:,:), allocatable :: getDShapeFuncFull
    getDShapeFuncFull = this%dShapeFunc
  end function getDShapeFuncFull

  pure function getDDShapeFuncFull(this)
    implicit none
    class(IntegratorDT)                    , intent(in)  :: this
    real(rkind)        , dimension(:,:,:,:), allocatable :: getDDShapeFuncFull
    getDDShapeFuncFull = this%ddShapeFunc
  end function getDDShapeFuncFull

end module IntegratorM


!>
module SurfaceMap
    use PrecisionMod, only: MK
    implicit none

contains

    ! function ue=fSurfaceIntegral(vX0,vY0,vZ0,Ux,Uy,Uz,n,XCP,YCP,ZCP)
    ! Compute the integral of the source and doublet from a given "Velocity on a Face" using point approximation
    subroutine fUi_PointSourceVortex_surface_mesh(P0,Sigmas,Gammas,Mesh,h)
        !use MathConstants, only: fourpi_inv
        use MeshTypes, only: T_Mesh
        use UIBlobs, only: fUi_Particle_11
        use UIPointSource, only: fUi_PointSource_11
        ! Arguments
        type(T_Mesh), intent(inout)         :: Mesh
        real(MK), dimension(:,:),intent(in) :: P0     !< Position of sources and doublet
        real(MK), dimension(:),intent(in)   :: Sigmas
        real(MK), dimension(:,:),intent(in) :: Gammas
        real(MK),intent(in)                 :: h
        ! Variables
        integer :: im1,im2,im3
        integer :: nm1,nm2,nm3
        integer :: p
        real(MK), dimension(3) :: CP
        real(MK), dimension(3) :: r
        real(MK), dimension(3) :: us
        real(MK), dimension(3) :: uv
        real(MK), dimension(3) :: Uind_cum
        real(MK), dimension(9) :: Grad_cum
        real(MK), dimension(3) :: Uind_tmp
        real(MK), dimension(9) :: Grad_tmp
        real(MK) :: r_norm
        real(MK) :: r3_inv
        real(MK) :: r2_inv
        real(MK) :: factor
        integer :: isd,nsd
        integer :: SmoothModel
        real(MK) :: SmoothParam

        ! Init
        nm1=Mesh%GP%n1
        nm2=Mesh%GP%n2
        nm3=Mesh%GP%n3
        nsd=size(P0,2)

        SmoothParam=1.5*h;

        !$OMP PARALLEL DEFAULT(SHARED)
        !$OMP DO PRIVATE(p,im1,im2,im3,CP,Uind_cum,Grad_cum,Uind_tmp,Grad_tmp,&
        !$OMP& isd,r,r_norm,r3_inv,r2_inv,factor,SmoothModel,us,uv&
        !$OMP& ) schedule(runtime)
        ! Loop on CPs is unrolled
        do p=1,Mesh%nCPs
            ! Mesh indexes
            im1=mod((p-1),nm1)+1
            im2=mod((p-1)/nm1,nm2)+1
            im3=(p-1)/(nm1*nm2)+1
            !
            CP(1:3)=(/Mesh%GP%v1(im1),Mesh%GP%v2(im2),Mesh%GP%v3(im3)/)
            Uind_cum(1:3)=0.0_MK
            Grad_cum(1:9)=0.0_MK

            ! The 'if' below was a safety to avoid the points next to the singularities
            !if(im1>1 .and. im2>1 .and. im3>1 .and. im1<nm1 .and. im2<nm2 .and. im3<nm3) then
                ! Loop on Sources, unrolled
                do isd=1,nsd
                    ! ue=-(un(i01,i02)*r+cross(squeeze(ut(i01,i02,1:3)),r))/(4*pi*r_norm^3)*dS;
                    r(1:3)      = CP(1:3)-P0(1:3,isd)
                    r_norm = sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3))

                    !
                    SmoothModel=1;
                    Uind_tmp(1:3)=0.0_MK
                    Grad_tmp(1:9)=0.0_MK
                    call fUi_PointSource_11(r,Sigmas(isd), SmoothModel, SmoothParam,.true.,Uind_tmp, Grad_tmp)
                    Uind_cum(1:3)= Uind_cum(1:3)+Uind_tmp(1:3)
                    Grad_cum(1:9)= Grad_cum(1:9)+Grad_tmp(1:9)
                    !
                    SmoothModel=2;
                    Uind_tmp(1:3)=0.0_MK
                    Grad_tmp(1:9)=0.0_MK
                    call fUi_Particle_11(r, Gammas(1:3,isd), SmoothModel, SmoothParam, .true., Uind_tmp, Grad_tmp)
                    Uind_cum(1:3)= Uind_cum(1:3)+Uind_tmp(1:3)
                    Grad_cum(1:9)= Grad_cum(1:9)+Grad_tmp(1:9)
!                     if (r_norm>h) then
!                         us(1) = Sigmas(isd)*r(1)  ! 1/(4*pi*r_norm^3)
!                         us(2) = Sigmas(isd)*r(2)  ! 1/(4*pi*r_norm^3)
!                         us(3) = Sigmas(isd)*r(3)  ! 1/(4*pi*r_norm^3)
!                         uv(1) = Gammas(2,isd) * r(3) - Gammas(3,isd) * r(2)
!                         uv(2) = Gammas(3,isd) * r(1) - Gammas(1,isd) * r(3)
!                         uv(3) = Gammas(1,isd) * r(2) - Gammas(2,isd) * r(1)
!                         r3_inv=1._MK/(r_norm**3);
!                         factor=fourpi_inv*r3_inv !1/(4 pi r^3)
!                         Uind_cum(1:3)= Uind_cum(1:3)+(us(1:3)+uv(1:3))*factor
!
!                         r2_inv=1._MK/(r_norm**2);
!                         Grad_cum(1) = Grad_cum(1)+factor*Sigmas(isd)*(1 -3*r(1)*r(1)*r2_inv) ! 11
!                         Grad_cum(2) = Grad_cum(2)+factor*Sigmas(isd)*(  -3*r(2)*r(1)*r2_inv) ! 12
!                         Grad_cum(3) = Grad_cum(3)+factor*Sigmas(isd)*(  -3*r(3)*r(1)*r2_inv) ! 13
!
!                         Grad_cum(4) = Grad_cum(4)+factor*Sigmas(isd)*(  -3*r(1)*r(2)*r2_inv) ! 21
!                         Grad_cum(5) = Grad_cum(5)+factor*Sigmas(isd)*(1 -3*r(2)*r(2)*r2_inv) ! 22
!                         Grad_cum(6) = Grad_cum(6)+factor*Sigmas(isd)*(  -3*r(3)*r(2)*r2_inv) ! 23
!
!                         Grad_cum(7) = Grad_cum(7)+factor*Sigmas(isd)*(  -3*r(1)*r(3)*r2_inv) ! 31
!                         Grad_cum(8) = Grad_cum(8)+factor*Sigmas(isd)*(  -3*r(2)*r(3)*r2_inv) ! 32
!                         Grad_cum(9) = Grad_cum(9)+factor*Sigmas(isd)*(1 -3*r(3)*r(3)*r2_inv) ! 33
!
!                     endif
                enddo
                Mesh%Values(1:3,im1,im2,im3)  = Mesh%Values(1:3,im1,im2,im3)+Uind_cum(1:3)
                Mesh%Values(4:12,im1,im2,im3) = Mesh%Values(4:12,im1,im2,im3)+Grad_cum(1:9)
            !endif
        enddo
        !$OMP END DO
        !$OMP END PARALLEL
    end subroutine
end module SurfaceMap


!
  subroutine make_grid_rect(tetra,verts_rphiz,grid_size,Rmin,Rmax,Zmin,Zmax)
!
  use tetra_grid_mod, only: ntetr,nvert,tetrahedron_grid
  use constants, only: pi
!
  implicit none
!
  type(tetrahedron_grid), dimension(ntetr), intent(out) :: tetra
  double precision,  dimension(3,nvert), intent(out) :: verts_rphiz
  integer, dimension(3), intent(in) :: grid_size
  double precision, intent(in) :: Rmin,Rmax,Zmin,Zmax
  integer :: ir,iphi,iz,iv,itetr,i,j,k,l
  integer :: ind_tetr,ind_tetr1,ind_tetr2,iface1,iface2
  integer :: nvertinner,nper
  integer, dimension(4) :: knots1,knots2
  integer, dimension(3,4,3) :: ivert_prism
  double precision :: hr,hphi,hz,r,phi,z,x,y,s
  double precision :: R_c,Z_c
  double precision, dimension(4)   :: sp,pp,zp
  integer,          dimension(:,:,:),       allocatable :: inodes,itetrbeg
  integer :: nr,nphi,nz
!
  nr = grid_size(1)
  nphi = grid_size(2)
  nz = grid_size(3)
!
! vertices of the first tetrahedron:
! point 1:
  ivert_prism(1,1,1)=0
  ivert_prism(2,1,1)=0
  ivert_prism(3,1,1)=0
! point 2:
  ivert_prism(1,2,1)=1
  ivert_prism(2,2,1)=0
  ivert_prism(3,2,1)=0
! point 3:
  ivert_prism(1,3,1)=0
  ivert_prism(2,3,1)=1
  ivert_prism(3,3,1)=0
! point 4:
  ivert_prism(1,4,1)=0
  ivert_prism(2,4,1)=0
  ivert_prism(3,4,1)=1
!
! vertices of the second tetrahedron:
! point 1:
  ivert_prism(:,1,2)=ivert_prism(:,2,1)
! point 2:
  ivert_prism(:,2,2)=ivert_prism(:,3,1)
! point 3:
  ivert_prism(:,3,2)=ivert_prism(:,4,1)
! point 4:
  ivert_prism(1,4,2)=1
  ivert_prism(2,4,2)=0
  ivert_prism(3,4,2)=1
!
! vertices of the third tetrahedron:
! point 1:
  ivert_prism(:,1,3)=ivert_prism(:,3,1)
! point 2:
  ivert_prism(:,2,3)=ivert_prism(:,4,1)
! point 3:
  ivert_prism(:,3,3)=ivert_prism(:,4,2)
! point 4:
  ivert_prism(1,4,3)=0
  ivert_prism(2,4,3)=1
  ivert_prism(3,4,3)=1
!
  hr=(Rmax-Rmin)/nr
  hphi=2.d0*pi/nphi
  hz=(Zmax-Zmin)/nz
!
  R_c=0.5d0*(Rmax+Rmin)
  Z_c=0.5d0*(Zmax+Zmin)
  nper=0
!
!
  allocate(inodes(0:nr,0:nz,0:nphi))
!
  iv=0
!
  do iphi=0,nphi
    phi=hphi*iphi
    do ir=0,nr
      do iz=0,nz
        r=rmin+hr*ir
        z=zmin+hz*iz
!
        x=(r-R_c)
        y=(z-Z_c)
        r=R_c+x*cos(nper*phi)+y*sin(nper*phi)
        z=Z_c-x*sin(nper*phi)+y*cos(nper*phi)! +hz/3000
        s=r
!
        iv=iv+1
        inodes(ir,iz,iphi)=iv
!
        verts_rphiz(:,iv) = [s,phi,z]
!
      enddo
    enddo
  enddo
!
  allocate(itetrbeg(nr,nz,nphi))
!
  ind_tetr=0
!
  do iphi=1,nphi
    do ir=1,nr
      do iz=1,nz
!
        itetrbeg(ir,iz,iphi)=ind_tetr
!
        do itetr=1,3
          ind_tetr=ind_tetr+1
          do i=1,4
            iv=inodes(ir-1+ivert_prism(1,i,itetr),iz-1+ivert_prism(2,i,itetr),iphi-1+ivert_prism(3,i,itetr))
            tetra(ind_tetr)%ind_knot(i)=iv
            tetra(ind_tetr)%neighbour_tetr(i)=-1
            tetra(ind_tetr)%neighbour_face(i)=-1
            tetra(ind_tetr)%neighbour_perbou_phi(i)=0
          enddo
        enddo
!
        do itetr=1,3
          ind_tetr=ind_tetr+1
          do i=1,4
            iv=inodes(ir-ivert_prism(1,i,itetr),iz-ivert_prism(2,i,itetr),iphi-ivert_prism(3,i,itetr))
            tetra(ind_tetr)%ind_knot(i)=iv
            tetra(ind_tetr)%neighbour_tetr(i)=-1
            tetra(ind_tetr)%neighbour_face(i)=-1
            tetra(ind_tetr)%neighbour_perbou_phi(i)=0
          enddo
        enddo
!
        do i=1,6
          ind_tetr1=itetrbeg(ir,iz,iphi)+i
          do j=1,6
            if(j.eq.i) cycle
            ind_tetr2=itetrbeg(ir,iz,iphi)+j
            call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                 tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
            if(iface1.ne.-1) then
              tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
              tetra(ind_tetr1)%neighbour_face(iface1)=iface2
            endif
          enddo
        enddo
      enddo
    enddo
  enddo
!
!
  do iphi=1,nphi
    do ir=1,nr
      do iz=1,nz
!
        if(ir.gt.1) then
          do i=1,3
            ind_tetr1=itetrbeg(ir,iz,iphi)+i
            do j=4,6
              ind_tetr2=itetrbeg(ir-1,iz,iphi)+j
              call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                   tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
              if(iface1.ne.-1) then
                tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
                tetra(ind_tetr1)%neighbour_face(iface1)=iface2
              endif
            enddo
          enddo
        endif
!
        if(ir.lt.nr) then
          do i=4,6
            ind_tetr1=itetrbeg(ir,iz,iphi)+i
            do j=1,3
              ind_tetr2=itetrbeg(ir+1,iz,iphi)+j
              call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                   tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
              if(iface1.ne.-1) then
                tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
                tetra(ind_tetr1)%neighbour_face(iface1)=iface2
              endif
            enddo
          enddo
        endif
!
        if(iz.gt.1) then
          do i=1,3
            ind_tetr1=itetrbeg(ir,iz,iphi)+i
            do j=4,6
              ind_tetr2=itetrbeg(ir,iz-1,iphi)+j
              call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                   tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
              if(iface1.ne.-1) then
                tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
                tetra(ind_tetr1)%neighbour_face(iface1)=iface2
              endif
            enddo
          enddo
        endif
!
        if(iz.lt.nz) then
          do i=4,6
            ind_tetr1=itetrbeg(ir,iz,iphi)+i
            do j=1,3
              ind_tetr2=itetrbeg(ir,iz+1,iphi)+j
              call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                   tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
              if(iface1.ne.-1) then
                tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
                tetra(ind_tetr1)%neighbour_face(iface1)=iface2
              endif
            enddo
          enddo
        endif
!
        if(iphi.gt.1) then
          do i=1,3
            ind_tetr1=itetrbeg(ir,iz,iphi)+i
            do j=1,3
              ind_tetr2=itetrbeg(ir,iz,iphi-1)+j
              call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                   tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
              if(iface1.ne.-1) then
                tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
                tetra(ind_tetr1)%neighbour_face(iface1)=iface2
              endif
            enddo
          enddo
          do i=4,6
            ind_tetr1=itetrbeg(ir,iz,iphi)+i
            do j=4,6
              ind_tetr2=itetrbeg(ir,iz,iphi-1)+j
              call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                   tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
              if(iface1.ne.-1) then
                tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
                tetra(ind_tetr1)%neighbour_face(iface1)=iface2
              endif
            enddo
          enddo
        endif
!
        if(iphi.lt.nphi) then
          do i=1,3
            ind_tetr1=itetrbeg(ir,iz,iphi)+i
            do j=1,3
              ind_tetr2=itetrbeg(ir,iz,iphi+1)+j
              call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                   tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
              if(iface1.ne.-1) then
                tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
                tetra(ind_tetr1)%neighbour_face(iface1)=iface2
              endif
            enddo
          enddo
          do i=4,6
            ind_tetr1=itetrbeg(ir,iz,iphi)+i
            do j=4,6
              ind_tetr2=itetrbeg(ir,iz,iphi+1)+j
              call check_neighbour(tetra(ind_tetr1)%ind_knot(:),              &
                                   tetra(ind_tetr2)%ind_knot(:),iface1,iface2)
              if(iface1.ne.-1) then
                tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
                tetra(ind_tetr1)%neighbour_face(iface1)=iface2
              endif
            enddo
          enddo
        endif
!
      enddo
    enddo
  enddo
!
! Neighbours through the periodic boundary
!
  nvertinner=(nr+1)*(nz+1)*nphi
!
  do ir=1,nr
    do iz=1,nz
!
      do i=1,3
        ind_tetr1=itetrbeg(ir,iz,1)+i
        knots1(:)=tetra(ind_tetr1)%ind_knot(:)
        do j=1,3
          ind_tetr2=itetrbeg(ir,iz,nphi)+j
          knots2(:)=tetra(ind_tetr2)%ind_knot(:)
          knots2(:)=modulo(knots2(:),nvertinner)
          call check_neighbour(knots1,knots2,iface1,iface2)
          if(iface1.ne.-1) then
            tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
            tetra(ind_tetr1)%neighbour_face(iface1)=iface2
            tetra(ind_tetr1)%neighbour_perbou_phi(iface1)=-1
            tetra(ind_tetr2)%neighbour_tetr(iface2)=ind_tetr1
            tetra(ind_tetr2)%neighbour_face(iface2)=iface1
            tetra(ind_tetr2)%neighbour_perbou_phi(iface2)=1
          endif
        enddo
      enddo
!
      do i=4,6
        ind_tetr1=itetrbeg(ir,iz,1)+i
        knots1(:)=tetra(ind_tetr1)%ind_knot(:)
        do j=4,6
          ind_tetr2=itetrbeg(ir,iz,nphi)+j
          knots2(:)=tetra(ind_tetr2)%ind_knot(:)
          knots2(:)=modulo(knots2(:),nvertinner)
          call check_neighbour(knots1,knots2,iface1,iface2)
          if(iface1.ne.-1) then
            tetra(ind_tetr1)%neighbour_tetr(iface1)=ind_tetr2
            tetra(ind_tetr1)%neighbour_face(iface1)=iface2
            tetra(ind_tetr1)%neighbour_perbou_phi(iface1)=-1
            tetra(ind_tetr2)%neighbour_tetr(iface2)=ind_tetr1
            tetra(ind_tetr2)%neighbour_face(iface2)=iface1
            tetra(ind_tetr2)%neighbour_perbou_phi(iface2)=1
          endif
        enddo
      enddo
!
    enddo
  enddo
!
! Check the number of tetrahedrons at the XY boundary
  j=0
!
b: do ind_tetr=1,ntetr
  do i=1,4
     if(tetra(ind_tetr)%neighbour_tetr(i).lt.1) then
       j=j+1
       cycle b
     endif
   enddo
  enddo b
!
  deallocate(inodes,itetrbeg)
!
  end subroutine make_grid_rect
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine check_neighbour(knots1,knots2,iface1,iface2)
!
  implicit none
!
  logical :: result
  integer :: iface1,iface2,i,j,matches
  integer, dimension(4) :: knots1,knots2
  integer, dimension(3) :: match1,match2
  logical, dimension(4) :: unused
!
  iface1=-1
  iface2=-1
  matches=0
!
  a: do i=1,4
    do j=1,4
      if(knots1(i).eq.knots2(j)) then
        matches=matches+1
        match1(matches)=i
        match2(matches)=j
        if(matches.eq.3) exit a
      endif
    enddo
    if(i-matches.gt.1) return
  enddo a
!
  unused= .true.
  do i=1,3
    unused(match1(i))= .false.
  enddo
  do i=1,4
    if(unused(i)) then
      iface1=i
      exit
    endif
  enddo
!
  unused= .true.
  do i=1,3
    unused(match2(i))= .false.
  enddo
  do i=1,4
    if(unused(i)) then
      iface2=i
      exit
    endif
  enddo
!
  end subroutine check_neighbour
!
!ccccccccccccccccccccccccccccccccccccccccccc
!


      program test
      real*16 sum,sum2,rmsd,energy,ave
      real*16 totale,intrae,intere,ke,temp,boltzman
      integer step
      character*16 fname

      boltzman=0.00198718

      ave=0.0
      rmsd=0.0
      sum=0.0
      sum2=0.0
      read(5,*)timestep,nline,natom
      read(5,*)fname

      open(10,file=fname)

      read(10,*)
      do i=1,nline
         read(10,*)step,totale,intrae,intere,ke
         temp=ke/(1.5*natom*boltzman)
         write(6,'(i5,5x,f7.3)')step,temp
         sum=sum+temp
         sum2=sum2+temp**2
      enddo
      close(10)
c 20   format(5x,f12.6)

c      write(6,*)sum**2/nline,sum2
      ave=sum/nline
      rmsd=(sum2-sum*sum/nline)/nline
      rmsd=sqrt(rmsd)

      write(6,10)timestep,rmsd,ave
 10   format(3f16.7)
      end


program main
    use std ! standard package of plantFEM library
    implicit none

    ! This example utilizes Array Class, where
    ! You can handle external files.

    ! How to use:

    ! First, create the instance
    real(real64),allocatable :: a(:,:)
    real(real64),allocatable :: b(:,:)
    real(real64),allocatable :: ab(:,:)
    real(real64),allocatable :: copyobj(:,:)
    real(real64),allocatable :: ret(:,:)
    integer(int32) :: i

    type(IO_) :: f

    ! #1 create array
    ! ----> allocate array
    allocate(ret(3,3) )
    ! ----> set identity matrix
    ret = identity_matrix(3)
    ! show array on terminal.
    print *, "ret = "
    call showArray(ret)

    ! #2 Array Input-Output
    ! ----> save matrix as "./test.txt" file
    call savetxt(ret,"./","test",".txt")
    ! ----> load a .txt or .csv file.
    a = loadtxt("./","test",".txt")
    b = loadtxt("./","test",".txt")

    ! -----> also, you can do it for multiple arrays as
    call f%open("./"//"arrays"//".txt")
    ! save "a" array
    call saveArray(f%fh,a)
    ! save "b" array
    call saveArray(f%fh,b)
    ! save "ret" array
    call saveArray(f%fh,ret)
    call f%close()

    ! -----> and,
    call f%open("./"//"arrays"//".txt")
    ! load "a" array
    call loadArray(f%fh,a)
    ! load "b" array
    call loadArray(f%fh,b)
    ! load "ret" array
    call loadArray(f%fh,ret)
    call f%close()

    ! -----> It shows the array.
    print *, "a = "
    call showArray(a)

    ! -----> copy array
    a(1,2)=20.0d0
    call copyarray(a,copyobj)
    ! -----> It shows the array.
    print *, "a (original) = "
    call showArray(a)
    print *, "copy = "
    call showArray(copyobj)

    ! Importance Index 7 / 10 : [*******   ]

end program


      function jsrchgt(N,SX,INC,TARGET)

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

!      Find the first array element that is greater than the
!      TARGET value.  If N < 1, then 0 is returned.  If no
!      value is found, N+1 is returned.  Replaces Cray version
!      on the workstation.
!      Bisection search implemented 09/29/93 to improve speed.
!
!      Started: 08/23/93
!
!      Input:
!        N      - Number of elements in array SX.
!        SX     - Array of numbers to be searched.  Assumed to be an
!                 ordered array.
!        INC    - Increment between elements of searched array.  Kept
!                 for compatibility with Cray call.
!        TARGET - Value searched for in array SX.
!
!      Output:
!        JSRCHGT - location in array SX where value of SX is first
!                   greater than the TARGET value.
!----------------------------------------------------------------------C

      implicit none

      integer :: n, inc, jsrchgt, ians, jl, jh, jm
      real*8  :: SX(N), target

!======================================================================C

      if(N.lt.1) then
        ians = 0
      elseif(TARGET.gt.SX(N)) then
        ians = N+1
      elseif(TARGET.lt.SX(1)) then
        ians = 1
      else

        JL = 1
        JH = N

   10   CONTINUE
        if(JH-JL.gt.1) then
          JM = (JL+JH)/2

          if(TARGET.GT.SX(JM)) then
            JL = JM
            JM = (JL+JH)/2
          else
            JH = JM
            JM = (JL+JH)/2
          end if

          GOTO 10
        end if

        if(TARGET.EQ.SX(JH)) JH = JH+1

        ians = JH
      end if

      JSRCHGT = ians

      end function jsrchgt


program main  ! global and partial sum

  implicit none
  include 'mpif.h'
  integer :: size, rank, ierr
  integer :: sum, i

  call mpi_init(ierr)
  call mpi_comm_size(MPI_COMM_WORLD, size, ierr)
  call mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)

  call mpi_reduce(rank, sum, 1, MPI_INTEGER, MPI_SUM, 0, MPI_COMM_WORLD, ierr)

  if (rank == 0) write(6,*) "global sum = ", sum

  call mpi_scan(rank, sum, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr)

  if (rank /= 0) then
     call mpi_send(sum, 1, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, ierr)
  else
     do i = 0, size - 1
        if (i > 0) then
           call mpi_recv(sum, 1, MPI_INTEGER, i, 0, &
                         MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
        endif
        write(6,*) " partial sum(", i, ") = ", sum
     enddo
  endif

  call mpi_finalize(ierr)

end


! RUN: bbc -emit-fir %s -o - | FileCheck %s
! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: exp_testr
! CHECK-SAME: (%[[AREF:.*]]: !fir.ref<f32> {{.*}}, %[[BREF:.*]]: !fir.ref<f32> {{.*}})
subroutine exp_testr(a, b)
  real :: a, b
! CHECK:  %[[A:.*]] = fir.load %[[AREF:.*]] : !fir.ref<f32>
! CHECK:  %[[RES:.*]] = fir.call @fir.exp.f32.f32(%[[A]]) : (f32) -> f32
! CHECK:  fir.store %[[RES]] to %[[BREF]] : !fir.ref<f32>
  b = exp(a)
end subroutine

! CHECK-LABEL: exp_testd
! CHECK-SAME: (%[[AREF:.*]]: !fir.ref<f64> {{.*}}, %[[BREF:.*]]: !fir.ref<f64> {{.*}})
subroutine exp_testd(a, b)
  real(kind=8) :: a, b
! CHECK:  %[[A:.*]] = fir.load %[[AREF:.*]] : !fir.ref<f64>
! CHECK:  %[[RES:.*]] = fir.call @fir.exp.f64.f64(%[[A]]) : (f64) -> f64
! CHECK:  fir.store %[[RES]] to %[[BREF]] : !fir.ref<f64>
  b = exp(a)
end subroutine

! CHECK-LABEL: exp_testc
! CHECK-SAME: (%[[AREF:.*]]: !fir.ref<!fir.complex<4>> {{.*}}, %[[BREF:.*]]: !fir.ref<!fir.complex<4>> {{.*}})
subroutine exp_testc(a, b)
  complex :: a, b
! CHECK:  %[[A:.*]] = fir.load %[[AREF:.*]] : !fir.ref<!fir.complex<4>>
! CHECK:  %[[RES:.*]] = fir.call @fir.exp.z4.z4(%[[A]]) : (!fir.complex<4>) -> !fir.complex<4>
! CHECK:  fir.store %[[RES]] to %[[BREF]] : !fir.ref<!fir.complex<4>>
  b = exp(a)
end subroutine

! CHECK-LABEL: exp_testcd
! CHECK-SAME: (%[[AREF:.*]]: !fir.ref<!fir.complex<8>> {{.*}}, %[[BREF:.*]]: !fir.ref<!fir.complex<8>> {{.*}})
subroutine exp_testcd(a, b)
  complex(kind=8) :: a, b
! CHECK:  %[[A:.*]] = fir.load %[[AREF:.*]] : !fir.ref<!fir.complex<8>>
! CHECK:  %[[RES:.*]] = fir.call @fir.exp.z8.z8(%[[A]]) : (!fir.complex<8>) -> !fir.complex<8>
! CHECK:  fir.store %[[RES]] to %[[BREF]] : !fir.ref<!fir.complex<8>>
  b = exp(a)
end subroutine

! CHECK-LABEL: private @fir.exp.f32.f32
! CHECK-SAME: (%[[ARG32_OUTLINE:.*]]: f32) -> f32
! CHECK: %[[RESULT32_OUTLINE:.*]] = fir.call @__fs_exp_1(%[[ARG32_OUTLINE]]) : (f32) -> f32
! CHECK: return %[[RESULT32_OUTLINE]] : f32

! CHECK-LABEL: private @fir.exp.f64.f64
! CHECK-SAME: (%[[ARG64_OUTLINE:.*]]: f64) -> f64
! CHECK: %[[RESULT64_OUTLINE:.*]] = fir.call @__fd_exp_1(%[[ARG64_OUTLINE]]) : (f64) -> f64
! CHECK: return %[[RESULT64_OUTLINE]] : f64

! CHECK-LABEL: private @fir.exp.z4.z4
! CHECK-SAME: (%[[ARG32_OUTLINE]]: !fir.complex<4>) -> !fir.complex<4>
! CHECK: %[[RESULT32_OUTLINE]] = fir.call @__fc_exp_1(%[[ARG32_OUTLINE]]) : (!fir.complex<4>) -> !fir.complex<4>
! CHECK: return %[[RESULT32_OUTLINE]] : !fir.complex<4>

! CHECK-LABEL: private @fir.exp.z8.z8
! CHECK-SAME: (%[[ARG64_OUTLINE]]: !fir.complex<8>) -> !fir.complex<8>
! CHECK: %[[RESULT64_OUTLINE]] = fir.call @__fz_exp_1(%[[ARG64_OUTLINE]]) : (!fir.complex<8>) -> !fir.complex<8>
! CHECK: return %[[RESULT64_OUTLINE]] : !fir.complex<8>


module prettify_selftest
    implicit none
   private
     public :: dp, test_routine, &
                 test_function,  test_type,    str_function
   integer,   parameter :: dp = selected_real_kind ( 15 , 307)
   type  test_type
      real  (kind =dp ) :: r = 1.0d-3
      integer :: i
   end type test_type

contains

   subroutine test_routine( &
   r, i, j, k, l)
        integer, intent(in)                                :: r, i, j, k
       integer,   intent (out)                               :: l

    l  = test_function(r,i,j,k)
 end &
subroutine

 pure function test_function(r, i, j, &
                                        k) &
   result(l)
   integer, intent(in)                                :: r, i, j, k
   integer                                            :: l

      l=r + i +j  +k
   end function
   function &
        str_function(a)      result(l)
      character(len=*)                                   :: a
      integer                                            :: l

     if(len(a)<5)then
       l=0
      else
       l=1
       endif
end function

end module

program example_prog
 use example, only: dp, test_routine, test_function, test_type,str_function

   implicit  none
  integer :: r,i,j,k,l,my_integer,m
     integer, dimension(5) :: arr
   integer, dimension(20) :: big_arr
integer :: endif
   type(test_type) :: t
real(kind=dp) :: r1,   r2,  r3, r4, r5,  r6
  integer, pointer :: point

  point=>  null( )

! 1) white space formatting !
!***************************!
! example 1.1
   r=1;i=-2;j=3;k=4;l=5
   r2  =  0.0_dp; r3= 1.0_dp;   r4 =2.0_dp; r5=3.0_dp;  r6 = 4.0_dp
   r1=-(r2**i*(r3+r5*(-r4)-r6))-2.e+2
   if( r.eq.2.and.r<=5) i=3
   write(*, *)(merge(3, 1, i<=2))
   write(*, *)test_function(r,i,j , k)
   t % r  = 4.0_dp
   t%i  = str_function( "t  % i   =  " )

! example 1.2
   my_integer=2
   i=3
   j=5

   big_arr = [1, 2, 3, 4, 5, &
              6, 7, 8, 9, 10, &
              11, 12, 13, 14, 15, &
              16, 17, 18, 19, 20]

! example 1.3: disabling auto-formatter:
   my_integer = 2 !&
   i          = 3 !&
   j          = 5 !&

!&<
   my_integer = 2
   i          = 3
   j          = 5
!&>

   big_arr = [ 1,  2,  3,  4,  5, & !&
               6,  7,  8,  9, 10, & !&
              11, 12, 13, 14, 15, & !&
              16, 17, 18, 19, 20] !&

! example 1.4:

   big_arr = [1, 2, 3, 4, 5,&
           &  6, 7, 8, 9, 10, &
           & 11, 12, 13, 14, 15,&
            &16, 17, 18, 19, 20]

! 2) auto indentation for loops !
!*******************************!

! example 2.1
   l = 0
   do r=   1 , 10
    select case (r)
      case(1)
    do_label: do i  =  1,100
        if  (i<=2)   then
          m =0
      do while(m <4)
              m =m+1
             do k=1,3
      if (k==1)  l =l +1
    end do
      enddo
     endif
    enddo do_label
    case ( 2 )
      l=i + j + k
      end select
   enddo

! example 2.2
   do m = 1, 2
     do r = 1, 3
        write (*, *) r
         do k = 1, 4
         do l = 1, 3
         do i = 4, 5
          do my_integer = 1, 1
          do j = 1, 2
          write (*, *) test_function(m, r, k, l) + i
            enddo
            enddo
         enddo
        enddo
          enddo
      enddo
   enddo

! 3) auto alignment for linebreaks   !
!************************************!

! example 3.1
   l = test_function(1, 2, test_function(1, 2, 3, 4), 4) + 3 *(2+1)

   l = test_function (1, 2, test_function(1,2, 3, 4),4)  +&
              3*(2+ 1 )

   l =  test_function(1, 2,   &
               test_function(1, 2,  3, 4),  4)+ &
                                    3 * (2+1)

   l = test_function(1, 2, &
   test_function(1, 2, 3, &
   4), 4) + &
   3*(2 + 1)

! example 3.2
   arr = [1, (/3,4, 5/),   6] + [  1, 2,3, 4,5 ]

   arr = [1,(/ 3, 4, 5 /) , &
   6]  +[1,2, 3, 4, 5 ]

   arr = [1,(/3,4,5/),  &
   6]+ &
             [1, 2, 3, 4, 5]

   arr = [1, (/3, 4, &
         5/), &
         6] + &
         [1, 2,3, 4, 5 ]

! example 3.3
   l = test_function(1, 2, &
         3, 4)

   l = test_function( &
                  1, 2, 3, 4)

   arr = [1, 2, &
        3, 4, 5]
   arr = [ &
            1, 2, 3, 4, 5]

! 4) more complex formatting and tricky test cases !
!**************************************************!

! example 4.1
   l = 0
   do r = 1, 10
         select case ( r )
   case( 1)
           do i=1,100;if (i<=2) then! comment
          do j = 1,5
                    do   k= 1, 3
                 l = l +  1
! unindented comment
         ! indented comment
              end do; enddo
                elseif ( .not. j ==4 ) then
                  my_integer  =   4
               else
            write (*,*)   " hello"
             endif
           enddo
            case(2 )
           l = i+ j + k
              end select
               enddo

! example 4.2
   if ( &
    l == &
       111) &
         then
       do k = 1, 2
   if (k == 1) &
               l = test_function(1, &
                          test_function(r=4, i=5, &
                      j=6, k=test_function(1,2*(3*(1 +1)), str_function ( ")a!(b['(;=dfe"), &
                                                                 9) + &
                            test_function(1, 2, 3, 4)), 9, 10) &
                     ! test_function(1,2,3,4)),9,10) &
            ! +13*str_function('') + str_function('"')
                    + 13*str_function('') + str_function('"')
                    end & ! comment
          ! comment
      do
       endif

! example 4.3
   arr = [1,( /3,4, &
      5 /),&
          6 ]+ &
    [1,2, 3, 4,5] ; arr = [1, 2,&
       3, 4, 5]

! example 4.4
   endif = 3
   if(endif==2)then
   endif=5
   else if(endif==3)then
   write(*,*)endif
   endif

! example 4.5
   do i=1,2;if(.true.)then
   write(*, *)"hello"
   endif; enddo

   end program


      subroutine cdchi(x,df,prob,io)
c********************************************
c  Calculates cumulative distribution function of chi square (df)
c  Input: x - level, df - degrees of freedom, io - output file no.
c  Output: prob - probability that chi**2(ndf) < x
c  Version : 8-18-99
c============================================
      real x,df,prob,tx
      parameter(tx=1.e-4)
      intent(in) x,df,io
      intent(out) prob
c********************************************
c Trap x
      if(x<0.) then
       write(io,*) 'x in cdchi ',x,' is not positive'
       return
      endif
      if(x<tx) then
       prob=0.
       return
      endif
c Trap df
      if(df<0.) then
       write(io,*) 'df ',df,' value is not positive in call to cdchi'
       return
      endif
      if(df<tx) then
       y=x/2
       if(y<=11) then
        prob=1.-exp(-y)
         else
          prob=1.
       endif
       return
      endif
      prob=gammp(0.5*df,0.5*x,io)
      if(prob<tx) then
       prob=0.
      endif
c-------
      return
      end
c
c==========================
c
      function gammp(a,x,io)
c******************************************
c  Incomplete gamma function. Uses gcf,gser
c==========================================
      real a,gammp,x
      real*8 gamser,gammcf,gln
      intent(in) a,x,io
c===========================
      if(x<0..or.a<=0.) then
       write(io,*) 'Bad argument in gammp'
       return
      endif
      if(x<a+1.)then
       call gser(gamser,a,x,gln,io)
       gammp=sngl(gamser)
        else
         call gcf(gammcf,a,x,gln,io)
         gammp=sngl(1.d0-gammcf)
      endif
      return
      end
c
c=========================================
c
      subroutine gcf(gammcf,a,x,gln,io)
c***********************************
c  Uses gammln
c===================================
      parameter(itmax=1000,eps=3.d-7,fpmin=1.d-30)
      real a,x
      real*8 gammcf,gln,dx,an,b,c,d,del,h,di,gammln
      intent(in) a,x,io
      intent(out) gammcf,gln
c================================
      gln=gammln(dble(a))
      dx=dble(x)
      b=dx+1.d0-dble(a)
      c=1.d0/fpmin
      d=1.d0/b
      h=d
      do i=1,itmax
       di=dfloat(i)
       an=-di*(di-dble(a))
       b=b+2.d0
       d=an*d+b
       if(dabs(d)<fpmin) d=fpmin
       c=b+an/c
       if(dabs(c)<fpmin) c=fpmin
       d=1.d0/d
       del=d*c
       h=h*del
       if(dabs(del-1.d0)<eps) then
        gammcf=dexp(-dx+dble(a)*dlog(dx)-gln)*h
        return
       endif
      enddo
      write(io,*) 'a = ',a,' too large, ITMAX too small in gcf'
      return
      end
c
c=========================================
c
      subroutine gser(gamser,a,x,gln,io)
c*************************************
c  Uses gammln
c=====================================
      parameter(itmax=1000,eps=3.d-7)
      real a,x
      real*8 gamser,gln,ap,dx,del,sum,gammln
      intent(in) a,x,io
      intent(out) gamser,gln
c=====================================
      if(x<=0.) then
       if(x<0.) then
        write(io,*) 'x < 0 in gser'
        return
       endif
       gamser=0.d0
       return
      endif
c-------
      ap=dble(a)
      gln=gammln(ap)
      dx=dble(x)
      sum=1.d0/ap
      del=sum
      do n=1,itmax
       ap=ap+1.d0
       del=del*dx/ap
       sum=sum+del
       if(dabs(del)<dabs(sum)*eps) then
        gamser=sum*dexp(-dx+dble(a)*dlog(dx)-gln)
        return
       endif
      enddo
      write(io,*) 'a = ',a,' too large, ITMAX too small in gser'
      return
      end
c
c=========================================
c
      function gammln(x)
c*************************************
c  log of gamma function
c=====================================
      real*8 ser,stp,tmp,x,y,cof(6),gammln
      save cof,stp
      data cof,stp/76.18009172947146d0,-86.50532032941677d0,
     *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     *-.5395239384953d-5,2.5066282746310005d0/
      intent(in) x
c=====================================
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*dlog(tmp)-tmp
      ser=1.000000000190015d0
      do j=1,6
       y=y+1.d0
       ser=ser+cof(j)/y
      enddo
      gammln=tmp+dlog(stp*ser/x)
      return
      end


      SUBROUTINE lamcal(phipog, guu, guv, gvv)
      USE vmec_main
      USE vmec_params, ONLY: ntmax, jlam, lamscale
      USE realspace, ONLY: sqrts, phip
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(rprec), DIMENSION(ns,nznt), INTENT(in) ::                    &
         phipog, guu, guv, gvv
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(rprec), PARAMETER :: damping_fac = 2
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: m,n,js
      REAL(rprec) :: tnn, tnm, tmm, power, pfactor0, pfactor
!-----------------------------------------------

      blam(:ns) = SUM(guu*phipog, dim=2)
      clam(:ns) = SUM(gvv*phipog, dim=2)
      dlam(:ns) = SUM(guv*phipog, dim=2)
      blam(1) = blam(2)
      clam(1) = clam(2)
      dlam(1) = dlam(2)
      blam(ns+1) =  0
      clam(ns+1) =  0
      dlam(ns+1) =  0
      DO js = 2, ns
        blam(js) = cp5*(blam(js) + blam(js+1))
        clam(js) = cp5*(clam(js) + clam(js+1))
        dlam(js) = cp5*(dlam(js) + dlam(js+1))
      END DO

      faclam = 0
      pfactor0 = 2*damping_fac/(2*r0scale)**2/lamscale

      DO m = 0, mpol1
         tmm = m*m
         power = MIN(tmm/256, 8._dp)
         pfactor = pfactor0
         DO n = 0, ntor
            IF (m.eq.0 .and. n.eq.0) CYCLE
!            IF (n .gt. 1) pfactor = pfactor0/4                          !sometimes helps convergence
            tnn = (n*nfp)**2
            tnm = 2*m*n*nfp
            DO js = jlam(m), ns
               faclam(js,n,m,1) = ((blam(js) + blam(js+1))*tnn          &
     &         + SIGN((dlam(js) + dlam(js+1)),blam(js))*tnm             &
     &         +      (clam(js) + clam(js+1))*tmm)
              IF (faclam(js,n,m,1) .eq. zero)                           &
     &            faclam(js,n,m,1) = -1.E-10_dp
            faclam(js,n,m,1) = (pfactor/faclam(js,n,m,1))               &
     &         * sqrts(js)**power                                        !Damps m > 16 modes
            END DO
         END DO
      END DO

      DO n = 2, ntmax
         faclam(:ns,0:ntor,0:mpol1,n) = faclam(:ns,0:ntor,0:mpol1,1)
      END DO

!
!     ADD NORM FOR IOTA FORCE, STORED IN lmnsc(m=0,n=0) COMPONENT
!
      DO js = 1, ns
         faclam(js,0,0,1) = pfactor/(blam(js) + blam(js+1))
      END DO

      END SUBROUTINE lamcal


      SUBROUTINE CFFTI1(N,WA,IFAC)
      DOUBLE PRECISION WA
      DOUBLE PRECISION TPI
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION DUM
      DOUBLE PRECISION ARGH
      DOUBLE PRECISION FI
      DOUBLE PRECISION ARGLD
      DOUBLE PRECISION ARG
      DIMENSION WA(*),IFAC(*),NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/

      NL = N
      NF = 0
      J = 0
  101 J = J + 1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY + 2
  104 NQ = NL/NTRY
      NR = NL - NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF + 1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY.NE.2) GO TO 107
      IF (NF.EQ.1) GO TO 107
      DO 106 I = 2,NF
          IB = NF - I + 2
          IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL.NE.1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 2.D0*DPIMACH(DUM)
      ARGH = TPI/DBLE(N)
      I = 2
      L1 = 1
      DO 110 K1 = 1,NF
          IP = IFAC(K1+2)
          LD = 0
          L2 = L1*IP
          IDO = N/L2
          IDOT = IDO + IDO + 2
          IPM = IP - 1
          DO 109 J = 1,IPM
              I1 = I
              WA(I-1) = 1.D0
              WA(I) = 0.D0
              LD = LD + L1
              FI = 0.D0
              ARGLD = DBLE(LD)*ARGH
              DO 108 II = 4,IDOT,2
                  I = I + 2
                  FI = FI + 1.D0
                  ARG = FI*ARGLD
                  WA(I-1) = COS(ARG)
                  WA(I) = SIN(ARG)
  108         CONTINUE
              IF (IP.LE.5) GO TO 109
              WA(I1-1) = WA(I-1)
              WA(I1) = WA(I)
  109     CONTINUE
          L1 = L2
  110 CONTINUE
      RETURN
      END


      subroutine splder(t,n,c,k,nu,x,y,m,wrk,ier)
c  subroutine splder evaluates in a number of points x(i),i=1,2,...,m
c  the derivative of order nu of a spline s(x) of degree k,given in
c  its b-spline representation.
c
c  calling sequence:
c     call splder(t,n,c,k,nu,x,y,m,wrk,ier)
c
c  input parameters:
c    t    : array,length n, which contains the position of the knots.
c    n    : integer, giving the total number of knots of s(x).
c    c    : array,length n, which contains the b-spline coefficients.
c    k    : integer, giving the degree of s(x).
c    nu   : integer, specifying the order of the derivative. 0<=nu<=k
c    x    : array,length m, which contains the points where the deriv-
c           ative of s(x) must be evaluated.
c    m    : integer, giving the number of points where the derivative
c           of s(x) must be evaluated
c    wrk  : real array of dimension n. used as working space.
c
c  output parameters:
c    y    : array,length m, giving the value of the derivative of s(x)
c           at the different points.
c    ier  : error flag
c      ier = 0 : normal return
c      ier =10 : invalid input data (see restrictions)
c
c  restrictions:
c    0 <= nu <= k
c    m >= 1
c    t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1.
c
c  other subroutines required: fpbspl
c
c  references :
c    de boor c : on calculating with b-splines, j. approximation theory
c                6 (1972) 50-62.
c    cox m.g.  : the numerical evaluation of b-splines, j. inst. maths
c                applics 10 (1972) 134-149.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      integer n,k,nu,m,ier
c  ..array arguments..
      real t(n),c(n),x(m),y(m),wrk(n)
c  ..local scalars..
      integer i,j,kk,k1,k2,l,ll,l1,l2,nk1,nk2,nn
      real ak,arg,fac,sp,tb,te
c  ..local arrays ..
      real h(6)
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      ier = 10
      if(nu.lt.0 .or. nu.gt.k) go to 200
      if(m-1) 200,30,10
  10  do 20 i=2,m
        if(x(i).lt.x(i-1)) go to 200
  20  continue
  30  ier = 0
c  fetch tb and te, the boundaries of the approximation interval.
      k1 = k+1
      nk1 = n-k1
      tb = t(k1)
      te = t(nk1+1)
c  the derivative of order nu of a spline of degree k is a spline of
c  degree k-nu,the b-spline coefficients wrk(i) of which can be found
c  using the recurrence scheme of de boor.
      l = 1
      kk = k
      nn = n
      do 40 i=1,nk1
         wrk(i) = c(i)
  40  continue
      if(nu.eq.0) go to 100
      nk2 = nk1
      do 60 j=1,nu
         ak = kk
         nk2 = nk2-1
         l1 = l
         do 50 i=1,nk2
            l1 = l1+1
            l2 = l1+kk
            fac = t(l2)-t(l1)
            if(fac.le.0.) go to 50
            wrk(i) = ak*(wrk(i+1)-wrk(i))/fac
  50     continue
         l = l+1
         kk = kk-1
  60  continue
      if(kk.ne.0) go to 100
c  if nu=k the derivative is a piecewise constant function
      j = 1
      do 90 i=1,m
         arg = x(i)
  70     if(arg.lt.t(l+1) .or. l.eq.nk1) go to 80
         l = l+1
         j = j+1
         go to 70
  80     y(i) = wrk(j)
  90  continue
      go to 200
 100  l = k1
      l1 = l+1
      k2 = k1-nu
c  main loop for the different points.
      do 180 i=1,m
c  fetch a new x-value arg.
        arg = x(i)
        if(arg.lt.tb) arg = tb
        if(arg.gt.te) arg = te
c  search for knot interval t(l) <= arg < t(l+1)
 140    if(arg.lt.t(l1) .or. l.eq.nk1) go to 150
        l = l1
        l1 = l+1
        go to 140
c  evaluate the non-zero b-splines of degree k-nu at arg.
 150    call fpbspl(t,n,kk,arg,l,h)
c  find the value of the derivative at x=arg.
        sp = 0.
        ll = l-k1
        do 160 j=1,k2
          ll = ll+1
          sp = sp+wrk(ll)*h(j)
 160    continue
        y(i) = sp
 180  continue
 200  return
      end


c***************************************************************
c  F-K: @(#) source.f			1.0 4/29/2000
c
c  Copyright (c) 2000 by L. Zhu
c  See README file for copying and redistribution conditions.
c
c Setup the displacement-stress vector jump across the source
c The coefficients can be all derived from the potential jump in
c Haskell (1964), or directly from Takiuchi and Saito (1972)
c
c  Input:
c	src	--- source type, 0=ex; 1=sf; 2=dc
c	k	--- wavenumber
c	xi	--- mu/(lambda+2*mu) at the source
c	mu	--- shear module
c  Output:
c	s(3,6)	--- source coef. for n=0, 1, 2
c
c  called by:	kernel()	in kernel.f
c
c  modified history:
c	May 12, 2000	Lupei Zhu	initial coding
c	July 17, 2000	Lupei Zhu	change xi, mu to be complex
c***************************************************************
      subroutine source(src, k, xi, mu, s)
      integer i, j, src
      real k
      complex s(3,6), xi, mu

      do i = 1, 3
         do j = 1, 6
	    s(i,j) = 0.
	 enddo
      enddo

      if (src .EQ. 2) then 		! DOUBLE_COUPLE
         s(1,2) = 2.*xi/mu
         s(1,4) = 4.*xi-3.
         s(2,1) = 1./mu
         s(2,5) =-s(2,1)
         s(3,4) = 1.
         s(3,6) =-1.
      else if (src .EQ. 0) then		! EXPLOSION
         s(1,2) = xi/mu
         s(1,4) = 2.*xi
      else if (src .EQ. 1) then		! SINGLE_FORCE
         s(1,3) = -1./k
         s(2,4) = -s(1,3)
         s(2,6) =  s(1,3)
      else				! unknow source type
	 write(0,*)'unknown source type'
	 stop
      endif

      return
      end


      SUBROUTINE cumbin(s,xn,pr,ompr,cum,ccum)
C**********************************************************************
C
C     SUBROUTINE CUMBIN(S,XN,PBIN,OMPR,CUM,CCUM)
C                    CUmulative BINomial distribution
C
C
C                              Function
C
C
C     Returns the probability   of 0  to  S  successes in  XN   binomial
C     trials, each of which has a probability of success, PBIN.
C
C
C                              Arguments
C
C
C     S --> The upper limit of cumulation of the binomial distribution.
C                                                  S is DOUBLE PRECISION
C
C     XN --> The number of binomial trials.
C                                                  XN is DOUBLE PRECISIO
C
C     PBIN --> The probability of success in each binomial trial.
C                                                  PBIN is DOUBLE PRECIS
C
C     OMPR --> 1 - PBIN
C                                                  OMPR is DOUBLE PRECIS
C
C     CUM <-- Cumulative binomial distribution.
C                                                  CUM is DOUBLE PRECISI
C
C     CCUM <-- Compliment of Cumulative binomial distribution.
C                                                  CCUM is DOUBLE PRECIS

C
C
C                              Method
C
C
C     Formula  26.5.24    of   Abramowitz  and    Stegun,  Handbook   of
C     Mathematical   Functions (1966) is   used  to reduce the  binomial
C     distribution  to  the  cumulative    beta distribution.
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION pr,ompr,s,xn,cum,ccum
C     ..
C     .. External Subroutines ..
      EXTERNAL cumbet
C     ..
C     .. Executable Statements ..
      IF (.NOT. (s.LT.xn)) GO TO 10
      CALL cumbet(pr,ompr,s+1.0D0,xn-s,ccum,cum)
      GO TO 20

   10 cum = 1.0D0
      ccum = 0.0D0
   20 RETURN

      END


      subroutine run_000000(k,l,DetGr,f,Gtwiddle,Gtt,
     . Shat5zzzz,Shat6zzzz,S000000,N0)
      implicit none
C------Fixes D000000
C-----knowing D0000 with correction of order Delta D0000ii
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,n,m,np
      parameter(np=3)
      double precision DetGr,Gtwiddle(np,np),Gtt(np,np,np,np),f(np)
      double complex Shat5zzzz(np,-2:0),S000000(-2:0),
     . Shat6zzzz(np,z1max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit
     . +Gtt(k,n,l,m)*(f(n)*Shat5zzzz(m,ep)-f(n)*f(m)*Dv(dd0000+N0,ep))
      enddo
      enddo
      pole=czip
      if (ep .gt. -2) pole=-4d0*Gtwiddle(k,l)*Dv(dd000000+N0,ep-1)

      Dv(dd000000+N0,ep)=
     . -(pole
     . +DetGr*Dv(dzzzzii(z2(k,l))+N0,ep)
     . -Gtwiddle(k,l)*S000000(ep)
     . -Gtwiddle(1,l)*Shat6zzzz(1,k,ep)
     . -Gtwiddle(2,l)*Shat6zzzz(2,k,ep)
     . -Gtwiddle(3,l)*Shat6zzzz(3,k,ep)
     . +Gtwiddle(k,l)
     . *(Shat6zzzz(1,1,ep)+Shat6zzzz(2,2,ep)+Shat6zzzz(3,3,ep))
     . +bit)/(12d0*Gtwiddle(k,l))
      enddo

      return
      end


      MODULE MOD_WRVEL
      CONTAINS

      FUNCTION WRVEL(R)

      IMPLICIT NONE

      real*8, intent(in) :: R
      real*8 ::             WRVEL
      real*8 ::             RCON,VPAR1,VPAR2,BETA,VFINAL,VMIN,HSCALE

      COMMON/VELPAR/        VFINAL,VMIN,BETA,VPAR1,VPAR2,RCON,HSCALE

      IF (R .LE. 1.d0) GOTO 2
      IF (R .LT. RCON) GOTO 3

      WRVEL = VPAR1 * (1.d0 - VPAR2 / R)**BETA

      IF (WRVEL .GT. VFINAL) WRVEL = VFINAL

      RETURN

    2 WRVEL = VMIN

      RETURN

    3 WRVEL = VMIN / R / R * EXP((1.d0 - 1.d0 / R) / HSCALE)

      RETURN

      END FUNCTION

      END MODULE


MODULE PARAM_MOD
USE BIOCOM_MOD
implicit none

! Indices for state variables
integer, parameter :: iNO3   = 1
integer, parameter :: iPHY(1)= 2
integer, parameter :: iZOO   = 3
integer, parameter :: iVNO3  = 4
integer, parameter :: iVPHY  = 5
integer, parameter :: iVZOO  = 6
integer, parameter :: iCOVNP = 7
integer, parameter :: iCOVPZ = 8
integer, parameter :: iCOVNZ = 9
integer, parameter :: NVAR   = iCOVNZ   ! Total number of biological tracers
! Define tracer matrix:
real               :: Vars(NVAR,nlev) = 0d0

! Define parameter indices:
integer, parameter :: imu0    = 1
integer, parameter :: iIopt   = imu0  + 1
integer, parameter :: iaI0_C  = iIopt + 1
integer, parameter :: iKN     = iaI0_C+ 1
integer, parameter :: iDp     = iKN   + 1
integer, parameter :: iwDET   = iDp   + 1  ! Index for phytoplankton sinking rate
integer, parameter :: ibeta   = iwDET + 1  ! Beta: ratio of total variance to squares of mean concentration
integer, parameter :: iKPHY   = ibeta + 1  ! Maximal grazing rate
integer, parameter :: igmax   = iKPHY + 1  ! Zooplankton maximal grazing rate
integer, parameter :: imz     = igmax + 1  ! Zooplankton mortality rate
integer, parameter :: iVPHY0  = imz   + 1  ! Initial fraction of VPHY over B
integer, parameter :: iVNO30  = iVPHY0+ 1  ! Initial fraction of VNO3 over B
integer, parameter :: NPar    = iVNO30     ! Total number of parameters
real               :: params(NPar)     = 0d0  ! Define parameters

integer, parameter :: LINEAR              = 1       ! Linear zooplankton mortality and linear grazing function
integer, parameter :: QUADRATIC           = 2       ! Quadratic zooplankton mortality
integer, parameter :: H2T                 = 2       ! Holling Type II with threshold
integer, parameter :: H3                  = 3       ! Holling Type III

integer, parameter :: grazing_formulation = LINEAR  ! Type of grazing function
integer, parameter :: ZOO_MORT            = LINEAR  ! Type of zooplankton mortality
!  Maxima and minima  of parameter values
real               :: MaxValue(NPar)   = 0d0, MinValue(NPar) = 0d0
END MODULE


      SUBROUTINE lamcal(phipog, guu, guv, gvv)
      USE vmec_main
      USE vmec_params, ONLY: ntmax, jlam
      USE realspace, ONLY: sqrts, phip
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec), DIMENSION(ns,nznt), INTENT(in) ::
     1   phipog, guu, guv, gvv
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: damping_fac = 2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: m,n,js
      REAL(rprec) :: tnn, tnm, tmm, power
C-----------------------------------------------

      blam(:ns) = SUM(guu*phipog, dim=2)*phip(2)
      clam(:ns) = SUM(gvv*phipog, dim=2)*phip(2)
      dlam(:ns) = SUM(guv*phipog, dim=2)*phip(2)
      blam(1) =  blam(2)
      clam(1) =  clam(2)
      dlam(1) =  dlam(2)
      blam(ns+1) =  0
      clam(ns+1) =  0
      dlam(ns+1) =  0
      DO js = 2, ns
        blam(js) = cp5*(blam(js) + blam(js+1))
        clam(js) = cp5*(clam(js) + clam(js+1))
        dlam(js) = cp5*(dlam(js) + dlam(js+1))
      END DO

      faclam = 0
      DO m = 0, mpol1
         tmm = m*m
         power = MIN(tmm/256, 8._dp)
         DO n = 0, ntor
            IF (m.eq.0 .and. n.eq.0) CYCLE
            tnn = (n*nfp)**2
            tnm = 2*m*n*nfp
            DO js = jlam(m), ns
               faclam(js,n,m,1) = 2*damping_fac/
     1               ((blam(js) + blam(js+1))*tnn
     2         + SIGN((dlam(js) + dlam(js+1)),blam(js))*tnm
     3         +      (clam(js) + clam(js+1))*tmm)
     4         * sqrts(js)**power                                   !Damps m > 16 modes
            END DO
         END DO
      END DO

      DO n = 2, ntmax
         faclam(:ns,0:ntor,0:mpol1,n) = faclam(:ns,0:ntor,0:mpol1,1)
      END DO

!
!     ADD NORM FOR IOTA FORCE, STORED IN lmnsc(m=0,n=0) COMPONENT
!
      IF (liota) THEN
         DO js = 1, ns
            faclam(js,0,0,1) = 2*damping_fac/(blam(js) + blam(js+1))
         END DO
      END IF
      END SUBROUTINE lamcal


      double complex function BSYA1Hqqppmp(e1,p2,p3,e4,za,zb,zab,zba)
      implicit none
C-----Authors: John Campbell and Keith Ellis, November 2011
C---- arXiv:1101.5947 [hep-ph], Eq. (102)
C---- (These are twiddle functions, c.f.arXiv:1101.5947[hep-ph],Eq.(91))
      include 'constants.f'
      include 'masses.f'
      include 'zprods_decl.f'
      include 'zabprods_decl.f'
      include 'sprods_com.f'
      include 'massiveintegrals.f'
      double complex BSYA0qqppmp
      integer e1,p2,p3,e4

      BSYA1Hqqppmp=
     &  2d0/3d0*BSYA0qqppmp(e1,p2,p3,e4,za,zb,zab,zba)*(
     & (2d0*mt**2/S(p2,p3)+1d0)*F2m23+Im2m-1d0/3d0)

      return
      end


      double complex function BSYA1fggpppp(e1,p2,p3,e4,za,zb,zab,zba)
      implicit none
C-----Authors: John Campbell and Keith Ellis, March 2012
C---- arXiv:1101.5947 [hep-ph], Eq. (100),fully Badger-compliant
C---- (These are twiddle functions, c.f.arXiv:1101.5947[hep-ph],Eq.(91))
      include 'constants.f'
      include 'masses.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'zabprods_decl.f'
      include 'qdef.f'
      double precision s23
      integer e1,p2,p3,e4

      s23=s(p2,p3)
      BSYA1fggpppp=
     & -2d0*mt*(za(e1,e4)*zab(p2,q1,p2)-za(p2,e1)*za(p3,e4)*zb(p2,p3))
     & /(za(p2,p3)**3*zb(p2,p3))*(s23/6d0)

      return
      end


*DECK DGAMMA
      DOUBLE PRECISION FUNCTION DGAMMA (X)
C***BEGIN PROLOGUE  DGAMMA
C***PURPOSE  Compute the complete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A
C***TYPE      DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DGAMMA(X) calculates the double precision complete Gamma function
C for double precision argument X.
C
C Series for GAM        on the interval  0.          to  1.00000E+00
C                                        with weighted error   5.79E-32
C                                         log weighted error  31.24
C                               significant figures required  30.00
C                                    decimal places required  32.05
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920618  Removed space from variable name.  (RWC, WRB)
C***END PROLOGUE  DGAMMA
      DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX,
     1  XMIN, Y, D9LGMC, DCSEVL, D1MACH
      LOGICAL FIRST
C
      SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST
      DATA GAMCS(  1) / +.8571195590 9893314219 2006239994 2 D-2      /
      DATA GAMCS(  2) / +.4415381324 8410067571 9131577165 2 D-2      /
      DATA GAMCS(  3) / +.5685043681 5993633786 3266458878 9 D-1      /
      DATA GAMCS(  4) / -.4219835396 4185605010 1250018662 4 D-2      /
      DATA GAMCS(  5) / +.1326808181 2124602205 8400679635 2 D-2      /
      DATA GAMCS(  6) / -.1893024529 7988804325 2394702388 6 D-3      /
      DATA GAMCS(  7) / +.3606925327 4412452565 7808221722 5 D-4      /
      DATA GAMCS(  8) / -.6056761904 4608642184 8554829036 5 D-5      /
      DATA GAMCS(  9) / +.1055829546 3022833447 3182350909 3 D-5      /
      DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6      /
      DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7      /
      DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8      /
      DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9      /
      DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9      /
      DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10     /
      DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11     /
      DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12     /
      DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12     /
      DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13     /
      DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14     /
      DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15     /
      DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15     /
      DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16     /
      DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17     /
      DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18     /
      DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18     /
      DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19     /
      DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20     /
      DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21     /
      DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22     /
      DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22     /
      DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23     /
      DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24     /
      DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25     /
      DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25     /
      DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26     /
      DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27     /
      DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28     /
      DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28     /
      DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29     /
      DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30     /
      DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31     /
      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DGAMMA
      IF (FIRST) THEN
         NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) )
C
         CALL DGAMLM (XMIN, XMAX)
         DXREL = SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.10.D0) GO TO 50
C
C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND.  REDUCE INTERVAL AND FIND
C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL.
C
      N = X
      IF (X.LT.0.D0) N = N - 1
      Y = X - N
      N = N - 1
      DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM)
      IF (N.EQ.0) RETURN
C
      IF (N.GT.0) GO TO 30
C
C COMPUTE GAMMA(X) FOR X .LT. 1.0
C
      N = -N
      IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2)
      IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC',
     +   'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2)
      IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL)
     +   CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
     +   1, 1)
C
      DO 20 I=1,N
        DGAMMA = DGAMMA/(X+I-1 )
 20   CONTINUE
      RETURN
C
C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0
C
 30   DO 40 I=1,N
        DGAMMA = (Y+I) * DGAMMA
 40   CONTINUE
      RETURN
C
C GAMMA(X) FOR ABS(X) .GT. 10.0.  RECALL Y = ABS(X).
C
 50   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X SO BIG GAMMA OVERFLOWS', 3, 2)
C
      DGAMMA = 0.D0
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X SO SMALL GAMMA UNDERFLOWS', 2, 1)
      IF (X.LT.XMIN) RETURN
C
      DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) )
      IF (X.GT.0.D0) RETURN
C
      IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
     +   'DGAMMA',
     +   'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1)
C
      SINPIY = SIN (PI*Y)
      IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X IS A NEGATIVE INTEGER', 4, 2)
C
      DGAMMA = -PI/(Y*SINPIY*DGAMMA)
C
      RETURN
      END