SUBROUTINE distriblay(nlay,bszlyd,bszlyt,layval,insertval,begind,endd)
!
IMPLICIT NONE
!
! Subroutine arguments
!
REAL :: begind,endd,insertval
INTEGER :: nlay
REAL,DIMENSION(nlay) :: bszlyd,bszlyt,layval
!
! Local variables
!
REAL :: depth,interval_thick,prevdepth,thick
REAL :: intersect
INTEGER :: lay
!
!     the following subroutine arguments are not used: bszlyt  jcaii  8/08/08
!
!     + + + purpose + + +
!     distributes a quantity of material over an underground interval
!     adding material in each layer in proportion to the fraction of
!     the interval that is each soil layer.

!     note: insertval and layval need the same units

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     nlay   - number of layers in soil input array
!     bszlyd - depth to bottom of soil layers (mm)
!     bszlyt - thickness of soil layers (mm)
!     layval - the layer bins that will be supplemented by added material
!     insertval - the quantity of material to be distributed into layval
!     begind - uppper depth of soil interval (mm)
!     endd   - lower depth of soil interval (mm)

!     + + + local variables + + +

!     + + + local definitions + + +
!     lay    - layer index
!     depth  - depth to bottom of present soil layer (mm)
!     prevdepth - previous cumulative depth in soil (mm)
!     thick  - thickness of soil slice (intersection of soil interval
!              and soil layer) (mm)
!     interval_thick - thickness of soil interval over which quantity
!                      of material is being inserted. (mm)

!     + + + functions called + + +

!     + + + end specifications + + +

      ! interval thickness is used repeatedly, calculate here
interval_thick = endd - begind
      ! start at soil surface
depth = 0.0
DO lay = 1,nlay
          ! set depth of layer upper boundary
  prevdepth = depth
          ! set depth of layer lower boundary
  depth = bszlyd(lay)
  IF (interval_thick.GT.0.0) THEN
          ! find thickness of intersection between layer and interval
     thick = intersect(prevdepth,depth,begind,endd)
                  ! put proportional amount in this layer
     IF (thick.GT.0.0) layval(lay) = layval(lay)                                &
                                   & + insertval*thick/interval_thick
              ! zero interval thickness
  ELSE IF ((endd.LE.depth).AND.(endd.GT.prevdepth)) THEN
                  ! interval in this layer, put all in this layer
     layval(lay) = layval(lay) + insertval
  END IF
END DO
!
END SUBROUTINE distriblay

Project Documents/Source Code Original/Distriblay.f90


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_eig2chol( n, u, lam, g )

!  The n x n matrix A has the eigendecomposition A = u * lam^2 * u^T
!  and the Cholesky decomposition A = G * G^T.  Given u and lam, this
!  routine returns G in packed format.

!  Method:
!     A = u * lam^2 * u^T = B * B^T, where B = u * lam
!     B = G * Q  ( LQ factorization)

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: u(n,n), lam(n)
real(k_dp), intent(out) :: g((n*(n+1))/2)

real(k_dp) :: B(n,n)
integer    :: j

!  form B
do j = 1, n  !  B = u * lam
   B(:,j) = u(:,j) * lam(j)
end do

call ell_bbt2chol( n, B, g )

return
end subroutine ell_eig2chol


Module Md_numerical_recipes

Use Md_Types_Numeriques
Use Md_Constantes

Implicit None

Contains

!######################################################################
Subroutine mnewt(neqt,nspec,nat,pilag,dlnn,abun,mu,b0,abuntot, &
                 ntrial,x,n,tolx,tolf,code)

! From Fortran Numerical Recipes, Chap. 9.6
! ...real variables changed to Real(8) ::
! ...included call to mprove and save of fvec and fjac
! USES lubksb,ludcmp,usrfun
! Given an initial guess x for a root in n dimensions, take ntrial Newton-Raphson steps to
! improve the root. Stop if the root converges in either summed absolute variable increments
! tolx or summed absolute function values tolf.

Implicit None
Integer,  intent(in)    :: neqt
Integer,  intent(in)    :: nspec
Integer,  intent(in)    :: nat(:,:)
Real(8), intent(inout) :: pilag(:)
Real(8), intent(inout) :: dlnn
Real(8), intent(in)    :: abun(:)
Real(8), intent(in)    :: mu(:)
Real(8), intent(in)    :: b0(:)
Real(8), intent(in)    :: abuntot

Integer,  intent(in)    :: n, ntrial
Real(8), intent(in)    :: tolf,tolx
Real(8), intent(inout) :: x(n)
Integer,  intent(inout) :: code          ! 0 : OK, 1 : error

Integer, parameter :: NP = 500		 ! Up to NP variables.
Integer  :: i, j, k, indx(NP)
Real(8) :: d, errf, errx, fjac(NP,NP), fvec(NP), p(NP)
Real(8) :: fvec_save(NP), fjac_save(NP,NP)

If (n > NP) then
  Write(*,*)' E- Too large size in mnewt'
  Stop
End if

Do k=1, ntrial
  Call usrfun(neqt,pilag,dlnn,nspec,nat,abun,mu,b0,abuntot, &
              x,n,NP,fvec,fjac) ! User Subroutine supplies function values at x in fvec
  Do i = 1, n			! *** save fvec and fjac
    fvec_save(i) = -fvec(i)
    Do j = 1, n
      fjac_save(i,j) = fjac(i,j)
    End do
  End do
  errf = 0.0d0			!  and Jacobian matrix in fjac.
  Do i = 1, n		        ! Check function convergence.
    errf = errf + dabs(fvec(i))
  End do
  If (errf <= tolf) Return
  Do i = 1, n		        ! Right-hand side of linear equations.
    p(i) = -fvec(i)
  End do
  Call ludcmp(fjac,n,NP,indx,d,code) ! Solve linear equations using LU decomposition.
  If (code == 1) Return
  Call lubksb(fjac,n,NP,indx,p)
  Call mprove(fjac_save,fjac,n,NP,indx,fvec_save,p)
  errx = 0.0d0			! Check root convergence.
  Do i = 1, n		        ! Update solution.
    errx = errx + dabs(p(i))
    x(i) = x(i) + p(i)
  End do
  If (errx <= tolx) Return
End do

End Subroutine mnewt

!######################################################################

Subroutine ludcmp(a,n,np,indx,d,code)
! From Fortran Numerical Recipes, Chap. 2.3
! ...real variables changed to Real(8) ::
! Given a matrix a(1:n,1:n), with physical dimension np by np, this routine replaces it by
! the LU decomposition of a rowwise permutation of itself. a and n are input. a is output,
! arranged as in equation (2.3.14) above; indx(1:n) is an output vector that records the
! row permutation effected by the partial pivoting; d is output as +-1 depending on whether
! the number of row interchanges was even or odd, respectively. This routine is used in
! combination with lubksb to solve linear equations or invert a matrix.
! the code variable has been added for when the code crashes at the end of the profiles at this stage

Implicit None
Integer, intent(in)     :: n, np
Integer, intent(out)    :: indx(n)
Real(8), intent(inout) :: a(np,np)
Real(8), intent(out)   :: d
Integer,  intent(inout) :: code        ! 0: OK, 1: error

Integer, parameter :: NMAX = 500 !Largest expected n
Integer  :: i, imax, j, k
Real(8) :: aamax, dum, sum, vv(NMAX)  ! vv stores the implicit scaling of each row.

imax = 0                                                 ! ad hoc initialization
d = 1.0d0                                                ! No row interchanges yet.
Do i = 1, n                                              ! Loop over rows to get the implicit scaling
  aamax = 0.0d0                                          ! information.
  Do j = 1, n
    If (dabs(a(i,j)) > aamax) aamax = dabs(a(i,j))
  End do
  !If (aamax == 0.0d0) pause 'singular matrix in ludcmp' ! No nonzero largest element.
  !If (aamax == 0.0d0) Stop 'singular matrix in ludcmp'   ! No nonzero largest element.
  If (aamax == 0.0d0) then
    code = 1
    Return
  End if
  vv(i) = 1.0d0 / aamax                                  ! Save the scaling.
End do
Do j = 1, n                                              ! This is the loop over columns of Crout's method.
  Do i = 1, j-1                                          ! This is equation (2.3.12) except for i = j.
    sum = a(i,j)
    Do k = 1, i-1
      sum = sum - a(i,k)*a(k,j)
    End do
    a(i,j) = sum
  End do
  aamax = 0.0d0                                          ! Initialize for the search for largest pivot element.
  Do i = j, n                                            ! This is i = j of equation (2.3.12) and i = j+1: ::N
    sum = a(i,j)                                         ! of equation (2.3.13).
    Do k = 1, j-1
       sum = sum-a(i,k) * a(k,j)
    End do
    a(i,j) = sum
    dum = vv(i) * dabs(sum)                               ! Figure of merit for the pivot.
    If (dum >= aamax) then                               ! Is it better than the best so far?
      imax = i
      aamax = dum
    End if
  End do
  If (j /= imax)then                                     ! Do we need to interchange rows?
    Do k = 1, n                                          ! Yes, do so...
      dum = a(imax,k)
      a(imax,k) = a(j,k)
      a(j,k) = dum
    End do
    d = -d                                               ! ...and change the parity of d.
    vv(imax) = vv(j)                                     ! Also interchange the scale factor.
  End if
  indx(j) = imax
  If (a(j,j) == 0.) a(j,j) = eps_dp
  !If the pivot element is zero the matrix is singular (at least to the precision of the algorithm).
  !For some applications on singular matrices, it is desirable to substitute eps
  !for zero.

  If(j /= n)then                                         ! Now, Finally, divide by the pivot element.
    dum = 1.0d0 / a(j,j)
    Do i = j+1, n
      a(i,j) = a(i,j) * dum
    End do
  End if
End do                                                   ! Go back for the next column in the reduction.

End Subroutine ludcmp

!######################################################################

Subroutine lubksb(a,n,np,indx,b)
! From Fortran Numerical Recipes, Chap. 2.3
! ...real variables changed to Real(8) ::
! Solves the set of n linear equations A . X = B. Here a is input, not as the matrix A but
! rather as its LU decomposition, determined by the routine ludcmp. indx is input as the
! permutation vector returned by ludcmp. b(1:n) is input as the right-hand side vector B,
! and returns with the solution vector X. a, n, np, and indx are not modified by this routine
! and can be left in place for successive calls with different right-hand sides b. This routine
! takes into account the possibility that b will begin with many zero elements, so it is efficient
! for use in matrix inversion.

Implicit None
Integer,  intent(in)    :: n, np, indx(n)
Real(8), intent(in)    :: a(np,np)
Real(8), intent(inout) :: b(n)
Integer  :: i, ii, j, ll
Real(8) :: sum

ii = 0                       ! When ii is set to a positive value, it will become the index
Do i = 1, n                  ! of the first nonvanishing element of b. We now do
  ll = indx(i)		     ! the forward substitution, equation (2.3.6). The only new
  sum = b(ll)		     ! wrinkle is to unscramble the permutation as we go.
  b(ll) = b(i)
  If (ii /= 0) then
    Do j = ii, i-1
      sum = sum - a(i,j)*b(j)
    End do
  Else if (sum /=0.) then
    ii = i		     ! A nonzero element was encountered, so from now on we will
  End if		     ! have to do the sums in the loop above.
  b(i) = sum
End do
Do i = n, 1, -1              ! Now we do the backsubstitution, equation (2.3.7).
  sum = b(i)
  Do j = i+1, n
    sum = sum - a(i,j)*b(j)
  End do
  b(i) = sum / a(i,i)	     ! Store a component of the solution vector X.
End do

End Subroutine lubksb

!######################################################################

Subroutine mprove(a,alud,n,np,indx,b,x)
! From Fortran Numerical Recipes, Chap. 2.5
! ...real variables changed to Real(8) ::
! USES lubksb
! Improves a solution vector x(1:n) of the linear set of equations A . X = B. The matrix
! a(1:n,1:n), and the vectors b(1:n) and x(1:n) are input, as is the dimension n. Also
! input is alud, the LU decomposition of a as returned by ludcmp, and the vector indx also
! returned by that routine. On output, only x(1:n) is modified, to an improved set of values.

Implicit None
Integer,  intent(in)    :: n, np, indx(n)
Real(8), intent(in)    :: a(np,np), alud(np,np), b(n)
Real(8), intent(inout) :: x(n)

Integer, parameter :: NMAX = 500	      ! Maximum anticipated value of n.
Integer  :: i, j
Real(8) :: r(NMAX)
Real(8) :: sdp

Do i=1,n		      ! Calculate the right-hand side, accumulating the residual
  sdp = -b(i)                 ! in double precision
  Do j = 1, n
    sdp = sdp + a(i,j)*x(j)
  End do
  r(i) = sdp
End do
Call lubksb(alud,n,np,indx,r) ! Solve for the error term,
Do i = 1, n                   ! and subtract it from the old solution.
  x(i) = x(i) - r(i)
End do

End subroutine mprove

!######################################################################
Subroutine usrfun(neqt,pilag,dlnn,nspec,nat,abun,mu,b0,abuntot, &
                  x,n,NP,fvec,fjac)

Implicit None
Integer,  intent(in)    :: neqt
Integer,  intent(in)    :: nspec
Integer,  intent(in)    :: nat(:,:)
Real(8), intent(inout) :: pilag(:)
Real(8), intent(inout) :: dlnn
Real(8), intent(in)    :: abun(:)
Real(8), intent(in)    :: mu(:)
Real(8), intent(in)    :: b0(:)
Real(8), intent(in)    :: abuntot

! user subroutine for mnewt
! it evaluates the functions F_i(x_j)=0 and the jacobian
Integer,  intent(in)  :: NP, n
Real(8), intent(in)  :: x(NP)
Real(8), intent(out) :: fvec(NP),fjac(NP,NP)

Integer  :: i,j,k
Real(8) :: s1,s2,s3

If(n /= neqt)then
  Write(*,*)' E- Error in mnewt usrfun'
  Stop
End if

! get current values of pi lagrange multipliers
Do i = 1, neqt-1
  pilag(i) = x(i)
End do
dlnn = x(neqt)

! evaluate functions f_i(x_j)
Do i = 1, neqt-1
  s1 = 0.0d0
  s2 = 0.0d0
  s3 = 0.0d0
  Do j = 1, nspec
    Do k = 1, neqt-1
      s1 = s1+ nat(j,i)*nat(j,k)*abun(j)*pilag(k)
    End do
    s2 = s2 + nat(j,i)*abun(j)
    s3 = s3 + nat(j,i)*abun(j)*mu(j)
  End do
  fvec(i) = s1 + s2*dlnn - b0(i) + s2 - s3
End do
s1 = 0.0d0
s2 = 0.0d0
s3 = 0.0d0
Do j = 1, nspec
  Do k = 1, neqt-1
    s1 = s1 + nat(j,k)*abun(j)*pilag(k)
  End do
  s2 = s2 + abun(j)
  s3 = s3 + abun(j)*mu(j)
End do
fvec(neqt) = s1 + (s2-abuntot)*dlnn - abuntot + s2 - s3

! evaluate derivatives of functions d[f_i(x_j)]/dx_j
Do i = 1, neqt-1
  Do k = 1, neqt-1
    fjac(i,k) = 0.0d0
    Do j = 1, nspec
      fjac(i,k) = fjac(i,k) + nat(j,i)*nat(j,k)*abun(j)
    End do
  End do
  fjac(i,neqt) = 0.0d0
  Do j = 1, nspec
    fjac(i,neqt) = fjac(i,neqt) + nat(j,i)*abun(j)
  End do
End do
Do k = 1, neqt-1
  fjac(neqt,k) = 0.0d0
  Do j = 1, nspec
    fjac(neqt,k) = fjac(neqt,k) + nat(j,k)*abun(j)
  End do
End do
fjac(neqt,neqt) = 0.0d0
Do j = 1, nspec
   fjac(neqt,neqt) = fjac(neqt,neqt) + abun(j)
End do
fjac(neqt,neqt) = fjac(neqt,neqt) - abuntot

End Subroutine usrfun

!######################################################################

End Module Md_numerical_recipes


module geq_sphax_base
  use, intrinsic :: iso_fortran_env, dp=>real64
  implicit none
  real(dp) :: asp_ratio ! rpolar / requatorial
  real(dp) :: surf_r_eq
  real(dp) :: surf_bl_a
  interface
    function pot_generic(pos) result(pot)
      import dp
      real(dp), dimension(0:3) :: pos
      real(dp), dimension(1:5) :: pot
      ! Index convention:
      !   pot: {1: V, 2: W, 3: X, 4: Y, 5: Z}
    end function
    function dpot_generic(pos) result(dpot)
      import dp
      real(dp), dimension(0:3) :: pos
      real(dp), dimension(1:5,1:2) :: dpot
      ! Index convention:
      !   dpot, first index:
      !     {1: V, 2: W, 3: X, 4: Y, 5: Z}
      !   dpot, second index: (variable w.r.t. which we differentiate)
      !     {1: r, 2: th}
    end function
  end interface
  procedure(pot_generic), pointer :: selected_pot_func => null()
  procedure(dpot_generic), pointer :: selected_dpot_func => null()
  save
contains
  function get_metric(pos) result(metric)
    real(dp), dimension(0:3,0:3) :: metric
    real(dp), dimension(0:3) :: pos
    real(dp), dimension(1:5) :: pot
    pot = selected_pot_func(pos)
    include "sphax-metric.f90"
  end function
  function geqrhs(pos, vel)
    real(dp), dimension(0:3) :: geqrhs
    real(dp), dimension(0:3) :: pos
    real(dp), dimension(0:3) :: vel
    real(dp), dimension(1:5) :: pot
    real(dp), dimension(1:5,1:2) :: dpot
    pot = selected_pot_func(pos)
    dpot = selected_dpot_func(pos)
    include "sphax-geq.f90"
  end function
  function surface_sph(pos,padding)
    real(dp) :: padding
    real(dp), dimension(0:3) :: pos
    logical :: surface_sph
    if (pos(1)/surf_r_eq - sin(pos(2))**2 - asp_ratio*cos(pos(2))**2 < padding) then
      surface_sph = .true.
    else
      surface_sph = .false.
    end if
  end function
  function surface_bl(pos,padding)
    real(dp) :: padding
    real(dp), dimension(0:3) :: pos
    logical :: surface_bl
    real(dp) :: r_sph, th_sph
    associate( r_bl => pos(1), th_bl => pos(2), a=> surf_bl_a )
      r_sph = sqrt( r_bl**2 + a**2*sin(th_bl)**2 )
      th_sph = acos( r_bl/r_sph * cos(th_bl) )
      if (r_sph/surf_r_eq - sin(th_sph)**2 - asp_ratio*cos(th_sph)**2 < padding ) then
        surface_bl = .true.
      else
        surface_bl = .false.
      end if
    end associate
  end function
end module


program main
use shoelace_implementation
implicit none
	integer :: perm(4, 24) = reshape( &
		(/ &
			1, 2, 3, 4, &
			1, 2, 4, 3, &
			1, 3, 2, 4, &
			1, 3, 4, 2, &
			1, 4, 2, 3, &
			1, 4, 3, 2, &
			2, 1, 3, 4, &
			2, 1, 4, 3, &
			2, 3, 1, 4, &
			2, 3, 4, 1, &
			2, 4, 1, 3, &
			2, 4, 3, 1, &
			3, 1, 2, 4, &
			3, 1, 4, 2, &
			3, 2, 1, 4, &
			3, 2, 4, 1, &
			3, 4, 1, 2, &
			3, 4, 2, 1, &
			4, 1, 2, 3, &
			4, 1, 3, 2, &
			4, 2, 1, 3, &
			4, 2, 3, 1, &
			4, 3, 1, 2, &
			4, 3, 2, 1 &
		/), (/ 4, 24 /) &
	)

	integer :: row
	real :: temp(2, 4)

	read (*, *) &
		temp(1, 1), temp(2, 1), &
		temp(1, 2), temp(2, 2), &
		temp(1, 3), temp(2, 3), &
		temp(1, 4), temp(2, 4)

	do row = 1, 24
		write (*, *) &
			intersect( &
				temp(1, perm(1, row)), temp(2, perm(1, row)), &
				temp(1, perm(2, row)), temp(2, perm(2, row)), &
				temp(1, perm(3, row)), temp(2, perm(3, row)), &
				temp(1, perm(4, row)), temp(2, perm(4, row))), &
			shoelace( &
				temp(1, perm(1, row)), temp(2, perm(1, row)), &
				temp(1, perm(2, row)), temp(2, perm(2, row)), &
				temp(1, perm(3, row)), temp(2, perm(3, row)), &
				temp(1, perm(4, row)), temp(2, perm(4, row)))
	end do
end program main


program test
      logical :: flag1, flag2
      integer :: a = (2*3) * 2
      integer :: b = 2 * 3 * 2
      flag1 = a == b .and. b == 12
      if (flag1) a = 10
      PRINT *,a
end program test


C     PROGRAM No. 11: QUADRATIC STRENGTH DOUBLET POTENTIAL
C     ----------------------------------------------------
C     THIS PROGRAM FINDS THE PRESSURE DISTRIBUTION ON AN ARBITRARY AIRFOIL
C        BY REPRESENTING THE SURFACE AS A FINITE NUMBER OF DOUBLET PANELS WITH
C        QUADRATIC STRENGTH (DIRICHLET B.C., PROGRAM BY STEVEN YON, 1989).
      REAL EP(400,2),EPT(400,2),PT1(400,2),PT2(400,2)
      REAL CO(400,2),A(400,400),B(400,400,3),G(400)
      REAL DL(400),U1(400),A1(400),B1(400),TH(400)

      OPEN(8,FILE='CPQD.DAT',STATUS='NEW')
      OPEN(9,FILE='AFOIL2.DAT',STATUS='OLD')

      WRITE(6,*) 'ENTER NUMBER OF PANELS'
      READ(5,*) M
      N=M+1
      WRITE(6,*) 'ENTER ANGLE OF ATTACK IN DEGREES'
      READ(5,*) ALPHA
      AL=ALPHA/57.2958

C     READ IN THE PANEL END POINTS
      DO I=1,M+1
         READ(9,*) EPT(I,1), EPT(I,2)
      END DO

C     CONVERT PANELING TO CLOCKWISE
      DO I=1,M+1
         EP(I,1)=EPT(N-I+1,1)
         EP(I,2)=EPT(N-I+1,2)
      END DO

C     ESTABLISH COORDINATES OF PANEL END POINTS
      DO I=1,M
         PT1(I,1)=EP(I,1)
         PT2(I,1)=EP(I+1,1)
         PT1(I,2)=EP(I,2)
         PT2(I,2)=EP(I+1,2)
      END DO

C     FIND PANEL ANGLES TH(J)
      DO I=1,M
         DZ=PT2(I,2)-PT1(I,2)
         DX=PT2(I,1)-PT1(I,1)
         TH(I)=ATAN2(DZ,DX)
      END DO

C     ESTABLISH COLLOCATION POINTS
      DO I=1,M
         CO(I,1)=(PT2(I,1)-PT1(I,1))/2+PT1(I,1)
         CO(I,2)=(PT2(I,2)-PT1(I,2))/2+PT1(I,2)
      END DO

C     ESTABLISH LOCATION OF ADDITIONAL COLLOCATION POINT
         WRITE(6,*) 'ENTER X COORD. OF INTERNAL POINT'
         READ(5,*) XX
         CO(M+1,1)=XX
         CO(M+1,2)=0.0

C     ESTABLISH INFLUENCE COEFFICIENTS
      DO I=1,M+1
         DO J=1,M
C           CONVERT COLLOCATION POINT TO LOCAL PANEL COORDS.
            XT=CO(I,1)-PT1(J,1)
            ZT=CO(I,2)-PT1(J,2)
            X2T=PT2(J,1)-PT1(J,1)
            Z2T=PT2(J,2)-PT1(J,2)

            X=XT*COS(TH(J))+ZT*SIN(TH(J))
            Z=-XT*SIN(TH(J))+ZT*COS(TH(J))
            X2=X2T*COS(TH(J))+Z2T*SIN(TH(J))
            Z2=0

C           SAVE PANEL LENGTHS FOR LATER USE
            IF(I.EQ.1) THEN
               DL(J)=X2
            END IF

C           FIND TH1, TH2, AND R1, R2
            R1=SQRT(X**2+Z**2)
            R2=SQRT((X-X2)**2+Z**2)
            TH1=ATAN2(Z,X)
            TH2=ATAN2(Z,X-X2)

C           COMPUTE THE INFLUENCE COEFFICIENTS IN
C           THE 'B' MATRIX (UNREDUCED).
            IF(I.EQ.J) THEN
               B(I,J,1)=0.5
               B(I,J,2)=0.5*X
               B(I,J,3)=0.5*X**2
            ELSE
               B(I,J,1)=-0.15916*(TH2-TH1)
               B(I,J,2)=-0.15916*(X*(TH2-TH1)+Z*LOG(R2/R1))
               B(I,J,3)=0.15916*((X**2-Z**2)*(TH1-TH2)
     *            -2*X*Z*LOG(R2/R1)-Z*X2)
            END IF
         END DO
      END DO

C     ADD DOUBLET GRADIENT CONDITION
      B(M+2,1,1)=0
      B(M+2,1,2)=1
      B(M+2,1,3)=0
      B(M+2,M,1)=0
      B(M+2,M,2)=1
      B(M+2,M,3)=2*DL(M)

C     ADD KUTTA CONDITION
      B(M+3,1,1)=-1
      B(M+3,1,2)=0
      B(M+3,1,3)=0
      B(M+3,M,1)=1
      B(M+3,M,2)=DL(M)
      B(M+3,M,3)=(DL(M))**2

C     BACK SUBSTITUTE THE 'B' MATRIX WITH THE
C     REGRESSION FORMULA TO GET THE COMPONENTS
C     OF THE 'A' MATRIX.
      DO I=1,M+3
         DO J=M-1,1,-1
            B(I,J,1)=B(I,J,1)+B(I,J+1,1)
            B(I,J,2)=B(I,J,2)+B(I,J+1,1)*DL(J)+B(I,J+1,2)
            B(I,J,3)=B(I,J,3)+B(I,J+1,1)
     *         *(DL(J))**2+2*B(I,J+1,2)*DL(J)
         END DO
            A(I,1)=B(I,1,1)
            A(I,2)=B(I,1,2)
         DO J=1,M
            A(I,J+2)=B(I,J,3)
         END DO
      END DO

C     ADD INFLUENCE OF WAKE AS A(I,M+3)
C     AND RHS AS A(I,M+4)
      DO I=1,M+1
         XW=CO(I,1)-PT2(M,1)
         ZW=CO(I,2)-PT2(M,2)
         DTHW=-ATAN(ZW/XW)
         A(I,M+3)=-0.15916*DTHW
         A(I,M+4)=(CO(I,1)*COS(AL)+CO(I,2)*SIN(AL))
      END DO

C     COMPLETE KUTTA COND. BY ADDING WAKE COEFF AND RHS
C     TO ROWS M+2 AND M+3
      A(M+2,M+3)=0
      A(M+2,M+4)=0
      A(M+3,M+3)=-1
      A(M+3,M+4)=0
      N=M+4

C     SOLVE FOR THE SOLUTION VECTOR OF DOUBLET STRENGTHS
      CALL MATRX(A,N,G)

C     CONVERT DOUBLET STRENGTHS, LINEAR CORRECTION
C     AND QUADRATIC CORRECTION INTO TANGENTIAL
C     VELOCITIES ALONG THE AIRFOIL SURFACE AND CP'S
C     ON EACH OF THE PANELS.

 200  CONTINUE

C     FORWARD SUBSTITUTE USING THE SOLUTION VECTOR TO
C     GET THE DOUBLET STRENGTH PARAMETERS
C     FOR EACH PANEL.
      U1(1)=G(1)
      A1(1)=G(2)
      DO I=3,M+2
         B1(I-2)=G(I)
      END DO

      DO I=1,M-1
         U1(I+1)=U1(I)+A1(I)*DL(I)+B1(I)*(DL(I))**2
         A1(I+1)=A1(I)+2*B1(I)*DL(I)
      END DO

C     THE DERIVATIVE OF THE DOUBLET STRENGTH IS THE
C     SURFACE SPEED ALONG EACH PANEL.
      DO I=1,M
         VEL=A1(I)+B1(I)*DL(I)
         CP=1-VEL**2
         WRITE(8,*) CO(I,1),' ,',CP
      END DO

      WRITE(6,*) ' '
      WRITE(6,*) 'LIFT COEFFICIENT=', G(M+3)

      STOP
      END


 SUBROUTINE lcasy6(deriv,x,jacin,j0,t3,ang,locax)
 !***********************************************************************
 !
 !****this routine sets up the local cartesyan system for element
 !
 !***********************************************************************
 IMPLICIT NONE

 !                   routine parameters

 REAL (kind=8), INTENT(IN) :: deriv(:,:),x(:,:),ang
 REAL (kind=8), INTENT(OUT) :: t3(:),j0,jacin(:,:)
 INTEGER(kind=4), INTENT(IN) :: locax

 !                   local variables

 REAL (kind=8) t1(3),t2(3),ta(3),gcova(3,2),lt

  INTERFACE
    INCLUDE 'vecpro.h'
    INCLUDE 'vecuni.h'
  END INTERFACE
 !     evaluates the local cartesian system

 !         convective base
 gcova = MATMUL(x,deriv)
 !         t3 normal to the plane
 CALL vecpro(gcova(:,1),gcova(:,2),t3)
 !         normalizes t3   &   j0 = |t3| (jacobian)
 CALL vecuni(3,t3,j0)
 SELECT CASE(locax)
 CASE (1)
   lt = (t3(2)*t3(2)+t3(3)*t3(3)) !component in th Y-Z plane
   IF( lt  < 1.0d-5) THEN         !If t3 is almost orthogonal to  Y-Z plane
     t2 = (/ -t3(3), 0d0, t3(1) /) !choose t2 orthogonal to global Y direction
     CALL vecuni(3,t2,lt)
     CALL vecpro(t2,t3,t1)
   ELSE       !         SELECT local y=t1 in the global YZ plane
     t1 = (/ 0d0, -t3(3), t3(2)  /)
     t2 = (/ lt, -t3(2)*t3(1), -t3(3)*t3(1) /)
     CALL vecuni(3,t1,lt)   !     normalizes t1 & t2
     CALL vecuni(3,t2,lt)
   END IF
 CASE (2)
   lt = (t3(3)*t3(3)+t3(1)*t3(1)) !component in th Z-X plane
   IF( lt  < 1.0d-5) THEN         !If t3 is almost orthogonal to  Z-Y plane
     t2 = (/ t3(2), -t3(1), 0d0 /) !choose t2 orthogonal to global Z direction
     CALL vecuni(3,t2,lt)
     CALL vecpro(t2,t3,t1)
   ELSE       !         SELECT local z=t1 in the global ZX plane
     t1 = (/ t3(3), 0d0, -t3(1)  /)
     t2 = (/  -t3(1)*t3(2), lt, -t3(3)*t3(2) /)
     CALL vecuni(3,t1,lt)   !     normalizes t1 & t2
     CALL vecuni(3,t2,lt)
   END IF
 CASE (3)
   lt = (t3(1)*t3(1)+t3(2)*t3(2)) !component in th X-Y plane
   IF( lt  < 1.0d-5) THEN         !If t3 is almost orthogonal to  X-Y plane
     t2 = (/ 0d0, t3(3), -t3(2) /) !choose t2 orthogonal to global X direction
     CALL vecuni(3,t2,lt)
     CALL vecpro(t2,t3,t1)
   ELSE       !         SELECT local x=t1 in the global xy plane
     t1 = (/ -t3(2), t3(1) , 0d0 /)
     t2 = (/ -t3(1)*t3(3), -t3(2)*t3(3), lt /)
     CALL vecuni(3,t1,lt)   !     normalizes t1 & t2
     CALL vecuni(3,t2,lt)
   END IF
 END SELECT
 ta = t1
 t1 =  COS(ang)*t1 + SIN(ang)*t2
 t2 = -SIN(ang)*ta + COS(ang)*t2
 !                  evaluates inverse of jacobian matrix (transpose)
 jacin(1,1) =  DOT_PRODUCT(gcova(:,2),t2)/j0     ! phi^xita . t_x
 jacin(2,1) = -DOT_PRODUCT(gcova(:,2),t1)/j0     ! phi^xita . t_y
 jacin(1,2) = -DOT_PRODUCT(gcova(:,1),t2)/j0     ! phi^eta  . t_x
 jacin(2,2) =  DOT_PRODUCT(gcova(:,1),t1)/j0     ! phi^eta  . t_y

 RETURN
 END SUBROUTINE lcasy6


! The tsunami example from _Modern Fortran_.
program tsunami

    implicit none

    integer, parameter :: nx = 100      ! grid dimension
    integer, parameter :: nt = 100      ! number of time steps
    real, parameter :: dt = 1.0         ! time step [s]
    real, parameter :: dx = 1.0         ! grid spacing [m]
    real, parameter :: c = 1.0          ! phase speed of wave [m s-1]
    integer, parameter :: icenter = 25  ! node of wave center
    real, parameter :: decay = 0.02     ! decay factor of wave shape

    integer :: i, n
    real :: h(nx)   ! wave height [m]
    real :: dh(nx)  ! change in wave height [m]

    do i = 1, nx
        h(i) = exp(-decay * (i - icenter)**2)
    end do

    print *, 0, h

    time_loop: do n = 1, nt

        dh(1) = h(1) - h(nx)

        do i = 2, nx
            dh(i) = h(i) - h(i-1)
        end do

        do i = 1, nx
            h(i) = h(i) - c * dh(i) / dx * dt
        end do

        print *, n, h

    end do time_loop

end program tsunami


      SUBROUTINE ga_niche(myid)
c#######################################################################
c
c  Implement "niching" through Goldberg''s multidimensional phenotypic
c  sharing scheme with a triangular sharing FUNCTION.  To find the
c  multidimensional distance from the best individual, normalize ALL
c  PARAMETER differences.
c
      USE ga_mod
      USE mpi_params, ONLY: master
      IMPLICIT NONE
      REAL(rprec) :: alpha, del, del2, sigshar, SUMshar, share
      INTEGER :: nniche, jj, ii, j, k, myid
      SAVE
c
c   Variable definitions:
c
c  alpha   = power law exponent for sharing function; typically = 1.0
c  del     = normalized multidimensional distance between ii and ALL
c            other members of the population
c            (equals the square root of del2)
c  del2    = sum of the squares of the normalized multidimensional
c            distance between member ii and all other members of
c            the population
c  nniche  = number of niched parameters
c  sigshar = normalized distance to be compared with del; in some sense,
c            1/sigshar can be viewed as the number of regions over which
c            the sharing function should focus, e.g. with sigshar=0.1,
c            the sharing function will try to clump in ten distinct
c            regions of the phase space.  a value of sigshar on the
c            order of 0.1 seems to work best.
c  share   = sharing function between individual ii and j
c  sumshar = sum of the sharing functions for individual ii
c
      alpha=1
      sigshar=0.1_dp
      nniche=0
      DO 33 jj=1,nparam
         nniche=nniche+nichflg(jj)
 33   CONTINUE
      IF (nniche.eq.0) THEN
         IF (myid .eq. master) THEN
            WRITE(6,1900)
            WRITE(iunit_ga_out,1900)
            CLOSE(iunit_ga_out)
         END IF
         STOP
      END IF
      DO 34 ii=1,npopsiz
         SUMshar=0
         DO 35 j=1,npopsiz
            del2=0
            DO 36 k=1,nparam
               IF (nichflg(k).ne.0) THEN
                  del2=del2+((parent(k,j)-parent(k,ii))/pardel(k))**2
               END IF
 36         CONTINUE
            del=SQRT(del2)/nniche
            IF (del.lt.sigshar) THEN
c               share=1.0-((del/sigshar)**alpha)
               share=1-(del/sigshar)
            ELSE
               share=0
            END IF
            SUMshar=sumshar+share/npopsiz
 35      CONTINUE
         IF (sumshar.ne.0.0_dp) fitness(ii)=fitness(ii)/sumshar
 34   CONTINUE

 1900 FORMAT(1x,'ERROR: iniche=1 and ALL values in nichflg array = 0'/
     1       1x,'       Do you want to niche or not?')

      END SUBROUTINE ga_niche


subroutine GLQGridCoord(latglq, longlq, lmax, nlat, nlong, extend, exitstatus)
!------------------------------------------------------------------------------
!
!   Given a maximum spherical harmonic degree lmax, this routine
!   will determine the latitude and longitude coordinates associated with
!   grids that are used in the Gauss-Legendre quadratue spherical harmonic
!   expansion routines. The coordinates are output in DEGREES.
!
!   Calling Parameters
!       IN
!           lmax        Maximum spherical harmonic degree of the expansion.
!
!       OUT
!           latglq      Array of latitude points used in Gauss-Legendre
!                       grids, in degrees.
!           longlq      Array of longitude points used in Gauss-Legendre
!                       grids, in degrees.
!           nlat        Number of latitude points.
!           nlong       Number of longitude points.
!
!       OPTIONAL (IN)
!           extend      If 1, return a grid that contains an additional column
!                       for 360 E longitude.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: PreGLQ
    use ftypes

    implicit none

    integer, intent(in) :: lmax
    integer, intent(out) :: nlat, nlong
    real(dp), intent(out) :: latglq(:), longlq(:)
    integer, intent(in), optional :: extend
    integer, intent(out), optional :: exitstatus
    real(dp) :: pi, upper, lower, zero(lmax+1), w(lmax+1)
    integer :: i, nlong_out

    if (present(exitstatus)) exitstatus = 0

    nlat = lmax + 1
    nlong = 2 * lmax + 1

    if (present(extend)) then
        if (extend == 0) then
            nlong_out = nlong
        else if (extend == 1) then
            nlong_out = nlong + 1
        else
            print*, "Error --- GLQGridCoord"
            print*, "Optional parameter EXTEND must be 0 or 1."
            print*, "Input value is ", extend
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if
    else
        nlong_out = nlong
    end if

    if (size(latglq) < nlat) then
        print*, "Error --- GLQGridCoord"
        print*, "LATGLQ must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(latglq)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(longlq) < nlong_out) then
        print*, "Error --- GLQGridCoord"
        print*, "LONGLQ must be dimensioned as ", nlong_out
        print*, "Input array is dimensioned as ", size(longlq)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    pi = acos(-1.0_dp)

    upper = 1.0_dp
    lower = -1.0_dp

    if (present(exitstatus)) then
        call PreGLQ(lower, upper, nlat, zero, w, exitstatus = exitstatus)
        if (exitstatus /= 0) return
    else
        call PreGLQ(lower, upper, nlat, zero, w)
    end if

    do i = 1, nlong_out
        longlq(i) = 360.0_dp * dble(i-1) / dble(nlong)
    end do

    do i = 1, nlat
        latglq(i) = asin(zero(i)) * 180.0_dp / pi
    end do

end subroutine GLQGridCoord


           program demo_aimag
           use, intrinsic :: iso_fortran_env, only : real_kinds, &
           & real32, real64, real128
           implicit none
           complex(kind=real32) z4
           complex(kind=real64) z8
              z4 = cmplx(1.e0, 2.e0)
              z8 = cmplx(3.e0_real64, 4.e0_real64,kind=real64)
              print *, aimag(z4), aimag(z8)
              ! an elemental function can be passed an array
              print *
              print *, [z4,z4/2.0,z4+z4,z4**3]
              print *
              print *, aimag([z4,z4/2.0,z4+z4,z4**3])
           end program demo_aimag


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  Tapenade 3.16 (master) -  9 Oct 2020 17:47
!
MODULE MOD_VARIANCE_D
  USE MOD_MEAN_D, ONLY : mean_d
  USE MOD_MATH_D, ONLY : divide_d, subtract_d
  IMPLICIT NONE
  PUBLIC :: variance_d
  PRIVATE

CONTAINS
!  Differentiation of variance in forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: b
!   with respect to varying inputs: a
!   RW status of diff variables: a:in b:out
  SUBROUTINE VARIANCE_D(a, ad, b, bd)
    IMPLICIT NONE
    real(8), DIMENSION(:), INTENT(INOUT) :: a
    real(8), DIMENSION(:), INTENT(INOUT) :: ad
    real(8), INTENT(INOUT) :: b
    real(8), INTENT(INOUT) :: bd
    real(8) :: meanval
    real(8) :: meanvald
    real(8) :: temp1
    real(8) :: temp1d
    real(8) :: temp2
    real(8) :: temp2d
    real(8) :: n
    INTEGER*8 :: i
    INTRINSIC SIZE
    INTRINSIC REAL
    INTRINSIC INT
    meanval = 0.0
    CALL MEAN_D(a, ad, meanval, meanvald)
    n = REAL(SIZE(a), 8)
    b = 0.0
    bd = 0.0_8
    DO i=1,INT(n)
      CALL SUBTRACT_D(a(i), ad(i), meanval, meanvald, temp1, temp1d)
      temp1d = 2*temp1*temp1d
      temp1 = temp1**2
      CALL DIVIDE_D(temp1, temp1d, n, temp2, temp2d)
      bd = bd + temp2d
      b = b + temp2
    END DO
  END SUBROUTINE VARIANCE_D

END MODULE MOD_VARIANCE_D


      SUBROUTINE GETGAUHER (vm,sg,veltemp,Nvhist,Nvmax,dvhist,
     &                      hh,Nhermmax,gam,ingam)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Calculate the first Nhermmax Gauss-Hermite moments from the histogram
C veltemp with spacing dvhist, using the values vm and sg for the weighting
C function. The results are returned in hh.
C
C If ingam=1, then gam is taken as input.
C If ingam=0, then gam is returned on output such that h0=1.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
C
      PARAMETER (pi = 3.14159265358979323846D0)
C
      DIMENSION veltemp(-Nvmax:Nvmax),hh(0:Nhermmax)
C
CCCCCCCCCCCCCCCCCCCC
C
C Initialize
C

      DO l=0,Nhermmax
        hh(l) = 0.0D0
      END DO
C
C Loop over the velocities
C
      DO i=-Nvhist,Nvhist
C
        vel = dvhist * DBLE(i)
        w   = (vel-vm)/sg
C
C Loop over the Gauss-Hermite moments
C
        DO l=0,Nhermmax
          hh(l) = hh(l) + (veltemp(i)*SDGAUSS(w)*H_POL(l,w))
        END DO
C
      END DO
C
C Normalize properly. The factor dvhist arises through the stepsize of the
C Euler integration. The value of gamma is determined by the constraint
C that h0=1.
C
      IF (ingam.EQ.0) THEN
        gam = hh(0) * 2.0D0 * SQRT(pi) * dvhist
      END IF
C
      DO l=0,Nhermmax
        hh(l) = hh(l) * 2.0D0 * SQRT(pi) * dvhist / gam
      END DO
C
      END

      SUBROUTINE GETGAUSSWEIGHTMOM
     &        (vm,sg,veltemp,Nvhist,Nvmax,dvhist,gw,Nmommax)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Calculate the first Nmommax Gaussian weighted moments from the histogram
C veltemp with spacing dvhist, using the values vm and sg for the weighting
C function. The results are returned in hh.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
C
      PARAMETER (pi = 3.14159265358979323846D0)
C
      DIMENSION veltemp(-Nvmax:Nvmax),gw(0:Nmommax)
C
CCCCCCCCCCCCCCCCCCCC
C
C Initialize
C
      DO l=0,Nmommax
        gw(l) = 0.0D0
      END DO
C
C Loop over the velocities
C
      DO i=-Nvhist,Nvhist
C
        vel = dvhist * DBLE(i)
        w   = (vel-vm)/sg
C
C Loop over the moments
C
        DO l=0,Nmommax
          gw(l) = gw(l) + (veltemp(i)*SDGAUSS(w)*(vel**l))
        END DO
C
      END DO
C
C Normalize properly
C
      DO l=0,Nmommax
        gw(l) = gw(l) * dvhist
      END DO
C
      END

      SUBROUTINE GETTRUEMOM (veltemp,Nvhist,Nvmax,dvhist,
     &                       allmom,Nmommax)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Calculate the first Nmommax moments from the histogram
C veltemp with spacing dvhist. The results are returned in allmom.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
C
      DIMENSION veltemp(-Nvmax:Nvmax),allmom(0:Nmommax)
C
CCCCCCCCCCCCCCCCCCCC
C
C Initialize
C
      DO l=0,Nmommax
        allmom(l) = 0.0D0
      END DO
C
C Loop over the velocities
C
      DO i=-Nvhist,Nvhist
C
        vel = dvhist * DBLE(i)
C
C Loop over the moments
C
        DO l=0,Nmommax
          allmom(l) = allmom(l) + (veltemp(i)*(vel**l))
        END DO
C
      END DO
C
C Normalize properly
C
      DO l=0,Nmommax
        allmom(l) = allmom(l) * dvhist
      END DO
C
      END

      SUBROUTINE GAUSSFIT (veltemp,Nvhist,Nvmax,dvhist,
     &                              gam,vm,sg,h12,NMC)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Calculate the normalization gam, mean vm and dispersion sg of
C the best-fitting Gaussian to the histogram veltemp with spacing dvhist.
C
C A good initial guess is sought using a random number scheme, by drawing
C NMC (vm,sg) points.
C
C The program uses an amoeba scheme which should be very robust.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
C
      PARAMETER (eps = 1.0D-10    ,
     &           Nhistmax = 10000 )
C
      DIMENSION veltemp(-Nvmax:Nvmax),vvtemp(-Nhistmax:Nhistmax),
     &          allmom(0:2)
C
C Starting simpleces for routine AMOEBA, and the function values
C in the starting simplices.
C
      DIMENSION P(3,2),Y(3),help(2)
C
      COMMON /vpcur/ vvtemp,dvhistt,gamma,Nvhistt
      COMMON /truesigcur/ sg0
C
      EXTERNAL CHI2H_2D
C
CCCCCCCCCCCCCCCCCCCC
C
C Store the velocity profile in a common block
C
      Nvhistt = Nvhist
      dvhistt = dvhist
      DO i=-Nhistmax,Nhistmax
        IF (ABS(i).LE.Nvhist) THEN
          vvtemp(i) = veltemp(i)
        ELSE
          vvtemp(i) = 0.0D0
        END IF
      END DO
C
CCCCCCCCCCCCCCCCCCCC
C
C Get the lowest order true moments
C
      CALL GETTRUEMOM (veltemp,Nvhist,Nvmax,dvhist,allmom,2)
C
C Initialize the estimates for the mean and dispersion of the best
C Gaussian fit.
C
      vm0 = allmom(1)/allmom(0)
      sg0 = SQRT((allmom(2)/allmom(0))-(vm0*vm0))
C
CCCCCCCCCCCCCCCCCCCC
C
C Draw a certain number of random points in (vm,sg). Remember
C the one with the lowest CHI2H_2D.
C
      Ndraw   = NMC
      idum    = -100
      vm      = vm0
      sg      = sg0
      help(1) = vm
      help(2) = sg
      chi2min = CHI2H_2D(help)
C
51    DO i=1,Ndraw
        help(1) = vm0 + (2.0D0 * sg0 * ((2.0D0*randraw(idum))-1.0D0))
        help(2) = 2.0D0 * sg0 * randraw(idum)
        chi2cur = CHI2H_2D(help)
        IF (chi2cur.LT.chi2min) THEN
          vm = help(1)
          sg = help(2)
          chi2min = chi2cur
        END IF
      END DO
C
CCCCCCCCCCCCCCCCCCCC
C
C Initialize the starting simplex fits
C
      epsmal = 0.2D0
      pl1    = 1.0D0 + epsmal
      xmn1   = 1.0D0 - epsmal
C
      P(1,1) = vm + (epsmal*sg)
      P(1,2) = pl1 * sg
      P(2,1) = vm - (epsmal*sg)
      P(2,2) = xmn1 * sg
      P(3,1) = vm + (epsmal*sg)
      P(3,2) = xmn1 * sg
C
C Initialize
C
      DO i=1,3
        DO j=1,2
          help(j) = P(i,j)
        END DO
        Y(i) = CHI2H_2D(help)
      END DO
C
      CALL AMOEBA(P,Y,3,2,2,eps,CHI2H_2D,iter)
C
      vm  = (P(1,1)+P(2,1)+P(3,1)) / 3.0D0
      sg  = (ABS(P(1,2))+ABS(P(2,2))+ABS(P(3,2))) / 3.0D0
C
      help(1) = vm
      help(2) = sg
      h12 = CHI2H_2D(help) - 1.0D0
      gam = gamma
C
C Start from the beginning if the found minimum does not satisfy
C h1=h2=0 to high enough accuracy.
C
      IF ((h12.GT.100.0D0*eps).AND.(Ndraw.LE.3000)) THEN
        Ndraw   = Ndraw*5
        chi2min = h12 + 1.0D0
        WRITE (*,*) 'Redraw', Ndraw
        GOTO 51
      END IF
C
      END

      REAL*8 FUNCTION CHI2H_2D (y)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Calculates the chih^2 = (h1^2) + (h2^2) for a Gaussian
C with parameters Vgau = y(1), sig = |y(2)|,
C for the VP in the common block /vpcur/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
C
      PARAMETER (Nhistmax = 10000)
C
      DIMENSION y(2),harr(0:10)
C
      DIMENSION veltemp(-Nhistmax:Nhistmax)
      COMMON /vpcur/ veltemp,dvhist,gam,Nvhist
      COMMON /truesigcur/ sg0
C
CCCCCCCCCCCCCCCCCCCC
C
C Note: it may be necessary to avoid values of gamma and sigma too
C close to zero.
C
      vm  = y(1)
      sg  = MAX(0.1D0*sg0,ABS(y(2)))
C
      CALL GETGAUHER (vm,sg,veltemp,Nvhist,Nhistmax,dvhist,
     &                harr,2,gam,0)
C
      CHI2H_2D = 1.0D0 + SQRT(MAX(0.0D0,
     &         (harr(1)**2.0D0)+(harr(2)**2.0D0) ))
C
      END

      SUBROUTINE GAUSSFITfix (veltemp,Nvhist,Nvmax,dvhist,
     &                                  vm,sg,h12,NMC)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Calculate the normalization mean vm and dispersion sg of
C the best-fitting NORMALIZED Gaussian to the histogram veltemp with
C spacing dvhist.
C
C A good initial guess is sought using a random number scheme, by drawing
C NMC (vm,sg) points.
C
C The program uses an amoeba scheme which should be very robust.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
C
      PARAMETER (eps = 1.0D-10    ,
     &           Nhistmax = 10000 )
C
      DIMENSION veltemp(-Nvmax:Nvmax),vvtemp(-Nhistmax:Nhistmax),
     &          allmom(0:2)
C
C Starting simpleces for routine AMOEBA, and the function values
C in the starting simplices.
C
      DIMENSION P(3,2),Y(3),help(2)
C
      COMMON /vpcur_FIX/ vvtemp,dvhistt,Nvhistt
      COMMON /truesigcur_FIX/ sg0
C
      EXTERNAL CHI2H_2D_FIX
C
CCCCCCCCCCCCCCCCCCCC
C
C Store the velocity profile in a common block
C
      Nvhistt = Nvhist
      dvhistt = dvhist
      DO i=-Nhistmax,Nhistmax
        IF (ABS(i).LE.Nvhist) THEN
          vvtemp(i) = veltemp(i)
        ELSE
          vvtemp(i) = 0.0D0
        END IF
      END DO
C
CCCCCCCCCCCCCCCCCCCC
C
C Get the lowest order true moments
C
      CALL GETTRUEMOM (veltemp,Nvhist,Nvmax,dvhist,allmom,2)
C
C Initialize the estimates for the mean and dispersion of the best
C Gaussian fit.
C
      vm0 = allmom(1)/allmom(0)
      sg0 = SQRT((allmom(2)/allmom(0))-(vm0*vm0))
C
CCCCCCCCCCCCCCCCCCCC
C
C Draw a certain number of random points in (vm,sg). Remember
C the one with the lowest CHI2H_2D.
C
      Ndraw   = NMC
      idum    = -100
      vm      = vm0
      sg      = sg0
      help(1) = vm
      help(2) = sg
      chi2min = CHI2H_2D_FIX(help)
C
51    DO i=1,Ndraw
        help(1) = vm0 + (2.0D0 * sg0 * ((2.0D0*randraw(idum))-1.0D0))
        help(2) = 2.0D0 * sg0 * randraw(idum)
        chi2cur = CHI2H_2D_FIX(help)
        IF (chi2cur.LT.chi2min) THEN
          vm = help(1)
          sg = help(2)
          chi2min = chi2cur
        END IF
      END DO
C
CCCCCCCCCCCCCCCCCCCC
C
C Initialize the starting simplex fits
C
      epsmal = 0.2D0
      pl1    = 1.0D0 + epsmal
      xmn1   = 1.0D0 - epsmal
C
      P(1,1) = vm + (epsmal*sg)
      P(1,2) = pl1 * sg
      P(2,1) = vm - (epsmal*sg)
      P(2,2) = xmn1 * sg
      P(3,1) = vm + (epsmal*sg)
      P(3,2) = xmn1 * sg
C
C Initialize
C
      DO i=1,3
        DO j=1,2
          help(j) = P(i,j)
        END DO
        Y(i) = CHI2H_2D_FIX(help)
      END DO
C
      CALL AMOEBA(P,Y,3,2,2,eps,CHI2H_2D_FIX,iter)
C
      vm  = (P(1,1)+P(2,1)+P(3,1)) / 3.0D0
      sg  = (ABS(P(1,2))+ABS(P(2,2))+ABS(P(3,2))) / 3.0D0
C
      help(1) = vm
      help(2) = sg
      h12 = CHI2H_2D_FIX(help) - 1.0D0
C
C Start from the beginning if the found minimum does not satisfy
C h12 = 0 to high enough accuracy.
C
      IF ((h12.GT.100.0D0*eps).AND.(Ndraw.LE.3000)) THEN
        Ndraw   = Ndraw*5
        chi2min = h12 + 1.0D0
        WRITE (*,*) 'Redraw', Ndraw
        GOTO 51
      END IF
C
      END

      REAL*8 FUNCTION CHI2H_2D_FIX (y)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Calculates the chih^2 = (h1^2) + ((h0-SQRT(2)*h2)^2) for a Gaussian
C with parameters Vgau = y(1), sig = |y(2)|,
C for the VP in the common block /vpcur_FIX/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
C
      PARAMETER (Nhistmax = 10000)
C
      DIMENSION y(2),harr(0:10)
C
      DIMENSION veltemp(-Nhistmax:Nhistmax)
      COMMON /vpcur_FIX/ veltemp,dvhist,Nvhist
      COMMON /truesigcur_FIX/ sg0
C
CCCCCCCCCCCCCCCCCCCC
C
      vm  = y(1)
      sg  = MAX(0.1D0*sg0,ABS(y(2)))
C
      CALL GETGAUHER (vm,sg,veltemp,Nvhist,Nhistmax,dvhist,
     &                harr,2,1.0D0,1)
C
      CHI2H_2D_FIX = 1.0D0 + SQRT(MAX(0.0D0,
     &      (harr(1)**2.0D0) +
     &      ((1.0D0-harr(0)+(SQRT(2.0D0)*harr(2)))**2.0D0) ))
C
      END

      REAL*8 FUNCTION SDGAUSS (x)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Returns the standard Gaussian as function of x
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
      PARAMETER (pi=3.14159265358979D0)
      SDGAUSS = (1.0D0/SQRT(2.0D0*pi)) * EXPP(-0.5D0*x*x)
      END

      REAL*8 FUNCTION EXPP(x)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Modified exponential function that will not underflow
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IF (x.GE.-500D0) THEN
        EXPP = EXP(x)
      ELSE
        EXPP = 0.0D0
      END IF
      END

      REAL*8 FUNCTION HE_POL (ll,x)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Returns the value of the Hermite polynomial He_l(x) as defined
C in Appendix A of van der Marel & Franx.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
C
      LOGICAL firstc
      DATA firstc/.TRUE./
C
      DIMENSION pfac(0:20,0:20)
      SAVE firstc,pfac
C
CCCCCCCCCCCCCCCCCCCC
C
      IF (firstc) THEN
        DO l=0,20
          dl = DBLE(l)
          DO j=l,0,-1
            IF (2*((j+l)/2).EQ.j+l) THEN
              dj = DBLE(j)
              pfacln = (0.5D0*gammaln(dl+1.0D0)) -
     &             gammaln(dj+1.0D0) - gammaln(dl-dj+1.0D0) +
     &             gammaln(0.5D0*(dl-dj+1.0D0)) -
     &             gammaln(0.5D0) + (0.5D0*(dl-dj)*LOG(2.0D0))
              pfac(l,j) = ((-1.0D0)**((l-j)/2)) * EXPP(pfacln)
            ELSE
              pfac(l,j) = 0.0D0
            END IF
          END DO
        END DO
        firstc = .FALSE.
      END IF
C
CCCCCCCCCCCCCCCCCCCC
C
      HE_POL = 0.0D0
      DO j=ll,0,-1
        HE_POL = pfac(ll,j) + (x*HE_POL)
      END DO
C
      END

      REAL*8 FUNCTION H_POL (l,x)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Returns the value of the Hermite polynomial H_l(x) as defined
C in Appendix A of van der Marel & Franx.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      IMPLICIT INTEGER*4 (i-n)
      H_POL = HE_POL(l,x*SQRT(2.0D0))
      END

      REAL*8 FUNCTION gammaln(x)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C The logarithm of the gamma function
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      PARAMETER (pi=3.14159265358979D0)
      IF (x.GE.1.0D0) THEN
        gammaln = gammln(x)
      ELSE IF (x.GE.0.0D0) THEN
        z = 1.0D0 - x
        gammaln = (LOG((pi*z)/SIN(pi*z))) - gammln(2.0D0-x)
      ELSE
        PAUSE 'x < 0 in gammaln'
      END IF
      END

      REAL*8 FUNCTION gammln(x)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C From Numerical recipes. Modified to be double precision
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      INTEGER j
      DIMENSION cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
     *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     *-.5395239384953d-5,2.5066282746310005d0/
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*log(tmp)-tmp
      ser=1.000000000190015d0
      do 11 j=1,6
        y=y+1.d0
        ser=ser+cof(j)/y
11    continue
      gammln=tmp+log(stp*ser/x)
      return
      END

      SUBROUTINE amoeba(p,y,mp,np,ndim,ftol,funk,iter)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C From Numerical Recipes. Modified to be double precision
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      INTEGER*4 iter,mp,ndim,np,NMAX,ITMAX
      REAL*8 ftol,p(mp,np),y(mp),funk
      PARAMETER (NMAX=20,ITMAX=1000)
      EXTERNAL funk
CU    USES amotry,funk
      INTEGER*4 i,ihi,ilo,inhi,j,m,n
      REAL*8 rtol,sum,swap,ysave,ytry,psum(NMAX),amotry
      iter=0
1     do 12 n=1,ndim
        sum=0.0D0
        do 11 m=1,ndim+1
          sum=sum+p(m,n)
11      continue
        psum(n)=sum
12    continue
2     ilo=1
      if (y(1).gt.y(2)) then
        ihi=1
        inhi=2
      else
        ihi=2
        inhi=1
      endif
      do 13 i=1,ndim+1
        if(y(i).le.y(ilo)) ilo=i
        if(y(i).gt.y(ihi)) then
          inhi=ihi
          ihi=i
        else if(y(i).gt.y(inhi)) then
          if(i.ne.ihi) inhi=i
        endif
13    continue
      rtol=2.0D0*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo)))
      if (rtol.lt.ftol) then
        swap=y(1)
        y(1)=y(ilo)
        y(ilo)=swap
        do 14 n=1,ndim
          swap=p(1,n)
          p(1,n)=p(ilo,n)
          p(ilo,n)=swap
14      continue
        return
      endif
C
C Possibility to write intermediate results
C
C      WRITE (*,'(I5,3F20.12)') iter,(p(ilo,j),j=1,2),y(ilo)
C
      if (iter.ge.ITMAX) then
        write (*,*) 'ITMAX exceeded in amoeba'
        return
      endif
      iter=iter+2
      ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,-1.0D0)
      if (ytry.le.y(ilo)) then
        ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,2.0D0)
      else if (ytry.ge.y(inhi)) then
        ysave=y(ihi)
        ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,0.5D0)
        if (ytry.ge.ysave) then
          do 16 i=1,ndim+1
            if(i.ne.ilo)then
              do 15 j=1,ndim
                psum(j)=0.5D0*(p(i,j)+p(ilo,j))
                p(i,j)=psum(j)
15            continue
              y(i)=funk(psum)
            endif
16        continue
          iter=iter+ndim
          goto 1
        endif
      else
        iter=iter-1
      endif
      goto 2
      END

      REAL*8 FUNCTION amotry(p,y,psum,mp,np,ndim,funk,ihi,fac)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C From Numerical Recipes. Modified to be double precision
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT REAL*8 (a-h,o-z)
      INTEGER*4 ihi,mp,ndim,np,NMAX
      REAL*8 fac,p(mp,np),psum(np),y(mp),funk
      PARAMETER (NMAX=20)
      EXTERNAL funk
CU    USES funk
      INTEGER j
      REAL*8 fac1,fac2,ytry,ptry(NMAX)
      fac1=(1.0D0-fac)/ndim
      fac2=fac1-fac
      do 11 j=1,ndim
        ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11    continue
      ytry=funk(ptry)
      if (ytry.lt.y(ihi)) then
        y(ihi)=ytry
        do 12 j=1,ndim
          psum(j)=psum(j)-p(ihi,j)+ptry(j)
          p(ihi,j)=ptry(j)
12      continue
      endif
      amotry=ytry
      return
      END

      FUNCTION randraw(idum)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   Function to compute a sequence of pseudo-random numbers in the
C   interval (0,1). 'Minimal' random number generator of Park and Miller
C   with Bays-Durham shuffle and added safeguards. idum must be negative
C   and must not be alterated on successive calls. (See Numerical
C   Recipes for more details, 2nd. Edition, it corresponds to ran). It
C   is not useful for a number of calls > 10^8.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   Declaration of local variables.
C
      INTEGER*4 idum, ia,im,iq,ir,ntab,ndiv
      REAL*8  randraw,am,epsran,rnmx
      PARAMETER (ia=16807,im=2147483647,am=1./im,iq=127773,ir=2836,
     &           ntab=32,ndiv=1+(im-1)/ntab,epsran=1.2e-7,
     &           rnmx=1.0-epsran)
      INTEGER j,k,iv(ntab),iy
C
      SAVE iv,iy
      DATA iv /ntab*0/, iy /0/
C
      IF (idum.LE.0.or.iy.EQ.0) THEN
        idum=max(-idum, 1)
        DO j=ntab+8, 1, -1
          k=idum/iq
          idum=ia*(idum-k*iq)-ir*k
          IF (idum.LT.0) idum=idum+im
          IF (j.LE.ntab) iv(j)=idum
        END DO
        iy=iv(1)
      END IF
      k=idum/iq
      idum=ia*(idum-k*iq)-ir*k
      IF (idum.LT.0) idum=idum+im
      j=1+iy/ndiv
      iy=iv(j)
      iv(j)=idum
      randraw=MIN(am*iy,rnmx)
C
      RETURN
      END


program test9
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
 use modsparse
 implicit none
 integer(kind=int32)::i
 integer(kind=int32)::nrow
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 real(kind=wp)::val
 real(kind=wp),allocatable::x(:),y(:),y1(:)
 real(kind=wp),allocatable::xa(:,:),ya(:,:),ya1(:,:)
 logical::lup=.false.
 type(coosparse)::coo
 type(crssparse)::crs

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(nrow)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 allocate(x(coo%getdim(2)),y(coo%getdim(1)),y1(coo%getdim(1)))
 allocate(xa(coo%getdim(2),3),ya(coo%getdim(1),3),ya1(coo%getdim(1),3))

 x(:) = [(i,i=1,size(x,1))]
 xa = 3
 xa(:,1) = [(i,i=1,size(x,1))]

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

 call coo%mult(1._wp,'n',x,2.5_wp,y)
 call crs%mult(1._wp,'n',x,2.5_wp,y1)
 print*,'sum ',sum(abs(y-y1))

 call coo%mult(1._wp,'n',xa,2.5_wp,ya)
 call crs%mult(1._wp,'n',xa,2.5_wp,ya1)
 print*,'sum ',sum(abs(ya-ya1))

 deallocate(x,xa,y,ya,y1,ya1)

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(nrow,lupper=.true.)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 allocate(x(coo%getdim(2)),y(coo%getdim(1)))
 allocate(xa(coo%getdim(2),3),ya(coo%getdim(1),3))

 x(:) = [(i,i=1,size(x,1))]
 xa = 3
 xa(:,1) = [(i,i=1,size(x,1))]

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%sort()
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

 y=1.7
 y1=y
 call coo%mult(1._wp,'n',x,2.5_wp,y)
 call crs%mult(1._wp,'n',x,2.5_wp,y1)
 print*,'sum ',sum(abs(y-y1))

 ya=1.7
 ya1=ya
 call coo%mult(1._wp,'n',xa,2.5_wp,ya)
 call crs%mult(1._wp,'n',xa,2.5_wp,ya1)
 print*,'sum ',sum(abs(ya-ya1))

 deallocate(x,xa,y,ya,y1,ya1)
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(nrow,lupper=.true.)

 call coo%setsymmetric()

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 allocate(x(coo%getdim(2)),y(coo%getdim(1)))
 allocate(xa(coo%getdim(2),3),ya(coo%getdim(1),3))

 x(:) = [(i,i=1,size(x,1))]
 xa = 3
 xa(:,1) = [(i,i=1,size(x,1))]

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%sort()
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

 y=1.7
 y1=y
 call coo%mult(1._wp,'n',x,2.5_wp,y)
 call crs%mult(1._wp,'n',x,2.5_wp,y1)
 print*,'sum ',sum(abs(y-y1))

 ya=1.7
 ya1=ya
 call coo%mult(1._wp,'n',xa,2.5_wp,ya)
 call crs%mult(1._wp,'n',xa,2.5_wp,ya1)
 print*,'sum ',sum(abs(ya-ya1))

end program


      SUBROUTINE TB01TY( MODE, IOFF, JOFF, NROW, NCOL, SIZE, X, LDX,
     $                   BVECT )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     Balances the rows (MODE .EQ. 0) or columns (MODE .NE. 0) of the
C     (NROW x NCOL) block of the matrix X with offset (IOFF,JOFF), i.e.
C     with first (top left) element (IOFF + 1,JOFF + 1).  Each non-
C     zero row (column) is balanced in the sense that it is multiplied
C     by that integer power of the base of the machine floating-point
C     representation for which the sum of the absolute values of its
C     entries (i.e. its 1-norm) satisfies
C
C        (SIZE / BASE) .LT. ABSSUM .LE. SIZE
C
C     for SIZE as input.  (Note that this form of scaling does not
C     introduce any rounding errors.)  The vector BVECT then contains
C     the appropriate scale factors in rows (IOFF + 1)...(IOFF + NROW)
C     (columns (JOFF + 1)...(JOFF + NCOL) ).  In particular, if the
C     I-th row (J-th column) of the block is 'numerically' non-zero
C     with 1-norm given by BASE**(-EXPT) for some real EXPT, then the
C     desired scale factor (returned as element IOFF + I (JOFF + J) of
C     BVECT) is BASE**IEXPT, where IEXPT is the largest integer .LE.
C     EXPT: this integer is precisely the truncation INT(EXPT) except
C     for negative non-integer EXPT, in which case this value is too
C     high by 1 and so must be adjusted accordingly.  Finally, note
C     that the element of BVECT corresponding to a 'numerically' zero
C     row (column) is simply set equal to 1.0.
C
C     For efficiency, no tests of the input scalar parameters are
C     performed.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           IOFF, JOFF, LDX, MODE, NCOL, NROW
      DOUBLE PRECISION  SIZE
C     .. Array Arguments ..
      DOUBLE PRECISION  BVECT(*), X(LDX,*)
C     .. Local Scalars ..
      DOUBLE PRECISION  ABSSUM, DIV, EPS, EXPT, SCALE, TEST
      INTEGER           BASE, I, IEXPT, J
C     .. External Functions ..
      DOUBLE PRECISION  DASUM, DLAMCH
      EXTERNAL          DASUM, DLAMCH
C     .. External Subroutines ..
      EXTERNAL          DSCAL
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, INT, LOG
C     .. Executable Statements ..
C
      BASE = DLAMCH( 'Base' )
      EPS  = DLAMCH( 'Epsilon' )
C
      DIV = ONE/LOG( DBLE( BASE ) )
      IF ( MODE.NE.0 ) THEN
C
C        Balance one column at a time using its column-sum norm.
C
         DO 10 J = JOFF + 1, JOFF + NCOL
            ABSSUM = DASUM( NROW, X(IOFF+1,J), 1 )/ABS( SIZE )
            TEST = ABSSUM/DBLE( NROW )
            IF ( TEST.GT.EPS ) THEN
C
C              Non-zero column: calculate (and apply) correct scale
C              factor.
C
               EXPT = -DIV*LOG( ABSSUM )
               IEXPT = INT( EXPT )
               IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) )
     $             IEXPT = IEXPT - 1
               SCALE = DBLE( BASE )**IEXPT
               BVECT(J) = SCALE
               CALL DSCAL( NROW, SCALE, X(IOFF+1,J), 1 )
            ELSE
C
C              'Numerically' zero column: do not rescale.
C
               BVECT(J) = ONE
            END IF
   10    CONTINUE
C
      ELSE
C
C        Balance one row at a time using its row-sum norm.
C
         DO 20 I = IOFF + 1, IOFF + NROW
            ABSSUM = DASUM( NCOL, X(I,JOFF+1), LDX )/ABS( SIZE )
            TEST = ABSSUM/DBLE( NCOL )
            IF ( TEST.GT.EPS ) THEN
C
C              Non-zero row: calculate (and apply) correct scale factor.
C
               EXPT = -DIV*LOG( ABSSUM )
               IEXPT = INT( EXPT )
               IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) )
     $             IEXPT = IEXPT - 1
C
               SCALE = DBLE( BASE )**IEXPT
               BVECT(I) = SCALE
               CALL DSCAL( NCOL, SCALE, X(I,JOFF+1), LDX )
            ELSE
C
C              'Numerically' zero row: do not rescale.
C
               BVECT(I) = ONE
            END IF
   20    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of TB01TY ***
      END


program main

  implicit none

  complex(kind(1d0)), allocatable :: poly(:),roots(:),coeffs(:,:),allroots(:,:)
  integer, allocatable :: iterations(:)
  double precision, allocatable :: res(:,:)
  double precision :: time

  integer :: ii,jj,kk,ll,mm,N,zero,flag
  integer :: clock_start,clock_end,clock_rate

  open (unit=8, file='poly.txt', status='unknown')
  open (unit=9, file='roots.txt', status='unknown')
  open (unit=10, file='errors.txt', status='unknown')

    	N = 10

	allocate(poly(N+1),roots(N),coeffs(N,3),allroots(N,2),iterations(N),res(N,6))

	call cnormalpoly(N,poly(2:N+1))
	poly(1) = complex(1d0,0d0)

	do kk=1,N+1
		write(8,*) dble(poly(kk)),dimag(poly(kk))
	end do

	CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate)
	CALL SYSTEM_CLOCK(COUNT=clock_start)

	call ZAVW2(0,N,1,POLY,COEFFS,ROOTS,ITERATIONS,FLAG)
	call RESCHECK(0,N,1,1,POLY(2:N+1)/poly(1),COEFFS,ROOTS,ALLROOTS,RES)

	CALL SYSTEM_CLOCK(COUNT=clock_end)
	time = dble(clock_end - clock_start)/dble(clock_rate)
	write (*,*) "Run time =", time

	do kk=1,N
		write(10,*) res(kk,:)
		write(9,*) dble(allroots(kk,2)),dimag(allroots(kk,2))
	end do

   	deallocate(poly,roots,coeffs,allroots,iterations,res)

  close(8)
  close(9)
  close(10)

end program main


cc Copyright (C) 2009: Zydrunas Gimbutas and Hong Xiao
cc Contact: Zydrunas Gimbutas <gimbutas@cims.nyu.edu>
cc          Hong Xiao <hxiao@ucdavis.edu>
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       Interpolation and quadratures for smooth functions on a tetrahedron
c
c       All quadratures are accurate to quad precision
c       All weights are positive and inside the standard tetrahedron
c
c       (-1,-1/Sqrt[3],-1/Sqrt[6]), (0,2/Sqrt[3],-1/Sqrt[6]),
c       (1,-1/Sqrt[3],-1/Sqrt[6]),  and (0,0,3/Sqrt[6])
c
c       Input:
c
c       n - the interpoation order (must not exceed 10)
c
c       Output:
c
c       fort.11 - quadrature nodes and weights
c       fort.12 - quadrature nodes in gnuplot compatible format
c       fort.14 - standard tetrahedron as constructed
c                   in gnuplot compatible format
c
c       in gnuplot:
c
c       splot 'fort.14' w l, 'fort.12'
c
c
c
        implicit real *8 (a-h,o-z)
        dimension rnodes(3,1000),weights(1000)
        dimension rints(1000),z(3),pols(1000)
        dimension work(100000),vert(3,4)
c
c
        call prini(6,13)
c
c       SET ALL PARAMETERS
c
        PRINT *, 'ENTER mmax (1..10)'
        READ *, mmax
c
        call prinf('mmax=*',mmax,1)
c
c

c
c       ... retrieve the quadrature rule
c
        call tetraintq(mmax,rnodes,weights,numnodes)
c
        call prinf('nummodes=*',numnodes,1)
        call prin2('rnodes=*',rnodes,3*numnodes)
        call prin2('weights=*',weights,numnodes)
c
        d=0
        do i=1,numnodes
        d=d+weights(i)
        enddo
c
        call prin2('sum of weights=*',d,1)
c
c       ... plot the standard tetrahedron
c

        vert(1,1)=-1
        vert(2,1)=-1/sqrt(3.0d0)
        vert(3,1)=-1/sqrt(6.0d0)
c
        vert(1,2)=0
        vert(2,2)=2/sqrt(3.0d0)
        vert(3,2)=-1/sqrt(6.0d0)
c
        vert(1,3)=1
        vert(2,3)=-1/sqrt(3.0d0)
        vert(3,3)=-1/sqrt(6.0d0)
c
        vert(1,4)=0
        vert(2,4)=0
        vert(3,4)=3/sqrt(6.0d0)
c

c
        write(14,*) vert(1,1),vert(2,1),vert(3,1)
        write(14,*) vert(1,2),vert(2,2),vert(3,2)
        write(14,*) vert(1,3),vert(2,3),vert(3,3)
        write(14,*) vert(1,1),vert(2,1),vert(3,1)
        write(14,*)
c
        write(14,*) vert(1,1),vert(2,1),vert(3,1)
        write(14,*) vert(1,4),vert(2,4),vert(3,4)
        write(14,*)
        write(14,*) vert(1,2),vert(2,2),vert(3,2)
        write(14,*) vert(1,4),vert(2,4),vert(3,4)
        write(14,*)
        write(14,*) vert(1,3),vert(2,3),vert(3,3)
        write(14,*) vert(1,4),vert(2,4),vert(3,4)
        write(14,*)
c
c
c       ... dump the nodes into a file
c
        write(11,*) numnodes
        do i=1,numnodes
        write(11,1020) rnodes(1,i),rnodes(2,i),rnodes(3,i),weights(i)
        write(12,*) rnodes(1,i),rnodes(2,i),rnodes(3,i)
        enddo
 1010   format(i2)
 1020   format(4(e21.15,2x))
c

c
c       construct the matrix of values of the orthogonal polynomials
c       at the user-provided nodes
c
        npols=(mmax+1)*(mmax+2)*(mmax+3)/6
c
c       adjust to somewhat arbitrary scaling in ortho3eva.f
c
        scale = 2.0d0 * sqrt(2.0d0) / 3.0d0
c
        d=0
        do i=1,numnodes
        d=d+weights(i)
        enddo

        do i=1,numnodes
        weights(i)=weights(i)/d * scale
        enddo

c
        do 1200 j=1,npols
        rints(j)=0
 1200 continue
c
c
        do 2400 i=1,numnodes
c
        z(1)=rnodes(1,i)
        z(2)=rnodes(2,i)
        z(3)=rnodes(3,i)
c
        call symeval(itype,mmax,z(1),z(2),z(3),pols,dersx,dersy,dersz)
c
        do 2200 j=1,npols
c
        rints(j)=rints(j)+weights(i)*pols(j)

 2200 continue

 2400 continue
c
c
        call prin2('rints=*',rints,npols)
c
        vol = 2.0d0 * sqrt(2.0d0) / 3.0d0
c
        d=0
        d=(rints(1)-sqrt(vol))**2
        do i=2,npols
        d=d+rints(i)**2
        enddo
c
        d=sqrt(d)/npols
c
        call prin2('error=*',d,1)
c
        stop
        end
c
c
c
c
c
        subroutine symeval(itype,mmax,x,y,z,polsout,dersx,dersy,dersz)
        implicit real *8 (a-h,o-z)
        dimension z1(3),polsout(1),dersx(1),dersy(1),dersz(1)
c
        dimension polsout1(10 000),
     $       dersx1(10 000),dersy1(10 000),dersz1(10 000)
        dimension work(100 000)
c
        dimension v(4 000 000), v0(4 000 000), rnorms(10000)
        data ifinit/0/
c
        save
c
c        evaluate all polynomials
c
        z1(1)=x
        z1(2)=y
        z1(3)=z
c
        npols7=(mmax+1)*(mmax+2)*(mmax+3)/6
c
        scale=1
c
        if(itype .eq. 1)
     1    call ortho3eva4
     2       (mmax,z1,polsout1,dersx1,dersy1,dersz1,work)
c
        if(itype .eq. 0)
     1    call ortho3eva(mmax,z1,polsout1,work)
c
        if(itype .eq. 0) goto 4400
c
        do 4200 i=1,npols7
c
        polsout(i)=polsout1(i) *scale
        dersx(i)=dersx1(i) *scale
        dersy(i)=dersy1(i) *scale
        dersz(i)=dersz1(i) *scale
c
 4200 continue
      return
c
        return
c
 4400 continue
c
        do 4600 i=1,npols7
c
        polsout(i)=polsout1(i) *scale
c
 4600 continue
      return
c
      return
c
c
c
        entry symevalget(mmax,ncolsout)
c
        npolsout=(mmax+1)*(mmax+2)*(mmax+3)/6
        npols7=npolsout
c
        return
        end
c
c
c
c
c


! { dg-do run }
! Check the fix for PR28947, in which the mechanism for dealing
! with matmul (a, transpose (b)) would cause wrong results for
! a having a rank == 1.
!
! Contributed by Harald Anlauf  <anlauf@gmx.de>
!
program gfcbug40
  implicit none

  real :: h(3,3), mat(2,3)

  h(:,:) = - HUGE (1.0)/4       ! Preset unused elements suitably...

  h(3,:) = 0
  h(3,3) = 1
  mat(:,:) = 1
  h(3,:) = h(3,:) + matmul (matmul (h(3,:), transpose (mat)), mat)

  if (any (h(3,:) .ne. (/2.0, 2.0, 3.0/))) STOP 1

end program gfcbug40


! calculate bulk's energy band using wannier TB method
  subroutine ek_bulk_polar

     use mpi
     use para

     implicit none

     integer :: ik, i, j
     integer :: nkx, nky
	  integer :: knv3
     integer :: ierr
     integer :: nktheta
     integer :: nkr
     real(Dp) :: k(3)
     real(dp) :: kx
     real(dp) :: ky
     real(dp) :: kz
     real(dp) :: ktheta
     real(dp) :: kr
     real(Dp) :: W(Num_wann)
     real(dp) :: krmax
     real(dp), allocatable :: kxy(:,:)
     real(dp), allocatable :: krtheta(:,:)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     ! eigen value of H
	  real(dp), allocatable :: eigv(:,:)
	  real(dp), allocatable :: eigv_mpi(:,:)

     nktheta= 50
     nkr= Nk
     knv3= nktheta*nkr
     allocate( kxy(2, knv3))
     allocate( krtheta(2, knv3))
     allocate( eigv    (4, knv3))
     allocate( eigv_mpi(4, knv3))
     kxy = 0d0
     krtheta = 0d0
	  eigv    = 0d0
	  eigv_mpi= 0d0

     krmax= 0.2d0
     kz= 0d0
     ik =0

     do i= 1, nktheta
        ktheta= 2d0*pi*(i-1)/nktheta
        do j= 1, nkr
           kr= krmax*(j-1)/nkr
           ik =ik +1
           kxy(1, ik)= kr*cos(ktheta)
           kxy(2, ik)= kr*sin(ktheta)
           krtheta(1, ik)= ktheta
           krtheta(2, ik)= kr
        enddo
     enddo

     do ik= 1+cpuid, knv3, num_cpu
	     if (cpuid==0) print * , ik

        k(1:2) = kxy(:, ik)
        k(3)= kz

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk(k, Hamk_bulk)

        !> diagonalization by call zheev in lapack
        W= 0d0
        call eigensystem_c( 'N', 'U', Num_wann ,Hamk_bulk, W)

        eigv(:, ik)= W(55:58)

     enddo

     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)

     if (cpuid==0)then
        open(unit=14, file='bulkek_polar.dat')
        do ik=1, knv3
           write(14, '(1000f19.9)')krtheta(:, ik), eigv_mpi(:, ik)
        enddo
        close(14)
     endif

   return
   end subroutine ek_bulk_polar