module blas_d2
  use blas_kinds, only : ik, dp
  implicit none
  private :: ik, dp

  interface
    subroutine dgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: trans
      integer(ik) :: m
      integer(ik) :: n
      integer(ik) :: kl
      integer(ik) :: ku
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: beta
      real(dp) :: y(*)
      integer(ik) :: incy
    end subroutine dgbmv
  end interface
  interface
    subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: trans
      integer(ik) :: m
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: beta
      real(dp) :: y(*)
      integer(ik) :: incy
    end subroutine dgemv
  end interface
  interface
    subroutine dger(m, n, alpha, x, incx, y, incy, a, lda)
      import :: ik, dp
      integer(ik) :: lda
      integer(ik) :: m
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: y(*)
      integer(ik) :: incy
      real(dp) :: a(lda, *)
    end subroutine dger
  end interface
  interface
    subroutine dsbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      integer(ik) :: k
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: beta
      real(dp) :: y(*)
      integer(ik) :: incy
    end subroutine dsbmv
  end interface
  interface
    subroutine dspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
      import :: ik, dp
      character(len=1) :: uplo
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: ap(*)
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: beta
      real(dp) :: y(*)
      integer(ik) :: incy
    end subroutine dspmv
  end interface
  interface
    subroutine dspr2(uplo, n, alpha, x, incx, y, incy, ap)
      import :: ik, dp
      character(len=1) :: uplo
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: y(*)
      integer(ik) :: incy
      real(dp) :: ap(*)
    end subroutine dspr2
  end interface
  interface
    subroutine dspr(uplo, n, alpha, x, incx, ap)
      import :: ik, dp
      character(len=1) :: uplo
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: ap(*)
    end subroutine dspr
  end interface
  interface
    subroutine dsymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: beta
      real(dp) :: y(*)
      integer(ik) :: incy
    end subroutine dsymv
  end interface
  interface
    subroutine dsyr2(uplo, n, alpha, x, incx, y, incy, a, lda)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: y(*)
      integer(ik) :: incy
      real(dp) :: a(lda, *)
    end subroutine dsyr2
  end interface
  interface
    subroutine dsyr(uplo, n, alpha, x, incx, a, lda)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: a(lda, *)
    end subroutine dsyr
  end interface
  interface
    subroutine dtbmv(uplo, trans, diag, n, k, a, lda, x, incx)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      integer(ik) :: k
      real(dp) :: a(lda, *)
      real(dp) :: x(*)
      integer(ik) :: incx
    end subroutine dtbmv
  end interface
  interface
    subroutine dtbsv(uplo, trans, diag, n, k, a, lda, x, incx)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      integer(ik) :: k
      real(dp) :: a(lda, *)
      real(dp) :: x(*)
      integer(ik) :: incx
    end subroutine dtbsv
  end interface
  interface
    subroutine dtpmv(uplo, trans, diag, n, ap, x, incx)
      import :: ik, dp
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      real(dp) :: ap(*)
      real(dp) :: x(*)
      integer(ik) :: incx
    end subroutine dtpmv
  end interface
  interface
    subroutine dtpsv(uplo, trans, diag, n, ap, x, incx)
      import :: ik, dp
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      real(dp) :: ap(*)
      real(dp) :: x(*)
      integer(ik) :: incx
    end subroutine dtpsv
  end interface
  interface
    subroutine dtrmv(uplo, trans, diag, n, a, lda, x, incx)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      real(dp) :: a(lda, *)
      real(dp) :: x(*)
      integer(ik) :: incx
    end subroutine dtrmv
  end interface
  interface
    subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, dp
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: side
      character(len=1) :: uplo
      character(len=1) :: transa
      character(len=1) :: diag
      integer(ik) :: m
      integer(ik) :: n
      real(dp) :: alpha
      real(dp) :: a(lda, *)
      real(dp) :: b(ldb, *)
    end subroutine dtrsm
  end interface
  interface
    subroutine dtrsv(uplo, trans, diag, n, a, lda, x, incx)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      real(dp) :: a(lda, *)
      real(dp) :: x(*)
      integer(ik) :: incx
    end subroutine dtrsv
  end interface
end module blas_d2


! examples/Fortran/ssmfe/shift_invert.f90
! Laplacian on a rectangular grid by shift-invert via LDLT factorization
program ssmfe_shift_invert_example
  use spral_ssmfe
  use laplace2d ! implement Lapalacian and preconditioners
  use ldltf     ! implements LDLT support routines
  implicit none

  integer, parameter :: wp = kind(0d0) ! Working precision

  integer, parameter :: nx = 8    ! grid points along x
  integer, parameter :: ny = 8    ! grid points along y
  integer, parameter :: n = nx*ny ! problem size
  real(wp), parameter :: sigma = 1.0 ! shift

  integer :: ipiv(n)               ! LDLT pivot index
  real(wp) :: lambda(n)            ! eigenvalues
  real(wp) :: X(n, n)              ! eigenvectors
  real(wp) :: A(n, n)              ! matrix
  real(wp) :: LDLT(n, n)           ! factors
  real(wp) :: work(n*n)            ! work array for dsytrf
  integer :: lwork = n*n           ! size of work
  integer :: left, right           ! wanted eigenvalues left and right of sigma
  integer :: i                     ! index
  type(ssmfe_options) :: options   ! eigensolver options
  type(ssmfe_inform ) :: inform    ! information
  type(ssmfe_rcid   ) :: rci       ! reverse communication data
  type(ssmfe_keepd  ) :: keep      ! private data

  call set_laplacian_matrix( nx, ny, A, n )

  ! perform LDLT factorization of the shifted matrix
  LDLT = A
  forall ( i = 1 : n ) LDLT(i, i) = A(i, i) - sigma
  lwork = n*n
  call dsytrf( 'L', n, LDLT, n, ipiv, work, lwork, i )

  left = num_neg_D(n, LDLT, n, ipiv) ! all eigenvalues to the left from sigma
  right = 5                          !   5 eigenvalues to the right from sigma
  rci%job = 0
  do
    call ssmfe_standard_shift &
      ( rci, sigma, left, right, n, lambda, n, X, n, keep, options, inform )
    select case ( rci%job )
    case ( 1 )
      call dgemm &
        ( 'N', 'N', n, rci%nx, n, 1.0_wp, A, n, rci%x, n, 0.0_wp, rci%y, n )
    case ( 9 )
      call dcopy( n * rci%nx, rci%x, 1, rci%y, 1 )
      call dsytrs( 'L', n, rci%nx, LDLT, n, ipiv, rci%y, n, i )
    case ( :-1 )
      exit
    end select
  end do
  print '(1x, a, es10.2, 1x, a, i3, 1x, a)', 'Eigenvalues near', sigma, &
     '(took', inform%iteration, 'iterations)'
  print '(1x, a, i2, a, es13.7)', &
    ('lambda(', i, ') = ', lambda(i), i = 1, inform%left + inform%right)
  call ssmfe_free( keep, inform )
end program ssmfe_shift_invert_example


program ex20

    use utils

    implicit none

    real(rk), allocatable :: A(:,:)
    real(rk), allocatable :: B(:,:)
    integer :: i, j

    allocate(A(20,20), B(20,20))

    call initRand()
    call randMat(A, 0.0_rk, 1.0_rk)
    call randMat(B, 0.0_rk, 1.0_rk)

    do i=1,20
        A(i,i) = 2.0_rk * B(i,i)
    end do

    forall(i=1:20) A(i,i) = 2.0_rk * B(i,i)

    forall(i=1:20, j=1:20) A(i,j) = i + j

    forall(i=1:20, j=1:20, A(i,j)/=0.0_rk)
        B(i,j) = 1.0/A(i,j)
    end forall

    deallocate(A, B)

end program ex20


! Extend operators for a user-defined vector type. Create new operator .DOT. to
! calculate dot product. Set module to PRIVATE, and set specific elements of
! module to PUBLIC.
MODULE vector_operators
IMPLICIT NONE
PRIVATE
PUBLIC :: vector, ASSIGNMENT(=), OPERATOR(+), OPERATOR(-), OPERATOR(*), &
          OPERATOR(/), OPERATOR(.DOT.), signal_me
TYPE :: vector
  !PRIVATE
  REAL :: x
  REAL :: y
  REAL :: z
END TYPE vector
CHARACTER(LEN=20), PUBLIC :: hello = "HELLO WORLD"
INTEGER, PUBLIC, PROTECTED :: signal = 29

INTERFACE OPERATOR(+)
  MODULE PROCEDURE add_vectors
  MODULE PROCEDURE add_vector_and_scalar
END INTERFACE

INTERFACE OPERATOR(-)
  MODULE PROCEDURE sub_vectors
END INTERFACE

INTERFACE OPERATOR(*)
  MODULE PROCEDURE mult_by_scalar
END INTERFACE

INTERFACE OPERATOR(/)
  MODULE PROCEDURE div_by_scalar
END INTERFACE

INTERFACE OPERATOR(.DOT.)
  MODULE PROCEDURE dot_product
END INTERFACE

INTERFACE ASSIGNMENT(=)
  MODULE PROCEDURE array_to_vector
  MODULE PROCEDURE vector_to_array
END INTERFACE

CONTAINS
  INTEGER FUNCTION signal_me()
  IMPLICIT NONE
  signal = 33
  signal_me = signal
  END FUNCTION signal_me

  TYPE(vector) FUNCTION add_vectors(v1, v2)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v1, v2
  add_vectors = vector(v1%x + v2%x, v1%y + v2%y, v1%z + v2%z)
  END FUNCTION add_vectors

  TYPE(vector) FUNCTION sub_vectors(v1, v2)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v1, v2
  sub_vectors = vector(v1%x - v2%x, v1%y - v2%y, v1%z - v2%z)
  END FUNCTION sub_vectors

  TYPE(vector) FUNCTION mult_by_scalar(v, s)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v
  REAL, INTENT(IN) :: s
  mult_by_scalar = vector(v%x * s, v%y * s, v%z * s)
  END FUNCTION mult_by_scalar

  TYPE(vector) FUNCTION div_by_scalar(v, s)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v
  REAL, INTENT(IN) :: s
  div_by_scalar = vector(v%x / s, v%y / s, v%z / s)
  END FUNCTION div_by_scalar

  REAL FUNCTION dot_product(v1, v2)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v1, v2
  dot_product = v1%x * v2%x + v1%y * v2%y + v1%z * v2%z
  END FUNCTION dot_product

  SUBROUTINE vector_to_array(vec, arr)
  IMPLICIT NONE
  REAL, DIMENSION(3), INTENT(IN) :: arr
  TYPE(vector), INTENT(OUT) :: vec
  vec = vector(arr(1), arr(2), arr(3))
  END SUBROUTINE vector_to_array

  SUBROUTINE array_to_vector(arr, vec)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: vec
  REAL, DIMENSION(3), INTENT(OUT) :: arr
  arr(1) = vec%x
  arr(2) = vec%y
  arr(3) = vec%z
  END SUBROUTINE array_to_vector

  TYPE(vector) FUNCTION add_vector_and_scalar(v, s)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v
  REAL, INTENT(IN) :: s
  add_vector_and_scalar = vector(v%x + s, v%y + s, v%z + s)
  END FUNCTION add_vector_and_scalar

END MODULE vector_operators

PROGRAM test_vector_operators
USE vector_operators
IMPLICIT NONE
TYPE(vector) :: u, v
REAL :: s
REAL, DIMENSION(3) :: a

a = [7., 8., 9.]
s = 2
!greet = hello
!u = vector(1., 2., 3.)
!v = vector(4., 5., 4.)
u = [1., 2., 3.]
v = [4., 5., 4.]
WRITE(*, *) u + v
WRITE(*, *) u * s
WRITE(*, *) v / 3.
WRITE(*, *) u .DOT. v
v = a
WRITE(*, *) v
a = u
WRITE(*, *) a
!signal = 55
WRITE(*, *) signal_me()
END PROGRAM test_vector_operators


      subroutine setprob()
      implicit none

      double precision pi, pi2
      common /compi/ pi, pi2

      pi = 4.d0*atan(1.d0)
      pi2 = 2.0*pi

      end


MODULE interfaces

INTERFACE
   FUNCTION arth(first,increment,n)
      use def_kind
      integer(kind=i_single),intent(in)  :: first,increment,n
      integer(kind=i_single),dimension(n):: arth
   END FUNCTION arth
END INTERFACE

INTERFACE
   FUNCTION convlv(data,respns)
      use def_kind
      implicit none
      real(kind=r_single),dimension(:),intent(inout):: data
      real(kind=r_single),dimension(:),intent(in)   :: respns
      real(kind=r_single),dimension(size(data))     :: convlv
   END FUNCTION convlv
END INTERFACE

INTERFACE
   FUNCTION correl(data1,data2)
      use def_kind
      implicit none
      real(kind=r_single),dimension(:),intent(in) :: data1,data2
      real(kind=r_single),dimension(size(data1))  :: correl
   END FUNCTION correl
END INTERFACE

INTERFACE
   FUNCTION derive(fun,dt)
      use def_kind
      implicit none
      real(kind=r_single),dimension(:),intent(in):: fun
      real(kind=r_single),intent(in)             :: dt
      real(kind=r_single),dimension(size(fun)-1) :: derive
   END FUNCTION derive
END INTERFACE

INTERFACE four1d
   SUBROUTINE four1d(data,isign)
      use def_kind
      implicit none
      complex(kind=r_single),dimension(:),intent(inout):: data
      integer(kind=i_single),intent(in)                :: isign
   END SUBROUTINE four1d
END INTERFACE four1d

INTERFACE fourrow
   SUBROUTINE fourrow(data,isign)
      use def_kind
      implicit none
      complex(kind=r_single),dimension(:,:),intent(inout):: data
      integer(kind=i_single),intent(in)                  :: isign
   END SUBROUTINE fourrow
END INTERFACE fourrow

INTERFACE
   FUNCTION lag_correl(seq1,seq2)
      use def_kind
      implicit none
      real(kind=r_single),dimension(:),intent(in):: seq1,seq2
      real(kind=r_single)                        :: lag_correl
   END FUNCTION lag_correl
END INTERFACE

INTERFACE
   FUNCTION normal_pdf(a,b,seed)
      use def_kind; use constants
      implicit none
      real(kind=r_scat),intent(in)     :: a,b
      integer(kind=i_single),intent(in):: seed
      real(kind=r_scat)                :: normal_pdf
   END FUNCTION normal_pdf
END INTERFACE

INTERFACE
   FUNCTION peaker(fun,dt)
      use def_kind
      real(kind=r_single),dimension(:),intent(in):: fun
      real(kind=r_single),intent(in)             :: dt
      real(kind=r_single)                        :: peaker
   END FUNCTION peaker
END INTERFACE

INTERFACE polint
   SUBROUTINE polint(xa,ya,x,y)
      use def_kind
      implicit none
      real(kind=r_single),dimension(:),intent(in):: xa,ya
      real(kind=r_single),intent(in)             :: x
      real(kind=r_single),intent(out)            :: y
   END SUBROUTINE polint
END INTERFACE polint

INTERFACE poly_interp
   SUBROUTINE poly_interp(x1a,x2a,ya,x1,x2,y)
      use def_kind
      implicit none
      real(kind=r_single),dimension(:),intent(in)  :: x1a,x2a
      real(kind=r_single),dimension(:,:),intent(in):: ya
      real(kind=r_single),intent(in)               :: x1,x2
      real(kind=r_single),intent(out)              :: y
   END SUBROUTINE poly_interp
END INTERFACE poly_interp

INTERFACE
   FUNCTION rand_pdf(seed,val_min,val_max,pdf)
      use def_kind
      implicit none
      real(kind=r_scat)                :: rand_pdf
      integer(kind=i_single),intent(in):: seed
      character(len=*),intent(in)      :: pdf
      real(kind=r_scat),intent(in)     :: val_min,val_max
   END FUNCTION rand_pdf
END INTERFACE

INTERFACE realft
   SUBROUTINE realft(data,isign,zdata)
      use def_kind
      implicit none
      real(kind=r_single),dimension(:),intent(inout)     :: data
      integer(kind=i_single),intent(in)                  :: isign
      complex(kind=r_single),dimension(:),optional,target:: zdata
   END SUBROUTINE realft
END INTERFACE realft

INTERFACE spline_interp
   SUBROUTINE spline_interp(in_seis,time_len,interp_npts,orig_npts,out_seis)
      use def_kind
      implicit none
      integer(kind=i_single),intent(in)           :: interp_npts,orig_npts
      real(kind=r_single),intent(in)              :: time_len
      real(kind=r_single),dimension(:),intent(in) :: in_seis
      real(kind=r_single),dimension(:),intent(out):: out_seis
   END SUBROUTINE spline_interp
END INTERFACE spline_interp

INTERFACE swap
   SUBROUTINE swap(a,b)
      use def_kind
      complex(kind=r_single),dimension(:),intent(inout):: a,b
   END SUBROUTINE swap
END INTERFACE swap

INTERFACE
   FUNCTION trapz(fun,dt)
      use def_kind
      implicit none
      real(kind=r_single),dimension(:),intent(in):: fun
      real(kind=r_single),intent(in)             :: dt
      real(kind=r_single)                        :: trapz
   END FUNCTION trapz
END INTERFACE

INTERFACE
   FUNCTION uniform_pdf(a,b,seed)
      use def_kind
      implicit none
      real(kind=r_scat),intent(in)     :: a,b
      integer(kind=i_single),intent(in):: seed
      real(kind=r_scat)                :: uniform_pdf
   END FUNCTION uniform_pdf
END INTERFACE

INTERFACE write_disk
   SUBROUTINE write_disk(station,type_flag,in_arr)
      use def_kind; use flags; use scattering, only: npts
      use source_receiver, only: stat_name
      use stf_data, only: npts_stf,total
      use waveform, only: lf_len,lf_npts
      implicit none
      integer(kind=i_single),intent(in)            :: station
      real(kind=r_single),dimension(:,:),intent(in):: in_arr
      character(len=*),intent(in)                  :: type_flag
   END SUBROUTINE write_disk
END INTERFACE write_disk

INTERFACE write_disk_mpi
   SUBROUTINE write_disk_mpi(station,type_flag,in_arr)
      use def_kind; use flags; use scattering, only: npts
      use source_receiver, only: stat_name
      use stf_data, only: npts_stf,total
      use waveform, only: lf_len,lf_npts
      implicit none
      integer(kind=i_single),intent(in)            :: station
      real(kind=r_single),dimension(:,:),intent(in):: in_arr
      character(len=*),intent(in)                  :: type_flag
   END SUBROUTINE write_disk_mpi
END INTERFACE write_disk_mpi

INTERFACE
   FUNCTION zroots_unity(n,nn)
      use def_kind
      integer(kind=i_single),intent(in)   :: n,nn
      complex(kind=r_single),dimension(nn):: zroots_unity
   END FUNCTION zroots_unity
END INTERFACE

END MODULE interfaces


      PROGRAM MATMUL
      implicit none
      INTEGER  N, I, J, K
      PARAMETER (N=10)
      REAL*8 A(N,N), B(N,N), C(N,N)

!$OMP PARALLEL

C     Initialize A, B and C matrices
!$OMP DO
      DO 10 J=1, N
        DO 10 I=1, N
          A(I,J) = 2.0
          B(I,J) = 3.0
          C(I,J) = 0
  10  CONTINUE
!$OMP END DO

!$OMP MASTER
      PRINT *, '******************************************************'
      PRINT *, 'Matrices initialized'
      PRINT *, '******************************************************'
!$OMP END MASTER

C     Compute matrix-matrix product
!$OMP DO
      DO 20 J=1, N
        DO 20 I=1, N
          DO 20 K=1, N
            C(I,J) = C(I,J) + A(I,K) * B(K,J)
  20  CONTINUE
!$OMP END DO

C     Print result matrix
!$OMP MASTER
      PRINT *, '******************************************************'
      PRINT *, 'Result Matrix:'
      DO 50 I=1, N
        DO 40 J=1, N
          WRITE(*,30) C(I,J)
  30	  FORMAT(2x,f8.2,$)
  40      CONTINUE
          PRINT *, ' '
  50      CONTINUE
      PRINT *, '******************************************************'
      PRINT *, 'Done.'
!$OMP END MASTER
!$OMP END PARALLEL

      END


subroutine dfrad(df,f,r,nrad)
  ! Computes the radial derivative of function f(r)
  IMPLICIT NONE
  REAL*8, intent(out):: df(nrad)
  INTEGER, intent(in):: nrad
  REAL*8, intent(in) :: r(nrad), f(nrad)
  ! locals
  REAL*8 ::  C(nrad), D(nrad)
  call spline(nrad, r, f, df, C, D)
  return
end subroutine dfrad

REAL*8 FUNCTION int_radial(funct,RX,DELTA,nr)
  ! Integrates radial function by Simpson: int funct(rx)*drx
  ! Notice that rx is logarithmic mesh, hence int[func(r)] requires summation of func(r)*r
  IMPLICIT NONE
  INTEGER, intent(in):: nr
  REAL*8, intent(in) :: RX(nr), funct(nr), DELTA
  ! locals
  REAL*8 :: dsum
  INTEGER :: jstart, jfin, j
  dsum=0.0D0
  jstart = 2-MOD(nr,2)
  jfin = nr-2
  ! Integration by Simpson  Integrate[f(r) r dr]
  ! dsum = (1/3.*f_0*r0 + 4/3.*f1*r1 + 2/3.*f2*r2 + 4/3.*f3*r3+....+fn*rn)*dx
  DO j=jstart,jfin,2
     dsum = dsum + funct(j)*RX(j)+4.*funct(j+1)*RX(j+1)+funct(j+2)*RX(j+2)
  ENDDO
  dsum = dsum * DELTA/3.0D0
  dsum = dsum + (1-MOD(nr,2))*(funct(1)+funct(jstart))/2.0D0*(RX(jstart)-RX(1)) ! correction for even number of mesh points
  int_radial = dsum
  RETURN
end FUNCTION int_radial

SUBROUTINE SPLINE(N,X,Y,B,C,D)
  IMPLICIT NONE
  INTEGER, intent(in) :: N
  REAL*8, intent(in)  :: X(N), Y(N)
  REAL*8, intent(out) :: B(N), C(N), D(N)
  !---------------------------------------------------------
  !     CALCULATE COEFFICIENTS B(I),C(I),D(I),I=1,2,...,N
  !     FOR CUBIC INTERPOLATIONAL SPLINE:
  !     S(X) = Y(I) + B(I) * (X-X(I)) + C(I)*(X-X(I))**2 + D(I)*(X-X(I))**3
  !     FOR X(I).LE.X.LE.X(I+1),
  !     WHERE: N - NUMBER OF POINTS (N.GE.2),
  !     X - ABSCISES (IN STRICTLY INCREASING ORDER),
  !     Y - ORDINATES.
  !---------------------------------------------------------
  !
  INTEGER :: NM1, IB, I
  REAL*8  :: T
  !
  NM1=N-1
  IF(N .LT. 2) RETURN
  IF(N .LT. 3) GO TO 50
  !---------------------------------------------------------
  !     CONSTRUCT 3-DIAGONAL SYSTEM WITH B - DIAGONAL,
  !     D - OVERDIAGONAL, C - RIGHT SIDES
  !---------------------------------------------------------
  !
  D(1)=X(2)-X(1)
  C(2)=(Y(2)-Y(1))/D(1)
  DO I=2,NM1
     D(I)=X(I+1)-X(I)
     B(I)=2.d0*(D(I-1)+D(I))
     C(I+1)=(Y(I+1)-Y(I))/D(I)
     C(I)=C(I+1)-C(I)
  ENDDO
  !----------------------------------------------------------
  !     BOUNDARY CONDITIONS
  !----------------------------------------------------------
  !
  B(1)= -D(1)
  B(N)= -D(N-1)
  C(1)=0.D00
  C(N)=0.D00
  IF(N .EQ. 3) GO TO 15
  C(1)=C(3)/(X(4)-X(2))-C(2)/(X(3)-X(1))
  C(N)=C(N-1)/(X(N)-X(N-2))-C(N-2)/(X(N-1)-X(N-3))
  C(1)=C(1)*D(1)*D(1)/(X(4)-X(1))
  C(N)= -C(N)*D(N-1)*D(N-1)/(X(N)-X(N-3))
  !----------------------------------------------------------
  !     UPWARD STEP
  !----------------------------------------------------------
  !
15 CONTINUE
  DO I=2,N
     T=D(I-1)/B(I-1)
     B(I)=B(I)-T*D(I-1)
     C(I)=C(I)-T*C(I-1)
  ENDDO
  !----------------------------------------------------------
  !     BACKWARD SUBSTITUTION
  !----------------------------------------------------------
  !
  C(N)=C(N)/B(N)
  DO IB =1,NM1
     I=N-IB
     C(I)=(C(I)-D(I)*C(I+1))/B(I)
  ENDDO
  !----------------------------------------------------------
  !     CALCULATE COEFFICIENTS OF THE POLINOMIALS
  !----------------------------------------------------------
  !
  B(N)=(Y(N)-Y(NM1))/D(NM1)+D(NM1)*(C(NM1)+2.D00*C(N))
  DO I=1,NM1
     B(I)=(Y(I+1)-Y(I))/D(I)-D(I)*(C(I+1)+2.D00*C(I))
     D(I)=(C(I+1)-C(I))/D(I)
     C(I)=3.D00*C(I)
  ENDDO

  C(N)=3.D00*C(N)
  D(N)=D(N-1)
  RETURN
!
50 CONTINUE
  B(1)=(Y(2)-Y(1))/(X(2)-X(1))
  C(1)=0.D00
  D(1)=0.D00
  B(2)=B(1)
  C(2)=0.D00
  D(2)=0.D00
  !
  RETURN
END SUBROUTINE SPLINE


c     program DRDRANG
c>> 2001-05-22 DRDRANG  Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRDRANG  Krogh Added external statement.
c>> 1994-10-19 DRDRANG  Krogh  Changes to use M77CON
c>> 1987-12-09 DRDRANG  Lawson  Initial Code.
c--D replaces "?": DR?RANG, ?RANG, ?STAT1, ?STAT2
c     Demonstration driver for DRANG.  Generates random numbers
c     from the Gaussian distribution.
c     ------------------------------------------------------------------
      integer NCELLS
      parameter(NCELLS = 12+2)
      external DRANG
      double precision     DRANG, STATS(5), Y1, Y2, YTAB(1), ZERO
      integer  I, IHIST(NCELLS), N
c
      parameter(ZERO = 0.0D0)
      data       N / 10000/
      data  Y1, Y2 / -3.0D0, +3.0D0/
c     ------------------------------------------------------------------
      STATS(1) = ZERO
      do 20 I=1,N
c                          GET RANDOM NUMBER
         YTAB(1) = DRANG()
c
c                          Accumulate statistics and histogram.
c
        call DSTAT1(YTAB(1), 1, STATS, IHIST, NCELLS, Y1, Y2)
   20 continue
c                          Print the statistics and histogram.
c
      write(*,'(13x,a//)') 'Gaussian random numbers from DRANG'
      call DSTAT2(STATS, IHIST, NCELLS, Y1, Y2)
      stop
      end


program ns
    use, intrinsic :: iso_fortran_env, only : wp => real64
    use pyplot_module, only : pyplot

    implicit none

    type(pyplot) :: plt

    real(kind=8), parameter :: nx = 41 ! Number of grid points
    real(kind=8) :: dx, nt, dt, c, i, n, j, nu, sigma
    real(kind=8), dimension(nx) :: u, un, grid !
    integer :: istat
    character :: input

    !nx is declared and assigned above
    dx = 2 / (nx-1) ! Distance between points
    nt = 20         ! Number of timesteps
    nu = 0.3        ! Viscosity
    sigma = 0.2
    dt = sigma * dx**2 / nu

    ! Initialize u to match our initial condition of
    ! u = 2 in the following range: 0.5 > x > 1
    ! and 1 everywhere else
    do i=1, nx
        u(i) = 1
        if (i .ge. (.5 / dx) .and. i .le. (1 / dx + 1)) then
            u(i) = 2
        end if
    end do

    ! Use this array to represent the gridpoints for plotting
    do i=1, nx
        grid(i) = i
    end do

    ! Copy values from u to un
    do i=1, nx
        un(i) = u(i)
    end do

    ! Solve convection
    do n=1, nt
        do j =1, nx
            un(j)=u(j)
        end do

        do i=2, nx-1
            u(i) = un(i) + nu * dt / dx**2 * (un(i+1) - 2 * un(i) + un(i-1))
        end do
    end do

    ! Print the values contained in u
    do i=1, nx
        print*, u(i)
    end do

    print*, "plotting"
    call plt%initialize(grid=.true.,xlabel='timestep',&
                        title='Plot of u over time',legend=.true.)
    call plt%add_plot(grid,u,label='value of u',linestyle='b-o',markersize=3,linewidth=1,istat=istat)
    call plt%savefig('plot.png', pyfile='plot.py', dpi='320', istat=istat)

    read*, input
end program ns


subroutine downhill (n, func, xstart, fstart, stepi, epsf, itmin, iter)
!
!    n dimension of the problem
!    func function
!    xstart starting values
!    fstart conrespoding function value
!    stepi relative stepsize for initial simplex
!    epsf esilon for termination
!    itmin termination istested if itmin < it
!    iter maximum number of iterations
!

    use numtype
    implicit none
    integer :: n, iter , itmin
    real (dp), external :: func
    real (dp) :: xstart (1:n), fstart , stepi , epsf
    real (dp), parameter :: alph =1._dp , gamm =2._dp , &
                            rho =0.5_dp , sig =0.5_dp
    real (dp) :: xi (1:n ,1:n+1) , x(1:n ,1:n+1) , &
                 fi (1: n+1) , f(1: n+1) , &
                 x0 (1: n), xr (1: n), xe (1: n), xc (1: n), &
                 fxr , fxe , fxc , deltaf
    integer :: i, j, ii , it

    xi (1:n ,1) = xstart (1:n); fi (1) = fstart
    do i = 2, n+1
        xi (1:n,i)= xi (1:n ,1) !can be done with append
        xi(i -1,i)= xi(i -1,i )*(1+ stepi ) !complete the actions seperatly
        fi(i)= func (xi (1:n,i))
    end do

    do it = 1, iter

        do i = 1, n+1 ! ordering
            ii = minloc(fi (1:n+1) ,dim=1)
            x(1:n,i) = xi (1:n,ii ); f(i) = fi(ii)
            fi(ii) = huge(0._dp)
        end do !order the parameters from best to worst, and ss
        xi (1:n ,1: n+1) = x(1:n ,1: n+1)
        fi (1: n+1) = f(1: n+1)

        x0 (1: n) = sum(x(1:n ,1:n),dim=2)/ n ! central

        if ( itmin < it ) then ! exit
            deltaf = (f(n)-f (1))
            write (7 ,*) it , deltaf
            if ( deltaf < epsf ) exit
        end if

        xr (1: n) = x0 (1: n)+ alph *( x0 (1: n)-x(1:n,n +1))
        fxr = func (xr)
        if ( fxr < f(n) .and. f(1) <= fxr ) then! reflection
            xi (1:n,n+1) = xr (1: n); fi(n+1) = fxr
            cycle

        else if ( fxr < f(1) ) then ! expansion
            xe (1: n) = x0 (1: n)+ gamm *( x0 (1: n)-x(1:n,n +1))
            fxe = func (xe)
            if ( fxe < fxr ) then
                xi (1:n,n+1) = xe (1: n); fi(n+1) = fxe
                cycle
            else
                xi (1:n,n+1) = xr (1: n); fi(n+1) = fxr
                cycle
            end if

        else if ( fxr >= f(n) ) then ! contraction
            xc (1: n) = x(1:n,n +1)+ rho *( x0 (1: n)-x(1:n,n +1))
            fxc = func (xc)
            if ( fxc <= f(n+1) ) then
                xi (1:n,n+1) = xc (1: n); fi(n+1) = fxc
                cycle
        end if

        else ! reduction
            do i = 2, n+1
                xi(1:n,i) = x(1:n ,1)+ sig *(x(1:n,i)-x(1:n ,1))
                fi(i) = func(xi)
            end do
            cycle

        end if

    end do

    xstart (1:n)= xi (1:n ,1); fstart = fi (1)

end subroutine downhill


Program Main

    use mfpGlobal
    use mfpSpecialFunction

Implicit None
    integer,parameter  :: nX = 5000
    Real(RP) :: xMin, xMax
    Real(RP),dimension(nX) :: X, Y
    integer  :: ii

    ! write(*,*) "Test Gamma Related Function"

    ! Call testGx()

    xMin = 0.1;
    xMax = 300.0;
    Call testBetaFunction(xMin, xMax, nX, X, Y)

    do ii = 1,nX
        write(*,*) ii, X(ii), Y(ii)
    Enddo

End Program

#include "gammaRelated/testXbeta2xm1.inc"


	subroutine alphasub(tau,n,alpha,depar)

	include 'PARAMETER'
        parameter (num=19)
	real*4 tau(*),alpha(*),depar(*),x(num),y(num),z(num)
        real xr(num)
	real xa(11),ya(11)

	data x/
     &    0.5235 ,   -0.0020 ,   -0.3570 ,   -0.6574 ,   -0.9519 ,
     &   -1.2627 ,   -1.5735 ,   -1.9115 ,   -2.2498 ,   -2.6212 ,
     &   -2.9927 ,   -3.4148 ,   -3.8368 ,   -4.1535 ,   -4.3514 ,
     &   -4.4831 ,   -4.5957 ,   -4.7022  ,  -8.0 /

	data y/
     &    1.00000e+00 ,    1.00000e+00 ,    9.89000e-01 ,    9.79185e-01 ,
     &    9.63803e-01 ,    9.34267e-01 ,    8.81333e-01 ,    8.11867e-01 ,
     &    7.05453e-01 ,    5.86343e-01 ,    4.67177e-01 ,    3.55368e-01 ,
     &    2.61316e-01 ,    1.87804e-01 ,    1.29386e-01 ,    8.72174e-02 ,
     &    5.19049e-02 ,    2.72269e-02 ,     0./

	data z/
     &    1.00000e+00 ,    1.01600e+00 ,    1.04200e+00 ,    1.04200e+00 ,
     &    1.02100e+00 ,    9.95000e-01 ,    9.60000e-01 ,    9.21000e-01 ,
     &    8.98000e-01 ,    8.98000e-01 ,    9.35000e-01 ,    1.10800e+00 ,
     &    1.60500e+00 ,    3.03500e+00 ,    6.90700e+00 ,    1.63790e+01 ,
     &    3.80500e+01 ,    9.21060e+01 ,    9.2106e1   /

	ngrado=1  !grado del polinomio interpolador

	n2=int(ngrado/2)

c        print*,'entro en alphasub'
        do i=1,num
	   xr(i)=x(i)
        end do

	do i=1,n
           stau=tau(i)
	   call locate(xr,num,stau,j)
	   n3=j-n2-1
           if(n3.lt.0)n3=0
           if(n3+ngrado+1.gt.num)n3=num-ngrado-1
	   do k=1,ngrado+1
	      xa(k)=x(n3+k)
	   end do
	   do k=1,ngrado+1
	      ya(k)=y(n3+k)
	   end do
	   call polint(xa,ya,ngrado+1,stau,sa,error)
           alpha(i)=dble(sa)

	   do k=1,ngrado+1
	      ya(k)=z(n3+k)
	   end do
	   call polint(xa,ya,ngrado+1,stau,da,error)
           depar(i)=dble(da)
c         print*,tau(i),alpha(i),depar(i)
	end do

c         print*,'salgo de alphasub'

	return
	end


      subroutine polcoe(x,y,n,cof)
c
c ************************************************
c *  njtj                                        *
c *  Returns the coefficients of a polynominal.  *
c *  Taken from numerical recipes, page 93.      *
c *  njtj                                        *
c ************************************************
c
c  njtj
c  ###  Cray conversions
c  ###    1)Comment out implicit double precision.
c  ###    2)Switch double precision parameter
c  ###      to single precision parameter statement.
c  ###  Cray conversions
c  njtj
c
      implicit double precision (a-h,o-z)
c
      parameter (nmax=10,zero=0.D0,one=1.D0)
Cray      parameter (nmax=10,zero=0.0,one=1.0)
c
      dimension x(n),y(n),cof(n),s(nmax)
      do 11 i=1,n
        s(i)=zero
        cof(i)=zero
11    continue
      s(n)=-x(1)
      do 13 i=2,n
        do 12 j=n+1-i,n-1
          s(j)=s(j)-x(i)*s(j+1)
12      continue
        s(n)=s(n)-x(i)
13    continue
      do 16 j=1,n
        phi=n
        do 14 k=n-1,1,-1
          phi=k*s(k+1)+x(j)*phi
14      continue
        ff=y(j)/phi
        b=one
        do 15 k=n,1,-1
          cof(k)=cof(k)+b*ff
          b=s(k)+x(j)*b
15      continue
16    continue
      return
      end


C -----------------------------------------------------------------------
C  Program to run a least squares minimization to standard star
C  photometry to find transformation coefficients:
C  instrumental --> standard
C
C  ISYA 2004                               (c) Ignasi Ribas (IEEC, Spain)
C -----------------------------------------------------------------------
      PROGRAM FINDCOEFS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAX=1000,N=2)
      DIMENSION YINST(MAX),BINST(MAX)
      DIMENSION XMA(MAX,N),XDEP(MAX)
      DIMENSION XV(MAX),XCV(N,N),XCR(N,N),XR(N),XERR(MAX)
      DIMENSION YMA(MAX,N),YDEP(MAX)
      DIMENSION YV(MAX),YCV(N,N),YCR(N,N),YR(N),YERR(MAX)

      Open(1,file='standards.lst',status='old')
      Do 1 k=1,MAX
       Read(1,*,end=2) yinst(k),xerr(k),binst(k),sigb,ystd,ydep(k)
       xma(k,1)=1.d0
       yma(k,1)=1.d0
       xma(k,2)=binst(k)-yinst(k)
       yma(k,2)=binst(k)-yinst(k)
       yerr(k)=dsqrt(xerr(k)*xerr(k)+sigb*sigb)
       xdep(k)=ystd-yinst(k)
  1   Continue
  2   Close(1)
      ns=k-1

      CALL MINQ(XMA,XDEP,XERR,NS,XR,XCV,XCR,XV,XSIG,XR1)
      CALL MINQ(YMA,YDEP,YERR,NS,YR,YCV,YCR,YV,YSIG,YR1)

      Open(2,file='coefficients.dat')
      Write(2,50)
  50  Format(20x,'FIT RESULTS',/,20x,'-----------')
      Write(2,*)
      Write(2,100) XR(1),XR(2)
      Write(2,200) SQRT(XCV(1,1)),SQRT(XCV(2,2))
      Write(2,*)
      Write(2,400) XSIG,XR1
      Write(2,*)
      Write(2,*)
      Write(2,300) YR(1),YR(2)
      Write(2,200) SQRT(YCV(1,1)),SQRT(YCV(2,2))
      Write(2,*)
      Write(2,400) YSIG,YR1
 100  Format('y_std-y_inst =    ',f7.3,'  + ',f7.3,' * (b-y)_inst')
 200  Format('               +/-',f7.3,' +/-',f7.3)
 300  Format('   (b-y)_std =    ',f7.3,'  + ',f7.3,' * (b-y)_inst')
 400  Format(5x,'sigma = ',f7.3,5x,'correlation coeff = ',f7.3)
      Write(2,*)
      Write(2,500)
 500  Format('  y_inst','   O-C ','  sigma',' (b-y)_i','   O-C ',
     $ '  sigma')
      Do 40 i=1,ns
       calc1=xr(1)+xma(i,2)*xr(2)
       res1=xdep(i)-calc1
       calc2=yr(1)+yma(i,2)*yr(2)
       res2=ydep(i)-calc2
       Write(2,'(2(f8.3,2f7.3))') yinst(i),-res1,xerr(i),yma(i,2),res2,
     $  yerr(i)
 40   Continue
      Close(2)

C      WRITE(*,900)
C      Do 10 i=1,n
C        WRITE(*,800) (XCV(i,j),j=1,n)
C 10   Continue
C      WRITE(*,901)
C      Do 20 i=1,n
C        WRITE(*,800) (YCV(i,j),j=1,n)
C 20   Continue

 800  Format(8x,4f9.5)
 900  Format(/,/,9x,'Covariance matrix 1')
 901  Format(/,/,9x,'Covariance matrix 2')

      Stop
      End
*
*     -------------
*     LEAST SQUARES
*     -------------
*
      SUBROUTINE MINQ (A,ALTINCR,ERRY,NS,R,CV,CR,V,SIGMA,R2)
      PARAMETER (MAX=1000,N=2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(MAX,N),ALTINCR(MAX),ERRY(MAX)
      DIMENSION P(MAX,MAX),ATP(N,MAX),AT(N,MAX),C(N,N)
      DIMENSION V(MAX),CV(N,N),CR(N,N)
      DIMENSION D(N,MAX),E(MAX),F(MAX),G(MAX),R(N)
      DIMENSION LL(N),MM(N)
*
*     -------------------------------
*     INITIALIZATION OF WEIGHT MATRIX
*     -------------------------------
*
      PT=0.
      DO 5 I=1,NS
         DO 6 J=1,NS
            IF (I.EQ.J) THEN
               P(I,J)=1.D0/ERRY(I)
            ELSE
               P(I,J)=0.D0
            ENDIF
6        CONTINUE
         PT=PT+P(I,I)
5     CONTINUE
      DO 7 I=1,NS
7     P(I,I)=NS*(P(I,I)/PT)
*
*     ------------------------------------
*     CALCULATION OF THE TRANSPOSED MATRIX
*     -------------------------------------
*
      DO 10 I=1,NS
         DO 15 J=1,N
           AT(J,I)=A(I,J)
15       CONTINUE
10    CONTINUE
*
*     ----------------------------------
*     PRODUCT OF TRANSPOSED TIMES WEIGHT
*     ----------------------------------
*
      DO 20 I=1,N
         DO 25 J=1,NS
            ATP(I,J)=0.D0
           DO 30 K=1,NS
               ATP(I,J)=ATP(I,J)+AT(I,K)*P(K,J)
30         CONTINUE
25       CONTINUE
20    CONTINUE
*
*     --------------------------
*     PRODUCT WITH SYSTEM MATRIX
*     --------------------------
*
      DO 35 I=1,N
         DO 40 J=1,N
           C(I,J)=0.D0
            DO 45 K=1,NS
              C(I,J)=C(I,J)+ATP(I,K)*A(K,J)
45          CONTINUE
40       CONTINUE
35    CONTINUE
*
*     -------
*     INVERSE
*     -------
*
      CALL INVERT (C,N,DET,LL,MM)
*
*     -----------------------------------
*     PRODUCT OF INVERSE TIMES TRANSPOSED
*     -----------------------------------
*
      DO 50 I=1,N
         DO 55 J=1,NS
            D(I,J)=0.D0
            DO 60 K=1,N
              D(I,J)=D(I,J)+C(I,K)*AT(K,J)
60          CONTINUE
55       CONTINUE
50    CONTINUE
*
*     -----------------------------------
*     PRODUCT OF WEIGHT TIMES DATA MATRIX
*     -----------------------------------
*
      em1=0.
      em2=0.
      DO 65 I=1,NS
         E(I)=0.D0
         em1=em1+ALTINCR(I)
         em2=em2+A(I,2)
         DO 70 J=1,NS
            E(I)=E(I)+P(I,J)*ALTINCR(J)
70    CONTINUE
65    CONTINUE
      em1=em1/NS
      em2=em2/NS
      dyt=0.
      dxt=0.
      dxy=0.
      Do 77 I=1,NS
      DXY=DXY+(P(I,I)/NS)*(A(I,2)-em2)*(ALTINCR(I)-em1)
      DXT=DXT+(P(I,I)/NS)*(A(I,2)-em2)*(A(I,2)-em2)
77    DYT=DYT+(P(I,I)/NS)*(ALTINCR(I)-em1)*(ALTINCR(I)-em1)
      R2=DXY/(SQRT(DXT*DYT))
*
*     -------------------------
*     SOLUTION BY LEAST SQUARES
*     -------------------------
*
      DO 75 I=1,N
         R(I)=0.D0
         DO 80 J=1,NS
            R(I)=R(I)+D(I,J)*E(J)
80       CONTINUE
75    CONTINUE
*
*     ------------------------------------
*     CALCULATION OF THE COVARIANCE MATRIX
*     ------------------------------------
*
      DO 85 I=1,NS
         F(I)=0.D0
         DO 90 J=1,N
           F(I)=F(I)+A(I,J)*R(J)
90       CONTINUE
        V(I)=F(I)-ALTINCR(I)
85    CONTINUE
*
      XNUMSIG=0.D0
      DO 95 I=1,NS
         G(I)=0.D0
         DO 100 J=1,NS
            G(I)=G(I)+V(J)*P(J,I)
100      CONTINUE
         XNUMSIG=XNUMSIG+G(I)*V(I)
95    CONTINUE
      SIGMAQ=XNUMSIG/(NS-N)
      SIGMA=DSQRT(SIGMAQ)
*
      DO 105 I=1,N
         DO 110 J=1,N
            CV(I,J)=SIGMAQ*C(I,J)
110      CONTINUE
105   CONTINUE
*
*     ------------------
*     CORRELATION MATRIX
*     ------------------
*
      DO 115 I=1,N
         DO 120 J=1,N
            CR(I,J)=C(I,J)/DSQRT(C(I,I)*C(J,J))
120      CONTINUE
115   CONTINUE
*
      RETURN
      END
*
*     ----------------
*     MATRIX INVERSION
*     ----------------
*
      SUBROUTINE INVERT (A,N,D,LL,MM)
      DIMENSION A(2*N),LL(N),MM(N)
      DOUBLE PRECISION A,D,BIGA,HOLD,DABS
*     --------------------------
*     SEARCH FOR LARGEST ELEMENT
*     --------------------------
      D=1.0D0
      NK=-N
      DO 80 K=1,N
      NK=NK+N
      LL(K)=K
      MM(K)=K
      KK=NK+K
      BIGA=A(KK)
      DO 20 J=K,N
      IZ=N*(J-1)
      DO 20 I=K,N
      IJ=IZ+I
10    IF (DABS(BIGA)-DABS(A(IJ))) 15,20,20
15    BIGA=A(IJ)
      LL(K)=I
      MM(K)=J
20    CONTINUE
*     ----------------
*     INTERCHANGE ROWS
*     ----------------
      J=LL(K)
      IF(J-K) 35,35,25
25    KI=K-N
      DO 30 I=1,N
      KI=KI+N
      HOLD=-A(KI)
      JI=KI-K+J
      A(KI)=A(JI)
30    A(JI) =HOLD
*     -------------------
*     INTERCHANGE COLUMNS
*     -------------------
35    I=MM(K)
      IF(I-K) 45,45,38
38    JP=N*(I-1)
      DO 40 J=1,N
      JK=NK+J
      JI=JP+J
      HOLD=-A(JK)
      A(JK)=A(JI)
40    A(JI) =HOLD
*     -------------------------------------------------------
*     DIVIDE COLUMN BY MINUS PIVOT (VALUE OF PIVOT ELEMENT IS
*     CONTAINED IN BIGA)
*     -------------------------------------------------------
45    IF(BIGA) 48,46,48
46    D=0.0D0
      RETURN
48    DO 55 I=1,N
      IF(I-K) 50,55,50
50    IK=NK+I
      A(IK)=A(IK)/(-BIGA)
55    CONTINUE
*     -------------
*     REDUCE MATRIX
*     -------------
      DO 65 I=1,N
      IK=NK+I
      HOLD=A(IK)
      IJ=I-N
      DO 65 J=1,N
      IJ=IJ+N
      IF(I-K) 60,65,60
60    IF(J-K) 62,65,62
62    KJ=IJ-I+K
      A(IJ)=HOLD*A(KJ)+A(IJ)
65    CONTINUE
*     -------------------
*     DIVIDE ROW BY PIVOT
*     -------------------
      KJ=K-N
      DO 75 J=1,N
      KJ=KJ+N
      IF(J-K) 70,75,70
70    A(KJ)=A(KJ)/BIGA
75    CONTINUE
*     -----------------
*     PRODUCT OF PIVOTS
*     -----------------
      D=D*BIGA
*     ---------------------------
*     REPLACE PIVOT BY RECIPROCAL
*     ---------------------------
      A(KK)=1.0D0/BIGA
80    CONTINUE
*     --------------------------------
*     FINAL ROW AND COLUMN INTERCHANGE
*     --------------------------------
      K=N
100   K=(K-1)
      IF(K) 150,150,105
105   I=LL(K)
      IF(I-K) 120,120,108
108   JQ=N*(K-1)
      JR=N*(I-1)
      DO 110 J=1,N
      JK=JQ+J
      HOLD=A(JK)
      JI=JR+J
      A(JK)=-A(JI)
110   A(JI) =HOLD
120   J=MM(K)
      IF(J-K) 100,100,125
125   KI=K-N
      DO 130 I=1,N
      KI=KI+N
      HOLD=A(KI)
      JI=KI-K+J
      A(KI)=-A(JI)
130   A(JI) =HOLD
      GO TO 100
150   RETURN
      END


      SUBROUTINE slCRAF (NDP, ANGLE, SIGN, IDMSF)
*+
*     - - - - - -
*      C R A F
*     - - - - - -
*
*  Convert an angle in radians into degrees, arcminutes, arcseconds
*  (single precision)
*
*  Given:
*     NDP       int      number of decimal places of arcseconds
*     ANGLE     real     angle in radians
*
*  Returned:
*     SIGN      char     '+' or '-'
*     IDMSF     int(4)   degrees, arcminutes, arcseconds, fraction
*
*  Notes:
*
*     1)  NDP less than zero is interpreted as zero.
*
*     2)  The largest useful value for NDP is determined by the size of
*         ANGLE, the format of REAL floating-point numbers on the target
*         machine, and the risk of overflowing IDMSF(4).  On some
*         architectures, for ANGLE up to 2pi, the available floating-
*         point precision corresponds roughly to NDP=3.  This is well
*         below the ultimate limit of NDP=9 set by the capacity of a
*         typical 32-bit IDMSF(4).
*
*     3)  The absolute value of ANGLE may exceed 2pi.  In cases where it
*         does not, it is up to the caller to test for and handle the
*         case where ANGLE is very nearly 2pi and rounds up to 360 deg,
*         by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero.
*
*  Called:  slCDTF
*
*  Last revision:   26 December 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER NDP
      REAL ANGLE
      CHARACTER SIGN*(*)
      INTEGER IDMSF(4)

*  Hours to degrees * radians to turns
      REAL F
      PARAMETER (F=15.0/6.283185307179586476925287)

*  Scale then use days to h,m,s routine
      CALL slCDTF(NDP,ANGLE*F,SIGN,IDMSF)

      END


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine multipole(dipole_m,quadrupole_m,norm_m)
  use global_variables
  implicit none
  real(dp) :: dipole_m, quadrupole_m, norm_m
  real(dp) :: ss
  integer :: ix,iy

  dipole_m = 0d0; norm_m = 0d0
  do ix = 0,Nx
     dipole_m = dipole_m + xn(ix)*abs(zwfn_e(ix))**2
     norm_m = norm_m + abs(zwfn_e(ix))**2
  end do
  dipole_m = dipole_m*dx
  norm_m = norm_m*dx

  ss = 0d0
  quadrupole_m = 0d0
  do iy = 0,NR
     ss = ss + abs(zwfn_n(iy))**2
     quadrupole_m = quadrupole_m + Rn(iy)**2*abs(zwfn_n(iy))**2
  end do
  ss = ss*dr
  quadrupole_m = quadrupole_m*dr

  dipole_m = dipole_m * ss
  quadrupole_m = quadrupole_m*norm_m
  norm_m = norm_m * ss

  return
end subroutine multipole


      subroutine SGESLD(A,LDA,N,IPVT,B)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 SGESLD Krogh  Changes to use M77CON
C>> 1987-08-18 SGESLD Lawson  Initial code.
c--S replaces "?": ?GESLD, ?AXPY

C     This subroutine solves the system of equations  A * X = B
C     using the LU factorization of A given in the array A().
c     ------------------------------------------------------------------
c           Subroutine arguments
C
C     A(,)  [in]  An array of size at least N x N.  On entry must
c         contain the LU factors of an N x N  matrix, A.  It is
c         expected that this factorization will have been computed by
c         use of _GEFA, either directly or indirectly via use of
c         _GEFS or _GEFSC.  This subr will not alter the contents of
c         A(,)
C
C     LDA  [in]  Leading dimensioning parameter for the array A(,).
C
C     N  [in]  The order of the original matrix, A.
C
C     IPVT()  [in]  An integer array of length at least N, containg a
c           record of the row interchanges made during factorization of
c           A.
C
c     B()  [inout]  On entry contains the right-side N-vector for the
c           problem, A * X = B.  On return contains the solution
c           N-vector, X.
c     ------------------------------------------------------------------
C     ERROR CONDITION
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        setting of LDA.  The user can avoid sending a singular matrix
c        to this subr by testing INFO (set by _GEFS or _GEFA) or
c        RCOND (set by _GEFSC or _GERC) before calling this subr.
c        Nonsingularity is indicated by INFO .eq. 0 or RCOND .ne. ZERO.
C     ------------------------------------------------------------------
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
c     Ref: LINPACK Users' Guide, by J. J. Dongarra, C. B. Moler,
c     J. R. Bunch, and G. W. Stewart, publ by Soc. for Indust. and Appl.
c     Math, Philadelphia, 1979.
c     Adapted from LINPACK for the JPL Math77 library by
c     C. L. Lawson, JPL, Aug 1987.
C     ------------------------------------------------------------------
c     Subprograms referenced: SAXPY
C     ------------------------------------------------------------------
      integer LDA,N,IPVT(N), K, KB, L, NM1
      real             A(LDA,N), B(N), T, ZERO
      parameter ( ZERO = 0.E0 )
C     ------------------------------------------------------------------
      NM1 = N - 1

C        SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B

         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .ne. K) THEN
              B(L) = B(K)
              B(K) = T
            END IF
            CALL SAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            IF (A(K,K) .NE. ZERO) THEN
              B(K) = B(K)/A(K,K)
            ELSE
              CALL ERMSG('SGESLD',1,0,'A diagonal element is zero','.')
              RETURN
            END IF
            T = -B(K)
            CALL SAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      RETURN
      END


Module m_valmed
Integer, Parameter :: kdp = selected_real_kind(15)
public :: valmed
private :: kdp
private :: R_valmed, I_valmed, D_valmed
interface valmed
  module procedure d_valmed, r_valmed, i_valmed
end interface valmed
contains

Recursive Function D_valmed (XDONT) Result (res_med)
!  Finds the median of XDONT using the recursive procedure
!  described in Knuth, The Art of Computer Programming,
!  vol. 3, 5.3.3 - This procedure is linear in time, and
!  does not require to be able to interpolate in the
!  set as the one used in INDNTH. It also has better worst
!  case behavior than INDNTH, but is about 30% slower in
!  average for random uniformly distributed values.
! __________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (In) :: XDONT
      Real (kind=kdp) :: res_med
! __________________________________________________________
      Real (kind=kdp), Parameter :: XHUGE = HUGE (XDONT)
      Real (kind=kdp), Dimension (SIZE(XDONT)+6) :: XWRKT
      Real (kind=kdp) :: XWRK, XWRK1, XMED7
!
      Integer, Dimension ((SIZE(XDONT)+6)/7) :: ISTRT, IENDT, IMEDT
      Integer :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
      Integer :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
!
      NDON = SIZE (XDONT)
      NMED = (NDON+1) / 2
!      write(unit=*,fmt=*) NMED, NDON
!
!  If the number of values is small, then use insertion sort
!
      If (NDON < 35) Then
!
!  Bring minimum to first location to save test in decreasing loop
!
         IDCR = NDON
         If (XDONT (1) < XDONT (NDON)) Then
            XWRK = XDONT (1)
            XWRKT (IDCR) = XDONT (IDCR)
         Else
            XWRK = XDONT (IDCR)
            XWRKT (IDCR) = XDONT (1)
         Endif
         Do IWRK = 1, NDON - 2
            IDCR = IDCR - 1
            XWRK1 = XDONT (IDCR)
            If (XWRK1 < XWRK) Then
                XWRKT (IDCR) = XWRK
                XWRK = XWRK1
            Else
                XWRKT (IDCR) = XWRK1
            Endif
         End Do
         XWRKT (1) = XWRK
!
! Sort the first half, until we have NMED sorted values
!
         Do ICRS = 3, NMED
            XWRK = XWRKT (ICRS)
               IDCR = ICRS - 1
               Do
                  If (XWRK >= XWRKT(IDCR)) Exit
                  XWRKT (IDCR+1) = XWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
            XWRKT (IDCR+1) = XWRK
         End Do
!
!  Insert any value less than the current median in the first half
!
         Do ICRS = NMED+1, NDON
            XWRK = XWRKT (ICRS)
            If (XWRK < XWRKT (NMED)) Then
               IDCR = NMED - 1
               Do
                  If (XWRK >= XWRKT(IDCR)) Exit
                  XWRKT (IDCR+1) = XWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
               XWRKT (IDCR+1) = XWRK
            End If
         End Do
         res_med = XWRKT (NMED)
         Return
      End If
!
!  Make sorted subsets of 7 elements
!  This is done by a variant of insertion sort where a first
!  pass is used to bring the smallest element to the first position
!  decreasing disorder at the same time, so that we may remove
!  remove the loop test in the insertion loop.
!
      DO IDEB = 1, NDON-6, 7
         IDCR = IDEB + 6
         If (XDONT (IDEB) < XDONT (IDCR)) Then
            XWRK = XDONT (IDEB)
            XWRKT (IDCR) = XDONT (IDCR)
         Else
            XWRK = XDONT (IDCR)
            XWRKT (IDCR) = XDONT (IDEB)
         Endif
         Do IWRK = 1, 5
            IDCR = IDCR - 1
            XWRK1 = XDONT (IDCR)
            If (XWRK1 < XWRK) Then
                XWRKT (IDCR) = XWRK
                XWRK = XWRK1
            Else
                XWRKT (IDCR) = XWRK1
            Endif
         End Do
         XWRKT (IDEB) = XWRK
         Do ICRS = IDEB+2, IDEB+6
            XWRK = XWRKT (ICRS)
            If (XWRK < XWRKT(ICRS-1)) Then
               XWRKT (ICRS) = XWRKT (ICRS-1)
               IDCR = ICRS - 1
               XWRK1 = XWRKT (IDCR-1)
               Do
                  If (XWRK >= XWRK1) Exit
                  XWRKT (IDCR) = XWRK1
                  IDCR = IDCR - 1
                  XWRK1 = XWRKT (IDCR-1)
               End Do
               XWRKT (IDCR) = XWRK
            EndIf
         End Do
      End Do
!
!  Add-up alternatively + and - HUGE values to make the number of data
!  an exact multiple of 7.
!
      IDEB = 7 * (NDON/7)
      NTRI = NDON
      If (IDEB < NDON) Then
!
         XWRK1 = XHUGE
         Do ICRS = IDEB+1, IDEB+7
            If (ICRS <= NDON) Then
               XWRKT (ICRS) = XDONT (ICRS)
            Else
               If (XWRK1 /= XHUGE) NMED = NMED + 1
               XWRKT (ICRS) = XWRK1
               XWRK1 = - XWRK1
            Endif
         End Do
!
         Do ICRS = IDEB+2, IDEB+7
            XWRK = XWRKT (ICRS)
            Do IDCR = ICRS - 1, IDEB+1, - 1
               If (XWRK >= XWRKT(IDCR)) Exit
               XWRKT (IDCR+1) = XWRKT (IDCR)
            End Do
            XWRKT (IDCR+1) = XWRK
         End Do
!
         NTRI = IDEB+7
      End If
!
!  Make the set of the indices of median values of each sorted subset
!
         IDON1 = 0
         Do IDON = 1, NTRI, 7
            IDON1 = IDON1 + 1
            IMEDT (IDON1) = IDON + 3
         End Do
!
!  Find XMED7, the median of the medians
!
         XMED7 = D_valmed (XWRKT (IMEDT))
!
!  Count how many values are not higher than (and how many equal to) XMED7
!  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
!  subsets where the median is lower than the median of medians. For similar
!  reasons, we also have at least 2N/7 values not lower than XMED7. At the
!  same time, we find in each subset the index of the last value < XMED7,
!  and that of the first > XMED7. These indices will be used to restrict the
!  search for the median as the Kth element in the subset (> or <) where
!  we know it to be.
!
         IDON1 = 1
         NLEQ = 0
         NEQU = 0
         Do IDON = 1, NTRI, 7
            IMED = IDON+3
            If (XWRKT (IMED) > XMED7) Then
                  IMED = IMED - 2
                  If (XWRKT (IMED) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XWRKT (IMED) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Else If (XWRKT (IMED) < XMED7) Then
                  IMED = IMED + 2
                  If (XWRKT (IMED) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XWRKT (IMED) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Endif
            If (XWRKT (IMED) > XMED7) Then
               NLEQ = NLEQ + IMED - IDON
               IENDT (IDON1) = IMED - 1
               ISTRT (IDON1) = IMED
            Else If (XWRKT (IMED) < XMED7) Then
               NLEQ = NLEQ + IMED - IDON + 1
               IENDT (IDON1) = IMED
               ISTRT (IDON1) = IMED + 1
            Else                    !       If (XWRKT (IMED) == XMED7)
               NLEQ = NLEQ + IMED - IDON + 1
               NEQU = NEQU + 1
               IENDT (IDON1) = IMED - 1
               Do IMED1 = IMED - 1, IDON, -1
                  If (XWRKT (IMED1) == XMED7) Then
                     NEQU = NEQU + 1
                     IENDT (IDON1) = IMED1 - 1
                  Else
                     Exit
                  End If
               End Do
               ISTRT (IDON1) = IMED + 1
               Do IMED1 = IMED + 1, IDON + 6
                  If (XWRKT (IMED1) == XMED7) Then
                     NEQU = NEQU + 1
                     NLEQ = NLEQ + 1
                     ISTRT (IDON1) = IMED1 + 1
                  Else
                     Exit
                  End If
               End Do
            Endif
            IDON1 = IDON1 + 1
         End Do
!
!  Carry out a partial insertion sort to find the Kth smallest of the
!  large values, or the Kth largest of the small values, according to
!  what is needed.
!
        If (NLEQ - NEQU + 1 <= NMED) Then
            If (NLEQ < NMED) Then   !      Not enough low values
                XWRK1 = XHUGE
                NORD = NMED - NLEQ
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                IDCR = 0
               Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XWRKT(ICRS) < XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                           If (ICRS2 < NORD) Then
                              XWRKT (ICRS1) = XWRKT (ICRS)
                              XWRK1 = XWRKT(ICRS1)
                           Endif
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XWRKT(ICRS) >= XWRK1) Exit
                         XWRK = XWRKT (ICRS)
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                         End Do
                         XWRKT (IDCR+1) = XWRK
                         XWRK1 = XWRKT(ICRS1)
                      End Do
                   End If
                End Do
                res_med = XWRK1
                Return
            Else
                res_med = XMED7
                Return
            End If
         Else                       !      If (NLEQ > NMED)
!                                          Not enough high values
                XWRK1 = -XHUGE
                NORD = NLEQ - NEQU - NMED + 1
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
!
                      Do ICRS = IDON, IENDT (IDON1)
                         If (XWRKT(ICRS) > XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                            If (ICRS2 < NORD) Then
                               XWRKT (ICRS1) = XWRKT (ICRS)
                               XWRK1 = XWRKT (ICRS1)
                            End If
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = IENDT (IDON1), IDON, -1
                         If (XWRKT(ICRS) > XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                            Exit
                         End If
                      End Do
                   Endif
                End Do
!
                res_med = XWRK1
                Return
         End If
!
End Function D_valmed

Recursive Function R_valmed (XDONT) Result (res_med)
!  Finds the median of XDONT using the recursive procedure
!  described in Knuth, The Art of Computer Programming,
!  vol. 3, 5.3.3 - This procedure is linear in time, and
!  does not require to be able to interpolate in the
!  set as the one used in INDNTH. It also has better worst
!  case behavior than INDNTH, but is about 30% slower in
!  average for random uniformly distributed values.
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (In) :: XDONT
      Real :: res_med
! __________________________________________________________
      Real, Parameter :: XHUGE = HUGE (XDONT)
      Real, Dimension (SIZE(XDONT)+6) :: XWRKT
      Real :: XWRK, XWRK1, XMED7
!
      Integer, Dimension ((SIZE(XDONT)+6)/7) :: ISTRT, IENDT, IMEDT
      Integer :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
      Integer :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
!
      NDON = SIZE (XDONT)
      NMED = (NDON+1) / 2
!      write(unit=*,fmt=*) NMED, NDON
!
!  If the number of values is small, then use insertion sort
!
      If (NDON < 35) Then
!
!  Bring minimum to first location to save test in decreasing loop
!
         IDCR = NDON
         If (XDONT (1) < XDONT (NDON)) Then
            XWRK = XDONT (1)
            XWRKT (IDCR) = XDONT (IDCR)
         Else
            XWRK = XDONT (IDCR)
            XWRKT (IDCR) = XDONT (1)
         Endif
         Do IWRK = 1, NDON - 2
            IDCR = IDCR - 1
            XWRK1 = XDONT (IDCR)
            If (XWRK1 < XWRK) Then
                XWRKT (IDCR) = XWRK
                XWRK = XWRK1
            Else
                XWRKT (IDCR) = XWRK1
            Endif
         End Do
         XWRKT (1) = XWRK
!
! Sort the first half, until we have NMED sorted values
!
         Do ICRS = 3, NMED
            XWRK = XWRKT (ICRS)
               IDCR = ICRS - 1
               Do
                  If (XWRK >= XWRKT(IDCR)) Exit
                  XWRKT (IDCR+1) = XWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
            XWRKT (IDCR+1) = XWRK
         End Do
!
!  Insert any value less than the current median in the first half
!
         Do ICRS = NMED+1, NDON
            XWRK = XWRKT (ICRS)
            If (XWRK < XWRKT (NMED)) Then
               IDCR = NMED - 1
               Do
                  If (XWRK >= XWRKT(IDCR)) Exit
                  XWRKT (IDCR+1) = XWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
               XWRKT (IDCR+1) = XWRK
            End If
         End Do
         res_med = XWRKT (NMED)
         Return
      End If
!
!  Make sorted subsets of 7 elements
!  This is done by a variant of insertion sort where a first
!  pass is used to bring the smallest element to the first position
!  decreasing disorder at the same time, so that we may remove
!  remove the loop test in the insertion loop.
!
      DO IDEB = 1, NDON-6, 7
         IDCR = IDEB + 6
         If (XDONT (IDEB) < XDONT (IDCR)) Then
            XWRK = XDONT (IDEB)
            XWRKT (IDCR) = XDONT (IDCR)
         Else
            XWRK = XDONT (IDCR)
            XWRKT (IDCR) = XDONT (IDEB)
         Endif
         Do IWRK = 1, 5
            IDCR = IDCR - 1
            XWRK1 = XDONT (IDCR)
            If (XWRK1 < XWRK) Then
                XWRKT (IDCR) = XWRK
                XWRK = XWRK1
            Else
                XWRKT (IDCR) = XWRK1
            Endif
         End Do
         XWRKT (IDEB) = XWRK
         Do ICRS = IDEB+2, IDEB+6
            XWRK = XWRKT (ICRS)
            If (XWRK < XWRKT(ICRS-1)) Then
               XWRKT (ICRS) = XWRKT (ICRS-1)
               IDCR = ICRS - 1
               XWRK1 = XWRKT (IDCR-1)
               Do
                  If (XWRK >= XWRK1) Exit
                  XWRKT (IDCR) = XWRK1
                  IDCR = IDCR - 1
                  XWRK1 = XWRKT (IDCR-1)
               End Do
               XWRKT (IDCR) = XWRK
            EndIf
         End Do
      End Do
!
!  Add-up alternatively + and - HUGE values to make the number of data
!  an exact multiple of 7.
!
      IDEB = 7 * (NDON/7)
      NTRI = NDON
      If (IDEB < NDON) Then
!
         XWRK1 = XHUGE
         Do ICRS = IDEB+1, IDEB+7
            If (ICRS <= NDON) Then
               XWRKT (ICRS) = XDONT (ICRS)
            Else
               If (XWRK1 /= XHUGE) NMED = NMED + 1
               XWRKT (ICRS) = XWRK1
               XWRK1 = - XWRK1
            Endif
         End Do
!
         Do ICRS = IDEB+2, IDEB+7
            XWRK = XWRKT (ICRS)
            Do IDCR = ICRS - 1, IDEB+1, - 1
               If (XWRK >= XWRKT(IDCR)) Exit
               XWRKT (IDCR+1) = XWRKT (IDCR)
            End Do
            XWRKT (IDCR+1) = XWRK
         End Do
!
         NTRI = IDEB+7
      End If
!
!  Make the set of the indices of median values of each sorted subset
!
         IDON1 = 0
         Do IDON = 1, NTRI, 7
            IDON1 = IDON1 + 1
            IMEDT (IDON1) = IDON + 3
         End Do
!
!  Find XMED7, the median of the medians
!
         XMED7 = R_valmed (XWRKT (IMEDT))
!
!  Count how many values are not higher than (and how many equal to) XMED7
!  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
!  subsets where the median is lower than the median of medians. For similar
!  reasons, we also have at least 2N/7 values not lower than XMED7. At the
!  same time, we find in each subset the index of the last value < XMED7,
!  and that of the first > XMED7. These indices will be used to restrict the
!  search for the median as the Kth element in the subset (> or <) where
!  we know it to be.
!
         IDON1 = 1
         NLEQ = 0
         NEQU = 0
         Do IDON = 1, NTRI, 7
            IMED = IDON+3
            If (XWRKT (IMED) > XMED7) Then
                  IMED = IMED - 2
                  If (XWRKT (IMED) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XWRKT (IMED) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Else If (XWRKT (IMED) < XMED7) Then
                  IMED = IMED + 2
                  If (XWRKT (IMED) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XWRKT (IMED) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Endif
            If (XWRKT (IMED) > XMED7) Then
               NLEQ = NLEQ + IMED - IDON
               IENDT (IDON1) = IMED - 1
               ISTRT (IDON1) = IMED
            Else If (XWRKT (IMED) < XMED7) Then
               NLEQ = NLEQ + IMED - IDON + 1
               IENDT (IDON1) = IMED
               ISTRT (IDON1) = IMED + 1
            Else                    !       If (XWRKT (IMED) == XMED7)
               NLEQ = NLEQ + IMED - IDON + 1
               NEQU = NEQU + 1
               IENDT (IDON1) = IMED - 1
               Do IMED1 = IMED - 1, IDON, -1
                  If (XWRKT (IMED1) == XMED7) Then
                     NEQU = NEQU + 1
                     IENDT (IDON1) = IMED1 - 1
                  Else
                     Exit
                  End If
               End Do
               ISTRT (IDON1) = IMED + 1
               Do IMED1 = IMED + 1, IDON + 6
                  If (XWRKT (IMED1) == XMED7) Then
                     NEQU = NEQU + 1
                     NLEQ = NLEQ + 1
                     ISTRT (IDON1) = IMED1 + 1
                  Else
                     Exit
                  End If
               End Do
            Endif
            IDON1 = IDON1 + 1
         End Do
!
!  Carry out a partial insertion sort to find the Kth smallest of the
!  large values, or the Kth largest of the small values, according to
!  what is needed.
!
        If (NLEQ - NEQU + 1 <= NMED) Then
            If (NLEQ < NMED) Then   !      Not enough low values
                XWRK1 = XHUGE
                NORD = NMED - NLEQ
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                IDCR = 0
               Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XWRKT(ICRS) < XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                           If (ICRS2 < NORD) Then
                              XWRKT (ICRS1) = XWRKT (ICRS)
                              XWRK1 = XWRKT(ICRS1)
                           Endif
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XWRKT(ICRS) >= XWRK1) Exit
                         XWRK = XWRKT (ICRS)
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                         End Do
                         XWRKT (IDCR+1) = XWRK
                         XWRK1 = XWRKT(ICRS1)
                      End Do
                   End If
                End Do
                res_med = XWRK1
                Return
            Else
                res_med = XMED7
                Return
            End If
         Else                       !      If (NLEQ > NMED)
!                                          Not enough high values
                XWRK1 = -XHUGE
                NORD = NLEQ - NEQU - NMED + 1
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
!
                      Do ICRS = IDON, IENDT (IDON1)
                         If (XWRKT(ICRS) > XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                            If (ICRS2 < NORD) Then
                               XWRKT (ICRS1) = XWRKT (ICRS)
                               XWRK1 = XWRKT (ICRS1)
                            End If
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = IENDT (IDON1), IDON, -1
                         If (XWRKT(ICRS) > XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                            Exit
                         End If
                      End Do
                   Endif
                End Do
!
                res_med = XWRK1
                Return
         End If
!
End Function R_valmed
Recursive Function I_valmed (XDONT) Result (res_med)
!  Finds the median of XDONT using the recursive procedure
!  described in Knuth, The Art of Computer Programming,
!  vol. 3, 5.3.3 - This procedure is linear in time, and
!  does not require to be able to interpolate in the
!  set as the one used in INDNTH. It also has better worst
!  case behavior than INDNTH, but is about 30% slower in
!  average for random uniformly distributed values.
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (In)  :: XDONT
      Integer :: res_med
! __________________________________________________________
      Integer, Parameter :: XHUGE = HUGE (XDONT)
      Integer, Dimension (SIZE(XDONT)+6) :: XWRKT
      Integer :: XWRK, XWRK1, XMED7
!
      Integer, Dimension ((SIZE(XDONT)+6)/7) :: ISTRT, IENDT, IMEDT
      Integer :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
      Integer :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
!
      NDON = SIZE (XDONT)
      NMED = (NDON+1) / 2
!      write(unit=*,fmt=*) NMED, NDON
!
!  If the number of values is small, then use insertion sort
!
      If (NDON < 35) Then
!
!  Bring minimum to first location to save test in decreasing loop
!
         IDCR = NDON
         If (XDONT (1) < XDONT (NDON)) Then
            XWRK = XDONT (1)
            XWRKT (IDCR) = XDONT (IDCR)
         Else
            XWRK = XDONT (IDCR)
            XWRKT (IDCR) = XDONT (1)
         Endif
         Do IWRK = 1, NDON - 2
            IDCR = IDCR - 1
            XWRK1 = XDONT (IDCR)
            If (XWRK1 < XWRK) Then
                XWRKT (IDCR) = XWRK
                XWRK = XWRK1
            Else
                XWRKT (IDCR) = XWRK1
            Endif
         End Do
         XWRKT (1) = XWRK
!
! Sort the first half, until we have NMED sorted values
!
         Do ICRS = 3, NMED
            XWRK = XWRKT (ICRS)
               IDCR = ICRS - 1
               Do
                  If (XWRK >= XWRKT(IDCR)) Exit
                  XWRKT (IDCR+1) = XWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
            XWRKT (IDCR+1) = XWRK
         End Do
!
!  Insert any value less than the current median in the first half
!
         Do ICRS = NMED+1, NDON
            XWRK = XWRKT (ICRS)
            If (XWRK < XWRKT (NMED)) Then
               IDCR = NMED - 1
               Do
                  If (XWRK >= XWRKT(IDCR)) Exit
                  XWRKT (IDCR+1) = XWRKT (IDCR)
                  IDCR = IDCR - 1
               End Do
               XWRKT (IDCR+1) = XWRK
            End If
         End Do
         res_med = XWRKT (NMED)
         Return
      End If
!
!  Make sorted subsets of 7 elements
!  This is done by a variant of insertion sort where a first
!  pass is used to bring the smallest element to the first position
!  decreasing disorder at the same time, so that we may remove
!  remove the loop test in the insertion loop.
!
      DO IDEB = 1, NDON-6, 7
         IDCR = IDEB + 6
         If (XDONT (IDEB) < XDONT (IDCR)) Then
            XWRK = XDONT (IDEB)
            XWRKT (IDCR) = XDONT (IDCR)
         Else
            XWRK = XDONT (IDCR)
            XWRKT (IDCR) = XDONT (IDEB)
         Endif
         Do IWRK = 1, 5
            IDCR = IDCR - 1
            XWRK1 = XDONT (IDCR)
            If (XWRK1 < XWRK) Then
                XWRKT (IDCR) = XWRK
                XWRK = XWRK1
            Else
                XWRKT (IDCR) = XWRK1
            Endif
         End Do
         XWRKT (IDEB) = XWRK
         Do ICRS = IDEB+2, IDEB+6
            XWRK = XWRKT (ICRS)
            If (XWRK < XWRKT(ICRS-1)) Then
               XWRKT (ICRS) = XWRKT (ICRS-1)
               IDCR = ICRS - 1
               XWRK1 = XWRKT (IDCR-1)
               Do
                  If (XWRK >= XWRK1) Exit
                  XWRKT (IDCR) = XWRK1
                  IDCR = IDCR - 1
                  XWRK1 = XWRKT (IDCR-1)
               End Do
               XWRKT (IDCR) = XWRK
            EndIf
         End Do
      End Do
!
!  Add-up alternatively + and - HUGE values to make the number of data
!  an exact multiple of 7.
!
      IDEB = 7 * (NDON/7)
      NTRI = NDON
      If (IDEB < NDON) Then
!
         XWRK1 = XHUGE
         Do ICRS = IDEB+1, IDEB+7
            If (ICRS <= NDON) Then
               XWRKT (ICRS) = XDONT (ICRS)
            Else
               If (XWRK1 /= XHUGE) NMED = NMED + 1
               XWRKT (ICRS) = XWRK1
               XWRK1 = - XWRK1
            Endif
         End Do
!
         Do ICRS = IDEB+2, IDEB+7
            XWRK = XWRKT (ICRS)
            Do IDCR = ICRS - 1, IDEB+1, - 1
               If (XWRK >= XWRKT(IDCR)) Exit
               XWRKT (IDCR+1) = XWRKT (IDCR)
            End Do
            XWRKT (IDCR+1) = XWRK
         End Do
!
         NTRI = IDEB+7
      End If
!
!  Make the set of the indices of median values of each sorted subset
!
         IDON1 = 0
         Do IDON = 1, NTRI, 7
            IDON1 = IDON1 + 1
            IMEDT (IDON1) = IDON + 3
         End Do
!
!  Find XMED7, the median of the medians
!
         XMED7 = I_valmed (XWRKT (IMEDT))
!
!  Count how many values are not higher than (and how many equal to) XMED7
!  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
!  subsets where the median is lower than the median of medians. For similar
!  reasons, we also have at least 2N/7 values not lower than XMED7. At the
!  same time, we find in each subset the index of the last value < XMED7,
!  and that of the first > XMED7. These indices will be used to restrict the
!  search for the median as the Kth element in the subset (> or <) where
!  we know it to be.
!
         IDON1 = 1
         NLEQ = 0
         NEQU = 0
         Do IDON = 1, NTRI, 7
            IMED = IDON+3
            If (XWRKT (IMED) > XMED7) Then
                  IMED = IMED - 2
                  If (XWRKT (IMED) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XWRKT (IMED) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Else If (XWRKT (IMED) < XMED7) Then
                  IMED = IMED + 2
                  If (XWRKT (IMED) > XMED7) Then
                     IMED = IMED - 1
                  Else If (XWRKT (IMED) < XMED7) Then
                     IMED = IMED + 1
                  Endif
            Endif
            If (XWRKT (IMED) > XMED7) Then
               NLEQ = NLEQ + IMED - IDON
               IENDT (IDON1) = IMED - 1
               ISTRT (IDON1) = IMED
            Else If (XWRKT (IMED) < XMED7) Then
               NLEQ = NLEQ + IMED - IDON + 1
               IENDT (IDON1) = IMED
               ISTRT (IDON1) = IMED + 1
            Else                    !       If (XWRKT (IMED) == XMED7)
               NLEQ = NLEQ + IMED - IDON + 1
               NEQU = NEQU + 1
               IENDT (IDON1) = IMED - 1
               Do IMED1 = IMED - 1, IDON, -1
                  If (XWRKT (IMED1) == XMED7) Then
                     NEQU = NEQU + 1
                     IENDT (IDON1) = IMED1 - 1
                  Else
                     Exit
                  End If
               End Do
               ISTRT (IDON1) = IMED + 1
               Do IMED1 = IMED + 1, IDON + 6
                  If (XWRKT (IMED1) == XMED7) Then
                     NEQU = NEQU + 1
                     NLEQ = NLEQ + 1
                     ISTRT (IDON1) = IMED1 + 1
                  Else
                     Exit
                  End If
               End Do
            Endif
            IDON1 = IDON1 + 1
         End Do
!
!  Carry out a partial insertion sort to find the Kth smallest of the
!  large values, or the Kth largest of the small values, according to
!  what is needed.
!
        If (NLEQ - NEQU + 1 <= NMED) Then
            If (NLEQ < NMED) Then   !      Not enough low values
                XWRK1 = XHUGE
                NORD = NMED - NLEQ
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                IDCR = 0
               Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XWRKT(ICRS) < XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                           If (ICRS2 < NORD) Then
                              XWRKT (ICRS1) = XWRKT (ICRS)
                              XWRK1 = XWRKT(ICRS1)
                           Endif
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = ISTRT (IDON1), IDON + 6
                         If (XWRKT(ICRS) >= XWRK1) Exit
                         XWRK = XWRKT (ICRS)
                         Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK >= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                         End Do
                         XWRKT (IDCR+1) = XWRK
                         XWRK1 = XWRKT(ICRS1)
                      End Do
                   End If
                End Do
                res_med = XWRK1
                Return
            Else
                res_med = XMED7
                Return
            End If
         Else                       !      If (NLEQ > NMED)
!                                          Not enough high values
                XWRK1 = -XHUGE
                NORD = NLEQ - NEQU - NMED + 1
                IDON1 = 0
                ICRS1 = 1
                ICRS2 = 0
                Do IDON = 1, NTRI, 7
                   IDON1 = IDON1 + 1
                   If (ICRS2 < NORD) Then
!
                      Do ICRS = IDON, IENDT (IDON1)
                         If (XWRKT(ICRS) > XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                            If (ICRS2 < NORD) Then
                               XWRKT (ICRS1) = XWRKT (ICRS)
                               XWRK1 = XWRKT (ICRS1)
                            End If
                         End If
                         ICRS1 = MIN (NORD, ICRS1 + 1)
                         ICRS2 = MIN (NORD, ICRS2 + 1)
                      End Do
                   Else
                      Do ICRS = IENDT (IDON1), IDON, -1
                         If (XWRKT(ICRS) > XWRK1) Then
                            XWRK = XWRKT (ICRS)
                            IDCR = ICRS1 - 1
                            Do IDCR = ICRS1 - 1, 1, - 1
                               If (XWRK <= XWRKT(IDCR)) Exit
                               XWRKT (IDCR+1) = XWRKT (IDCR)
                            End Do
                            XWRKT (IDCR+1) = XWRK
                            XWRK1 = XWRKT(ICRS1)
                         Else
                            Exit
                         End If
                      End Do
                   Endif
                End Do
!
                res_med = XWRK1
                Return
         End If
!
End Function I_valmed
end module m_valmed


!*==dlapy3.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAPY3 returns sqrt(x2+y2+z2).
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAPY3 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION   X, Y, Z
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
!> unnecessary overflow.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] X
!> \verbatim
!>          X is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[in] Y
!> \verbatim
!>          Y is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[in] Z
!> \verbatim
!>          Z is DOUBLE PRECISION
!>          X, Y and Z specify the values x, y and z.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup OTHERauxiliary
!
!  =====================================================================
      DOUBLE PRECISION FUNCTION DLAPY3(X,Y,Z)
      IMPLICIT NONE
!*--DLAPY372
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION X , Y , Z
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION w , xabs , yabs , zabs
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
      xabs = ABS(X)
      yabs = ABS(Y)
      zabs = ABS(Z)
      w = MAX(xabs,yabs,zabs)
      IF ( w==ZERO ) THEN
!     W can be zero for max(0,nan,0)
!     adding all three entries together will make sure
!     NaN will not disappear.
         DLAPY3 = xabs + yabs + zabs
      ELSE
         DLAPY3 = w*SQRT((xabs/w)**2+(yabs/w)**2+(zabs/w)**2)
      ENDIF
!
!     End of DLAPY3
!
      END FUNCTION DLAPY3


subroutine dTuberiaSimple
    use messages
     implicit none
     !!Variables Externas
     real:: Qd, ks, d_delta, H, z2, l, nu,sigma_km,E

     !!Variables Internas
     real:: di, hfi, vi, Qi, Hfi_1,sigma_hm
     real, parameter, dimension(1:6)::d_comercial=(/3,4,6,8,10,12/) !Tomados del ejemplo 2.5
     integer::i,j=1,k=0
     character :: option !es la opción par cambiar los ejemplos (y/n)

     real, parameter :: pi = 4 * atan (1.0), g = 9.81, p_agua = 999.1

     print *, char(10),"         <<<<1: disenio de tuberia simple>>>>",char(10)

     !Leer las variables
     l=150; ks=0.00015;Qd=0.12; H=2.2;Sigma_km=0.5+0.8+10*0.1+1; nu = 1.17E-6; E = 1.0E-5; d_delta=0.0254; z2=0
     print"('Por defecto, se cargaran datos del ejemplo 2.3'/)"
     do i = 1,10

        print datosEjercicio4, l,ks,Qd,H,Sigma_km,nu,E,d_delta
        print "('Diametros comerciales(inch): ',6f10.0)",d_comercial(:)
        print "('Diametros comerciales( mts): ',6f10.4)",d_comercial(:)*0.0254

        write(*,'(a)',ADVANCE="NO") "Desea continuar con estos datos (y/n)? "
        read(*,*) option
        if (option == 'y')then
            exit
        else
            write(*,*) char(10),"introduzca los valores(9) como un vector con el sgte formato: "
            print*,"l, ks, Qd, H, Sigma_km, nu, E, d_delta"
            read(*,*)l, ks, Qd, H, Sigma_km, nu, E, d_delta  !DEBUG
            print*, char(10)
        end if
        end do

     !Suponer hs = H-z2
     hfi= H-z2

     !Suponer d pequeño
     di=5*0.0254

     print"(/,2x,'i',2x,'k',4x,'di',4x,'hfi',4x,'j',5x,'vi',5x,'Qi',4x,'Qi>Qd',2x,'Sigma_hm')"
     !Loop
     do i = 0, 10, 1
         vi = cal_vi(l,ks,nu,g,di,hfi)
         sigma_hm = sigma_km* vi**2 /(2*g)

         !Calcular Q
         Qi=vi*pi/4 * di ** 2

         !Visualizacion 1ra convergencia
         print "(i3,1x,i2,2x,f6.4,2x,f4.2,2x,f3.0,2x,f5.3,2x,f6.4,4x,L1,5x,f5.3)",&
                 i,k, di,hfi,d_comercial(j), vi,Qi,Qi>Qd,sigma_hm

         if (Qi < Qd) then
             if (di>=d_comercial(1)*0.0254)then
                 di = d_comercial(j+1)*0.0254
                 if (j<size(d_comercial))then
                     j=j+1
                 endif
             else
                 di=di+d_delta
             endif

             cycle
         endif

         do k = 1, 100, 1
             Hfi_1 = cal_hfi_1(H,z2,Sigma_km,vi,g)
             if (abs(Hfi_1 - hfi)<E) then
                 exit
             else
                 hfi = Hfi_1
                 vi = cal_vi(l,ks,nu,g,di,hfi)
                 sigma_hm = sigma_km* vi**2 /(2*g)
                 Qi=vi*pi/4 * di ** 2
                 !Visualizacion 2da convergencia
                 print "(i3,1x,i2,2x,f6.4,2x,f4.2,2x,f3.0,2x,f5.3,2x,f6.4,4x,L1,5x,f5.3,'_')",&
                 i,k, di,hfi,d_comercial(j), vi,Qi,Qi>Qd,sigma_hm
             end if

         end do

         if (Qi > Qd) then
             exit
         else
             if (di>=d_comercial(1)*0.0254)then
                 di = d_comercial(j+1)*0.0254
                 if (j<size(d_comercial))then
                     j=j+1
                 endif
             else
                 di=di+d_delta
             endif
             hfi= H-z2
         endif

     end do

     !Respuesta
     print "(/,'Tuberia de: ', f5.0, ' inchs ('f6.4 ' mts)')",di/0.0254,di
     print "(' Caudal de: ', f7.2, ' l/s ('f6.4 ' m3/s)')",Qi*1000,Qi

     read(*,*)

     contains

     function cal_vi(l,ks,nu,g,d,hf1) !velocidad ec 2.3
         implicit none
         real :: cal_vi,l,ks,nu,g,d,hf1

         cal_vi = (2.51 * nu * sqrt(l)) / (d * sqrt(2 * g * d * hf1))
         cal_vi = (ks / (3.7 * d)) + cal_vi
         cal_vi = (-2 * sqrt(2 * g * d * hf1) / sqrt(l)) * log10(cal_vi)

     end function cal_vi

     function cal_hfi_1(H,zy,Sigma_km,vi,g)
         implicit none
         real ::cal_hfi_1,H,zy,Sigma_km,vi,g
         cal_hfi_1 = H - zy - Sigma_km * ((vi ** 2) / (2 * g))
     end function cal_hfi_1
 end subroutine dTuberiaSimple


      MODULE liprec

      INTEGER, PARAMETER :: SP=KIND(1.0), DP=KIND(1.0D0)

      INTERFACE li_gbfa

         SUBROUTINE sgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)
            INTEGER, PARAMETER :: SP=KIND(1.0)
            INTEGER LDA, N, ML, MU, INFO
            INTEGER, DIMENSION(N) :: IPVT
            REAL(SP), DIMENSION(LDA,N) :: ABD
         END SUBROUTINE sgbfa

         SUBROUTINE dgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)
            INTEGER, PARAMETER :: DP=KIND(1.0D0)
            INTEGER LDA, N, ML, MU, INFO
            INTEGER, DIMENSION(N) :: IPVT
            REAL(DP), DIMENSION(LDA,N) :: ABD
         END SUBROUTINE dgbfa

         SUBROUTINE sgbfa1 (ABD, LDA, N, ML, MU, IPVT, INFO)
            INTEGER, PARAMETER :: SP=KIND(1.0)
            INTEGER LDA, N, ML, MU, INFO
            INTEGER, DIMENSION(N) :: IPVT
            REAL(SP), DIMENSION(*) :: ABD
         END SUBROUTINE sgbfa1

         SUBROUTINE dgbfa1 (ABD, LDA, N, ML, MU, IPVT, INFO)
            INTEGER, PARAMETER :: DP=KIND(1.0D0)
            INTEGER LDA, N, ML, MU, INFO
            INTEGER, DIMENSION(N) :: IPVT
            REAL(DP), DIMENSION(*) :: ABD
         END SUBROUTINE dgbfa1

      END INTERFACE

      INTERFACE li_gbsl

         SUBROUTINE sgbsl (ABD, LDA, N, ML, MU, IPVT, B, JOB)
            INTEGER, PARAMETER :: SP=KIND(1.0)
            INTEGER LDA, N, ML, MU, JOB
            INTEGER, DIMENSION(N) :: IPVT
            REAL(SP), DIMENSION(LDA,N) :: ABD
            REAL(SP), DIMENSION(N) :: B
         END SUBROUTINE sgbsl

         SUBROUTINE sgbsl1 (ABD, LDA, N, ML, MU, IPVT, B, JOB)
            INTEGER, PARAMETER :: SP=KIND(1.0)
            INTEGER LDA, N, ML, MU, JOB
            INTEGER, DIMENSION(N) :: IPVT
            REAL(SP), DIMENSION(*) :: ABD
            REAL(SP), DIMENSION(N) :: B
         END SUBROUTINE sgbsl1

         SUBROUTINE dgbsl (ABD, LDA, N, ML, MU, IPVT, B, JOB)
            INTEGER, PARAMETER :: DP=KIND(1.0D0)
            INTEGER LDA, N, ML, MU, JOB
            INTEGER, DIMENSION(N) :: IPVT
            REAL(DP), DIMENSION(LDA,N) :: ABD
            REAL(DP), DIMENSION(N) :: B
         END SUBROUTINE dgbsl

         SUBROUTINE dgbsl1 (ABD, LDA, N, ML, MU, IPVT, B, JOB)
            INTEGER, PARAMETER :: DP=KIND(1.0D0)
            INTEGER LDA, N, ML, MU, JOB
            INTEGER, DIMENSION(N) :: IPVT
            REAL(DP), DIMENSION(*) :: ABD
            REAL(DP), DIMENSION(N) :: B
         END SUBROUTINE dgbsl1

      END INTERFACE

      INTERFACE li_gefa

         SUBROUTINE sgefa (A, LDA, N, IPVT, INFO)
            INTEGER, PARAMETER :: SP=KIND(1.0)
            INTEGER LDA, N, INFO
            INTEGER, DIMENSION(N) :: IPVT
            REAL(SP), DIMENSION(LDA,N) :: A
         END SUBROUTINE sgefa

         SUBROUTINE dgefa (A, LDA, N, IPVT, INFO)
            INTEGER, PARAMETER :: DP=KIND(1.0D0)
            INTEGER LDA, N, INFO
            INTEGER, DIMENSION(N) :: IPVT
            REAL(DP), DIMENSION(LDA,N) :: A
         END SUBROUTINE dgefa

         SUBROUTINE sgefa1 (A, LDA, N, IPVT, INFO)
            INTEGER, PARAMETER :: SP=KIND(1.0)
            INTEGER LDA, N, INFO
            INTEGER, DIMENSION(N) :: IPVT
            REAL(SP), DIMENSION(*) :: A
         END SUBROUTINE sgefa1

         SUBROUTINE dgefa1 (A, LDA, N, IPVT, INFO)
            INTEGER, PARAMETER :: DP=KIND(1.0D0)
            INTEGER LDA, N, INFO
            INTEGER, DIMENSION(N) :: IPVT
            REAL(DP), DIMENSION(*) :: A
         END SUBROUTINE dgefa1

      END INTERFACE

      INTERFACE li_gesl

         SUBROUTINE sgesl (A, LDA, N, IPVT, B, JOB)
            INTEGER, PARAMETER :: SP=KIND(1.0)
            INTEGER, INTENT(IN) :: LDA, N, JOB
            INTEGER, DIMENSION(N), INTENT(IN) :: IPVT
            REAL(SP), DIMENSION(LDA,N), INTENT(IN) :: A
            REAL(SP), DIMENSION(N), INTENT(INOUT) :: B
         END SUBROUTINE sgesl

         SUBROUTINE sgesl1 (A, LDA, N, IPVT, B, JOB)
            INTEGER, PARAMETER :: SP=KIND(1.0)
            INTEGER, INTENT(IN) :: LDA, N, JOB
            INTEGER, DIMENSION(N), INTENT(IN) :: IPVT
            REAL(SP), DIMENSION(*), INTENT(IN) :: A
            REAL(SP), DIMENSION(N), INTENT(INOUT) :: B
         END SUBROUTINE sgesl1

         SUBROUTINE dgesl (A, LDA, N, IPVT, B, JOB)
            INTEGER, PARAMETER :: DP=KIND(1.0D0)
            INTEGER, INTENT(IN) :: LDA, N, JOB
            INTEGER, DIMENSION(N), INTENT(IN) :: IPVT
            REAL(DP), DIMENSION(LDA,N), INTENT(IN) :: A
            REAL(DP), DIMENSION(N), INTENT(INOUT) :: B
         END SUBROUTINE dgesl

         SUBROUTINE dgesl1 (A, LDA, N, IPVT, B, JOB)
            INTEGER, PARAMETER :: DP=KIND(1.0D0)
            INTEGER, INTENT(IN) :: LDA, N, JOB
            INTEGER, DIMENSION(N), INTENT(IN) :: IPVT
            REAL(DP), DIMENSION(*), INTENT(IN) :: A
            REAL(DP), DIMENSION(N), INTENT(INOUT) :: B
         END SUBROUTINE dgesl1

      END INTERFACE

      END MODULE liprec


c     program DRDBLAS1
c>> 1996-06-18 DRDBLAS1 Krogh  Minor format change for C conversion.
c>> 1996-05-28 DRDBLAS1 Krogh Added external statement.
c>> 1994-10-19 DRDBLAS1 Krogh  Changes to use M77CON
c>> 1992-03-24 DRDBLAS1 CLL Removed reference to DBLE() function.
c>> 1991-12-02 DRDBLAS1 CLL
c>> 1991-07-25 DRDBLAS1 CLL
c>> 1987-12-09 DRBLAS1  Lawson  Initial Code.
c
c     Demonstrate usage of DAXPY, DCOPY, and DDOT from the BLAS
c     by computing
c     (1) p = A * b              using DDOT
c     (2) q = A * b              using DCOPY & DAXPY
c     (3) r = (A Transposed) * p using DDOT
c     (4) S = A * E              using DDOT
c     ------------------------------------------------------------------
c--D replaces "?": DR?BLAS1, ?AXPY, ?COPY, ?DOT
c     ------------------------------------------------------------------
      external DDOT
      double precision DDOT
      integer M2, M3, M4, N2, N3, N4
      parameter ( M2=5, M3=10, M4=12 )
      parameter ( N2=2, N3=3, N4=4 )
      integer I, J
      double precision A(M2,M3), E(M3,M4), S(M2,M4)
      double precision B(M3), P(M2), Q(M2), R(M3)
      double precision ZERO(1)
c
      data ZERO(1) / 0.0d0 /
      data (A(1,J),J=1,N3) /  2.0d0, -4.0d0, 3.0d0 /
      data (A(2,J),J=1,N3) / -5.0d0, -2.0d0, 6.0d0 /
      data (B(J),J=1,N3)   /  7.0d0, -3.0d0, 5.0d0 /
      data (E(1,J),J=1,N4) / -4.0d0, 2.0d0,  3.0d0, -6.0d0 /
      data (E(2,J),J=1,N4) /  7.0d0, 5.0d0, -6.0d0, -3.0d0 /
      data (E(3,J),J=1,N4) /  3.0d0, 4.0d0, -2.0d0,  5.0d0 /
c     ---------------------------------------------------------------
c
c                                  1. p = A * b using DDOT
c
      do 10 I = 1, N2
        P(I) = DDOT(N3,A(I,1),M2,B,1)
   10 continue
c
c                                  2. q = A * b using DCOPY and DAXPY
c
      call DCOPY(N2,ZERO,0,Q,1)
      do 20 J = 1, N3
        call DAXPY(N2,B(J),A(1,J),1,Q,1)
   20 continue
c
c                                  3. r = (A Transposed) * p using DDOT
c
      do 30 J = 1, N3
        R(J) = DDOT(N2,A(1,J),1,P,1)
   30 continue
c
c                                  4. S = A * E using DDOT
c
      do 50 I = 1, N2
        do 40 J = 1, N4
          S(I,J) = DDOT(N3,A(I,1),M2,E(1,J),1)
   40   continue
   50 continue
c
      print*,'DRDBLAS1..  Demo driver for DAXPY, DCOPY, and DDOT'
      print'(/'' P() = '', 7x,4f8.1)', (P(J),J=1,N2)
      print'(/'' Q() = '',7x,4f8.1)', (Q(J),J=1,N2)
      print'(/'' R() = '',7x,4f8.1)', (R(J),J=1,N3)
      print'(/'' S(,) = '')'
      do 60 I = 1,N2
         print'(''   Row '',i2,5x,4f8.1)', I,(S(I,J),J=1,N4)
   60 continue
      stop
      end