    Program dgeevx_example

!     DGEEVX Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dgeevx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: eig
      Real (Kind=dp) :: abnrm, eps, tol
      Integer :: i, ihi, ilo, info, j, k, lda, ldvl, ldvr, lwork, n
      Logical :: pair
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), rconde(:), rcondv(:), scale(:), &
        vl(:, :), vr(:, :), wi(:), work(:), wr(:)
      Real (Kind=dp) :: dummy(1)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: cmplx, epsilon, max, maxloc, nint
!     .. Executable Statements ..
      Write (nout, *) 'DGEEVX Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldvl = n
      ldvr = n
      lwork = (2+nb)*n
      Allocate (a(lda,n), rconde(n), rcondv(n), scale(n), vl(ldvl,n), &
        vr(ldvr,n), wi(n), wr(n), iwork(2*n-2))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dgeevx('Balance', 'Vectors (left)', 'Vectors (right)', &
        'Both reciprocal condition numbers', n, a, lda, wr, wi, vl, ldvl, vr, &
        ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, dummy, lwork, iwork, &
        info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+2)*n, nint(dummy(1)))
      Allocate (work(lwork))

!     Read the matrix A from data file

      Read (nin, *)(a(i,1:n), i=1, n)

!     Solve the eigenvalue problem
      Call dgeevx('Balance', 'Vectors (left)', 'Vectors (right)', &
        'Both reciprocal condition numbers', n, a, lda, wr, wi, vl, ldvl, vr, &
        ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work, lwork, iwork, &
        info)

      If (info==0) Then

!       Compute the machine precision
        eps = epsilon(1.0E0_dp)
        tol = eps*abnrm
        pair = .False.

!       Print the eigenvalues and vectors, and associated condition
!       number and bounds

        Write (nout, *)
        Write (nout, *) 'Eigenvalues'
        Write (nout, *)
        Write (nout, *) '         Eigenvalue           rcond    error'

        Do j = 1, n

!         Print information on j-th eigenvalue

          If (wi(j)==0.0_dp) Then
            If (rconde(j)>0.0_dp) Then
              If (tol/rconde(j)<10.0_dp*eps) Then
                Write (nout, 100) j, wr(j), rconde(j), '-'
              Else
                Write (nout, 110) j, wr(j), rconde(j), tol/rconde(j)
              End If
            Else
              Write (nout, 110) j, wr(j), rconde(j), 'Inf'
            End If
          Else
            If (rconde(j)>0.0_dp) Then
              If (tol/rconde(j)<10.0_dp*eps) Then
                Write (nout, 120) j, wr(j), wi(j), rconde(j), '-'
              Else
                Write (nout, 130) j, wr(j), wi(j), rconde(j), tol/rconde(j)
              End If
            Else
              Write (nout, 120) j, wr(j), wi(j), rconde(j), 'Inf'
            End If
          End If
        End Do

        Write (nout, *)
        Write (nout, *) 'Eigenvectors'
        Write (nout, *)
        Write (nout, *) '         Eigenvector          rcond    error'

        Do j = 1, n

!         Print information on j-th eigenvector
          Write (nout, *)

          If (wi(j)==0.0E0_dp) Then
!           Make real eigenvectors have positive first entry
            If (vr(1,j)<0.0_dp) Then
              vr(1:n, j) = -vr(1:n, j)
            End If
            If (rcondv(j)>0.0_dp) Then
              If (tol/rcondv(j)<10.0_dp*eps) Then
                Write (nout, 100) j, vr(1, j), rcondv(j), '-'
              Else
                Write (nout, 110) j, vr(1, j), rcondv(j), tol/rcondv(j)
              End If
            Else
              Write (nout, 110) j, vr(1, j), rcondv(j), 'Inf'
            End If
            Write (nout, 140) vr(2:n, j)
          Else
            If (pair) Then
              eig = cmplx(vr(1,j-1), -vr(1,j), kind=dp)
            Else
!             Make largest eigenvector element have positive first entry
              work(1:n) = vr(1:n, j)**2 + vr(1:n, j+1)**2
              k = maxloc(work(1:n), 1)
              If (vr(k,j)<0.0_dp) Then
                vr(1:n, j) = -vr(1:n, j)
              End If
              eig = cmplx(vr(1,j), vr(1,j+1), kind=dp)
            End If
            If (rcondv(j)>0.0_dp) Then
              If (tol/rcondv(j)<10.0_dp*eps) Then
                Write (nout, 120) j, eig, rcondv(j), '-'
              Else
                Write (nout, 130) j, eig, rcondv(j), tol/rcondv(j)
              End If
            Else
              Write (nout, 120) j, eig, rcondv(j), 'Inf'
            End If
            If (pair) Then
              Write (nout, 150)(vr(i,j-1), -vr(i,j), i=2, n)
            Else
              Write (nout, 150)(vr(i,j), vr(i,j+1), i=2, n)
            End If
            pair = .Not. pair
          End If
        End Do
        Write (nout, *)
        Write (nout, *) 'Errors below 10*machine precision are not displayed'
      Else
        Write (nout, *)
        Write (nout, 160) 'Failure in DGEEVX.  INFO = ', info
      End If

100   Format (1X, I2, 2X, 1P, E11.4, 14X, 0P, F7.4, 4X, A)
110   Format (1X, I2, 2X, 1P, E11.4, 11X, 0P, F7.4, 1X, 1P, E8.1)
120   Format (1X, I2, 1X, '(', 1P, E11.4, ',', E11.4, ')', 1X, 0P, F7.4, 4X, &
        A)
130   Format (1X, I2, 1X, '(', 1P, E11.4, ',', E11.4, ')', 1X, 0P, F7.4, 1X, &
        1P, E8.1)
140   Format (1X, 4X, 1P, E11.4)
150   Format (1X, 3X, '(', 1P, E11.4, ',', E11.4, ')')
160   Format (1X, A, I4)
    End Program


program ch0402
    ! Simple Numeric I/O and Arithmetic
    implicit none

    real :: n1, n2, n3, average = 0., total = 0.
    integer :: n = 3

    print *, ' type in three numbers.'
    print *, ' Separated by spaces or commas'
    read *, n1, n2, n3
    total = n1+n2+n3
    average = total/n
    print *, ' Total of numbers is ', total
    print *, ' Average of the numbers is ', average
end program


module diag_dom_utility
contains
    subroutine to_diag_dom(n,m,A,out_status)
    !This routime checks if a given matriz A can be converted to diagonally
    !dominant form, and in case that is true, it makes the conversion and returns
    !the diagonally dominant matrix.
    !
    !For the matrix to be convertible, two conditions must be satisfied:
    ! #1 The largest elements (in abs value) of each row must all belong to
    !    different columns, so the can be placed at the main diagonal by
    !    changing rows or columns.
    ! #2 The largest element of each row must be 'dominant', that is, must be
    !    grater than the sum of the abs value of all other elements in the
    !    same row.
    !
    !If both conditions are met the routine returns out_status=.TRUE. and the
    !modified matrix in array A.
    !If any of the conditions is not met, the routine returns out_status=.FALSE.
    !and the original matriz in array A.
        implicit none
        !Declaration of arguments
        integer(2), intent(in) :: n,m
        integer(2), intent(inout) :: A(n,m)
        logical, intent(out) :: out_status

        !Declaration of internal variables
        integer(2) :: i
        integer(2) :: m_index(n), sum_row(n)
        logical :: max_are_dominant, max_in_dif_col

        !Find the position of the largest element (in abs value)
        !for each row.
        !Read about MAXLOC function at: https://gcc.gnu.org/onlinedocs/gcc-4.4.3/gfortran/MAXLOC.html
        m_index=maxloc(abs(A),dim=2)

        !Check if the largest element of each row is in a different column
        !then, after rearranging rows it will be possible to place the those
        !elements in the main diagonal of the matrix.
        max_in_dif_col=all_different(m_index)

        !Compute the summation of all elements in each row.
        !Substracting the value of the row's maximum we get the sum of all other elements
        !Substracting the value of the row's maximum again, if the maximums are dominant
        !we get an array with all negative values.
        sum_row=0
        do i=1,n
            sum_row(i)=sum(abs(A(i,:)))-2*abs(A(i,m_index(i)))
        enddo

        !Check if all values are negative. If that is the case we set
        !max_are_dominant to true because the matriz mets the first conditions
        !to be convertible to diagonally dominant form
        if (all(sum_row<0)) max_are_dominant=.true.

        if ((max_are_dominant).and.(max_in_dif_col)) then
            call convert_to_diag_dom(A, m_index)
            out_status=.true.
        else
            out_status=.false.
        endif
    end subroutine

    logical function all_different(arr)
        !This function returns TRUE if all elements of array 'arr'
        !are different to each other. If not, it returns FALSE.
        implicit none
        !Declaration of arguments
        integer(2), intent(in) :: arr(:)  !<----This is an automatic array not
                                          !a dynamic array (allocatable)
                                          !Ask Google about it or go to consulta

        !Declaration of internal variables
        integer(2) :: i

        all_different=.true.

        !Read about intrisinc function SIZE at:
        !https://gcc.gnu.org/onlinedocs/gcc-4.4.3/gfortran/SIZE.html#SIZE
        do i=1,size(arr)-1
          !Read about intrisinc function ANY at:
          !https://gcc.gnu.org/onlinedocs/gcc-4.4.3/gfortran/ANY.html#ANY
          if (any(arr(i)==arr(i+1:size(arr)))) then
            all_different=.false.
            exit
          endif
        enddo

    end function

    subroutine convert_to_diag_dom(M,m_index)
      !This routine places each row in the correspondig place.
        implicit none
        integer(2), intent(in) :: m_index(:)
        integer(2), intent(inout) :: M(:,:)

        integer(2) :: i
        integer(2) :: aux(size(M,1),size(M,2))

        do i=1,size(M,1)
            aux(m_index(i),:)=M(i,:)
        enddo

        M=aux

    end subroutine convert_to_diag_dom
end module diag_dom_utility

program test_ddomin
      use diag_dom_utility
      implicit none
      integer(2) :: i,n,m
      integer(2), allocatable :: A(:,:)   !This is a dynamic array (allocatable)
      logical :: ddiag_status

      open(unit=10,file='datos.in',status='old')

      read(10,*) n,m
      allocate(A(n,m))

      do i=1,n
        read(10,*) A(i,:)
        write(*,*) A(i,:)
      enddo
      close(10)

      call to_diag_dom(n,m,A,ddiag_status)
      print *, "---------------------------------"

      if (ddiag_status) then
        do i=1,size(A,1)
          print *, A(i,:)
        enddo
      else
        print *, " "
        print *, "The matrix cannot be converted to diagonally dominant form"
      endif

end program


      implicit real*8(a-h,o-z)
      external f1
      write(*,*) "enter the intial guess and step value"
      read (*,*) x0,xinc
      call bracket(f1,x0,xinc,a,b)
      write(*,*)"The brackets are ",a,b
      x=bisec(f1,a,b)
      write(*,*)"The solution is ",x,a,b
      end

      real*8 function f1(x)
      implicit real*8(a-h,o-z)
      f1=sin(x)
      end

      subroutine bracket(f,x0,xinc,xpos,xneg)
* sign of xinc should be +/- for increasing/decreasing function
      implicit real*8(a-h,o-z)
      logical flag
      flag=.true.
      x=x0
      if(f(x).gt.0.0)then
        xpos=x
        ival=1
        x=x-xinc
      else
        xneg=x
        ival=-1
        x=x+xinc
      end if
      do iterate=1,50
        if(f(x).gt.0.0)then
          xpos=x
          if(ival.eq.-1)then
            flag=.false.
            exit
          end if
          x=x-xinc
        else
          xneg=x
          if(ival.eq.1)then
            flag=.false.
            exit
          end if
          x=x+xinc
        end if
      end do
      if(flag)then
        write(*,*)'Havent got change in sign for bracketing'
        stop
      end if
      end

      real*8 function bisec(f,xpos,xneg)
      implicit real*8(a-h,o-z)
      logical flag
      flag=.true.
      if(f(xpos).lt.0)then
        t=xpos
        xpos=xneg
        xneg=t
      endif
      x0=(xpos+xneg)/2.0d0
      do iterate=1,300
        x=x0
        fx=f(x)
        if(fx.gt.0.0)then
          xpos=x
        else
          xneg=x
        end if
        x0=(xpos+xneg)/2.0d0
c        print *,iterate,x,fx
        if((dabs(x0-x).lt.1.0e-8).and.(dabs(fx).lt.1e-3))then
          flag=.false.
          bisec=x0
          exit
        end if
      end do
      if(flag)then
        write(*,*)'Bisection method did not converge'
        stop
      end if
      end


module timestep_module

  use datatypes_module

  implicit none

contains

  subroutine compute_dt(U, dt)

    use grid_module
    use runtime_params_module, only : gamma, cfl

    implicit none

    real(dp_t), intent(in) :: U(a_lo:a_hi, NVAR)
    real(dp_t), intent(out) :: dt

    real(dp_t) :: vel, p, cs
    integer :: i

    dt = 1.e33_dp_t

    do i = ilo, ihi
       vel = U(i, UMX)/U(i, URHO)
       p = (U(i, UENER) - 0.5_dp_t * U(i, URHO) * vel**2)*(gamma - 1.0_dp_t)

       cs = sqrt(gamma * p / U(i, URHO))
       dt = min(dt, cfl*dx/(abs(vel) + cs))
    enddo

  end subroutine compute_dt

end module timestep_module


      subroutine evol_alphadyopl(n_K,n_alpha,np1_K,np1_alpha,x,Nx,ht,myz
     &ero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 myzero
      real*8 n_K(Nx)
      real*8 n_alpha(Nx)
      real*8 np1_K(Nx)
      real*8 np1_alpha(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_alpha(i) - 0.1D1 / (np1_K(i) * ht + 0.1D1) * ht * ((-0.1D
     #1 * n_alpha(i) + np1_alpha(i)) / ht + np1_alpha(i) * np1_K(i) + n_
     #alpha(i) * n_K(i))
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = np1_alpha(i) - 0.1D1 / (np1_K(i) * ht + 0.1D1) * ht * ((-0.1D
     #1 * n_alpha(i) + np1_alpha(i)) / ht + np1_alpha(i) * np1_K(i) + n_
     #alpha(i) * n_K(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = -0.1D1 * myzero * x(i) + 0.1D1
      res(i)=qb
      end do
      endif
      END


PROGRAM main

    IMPLICIT NONE
    REAL(8), DIMENSION(10) :: A

    A = (/ 1d0, 3d0, 2d0, 4d0, 5d0, 10d0, 50d0, 7d0, 1.5d0, 0.3d0 /)

    WRITE(*,*) 'Input vector'
    WRITE(*,'( F6.2 )') A
    WRITE(*,*) ' '

    CALL bubblesort(A)

    WRITE(*,*) 'Output vector'
    WRITE(*,'(F6.2)') A

CONTAINS

SUBROUTINE bubblesort(array)

    IMPLICIT NONE
    INTEGER                              :: array_length, i, j, n
    REAL(8)                              :: tmp
    REAL(8), DIMENSION(:), INTENT(INOUT) :: array

    array_length = size(array)
    n = array_length

    DO i=1, n
        DO j=1, n-1
            IF ( array(j) > array(j+1) ) THEN

                tmp        = array(j+1)
                array(j+1) = array(j)
                array(j)   = tmp

            END IF
        END DO
    END DO
END SUBROUTINE bubblesort

END PROGRAM main


program Approximate_pi
implicit none
    real :: a , b = 0 , delta , pi
    integer:: n , i
    read* , n

    do i = 1 , n
        delta = 1. / i**2
        a = b + delta
        b = a
    end do
    pi = sqrt(6*b)
    write(*,"(a,f5.2)") 'pi=',pi

end


program test_poisson_3d

use mesh_fields_m
use poisson_3d_m
use output_m

implicit none

type(mesh_t)       :: mesh
type(fields_3d_t)  :: fields
type(poisson_3d_t) :: poisson

integer, parameter :: nx = 32, ny = 64, nz = 128
real(8)            :: xmin, xmax, ymin, ymax, zmin, zmax
real(8)            :: pi
integer            :: i, j, k
real(8)            :: x, y, z
real(8)            :: err_x, err_y, err_z

pi = 4d0 * atan(1d0)

xmin = 0d0
xmax = 2d0 * pi
ymin = 0d0
ymax = 4d0 * pi
zmin = 0d0
zmax = 6d0 * pi

call init_mesh( mesh, xmin, xmax, nx, ymin, ymax, ny, zmin, zmax, nz )

call init_fields( fields, mesh )

call init_poisson( poisson, mesh)

do k = 1, nz
    z = (k-1) * mesh%dz
    do j = 1, ny
        y = (j-1) * mesh%dy
        do i = 1, nx
            x = (i-1) * mesh%dx
            fields%rho(i,j,k) = - 3d0 * sin(x) * sin(y) * sin(z)
        end do
    end do
end do

call solve_poisson( poisson, fields)

call write_data( 1, fields)

err_x = 0d0
err_y = 0d0
err_z = 0d0
do k = 1, nz+1
    z = (k-1) * mesh%dz
    do j = 1, ny+1
        y = (j-1) * mesh%dy
        do i = 1, nx+1
            x = (i-1) * mesh%dx
            err_x = err_x + abs( fields%e(1,i,j,k) - cos(x)*sin(y)*sin(z))
            err_y = err_y + abs( fields%e(2,i,j,k) - cos(y)*sin(x)*sin(z))
            err_z = err_z + abs( fields%e(3,i,j,k) - cos(z)*sin(x)*sin(y))
        end do
    end do
end do

print*, err_x, err_y, err_z

end


subroutine frivel(delta,tveno,vikin,velfr)
!------------------------------------------------------------------------
!****f* Mathru/frivel
! NAME
!    frivel
! DESCRIPTION
!    Computes the friction velocity by the Newton-Raphson method. This
!    friction velocity is computed from U_p/U_*=(1/X)log(U_* D/nu)+C,
!    where X=0.41 (VONKA) is the von Karman constant, U_p is the tangent
!    wall velocity at the current integration point, C is a constant
!    which value is 5.5 and D = DELTA is a user defined parameter
!    (DELTA, its physical meaning being the boundary layer width.
!    The result is VELFR.
! USES
! USED BY
!    nsm_bouwal
!    tur_updnbc
!***
!------------------------------------------------------------------------
  use      typre
  implicit none
  real(rp), intent(in)  :: delta,tveno,vikin
  real(rp), intent(out) :: velfr
  integer(ip)           :: itera,ndelt,j
  real(rp)              :: xmuit,fdvfr,devfr
  real(rp)              :: vkinv,diffd,parco,dplus
  real(rp)              :: ypele,expye,expyt,oneoe,firsl
!
! Wall law taking into account the buffer zone and log layer:
! u+ =1/k*ln(1+0.4*y+)+7.8*[1-exp(-y+/11-y+/11*exp(-0.33*y+)]
!
  if (delta>0.0_rp) then
     velfr=sqrt(tveno*vikin/delta)
     if(velfr*delta/vikin>5.0_rp) then
        vkinv=1.0_rp/0.41_rp
        xmuit=delta/vikin                                               ! D/nu
        itera=0                                                         ! i=0
        velfr=tveno                                                     ! U_*^0
        parco=1.0_rp
        oneoe=1.0_rp/11.0_rp
        do while((parco>=1.0e-6).and.itera<100)
           itera=itera+1                                                ! i=i+1
           if(velfr<0.0_rp) velfr=0.0_rp
           dplus=velfr*xmuit
           ypele=dplus*oneoe
           expye=exp(-ypele)
           expyt=exp(-dplus*0.33_rp)
           firsl=vkinv*log(1.0_rp+0.4_rp*dplus)
           fdvfr=velfr*(firsl+7.8_rp*(1.0_rp-expye-ypele*expyt))-tveno  ! F(U_*^i)
           diffd=firsl+vkinv*0.4_rp*dplus/(1.0_rp+0.4_rp*dplus)&        ! DF(U_*^i)
                +7.8_rp*(1.0_rp-expye*(1.0_rp+ypele)&
                -ypele*expyt*(2.0_rp-dplus*0.33_rp))
           devfr=-fdvfr/diffd                                           ! delta(U_*^0)
           parco=abs(devfr/tveno)                                       ! U_*^i=U_*^i-1
           velfr=velfr+devfr                                            ! +delta(U_*)
        end do
     end if
!
! If DELTA = 0, the friction velocity is set to zero.
!
  else
     velfr=0.0_rp
  end if

end subroutine frivel


c     program DRSEVUN
c>> 1994-10-19 DRSEVUN  Krogh  Changes to use M77CON
c>> 1992-04-23 DRSEVUN  CLL   Declaring all variables.
c>> 1992-03-04 DRSEVUN  Krogh Initial version.
c     Demonstrate unsymmetric eigenvalue subroutine SEVUN.
c     ------------------------------------------------------------------
c--S replaces "?": DR?EVUN, ?EVUN, ?VECP
c     ------------------------------------------------------------------
      integer I, KASE, LDA, N
      parameter (LDA = 3)
      integer IFLAG(LDA)
      real             A(LDA,LDA,3), VR(LDA), VI(LDA)
c
      data (A(1,I,1), I=1,3) / -954.0e0, -464.0e0, -2088.0e0 /
      data (A(2,I,1), I=1,3) /  792.0e0,  387.0e0,  1728.0e0 /
      data (A(3,I,1), I=1,3) /  264.0e0,  128.0e0,   579.0e0 /
c
      data (A(1,I,2), I=1,3) / 4.0e0, 1.0e0, 1.0e0 /
      data (A(2,I,2), I=1,3) / 2.0e0, 4.0e0, 1.0e0 /
      data (A(3,I,2), I=1,3) / 0.0e0, 1.0e0, 4.0e0 /
c
      data (A(1,I,3), I=1,3) /  8.0e0, -1.0e0, -5.0e0 /
      data (A(2,I,3), I=1,3) / -4.0e0,  4.0e0, -2.0e0 /
      data (A(3,I,3), I=1,3) / 18.0e0, -5.0e0, -7.0e0 /
      data N / LDA /
c     ------------------------------------------------------------------
      print*,'DRSEVUN..  Demo driver for SEVUN.'
      do 10 KASE = 1, 3
         print '(/a,i2)',' Beginning Case =', KASE
         call SEVUN(A(1, 1, KASE), LDA, N, VR, VI, IFLAG)
         print '(a,i2)',' IFLAG(1) =', IFLAG(1)
         if (IFLAG(1) .le. 2) then
            call SVECP(VR, N, ' Real part of the eigenvalues')
            call SVECP(VI, N, ' Imaginary part of the eigenvalues')
         else
            print '(/a)',' Failure in SEVUN.'
         end if
   10 continue
      stop
      end


!**********************************************************************
!     matmult.f90 - simple matrix multiply implementation
!************************************************************************
      subroutine initialize(a, b, n)
        double precision a(n,n)
        double precision b(n,n)
        integer n

! first initialize the A matrix
        do i = 1,n
          do j = 1,n
            a(j,i) = i
          end do
        end do

! then initialize the B matrix
        do i = 1,n
          do j = 1,n
            b(j,i) = i
          end do
        end do

      end subroutine initialize

      subroutine multiply_matrices(answer, buffer, b, matsize)
        double precision buffer(matsize), answer(matsize)
        double precision b(matsize, matsize)
        integer i, j
! multiply the row with the column

        do i = 1,matsize
          answer(i) = 0.0
          do j = 1,matsize
            answer(i) = answer(i) + buffer(j)*b(j,i)
          end do
        end do
      end subroutine multiply_matrices

      program main
      include "mpif.h"

      integer SIZE_OF_MATRIX
      parameter (SIZE_OF_MATRIX = 1000)
! try changing this value to 2000 to get rid of transient effects
! at startup
      double precision a(SIZE_OF_MATRIX,SIZE_OF_MATRIX)
      double precision b(SIZE_OF_MATRIX,SIZE_OF_MATRIX)
      double precision c(SIZE_OF_MATRIX,SIZE_OF_MATRIX)
      double precision buffer(SIZE_OF_MATRIX), answer(SIZE_OF_MATRIX)

      integer myid, master, maxpe, ierr, status(MPI_STATUS_SIZE)
      integer i, j, numsent, sender
      integer answertype, row, flag
      integer matsize

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, maxpe, ierr )
      print *, "Process ", myid, " of ", maxpe, " is active"

      master = 0
      matsize = SIZE_OF_MATRIX

      if ( myid .eq. master ) then
! master initializes and then dispatches
! initialize a and b
        call initialize(a, b, matsize)
        numsent = 0

! send b to each other process
        do i = 1,matsize
          call MPI_BCAST(b(1,i), matsize, MPI_DOUBLE_PRECISION, master, &
             MPI_COMM_WORLD, ierr)
        end do

! send a row of a to each other process; tag with row number
        do i = 1,maxpe-1
          do j = 1,matsize
            buffer(j) = a(i,j)
          end do
          call MPI_SEND(buffer, matsize, MPI_DOUBLE_PRECISION, i,       &
             i, MPI_COMM_WORLD, ierr)
          numsent = numsent+1
        end do

        do i = 1,matsize
          call MPI_RECV(answer, matsize, MPI_DOUBLE_PRECISION,          &
           MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
          sender = status(MPI_SOURCE)
          answertype = status(MPI_TAG)
          do j = 1,matsize
            c(answertype,j) = answer(j)
          end do

          if (numsent .lt. matsize) then
            do j = 1,matsize
              buffer(j) = a(numsent+1,j)
            end do
            call MPI_SEND(buffer, matsize, MPI_DOUBLE_PRECISION, sender,&
              numsent+1, MPI_COMM_WORLD, ierr)
            numsent = numsent+1
          else
            call MPI_SEND(1.0, 1, MPI_DOUBLE_PRECISION, sender, 0,      &
                 MPI_COMM_WORLD, ierr)
          endif
        end do

! print out one element of the answer
        print *, "c(", matsize, ",", matsize, ") = ", c(matsize,matsize)
      else
! workers receive B, then compute rows of C until done message
        do i = 1,matsize
          call MPI_BCAST(b(1,i), matsize, MPI_DOUBLE_PRECISION, master, &
                 MPI_COMM_WORLD, ierr)
        end do
        flag = 1
        do while (flag .ne. 0)
          call MPI_RECV(buffer, matsize, MPI_DOUBLE_PRECISION, master,  &
            MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
          row = status(MPI_TAG)
          flag = row
          if (flag .ne. 0) then
! multiply the matrices here using C(i,j) += sum (A(i,k)* B(k,j))
            call multiply_matrices(answer, buffer, b, matsize)
            call MPI_SEND(answer, matsize, MPI_DOUBLE_PRECISION, master,&
               row, MPI_COMM_WORLD, ierr)
          endif
        end do
      endif

      call MPI_FINALIZE(ierr)
      end program main


program test_bessel
use types, only: dp
use constants, only: pi
use special_functions, only: Fm, Inu_formula2
use utils, only: assert, init_random
implicit none
integer :: i, n, k
real(dp) :: r
real(dp), allocatable :: yf(:), yr(:), x(:)
real(dp) :: t1, t2, t3

call init_random()

n = 100000
allocate(x(n), yf(n), yr(n))
do k = 0, 4
    print *, "Testing k =", k
    do i = 1, n
        call random_number(r)
        x(i) = r*40
    end do
    call cpu_time(t1)
    do i = 1, n
        yf(i) = f(k, x(i))
    end do
    call cpu_time(t2)
    do i = 1, n
        yr(i) = Inu_formula2(k, x(i))
    end do
    call cpu_time(t3)
    print *, "abs:", maxval(abs(yf-yr))
    print *, "rel:", maxval(abs(yf-yr) / max(abs(yf), abs(yr)))
    print *, "time f(r):", t2-t1
    print *, "time r(r):", t3-t2
    !print *, "speedup:", (t2-t1) / (t3-t2)
    print *
end do

contains

real(dp) pure function f(k, x) result(r)
integer, intent(in) :: k
real(dp), intent(in) :: x
select case (k)
    case (0)
        r = sinh(x)
    case (1)
        r = -sinh(x)/x + cosh(x)
    case (2)
        r = (3/x**2 + 1)*sinh(x) - 3/x*cosh(x)
    case (3)
        r = -(15/x**3 + 6/x)*sinh(x) + (15/x**2 + 1)*cosh(x)
    case (4)
        r = (105/x**4 + 45/x**2 + 1)*sinh(x) - (105/x**3 + 10/x)*cosh(x)
end select
r = r * sqrt(2/(pi*x)) / exp(x)
end function

end program


SUBROUTINE DSPSVX_F95(A, B, X, UPLO, AFP, IPIV, FACT, &
                      FERR, BERR, RCOND, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: LSAME, ERINFO
   USE F77_LAPACK, ONLY: SPSVX_F77 => LA_SPSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO, FACT
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(IN) :: A(:), B(:,:)
   REAL(WP), INTENT(OUT) :: X(:,:)
   INTEGER, INTENT(INOUT), OPTIONAL, TARGET :: IPIV(:)
   REAL(WP), INTENT(INOUT), OPTIONAL, TARGET :: AFP(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_SPSVX computes the solution to a linear system of equations
! A*X = B, where A is a real or complex symmetric matrix stored in packed
! format and X and B are rectangular matrices or vectors.
!    LA_HPSVX computes the solution to a linear system of equations
! A*X = B, where A is a complex Hermitian matrix stored in packed format
! and X and B are rectangular matrices or vectors.
!    LA_SPSVX and LA_HPSVX can also optionally estimate the condition
! number of A and compute error bounds.
!
! =========
!
!       SUBROUTINE LA_SPSVX / LA_HPSVX( AP, B, X, UPLO=uplo, AFP=afp, &
!                         IPIV=ipiv, FACT=fact, FERR=ferr, BERR=berr, &
!                         RCOND=rcond, INFO=info )
!            <type>(<wp>), INTENT(IN) :: AP(:), <rhs>
!            <type>(<wp>), INTENT(OUT) :: <sol>
!            CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!            <type>(<wp>), INTENT(INOUT), OPTIONAL :: AFP(:)
!            INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:)
!            CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT
!            REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>, RCOND
!            INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!            <type> ::= REAL | COMPLEX
!            <wp>   ::= KIND(1.0) | KIND(1.0D0)
!            <rhs>  ::= B(:,:) | B(:)
!            <sol>  ::= X(:,:) | X(:)
!            <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! Arguments
! =========
!
! AP       (input) REAL or COMPLEX array, shape (:) with size(AP ) =
!          n*(n + 1)/2, where n is the order of A.
!          On entry, the upper or lower triangle of matrix A in packed
! 	   storage. The elements are stored columnwise as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j<=n;
! 	   if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for 1<=j<=i<=n.
! B        (input) REAL or COMPLEX array, shape (:,:) with
!          size(B,1) = n or shape (:) with size(B) = n.
!          The matrix B.
! X        (output) REAL or COMPLEX array, shape (:,:) with
!          size(X,1) = n and size(X,2) = size(B,2), or shape (:) with
! 	   size(X) = n.
!          The solution matrix X .
! UPLO     Optional (input) CHARACTER(LEN=1).
!            = 'U': Upper triangle of A is stored;
!            = 'L': Lower triangle of A is stored.
!          Default value: 'U'.
! AFP      Optional (input or output) REAL or COMPLEX array, shape (:,:)
!          with the same size as AP.
!          If FACT = 'F', then AFP is an input argument that contains
! 	   the block diagonal matrix D and the multipliers used to
! 	   obtain the factor L or U from the factorization of A, returned
! 	   by a previous call to LA_SPSVX or LA_HPSVX and stored as a
! 	   packed triangular matrix in the same storage format as A.
!          If FACT = 'N', then AFP is an output argument that contains
! 	   the block diagonal matrix D and the multipliers used to obtain
! 	   the factor L or U from the factorization of A, stored as a
!          packed triangular matrix in the same storage format as A.
! IPIV     Optional (input or output) INTEGER array, shape (:) with
!          size(IPIV) = size(A,1).
!          If FACT = 'F', then IPIV is an input argument that contains
! 	   details of the row and column interchanges and the block
! 	   structure of D.
!          If IPIV(k) > 0 , then rows and columns k and IPIV(k) were
! 	   interchanged and D(k,k) is a 1 by 1 diagonal block.
!          If IPIV(k) < 0 , then there are two cases:
!           1. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
! 	     columns (k-1) and -IPIV(k) were interchanged and
! 	     D(k-1:k,k-1:k) is a 2 by 2 diagonal block.
!           2. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, then rows and
! 	     columns (k+1) and -IPIV(k) were interchanged and
! 	     D(k:k+1,k:k+1) is a 2 by 2 diagonal block.
!          If FACT = 'N', then IPIV is an output argument and on exit
! 	   contains details of the interchanges and the block structure
! 	   of D (as described above).
! FACT     Optional (input) CHARACTER(LEN=1).
!          Specifies whether the factored form of A has been supplied
! 	   on entry.
!            = 'N': The matrix A will be copied to AFP and factored.
!            = 'F': AFP and IPIV contain the factored form of A.
!          Default value: 'N'.
! FERR     Optional (output) REAL array of shape (:), with size(FERR)=
!          size(X,2), or REAL scalar.
!          The estimated forward error bound for each solution vector
! 	   X(j) (the j-th column of the solution matrix X). If XTRUE is
! 	   the true solution corresponding to X(j) , FERR(j) is an
!          estimated upper bound for the magnitude of the largest element
! 	   in (X(j)-XTRUE) divided by the magnitude of the largest
! 	   element in X(j). The estimate is as reliable as the estimate
!          for RCOND, and is almost always a slight overestimate of the
! 	   true error.
! BERR     Optional (output) REAL array of shape (:), with size(BERR) =
!          size(X,2), or REAL scalar.
!          The componentwise relative backward error of each solution
! 	   vector X(j) (i.e., the smallest relative change in any element
! 	   of A or B that makes X(j) an exact solution).
! RCOND    Optional (output) REAL
!          The estimate of the reciprocal condition number of A. If RCOND
! 	   is less than the machine precision, the matrix is singular to
! 	   working precision. This condition is indicated by a return
!          code of INFO > 0.
! INFO     (output) INTEGER
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: if INFO = i, and i is
!             <= n: D(i,i) = 0. The factorization has been completed, but
! 	         the block diagonal matrix D is singular, so the
! 		 solution could not be computed.
!             = n+1: D is nonsingular, but RCOND is less than machine
! 	         precision, so the matrix is singular to working
! 		 precision. Nevertheless, the solution and error bounds
! 		 are computed because the computed solution can be more
! 		 accurate than the value of RCOND would suggest.
!            n is the order of A.
!          If INFO is not present and an error occurs, then the program
! 	   is terminated with an error message.
!----------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SPSVX'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LFACT, LUPLO
   INTEGER :: LINFO, NRHS, N, NN, ISTAT, ISTAT1, SIPIV, SAF, SFERR, SBERR
   REAL(WP) :: LRCOND
   COMPLEX(WP) :: WW
!  .. LOCAL POINTERS ..
   INTEGER, POINTER :: IWORK(:), LPIV(:)
   REAL(WP),  POINTER :: LFERR(:), LBERR(:)
   REAL(WP),  POINTER :: WORK(:), LAF(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MAX, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; NN = SIZE(A); NRHS = SIZE(B, 2)
   WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW)
   IF( PRESENT(RCOND) ) RCOND = 1.0_WP
   IF( PRESENT(FACT) )THEN; LFACT = FACT; ELSE; LFACT='N'; END IF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = N; END IF
   IF( PRESENT(AFP) )THEN; SAF = SIZE(AFP); ELSE; SAF = NN; END IF
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
!  .. TEST THE ARGUMENTS
    IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1
   ELSE IF( SIZE(B, 1) /= N .OR. NRHS < 0 )THEN; LINFO = -2
   ELSE IF( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS )THEN; LINFO = -3
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -4
   ELSE IF( SAF /= NN ) THEN; LINFO = -5
   ELSE IF( SIPIV /= N )THEN; LINFO = -6
   ELSE IF( ( .NOT. LSAME(LFACT,'F') .AND. .NOT. LSAME(LFACT,'N') ) .OR. &
     ( LSAME(LFACT,'F') .AND. .NOT.( PRESENT(AFP) .AND. PRESENT(IPIV) ) ) )THEN; LINFO = -7
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -8
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -9
   ELSE IF ( N > 0 )THEN
      IF( .NOT.PRESENT(AFP) ) THEN; ALLOCATE( LAF(NN), STAT=ISTAT )
      ELSE; LAF => AFP; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(IPIV) )THEN; ALLOCATE( LPIV(N), STAT=ISTAT )
         ELSE; LPIV => IPIV; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(FERR) )THEN; ALLOCATE( LFERR(NRHS), STAT=ISTAT )
         ELSE; LFERR => FERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) )THEN; ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         ALLOCATE(WORK(MAX(1,3*N)), IWORK(N), STAT=ISTAT)
      END IF
      IF( ISTAT == 0 )THEN
!        .. CALL LAPACK77 ROUTINE
         CALL SPSVX_F77( LFACT, LUPLO, N, NRHS, A, LAF, LPIV, B, N, X, N, &
                         LRCOND, LFERR, LBERR, WORK, IWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(AFP) ) DEALLOCATE( LAF, STAT=ISTAT1 )
      IF( .NOT.PRESENT(IPIV) ) DEALLOCATE( LPIV, STAT=ISTAT1 )
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      IF( PRESENT(RCOND) ) RCOND=LRCOND
      DEALLOCATE( WORK, IWORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE DSPSVX_F95


      PROGRAM TEST
      INTEGER X

      X = 14 + 2
      ASSERT X.EQ.16

      X = 14 - 2
      ASSERT X.EQ.12

      X = 14 * 2
      ASSERT X.EQ.28

      X = 14 / 2
      ASSERT X.EQ.7

      X = 2 * 3 + 4
      ASSERT X.EQ.10

      X = 2 + 3 * 4
      ASSERT X.EQ.14

      X = 2 * (3 + 4)
      ASSERT X.EQ.14

      END


subroutine cal_combination(n, m, cnm)
    use m_constants, only: dp

    implicit none

    ! external variables
    integer, intent(in) :: n
    integer, intent(in) :: m
    integer, intent(out) :: cnm

    ! local variables
    integer :: small
    integer :: large
    integer :: i

    real(dp) :: x
    real(dp) :: y

    small = min(m,n-m)
    large = max(m,n-m)

    x = 1.0_dp
    y = 1.0_dp
    do i=large+1, n
        x = x * dble(i)
    enddo

    do i=1, small
        y = y * dble(i)
    enddo

    cnm = nint(x / y)

    return
end subroutine cal_combination

!!>>> get new fock state and the sign
subroutine make_newfock(c_type, pos, old, new, sgn)
    use m_constants, only: mystd, dp

    implicit none

    character(1), intent(in)  :: c_type
    integer,      intent(in)  :: pos
    integer(dp),  intent(in)  :: old
    integer(dp),  intent(out) :: new
    integer,      intent(out) :: sgn

    integer :: i

    sgn = 0
    do i=1,pos-1
       if (btest(old, i-1) .eqv. .true.) sgn = sgn + 1
    enddo
    sgn = mod(sgn,2)
    sgn = (-1)**sgn

    if (c_type == '+') then
        new = old + (2_dp)**(pos-1)
    elseif (c_type == '-') then
        new = old - (2_dp)**(pos-1)
    else
        write(mystd, "(58a,a)")  "edrixs >>> error of create and destroy operator type: ", c_type
        STOP
    endif

    return
end subroutine make_newfock


( http://www.softsynth.com/pforth/pf_tut.php )

: square ( n -- s )
  dup * ;

: fibonacci ( n -- s )
  dup 1 <=
  if drop 1
  else dup 1 - swap 2 -
       recurse swap recurse
       + then ;

: sum-of-squares ( a b -- c )
  square swap square + ;


!*****************************************************************************************
!>
!  Units test for 1d-6d tensor product b-spline interpolation (object-oriented version).

    program bspline_oo_test

    use bspline_module
    use bspline_kinds_module, only: wp, ip

    implicit none

    integer(ip),parameter :: nx = 6    !number of points
    integer(ip),parameter :: ny = 6
    integer(ip),parameter :: nz = 6
    integer(ip),parameter :: nq = 6
    integer(ip),parameter :: nr = 6
    integer(ip),parameter :: ns = 6

    integer(ip),parameter :: kx = 4    !order
    integer(ip),parameter :: ky = 4
    integer(ip),parameter :: kz = 4
    integer(ip),parameter :: kq = 4
    integer(ip),parameter :: kr = 4
    integer(ip),parameter :: ks = 4

    real(wp) :: x(nx),y(ny),z(nz),q(nq),r(nr),s(ns)
    real(wp) :: fcn_1d(nx)
    real(wp) :: fcn_2d(nx,ny)
    real(wp) :: fcn_3d(nx,ny,nz)
    real(wp) :: fcn_4d(nx,ny,nz,nq)
    real(wp) :: fcn_5d(nx,ny,nz,nq,nr)
    real(wp) :: fcn_6d(nx,ny,nz,nq,nr,ns)

    type(bspline_1d) :: s1
    type(bspline_2d) :: s2
    type(bspline_3d) :: s3
    type(bspline_4d) :: s4
    type(bspline_5d) :: s5
    type(bspline_6d) :: s6

    real(wp) :: tol
    real(wp),dimension(6) :: val,tru,err,errmax
    logical  :: fail
    integer(ip)  :: i,j,k,l,m,n,idx,idy,idz,idq,idr,ids
    integer(ip),dimension(6) :: iflag

    fail = .false.
    tol = 100 * epsilon(1.0_wp)
    idx = 0
    idy = 0
    idz = 0
    idq = 0
    idr = 0
    ids = 0

     do i=1,nx
        x(i) = real(i-1,wp)/real(nx-1,wp)
     end do
     do j=1,ny
        y(j) = real(j-1,wp)/real(ny-1,wp)
     end do
     do k=1,nz
        z(k) = real(k-1,wp)/real(nz-1,wp)
     end do
     do l=1,nq
        q(l) = real(l-1,wp)/real(nq-1,wp)
     end do
     do m=1,nr
        r(m) = real(m-1,wp)/real(nr-1,wp)
     end do
     do n=1,ns
        s(n) = real(n-1,wp)/real(ns-1,wp)
     end do
     do i=1,nx
                        fcn_1d(i) = f1(x(i))
        do j=1,ny
                        fcn_2d(i,j) = f2(x(i),y(j))
           do k=1,nz
                        fcn_3d(i,j,k) = f3(x(i),y(j),z(k))
              do l=1,nq
                        fcn_4d(i,j,k,l) = f4(x(i),y(j),z(k),q(l))
                 do m=1,nr
                        fcn_5d(i,j,k,l,m) = f5(x(i),y(j),z(k),q(l),r(m))
                     do n=1,ns
                        fcn_6d(i,j,k,l,m,n) = f6(x(i),y(j),z(k),q(l),r(m),s(n))
                     end do
                 end do
              end do
           end do
        end do
     end do

     !initialize:

     call s1%initialize(x,fcn_1d,kx,iflag(1))
     call s2%initialize(x,y,fcn_2d,kx,ky,iflag(2))
     call s3%initialize(x,y,z,fcn_3d,kx,ky,kz,iflag(3))
     call s4%initialize(x,y,z,q,fcn_4d,kx,ky,kz,kq,iflag(4))
     call s5%initialize(x,y,z,q,r,fcn_5d,kx,ky,kz,kq,kr,iflag(5))
     call s6%initialize(x,y,z,q,r,s,fcn_6d,kx,ky,kz,kq,kr,ks,iflag(6))

     if (any(iflag/=0)) then
         do i=1,6
             if (iflag(i)/=0) then
                 write(*,*) 'Error initializing ',i,'D spline: '//get_status_message(iflag(i))
             end if
         end do
     end if

     write(*,*) ''
     write(*,*) 'size of 1d structure: ', s1%size_of()*8_ip, 'bytes'
     write(*,*) 'size of 2d structure: ', s2%size_of()*8_ip, 'bytes'
     write(*,*) 'size of 3d structure: ', s3%size_of()*8_ip, 'bytes'
     write(*,*) 'size of 4d structure: ', s4%size_of()*8_ip, 'bytes'
     write(*,*) 'size of 5d structure: ', s5%size_of()*8_ip, 'bytes'
     write(*,*) 'size of 6d structure: ', s6%size_of()*8_ip, 'bytes'
     write(*,*) ''

    ! compute max error at interpolation points

     errmax = 0.0_wp
     do i=1,nx
                        call s1%evaluate(x(i),idx,val(1),iflag(1))
                        tru(1)    = f1(x(i))
                        err(1)    = abs(tru(1)-val(1))
                        errmax(1) = max(err(1),errmax(1))
        do j=1,ny
                        call s2%evaluate(x(i),y(j),idx,idy,val(2),iflag(2))
                        tru(2)    = f2(x(i),y(j))
                        err(2)    = abs(tru(2)-val(2))
                        errmax(2) = max(err(2),errmax(2))
           do k=1,nz
                        call s3%evaluate(x(i),y(j),z(k),idx,idy,idz,val(3),iflag(3))
                        tru(3)    = f3(x(i),y(j),z(k))
                        err(3)    = abs(tru(3)-val(3))
                        errmax(3) = max(err(3),errmax(3))
              do l=1,nq
                        call s4%evaluate(x(i),y(j),z(k),q(l),idx,idy,idz,idq,val(4),iflag(4))
                        tru(4)    = f4(x(i),y(j),z(k),q(l))
                        err(4)    = abs(tru(4)-val(4))
                        errmax(4) = max(err(4),errmax(4))
                do m=1,nr
                        call s5%evaluate(x(i),y(j),z(k),q(l),r(m),idx,idy,idz,idq,idr,val(5),iflag(5))
                        tru(5)    = f5(x(i),y(j),z(k),q(l),r(m))
                        err(5)    = abs(tru(5)-val(5))
                        errmax(5) = max(err(5),errmax(5))
                    do n=1,ns
                        call s6%evaluate(x(i),y(j),z(k),q(l),r(m),s(n),idx,idy,idz,idq,idr,ids,val(6),iflag(6))
                        tru(6)    = f6(x(i),y(j),z(k),q(l),r(m),s(n))
                        err(6)    = abs(tru(6)-val(6))
                        errmax(6) = max(err(6),errmax(6))
                    end do
                end do
              end do
           end do
        end do
     end do

    ! check max error against tolerance
    do i=1,6
        write(*,*) i,'D: max error:', errmax(i)
        if (errmax(i) >= tol) then
            write(*,*)  ' ** test failed ** '
        else
            write(*,*)  ' ** test passed ** '
        end if
        write(*,*) ''
    end do

    contains

        real(wp) function f1(x) !! 1d test function
        implicit none
        real(wp) :: x
        f1 = 0.5_wp * (x*exp(-x) + sin(x) )
        end function f1

        real(wp) function f2(x,y) !! 2d test function
        implicit none
        real(wp) x,y,piov2
        piov2 = 2.0_wp * atan(1.0_wp)
        f2 = 0.5_wp * (y*exp(-x) + sin(piov2*y) )
        end function f2

        real(wp) function f3 (x,y,z) !! 3d test function
        implicit none
        real(wp) x,y,z,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f3 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) )
        end function f3

        real(wp) function f4 (x,y,z,q) !! 4d test function
        implicit none
        real(wp) x,y,z,q,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f4 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q )
        end function f4

        real(wp) function f5 (x,y,z,q,r) !! 5d test function
        implicit none
        real(wp) x,y,z,q,r,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f5 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r )
        end function f5

        real(wp) function f6 (x,y,z,q,r,s) !! 6d test function
        implicit none
        real(wp) x,y,z,q,r,s,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f6 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r + 2.0_wp*s )
        end function f6

    end program bspline_oo_test


      PROGRAM xmprove
C     driver for routine mprove
      INTEGER N,NP
      PARAMETER(N=5,NP=5)
      INTEGER i,j,idum,indx(N)
      REAL d,a(NP,NP),b(N),x(N),aa(NP,NP),ran3
      DATA a/1.0,2.0,1.0,4.0,5.0,2.0,3.0,1.0,5.0,1.0,
     *     3.0,4.0,1.0,1.0,2.0,4.0,5.0,1.0,2.0,3.0,
     *     5.0,1.0,1.0,3.0,4.0/
      DATA b/1.0,1.0,1.0,1.0,1.0/
      do 12 i=1,N
        x(i)=b(i)
        do 11 j=1,N
          aa(i,j)=a(i,j)
11      continue
12    continue
      call ludcmp(aa,N,NP,indx,d)
      call lubksb(aa,N,NP,indx,x)
      write(*,'(/1x,a)') 'Solution vector for the equations:'
      write(*,'(1x,5f12.6)') (x(i),i=1,N)
C     now phoney up x and let mprove fix it
      idum=-13
      do 13 i=1,N
        x(i)=x(i)*(1.0+0.2*ran3(idum))
13    continue
      write(*,'(/1x,a)') 'Solution vector with noise added:'
      write(*,'(1x,5f12.6)') (x(i),i=1,N)
      call mprove(a,aa,N,NP,indx,b,x)
      write(*,'(/1x,a)') 'Solution vector recovered by MPROVE:'
      write(*,'(1x,5f12.6)') (x(i),i=1,N)
      END

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


program main
    use MathClass
    implicit none

    ! computing derivative
    print *, d_dx(myfunc      ,x=0.10d0)
    print *, d_dx(my_vec_func ,x=[0.10d0, 2.0d0],dim_num=2)

contains

function myfunc(x) result(ret)
    real(real64),parameter :: a=2.0d0
    real(real64),parameter :: b=1.0d0
    real(real64),intent(in) :: x
    real(real64) :: ret
    ret = a*x*x + b
end function

function my_vec_func(x) result(ret)
    real(real64),parameter :: a=2.0d0
    real(real64),parameter :: b=1.0d0
    real(real64),intent(in) :: x(:)
    real(real64),allocatable :: ret(:)
    ret = a*x + b
end function

end program main


subroutine SHReturnTapers(theta0, lmax, tapers, eigenvalues, taper_order)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will return all the eigenvalues and
!	eigenfunctions for the space concentration problem of
!	a spherical cap of angular radius theta0. The returned
!	eigenfunctions correspond to "geodesy" normalized spherical
!	harmonic coefficients, and the eigenfunctions are further
!	normalized such that they have unit power (i.e., the integral
!	of the function squared over the sphere divided by 4 pi is 1,
!	and the sum of the squares of their coefficients is 1).
!	The eigenfunctions are calculated using the
!	kernel of Grunbaum et al. 1982, and the eigenvalues are
!	calculated by numerical integration.
!
!
!	Calling Parameters
!		IN
!			theta0		Angular radius of spherical cap
!					in RADIANS.
!			lmax		Maximum spherical harmonic degree
!					for the concentration problem.
!		OUT
!			tapers		An (lmax+1) by (lmax+1) array containing
!					all the eigenfunctions of the space-
!					concentration kernel. Eigenfunctions
!					are listed by columns in decreasing order
!					corresponding to value of their eigenvalue.
!			eigenvalues	A vector of length lmax+1 containing the
!					eigenvalued corresponding to the individual
!					eigenfunctions.
!			taper_order	A vector of dimension X denoting which order m
!					corresponds to the column of tapers and
!					eigenvalues.
!
!	Dependencies: LAPACK, BLAS, ComputeDG82, EigValVecSymTri, PreGLQ, PlmBar, PlmIndex
!
!	Written by Mark Wieczorek 2006
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: ComputeDG82, EigValVecSymTri, PreGLQ, PlmBar, PlmIndex

	implicit none

	real*8, intent(in) ::	theta0
	integer, intent(in) ::	lmax
	real*8, intent(out) ::	tapers(:,:), eigenvalues(:)
	integer, intent(out) ::	taper_order(:)
	integer ::		l, m, nt, nt2, n, i, j, jj(1), astat(8), n_int
	real*8, allocatable :: 	eval(:), evec(:, :), tapers_unordered(:,:), &
				dllmtri(:,:), eval_unordered(:), p(:)
	real*8 :: 		pi, upper, lower, w(lmax+1), zero(lmax+1), h
	integer, allocatable ::	m_unordered(:)

	if (size(tapers(:,1)) < (lmax+1) .or. size(tapers(1,:)) < (lmax+1)**2) then
		print*, "Error --- SHReturnTapers"
		print*, "TAPERS must be dimensioned as ( LMAX+1, (LMAX+1)**2 ) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(tapers(:,1)), size(tapers(1,:))
		stop
	elseif(size(eigenvalues) < (lmax+1)**2) then
		print*, "Error --- SHReturnTapers"
		print*, "EIGENVALUES must be dimensioned as (LMAX+1)**2 where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(eigenvalues)
		stop
	elseif(size(taper_order) < (lmax+1)**2) then
		print*, "Error --- SHReturnTapers"
		print*, "TAPER_ORDER must be dimensioned as (LMAX+1)**2 where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(taper_order)
		stop
	endif

	allocate(eval(lmax+1), stat = astat(1))
	allocate(evec(lmax+1, lmax+1), stat = astat(2))
	allocate(tapers_unordered(lmax+1, (lmax+1)**2), stat = astat(3))
	allocate(dllmtri(lmax+1, lmax+1), stat = astat(4))
	allocate(eval_unordered((lmax+1)**2), stat = astat(5))
	allocate(m_unordered((lmax+1)**2), stat = astat(6))
	allocate(p((lmax+1)*(lmax+2)/2), stat = astat(7))

	if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 .or. astat(4) /=0 &
		.or. astat(5) /= 0 .or. astat(6) /=0 .or. astat(7) /=0 ) then
		print*, "ERROR ---- SHReturnTapers"
		print*, "Problem allocating memory for temporary arrays", astat
		stop
	endif

	pi = acos(-1.0d0)

	tapers = 0.0d0
	tapers_unordered = 0.0d0
	eigenvalues = 0.0d0
	eval_unordered = 0.0d0
	m_unordered = 0
	taper_order = 0

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate eigenfunctions of the Grunbaum et al. kernel.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	nt = 0

	do m=0, lmax

		n = lmax + 1 - m

		call ComputeDG82(dllmtri(1:n,1:n), lmax, m, theta0)
		call EigValVecSymTri(dllmtri(1:n, 1:n), n, eval(1:n), evec(1:n,1:n))

		tapers_unordered(m+1:lmax+1, nt+1:nt+n) = evec(1:n,1:n)
		m_unordered(nt+1:nt+n) = m

		nt = nt + n
	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate true eigenvalues
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	upper = 1.0d0
	lower = cos(theta0)
	n_int = lmax+1

	call PreGLQ(lower, upper, n_int, zero, w)

	do i=1, n_int

		call PlmBar(p, lmax, zero(i))

		do j=1, nt

			h = 0.0d0

			do l=m_unordered(j), lmax
				h = h + p(PlmIndex(l, m_unordered(j))) * tapers_unordered(l+1, j)
			enddo

			eval_unordered(j) = eval_unordered(j) + w(i) * h**2
		enddo
	enddo

	do j=1, nt
		if (m_unordered(j) == 0) then
			eval_unordered(j) = eval_unordered(j) / 2.0d0
		else
			eval_unordered(j) = eval_unordered(j) / 4.0d0
		endif
	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Reorder tapers and eigenvalues
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	nt2 = 0

	do i=1, nt

		jj = maxloc(eval_unordered(1:nt))
		j = jj(1)

		if (m_unordered(j) == 0) then
			nt2 = nt2 + 1
			taper_order(nt2) = m_unordered(j)
			eigenvalues(nt2) = eval_unordered(j)
			tapers(1:lmax+1,nt2) = tapers_unordered(1:lmax+1,j)
		else
			nt2 = nt2 + 1
			taper_order(nt2) = -m_unordered(j)
			eigenvalues(nt2) = eval_unordered(j)
			tapers(1:lmax+1,nt2) = tapers_unordered(1:lmax+1,j)
			nt2 = nt2 + 1
			taper_order(nt2) = m_unordered(j)
			eigenvalues(nt2) = eval_unordered(j)
			tapers(1:lmax+1,nt2) = tapers_unordered(1:lmax+1,j)
		endif

		eval_unordered(j) = -1.0d25

	enddo

	call PlmBar(p, -1, zero(1))
	deallocate(eval) ;  deallocate(evec) ; deallocate(tapers_unordered)
	deallocate(dllmtri) ; deallocate(eval_unordered)
	deallocate(m_unordered) ; deallocate(p)

end subroutine SHReturnTapers


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_modcylk
      use m_juDFT
c     generates Makdonald's function K_m(x) for a given
c     order m and point x
c                         Y.Mokrousov
      CONTAINS
      SUBROUTINE modcylk(
     >                   m,x,
     <                   kJ)

      implicit none

      integer, intent  (in) :: m
      real,    intent  (in) :: x
      real,    intent (out) :: kJ

      real,    parameter :: zero = 0.0
      real,    parameter :: gamma =
     =     0.5772156649015328608

      integer :: mm,i,mass,fact,j,m1
      real :: quot,t,k0,k1,kJ1,kJ2,psi,a
c     real, allocatable :: aux(:)

      if (x.le.zero)  CALL juDFT_error("x.le.zero",calledby="modcylk")

c     K_0 and K_1 part

      if (x.gt.1.0) then
         t = 1./x
         k0 = exp(-x)*sqrt(t)*(1.2533141373 -
     -    0.1566641816*t      + 0.0881112782*(t**2)  -
     -    0.0913909546*(t**3) + 0.1344569228*(t**4)  -
     -    0.2299850328*(t**5) + 0.3792409730*(t**6)  -
     -    0.5247277331*(t**7) + 0.5575368367*(t**8)  -
     -    0.4262632912*(t**9) + 0.2184518096*(t**10) -
     -    0.0668097672*(t**11)+ 0.0091893830*(t**12))
         k1 = exp(-x)*sqrt(t)*(1.2533141373 +
     +    0.4699927013*t      - 0.1468582957*(t**2)  +
     +    0.1280426636*(t**3) - 0.1736431637*(t**4)  +
     +    0.2847618149*(t**5) - 0.4594342117*(t**6)  +
     +    0.6283380681*(t**7) - 0.6632295430*(t**8)  +
     +    0.5050238576*(t**9) - 0.2581303765*(t**10) +
     +    0.0788000118*(t**11)- 0.0108241775*(t**12))
      end if
      if (x.le.1.0) then
         t = 1./x
         k0 = - gamma - log(x/2.)
         k1 = t
         do i = 1,8
            psi = -gamma
            fact = 1
            do j = 1,i
               psi = psi + 1./j
               fact = fact*j
            end do
            if (i.le.6) then
            k0 = k0 + ((x/2.)**(2*i))*(psi-log(x/2.))/
     /           (fact*fact)
            end if
            k1 = k1 + ((x/2.)**(2*i-1))*(0.5 - i*
     *           (psi - log(x/2.)))/(fact*fact)
         end do
      end if
      if (m.eq.0) then
         kJ = k0
         return
      end if
      if (m.eq.1 .or. m.eq.-1) then
         kJ = k1
         return
      end if

c     forward recursion

      kJ1 = k0
      kJ2 = k1
      m1 = int(abs(m))
      do mm = 2,m1
         a = kJ2
         kJ2 = 2*(mm-1)*t*kJ2 + kJ1
         kJ1 = a
      end do
      kJ = kJ2

      END SUBROUTINE modcylk
      END MODULE m_modcylk


module problem

    ! Specify the function f defining the problem to be solved,
    ! and the true solution for checking the answers.

    ! These functions must be consistent: the second derivative of
    ! u_true should equal -f(x).

contains

    real(kind=8) function f(x)
        ! right hand side
        implicit none
        real(kind=8), intent(in) :: x
        f = 100.d0 * exp(x)
    end function f

    real(kind=8) function u_true(x)
        ! true solution
        implicit none
        real(kind=8), intent(in) :: x
        u_true = (100.d0*exp(1.d0) - 60.d0)*x + 120 - 100.d0*exp(x)
    end function u_true

end module problem


c
c
c     =====================================================
      double precision function philim(a,b,meth)
c     =====================================================
      implicit none

      double precision a,b
      integer meth

      double precision r, c
c
c     # Compute a limiter based on wave strengths a and b.
c     # meth determines what limiter is used.
c     # a is assumed to be nonzero.
c
      r = b/a
      goto (10, 20, 30, 40) meth

   10 continue
c     --------
c     # minmod
c     --------
      philim = dmax1(0.d0, dmin1(1.d0, r))
      return
c
   20 continue
c     ----------
c     # superbee
c     ----------
      philim = dmax1(0.d0, dmin1(1.d0, 2.d0*r), dmin1(2.d0, r))
      return
c
   30 continue
c     ----------
c     # van Leer
c     ----------
      philim = (r + dabs(r)) / (1.d0 + dabs(r))
      return
c
   40 continue
c     ------------------------------
c     # monotinized centered
c     ------------------------------
      c = (1.d0 + r)/2.d0
      philim = dmax1(0.d0, dmin1(c, 2.d0, 2.d0*r))

      return
      end


      SUBROUTINE lpbut3p( corner, sample, number, data )
!     lpbut3p is a recursive three-pole Butterworth low-pass filter.
!    Taken from Gold and Rader, "Digital Processing of Signals", pg57
!
!  ARGUMENTS:
!  corner - the corner frequency in hertz
!  sample - the sampling frequency in hertz
!  number - the number of data points in the time series
!  data   - the input and output data array
!
!  Variables:
!  delay  - unfiltered data for the previous point
!  twc    - corner / sample
!
      REAL data(111)

      twc = corner / sample
      expon = EXP(-twc)
      expon2 = EXP(-twc / 2. )
      term = twc * SQRT(3.) / 2.
      beta = 2. * expon2 * COS(term)
      eta = expon2 * (COS(term) + SIN(term) / SQRT(3.))
      delay = data(2)
      delayd = 0.
      delay1 = 0.
      delay2 = 0.

      DO 510 i = 3, number
         out1 = twc * data(i) + expon * delay
         out2 = twc * (eta*delayd-data(i)) + beta*delay1 - expon*delay2
         delayd = data(i)
         delay = out1
         delay2 = delay1
         delay1 = out2
         data(i) = -(out1 + out2)
  510 CONTINUE

      RETURN
      END


c=======================================================================
c
c     subroutine ALLOCVAR
c
c     Asset allocation s.t. maximum Value-at-Risk (upper bound) constraint
c
c     Max[ rho*w]
c      s.t.
c     VaR(w) <= VaRmax         (Value-at-Risk constraint)
c     C*w <= b                 (linear constraints)
c     Cinf <= w <= Csup        (lower/upper bounds)
c
c        w      : portfolio weights
c        Q      : covariance matrix
c        rho    : assets performance
c        VaRmax : VaR upper bound
c
c-----------------------------------------------------------------------
      SUBROUTINE allocvar ( n, cov, rho,
     &                      neq, nin, ccst, bcst, cinf, csup,
     &                      vrimax, conflp, maxdic, epsdic,
     &                      iwork, dwork,
     &                      wopt, vriopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : portfolio size                            integer
c            cov    : covariance matrix (n*n)                     double
c            rho    : mean returns (n)                            double
c            neq    : number of equality constraints             integer
c            nin    : number of inequality constraints           integer
c            ccst   : constraints matrix (n*(neq + nin))          double
c            bcst   : constraints vector (neq + nin)              double
c            cinf   : lower bound (n)                             double
c            csup   : upper bound (n)                             double
c            vrimax : Value-at-Risk constraint                    double
c            conflp : confidence level parameter ( 0<conflp<1 )   double
c            maxdic : maximum of dichotomy iterations            integer
c            epsdic : precision of dichotomy                      double
c
c     WORKSPACE
c            iwork  : 3*n + 2*nin + neq + 3                      integer
c            dwork  : n*(2*n+nin+neq+10) + 2*neq + 4*nin + 4      double
c
c     OUTPUT
c            wopt   : optimal portfolio (n)                       double
c            vriopt : optimal Value-at-Risk                       double
c            info   : diagnostic argument                        integer
c
c     CALL
c        YM      : copy a vectorized matrix in a vectorized matrix
c        OPVAR   : computing optimization for ALLOCVAR (cf. OPVAR.F)
c        TESTSDP : test if covariance matrix is SDP
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, maxdic, info
      DOUBLE PRECISION vrimax, conflp, epsdic, vriopt
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*), ccst(*),
     &                 bcst(*), wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piwo, pdwo, pisdp, pdsdp
      DOUBLE PRECISION EPS
      PARAMETER ( EPS = 1.0E-8 )
c
c     external subroutines
      EXTERNAL YM, testsdp, opvar
c
c     intrinsic functions
      INTRINSIC MAX
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp  : pointer for TESTSDP ( n )
      piwo  = 1
c     piwo  : pointer for OPVAR ( 3*n + neq + 2*nin + 3 )
c
c     Total size of iwork array = 3*n + 2*nin + neq + 3
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdsdp = 1
c     pdsdp : pointer for TESTSDP ( n*(2*n + 7) )
      pdwo  = 1
c     pdwo  : pointer for OPVAR
c             ( n*( n + neq + nin + 10 ) + 2*neq + 4*nin + 4 )
c
c     Total size of dwork array = n*(2*n + nin + neq + 10) + 2*neq + 4*nin + 4
c
c-----------------------------------------------------------------------
c
c     test confidence level
      IF ( (conflp .LT. EPS) .or. (conflp .GT. (1. - EPS)) ) THEN
         info = -102
         RETURN
      ENDIF
c
c     covariance matrix SDP test
      CALL testsdp (n , cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     optimization (see OPVAR.F)
      CALL opvar ( n, cov, rho, neq, nin, ccst, bcst, cinf, csup,
     &             vrimax, conflp, maxdic, epsdic,
     &             iwork(piwo), dwork(pdwo),
     &             wopt, vriopt, info )
c
      RETURN
      END


! =============================================================================
!                       Test ellipsoid split and merge
!
!         This unit test splits an ellispoid and the merges it again. The
!         initial and final ellispoid should be the same. The ellipsoid
!         is centred at the origin and the orientation is varied.
! =============================================================================
program test_ellipsoid_split_merge
    use unit_test
    use constants, only : pi, zero, one, three, four, five, ten, f12, f14, f34
    use parcel_container
    use parcel_ellipsoid, only : get_B33
    use parcel_merge, only : merge_parcels, merge_timer
    use parcel_nearest
    use parcel_split_mod, only : parcel_split, split_timer
    use parameters, only : update_parameters, nx, ny, nz, extent, lower, vmax, vmin
    use timer
    implicit none

    double precision, parameter :: lam = five
    double precision :: theta, phi, st, ct, sp, cp
    double precision :: B11, B12, B13, B22, B23, B33, abc, ab
    double precision :: error, a2, b2, c2
    integer :: i, j

    nx = 1
    ny = 1
    nz = 1
    extent = (/ten, ten, ten/)
    lower = (/-five, -five, -five/)
    call update_parameters

    abc = one
    ab = f34

    a2 = ab * lam
    b2 = ab / lam
    c2 = (abc / ab) ** 2

    ! set vmin to initial parcel volume
    vmin = four / three * abc * pi

    ! set vmax to half the initial volume
    vmax = f12 * vmin

    call register_timer('parcel split', split_timer)
    call register_timer('parcel merge', merge_timer)
    call register_timer('merge nearest', merge_nearest_timer)
    call register_timer('merge tree resolve', merge_tree_resolve_timer)

    call parcel_alloc(2)

    error = zero

    do i = 0, 7
        theta = dble(i) * f14 * pi
        st = dsin(theta)
        ct = dcos(theta)
        do j = 0, 7
            phi = dble(j) * f14 * pi
            sp = dsin(phi)
            cp = dcos(phi)

            call setup_parcels

            ! numerical split
            call parcel_split(parcels, threshold=four)

            ! make sure we split
            error = max(error, abs(dble(2 - n_parcels)))

            call merge_parcels(parcels)

            ! we should get original parcel
            call check_result
        enddo
    enddo

    call print_result_dp('Test ellipsoid split and split', error, atol=1.0e-14)

    call parcel_dealloc

    contains

        subroutine setup_parcels
            n_parcels = 1

            parcels%position(:, 1) = zero
            parcels%volume(1) = four / three * abc * pi
            parcels%buoyancy(1) = one
#ifndef ENABLE_DRY_MODE
            parcels%humidity(1) = one
#endif
            ! 7 Nov 2021
            ! https://mathworld.wolfram.com/SphericalCoordinates.html
            B11 = a2 * ct ** 2 * sp ** 2 + b2 * st ** 2 + c2 * ct ** 2 * cp ** 2
            B12 = a2 * st * ct * sp ** 2 - b2 * st * ct + c2 * st * ct * cp ** 2
            B13 = (a2 - c2) * ct * sp * cp
            B22 = a2 * st ** 2 * sp ** 2 + b2 * ct ** 2 + c2 * st ** 2 * cp ** 2
            B23 = (a2 - c2) * st * sp * cp
            B33 = a2 * cp ** 2 + c2 * sp ** 2

            parcels%B(1, 1) = B11
            parcels%B(2, 1) = B12
            parcels%B(3, 1) = B13
            parcels%B(4, 1) = B22
            parcels%B(5, 1) = B23
        end subroutine setup_parcels

        subroutine check_result
            error = max(error, abs(dble(1 - n_parcels)))
            error = max(error, abs(parcels%B(1, 1) - B11))
            error = max(error, abs(parcels%B(2, 1) - B12))
            error = max(error, abs(parcels%B(3, 1) - B13))
            error = max(error, abs(parcels%B(4, 1) - B22))
            error = max(error, abs(parcels%B(5, 1) - B23))
            error = max(error, abs(get_B33(parcels%B(:, 1), parcels%volume(1)) - B33))
            error = max(error, sum(abs(parcels%position(:, 1))))
            error = max(error, abs(four / three * abc * pi - parcels%volume(1)))
            error = max(error, abs(parcels%buoyancy(1) - one))
#ifndef ENABLE_DRY_MODE
            error = max(error, abs(parcels%humidity(1) - one))
#endif
        end subroutine check_result

end program test_ellipsoid_split_merge


SUBROUTINE p87(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.7 Plane or axisymmetric analysis of the consolidation equation
!             using 4-node rectangular quadrilaterals. Mesh numbered in
!             x(r)- or y(z)- direction. "theta" method using an
!             "element-by-element" (ebe) product algorithm.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,j,nci,ndim=2,nels,neq,nip=4,nlen,nn,nod=4, &
   npri,np_types,nres,nstep,ntime,nxe,nye
 REAL(iwp)::det,dtim,one=1.0_iwp,pt5=0.5_iwp,theta,time,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,dir,element='quadrilateral',type_2d
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::coord(:,:),der(:,:),deriv(:,:),fun(:),gc(:),      &
   globma(:),g_coord(:,:),jac(:,:),kay(:,:),kc(:,:),loads(:),ntn(:,:),    &
   mm(:,:),points(:,:),prop(:,:),store_kc(:,:,:),value(:),weights(:),     &
   x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)type_2d,dir,nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 neq=nn
 WRITE(11,'(a,i5,a)')" There are",neq," equations"
 ALLOCATE(points(nip,ndim),weights(nip),kay(ndim,ndim),coord(nod,ndim),   &
   fun(nod),jac(ndim,ndim),g_coord(ndim,nn),der(ndim,nod),deriv(ndim,nod),&
   mm(nod,nod),g_num(nod,nels),kc(nod,nod),ntn(nod,nod),num(nod),         &
   globma(0:nn),store_kc(nod,nod,nels),gc(ndim),loads(0:neq),             &
   x_coords(nxe+1),y_coords(nye+1),prop(ndim,np_types),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 READ(10,*)dtim,nstep,theta,npri,nres,ntime
 CALL sample(element,points,weights)
 globma=zero
 gc=one
 !---------create and store element and global lumped mass matrices--------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,dir)
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   kc=zero
   mm=zero
   gauss_pts: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     if(type_2d=='axisymmetric')gc=MATMUL(fun,coord)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)*gc(1)
     CALL cross_product(fun,fun,ntn)
     mm=mm+ntn*det*weights(i)*gc(1)
   END DO gauss_pts
   store_kc(:,:,iel)=kc
   DO i=1,nod
     globma(num(i))=globma(num(i))+SUM(mm(i,:))
   END DO
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
!-----------------------recover element a and b matrices------------------
 elements_2: DO iel=1,nels
   num=g_num(:,iel)
   kc=-store_kc(:,:,iel)*(one-theta)*dtim*pt5
   mm=store_kc(:,:,iel)*theta*dtim*pt5
   DO i=1,nod
     mm(i,i)=mm(i,i)+globma(num(i))
     kc(i,i)=kc(i,i)+globma(num(i))
   END DO
   CALL invert(mm)
   mm=MATMUL(mm,kc)
   store_kc(:,:,iel)=mm
 END DO elements_2
!-----------------------specify initial and boundary values---------------
 READ(10,*)loads(1:)
 loads(0)=zero
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
 END IF
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/a,i3,a)')"    Time      Pressure (node",nres,")"
 WRITE(11,'(2e12.4)')0.0,loads(nres)
 timesteps: DO j=1,nstep
   time=j*dtim
!-----------------------first pass (1 to nels)----------------------------
   elements_3: DO iel=1,nels
     num=g_num(:,iel)
     mm=store_kc(:,:,iel)
     loads(num)=MATMUL(mm,loads(num))
     loads(0)=zero
     loads(node)=value
   END DO elements_3
!-----------------------second pass (nels to 1)---------------------------
   elements_4: DO iel=nels,1,-1
     num=g_num(:,iel)
     mm=store_kc(:,:,iel)
     loads(num)=MATMUL(mm,loads(num))
     loads(0)=zero
     loads(node)=value
   END DO elements_4
   IF(nod==4.AND.j==ntime)THEN
     READ(10,*)nci
     CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)
   END IF
   IF(j/npri*npri==j)WRITE(11,'(2e12.4)')time,loads(nres)
 END DO timesteps

END SUBROUTINE p87


      REAL FUNCTION VECL (VX,VY,VZ)

C  This function returns the length of a 3D vector.

      REAL  VX,VY,VZ, VECL2

      VECL = SQRT (VECL2 (VX,VY,VZ) )

      END


module constants_mod
  implicit none
  save

  real*8, parameter :: pi = 4.*atan(1.)
  real*8, parameter:: twopi=2.*pi
  real*8, parameter:: fourpi=4.*pi

  real*8, parameter :: h=6.626D-34 !Planck
  real*8, parameter :: c=3.D+8      !Speed of light
  real*8, parameter :: Na=6.022D+23  !Avogadro

end module constants_mod


Subroutine RanGauss (Gau)

  Use cte
  Implicit None

  Real :: Ran1, Ran2, Gau

1 Call Random_Number (Ran1)
  Call Random_Number (Ran2)

  ! Condicion para evitar que el logaritmo diverja

  If (Ran1 .LE. 1E-8) Then

     Go To 1

  End If

  ! Aqui se generan los numeros aleatorios con distribucion Gaussiana

  Gau =  sqrt(-2.0 * Log(Ran1) ) * Cos(2.0 * Pi * Ran2)

End Subroutine RanGauss


program harmonics
   use constants
   use io
   use samples
   use spectra
   implicit none

   integer :: n
   integer, parameter :: nmax = 100

   real(dp) :: wave(2 * nmax), amplitude, phase
   complex(dp) :: spectrum(nmax)

   call sample(wave, 'wave', command_argument(1, 'circular'))

   call fourier(wave, spectrum)

   write (*, "(/ 'f(t) = sum r[n] cos(n omega t - phi[n])' /)")
   write (*, '(A2, 2A15)') 'n', 'r[n]', 'phi[n]'

   do n = 1, size(spectrum)
      amplitude = 2 * abs(spectrum(n))

      if (amplitude .lt. 1e-10_dp) cycle

      phase = atan2(aimag(spectrum(n)), real(spectrum(n)))

      write (*, '(I2, 2F15.10)') n, amplitude, phase
   end do
end program harmonics


      subroutine realtr(a,b,n,isn)
c  if isn=1, this subroutine completes the fourier transform
c    of 2*n real data values, where the original data values are
c    stored alternately in arrays a and b, and are first
c    transformed by a complex fourier transform of dimension n.
c    the cosine coefficients are in a(1),a(2),...,a(n+1) and
c    the sine coefficients are in b(1),b(2),...,b(n+1).
c    a typical calling sequence is
c      call fft(a,b,n,n,n,1)
c      call realtr(a,b,n,1)
c    the results should be multiplied by 1.0/(2.0*n) to give the
c    usual scaling of coefficients.
c  if isn=-1, the inverse transformation is done, the first step
c    in evaluating a real fourier series.
c    a typical calling sequence is
c      call realtr(a,b,n,-1)
c      call fft(a,b,n,n,n,-1)
c    the results should be multiplied by 0.5 to give the usual
c    scaling, and the time domain results alternate in arrays a
c    and b, i.e. a(1),b(1),a(2),b(2),...,a(n),b(n).
c  with most fortran compilers the data can alternatively be
c    stored in a single complex array a, then the magnitude of isn
c    changed to two to give the correct indexing increment and a(2)
c    used to pass the initial address for the sequence of imaginary
c    values, e.g.
c      call fft(a,a(2),n,n,n,2)
c      call realtr(a,a(2),n,2)
c    in this case, the cosine and sine coefficients alternate in a.
c  by r. c. singleton, stanford research institute, sept. 1968
      dimension a(1),b(1)
      real im
      inc=iabs(isn)
      nk=n*inc+2
      nh=nk/2
      sd=2.0*atan(1.0)/float(n)
      cd=2.0*sin(sd)**2
      sd=sin(sd+sd)
      sn=0.0
      if(isn .lt. 0) go to 30
      cn=1.0
      a(nk-1)=a(1)
      b(nk-1)=b(1)
   10 do 20 j=1,nh,inc
      k=nk-j
      aa=a(j)+a(k)
      ab=a(j)-a(k)
      ba=b(j)+b(k)
      bb=b(j)-b(k)
      re=cn*ba+sn*ab
      im=sn*ba-cn*ab
      b(k)=im-bb
      b(j)=im+bb
      a(k)=aa-re
      a(j)=aa+re
      aa=cn-(cd*cn+sd*sn)
      sn=(sd*cn-cd*sn)+sn
      cn=2.0-(aa**2+sn**2)
      sn=cn*sn
   20 cn=cn*aa
      return
   30 cn=-1.0
      sd=-sd
      go to 10
      end


module gaussmod
!! Helper for [[vscoul_mod]]
contains

subroutine gauss(n,ldim,a,x,c)
   implicit none
   integer n,ldim
   real(8) a,x,c
   integer i,j,k
   real(8) swap,fact
   dimension a(ldim,ldim),x(ldim),c(ldim)
   do i=1,n
      x(i)=c(i)
   end do
   do i=1,n-1
      k=i
      do j=i+1,n
         if(abs(a(k,i)) .lt. abs(a(j,i))) k=j
      end do
      if(k .ne. i) then
         do j=i,n
            swap=a(i,j)
            a(i,j)=a(k,j)
            a(k,j)=swap
         enddo
         swap=x(i)
         x(i)=x(k)
         x(k)=swap
      end if
      do k=i+1,n
         fact=a(k,i)/a(i,i)
         do j=i+1,n
            a(k,j)=a(k,j)-fact*a(i,j)
         end do
         x(k)=x(k)-fact*x(i)
      end do
   end do
   x(n)=x(n)/a(n,n)
   do i=n-1,1,-1
      do k=i+1,n
         x(i)=x(i)-a(i,k)*x(k)
      end do
      x(i)=x(i)/a(i,i)
   end do
   return
end subroutine

end module gaussmod


function gaussian_kernel(a, b) result(kernel)

    double precision, dimension(:), intent(in) :: a
    double precision, dimension(:), intent(in) :: b

    double precision :: kernel
    integer :: i
    double precision :: temp
    double precision :: sigma

    kernel = 0.0d0
    sigma = 724.0d0

    do i = 1, size(a)
        temp = a(i) - b(i)
        kernel = kernel + temp * temp
    enddo

    kernel = exp(-0.5d0 * sqrt(kernel) / (sigma*sigma))

end function gaussian_kernel

function laplace_kernel(a, b) result(kernel)

    double precision, dimension(:), intent(in) :: a
    double precision, dimension(:), intent(in) :: b

    double precision :: kernel

    kernel = sum(abs(a(:) - b(:)))
    kernel = exp(-0.00025118864315095795d0 * kernel)

end function laplace_kernel

subroutine kgaussian_kernel(a, na, b, nb, k, sigma)

    double precision, dimension(:,:), intent(in) :: a
    double precision, dimension(:,:), intent(in) :: b

    integer, intent(in) :: na, nb

    double precision, dimension(:,:), intent(inout) :: k
    double precision, intent(in) :: sigma

    double precision, allocatable, dimension(:) :: temp

    double precision :: inv_sigma
    integer :: l

    inv_sigma = -0.5d0 / (sigma*sigma)

    allocate(temp(size(a, dim=1)))

!$OMP PARALLEL DO PRIVATE(temp)
    do i = 1, nb
        do j = 1, na
            temp(:) = a(:,j) - b(:,i)
            K(j,i) = exp(inv_sigma * sqrt(sum(temp*temp)))
        enddo
    enddo
!$OMP END PARALLEL DO

    deallocate(temp)
end subroutine kgaussian_kernel

subroutine klaplace_kernel(a, na, b, nb, k, sigma)

    double precision, dimension(:,:), intent(in) :: a
    double precision, dimension(:,:), intent(in) :: b

    integer, intent(in) :: na, nb

    double precision, dimension(:,:), intent(inout) :: k
    double precision, intent(in) :: sigma

    double precision :: inv_sigma

    inv_sigma = -1.0d0 / sigma

!$OMP PARALLEL DO
    do i = 1, nb
        do j = 1, na
        k(j,i) = exp(inv_sigma * sum(abs(a(:,j) - b(:,i))))
        enddo
    enddo
!$OMP END PARALLEL DO

end subroutine klaplace_kernel


c
	subroutine cart_to_pol(x_in,lat,long,radial)
	parameter (pi=3.1415927)
	real lat,long,radial,x_in(3),row
c
	row=sqrt(x_in(1)*x_in(1)+x_in(2)*x_in(2))
	radial=sqrt(row*row+x_in(3)*x_in(3))
	lat=atan2(x_in(3),row)
	long=atan2(x_in(2),x_in(1))
	long=long + (1.0-sign(1.0,long))*pi
c
	return
	end


!> \file rho.f90
!! \BRIEF
!> Module with rho function - computes in situ density from S, T, P
MODULE mrho
CONTAINS
!> Function to compute in situ density from salinity (psu), in situ temperature (C), & pressure (bar)
FUNCTION rho(salt, temp, pbar)

  ! Compute in situ density from salinity (psu), in situ temperature (C), & pressure (bar)

#if USE_PRECISION == 2
#   define SGLE(x)    (x)
#else
#   define SGLE(x)    REAL(x)
#endif

  USE msingledouble
  IMPLICIT NONE

  !> salinity [psu]
  REAL(kind=rx) :: salt
  !> in situ temperature (C)
  REAL(kind=rx) :: temp
  !> pressure (bar) [Note units: this is NOT in decibars]
  REAL(kind=rx) :: pbar

  REAL(kind=r8) :: s, t, p
! REAL(kind=r8) :: t68
  REAL(kind=r8) :: X
  REAL(kind=r8) :: rhow, rho0
  REAL(kind=r8) :: a, b, c
  REAL(kind=r8) :: Ksbmw, Ksbm0, Ksbm
  REAL(kind=r8) :: drho

  REAL(kind=rx) :: rho

  !     Input arguments:
  !     -------------------------------------
  !     s  = salinity            [psu      (PSS-78) ]
  !     t  = in situ temperature [degree C (IPTS-68)]
  !     p  = pressure            [bar] !!!!  (not in [db]

  s = DBLE(salt)
  t = DBLE(temp)
  p = DBLE(pbar)

! Convert the temperature on today's "ITS 90" scale to older IPTS 68 scale
! (see Dickson et al., Best Practices Guide, 2007, Chap. 5, p. 7, including footnote)
! According to Best-Practices guide, line above should be commented & 2 lines below should be uncommented
! Guide's answer of rho (s=35, t=25, p=0) = 1023.343 is for temperature given on ITPS-68 scale
! t68 = (T - 0.0002) / 0.99975
! X = t68
! Finally, don't do the ITS-90 to IPTS-68 conversion (T input var now already on IPTS-68 scale)
  X = T

! Density of pure water
  rhow = 999.842594d0 + 6.793952e-2_r8*X          &
       -9.095290e-3_r8*X*X + 1.001685e-4_r8*X**3  &
       -1.120083e-6_r8*X**4 + 6.536332e-9_r8*X**5

! Density of seawater at 1 atm, P=0
  A = 8.24493e-1_r8 - 4.0899e-3_r8*X                         &
       + 7.6438e-5_r8*X*X - 8.2467e-7_r8*X**3 + 5.3875e-9_r8*X**4
  B = -5.72466e-3_r8 + 1.0227e-4_r8*X - 1.6546e-6_r8*X*X
  C = 4.8314e-4_r8

  rho0 = rhow + A*S + B*S*SQRT(S) + C*S**2.0d0

! Secant bulk modulus of pure water
! The secant bulk modulus is the average change in pressure
! divided by the total change in volume per unit of initial volume.
  Ksbmw = 19652.21d0 + 148.4206d0*X - 2.327105d0*X*X &
       + 1.360477e-2_r8*X**3 - 5.155288e-5_r8*X**4

! Secant bulk modulus of seawater at 1 atm
  Ksbm0 = Ksbmw + S*( 54.6746d0 - 0.603459d0*X + 1.09987e-2_r8*X**2 &
       - 6.1670e-5_r8*X**3) &
       + S*SQRT(S)*( 7.944e-2_r8 + 1.6483e-2_r8*X - 5.3009e-4_r8*X**2)

! Secant bulk modulus of seawater at S,T,P
  Ksbm = Ksbm0 &
       + P*(3.239908d0 + 1.43713e-3_r8*X + 1.16092e-4_r8*X**2 - 5.77905e-7_r8*X**3) &
       + P*S*(2.2838e-3_r8 - 1.0981e-5_r8*X - 1.6078e-6_r8*X**2) &
       + P*S*SQRT(S)*1.91075e-4_r8 &
       + P*P*(8.50935e-5_r8 - 6.12293e-6_r8*X + 5.2787e-8_r8*X**2) &
       + P*P*S*(-9.9348e-7_r8 + 2.0816e-8_r8*X + 9.1697e-10_r8*X**2)

! Density of seawater at S,T,P
  drho = rho0/(1.0d0 - P/Ksbm)
  rho = SGLE(drho)

  RETURN
END FUNCTION rho

!> Function to compute in situ density from salinity (psu), in situ temperature (C), & pressure (bar)
!! and its derivatives with respect to salinity and temperature.
FUNCTION rho_DNAD(salt, temp, pbar)

  ! Compute in situ density from salinity (psu), in situ temperature (C), & pressure (bar)
  !
  ! It is similar to subroutine 'rho' above except that it computes
  ! partial derivatives of in situ density
  ! with respect to salinity and temperature.

  USE msingledouble
  USE Dual_Num_Auto_Diff
  IMPLICIT NONE

  !> salinity [psu]
  TYPE (DUAL_NUM) :: salt
  !> in situ temperature (C)
  TYPE (DUAL_NUM) :: temp
  !> pressure (bar) [Note units: this is NOT in decibars]
  TYPE (DUAL_NUM) :: pbar

  TYPE (DUAL_NUM) :: s, p
! REAL(kind=r8) :: t68
  TYPE (DUAL_NUM) :: X
  TYPE (DUAL_NUM) :: rhow, rho0
  TYPE (DUAL_NUM) :: a, b, c
  TYPE (DUAL_NUM) :: Ksbmw, Ksbm0, Ksbm

  TYPE (DUAL_NUM) :: rho_DNAD

  !     Input arguments:
  !     -------------------------------------
  !     s  = salinity            [psu      (PSS-78) ]
  !     t  = in situ temperature [degree C (IPTS-68)]
  !     p  = pressure            [bar] !!!!  (not in [db]

  s = salt
  p = pbar

! Convert the temperature on today's "ITS 90" scale to older IPTS 68 scale
! (see Dickson et al., Best Practices Guide, 2007, Chap. 5, p. 7, including footnote)
! According to Best-Practices guide, line above should be commented & 2 lines below should be uncommented
! Guide's answer of rho (s=35, t=25, p=0) = 1023.343 is for temperature given on ITPS-68 scale
! t68 = (T - 0.0002) / 0.99975
! X = t68
! Finally, don't do the ITS-90 to IPTS-68 conversion (T input var now already on IPTS-68 scale)
  X = temp

! Density of pure water
  rhow = 999.842594d0 + 6.793952e-2_r8*X          &
       -9.095290e-3_r8*X*X + 1.001685e-4_r8*X**3  &
       -1.120083e-6_r8*X**4 + 6.536332e-9_r8*X**5

! Density of seawater at 1 atm, P=0
  A = 8.24493e-1_r8 - 4.0899e-3_r8*X                         &
       + 7.6438e-5_r8*X*X - 8.2467e-7_r8*X**3 + 5.3875e-9_r8*X**4
  B = -5.72466e-3_r8 + 1.0227e-4_r8*X - 1.6546e-6_r8*X*X
  C = 4.8314e-4_r8

  rho0 = rhow + A*S + B*S*SQRT(S) + C*S**2.0d0

! Secant bulk modulus of pure water
! The secant bulk modulus is the average change in pressure
! divided by the total change in volume per unit of initial volume.
  Ksbmw = 19652.21d0 + 148.4206d0*X - 2.327105d0*X*X &
       + 1.360477e-2_r8*X**3 - 5.155288e-5_r8*X**4

! Secant bulk modulus of seawater at 1 atm
  Ksbm0 = Ksbmw + S*( 54.6746d0 - 0.603459d0*X + 1.09987e-2_r8*X**2 &
       - 6.1670e-5_r8*X**3) &
       + S*SQRT(S)*( 7.944e-2_r8 + 1.6483e-2_r8*X - 5.3009e-4_r8*X**2)

! Secant bulk modulus of seawater at S,T,P
  Ksbm = Ksbm0 &
       + P*(3.239908d0 + 1.43713e-3_r8*X + 1.16092e-4_r8*X**2 - 5.77905e-7_r8*X**3) &
       + P*S*(2.2838e-3_r8 - 1.0981e-5_r8*X - 1.6078e-6_r8*X**2) &
       + P*S*SQRT(S)*1.91075e-4_r8 &
       + P*P*(8.50935e-5_r8 - 6.12293e-6_r8*X + 5.2787e-8_r8*X**2) &
       + P*P*S*(-9.9348e-7_r8 + 2.0816e-8_r8*X + 9.1697e-10_r8*X**2)

! Density of seawater at S,T,P
  rho_DNAD = rho0/(1.0d0 - P/Ksbm)

  RETURN
END FUNCTION rho_DNAD
END MODULE mrho


SUBROUTINE p54(input_file,output_file)
!-------------------------------------------------------------------------
! Program 5.4 General two- (plane strain) or three-dimensional analysis
!             of elastic solids (optional gravity loading).
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=70),INTENT(IN) :: input_file
 CHARACTER(len=70),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,k,loaded_nodes,ndim,ndof,nels,neq,nip,nlen,&
   nn,nod,nodof,nprops=3,np_types,nr,nst
 REAL(iwp)::det,penalty=1.0e20_iwp,zero=0.0_iwp
 CHARACTER(len=15)::argv,element
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   no(:),node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::bee(:,:),coord(:,:),dee(:,:),der(:,:),deriv(:,:), &
   eld(:),fun(:),gc(:),gravlo(:),g_coord(:,:),jac(:,:),km(:,:),kv(:),     &
   loads(:),points(:,:),prop(:,:),sigma(:),value(:),weights(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)element,nod,nels,nn,nip,nodof,nst,ndim,np_types
 ndof=nod*nodof
 ALLOCATE(nf(nodof,nn),points(nip,ndim),dee(nst,nst),g_coord(ndim,nn),    &
   coord(nod,ndim),jac(ndim,ndim),weights(nip),num(nod),g_num(nod,nels),  &
   der(ndim,nod),deriv(ndim,nod),bee(nst,ndof),km(ndof,ndof),eld(ndof),   &
   sigma(nst),g(ndof),g_g(ndof,nels),gc(ndim),fun(nod),etype(nels),       &
   prop(nprops,np_types))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)g_coord
 READ(10,*)g_num
 IF(ndim==2)CALL mesh(g_coord,g_num,argv,nlen,12)
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq),gravlo(0:neq))
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   num=g_num(:,iel)
   CALL num_to_g(num,nf,g)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------element stiffness integration and assembly--------
 CALL sample(element,points,weights)
 kv=zero
 gravlo=zero
 elements_2: DO  iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   eld=zero
   int_pts_1: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(transpose(bee),dee),bee)*det*weights(i)
     eld(nodof:ndof:nodof)=eld(nodof:ndof:nodof)+fun(:)*det*weights(i)
   END DO int_pts_1
   CALL fsparv(kv,km,g,kdiag)
   gravlo(g)=gravlo(g)-eld*prop(3,etype(iel))
 END DO elements_2
 loads=zero
 READ(10,*)loaded_nodes,(k,loads(nf(:,k)),i=1,loaded_nodes)
 loads=loads+gravlo
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),sense(fixed_freedoms),                   &
     value(fixed_freedoms),no(fixed_freedoms))
   READ(10,*)(node(i),sense(i),value(i),i=1,fixed_freedoms)
   DO  i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   kv(kdiag(no))=kv(kdiag(no))+penalty
   loads(no)=kv(kdiag(no))*value
 END IF
!-----------------------equation solution---------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
 loads(0)=zero
 IF(ndim==3)THEN
   WRITE(11,'(/A)')"  Node   x-disp      y-disp      z-disp"
 ELSE
   WRITE(11,'(/A)')"  Node   x-disp      y-disp"
 END IF
 DO k=1,nn
   WRITE(11,'(I5,3E12.4)')k,loads(nf(:,k))
 END DO
!-----------------------recover stresses at element Gauss-points----------
!nip=1
!DEALLOCATE(points,weights)
!ALLOCATE(points(nip,ndim),weights(nip))
!CALL sample(element,points,weights)
 WRITE(11,'(/A,I2,A)')" The integration point (nip=",nip,") stresses are:"
 IF(ndim==3)THEN
   WRITE(11,'(A,/,A)')"    Element     x-coord     y-coord     z-coord",  &
   "    sig_x       sig_y       sig_z       tau_xy      tau_yz      tau_zx"
 ELSE
   WRITE(11,'(A,A)')  "    Element x-coord     y-coord",              &
   "          sig_x       sig_y       tau_xy"
 END IF
 elements_3: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   eld=loads(g)
   int_pts_2: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     gc=MATMUL(fun,coord)
     jac=MATMUL(der,coord)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     sigma=MATMUL(dee,MATMUL(bee,eld))
     IF(ndim==3)THEN
       WRITE(11,'(I8,4X,3E12.4)')iel,gc
       WRITE(11,'(6E12.4)')sigma
     ELSE
       WRITE(11,'(I8,2E12.4,5X,3E12.4)')iel,gc,sigma
     END IF
   END DO int_pts_2
 END DO elements_3
 IF(ndim==2)THEN
   CALL dismsh(loads,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
   CALL vecmsh(loads,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)
 END IF

END SUBROUTINE p54


C      TMWN JULY 94
C      Savitsky Golay smoothing subroutines.
C      Taken from "Numerical Recipes" by Flannery and Press.
C      Stored here in a separate file to assist debugging.

      SUBROUTINE savgol(c,np,nl,nr,ld,m)
C     Savitsky Golay smoothing.
C     Taken from Numerical Recipes, Flannery and Press.
C     Calculates coefficients for linear smoothing,
C     such that higher moments are preserved.
C     Re. correlation function analysis, smoothing used
C     to ease the join between calc. and expt. data.
      INTEGER ld,m,nl,np,nr,mmax
      REAL c(np)
      PARAMETER (mmax=6)
      INTEGER imj,ipj,j,k,kk,mm,indx(mmax+1)
      REAL d,fac,sum,a(mmax+1,mmax+1),b(mmax+1)

      IF (np.LT.nl+nr+1.OR.nl.LT.0.OR.nr.LT.0.OR.ld.GT.m.OR.m.GT.mmax
     +.OR.nl+nr.LT.m) PAUSE 'Bad arguments passed to subroutine savgol'

      DO ipj=0,2*m
        sum=0.
        IF (ipj .EQ. 0) sum=1.

        DO k=1,nr
          sum=sum+FLOAT(k)**ipj
        END DO

        DO k=1,nl
          sum=sum+FLOAT(-k)**ipj
        END DO

        mm=MIN(ipj,2*m-ipj)
        DO imj=-mm,mm,2
          a(1+(ipj+imj)/2,1+(ipj-imj)/2)=sum
        END DO
      END DO

      CALL ludcmp(a,m+1,mmax+1,indx,d)

      DO j=1,m+1
        b(j)=0.
      END DO
      b(ld+1)=1

      CALL lubksb(a,m+1,mmax+1,indx,b)

      DO kk=1,np
        c(kk)=0.
      END DO

      DO k=-nl,nr
        sum=b(1)
        fac=1.
        DO mm=1,m
          fac=fac*k
          sum=sum+b(mm+1)*fac
        END DO
        kk=MOD(np-k,np)+1
        c(kk)=sum
      END DO

      RETURN
      END

      SUBROUTINE ludcmp(a,n,np,indx,d)
C     LU decomposition.
C     Taken from Numerical Recipes, Flannery and Press.
C     Used by subroutine savgol.
      INTEGER n,np,indx(n),nmax
      REAL d,a(np,np),tiny
      PARAMETER (nmax=500,tiny=1.E-8)
      INTEGER i,imax,j,k
      REAL aamax,dum,sum,vv(nmax)

      d=1.
      DO i=1,n
        aamax=0.
        DO j=1,n
          IF (ABS(a(i,j)) .GT. aamax) aamax=ABS(a(i,j))
        END DO
        IF (aamax .EQ. 0.) PAUSE 'Singular matrix in subroutine ludcmp'
        vv(i)=1./aamax
      END DO

      DO j=1,n
        DO i=1,j-1
          sum=a(i,j)
          DO k=1,i-1
            sum=sum-a(i,k)*a(k,j)
          END DO
          a(i,j)=sum
        END DO
        aamax=0.
        DO i=j,n
          sum=a(i,j)
          DO k=1,j-1
            sum=sum-a(i,k)*a(k,j)
          END DO
          a(i,j)=sum
          dum=vv(i)*ABS(sum)
          IF (dum .GE. aamax) THEN
            imax=i
            aamax=dum
          ENDIF
        END DO
        IF (j .NE. imax) THEN
          DO k=1,n
            dum=a(imax,k)
            a(imax,k)=a(j,k)
            a(j,k)=dum
          END DO
          d=-d
          vv(imax)=vv(j)
        ENDIF
        indx(j)=imax
        IF (a(j,j) .EQ. 0.) a(j,j)=tiny
        IF (j .NE. n) THEN
          dum=1./a(j,j)
          DO i=j+1,n
            a(i,j)=a(i,j)*dum
          END DO
        ENDIF
      END DO

      RETURN
      END

      SUBROUTINE lubksb(a,n,np,indx,b)
C     Subroutine associated with LU decomposition.
C     Taken from "Numerical Recipes" Flannery and Press.
C     Used in Savitsky Golay smoothing.
      INTEGER n,np,indx(n)
      REAL a(np,np),b(n)
      INTEGER i,ii,j,ll
      REAL sum
      ii=0
      DO i=1,n
        ll=indx(i)
        sum=b(ll)
        b(ll)=b(i)
        IF (ii .NE. 0) THEN
          DO j=ii,i-1
            sum=sum-a(i,j)*b(j)
          END DO
        ELSEIF (sum .NE. 0.) THEN
          ii=i
        ENDIF
        b(i)=sum
      END DO
      DO i=n,1,-1
        sum=b(i)
        DO j=i+1,n
          sum=sum-a(i,j)*b(j)
        END DO
        b(i)=sum/a(i,i)
      END DO

      RETURN
      END