! This test was created from ..\problem-specifications\exercises\triangle\canonical-data.json
!

program triangle_test_main
  use TesterMain
  use triangle
  implicit none

  ! Test 1: all sides are equal
  call assert_equal(.true., equilateral([2, 2, 2]), "all sides are equal")
  ! Test 2: any side is unequal
  call assert_equal(.false., equilateral([2, 3, 2]), "any side is unequal")
  ! Test 3: no sides are equal
  call assert_equal(.false., equilateral([5, 4, 6]), "no sides are equal")
  ! Test 4: all zero sides is not a triangle
  call assert_equal(.false., equilateral([0, 0, 0]), "all zero sides is not a triangle")
  ! Test 5: sides may be floats
  call assert_equal(.true., equilateral([0.5, 0.5, 0.5]), "sides may be floats")
  ! Test 1: last two sides are equal
  call assert_equal(.true., isosceles([3, 4, 4]), "last two sides are equal")
  ! Test 2: first two sides are equal
  call assert_equal(.true., isosceles([4, 4, 3]), "first two sides are equal")
  ! Test 3: first and last sides are equal
  call assert_equal(.true., isosceles([4, 3, 4]), "first and last sides are equal")
  ! Test 4: equilateral triangles are also isosceles
  call assert_equal(.true., isosceles([4, 4, 4]), "equilateral triangles are also isosceles")
  ! Test 5: no sides are equal
  call assert_equal(.false., isosceles([2, 3, 4]), "no sides are equal")
  ! Test 6: first triangle inequality violation
  call assert_equal(.false., isosceles([1, 1, 3]), "first triangle inequality violation")
  ! Test 7: second triangle inequality violation
  call assert_equal(.false., isosceles([1, 3, 1]), "second triangle inequality violation")
  ! Test 8: third triangle inequality violation
  call assert_equal(.false., isosceles([3, 1, 1]), "third triangle inequality violation")
  ! Test 9: sides may be floats
  call assert_equal(.true., isosceles([0.5, 0.4, 0.5]), "sides may be floats")
  ! Test 1: no sides are equal
  call assert_equal(.true., scalene([5, 4, 6]), "no sides are equal")
  ! Test 2: all sides are equal
  call assert_equal(.false., scalene([4, 4, 4]), "all sides are equal")
  ! Test 3: two sides are equal
  call assert_equal(.false., scalene([4, 4, 3]), "two sides are equal")
  ! Test 4: may not violate triangle inequality
  call assert_equal(.false., scalene([7, 3, 2]), "may not violate triangle inequality")
  ! Test 5: sides may be floats
  call assert_equal(.true., scalene([0.5, 0.4, 0.6]), "sides may be floats")

  call test_report()

end program


MODULE nrtype
	INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
	INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
	INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
	INTEGER, PARAMETER :: SP = KIND(1.0)
	INTEGER, PARAMETER :: DP = KIND(1.0D0)
	INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
	INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
	INTEGER, PARAMETER :: LGT = KIND(.true.)
	REAL(SP), PARAMETER :: PI_S=3.141592653589793238462643383279502884197_sp
	REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp
	REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp
	REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp
	REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp
	REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp
	REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp
	REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp
	TYPE sprs2_sp
		INTEGER(I4B) :: n,len
		REAL(SP), DIMENSION(:), POINTER :: val
		INTEGER(I4B), DIMENSION(:), POINTER :: irow
		INTEGER(I4B), DIMENSION(:), POINTER :: jcol
	END TYPE sprs2_sp
	TYPE sprs2_dp
		INTEGER(I4B) :: n,len
		REAL(DP), DIMENSION(:), POINTER :: val
		INTEGER(I4B), DIMENSION(:), POINTER :: irow
		INTEGER(I4B), DIMENSION(:), POINTER :: jcol
	END TYPE sprs2_dp
END MODULE nrtype


!
! Copyright (C) 2016  Timothy Brown
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!

module jacobi

        use kinds,    only : r_dp
        use err,      only : err_msg
!        use hdf_rw,   only : hcreate, hwdata, hclose
!        use hdf5,     only : hid_t
        use walltime, only : get_walltime

        implicit none

        private
        public jacobi_solver

contains

subroutine jacobi_solver(phi, niter, ierr, filename)

        implicit none
        real(kind=r_dp), contiguous, intent(inout) :: phi(:,:,:)
        integer,                     intent(in)    :: niter
        integer,                     intent(out)   :: ierr
        character(len=*), optional,  intent(in)    :: filename

        integer                      :: it, k, j, i     ! loop indexers
        integer                      :: imax, jmax, kmax
        real(kind=r_dp), parameter   :: one_sixth = 1.0_r_dp / 6.0_r_dp
        real(kind=r_dp)              :: s, e
        real(kind=r_dp), allocatable :: tmp(:,:,:)
        !real(kind=r_dp), pointer     :: grid(:,:,:) => null()

        !integer(kind=hid_t) :: f_id                     ! file identifier
        !character(len=256)  :: outfile                  ! output file name
        !character(len=256)  :: gname                    ! iteration group

        ierr = 0
        imax = size(phi, 1)
        jmax = size(phi, 2)
        kmax = size(phi, 3)

        allocate(tmp, source=phi, stat=ierr)
        if (ierr /= 0 ) then
                call err_msg('Unable to allocate temporary domain')
        end if

        ! Write the array
!        if (present(filename)) then
!                outfile = trim(filename)
!        else
!                outfile = 'js.h5'
!        end if
!        call hcreate(outfile, f_id, ierr)
!        it = 0
!        write(gname, '(I8)') it
!        call hwdata(f_id, phi, gname, ierr)

        call get_walltime(s)

        do it = 1, niter
            do k = 2, kmax-1
                do j = 2, jmax-1
                    do i = 2, imax-1
                        tmp(i,j,k) =(  phi(i-1,j,k) + phi(i+1,j,k)  &
                                     + phi(i,j-1,k) + phi(i,j+1,k)  &
                                     + phi(i,j,k-1) + phi(i,j,k+1)) &
                                    * one_sixth
                    end do
                end do
            end do
            phi = tmp
!            write(gname, '(I8)') it
!            call hwdata(f_id, phi, gname, ierr)
        end do

        call get_walltime(e)

        print *, 'Time elapsed: ', e - s

!        call hclose(f_id, ierr)

        if (allocated(tmp)) then
                deallocate(tmp)
        end if

end subroutine jacobi_solver

end module jacobi


      PROGRAM FOO
      INTEGER I, J, K
      REAL L, M, N
      K = MOD (I, J)
      N = MOD (l, M)
      END


module IdentityOperators
  use DVectors
  use AbstractOperators
  implicit none
  !! identity operator
  type, public, extends(abstract_operator) :: eye
   contains
     !! constructor
     procedure, public, pass :: init => init_eye
     !! procedure to be overrided
     procedure, public, pass :: apply =>  apply_eye
  end type eye

contains
        !! set identity dimensions
  subroutine init_eye(this,size)
    implicit none
    class(eye),     intent(inout) :: this
    integer,        intent(in   ) :: size

    !! the set domain/codomain operator dimension
    this%nrow = size
    this%ncol = size
    this%is_symmetric=.False.
    this%nonlinearity=0.d0

  end subroutine init_eye

  !! simply copy x into y
  subroutine apply_eye(this,vec_in,vec_out,ierr)
    use DVectors
    implicit none
    class(eye),     intent(inout) :: this
    class(dvector), intent(in   ) :: vec_in
    class(dvector), intent(inout) :: vec_out
    integer,        intent(inout) :: ierr

    ! using basic linear algebra operation defined in Dvectors module
    call axpby_dvector(1.0d0,vec_in,0.0d0,vec_out)

    ! or we can simply use a procedure assocaite with standard Fortran vector
    !vec_out%coefficinets=vec_in%coefficients

    ierr=0
  end subroutine apply_eye

end module IdentityOperators


!-----------------------------------------------------------------------
!
! Header with QFunctions
!
      include 't500-operator-f.h'
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j
      integer stridesu(3)
      integer erestrictx,erestrictu,erestrictui
      integer bx,bu
      integer qf_setup,qf_mass
      integer op_setup,op_mass
      integer qdata,x,u,v
      integer nelem,p,q
      parameter(nelem=15)
      parameter(p=5)
      parameter(q=8)
      integer nx,nu
      parameter(nx=nelem+1)
      parameter(nu=nelem*(p-1)+1)
      integer indx(nelem*2)
      integer indu(nelem*p)
      real*8 arrx(nx)
      integer*8 voffset,xoffset

      real*8 hv(nu)
      real*8 total

      character arg*32

      external setup,mass

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      do i=0,nx-1
        arrx(i+1)=i/(nx-1.d0)
      enddo
      do i=0,nelem-1
        indx(2*i+1)=i
        indx(2*i+2)=i+1
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,2,1,1,nx,ceed_mem_host,&
     & ceed_use_pointer,indx,erestrictx,err)

      do i=0,nelem-1
        do j=0,p-1
          indu(p*i+j+1)=i*(p-1)+j
        enddo
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,p,1,1,nu,ceed_mem_host,&
     & ceed_use_pointer,indu,erestrictu,err)
      stridesu=[1,q,q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q,1,q*nelem,stridesu,&
     & erestrictui,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bx,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,p,q,ceed_gauss,bu,err)

      call ceedqfunctioncreateinterior(ceed,1,setup,&
     &SOURCE_DIR&
     &//'t500-operator.h:setup'//char(0),qf_setup,err)
      call ceedqfunctionaddinput(qf_setup,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddinput(qf_setup,'dx',1,ceed_eval_grad,err)
      call ceedqfunctionaddoutput(qf_setup,'rho',1,ceed_eval_none,err)

      call ceedqfunctioncreateinterior(ceed,1,mass,&
     &SOURCE_DIR&
     &//'t500-operator.h:mass'//char(0),qf_mass,err)
      call ceedqfunctionaddinput(qf_mass,'rho',1,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_mass,'u',1,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_mass,'v',1,ceed_eval_interp,err)

      call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup,err)
      call ceedoperatorcreate(ceed,qf_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_mass,err)

      call ceedvectorcreate(ceed,nx,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)
      call ceedvectorcreate(ceed,nelem*q,qdata,err)

      call ceedoperatorsetfield(op_setup,'_weight',ceed_elemrestriction_none,&
     & bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup,'dx',erestrictx,bx,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup,'rho',erestrictui,&
     & ceed_basis_collocated,ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass,'rho',erestrictui,&
     & ceed_basis_collocated,qdata,err)
      call ceedoperatorsetfield(op_mass,'u',erestrictu,bu,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass,'v',erestrictu,bu,&
     & ceed_vector_active,err)

      call ceedoperatorapply(op_setup,x,qdata,ceed_request_immediate,err)

      call ceedvectorcreate(ceed,nu,u,err)
      call ceedvectorsetvalue(u,1.d0,err)
      call ceedvectorcreate(ceed,nu,v,err)
      call ceedvectorsetvalue(v,0.d0,err)

      call ceedoperatorapplyadd(op_mass,u,v,ceed_request_immediate,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,hv,voffset,err)
      total=0.
      do i=1,nu
        total=total+hv(voffset+i)
      enddo
      if (abs(total-1.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(v,hv,voffset,err)

      call ceedvectorsetvalue(v,1.d0,err)
      call ceedoperatorapplyadd(op_mass,u,v,ceed_request_immediate,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,hv,voffset,err)
      total=-nu
      do i=1,nu
        total=total+hv(voffset+i)
      enddo
      if (abs(total-1.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(v,hv,voffset,err)

      call ceedvectordestroy(qdata,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedoperatordestroy(op_mass,err)
      call ceedoperatordestroy(op_setup,err)
      call ceedqfunctiondestroy(qf_mass,err)
      call ceedqfunctiondestroy(qf_setup,err)
      call ceedbasisdestroy(bu,err)
      call ceedbasisdestroy(bx,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


! { dg-do run }
! Check that maxval uses for integers HUGE()-1.
! PR fortran/30512

program main
implicit none
integer(1) :: i1(3), a1(3:2)
integer(2) :: i2(3), a2(3:2)
integer(4) :: i4(3), a4(3:2)
integer(8) :: i8(3), a8(3:2)

integer(kind=4), allocatable :: a(:,:)
integer(kind=8), allocatable :: b(:,:)

logical :: msk(3)
msk = .false.

i1 = 1
i2 = 1
i4 = 1
i8 = 1

if(-huge(i1)-1_1 /= maxval(i1, msk)) call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }
if(-huge(a1)-1_1 /= maxval(a1))      call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }

if(-huge(i2)-1_2 /= maxval(i2, msk)) call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }
if(-huge(a2)-1_2 /= maxval(a2))      call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }

if(-huge(i4)-1_4 /= maxval(i4, msk)) call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }
if(-huge(a4)-1_4 /= maxval(a4))      call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }

if(-huge(i8)-1_4 /= maxval(i8, msk)) call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }
if(-huge(a8)-1_4 /= maxval(a8))      call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }

allocate (a(0:-1,1:1))
allocate (b(0:-1,1:1))

if(any(maxval(a,dim=1) /= -huge(a)-1_4)) call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }
if(any(minval(a,dim=1) /=  huge(a)    )) call abort()

if(any(maxval(b,dim=1) /= -huge(b)-1_8)) call abort() ! { dg-warning "outside symmetric range implied by Standard Fortran" }
if(any(minval(b,dim=1) /=  huge(b)    )) call abort()

end program main


*> \brief \b SROUNDUP_LWORK
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*      REAL             FUNCTION SROUNDUP_LWORK( LWORK )
*
*     .. Scalar Arguments ..
*      INTEGER          LWORK
*     ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SROUNDUP_LWORK deals with a subtle bug with returning LWORK as a Float.
*> This routine guarantees it is rounded up instead of down by
*> multiplying LWORK by 1+eps when it is necessary, where eps is the relative machine precision.
*> E.g.,
*>
*>        float( 16777217            ) == 16777216
*>        float( 16777217 ) * (1.+eps) == 16777218
*>
*> \return SROUNDUP_LWORK
*> \verbatim
*>         SROUNDUP_LWORK >= LWORK.
*>         SROUNDUP_LWORK is guaranteed to have zero decimal part.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] LWORK Workspace size.
*
*  Authors:
*  ========
*
*> \author Weslley Pereira, University of Colorado Denver, USA
*
*> \ingroup auxOTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>  This routine was inspired in the method `magma_zmake_lwork` from MAGMA.
*>  \see https://bitbucket.org/icl/magma/src/master/control/magma_zauxiliary.cpp
*> \endverbatim
*
*  =====================================================================
      REAL             FUNCTION SROUNDUP_LWORK( LWORK )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER          LWORK
*     ..
*
* =====================================================================
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC         EPSILON, REAL, INT
*     ..
*     .. Executable Statements ..
*     ..
      SROUNDUP_LWORK = REAL( LWORK )
*
      IF( INT( SROUNDUP_LWORK ) .LT. LWORK ) THEN
*         Force round up of LWORK
          SROUNDUP_LWORK = SROUNDUP_LWORK * ( 1.0E+0 + EPSILON(0.0E+0) )
      ENDIF
*
      RETURN
*
*     End of SROUNDUP_LWORK
*
      END


! 6.1.2 Trapezoidal rule integration with I/O.
!
! Compile and run:
! $ mpifort -O0 -Wall -Wextra -Wpedantic -fcheck=all -fbacktrace trapezoidal_p2p.f90
! $ mpirun -np 4 --oversubscribe ./a.out
program trapezoidal_p2p
    use mpi_f08
    implicit none
    integer :: my_rank, n_ranks, r, root
    type(MPI_Status) :: status
    type(MPI_Comm) :: comm = MPI_COMM_WORLD
    real :: a, b, a_r, b_r, integral, total, step
    integer :: m, m_r

    call MPI_Init()
    call MPI_Comm_size(comm, n_ranks)
    call MPI_Comm_rank(comm, my_rank)

    root = 0

    ! a = 1.0e-3
    ! b = 1.0
    ! n = 1024
    if (my_rank == root) then
        print *, "Enter the interval [a, b] and the number of steps m:"
        read *, a, b, m
        do r = 1, n_ranks - 1
            call MPI_Send(a, 1, MPI_REAL,    r, 0, comm)
            call MPI_Send(b, 1, MPI_REAL,    r, 0, comm)
            call MPI_Send(m, 1, MPI_INTEGER, r, 0, comm)
        end do
    else ! my_rank /= root
        call MPI_Recv(a, 1, MPI_REAL,    root, 0, comm, status)
        call MPI_Recv(b, 1, MPI_REAL,    root, 0, comm, status)
        call MPI_Recv(m, 1, MPI_INTEGER, root, 0, comm, status)
    end if

    step = (b - a) / m
    m_r  = m / n_ranks

    a_r = a   + my_rank * m_r * step
    b_r = a_r +           m_r * step
    integral = trap_integral(a_r, b_r, m_r)

    if (my_rank /= root) then
        call MPI_Send(integral, 1, MPI_REAL, root, 0, comm)
    else ! my_rank == root
        total = integral
        do r = 1, n_ranks - 1
            call MPI_Recv(integral, 1, MPI_REAL, r, 0, comm, status)
            total = total + integral
        end do
        print '(a, i0, 3(a, es12.6))', &
            "With ", m, " trapezoids the integral from ", a, " to ", b, " is ", total
    end if

    call MPI_Finalize()
contains
    !---------------------------------------------------------------------------
    function func(x)
        implicit none
        real :: func
        real, intent(in) :: x

        func = sin(1.0 / x)
        return
    end function func
    !---------------------------------------------------------------------------
    function trap_integral(x_s, x_e, steps)
        implicit none
        real                :: trap_integral
        real,    intent(in) :: x_s, x_e
        integer, intent(in) :: steps
        integer :: i
        real    :: x, dx

        dx = (x_e - x_s) / steps
        trap_integral = (func(x_s) + func(x_e)) / 2.0
        x = x_s
        do i = 2, steps
            x = x + dx
            trap_integral = trap_integral + func(x)
        end do
        trap_integral = trap_integral * dx
        return
    end function trap_integral
end program trapezoidal_p2p


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

!       array expression in parallel loops
        program tomp
        implicit none

        integer n
        parameter(n=100)
        real A(n,n)
        integer i,j
        real dsum
	real result(2),expect(2)
	data expect/1020000,1020000/

        do i=1,n
        do j=1,n
           A(i,j) = real(i+j+1)
        enddo
        enddo

        dsum = 0.0
!$omp   parallel do private(i) reduction(+:dsum)
        do i=1,n
          dsum = dsum + sum(A(i,:n))  !a$r is SC_LOCAL, but should be private
        enddo

	result(1) = dsum
        !print*,' dsum in i', dsum

        dsum = 0.0
!$omp   parallel do private(j) reduction(+:dsum)
        do j=1,n
          dsum = dsum + sum(A(:n, j)) !a$r1 is SC_LOCAL, but should be private
        enddo

        !print*,'dsum in j ', dsum
	result(2) = dsum

        call check(result,expect,2)
        end


      SUBROUTINE FOLD (LA,A,LB,B,LC,C)
C
C     THIS SUBROUTINE FINDS THE COMPLETE TRANSIENT CONVOLUTION OF THE
C     VECTORS A AND B
C
C     INPUTS ARE
C        LA=LENGTH OF THE VECTOR A    INTEGER*4
C         A=THE VECTOR A, A(1),A(2),...A(LA)      REAL*4
C        LB=LENGTH OF THE VECTOR B      INTEGER*4
C         B=THE VECTOR B, B(1),B(2),...B(LB)    REAL*4
C     OUTPUTS ARE
C        LC=LA+LB-1=LENGTH OF THE VECTOR C     INTEGER*4
C         C=THE COMPLETE TRANSIENT CONVOLUTION VECTOR C     REAL*4
C
C      Robinson, page 29
C
      DIMENSION A(LA),B(LB),C(LC)
      LC=LA+LB-1
      CALL ZERO(LC,C)
      DO I = 1, LA
         DO J = 1, LB
            K = I + J - 1
            C(K) = C(K) + A(I) * B(J)
         ENDDO
      ENDDO
      RETURN
      END


SUBROUTINE getpercentile(N,array,q25,q75)
    real q25
    real q75
    integer N
    real,intent(in) :: array(*)
    integer idx

    real RA(N)
    RA(1:N) = array(1:N)
  L=N/2+1
  IR=N
  !The index L will be decremented from its initial value during the
  !"hiring" (heap creation) phase. Once it reaches 1, the index IR
  !will be decremented from its initial value down to 1 during the
  !"retirement-and-promotion" (heap selection) phase.
10 continue
  if(L > 1)then
    L=L-1
    RRA=RA(L)
  else
    RRA=RA(IR)
    RA(IR)=RA(1)
    IR=IR-1
    if(IR.eq.1)then
      RA(1)=RRA
     idx = int(0.25*N)
     q25 = RA(idx)
     idx = int(0.75*N)
     q75 = RA(idx)
      return
    end if
  end if
  I=L
  J=L+L
20 if(J.le.IR)then
  if(J < IR)then
    if(RA(J) < RA(J+1))  J=J+1
  end if
  if(RRA < RA(J))then
    RA(I)=RA(J)
    I=J; J=J+J
  else
    J=IR+1
  end if
  goto 20
  end if
  RA(I)=RRA
  goto 10

END


module mRCM
! By Kristoffer Andersen, Dec 2016
! Updated by Tue Boesen, August 2017
! These routines can be used to reorder a matrix.
! The only dependecies are to mSmat, mError, mArrays and mQuicksort
!
!   The main routines are>
!       RCMSort - performs a reverse Cuthill-McKee ordering of a matrix
!       SymPerm - performs a symmetric permutation of a matrix: PAP^t
!       HalfPermOnlyTranspose - by using permutation operations this
!               routine finds the transpose of a matrix

    use mSMat
    implicit none

    contains
    subroutine RCMSort(ioA,oPerm)
    ! Kristoffer Andersen, Dec 2016
    ! this routine finds the reverse Cuthill-McKee ordering of matrix ioA
    ! and makes the symmetric permutation A = PAP^t
    !
    ! IO
    ! IO - ioA - on input the unpermuted matrix
    !            on output the permuted matrix
    ! O - oPerm - the permuatation vector - this can ie be used for the vectors used together with the matrix
    !
    implicit none
    type(Tsparsemat),intent(inout)  :: ioA
    integer,intent(out)             :: oPerm(:)
    ! prog
    call RCMOrdering(ioA,oPerm)
    call symperm(ioA,oPerm)
    end subroutine

    subroutine RCMOrdering(iA,oRCMind,opStartIndex)
    ! Kristoffer Andersen, Dec 2016
    ! this routine finds the reverse Cuthill-McKee ordering for a
    ! symmetric sparse matrix iA.
    ! IO
    ! IO - iA - the unpermuted matrix
    ! O - RCMind - the permutation vector - this can ie be used for the vectors used together with the matrix
    ! I (optional) - opStartIndex - optional start index (default = 1)
    !
    use mArrays
    use mQuickSort
    implicit none
    type(Tsparsemat),intent(inout)  :: iA
    integer,intent(out)             :: oRCMind(:)
    integer,intent(in),optional     :: opStartIndex
    !var
    logical, allocatable        :: inRCMind(:)
    integer :: i,j,k,ni,ni1,nneighbours,jn,ad,itot,inArray,MinEle,n,MaxEle
    integer,allocatable :: Neighbours(:),Adj(:),R(:),ele(:)
    !prog

    allocate(inRCMind(iA%NoRows))
    allocate(Ele(iA%NoRows))
    allocate(R(iA%NoRows))

    inRCMInd(:) = .false. ! non sorted

    MaxEle=-1
    Ele=-1
    do j=1,iA%NoRows
       n=iA%RowIdxs(j+1)-iA%RowIdxs(j)
       MaxEle=max(MaxEle,n)
       Ele(j)=n
    end do

    allocate(Neighbours(MaxEle))
    allocate(Adj(MaxEle))

    R=-1
    itot = 1
    inArray = 0
    do
        if(itot.gt.iA%NoRows) exit ! termination
        if(inArray.ge.iA%NoRows ) exit

        if(R(itot).eq.-1) then
          MinEle=999999
          inArray=inArray+1
          do j=1,iA%NoRows
            if (inRCMInd(j)) then
              cycle
            end if
            n=iA%RowIdxs(j+1)-iA%RowIdxs(j)
            if (n.lt.MinEle) then
              MinEle=n
              R(itot)=j
            end if
          end do
        end if
        i = R(itot)  !present index
        inRCMInd(i) = .true. !Mark it

        ! get neighbours
        ni = iA%Rowidxs(I)
        ni1 = iA%Rowidxs(I+1)
        Nneighbours = ni1-ni
        Neighbours(1:Nneighbours) = ia%Colidxs(ni:(ni1-1))
        ! remove already present neighbours - this will also remove the self reference
        jn = 1
        do j = 1,Nneighbours
            if(.not.inRCMInd(Neighbours(J))) then
                Neighbours(Jn) = Neighbours(J)
                jn = jn+1
            endif
        enddo
        Nneighbours = jn-1

        Adj(1:Nneighbours)=Ele(Neighbours(1:Nneighbours))
        ! sorting
        call IntQSortC(adj(1:Nneighbours),Neighbours(1:Nneighbours))  ! we need a real type routine for this.

        !Add new nodes to the queue
        do j = 1,Nneighbours
            inArray = inArray+1
            R(inArray) = Neighbours(j) ! add neighbours
            inRCMInd(Neighbours(J)) = .true. ! mark as included
        enddo
        itot = itot+1
    enddo

    ! finally reverse the order
    do i=1,(iA%NoRows)
        oRCMind(i) = R(iA%NoRows-i+1)
    enddo

    return
    ! error messages
    end subroutine RCMOrdering

    subroutine halfperm(iA,oB,iPerm,opColCounts)
    ! by Kristoffer Andersen, Dec 2016
    ! this routine performs the operation B = (P*A)^t, where P is er
    ! permutation vector of A
    ! The out is sorted independent on the status of the input - nice feature!
    !
    ! IO
    ! I iA - unpermuted matrix
    ! O oB - permuted and sorted matrix
    ! I iPerm - permutation vector
    ! I opColCounts (optional) - used to speed up repeated calls of the routine.
    implicit none
    !io
    type(Tsparsemat),intent(in) :: iA
    type(Tsparsemat),intent(out) :: oB
    integer,intent(in) :: iPerm(:)
    integer,intent(in),optional :: opColCounts(:)
    !var
    integer :: pi,i,j,jp,p,pm1,pm2,jpt
    !prog

    call SMatCreate(oB,ia%NoCols,iA%NoRows,'(PA)^T',.false.,iA%NoElements)

    ! create column structure in permuted matrix - the column count is unchanged by row permutations
    if(present(opColCounts)) then ! when halfperm is called twice in symperm, one already knows this
        oB%RowIdxs(1:iA%NoRows) = opColCounts(1:iA%NoRows)
    else
        oB%RowIdxs(:) = 0
        do i=1,iA%NoRows
            do j=iA%RowIDxs(i),iA%RowIdxs(i+1)-1
                oB%RowIdxs(iA%ColIDxs(j)) = oB%RowIdxs(iA%ColIDxs(j))+1  ! find coumn counts
            enddo
        enddo
    endif
    ! create column pointers
    pm2 = 0
    pm1 = 1
    do i=3,iA%NoCols+3
        p = pm1+ob%RowIdxs(i-2)
        ob%RowIdxs(i-2) = pm2
        pm2 =pm1
        pm1 = p
    enddo

    ! fill matrix
    do i=1,iA%NoRows
        pi = iPerm(i) ! get the permuted row
        do jp=iA%RowIDxs(pi),iA%RowIdxs(pi+1)-1
            j = iA%ColIdxs(jp)
            jpt = oB%RowIdxs(j+1)
            ob%ColIdxs(jpt) = i
            oB%Vals(jpt) = iA%Vals(jp)
            oB%RowIdxs(j+1) = jpt+1
        enddo
    enddo
    oB%RowIdxs(1) = 1
    oB%NoElements = iA%NoElements

    return
    ! error messages

    end subroutine halfperm

    subroutine halfpermOnlyTranspose(iA,oB)
    ! by Kristoffer Andersen, Dec 2016
    ! this routine performs the operation B = A^t
    ! The out is sorted independent on the status of the input - nice feature!
    !
    ! IO
    ! I iA - unpermuted matrix
    ! O oB - permuted and sorted matrix
    !
    implicit none
    !io
    type(Tsparsemat),intent(in) :: iA
    type(Tsparsemat),intent(out) :: oB
    !var
    integer :: pi,i,j,jp,p,pm1,pm2,jpt
    !prog
    call SMatCreate(oB,ia%NoCols,iA%NoRows,'(A)^T',.false.,iA%NoElements)

    ! create column structure in permuted matrix - the column count is unchanged by row permutations
    oB%RowIdxs(:) = 0
    do i=1,iA%NoRows
        do j=iA%RowIDxs(i),iA%RowIdxs(i+1)-1
            oB%RowIdxs(iA%ColIDxs(j)) = oB%RowIdxs(iA%ColIDxs(j))+1  ! find coumn counts
        enddo
    enddo

    ! create column pointers
    pm2 = 0
    pm1 = 1
    do i=3,iA%NoCols+3
        p = pm1+ob%RowIdxs(i-2)
        ob%RowIdxs(i-2) = pm2
        pm2 =pm1
        pm1 = p
    enddo

    ! fill matrix
    do i=1,iA%NoRows
        pi = i ! get row
        do jp=iA%RowIDxs(pi),iA%RowIdxs(pi+1)-1
            j = iA%ColIdxs(jp)
            jpt = oB%RowIdxs(j+1)
            ob%ColIdxs(jpt) = i
            oB%Vals(jpt) = iA%Vals(jp)
            oB%RowIdxs(j+1) = jpt+1
        enddo
    enddo
    oB%RowIdxs(1) = 1
    oB%NoElements = iA%NoElements

    return
    ! error messages

    end subroutine halfpermOnlyTranspose

    subroutine symperm(ioA,iPerm)
    ! by Kristoffer Andersen, Dec 2016
    ! performs the halfperm twice in order to get B = PAP^t = (P(PA)^t)^t
    !
    ! IO
    ! IO ioA - in input: unpermuted matrix
    !          on output: permuted and sorted matrix
    ! I iPerm- permutation vector
    implicit none
    !io
    type(Tsparsemat),intent(inout) :: ioA
    integer,intent(in) :: iPerm(:)
    !var
    type(tsparsemat) :: temp
    integer,allocatable :: ColCounts(:)
    integer :: i,pi,N
    !prog
    call halfperm(ioA,temp,iPerm)
    N = ioA%NoRows
    allocate(ColCounts(N))
    do i = 1,N
        pi = iPerm(i)
        ColCounts(i) = ioA%RowIdxs(pi+1)-ioA%RowIdxs(pi)
    enddo
    call halfperm(temp,ioA,iPerm,ColCounts)
    return
    end subroutine symperm

    subroutine PermuteVector(ioV,iPerm)
    ! by Kristoffer Andersen, Dec 2016
    ! this routine permutes a vector according to iPerm
    !
    ! IO
    ! IO ioV - in input: unpermuted vector
    !          on output: permuted vector
    ! I iPerm- permutation vector
    real*8,intent(inout) :: ioV(:)
    integer,intent(in) :: iPerm(:)
    ! var
    real*8,allocatable :: temp(:)
    integer :: i,N
    !prog
    N = ubound(ioV,1)
    allocate(temp(N))
    temp(1:N) = ioV(1:N)
    do i=1,N
        ioV(iPerm(i)) = temp(i)
    enddo
    return
    end subroutine PermuteVector

end module mRCM


module mod_monolis_eigen_lanczos
  use mod_monolis_prm
  use mod_monolis_com
  use mod_monolis_mat
  use mod_monolis_solve
  use mod_monolis_eigen_lanczos_util

  implicit none

contains

  subroutine monolis_eigen_inverted_standard_lanczos &
    & (monolis, n_get_eigen, ths, maxiter, val, vec, is_bc)
    implicit none
    type(monolis_structure) :: monolis
    integer(kint) :: n_get_eigen, maxiter
    real(kdouble) :: ths, val(:), vec(:,:)
    logical, optional :: is_bc(:)

    call monolis_eigen_inverted_standard_lanczos_(monolis%PRM, monolis%COM, monolis%MAT, &
      & n_get_eigen, ths, maxiter, val, vec, is_bc)
  end subroutine monolis_eigen_inverted_standard_lanczos

  subroutine monolis_eigen_inverted_standard_lanczos_ &
    & (monoPRM, monoCOM, monoMAT, n_get_eigen, ths, maxiter, val, vec, is_bc)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kint) :: N, NP, NDOF, total_dof, j, k
    integer(kint) :: i, iter, maxiter, n_get_eigen
    real(kdouble) :: beta_t, ths, norm
    real(kdouble) :: vec(:,:), val(:)
    real(kdouble), allocatable :: p(:), q(:,:), alpha(:), beta(:), eigen_value(:), eigen_mode(:,:), prev(:)
    logical :: is_converge
    logical, optional :: is_bc(:)

    if(monoPRM%is_debug) call monolis_debug_header("monolis_eigen_inverted_standard_lanczos_")

    N     = monoMAT%N
    NP    = monoMAT%NP
    NDOF  = monoMAT%NDOF
    norm = 0.0d0
    is_converge = .false.

    total_dof = N*NDOF
    call monolis_allreduce_I1(total_dof, monolis_sum, monoCOM%comm)

    if(n_get_eigen > total_dof) n_get_eigen = total_dof

    allocate(alpha(maxiter), source = 0.0d0)
    allocate(beta(maxiter+1), source = 0.0d0)
    allocate(eigen_value(maxiter), source = 0.0d0)
    allocate(prev(maxiter), source = 0.0d0)
    allocate(q(NP*NDOF,0:maxiter+1), source = 0.0d0)
    allocate(p(NP*NDOF), source = 0.0d0)
    allocate(eigen_mode(NP*NDOF,maxiter), source = 0.0d0)

    call lanczos_initialze(NP*NDOF, q(:,1), is_bc)

    do iter = 1, maxiter
      call monolis_set_RHS(monoMAT, q(:,iter))

      call monolis_solve_(monoPRM, monoCOM, monoMAT)

      call monolis_vec_AXPY(N, NDOF, -beta(iter), q(:,iter-1), monoMAT%X, p)

      call monolis_inner_product_R(monoCOM, N, NDOF, p, q(:,iter), alpha(iter))

      call monolis_vec_AXPY(N, NDOF, -alpha(iter), q(:,iter), p, p)

      call monolis_gram_schmidt(monoPRM, monoCOM, monoMAT, iter, q, p)

      call monolis_inner_product_R(monoCOM, N, NDOF, p, p, beta_t)

      beta(iter+1) = dsqrt(beta_t)
      beta_t = 1.0d0/beta(iter+1)
      do i = 1, NP*NDOF
        q(i,iter+1) = p(i)*beta_t
      enddo

      call monolis_get_eigen_pair_from_tridiag(iter, alpha, beta, q, eigen_value, eigen_mode)

      if(iter > n_get_eigen)then
        norm = 0.0d0
        do i = 1, n_get_eigen
          norm = max(norm, dabs(prev(i) - eigen_value(i)))
        enddo
        if(norm < ths) is_converge = .true.
      endif
      prev = eigen_value

write(*,"(a,i6,a,1p2e12.4)")"iter: ", iter, ", ths: ", norm

      if(is_converge .or. iter >= total_dof .or. iter == maxiter)then
        do i = 1, n_get_eigen
          val(i) = eigen_value(i)
          do j = 1, NP*NDOF
            vec(j,i) = eigen_mode(j,i)
          enddo
        enddo
        exit
      endif
    enddo
  end subroutine monolis_eigen_inverted_standard_lanczos_

end module mod_monolis_eigen_lanczos

  subroutine interface_monolis_eigen_inverted_standard_lanczos_ &
    & (monoPRM, monoCOM, monoMAT, NPNDOF, &
    & n_get_eigen, ths, maxiter, val, vec, is_bc)
    use mod_monolis_prm
    use mod_monolis_com
    use mod_monolis_mat
    use mod_monolis_eigen_lanczos
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kint) :: maxiter, n_get_eigen, NPNDOF
    real(kdouble) :: ths
    real(kdouble) :: vec(NPNDOF,n_get_eigen), val(n_get_eigen)
    logical, optional :: is_bc(NPNDOF)

    call monolis_eigen_inverted_standard_lanczos_(monoPRM, monoCOM, monoMAT, &
      & n_get_eigen, ths, maxiter, val, vec, is_bc)
  end subroutine interface_monolis_eigen_inverted_standard_lanczos_


! { dg-do run }
!
! Rolls together 'len_par_06_pos.f90' and 'len_par_07_pos.f90', both of which
! failed to compile.
!
! Contributed by Reinhold Bader  <reinhold.bader@lrz.de>
!
module m_type_decs

  implicit none

  type :: matrix(rk, n, m)
     integer, kind :: rk
     integer, len :: n = 15, m = 20
     real(rk) :: entry(n, m)
  end type matrix

  type :: fdef(rk, n)
     integer, kind :: rk = kind(1.0)
     integer, len :: n = 15
  end type

end module

program test

  use m_type_decs
  implicit none
  integer, parameter :: rk1=kind(1.d0)
  type(matrix(rk1,:,:)), allocatable :: o_matrix
  type(fdef(n=:)), allocatable :: o_fdef

  allocate(matrix(rk=rk1)::o_matrix)

  if (o_matrix%n == 15 .and. o_matrix%m == 20) then
     write(*,*) 'o_matrix OK'
  else
     write(*,*) 'o_matrix FAIL'
     STOP 1
  end if

  allocate(fdef(n=12)::o_fdef)

  if (o_fdef%n == 12) then
     write(*,*) 'o_fdef OK'
  else
     write(*,*) 'o_fdef FAIL'
     STOP 2
  end if
end program test


C
C     ***********************
C     SIMPLE DRIVER FOR LBFGS
C     ***********************
C
C     Example of driver for LBFGS routine, using a
C     simple test problem. The solution point is at
C     X=(1,...,1) and the optimal function value of 0.
C
C                          JORGE NOCEDAL
C                        *** July 1990 ***
C
      PROGRAM SDRIVE
      PARAMETER(NDIM=2000,MSAVE=7,NWORK=NDIM*(2*MSAVE +1)+2*MSAVE)
      DOUBLE PRECISION X(NDIM),G(NDIM),DIAG(NDIM),W(NWORK)
      DOUBLE PRECISION F,EPS,XTOL,GTOL,T1,T2,STPMIN,STPMAX
      INTEGER IPRINT(2),IFLAG,ICALL,N,M,MP,LP,J
      LOGICAL DIAGCO
C
C     The driver for LBFGS must always declare LB2 as EXTERNAL
C
      EXTERNAL LB2
      COMMON /LB3/MP,LP,GTOL,STPMIN,STPMAX
C
      N=100
      M=5
      IPRINT(1)= 1
      IPRINT(2)= 0
C
C     We do not wish to provide the diagonal matrices Hk0, and
C     therefore set DIAGCO to FALSE.
C
      DIAGCO= .FALSE.
      EPS= 1.0D-5
      XTOL= 1.0D-16
      ICALL=0
      IFLAG=0
      DO 10 J=1,N,2
         X(J)=-1.2D0
         X(J+1)=1.D0
 10   CONTINUE
C
 20   CONTINUE
      F= 0.D0
      DO 30 J=1,N,2
        T1= 1.D0-X(J)
        T2= 1.D1*(X(J+1)-X(J)**2)
        G(J+1)= 2.D1*T2
        G(J)= -2.D0*(X(J)*G(J+1)+T1)
        F= F+T1**2+T2**2
 30   CONTINUE
      CALL LBFGS(N,M,X,F,G,DIAGCO,DIAG,IPRINT,EPS,XTOL,W,IFLAG)
      IF(IFLAG.LE.0) GO TO 50
      ICALL=ICALL + 1
C     We allow at most 2000 evaluations of F and G
      IF(ICALL.GT.2000) GO TO 50
      GO TO 20
  50  CONTINUE
      END
C
C     ** LAST LINE OF SIMPLE DRIVER (SDRIVE) **


      REAL*4 FUNCTION COSD(ARG)

!PURPOSE: Calculate cosine from angle in deg.

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

      REAL*4        ARG                 !Cosine argument in degrees

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA  RPD/0.017453292519943/

!CODE:

      COSD = COS(ARG*RPD)
      RETURN
      END


!Copyright (c) 2012-2022, Xcompact3d
!This file is part of Xcompact3d (xcompact3d.com)
!SPDX-License-Identifier: BSD 3-Clause

module mom

  use MPI

  use decomp_2d, only : nrank
  use decomp_2d, only : mytype, real_type
  use decomp_2d, only : xsize, ysize, zsize
  use decomp_2d, only : xstart, ystart, zstart
  use param, only : dx, dy, dz, xlx, yly, zlz
  use variables, only : test_mode
  use var, only : nx, ny, nz
  use var, only : zero, two, pi

  implicit none

  private
  public :: vel, test_du, test_dv, test_dw

contains

  subroutine vel(u, v, w)

    real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(out) :: u, v, w

    real(mytype) :: x, y, z
    integer :: i, j, k

    do k = 1, xsize(3)
       z = (k + xstart(3) - 2) * dz
       do j = 1, xsize(2)
          y = (j + xstart(2) - 2) * dy
          do i = 1, xsize(1)
             x = (i + xstart(1) - 2) * dx

             u(i, j, k) = sin(two * pi * (x / xlx)) * cos(two * pi * (y / yly)) * cos(two * pi * (z / zlz))
             v(i, j, k) = cos(two * pi * (x / xlx)) * sin(two * pi * (y / yly)) * cos(two * pi * (z / zlz))
             w(i, j, k) = -two * cos(two * pi * (x / xlx)) * cos(two * pi * (y / yly)) * sin(two * pi * (z / zlz))
          enddo
       enddo
    enddo

  endsubroutine vel

  subroutine test_du(du)

    real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: du

    real(mytype) :: x, y, z
    integer :: i, j, k
    integer :: ierr

    real(mytype) :: err, errloc
    real(mytype) :: du_ana

    if (test_mode) then
       if (nrank .eq. 0 ) then
          open(101, file="du.dat", action="write", status="unknown")
       endif

       errloc = zero
       do k = 1, xsize(3)
          z = (k + xstart(3) - 2) * dz
          do j = 1, xsize(2)
             y = (j + xstart(2) - 2) * dy
             do i = 1, xsize(1)
                x = (i + xstart(1) - 2) * dx

                du_ana = cos(two * pi * (x / xlx)) * cos(two * pi * (y / yly)) * cos(two * pi * (z / zlz))
                du_ana = two * pi * du_ana / xlx
                errloc = errloc + (du(i, j, k) - du_ana)**2

                if (nrank .eq. 0) then
                   if ((j.eq.1) .and. (k.eq.1)) then
                      write(101, *) x, du(i, j, k), du_ana, errloc
                   endif
                endif
             enddo
          enddo
       enddo
       call MPI_ALLREDUCE(errloc, err, 1, real_type, MPI_SUM, MPI_COMM_WORLD, ierr)
       err = sqrt(err / nx / ny / nz)

       if (nrank .eq. 0) then
          print *, "RMS error in dudx: ", err
       end if

       if (nrank .eq. 0) then
          close(101)
       endif
    end if

  endsubroutine test_du

  subroutine test_dv(dv)

    real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: dv

    real(mytype) :: x, y, z
    integer :: i, j, k
    integer :: ierr

    real(mytype) :: err, errloc
    real(mytype) :: dv_ana

    if (test_mode) then
       if (nrank .eq. 0) then
          open(102, file="dv.dat", action="write", status="unknown")
       endif

       errloc = zero
       do k = 1, ysize(3)
          z = (k + ystart(3) - 2) * dz
          do j = 1, ysize(2)
             y = (j + ystart(2) - 2) * dy
             do i = 1, ysize(1)
                x = (i + ystart(1) - 2) * dx

                dv_ana = cos(two * pi * (x / xlx)) * cos(two * pi * (y / yly)) * cos(two * pi * (z / zlz))
                dv_ana = two * pi * dv_ana / yly
                errloc = errloc + (dv(i, j, k) - dv_ana)**2
                if (nrank .eq. 0) then
                   if ((i.eq.1) .and. (k.eq.1)) then
                      write(102, *) y, dv(i, j, k), dv_ana, errloc
                   endif
                endif
             enddo
          enddo
       enddo
       call MPI_ALLREDUCE(errloc, err, 1, real_type, MPI_SUM, MPI_COMM_WORLD, ierr)
       err = sqrt(err / nx / ny / nz)

       if (nrank .eq. 0) then
          print *, "RMS error in dvdy: ", err
       end if

       if (nrank .eq. 0) then
          close(102)
       endif
    end if

  endsubroutine test_dv

  subroutine test_dw(dw)

    real(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(in) :: dw

    real(mytype) :: x, y, z
    integer :: i, j, k
    integer :: ierr

    real(mytype) :: err, errloc
    real(mytype) :: dw_ana

    if (test_mode) then
       if (nrank .eq. 0) then
          open(103, file="dw.dat", action="write", status="unknown")
       endif

       errloc = zero
       do k = 1, zsize(3)
          z = (k + zstart(3) - 2) * dz
          do j = 1, zsize(2)
             y = (j + zstart(2) - 2) * dy
             do i = 1, zsize(1)
                x = (i + zstart(1) - 2) * dx

                dw_ana = -two * cos(two * pi * (x / xlx)) * cos(two * pi * (y / yly)) * cos(two * pi * (z / zlz))
                dw_ana = two * pi * dw_ana / zlz
                errloc = errloc + (dw(i, j, k) - dw_ana)**2

                if (nrank .eq. 0) then
                   if ((i.eq.1) .and. (j.eq.1)) then
                      write(103, *) z, dw(i, j, k), dw_ana, errloc
                   endif
                endif
             enddo
          enddo
       enddo
       call MPI_ALLREDUCE(errloc, err, 1, real_type, MPI_SUM, MPI_COMM_WORLD, ierr)
       err = sqrt(err / nx / ny / nz)

       if (nrank .eq. 0) then
          print *, "RMS error in dwdz: ", err
       end if

       if (nrank .eq. 0) then
          close(103)
       endif
    end if

  endsubroutine test_dw

end module mom


program t
  implicit none
  REAL C,F,TEMP
  C(F) = 5.0*(F - 32.0)/9.0
  print '(f5.1)',c(32.0)
  print '(f5.1)',c(212.0)
end program t


FUNCTION MULTIPLY(X,Y)
REAL MULTIPLY, X, Y
MULTIPLY = X * Y
END


      SUBROUTINE MB02DD( JOB, TYPET, K, M, N, TA, LDTA, T, LDT, G,
     $                   LDG, R, LDR, L, LDL, CS, LCS, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To update the Cholesky factor and the generator and/or the
C     Cholesky factor of the inverse of a symmetric positive definite
C     (s.p.d.) block Toeplitz matrix T, given the information from
C     a previous factorization and additional blocks in TA of its first
C     block row, or its first block column, depending on the routine
C     parameter TYPET. Transformation information is stored.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the output of the routine, as follows:
C             = 'R':  updates the generator G of the inverse and
C                     computes the new columns / rows for the Cholesky
C                     factor R of T;
C             = 'A':  updates the generator G, computes the new
C                     columns / rows for the Cholesky factor R of T and
C                     the new rows / columns for the Cholesky factor L
C                     of the inverse;
C             = 'O':  only computes the new columns / rows for the
C                     Cholesky factor R of T.
C
C     TYPET   CHARACTER*1
C             Specifies the type of T, as follows:
C             = 'R':  the first block row of an s.p.d. block Toeplitz
C                     matrix was/is defined; if demanded, the Cholesky
C                     factors R and L are upper and lower triangular,
C                     respectively, and G contains the transposed
C                     generator of the inverse;
C             = 'C':  the first block column of an s.p.d. block Toeplitz
C                     matrix was/is defined; if demanded, the Cholesky
C                     factors R and L are lower and upper triangular,
C                     respectively, and G contains the generator of the
C                     inverse. This choice results in a column oriented
C                     algorithm which is usually faster.
C             Note:   in this routine, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows / columns in T, which should be equal
C             to the blocksize.  K >= 0.
C
C     M       (input)  INTEGER
C             The number of blocks in TA.  M >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in T.  N >= 0.
C
C     TA      (input/output)  DOUBLE PRECISION array, dimension
C             (LDTA,M*K) / (LDTA,K)
C             On entry, the leading K-by-M*K / M*K-by-K part of this
C             array must contain the (N+1)-th to (N+M)-th blocks in the
C             first block row / column of an s.p.d. block Toeplitz
C             matrix.
C             On exit, if INFO = 0, the leading K-by-M*K / M*K-by-K part
C             of this array contains information on the Householder
C             transformations used, such that the array
C
C                        [ T  TA ]    /    [ T  ]
C                                          [ TA ]
C
C             serves as the new transformation matrix T for further
C             applications of this routine.
C
C     LDTA    INTEGER
C             The leading dimension of the array TA.
C             LDTA >= MAX(1,K),   if TYPET = 'R';
C             LDTA >= MAX(1,M*K), if TYPET = 'C'.
C
C     T       (input)  DOUBLE PRECISION array, dimension (LDT,N*K) /
C             (LDT,K)
C             The leading K-by-N*K / N*K-by-K part of this array must
C             contain transformation information generated by the SLICOT
C             Library routine MB02CD, i.e., in the first K-by-K block,
C             the upper / lower Cholesky factor of T(1:K,1:K), and in
C             the remaining part, the Householder transformations
C             applied during the initial factorization process.
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= MAX(1,K),    if TYPET = 'R';
C             LDT >= MAX(1,N*K),  if TYPET = 'C'.
C
C     G       (input/output)  DOUBLE PRECISION array, dimension
C             (LDG,( N + M )*K) / (LDG,2*K)
C             On entry, if JOB = 'R', or 'A', then the leading
C             2*K-by-N*K / N*K-by-2*K part of this array must contain,
C             in the first K-by-K block of the second block row /
C             column, the lower right block of the Cholesky factor of
C             the inverse of T, and in the remaining part, the generator
C             of the inverse of T.
C             On exit, if INFO = 0 and JOB = 'R', or 'A', then the
C             leading 2*K-by-( N + M )*K / ( N + M )*K-by-2*K part of
C             this array contains the same information as on entry, now
C             for the updated Toeplitz matrix. Actually, to obtain a
C             generator of the inverse one has to set
C               G(K+1:2*K, 1:K) = 0,    if TYPET = 'R';
C               G(1:K, K+1:2*K) = 0,    if TYPET = 'C'.
C
C     LDG     INTEGER
C             The leading dimension of the array G.
C             LDG >= MAX(1,2*K),  if TYPET = 'R' and JOB = 'R', or 'A';
C             LDG >= MAX(1,( N + M )*K),
C                                 if TYPET = 'C' and JOB = 'R', or 'A';
C             LDG >= 1,           if JOB = 'O'.
C
C     R       (input/output)  DOUBLE PRECISION array, dimension
C             (LDR,M*K) / (LDR,( N + M )*K)
C             On input, the leading N*K-by-K part of R(K+1,1) /
C             K-by-N*K part of R(1,K+1) contains the last block column /
C             row of the previous Cholesky factor R.
C             On exit, if INFO = 0, then the leading
C             ( N + M )*K-by-M*K / M*K-by-( N + M )*K part of this
C             array contains the last M*K columns / rows of the upper /
C             lower Cholesky factor of T. The elements in the strictly
C             lower / upper triangular part are not referenced.
C
C     LDR     INTEGER
C             The leading dimension of the array R.
C             LDR >= MAX(1, ( N + M )*K), if TYPET = 'R';
C             LDR >= MAX(1, M*K),         if TYPET = 'C'.
C
C     L       (output)  DOUBLE PRECISION array, dimension
C             (LDL,( N + M )*K) / (LDL,M*K)
C             If INFO = 0 and JOB = 'A', then the leading
C             M*K-by-( N + M )*K / ( N + M )*K-by-M*K part of this
C             array contains the last M*K rows / columns of the lower /
C             upper Cholesky factor of the inverse of T. The elements
C             in the strictly upper / lower triangular part are not
C             referenced.
C
C     LDL     INTEGER
C             The leading dimension of the array L.
C             LDL >= MAX(1, M*K),         if TYPET = 'R' and JOB = 'A';
C             LDL >= MAX(1, ( N + M )*K), if TYPET = 'C' and JOB = 'A';
C             LDL >= 1,                   if JOB = 'R', or 'O'.
C
C     CS      (input/output)  DOUBLE PRECISION array, dimension (LCS)
C             On input, the leading 3*(N-1)*K part of this array must
C             contain the necessary information about the hyperbolic
C             rotations and Householder transformations applied
C             previously by SLICOT Library routine MB02CD.
C             On exit, if INFO = 0, then the leading 3*(N+M-1)*K part of
C             this array contains information about all the hyperbolic
C             rotations and Householder transformations applied during
C             the whole process.
C
C     LCS     INTEGER
C             The length of the array CS.  LCS >= 3*(N+M-1)*K.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -19,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,(N+M-1)*K).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The block Toeplitz
C                   matrix associated with [ T  TA ] / [ T'  TA' ]' is
C                   not (numerically) positive definite.
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C                               3         2
C     The algorithm requires 0(K ( N M + M ) ) floating point
C     operations.
C
C     FURTHER COMMENTS
C
C     For min(K,N,M) = 0, the routine sets DWORK(1) = 1 and returns.
C     Although the calculations could still be performed when N = 0,
C     but min(K,M) > 0, this case is not considered as an "update".
C     SLICOT Library routine MB02CD should be called with the argument
C     M instead of N.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Chemnitz, Germany, December 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000,
C     Feb. 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB, TYPET
      INTEGER           INFO, K, LCS, LDG, LDL, LDR, LDT, LDTA, LDWORK,
     $                  M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*),
     $                  T(LDT,*), TA(LDTA,*)
C     .. Local Scalars ..
      INTEGER           I, IERR, J, MAXWRK, STARTI, STARTR, STARTT
      LOGICAL           COMPG, COMPL, ISROW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLACPY, DLASET, DTRSM, MB02CX, MB02CY,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      COMPL = LSAME( JOB, 'A' )
      COMPG = LSAME( JOB, 'R' ) .OR. COMPL
      ISROW = LSAME( TYPET, 'R' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( COMPG .OR. LSAME( JOB, 'O' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -2
      ELSE IF ( K.LT.0 ) THEN
         INFO = -3
      ELSE IF ( M.LT.0 ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( LDTA.LT.1 .OR. ( ISROW .AND. LDTA.LT.K ) .OR.
     $                    ( .NOT.ISROW .AND. LDTA.LT.M*K ) ) THEN
         INFO = -7
      ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR.
     $                   ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN
         INFO = -9
      ELSE IF ( ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K )
     $                .OR. ( .NOT.ISROW .AND. LDG.LT.( N + M )*K ) ) )
     $          .OR. LDG.LT.1 ) THEN
         INFO = -11
      ELSE IF ( ( (      ISROW .AND. LDR.LT.( N + M )*K ) .OR.
     $            ( .NOT.ISROW .AND. LDR.LT.M*K ) ) .OR.
     $          LDR.LT.1 ) THEN
         INFO = -13
      ELSE IF ( ( COMPL .AND. ( ( ISROW .AND. LDL.LT.M*K )
     $                .OR. ( .NOT.ISROW .AND. LDL.LT.( N + M )*K ) ) )
     $          .OR. LDL.LT.1 ) THEN
         INFO = -15
      ELSE IF ( LCS.LT.3*( N + M - 1 )*K ) THEN
         INFO = -17
      ELSE IF ( LDWORK.LT.MAX( 1, ( N + M - 1 )*K ) ) THEN
         DWORK(1) = MAX( 1, ( N + M - 1 )*K )
         INFO = -19
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02DD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( K, N, M ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      MAXWRK = 1
      IF ( ISROW ) THEN
C
C        Apply Cholesky factor of T(1:K, 1:K) on TA.
C
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, M*K,
     $               ONE, T, LDT, TA, LDTA )
C
C        Initialize the output matrices.
C
         IF ( COMPG ) THEN
            CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(1,N*K+1), LDG )
            IF ( M.GE.N-1 .AND. N.GT.1 ) THEN
               CALL DLACPY( 'All', K, (N-1)*K, G(K+1,K+1), LDG,
     $                      G(K+1,K*(M+1)+1), LDG )
            ELSE
               DO 10  I = N*K, K + 1, -1
                  CALL DCOPY( K, G(K+1,I), 1, G(K+1,M*K+I), 1 )
   10          CONTINUE
            END IF
            CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(K+1,K+1), LDG )
         END IF
C
         CALL DLACPY( 'All', K, M*K, TA, LDTA, R, LDR )
C
C        Apply the stored transformations on the new columns.
C
         DO 20  I = 2, N
C
C           Copy the last M-1 blocks of the positive generator together;
C           the last M blocks of the negative generator are contained
C           in TA.
C
            STARTR =   ( I - 1 )*K + 1
            STARTT = 3*( I - 2 )*K + 1
            CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR,
     $                   R(STARTR,K+1), LDR )
C
C           Apply the transformations stored in T on the generator.
C
            CALL MB02CY( 'Row', 'NoStructure', K, K, M*K, K,
     $                   R(STARTR,1), LDR, TA, LDTA, T(1,STARTR), LDT,
     $                   CS(STARTT), 3*K, DWORK, LDWORK, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
   20    CONTINUE
C
C        Now, we have "normality" and can apply further M Schur steps.
C
         DO 30  I = 1, M
C
C           Copy the first M-I+1 blocks of the positive generator
C           together; the first M-I+1 blocks of the negative generator
C           are contained in TA.
C
            STARTT = 3*( N + I - 2 )*K + 1
            STARTI = ( M - I + 1 )*K + 1
            STARTR = ( N + I - 1 )*K + 1
            IF ( I.EQ.1 ) THEN
               CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR,
     $                      R(STARTR,K+1), LDR )
            ELSE
               CALL DLACPY( 'Upper', K, (M-I+1)*K,
     $                      R(STARTR-K,(I-2)*K+1), LDR,
     $                      R(STARTR,(I-1)*K+1), LDR )
            END IF
C
C           Reduce the generator to proper form.
C
            CALL MB02CX( 'Row', K, K, K, R(STARTR,(I-1)*K+1), LDR,
     $                   TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, DWORK,
     $                   LDWORK, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            IF ( M.GT.I ) THEN
               CALL MB02CY( 'Row', 'NoStructure', K, K, (M-I)*K, K,
     $                      R(STARTR,I*K+1), LDR, TA(1,I*K+1), LDTA,
     $                      TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K,
     $                      DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            END IF
C
            IF ( COMPG ) THEN
C
C              Transformations acting on the inverse generator:
C
               CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1),
     $                      LDG, G(1,STARTR), LDG, TA(1,(I-1)*K+1),
     $                      LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               CALL MB02CY( 'Row', 'NoStructure', K, K, (N+I-1)*K, K,
     $                      G(K+1,STARTI), LDG, G, LDG, TA(1,(I-1)*K+1),
     $                      LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               IF ( COMPL ) THEN
                  CALL DLACPY( 'All', K, (N+I-1)*K, G(K+1,STARTI), LDG,
     $                         L((I-1)*K+1,1), LDL )
                  CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG,
     $                         L((I-1)*K+1,STARTR), LDL )
               END IF
C
            END IF
   30    CONTINUE
C
      ELSE
C
C        Apply Cholesky factor of T(1:K, 1:K) on TA.
C
         CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M*K, K,
     $               ONE, T, LDT, TA, LDTA )
C
C        Initialize the output matrices.
C
         IF ( COMPG ) THEN
            CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(N*K+1,1), LDG )
            IF ( M.GE.N-1 .AND. N.GT.1 ) THEN
               CALL DLACPY( 'All', (N-1)*K, K, G(K+1,K+1), LDG,
     $                      G(K*(M+1)+1,K+1), LDG )
            ELSE
               DO 40  I = 1, K
                  DO 35  J = N*K, K + 1, -1
                     G(J+M*K,K+I) = G(J,K+I)
   35             CONTINUE
   40          CONTINUE
            END IF
            CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(K+1,K+1), LDG )
         END IF
C
         CALL DLACPY( 'All', M*K, K, TA, LDTA, R, LDR )
C
C        Apply the stored transformations on the new rows.
C
         DO 50  I = 2, N
C
C           Copy the last M-1 blocks of the positive generator together;
C           the last M blocks of the negative generator are contained
C           in TA.
C
            STARTR =   ( I - 1 )*K + 1
            STARTT = 3*( I - 2 )*K + 1
            CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR,
     $                   R(K+1,STARTR), LDR )
C
C           Apply the transformations stored in T on the generator.
C
            CALL MB02CY( 'Column', 'NoStructure', K, K, M*K, K,
     $                   R(1,STARTR), LDR, TA, LDTA, T(STARTR,1), LDT,
     $                   CS(STARTT), 3*K, DWORK, LDWORK, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
   50    CONTINUE
C
C        Now, we have "normality" and can apply further M Schur steps.
C
         DO 60  I = 1, M
C
C           Copy the first M-I+1 blocks of the positive generator
C           together; the first M-I+1 blocks of the negative generator
C           are contained in TA.
C
            STARTT = 3*( N + I - 2 )*K + 1
            STARTI = ( M - I + 1 )*K + 1
            STARTR = ( N + I - 1 )*K + 1
            IF ( I.EQ.1 ) THEN
               CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR,
     $                      R(K+1,STARTR), LDR )
            ELSE
               CALL DLACPY( 'Lower', (M-I+1)*K, K,
     $                      R((I-2)*K+1,STARTR-K), LDR,
     $                      R((I-1)*K+1,STARTR), LDR )
            END IF
C
C           Reduce the generator to proper form.
C
            CALL MB02CX( 'Column', K, K, K, R((I-1)*K+1,STARTR), LDR,
     $                   TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, DWORK,
     $                   LDWORK, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            IF ( M.GT.I ) THEN
               CALL MB02CY( 'Column', 'NoStructure', K, K, (M-I)*K, K,
     $                      R(I*K+1,STARTR), LDR, TA(I*K+1,1), LDTA,
     $                      TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K,
     $                      DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            END IF
C
            IF ( COMPG ) THEN
C
C              Transformations acting on the inverse generator:
C
               CALL MB02CY( 'Column', 'Triangular', K, K, K, K,
     $                      G(1,K+1), LDG, G(STARTR,1), LDG,
     $                      TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K,
     $                      DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               CALL MB02CY( 'Column', 'NoStructure', K, K, (N+I-1)*K, K,
     $                      G(STARTI,K+1), LDG, G, LDG, TA((I-1)*K+1,1),
     $                      LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               IF ( COMPL ) THEN
                  CALL DLACPY( 'All', (N+I-1)*K, K, G(STARTI,K+1), LDG,
     $                         L(1,(I-1)*K+1), LDL )
                  CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG,
     $                         L(STARTR,(I-1)*K+1), LDL )
               END IF
C
            END IF
   60    CONTINUE
C
      END IF
C
      DWORK(1) = MAXWRK
C
      RETURN
C
C *** Last line of MB02DD ***
      END


      DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
C**********************************************************************
C
C     ALLM97 parametrization for gamma*-p cross section
C     (for F2 see comments, code adapted from V. Shekelyan, H1)
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

C  input/output channels
      INCLUDE 'inc/poinou'

      DOUBLE PRECISION Q2 , W
      DOUBLE PRECISION m02 , m12 , lam2 , m22
      DOUBLE PRECISION s11 , s12 , s13 , a11 , a12 , a13 , b11 , b12 ,
     &                 b13
      DOUBLE PRECISION s21 , s22 , s23 , a21 , a22 , a23 , b21 , b22 ,
     &                 b23
      DOUBLE PRECISION alfa , xmp2 , w2 , q02 , s , t , t0 , z , cin ,
     &                 ap , bp , ar , br , xp , xr , sr , sp , f2p , f2r
      DATA alfa , xmp2/112.2D0 , .8802D0/

      w2 = W*W
      PHO_ALLM97 = 0.D0

C  pomeron
      s11 = 0.28067D0
      s12 = 0.22291D0
      s13 = 2.1979D0
      a11 = -0.0808D0
      a12 = -0.44812D0
      a13 = 1.1709D0
      b11 = 0.60243D0
      b12 = 1.3754D0
      b13 = 1.8439D0
      m12 = 49.457D0

C  reggeon
      s21 = 0.80107D0
      s22 = 0.97307D0
      s23 = 3.4942D0
      a21 = 0.58400D0
      a22 = 0.37888D0
      a23 = 2.6063D0
      b21 = 0.10711D0
      b22 = 1.9386D0
      b23 = 0.49338D0
      m22 = 0.15052D0
C
      m02 = 0.31985D0
      lam2 = 0.065270D0
      q02 = 0.46017D0 + lam2

C
      s = 0.
      t = LOG((Q2+q02)/lam2)
      t0 = LOG(q02/lam2)
      IF ( Q2.GT.0.D0 ) s = LOG(t/t0)
      z = 1.D0

      IF ( Q2.GT.0.D0 ) z = (w2-xmp2)/(Q2+w2-xmp2)

      IF ( s.LT.0.01D0 ) THEN

C   pomeron part

         xp = 1.D0/(1.D0+(w2-xmp2)/(Q2+m12))

         ap = a11
         bp = b11**2

         sp = s11
         f2p = sp*xp**ap*z**bp

C   reggeon part

         xr = 1.D0/(1.D0+(w2-xmp2)/(Q2+m22))

         ar = a21
         br = b21**2

         sr = s21
         f2r = sr*xr**ar*z**br

      ELSE

C   pomeron part

         xp = 1.D0/(1.D0+(w2-xmp2)/(Q2+m12))

         ap = a11 + (a11-a12)*(1.D0/(1.D0+s**a13)-1.D0)

         bp = b11**2 + b12**2*s**b13

         sp = s11 + (s11-s12)*(1.D0/(1.D0+s**s13)-1.D0)

         f2p = sp*xp**ap*z**bp

C   reggeon part

         xr = 1.D0/(1.D0+(w2-xmp2)/(Q2+m22))

         ar = a21 + a22*s**a23
         br = b21**2 + b22**2*s**b23

         sr = s21 + s22*s**s23
         f2r = sr*xr**ar*z**br

      END IF

C     F2 = (F2P+F2R)*Q2/(Q2+M02)

      cin = alfa/(Q2+m02)*(1.D0+4.D0*xmp2*Q2/(Q2+w2-xmp2)**2)/z
      PHO_ALLM97 = cin*(f2p+f2r)

      END FUNCTION


subroutine  CANRES
  use simsphere_mod
  implicit none

  real :: RCBS=0.0, CELL1=0.0, CELL2=0.0, CELL3=0.0, QSTVEG=0.0
  real :: EPOTV=0.0, EMP=0.0, RCP=0.0

!      INCLUDE 'modvars.h'

  EMBAR =  9999
  RESIST = 9999
  IF (F > 0.)  THEN

!      SUBROUTINE COMPUTES CANOPY RESISTANCE (RESIST)
!      AND MOISTURE AVAILABILITY (EMBAR)
!      FOR TOTAL VEGETATION AND BARE SOIL CANOPY
!         ***** RESISTANCES CONVERTED TO CGS (S CM-1) *****

    RCBS = (SUMW - F*SUMW)/F
!       RCBS IS CANOPY RESISTANCE FOR BARE SOIL

    IF(XLEF /= 0 .AND. CHA /= 0 .AND. OSHUM /= QD(1)) THEN

      CELL1 = (1./CHA + RZASCR)
      QSTVEG = 10**( 6.1989 - ( 2353. / OTEMP ) )
      CELL2 = (QSTVEG - QD(1))
      CELL3 = DENS*LE

!    EMP IS MOISTURE AVAILABILITY FOR VEGETATION CANOPY
!    EPOTV IS POTENTIAL EVAPORATION OVER VEGETATION
!    RCP IS THE CANOPY RESISTANCE FOR VEGETATION

      EPOTV = CELL3*CELL2/CELL1
      EMP  = XLEF/EPOTV
      RCP = (CELL1 - EMP*CELL1)/EMP

      RESIST = RCP*FRVEG   +  RCBS*(1.0 - FRVEG)

!     WEIGHT TOTAL CANOPY RESISTANCE, MAVAIL BY VEG FRACTION

      EMBAR = EMP*FRVEG + F*(1.0 - FRVEG)

    end if

  end if

  return
end


*****************************************************************************
* Auxiliary subroutine. Determines the invariant mass squared of a branching.
* The mass is supposed to resonate at three different masses rmx1, rmx2 and rmx3.
* INPUT:
*   xvar: a random number in [0,1]
*   rmx1,gamx1     : mass and width of first resonance
*   rmx2,gamx2     : mass and width of second resonance
*   rmx3,gamx3     : mass and width of third resonance
*   iregion        : index for filling the iphsp_fxn COMMON
*
*  alfa1,alfa2,alfa3,alfa4,alfa5,alfa6:
*                      separation points in [0,1] between the five regions
*                      Can also be 0 or 1. Some care necessary in this cases
*  auxalfa2,xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,xw2_min,xw2_max,
*  xf3_min,xf3_max,auxalfa3,auxalfa4,xw3_min,xw3_max,
*  xf4_min,xf4_max,auxalfa5,auxalfa6
*                    : auxiliary quantities used for generating the mass
*                      and computing the jacobian
* OUTPUT:
*   svar: the generated invariant mass squared
*   xjacvar: the jacobian
*****************************************************************************
      SUBROUTINE PHSP_7(xvar,
     &                     rmx1,gamx1,rmx2,gamx2,rmx3,gamx3,
     &                     alfa1,alfa2,auxalfa2,
     &                     alfa3,auxalfa3,alfa4,auxalfa4,
     &                     alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max,
     &                     iregion,
     &                     svar,xjacvar)

      IMPLICIT REAL*8(a-h,o-z)
c giuseppe 29/09/2007
      INTEGER maxnresonant
      PARAMETER (maxnresonant=4)
      INTEGER isresonant(maxnresonant),imapregion(maxnresonant)
      COMMON /iphsp_fxn/ isresonant,imapregion
      PARAMETER (pi=3.141592653589793238462643d0,twopi=2.d0*pi,
     &           fourpi=4.d0*pi)

* Compute the invariant mass squared and the corresponding jacobian

      xjacvar=1.d0

      IF(xvar.LE.alfa1.AND.alfa1.GT.0.d0)THEN
        vegas_x=xvar/alfa1
        evar=(xf1_max-xf1_min)*vegas_x+xf1_min
        svar=evar*evar
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(xf1_max-xf1_min)*2.d0*evar/alfa1
      ELSEIF(xvar.LE.alfa2.AND.alfa2.GT.0.d0)THEN
        vegas_x=(xvar-alfa1)/(1.d0-alfa1)/auxalfa2
        x_max=xw1_max
        x_min=xw1_min
        svar=(gamx1*rmx1*tan((x_max-x_min)*vegas_x+x_min)+rmx1**2)
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(x_max-x_min)*((svar-rmx1**2)**2+
     &      (gamx1*rmx1)**2)/(gamx1*rmx1)/(1.d0-alfa1)/auxalfa2
c giuseppe 29/09/2007
        isresonant(iregion)=1
        imapregion(iregion)=2
c end giuseppe 29/09/2007
      ELSEIF(xvar.LE.alfa3.AND.alfa3.GT.0.d0)THEN
        vegas_x=(xvar-alfa2)/(1.d0-alfa1)/(1.d0-auxalfa2)/auxalfa3
        evar=(xf2_max-xf2_min)*vegas_x+xf2_min
        svar=evar*evar
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(xf2_max-xf2_min)*2.d0*evar
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)/auxalfa3
      ELSEIF(xvar.LE.alfa4.AND.alfa4.GT.0.d0)THEN
        vegas_x=(xvar-alfa3)/(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/auxalfa4
        x_max=xw2_max
        x_min=xw2_min
        svar=(gamx2*rmx2*tan((x_max-x_min)*vegas_x+x_min)+rmx2**2)
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(x_max-x_min)*((svar-rmx2**2)**2+
     &      (gamx2*rmx2)**2)/(gamx2*rmx2)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)/auxalfa4
c giuseppe 29/09/2007
        isresonant(iregion)=1
        imapregion(iregion)=4
c end giuseppe 29/09/2007
      ELSEIF(xvar.LE.alfa5.AND.alfa5.GT.0.d0)THEN
        vegas_x=(xvar-alfa4)/(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/(1.d0-auxalfa4)/auxalfa5
        evar=(xf3_max-xf3_min)*vegas_x+xf3_min
        svar=evar*evar
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(xf3_max-xf3_min)*2.d0*evar
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/(1.d0-auxalfa4)/auxalfa5
      ELSEIF(xvar.LE.alfa6.AND.alfa6.GT.0.d0)THEN
        vegas_x=(xvar-alfa5)/(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                      /(1.d0-auxalfa5)/auxalfa6
        x_max=xw3_max
        x_min=xw3_min
        svar=(gamx3*rmx3*tan((x_max-x_min)*vegas_x+x_min)+rmx3**2)
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(x_max-x_min)*((svar-rmx3**2)**2+
     &      (gamx3*rmx3)**2)/(gamx3*rmx3)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                      /(1.d0-auxalfa5)/auxalfa6
c giuseppe 29/09/2007
        isresonant(iregion)=1
        imapregion(iregion)=6
c end giuseppe 29/09/2007
      ELSE
        vegas_x=(xvar-alfa6)/(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                      /(1.d0-auxalfa5)/(1.d0-auxalfa6)
        evar=(xf4_max-xf4_min)*vegas_x+xf4_min
        svar=evar*evar
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(xf4_max-xf4_min)*2.d0*evar
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                      /(1.d0-auxalfa5)/(1.d0-auxalfa6)
      ENDIF
      xjacvar=xjacvar/twopi

      RETURN
      END


subroutine coriolis

use vars

implicit none

real u_av, v_av, w_av
integer i,j,k,ib,ic,jb,jc,kc

if(RUN3D) then

do k=1,nzm
 kc=k+1
 do j=1,ny
  jb=j-1
  jc=j+1
  do i=1,nx
   ib=i-1
   ic=i+1
    v_av=0.25*(v(i,j,k)+v(i,jc,k)+v(ib,j,k)+v(ib,jc,k))
    w_av=0.25*(w(i,j,kc)+w(ib,j,kc)+w(i,j,k)+w(ib,j,k))
    dudt(i,j,k,na)=dudt(i,j,k,na)+fcory(j)*(v_av-vg0(k))-fcorzy(j)*w_av
    u_av=0.25*(u(i,j,k)+u(ic,j,k)+u(i,jb,k)+u(ic,jb,k))
    dvdt(i,j,k,na)=dvdt(i,j,k,na)-0.5*(fcory(j)+fcory(jb))*(u_av-ug0(k))
  end do ! i
 end do ! j
end do ! k

else

do k=1,nzm
 kc=k+1
 do j=1,ny
  do i=1,nx
   ib=i-1
   ic=i+1
   w_av=0.25*(w(i,j,kc)+w(ib,j,kc)+w(i,j,k)+w(ib,j,k))
   dudt(i,j,k,na)=dudt(i,j,k,na)+fcory(j)*(v(i,j,k)-vg0(k))-fcorzy(j)*w_av
   dvdt(i,j,k,na)=dvdt(i,j,k,na)-fcory(j)*(u(i,j,k)-ug0(k))
  end do ! i
 end do ! i
end do ! k

endif

!bloss: accumulate coriolis accelerations for statistics
if(dostatis) then

   utendcor(:) = 0.
   vtendcor(:) = 0.

   if(RUN3D) then

      do k=1,nzm
         kc=k+1
         do j=1,ny
            jb=j-1
            jc=j+1
            do i=1,nx
               ib=i-1
               ic=i+1
               v_av=0.25*(v(i,j,k)+v(i,jc,k)+v(ib,j,k)+v(ib,jc,k))
               w_av=0.25*(w(i,j,kc)+w(ib,j,kc)+w(i,j,k)+w(ib,j,k))
               utendcor(k)=utendcor(k)+fcory(j)*(v_av-vg0(k))-fcorzy(j)*w_av
               u_av=0.25*(u(i,j,k)+u(ic,j,k)+u(i,jb,k)+u(ic,jb,k))
               vtendcor(k)=vtendcor(k)-0.5*(fcory(j)+fcory(jb))*(u_av-ug0(k))
            end do ! i
         end do ! j
      end do ! k

   else

      do k=1,nzm
         kc=k+1
         do j=1,ny
            do i=1,nx
               ib=i-1
               ic=i+1
               w_av=0.25*(w(i,j,kc)+w(ib,j,kc)+w(i,j,k)+w(ib,j,k))
               utendcor(k)=utendcor(k)+fcory(j)*(v(i,j,k)-vg0(k))-fcorzy(j)*w_av
               vtendcor(k)=vtendcor(k)-fcory(j)*(u(i,j,k)-ug0(k))
            end do ! i
         end do ! i
      end do ! k

   endif !if(RUN3D)

end if !if(dostatis)

end subroutine coriolis


Module symetrically_screened_poisson_module

  Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

  Implicit None

  Public :: ssp_long_range
  Public :: ssp_sic

  Private

  Real( wp ), Parameter :: pi = 3.141592653589793238462643383279502884197_wp

Contains

  Subroutine ssp_long_range( l, q, r, alpha, FD_order, recip_E, q_grid, pot_grid, ei, f, t_grid, t_recip, error )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

    Use lattice_module         , Only : lattice
    Use charge_grid_module     , Only : charge_grid_calculate, charge_grid_find_range, charge_grid_forces
    Use minresmodule           , Only : minres
    Use FD_Laplacian_3d_module , Only : FD_Laplacian_3D
    Use halo_serial_module     , Only : halo_serial_setter, halo_serial_data
    Use halo_setter_base_module, Only : halo_setter_base_class, halo_setter_base_data_class

    Implicit None

    Real( wp ), Dimension( :, :, : ), Allocatable :: rhs

    Type( lattice )                    , Intent( In    ) :: l
    Real( wp ), Dimension( :     )     , Intent( In    ) :: q
    Real( wp ), Dimension( :, :  )     , Intent( In    ) :: r
    Real( wp )                         , Intent( In    ) :: alpha
    Integer                            , Intent( In    ) :: FD_order
    Real( wp )                         , Intent(   Out ) :: recip_E
    Real( wp ), Dimension( 0:, 0:, 0: ), Intent(   Out ) :: q_grid
    Real( wp ), Dimension( 0:, 0:, 0: ), Intent(   Out ) :: pot_grid
    Real( wp ), Dimension( 1: )        , Intent(   Out ) :: ei
    Real( wp ), Dimension( 1:, 1: )    , Intent(   Out ) :: f
    Real( wp )                         , Intent(   Out ) :: t_grid
    Real( wp )                         , Intent(   Out ) :: t_recip
    Integer                            , Intent(   Out ) :: error

    ! Standardize the potential so it sums to zero over the cell
    ! Not required, but useful for comparison of accuracy with Fourier methods.
    ! This should be set to .False. for production
    Logical, Parameter :: standardise = .True.

    Class( halo_setter_base_class      ), Allocatable :: halo_swapper
    Class( halo_setter_base_data_class ), Allocatable :: halo_data

    Type( FD_Laplacian_3d    ) :: FD

    Real( wp ), Dimension( 1:3, 1:3 ) :: dGrid_vecs

    Real( wp ), Dimension( 1:3 ) :: dG

    Integer, Dimension( 1:3 ) :: n_grid
    Integer, Dimension( 1:3 ) :: range_gauss

    Real( wp ) :: Anorm, Arnorm, Acond, rnorm, ynorm, rtol

    Integer :: istop, itn
    Integer :: i

    Integer( li ) :: start, finish, rate

    Character( Len = 132 ) :: istop_message

    error = 0

    n_grid = Ubound( q_grid ) + 1

    ! Grid the charge
    Call system_clock( start, rate )
    ! First find range of the gaussian along each of the axes of the grid
    Call charge_grid_find_range( l, alpha, n_grid, range_gauss )
    ! Now grid the charge
    Call charge_grid_calculate( l, alpha, q, r, range_gauss, q_grid, error )
    Call system_clock( finish, rate )
    t_grid = Real( finish - start, wp ) / rate

    ! Now calculate the long range potential by Finite difference

    ! Initialise the FD template
    dGrid_vecs = l%get_direct_vectors()
    Do i = 1, 3
       dGrid_vecs( :, i ) = dGrid_vecs( :, i ) / n_grid( i )
       dG( i )            = Sqrt( Dot_product( dGrid_vecs( :, i ), dGrid_vecs( :, i ) ) )
    End Do
    Call FD%init( FD_order, dGrid_vecs )

    ! Initalise the halo swapper
    Allocate( halo_serial_setter :: halo_swapper )
    Allocate(  halo_serial_data  :: halo_data    )
    Call halo_swapper%init( halo_data, error )

    ! And solve  Possion equation on the grid by FDs
    rtol = 1.0e-12_wp
    Call system_clock( start, rate )
    rhs = - 4.0_wp * pi * q_grid
    Call minres( Lbound( q_grid ), Ubound( q_grid ), FD, halo_swapper, dummy_Msolve, rhs, 0.0_wp, .True., .False., &
         pot_grid, 1000, 99, rtol,                      &
         istop, istop_message, itn, Anorm, Acond, rnorm, Arnorm, ynorm )
    If( standardise ) Then
       ! Standardise to potential averages to zero over grid
       ! In real calculation don't need to do this!
       pot_grid = pot_grid  - Sum( pot_grid ) / Size( pot_grid )
    End If
    Call system_clock( finish, rate )
    t_recip = Real( finish - start, wp ) / rate

    ! Summarise the iterative solver
    Write( *, * ) 'Iterative solver summary:'
    Write( *, * ) 'alpha                = ', alpha
    Write( *, * ) 'Grid resolution      = ', dG
    Write( *, * ) 'Grid size            = ', n_grid
    Write( *, * ) 'Order                = ', FD_order
    Write( *, * ) 'iterations           = ', itn
    Write( *, * ) 'istop                = ', istop, Trim( istop_message )
    Write( *, * ) 'norm of the residual = ', rnorm

    ! Calculate from the potential the long range energy
    ! Two minus signs as a) this is the SCREENED charge
    !                    b) I like to just add up the energies, having to subtract it is confusing
    recip_E = - 0.5_wp * Sum( - q_grid * pot_grid ) * ( l%get_volume() / Product( n_grid ) )

    ! Calculate the forces and energy per site
    Call charge_grid_forces( l, alpha, q, r, range_gauss, q_grid, pot_grid, ei, f )

  End Subroutine ssp_long_range

  Pure Function ssp_sic( q, alpha ) Result( sic )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

    Real( wp ), Dimension( : ), Intent( In    ) :: q
    Real( wp )                , Intent( In    ) :: alpha

    Real( wp ) :: sic

    sic = - alpha * Sum( q * q ) / Sqrt( 2.0_wp * pi )

  End Function ssp_sic

  Subroutine dummy_msolve(lb,ub,x,y)                   ! Solve M*y = x
    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64
    Integer,  Intent(in)    :: lb( 1:3 ), ub( 1:3 )
    Real(wp), Intent(in)    :: x( lb( 1 ):ub( 1 ), lb( 2 ):ub( 2 ), lb( 3 ):ub( 3 ) )
    Real(wp), Intent(out)   :: y( lb( 1 ):ub( 1 ), lb( 2 ):ub( 2 ), lb( 3 ):ub( 3 ) )

    ! Shut up compiler
    y = x

  End Subroutine dummy_msolve

End Module symetrically_screened_poisson_module


      subroutine velh(iseed,
     &                sample_stars_count,
     &                geometry)
C         Сalculating heliocentrical velocities.
C         Velocity dispersion is based on scale height
C           TODO: get rid of this, implement another RNG
C           iseed: random number generator parameter (dummy)
          implicit none

C         TODO: this is numberOfStars, take it up as const
          integer, parameter :: MAX_STARS_COUNT = 6000000
C         A, B: Oort constants in km/sKpc (values by Kerr and
C              Lynden-Bell 1986)
          real, parameter :: oort_const_A = 14.4,
     &                       oort_const_B = -12.8,
     &                       ro = 10.5,
     &                       l = 5.5,
     &                       sigo = 80.0,
     &                       sigm = 145.0,
     &                       pi = 4.0 * atan(1.0),
     &                       vc = 220.0,
     &                       gamma = 3.4
          double precision, parameter :: solar_galactocentric_distance
     &                                   = 8.5d0
          integer :: iseed,
     &               sample_stars_count,
     &               i,
     &               k,
     &               numberOfWDs,
     &               disk_belonging(MAX_STARS_COUNT),
     &               flagOfWD(MAX_STARS_COUNT)
          real :: peculiar_solar_velocity_u,
     &            peculiar_solar_velocity_v,
     &            peculiar_solar_velocity_w,
     &            uop,
     &            vop,
     &            gasdev,
     &            uom,
     &            vom,
C         Heliocentric velocities, B3 system
     &            uu(MAX_STARS_COUNT),
     &            vv(MAX_STARS_COUNT),
     &            ww(MAX_STARS_COUNT),
     &            velocities_dispersions(3),
     &            stellar_galactocentric_distance,
     &            xx,
     &            sigo2,
     &            sigm2,
     &            sigr2,
     &            dsigr2dr,
     &            sigt2,
     &            sigr,
     &            sigt,
     &            vr,
     &            vth,
     &            vph,
     &            delta,
     &            sindel,
     &            cosdel,
     &            vx,
     &            vy,
     &            vz,
     &            sini,
     &            cosi
          character(len = 6) :: geometry
          double precision :: coordinate_R(MAX_STARS_COUNT),
     &                        coordinate_Theta(MAX_STARS_COUNT),
     &                        coordinate_Zcylindr(MAX_STARS_COUNT),
     &                        lgac(MAX_STARS_COUNT),
     &                        bgac(MAX_STARS_COUNT)

          common /vel/ uu, vv, ww
          common /coorcil/ coordinate_R,
     &                     coordinate_Theta,
     &                     coordinate_Zcylindr
          common /index/ flagOfWD,
     &                   numberOfWDs,
     &                   disk_belonging
          common /lb/ lgac, bgac

C         Peculiar solar velocities, values from Anguiano et al. 2017
C         TODO: find out why signs are different from values in Python
          peculiar_solar_velocity_u = -11.0
          peculiar_solar_velocity_v = -12.0
          peculiar_solar_velocity_w = -7.0

C         Making the transfer of z, r, theta
          k = 0
          do i = 1, sample_stars_count
              if (flagOfWD(i) == 1) then
                  k = k + 1
                  if (geometry == 'cones') then
                      coordinate_R(k) = coordinate_R(i)
                      coordinate_Theta(k) = coordinate_Theta(i)
                  end if
              end if
          end do

          do i = 1, numberOfWDs
C             TODO: find these constants and make variables for them
              if (disk_belonging(i) == 1) then
                  velocities_dispersions(1) = 32.4
                  velocities_dispersions(2) = 23.0
                  velocities_dispersions(3) = 18.1
              else if (disk_belonging(i) == 2) then
                  velocities_dispersions(1) = 50.0
                  velocities_dispersions(2) = 56.0
                  velocities_dispersions(3) = 34.0
              else if (disk_belonging(i) /= 3) then
                  write(6, *) "Error in velh:"
                  write(6, *) "    Number of WD's =", numberOfWDs
                  write(6, *) "    index =", i
                  write(6, *) "    disk_belonging =", disk_belonging(i)
                  stop
              end if

C             TODO: find out what is going on here (see article
C             Simulating Gaia performances on white dwarfs by Torres)
              if (disk_belonging(i) == 3) then
C                 Radial and tangential dispersions
                  stellar_galactocentric_distance = real(sqrt(
     &                coordinate_R(i) ** 2
     &                + coordinate_Zcylindr(i) ** 2))
                  xx = (stellar_galactocentric_distance - ro) / l
                  sigo2 = sigo * sigo
                  sigm2 = sigm * sigm
                  sigr2 = sigo2 + sigm2 * (0.5 - (atan(xx) / pi))
                  dsigr2dr = -(1.0 / l) * sigm2 / ((1.0 + xx * xx) * pi)
                  sigt2 = 0.5 * vc * vc + (1.0 - gamma / 2.0) * sigr2
     &                    + (stellar_galactocentric_distance / 2.0)
     &                      * dsigr2dr
                  sigr = sqrt(sigr2)
                  sigt = sqrt(sigt2)
                  sigr = vc / sqrt(2.0)
                  sigt = vc / sqrt(2.0)

C                 Spherical coordinates
                  vr = sigr * gasdev(iseed)
                  vth = sigt * gasdev(iseed)
                  vph = sigt * gasdev(iseed)

C                 Cartesian coordinates
                  delta = real(pi - lgac(i) - coordinate_Theta(i))
                  sindel = sin(delta)
                  cosdel = cos(delta)
                  vx = -cosdel * vr + sindel * vph
                  vy = sindel * vr + cosdel * vph
                  vz = vth

                  sini = sin(real(lgac(i)))
                  cosi = cos(real(lgac(i)))

                  uu(i) = vz * cosi + vx * sini
                  vv(i) = -vz * sini + vx * cosi
                  ww(i) = vy

                  vv(i) = vv(i) - vc

                  uu(i) = uu(i) + peculiar_solar_velocity_u
                  vv(i) = vv(i) + peculiar_solar_velocity_v
                  ww(i) = ww(i) + peculiar_solar_velocity_w
              else
C                 Calling function of gaussian distribution
C                 TODO: find out the meaning of uop
                  uop = uom(coordinate_R(i),
     &                      coordinate_Theta(i),
     &                      oort_const_A,
     &                      oort_const_B,
     &                      solar_galactocentric_distance,
     &                      peculiar_solar_velocity_u)
                  uu(i) = velocities_dispersions(1) * gasdev(iseed) +uop
C                 TODO: find out the meaning of vop
                  vop = vom(coordinate_R(i),
     &                      coordinate_Theta(i),
     &                      oort_const_A,
     &                      oort_const_B,
     &                      solar_galactocentric_distance,
     &                      peculiar_solar_velocity_v)
C                 TODO: find out what this 120.0 is
                  vv(i) = velocities_dispersions(2) * gasdev(iseed) +vop
     &                    - velocities_dispersions(1)
     &                      * velocities_dispersions(1)
     &                      / 120.0
                  ww(i) = velocities_dispersions(3) * gasdev(iseed)
     &                    + peculiar_solar_velocity_w
              end if
          end do
      end subroutine

C     TODO: give a better name
      function uom(coordinate_R,
     &             coordinate_Theta,
     &             oort_const_A,
     &             oort_const_B,
     &             solar_galactocentric_distance,
     &             peculiar_solar_velocity_u)
C         Calculating uom taking into account the effect of gal. rotation
          implicit none

          real :: oort_const_A,
     &            oort_const_B,
     &            peculiar_solar_velocity_u,
     &            uom
          double precision :: coordinate_R,
     &                        coordinate_Theta,
     &                        solar_galactocentric_distance
C         TODO: what is going on here?
          uom = real(peculiar_solar_velocity_u
     &               + ((3.0 - (2.0 * coordinate_R)
     &                         / solar_galactocentric_distance)
     &                  * oort_const_A - oort_const_B) * coordinate_R
     &                 * sin(coordinate_Theta))
      end function

C     TODO: give a better name
      function vom(coordinate_R,
     &             coordinate_Theta,
     &             oort_const_A,
     &             oort_const_B,
     &             solar_galactocentric_distance,
     &             peculiar_solar_velocity_v)
C         Calculating vom taking into account the effect of gal. rotation
          implicit none

          real :: oort_const_A,
     &            oort_const_B,
     &            peculiar_solar_velocity_v,
     &            vom
          double precision :: coordinate_R,
     &                        coordinate_Theta,
     &                        solar_galactocentric_distance

          vom = real(peculiar_solar_velocity_v
     &               + ((3.0 - (2.0 * coordinate_R)
     &                         / solar_galactocentric_distance)
     &                  * oort_const_A - oort_const_B) * coordinate_R
     &                 * cos(coordinate_Theta)
     &               - (oort_const_A - oort_const_B)
     &                 * solar_galactocentric_distance)
      end function


Implicit none

integer :: i,j
real*8,dimension(2346) :: latitude,longitude,utem2
Integer, parameter :: npt=2346,ndeg=8,mdeg=8,rang=(2*mdeg+1)*(ndeg+1),&
			rang1=(ndeg+1)*(mdeg+1)
Integer :: nb_data,ind_data(npt),dpar11
real*8  :: latmin=40.d0,latmax=72.d0

Real*8  :: A(npt*rang),B(rang*npt)

Real*8  :: coef_r(rang),coef_i(rang)

!!!!!!! !!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!! !!!!!!
open(unit=4,file='CoefP1.lis',form='formatted',status='unknown')
do i=1,2346
	read(4,*) longitude(i),latitude(i),utem2(i)
	read(4,*)
end do
close(4)
dpar11=2346
print* , dpar11
!!!!!!! !!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!! !!!!!!

!! CALCUL LES COEFFICIENTS

call geometrie(dpar11,nb_data,ind_data,longitude,latitude,latmin,&
		latmax,ndeg,mdeg,rang,A,B)

!!!!!!!!!!!!!!!!!!!!!! POTENTIEL

open(20,file='CoefRePot1.lis',form='formatted',status='unknown')

call coefficient(ndeg,mdeg,rang,dpar11,nb_data,ind_data,B,utem2,coef_r,coef_i)

do i=1,rang1
	write(20,*) coef_r(i),coef_i(i)
end do

close(20)

END


module mod_spalart_allmaras
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: ONE, TWO, THREE
    implicit none

    real(rk), parameter :: SA_c_b1 = 0.1355_rk
    real(rk), parameter :: SA_c_b2 = 0.622_rk
    real(rk), parameter :: SA_kappa = 0.41_rk
    real(rk), parameter :: SA_sigma = TWO/THREE
    real(rk), parameter :: SA_c_w1  = SA_c_b1/(SA_kappa*SA_kappa)  + (ONE + SA_c_b2)/SA_sigma
    real(rk), parameter :: SA_c_w2  = 0.3_rk
    real(rk), parameter :: SA_c_w3  = TWO
    real(rk), parameter :: SA_c_v1  = 7.1_rk
    real(rk), parameter :: SA_c_v2  = 0.7_rk
    real(rk), parameter :: SA_c_v3  = 0.9_rk
    real(rk), parameter :: SA_c_t3  = 1.2_rk
    real(rk), parameter :: SA_c_t4  = 0.5_rk
    real(rk), parameter :: SA_c_n1  = 16._rk
    real(rk), parameter :: SA_Pr_t  = 0.9_rk
    real(rk), parameter :: SA_rlim  = 5._rk
    real(rk), parameter :: SA_b     = 100._rk

end module mod_spalart_allmaras