C     LAST UPDATE 29/09/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FDEBYE(X,A,Y,DYDA)
      IMPLICIT NONE
C
C Purpose: Y(X;A) is the Debye approximation to the intensity transform
C          for chain molecules.
C          of A: A(1) = I(0),  A(2) = Origin,  A(3) = 1/Rg
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      DOUBLE PRECISION TINY
      PARAMETER(TINY=1.0D-10)
C
C Arguments:
C
      DOUBLE PRECISION A(*),DYDA(*)
      DOUBLE PRECISION X,Y
C
C Local variables:
C
      DOUBLE PRECISION ARG,ARG2,ARG4,EX,FAC,DARG
C
C-----------------------------------------------------------------------
      IF(A(3).LT.TINY)A(3) = TINY
      ARG = (X-A(2))/A(3)
      ARG2 = ARG*ARG
      IF(ARG2.LT.TINY)THEN
         Y = A(1)
         DYDA(1) = 1.0D0
         DYDA(2) = 0.0D0
         DYDA(3) = 0.0D0
      ELSE
         ARG4 = ARG2*ARG2
         EX = EXP(-ARG2)
         FAC = 2.0D0*(EX-1.0D0+ARG2)
         Y = A(1)*FAC/ARG4
         DYDA(1) = FAC/ARG4
         DARG = 2.0D0*A(1)*((2.0D0/ARG2)*(1.0D0-EX)-EX-1.0D0)/ARG4
         DYDA(2) = -2.0D0*ARG*DARG/A(3)
         DYDA(3) = -2.0D0*ARG2*DARG/A(3)
      ENDIF
C
      RETURN
      END


!===============================================================================
!
!*** 				INITIAL CONDITIONS			     ***
!
!-------------------------------------------------------------------------------
!Subroutine for initial conditions functions for density, velocity, and pressure
!& as a function of x.
!-------------------------------------------------------------------------------
subroutine init_conds(x,y,z,rho,ux,uy,uz,p)
	use constants								!Tells program to use global constants
	implicit none

		Real*8, intent(in) :: x,y,z
		Real*8, intent(out) :: rho,ux,uy,uz,p
		Real*8 :: r_xy							!Radius in x-y plane
		Real*8 :: delx,dely,delz					!Ranges in x, y and z for the maximum range limit
		Real*8 :: lowbound,midbound,upbound				!Bounds for ranges in initial conditions
		Real*8 :: x0,y0,z0						!x, y, and z coordinates of centre of high pressure region
		Real*8 :: rmax							!Maximum radius of high pressure region

!	Cells format: 	cells(i,j,k,1:23) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z,grad_ux,grad_uy,grad_uz, &
!						& grad_p_x,grad_p_y,grad_p_z	/)

!	Set x0, y0 and z0 to be centre of system:
	x0=0.5d0
	y0=0.5d0
	z0=0.5d0

!	Set max radius of high pressure region:
	rmax=0.50d0/2.d0

!	Set radius:
	r_xy = Sqrt((x-x0)**2+(y-y0)**2+(z-z0)**2)
!	r_xy = Sqrt(x**2+y**2)

!	Set axis lengths and calculate lower bound, mid-pont, and upper bound:
	delx=xrangeMax-xrangeMin
	dely=yrangeMax-yrangeMin
	delz=zrangeMax-zrangeMin

	lowbound=0.d0
	midbound=0.5d0
	upbound=Sqrt(delx**2+dely**2+delz**2)

!Sets values of pressure, x-velocity, and density according to starting conditions for 2D Sod Shock
	If ((r_xy>=0.d0).and.(r_xy<rmax)) then
		rho=1.d0
		ux=0.d0
		uy=0.d0
		uz=0.d0
		p=1.d0
	else if ((r_xy>=rmax)) then
		rho=0.125d0
		ux=0.d0
		uy=0.d0
		uz=0.d0
		p=0.1d0
	else
		Print*,"Invalid coordinate! Program will terminate!"		!Exits program if x lies outside of 1 to 0 range
		STOP
	endif

end subroutine init_conds
!===============================================================================


program Gauss_shear_distribution

  use fieldinfo_
  use sub_
  implicit none

  integer :: idum,n,irun
  real, pointer ::  clkappa(:),clshear(:)
  real, pointer :: pos(:,:),kappa(:,:)
  complex, pointer :: sdata(:),shear(:,:)
  character :: outfdat*100,outfpow*100,crun*10,pcond*1

  call getarg(1,outfdat)
  call getarg(2,outfpow)
  call getarg(3,crun)
  read(crun,*) irun
  call getarg(4,pcond)

  call binninginit
  call makegashear(irun,shear,kappa,pcond)
  call calcpow_scalar(kappa,clkappa)
  deallocate(kappa)
  call calcpow(shear,clshear)
  call outinitpow(outfpow,clkappa,clshear)
  idum=-1
  call randist(pos,idum)
  call shearassign(shear,pos,sdata)
  deallocate(shear)
  call outsheardat(outfdat,pos,sdata)

contains

  subroutine makegashear(nreal,shear,kappa,pcond)

    use fieldinfo_
    use sub_

    implicit none

    integer, intent(in) :: nreal
    integer ::  i,j,ic,jc,i1,j1,np,idum,nn(2),fac
    real, pointer ::  g1(:,:),g2(:,:),ka(:,:),kappa(:,:)
    complex, pointer ::  shear(:,:)
    real :: clk,elr,eli,blr,bli,labs,lx,ly,area,c1,s1,c2,s2,rad1f,rad2f
    character, intent(in) :: pcond*1

    integer, parameter :: nin=69
    real :: x(nin),y(nin),y2(nin)
    real, parameter :: d2nl=1.e30
    character(100) :: infcl='clin.dat'

    idum=-nreal-1
    if (pcond=='y') then
       fac=1
       write(*,*) 'Make a Gaussian Shear Field'
    else
       fac=2
       write(*,*) 'To break periodic boundary condition, &
            make a larger size Gaussian Shear Field and &
            use a part of it'
    endif
    write(*,*) 'initial seed: ',idum

    nn(1)=ni*fac
    nn(2)=nj*fac
    rad1f=rad1*fac
    rad2f=rad2*fac
    area=rad1f*rad2f

    allocate(g1(nn(1)*2,nn(2)),g2(nn(1)*2,nn(2)),ka(nn(1)*2,nn(2)))

    ka=0.
    g1=0.
    g2=0.

    open(1,file=infcl,status='old')
    do n=1,nin
       read(1,*) x(n),y(n)
       y(n)=y(n)/x(n)/x(n)*(2.*pi)
    enddo
    close(1)
    call spline(x,y,nin,d2nl,d2nl,y2)

    do j=1,nn(2)
       j1 = j-1
       if (j1>nn(2)/2)  j1 = j1 - nn(2)
       do i=1,nn(1)/2+1
          i1 = i-1
          if ((i==1).and.(j==1)) cycle
          if ((i==1).and.(j>nn(2)/2)) cycle
          lx=float(i1)/(rad1f)*(2.*pi)
          ly=float(j1)/(rad2f)*(2.*pi)
          labs=sqrt(lx*lx+ly*ly)
          c1=lx/labs
          s1=ly/labs
          c2=c1*c1-s1*s1
          s2=2*c1*s1

          call splint(x,y,y2,nin,labs,clk)

          elr=sqrt(clk/2.)*normsinv(dble(ran2(idum)))*sqrt(area)
          eli=sqrt(clk/2.)*normsinv(dble(ran2(idum)))*sqrt(area)

          blr=0.
          bli=0.

          ka(2*i-1,j) = elr
          ka(2*i,j) = eli
          g1(2*i-1,j) = c2*elr - s2*blr
          g1(2*i,j)   = c2*eli - s2*bli
          g2(2*i-1,j) = s2*elr + c2*blr
          g2(2*i,j)   = s2*eli + c2*bli

          if (((i1==0).or.(i1==nn(1)/2)).and.((j1==0).or.(j1==nn(2)/2))) then
             ka(2*i,j) = 0.
             g1(2*i,j) = 0.
             g2(2*i,j) = 0.
          endif

          ic = mod(nn(1)-i1,nn(1))+1
          jc = mod(nn(2)-j1,nn(2))+1
          ka(2*ic-1,jc) = ka(2*i-1,j)
          ka(2*ic,jc) = -ka(2*i,j)
          g1(2*ic-1,jc) =  g1(2*i-1,j)
          g1(2*ic,jc)   = -g1(2*i,j)
          g2(2*ic-1,jc) =  g2(2*i-1,j)
          g2(2*ic,jc)   = -g2(2*i,j)
       enddo
    enddo

    call fourn(ka,nn,2,1)
    call fourn(g1,nn,2,1)
    call fourn(g2,nn,2,1)

    allocate(kappa(ni,nj))

    do j=1,nj
       do i=1,ni
          kappa(i,j)=ka(2*i-1,j)/area
       enddo
    enddo
    deallocate(ka)

    allocate(shear(ni,nj))
    do j=1,nj
       do i=1,ni
          shear(i,j)=cmplx(g1(2*i-1,j),g2(2*i-1,j))/area
       enddo
    enddo
    deallocate(g1,g2)

  end subroutine makegashear

  subroutine shearassign(shear,pos,sdata)

    use fieldinfo_

    implicit none

    integer :: i,j,n
    real, pointer :: pos(:,:)
    complex, pointer :: shear(:,:),sdata(:)

    allocate(sdata(ntot))
    do n=1,ntot
       i=int(pos(n,1))+1
       j=int(pos(n,2))+1
       sdata(n)=shear(i,j)
    enddo

  end subroutine shearassign

end program Gauss_shear_distribution


! Ode solver
!
! Adapted from Numerical Recipes 77

submodule (solver) solver_sm

    real(8), parameter :: pi = 4*atan(1.0d0)
    real(8), parameter :: two_pi = 2*pi
    real(8), allocatable, target :: xp_data(:), yp_data(:,:)
    real(8), allocatable, target :: x_error(:,:)

contains
!
!   Cash-Karp - an adaptive Runge-Kutta method
!   see https://en.wikipedia.org/wiki/Cash%E2%80%93Karp_method
    module function rk_cash_karp(h,t,x,fp) result(xout)
        real(8), intent(in)             :: h, t
        real(8), intent(in), contiguous :: x(:,:)
        procedure(f_p), pointer         :: fp
        real(8)                         :: xout(size(x,1),size(x,2))
        real(8), dimension(size(x,1),size(x,2)) :: k1, k2, k3, k4, k5, k6
        real(8) :: a2,a3,a4,a5,a6,b21,b31,b32,b41,b42,b43,b51,b52,b53
        real(8) :: b54,b61,b62,b63,b64,b65,c1,c3,c4,c6,dc1,dc3,dc4,dc5,dc6

        parameter (a2=1/5.0d0, a3=3/10.0d0, a4=3/5.0d0, a5=1.0d0 ,a6=7/8.0d0,                               &
                   b21=1/5.0d0,                                                                             &
                   b31=3/40.0d0, b32=9/40.0d0,                                                                  &
                   b41=.3, b42=-.9, b43=1.2,                                                                &
                   b51=-11./54., b52=2.5, b53=-70./27., b54=35./27.,                                        &
                   b61=1631./55296.,b62=175./512., b63=575./13824.,b64=44275./110592.,b65=253./4096.,       &
                   c1=37./378., c3=250./621., c4=125./594., c6=512./1771.,                                  &
                   dc1=c1-2825./27648., dc3=c3-18575./48384., dc4=c4-13525./55296., dc5=-277./14336., dc6=c6-.25)

        k1 = h*fp(t         , x   )
        k2 = h*fp(t + a2*h  , x + b21*k1  )
        k3 = h*fp(t + a3*h  , x + b31*k1 + b32*k2  )
        k4 = h*fp(t + a4*h  , x + b41*k1 + b42*k2 + b43*k3   )
        k5 = h*fp(t + a5*h  , x + b51*k1 + b52*k2 + b53*k3 + b54*k4   )
        k6 = h*fp(t + a6*h  , x + b61*k1 + b62*k2 + b63*k3 + b64*k4 + b65*k5   )
        xout = x + c1*k1 + c3*k3 + c4*k4 + c6*k6
        x_error = dc1*k1 + dc3*k3 + dc4*k4 + dc5*k5 + dc6*k6
    end function rk_cash_karp

    module function rk_get_error() result(r)
        real(8), dimension(:,:), pointer :: r
        if (allocated(x_error)) then
            r => x_error
        else
            nullify(r)
        end if
    end function rk_get_error

    ! Explicit 4th order Runge-Kutta method
    module function rk_exp4(h,t,x,fp) result(xout)
        real(8), intent(in)             :: h, t
        real(8), intent(in), contiguous :: x(:,:)
        procedure(f_p), pointer :: fp
        real(8)                         :: xout(size(x,1),size(x,2))
        real(8), dimension(size(x,1),size(x,2)) :: k1, k2, k3, k4
        k1   = h*fp(t    , x     )
        k2   = h*fp(t+h/2, x+k1/2)
        k3   = h*fp(t+h/2, x+k2/2)
        k4   = h*fp(t+h  , x+k3  )
        xout = x + k1/6 + k2/3 + k3/3 + k4/6
    end function rk_exp4

    ! Explicit 4th order Runge-Kutta method - the 3/8 rule
    module function rk_exp38(h,t,x,fp) result(xout)
        real(8), intent(in)             :: h, t
        real(8), intent(in), contiguous :: x(:,:)
        procedure(f_p), pointer :: fp
        real(8)                         :: xout(size(x,1),size(x,2))
        real(8), dimension(size(x,1),size(x,2)) :: k1, k2, k3, k4
        k1   = h*fp(t      , x     )
        k2   = h*fp(t+h/3  , x + k1/3)
        k3   = h*fp(t+2*h/3, x - k1/3 + k2)
        k4   = h*fp(t+h    , x + k1 - k2 + k3  )
        xout = x + k1/8 + 3*k2/8 + 3*k3/8 + k4/8
    end function rk_exp38

    module subroutine four1(data,nn,isign)
        integer, intent(in) :: isign, nn
        real(8) :: data(2*nn)
        integer :: i,istep,j,m,mmax,n
        real(8) :: temp(2)
        real(8) :: theta,wi,wpi,wpr,wr,wtemp
        n = 2*nn
        j = 1
        do i=1,n,2
            if(j > i) then
              temp = data(j:j+1)
              data(j:j+1) = data(i:i+1)
              data(i:i+1) = temp
            endif
            m = n/2
            do
                if((m < 2) .or. (j <= m)) exit
                j = j-m
                m = m/2
            end do
            j = j+m
        end do

        mmax = 2
        do
            if (n <= mmax) exit
            istep = 2*mmax
            theta = two_pi/(isign*mmax)
            wpr = -2*sin(0.5d0*theta)**2
            wpi = sin(theta)
            wr = 1
            wi = 0
            do m=1,mmax,2
                do i=m,n,istep
                    j=i+mmax
                    temp = [wr*data(j)-wi*data(j+1), wr*data(j+1)+wi*data(j)]
                    data(j:j+1) = data(i:i+1) - temp
                    data(i:i+1) = data(i:i+1) + temp
                end do
                wtemp = wr
                wr = wr*wpr - wi*wpi+wr
                wi = wi*wpr + wtemp*wpi+wi
            end do
            mmax = istep
        end do
        return
    end subroutine four1
!
    module subroutine realft(data, isign)
        integer, intent(in)     :: isign
        real(8), intent(inout) :: data(:)

        integer  :: i,i1,i2,i3,i4,n2p3, n
        real(8) :: c1,c2,h1i,h1r,h2i,h2r
        real(8) :: theta,wi,wpi,wpr,wr,wtemp

        n = size(data)
        theta = 2*pi/n
        c1 = 0.5
        if (isign == 1) then
            c2 = -0.5d0
            call four1(data,n/2,+1)
        else
            c2 = 0.5d0
            theta = -theta
        end if
        wpr = -2*sin(0.5d0*theta)**2
        wpi = sin(theta)
        wr = 1 + wpr
        wi = wpi
        n2p3 = n+3
        do i=2,n/4
            i1 = 2*i-1
            i2 = i1+1
            i3 = n2p3-i2
            i4 = i3+1
            h1r = c1*(data(i1)+data(i3))
            h1i = c1*(data(i2)-data(i4))
            h2r = -c2*(data(i2)+data(i4))
            h2i = c2*(data(i1)-data(i3))
            data(i1) = h1r+wr*h2r-wi*h2i
            data(i2) = h1i+wr*h2i+wi*h2r
            data(i3) = h1r-wr*h2r+wi*h2i
            data(i4) = -h1i+wr*h2i+wi*h2r
            wtemp = wr
            wr = wr*wpr-wi*wpi+wr
            wi = wi*wpr+wtemp*wpi+wi
        end do
        if (isign == 1) then
            h1r = data(1)
            data(1) = h1r+data(2)
            data(2) = h1r-data(2)
        else
            h1r = data(1)
            data(1) = c1*(h1r+data(2))
            data(2) = c1*(h1r-data(2))
            call four1(data,n/2,-1)
        end if
        return
    end subroutine realft

end submodule solver_sm


      SUBROUTINE fit(x, y, n, a, b, r)
C     Compute the best fit line (y = a + bx) and its correlation to obs
C     Robert Grumbine 15 December 1994

      IMPLICIT none

      INTEGER n
      REAL x(n), y(n), corxy
      REAL a, b, r

      INTEGER i
      REAL sumxy, sumx, sumy, sumxx, sumyy
      REAL xm, ym

      sumx  = 0.0
      sumy  = 0.0
      sumxy = 0.0
      sumxx = 0.0
      sumyy = 0.0

      DO i = 1, n
        sumx  = sumx + x(i)
        sumxx = sumxx + x(i)*x(i)
        sumxy = sumxy + x(i)*y(i)
        sumyy = sumyy + y(i)*y(i)
        sumy  = sumy  + y(i)
      ENDDO

      xm = sumx / FLOAT(n)
      ym = sumy / FLOAT(n)

      b = (sumxy-n*xm*ym)/(sumxx - n*xm*xm)
      a = ym - b*xm
      r = (sumxy-n*xm*ym)/SQRT(sumxx-n*xm*xm)/SQRT(sumyy-n*ym*ym)

      RETURN
      END


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_FUNC_HKS

    USE MR_KINDS

    USE MR_DEF_CONSTS_N_REF_PARS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_FUNC_HDKS
    PUBLIC :: MR_FUNC_HKS

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_HDKS( DKS ) RESULT( HDKS )

   !DIR$ ATTRIBUTES VECTOR : UNIFORM( DKS ) :: MR_FUNC_HDKS

    IMPLICIT NONE

    REAL(PARD_KIND) , INTENT(IN ) :: DKS

    REAL(FDRD_KIND) :: HDKS

    HDKS = 3.0 * ( DKS * DSPAR )

  END FUNCTION MR_FUNC_HDKS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_HKS( DKS , TCRKS , H , TBFUV_MOD ) RESULT( HKS )

   !DIR$ ATTRIBUTES VECTOR : UNIFORM( DKS , TCRKS ) :: MR_FUNC_HKS

    IMPLICIT NONE

    REAL(PARD_KIND) , INTENT(IN ) :: DKS , TCRKS
    REAL(FDRD_KIND) , INTENT(IN ) :: H , TBFUV_MOD

    REAL(PARD_KIND) :: TRANS_STATE
    REAL(PARD_KIND) :: SDUNE , HDUNE

    REAL(FDRD_KIND) :: HKS

    TRANS_STATE = MIN( MAX( TBFUV_MOD / TCRKS - 1.0 , 0.0 ) , 25.0 )

    SDUNE = 0.015 * ( ( ( DKS * DSPAR ) / H )**0.3 ) *   &
    & ( 1.0 - EXP( -0.5 * TRANS_STATE ) ) * ( 25.0 - TRANS_STATE )
    HDUNE = 7.3 * H * SDUNE

    HKS = MR_FUNC_HDKS( DKS ) + 1.1 * HDUNE * ( 1.0 - EXP( -25.0 * SDUNE ) )

  END FUNCTION MR_FUNC_HKS

  END MODULE MR_MOD_FUNC_HKS


c=======================================================================
c
c     subroutine SCHUR
c
c     Matrix Schur Decomposition
c
c     If A is a complex square matrix of dimention n, then there exists
c     a unitary matrix Q such that
c
c     Q'AQ = T = D + N
c
c     where ' is the conjugate transpose,
c     T is an upper triangular matrix,
c     D = Diag(l1,...,lp) (the li are eigenvalues of A),
c     and N is strictly upper triangular matrix.
c
c     Furthermore, Q can be chosen such that the eigenvalues li appear
c     in any order along the diagonal.
c
c-----------------------------------------------------------------------
      SUBROUTINE schur ( n, X, iwork, dwork, eigval, vpmat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : input matrix (n*n)                          double
c
c     WORKSPACE
c            iwork  : vector (n)                                 integer
c            dwork  : vector ( n*(n+6) )                          double
c
c     OUTPUT
c            eigval : eigenvalues (n)                             double
c            vpmat  : eigenvectors (n*n)                          double
c            info   : diagnostic argument                        integer
c
c     CALL
c            YM     : copy a vectorized matrix in a vectorized matrix
c            DGEES  : Schur factorization (cf. LAPACK)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION eigval(*), X(*), vpmat(n,*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      LOGICAL select
      INTEGER sdim, piw, pmat, pdw, pip, lwork, ilwork
      PARAMETER ( ilwork = 5 )
c
c     external subroutines
      EXTERNAL YM, DGEES
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
c
c     lwork  : size of workspace for DGEES
c              ( min 3*N , so ilwork = min 3 , more is best )
      lwork = n*ilwork
      sdim = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw   : pointer for DGEES  who needs (n)
c     pinext = piw + n
c     pinext : pointer for the next iwork array
c
c     Total size of iwork array ( n )
c
c     pointers for double precision work space  : work(nasmax,*)
c     ----------------------------------------------------------
      pmat = 1
c     pmat   : pointer for work  matrix so (n*n) more
      pdw = pmat + ( n*n )
c     pdw    : pointer for work matrix of DGEES so lwork=(n*5) more
      pip = pdw + lwork
c     pip    : pointer for imaginary part vector so (n) more
c     pdnext = pip + n
c     pdnext  : pointer of the next dwork array
c
c     Total size of work array = ( n*(n + 6) )
c
c-----------------------------------------------------------------------
c
c     saves matrix initial ( altered by DGEES )
      CALL YM ( n, n, X, dwork(pmat) )
c
c     DGEES (cf. LAPACK)
c     DGEES computes for an N-by-N real  nonsymmetric  matrix  A,
c     the eigenvalues, the real Schur form T, and, optionally, the
c     matrix of Schur vectors Z
      CALL DGEES( 'V', 'N', select, n, dwork(pmat), n,
     &            sdim, eigval, dwork(pip), vpmat,
     &            n, dwork(pdw), lwork, iwork(piw), info )
c
      RETURN
      END


module data_mod
   integer, parameter :: num_steps = 1024*1024*1024
   integer, parameter :: MIN_BLK = 1024*256

   contains
      real*8 recursive function pi_comp(Nstart, Nfinish, step) result(sum)
         use omp_lib
         implicit none

         integer, intent(in) :: Nstart, Nfinish
         real*8 :: x, sum1, sum2, step
         integer :: i, iblk

         sum = 0.0

         if (Nfinish - Nstart < MIN_BLK) then
            do i = Nstart,  Nfinish - 1
               x = (i + 0.5) * step
              sum = sum + 4.0 / (1.0 + x * x)
            enddo
         else
            iblk = Nfinish - Nstart
            !$omp task shared(sum1)
               sum1 = pi_comp(Nstart, Nfinish - iblk/2, step)
            !$omp end task
            !$omp task shared(sum2)
               sum2 = pi_comp(Nfinish - iblk/2, Nfinish, step)
            !$omp end task
            !$omp taskwait
            sum = sum1 + sum2
         endif

      end function

end module data_mod

program main
   use omp_lib
   use data_mod
   implicit none

   integer :: i
   real*8 :: pi, sum, step

   step = 1.0 / num_steps

   !$omp parallel
      !$omp single
         sum = pi_comp(0, num_steps, step);
      !$omp end single
   !$omp end parallel

   pi = step * sum

   WRITE(*,100) pi, num_steps
100       FORMAT('pi = ', f15.8, ',', i14, ' steps')

end program main


module divergence_cpu
    use precision
    use dimen
contains
subroutine div0_cpu(div,u,v,w)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------
    implicit none

    real(fp),dimension(nx,ny,nz2),intent(out) :: div
    real(fp),dimension(nx,ny,nz2),intent(in) :: u,v,w

    real(fp),dimension(nx,ny,nz2) :: dudx,dvdy,dwdz
    integer :: i,j,k

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    call ddx_cpu(dudx,u,1)
    call ddy_cpu(dvdy,v,1)
    call ddz_w_cpu(dwdz,w)

    do k=2,nzb+1
        do j=1,ny
            do i=1,nx
                div(i,j,k) = dudx(i,j,k)+dvdy(i,j,k)+dwdz(i,j,k)
            end do
        end do
    end do

end subroutine div0_cpu

subroutine divstress_uv_cpu(divt,tx,ty,tz)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------
    implicit none

    real(fp),dimension(nx,ny,nz2),intent(out) :: divt
    real(fp),dimension(nx,ny,nz2),intent(in) :: tx,ty,tz

    real(fp),dimension(nx,ny,nz2) :: tdx,tdy,tdz
    integer :: i,j,k

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! stress gradients

    call ddx_cpu(tdx,tx,1)
    call ddy_cpu(tdy,ty,1)
    call ddz_w_cpu(tdz,tz)

    !---------------------------------------------------------------------------
    ! stress divergence

    do k=2,nzb+1
        do j=1,ny
            do i=1,nx
                divt(i,j,k)=tdx(i,j,k)+ tdy(i,j,k)+ tdz(i,j,k)
            end do
        end do
    end do

end subroutine divstress_uv_cpu

subroutine divstress_w_cpu(divt,tx,ty,tz)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------
    implicit none

    real(fp),dimension(nx,ny,nz2),intent(out) :: divt
    real(fp),dimension(nx,ny,nz2),intent(in) :: tx,ty,tz

    real(fp),dimension(nx,ny,nz2) :: tdx,tdy,tdz
    integer :: i,j,k

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! stress gradients

    call ddx_cpu(tdx,tx,1)
    call ddy_cpu(tdy,ty,1)
    call ddz_uv_cpu(tdz,tz)

    !---------------------------------------------------------------------------
    ! stress divergence

    do k=2,nzb+1
        do j=1,ny
            do i=1,nx
                divt(i,j,k)=tdx(i,j,k)+ tdy(i,j,k)+ tdz(i,j,k)
            end do
        end do
    end do

    !---------------------------------------------------------------------------
    ! at the wall we have to assume that tdz(tzz)=0.0.  any better ideas?
    ! yes -> assymetric fdm ???? -> do we really care ) w(:,:,2)=0 anyway !!

    ! if (me==0) then
    !     divt(:,:,2)=tdx(:,:,2)+ tdy(:,:,2)
    ! end if

end subroutine divstress_w_cpu

subroutine ddx_cpu(dfdx,f,flag)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------

    implicit none
    include '../common/fftw3.f90'

    real*8,dimension(nx,ny,nz2),intent(out) :: dfdx
    real*8,dimension(nx,ny,nz2),intent(in) :: f
    integer,intent(in) :: flag

    integer*8 :: plan_forward,plan_backward
    real*8,dimension(nx,ny) :: f_2d
    double complex,dimension(nx/2+1,ny) :: f_hat,dfdx_hat

    integer :: i,j,k,ii,jj

    save plan_forward,plan_backward

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! init

    if (flag==0) then

        call dfftw_plan_dft_r2c_2d(plan_forward,nx,ny,f_2d,f_hat,fftw_measure)
        call dfftw_plan_dft_c2r_2d(plan_backward,nx,ny,f_hat,f_2d,fftw_measure)

    !---------------------------------------------------------------------------
    ! compute

    elseif (flag==1) then

        do k=2,nzb+1
            ! forward fft --> f_hat
            call dfftw_execute_dft_r2c(plan_forward,f(:,:,k),f_hat)
            f_hat=f_hat*inxny
            ! derivate
            do j=1,ny
                jj=j-1
                if(jj>nint(ny/2.0)) jj=jj-ny
                do i=1,nx/2+1
                    ii=i-1
                    ! filter
                    if ((ii==nint(nx/2.0)) .or. (abs(jj)>=nint(ny/2.0)))then
                        dfdx_hat(i,j)=0.d0
                    ! dfdx_hat
                    else
                        dfdx_hat(i,j)=dcmplx(dimag(f_hat(i,j))*(-1.d0),dreal(f_hat(i,j)))*ii
                    end if
                end do
            end do
            ! backward fft --> dfdx
            call dfftw_execute_dft_c2r(plan_backward,dfdx_hat,dfdx(:,:,k))

        end do

      !---------------------------------------------------------------------------
      ! finalize

      elseif (flag==2) then

            call dfftw_destroy_plan(plan_forward)
            call dfftw_destroy_plan(plan_backward)

      endif

end subroutine ddx_cpu

subroutine ddy_cpu(dfdy,f,flag)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------

    implicit none
    include '../common/fftw3.f90'

    real*8,dimension(nx,ny,nz2),intent(out) :: dfdy
    real*8,dimension(nx,ny,nz2),intent(in) :: f
    integer, intent(in) :: flag

    integer*8 :: plan_forward,plan_backward
    real*8,dimension(nx,ny) :: f_2d
    double complex,dimension(nx/2+1,ny) :: f_hat,dfdy_hat

    integer :: i,j,k,ii,jj

    save plan_forward,plan_backward

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! init

    if (flag==0) then

        call dfftw_plan_dft_r2c_2d(plan_forward,nx,ny,f_2d,f_hat,fftw_measure)
        call dfftw_plan_dft_c2r_2d(plan_backward,nx,ny,f_hat,f_2d,fftw_measure)

    !---------------------------------------------------------------------------
    ! compute

    elseif (flag==1) then

        do k=2,nzb+1
            ! forward fft --> f_hat
            call dfftw_execute_dft_r2c(plan_forward,f(:,:,k),f_hat)
            f_hat=f_hat*inxny
            ! derivate
            do j=1,ny
                jj=j-1
                if(jj>nint(ny/2.0)) jj=jj-ny
                jj=jj*l_r
                do i=1,nx/2+1
                    ii=i-1
                    ! filter
                    if ((ii==nint(nx/2.0)) .or. (abs(jj)==nint(l_r*ny/2.0)))then
                        dfdy_hat(i,j)=0.d0
                    ! dfdx_hat
                    else
                        dfdy_hat(i,j)=dcmplx(dimag(f_hat(i,j))*(-1.d0),dreal(f_hat(i,j)))*jj
                    end if
                end do
            end do
            ! backward fft --> dfdx
            call dfftw_execute_dft_c2r(plan_backward,dfdy_hat,dfdy(:,:,k))

        end do

    !---------------------------------------------------------------------------
    ! finalize

    elseif (flag==2) then

        call dfftw_destroy_plan(plan_forward)
        call dfftw_destroy_plan(plan_backward)

    endif

end subroutine ddy_cpu

pure subroutine ddz_uv_cpu (dfdz,f)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------

    implicit none

    real(fp),dimension(nx,ny,nz2),intent(out) :: dfdz
    real(fp),dimension(nx,ny,nz2),intent(in) :: f

    integer :: i,j,k

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    do k=2,nzb+1
        do j=1,ny
            do i=1,nx
                dfdz(i,j,k)=(f(i,j,k)-f(i,j,k-1))*idz
            end do
        end do
    end do

end subroutine ddz_uv_cpu

pure subroutine ddz_w_cpu (dfdz,f)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------

    implicit none

    real(fp),dimension(nx,ny,nz2),intent(out) :: dfdz
    real(fp),dimension(nx,ny,nz2),intent(in) :: f

    integer :: i,j,k

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    do k=2,nzb+1
        do j=1,ny
            do i=1,nx
                dfdz(i,j,k)=(f(i,j,k+1)-f(i,j,k))*idz
            end do
        end do
    end do

end subroutine ddz_w_cpu

pure subroutine ddz_uv_cpu_corr (dfdz,k_corr)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------

    implicit none

    real(fp),dimension(nx,ny,nz2),intent(inout):: dfdz
    integer,intent(in) :: k_corr

    real(fp) :: d_avg1

    integer :: i,j

    real(fp),parameter :: fr1 = 1.d0/dlog(3.d0)-1.d0

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    d_avg1 = 0.d0

    do j=1,ny
        do i=1,nx
            d_avg1= d_avg1 + dfdz(i,j,k_corr)
        end do
    end do

    d_avg1 = d_avg1*inxny

    do j=1,ny
        do i=1,nx
            dfdz(i,j,k_corr)= dfdz(i,j,k_corr) + fr1*d_avg1
        end do
    end do

end subroutine ddz_uv_cpu_corr

end module divergence_cpu


*
************************************************************************
*
*     File of the COMPLEX          Level-3 BLAS.
*     ==========================================
*
*     SUBROUTINE CGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE CSYMM ( SIDE,   UPLO,   M, N,    ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE CHEMM ( SIDE,   UPLO,   M, N,    ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE CSYRK ( UPLO,   TRANS,     N, K, ALPHA, A, LDA,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE CHERK ( UPLO,   TRANS,     N, K, ALPHA, A, LDA,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE CSYR2K( UPLO,   TRANS,     N, K, ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE CHER2K( UPLO,   TRANS,     N, K, ALPHA, A, LDA, B, LDB,
*    $                   BETA, C, LDC )
*
*     SUBROUTINE CTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
*    $                   B, LDB )
*
*     SUBROUTINE CTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
*    $                   B, LDB )
*
*     See:
*
*        Dongarra J. J.,   Du Croz J. J.,   Duff I.  and   Hammarling S.
*        A set of  Level 3  Basic Linear Algebra Subprograms.  Technical
*        Memorandum No.88 (Revision 1), Mathematics and Computer Science
*        Division,  Argonne National Laboratory, 9700 South Cass Avenue,
*        Argonne, Illinois 60439.
*
*
************************************************************************
*
      SUBROUTINE CGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
     $                   BETA, C, LDC )
*     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      COMPLEX            ALPHA, BETA
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  CGEMM  performs one of the matrix-matrix operations
*
*     C := alpha*op( A )*op( B ) + beta*C,
*
*  where  op( X ) is one of
*
*     op( X ) = X   or   op( X ) = X'   or   op( X ) = conjg( X' ),
*
*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
*
*  Parameters
*  ==========
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n',  op( A ) = A.
*
*              TRANSA = 'T' or 't',  op( A ) = A'.
*
*              TRANSA = 'C' or 'c',  op( A ) = conjg( A' ).
*
*           Unchanged on exit.
*
*  TRANSB - CHARACTER*1.
*           On entry, TRANSB specifies the form of op( B ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSB = 'N' or 'n',  op( B ) = B.
*
*              TRANSB = 'T' or 't',  op( B ) = B'.
*
*              TRANSB = 'C' or 'c',  op( B ) = conjg( B' ).
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry,  M  specifies  the number  of rows  of the  matrix
*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry,  N  specifies the number  of columns of the matrix
*           op( B ) and the number of columns of the matrix C. N must be
*           at least zero.
*           Unchanged on exit.
*
*  K      - INTEGER.
*           On entry,  K  specifies  the number of columns of the matrix
*           op( A ) and the number of rows of the matrix op( B ). K must
*           be at least  zero.
*           Unchanged on exit.
*
*  ALPHA  - COMPLEX         .
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - COMPLEX          array of DIMENSION ( LDA, ka ), where ka is
*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
*           part of the array  A  must contain the matrix  A,  otherwise
*           the leading  k by m  part of the array  A  must contain  the
*           matrix A.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*           least  max( 1, k ).
*           Unchanged on exit.
*
*  B      - COMPLEX          array of DIMENSION ( LDB, kb ), where kb is
*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
*           part of the array  B  must contain the matrix  B,  otherwise
*           the leading  n by k  part of the array  B  must contain  the
*           matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
*           least  max( 1, n ).
*           Unchanged on exit.
*
*  BETA   - COMPLEX         .
*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*           supplied as zero then C need not be set on input.
*           Unchanged on exit.
*
*  C      - COMPLEX          array of DIMENSION ( LDC, n ).
*           Before entry, the leading  m by n  part of the array  C must
*           contain the matrix  C,  except when  beta  is zero, in which
*           case C need not be set on entry.
*           On exit, the array  C  is overwritten by the  m by n  matrix
*           ( alpha*op( A )*op( B ) + beta*C ).
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
*     .. Local Scalars ..
      LOGICAL            CONJA, CONJB, NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      COMPLEX            TEMP
*     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Executable Statements ..
*
*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
*     conjugated or transposed, set  CONJA and CONJB  as true if  A  and
*     B  respectively are to be  transposed but  not conjugated  and set
*     NROWA, NCOLA and  NROWB  as the number of rows and  columns  of  A
*     and the number of rows of  B  respectively.
*
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      CONJA = LSAME( TRANSA, 'C' )
      CONJB = LSAME( TRANSB, 'C' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.
     $         ( .NOT.CONJA                ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.
     $         ( .NOT.CONJB                ).AND.
     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CGEMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     And when  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
*
*     Start the operations.
*
      IF( NOTB )THEN
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B + beta*C.
*
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE IF( CONJA )THEN
*
*           Form  C := alpha*conjg( A' )*B + beta*C.
*
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + CONJG( A( L, I ) )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B + beta*C
*
            DO 150, J = 1, N
               DO 140, I = 1, M
                  TEMP = ZERO
                  DO 130, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  130             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  140          CONTINUE
  150       CONTINUE
         END IF
      ELSE IF( NOTA )THEN
         IF( CONJB )THEN
*
*           Form  C := alpha*A*conjg( B' ) + beta*C.
*
            DO 200, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 160, I = 1, M
                     C( I, J ) = ZERO
  160             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 170, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  170             CONTINUE
               END IF
               DO 190, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*CONJG( B( J, L ) )
                     DO 180, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  180                CONTINUE
                  END IF
  190          CONTINUE
  200       CONTINUE
         ELSE
*
*           Form  C := alpha*A*B'          + beta*C
*
            DO 250, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 210, I = 1, M
                     C( I, J ) = ZERO
  210             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 220, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  220             CONTINUE
               END IF
               DO 240, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 230, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  230                CONTINUE
                  END IF
  240          CONTINUE
  250       CONTINUE
         END IF
      ELSE IF( CONJA )THEN
         IF( CONJB )THEN
*
*           Form  C := alpha*conjg( A' )*conjg( B' ) + beta*C.
*
            DO 280, J = 1, N
               DO 270, I = 1, M
                  TEMP = ZERO
                  DO 260, L = 1, K
                     TEMP = TEMP + CONJG( A( L, I ) )*CONJG( B( J, L ) )
  260             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  270          CONTINUE
  280       CONTINUE
         ELSE
*
*           Form  C := alpha*conjg( A' )*B' + beta*C
*
            DO 310, J = 1, N
               DO 300, I = 1, M
                  TEMP = ZERO
                  DO 290, L = 1, K
                     TEMP = TEMP + CONJG( A( L, I ) )*B( J, L )
  290             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  300          CONTINUE
  310       CONTINUE
         END IF
      ELSE
         IF( CONJB )THEN
*
*           Form  C := alpha*A'*conjg( B' ) + beta*C
*
            DO 340, J = 1, N
               DO 330, I = 1, M
                  TEMP = ZERO
                  DO 320, L = 1, K
                     TEMP = TEMP + A( L, I )*CONJG( B( J, L ) )
  320             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  330          CONTINUE
  340       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B' + beta*C
*
            DO 370, J = 1, N
               DO 360, I = 1, M
                  TEMP = ZERO
                  DO 350, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  350             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  360          CONTINUE
  370       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of CGEMM .
*
      END


!!# MODULE <<FUN_xyTRIANGULATE>>
MODULE FUN_xyTRIANGULATE
!!## PURPOSE
!! Triangulate the following shapes.
!!
!! * xyTRIANGULATE_Pg - returns a triangulation of a polygon.

!!## DISCUSSION
!!
!! * xyTRIANGULATE_Pg
!!
!!    Given a polygon with N (distinct) nodes, a triangulation consists of
!!    N-2 (distinct) triangles, with the property that each triangle is
!!    constructed from vertices of the polygon, and that every point in the
!!    polygon is contained in exactly one triangle, unless it lies on the
!!    boundary of two or more triangles, and that no point exterior to the
!!    polygon is contained in any triangle.  In other words, a triangulation
!!    is a dissection of the area of the polygon into triangles.

!!## COMMENTS
!!    This algorithm should be correct, but not efficient.

!!## MODIFIED
!!  09 November 2000

!!## AUTHOR
!!  John Burkardt

!!## REFERENCE
!!
!!    de Berg, van Krevald, Overmars, Schwarzkopf,
!!    Computational Geometry,
!!    Second Edition,
!!    Springer, 2000, pages 46-49.
!!

!!## USAGE
!
!     order_Tr = xyTRIANGULATE_Pg(N,Pg)
!
!! where <N> is the input number of nodes of the polygon and
!! Pg(1,1:N), Pg(2,1:N) are the counter-clockwise ordered
!! x and y-coordinates of the polygon, starting with the
!! left-lowest point.
!!
!! The output, <order_Tr(1:3,N-1)> are the N-2 triangles
!! that make up the polygon.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes      ,ONLY: KIND_Rsp , KIND_Rdp      !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_1_Rsp => c_1 , c_0_Rsp => c_0 !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_1_Rdp => c_1 , c_0_Rdp => c_0 !!((02-A-PAR_Constants_Rdp.f90))

!!## EXTERNAL PROCEDURES
USE FUN_xyDIRECTION       ,ONLY: xyDIRECTION_PP             !!((04-B-FUN_xyDIRECTION.f90))
USE FUN_xyANGLE           ,ONLY: xyANGLE_UU                 !!((05-B-FUN_xyANGLE.f90))
USE FUN_xyROTATE          ,ONLY: xyROTATE_Px                !!((05-B-FUN_xyROTATE.f90))
USE FUN_xyTRANSLATE       ,ONLY: xyTRANSLATE_Px             !!((05-B-FUN_xyTRANSLATE.f90))
USE FUN_xyCOUNTERCLOCKWISE,ONLY: xyCOUNTERCLOCKWISE_Cn      !!((06-B-FUN_xyCOUNTERCLOCKWISE.f90))

USE LIB_MeshQuality,ONLY: dtris2                            !!((04-B-LIB_MeshQuality.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyTRIANGULATE_Pg
 MODULE PROCEDURE xyTRIANGULATE_Pg_Rsp
 MODULE PROCEDURE xyTRIANGULATE_Pg_Rdp
 MODULE PROCEDURE xyTRIANGULATE2_Pg_Rsp
 MODULE PROCEDURE xyTRIANGULATE2_Pg_Rdp
END INTERFACE
INTERFACE D_SWAP
 MODULE PROCEDURE D_SWAP_Rsp
 MODULE PROCEDURE D_SWAP_Rdp
END INTERFACE
INTERFACE ENORM0_2D
 MODULE PROCEDURE ENORM0_2D_Rsp
 MODULE PROCEDURE ENORM0_2D_Rdp
END INTERFACE
INTERFACE ENORMSQ0_2D
 MODULE PROCEDURE ENORMSQ0_2D_Rsp
 MODULE PROCEDURE ENORMSQ0_2D_Rdp
END INTERFACE
INTERFACE DMAT_SOLVE
 MODULE PROCEDURE DMAT_SOLVE_Rsp
 MODULE PROCEDURE DMAT_SOLVE_Rdp
END INTERFACE
INTERFACE LINE_EXP_POINT_DIST_2D
 MODULE PROCEDURE LINE_EXP_POINT_DIST_2D_Rsp
 MODULE PROCEDURE LINE_EXP_POINT_DIST_2D_Rdp
END INTERFACE
INTERFACE TRIANGLE_CONTAINS_POINT_2D
 MODULE PROCEDURE TRIANGLE_CONTAINS_POINT_2D_Rsp
 MODULE PROCEDURE TRIANGLE_CONTAINS_POINT_2D_Rdp
END INTERFACE
INTERFACE POLY_REORDER_NODES
 MODULE PROCEDURE POLY_REORDER_NODES_Rsp
 MODULE PROCEDURE POLY_REORDER_NODES_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyTRIANGULATE_Pg
PUBLIC :: xyTRIANGULATE_Pg_Rsp
PUBLIC :: xyTRIANGULATE_Pg_Rdp

!!## MODULE PROCEDURES
CONTAINS

!!### FUNCTION: xyTRIANGULATE2_Pg_Rsp
FUNCTION xyTRIANGULATE2_Pg_Rsp( N , Pg , P_centroid ) RESULT(order_Tr)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R = KIND_Rsp
INCLUDE "07-B-FUN_xyTRIANGULATE2_Pg.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyTRIANGULATE2_Pg.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: xyTRIANGULATE2_Pg_Rdp
FUNCTION xyTRIANGULATE2_Pg_Rdp( N , Pg , P_centroid ) RESULT(order_Tr)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R = KIND_Rdp
INCLUDE "07-B-FUN_xyTRIANGULATE2_Pg.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyTRIANGULATE2_Pg.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: xyTRIANGULATE_Pg_Rsp
FUNCTION xyTRIANGULATE_Pg_Rsp( N , Pg ) RESULT(order_Tr)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R = KIND_Rsp
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1 = c_1_Rsp
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "07-B-FUN_xyTRIANGULATE_Pg.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyTRIANGULATE_Pg.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: xyTRIANGULATE_Pg_Rdp
FUNCTION xyTRIANGULATE_Pg_Rdp( N , Pg ) RESULT(order_Tr)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R = KIND_Rdp
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1 = c_1_Rdp
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "07-B-FUN_xyTRIANGULATE_Pg.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyTRIANGULATE_Pg.f90.bdy"
!!--end--
END FUNCTION

subroutine ivec_indicator ( n, a )

!*******************************************************************************
!
!! IVEC_INDICATOR sets an integer vector to the vector A(I)=I.
!
!  Modified:
!
!    09 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer N, the number of elements of A.
!
!    Output, integer A(N), the array to be initialized.
!
  implicit none

  integer n

  integer a(n)
  integer i

  do i = 1, n
    a(i) = i
  end do

  return
end subroutine

subroutine ivec_push ( n, x, stack1_max, stack1_num, stack1, stack2_max, &
  stack2_num, stack2 )

!*******************************************************************************
!
!! IVEC_PUSH pushes an integer vector onto a stack.
!
!  Discussion:
!
!    STACK1 contains a list of the dimensions of the objects stored.
!    Therefore, STACK1_MAX should be at least as big as the maximum number
!    of objects to be considered.
!
!    STACK2 contains the values of the objects.  Therefore, STACK2_MAX
!    should probably be as big as the maximum total length of the maximum
!    number of objects stored.
!
!    On first call, the USEr should have set STACK1_NUM and STACK2_NUM to zero.
!
!  Modified:
!
!    09 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer N, the dimension of the vector.  N may be zero.
!
!    Input, integer X(N), the value of the vector.
!
!    Input, integer STACK1_MAX, the maximum size of STACK1.
!
!    Input/output, integer STACK1_NUM, the current size of STACK1.
!
!    Input/output, integer STACK1(STACK1_MAX), the vector dimension stack.
!
!    Input, integer STACK2_MAX, the maximum size of STACK2.
!
!    Input/output, integer STACK2_NUM, the current size of STACK2.
!
!    Input/output, integer STACK2(STACK2_MAX), the vector value stack.
!
  implicit none

  integer n
  integer stack1_max
  integer stack2_max

  integer stack1(stack1_max)
  integer stack1_num
  integer stack2(stack2_max)
  integer stack2_num
  integer x(n)

  if ( n < 0 ) then
    write ( *, * ) ' '
    write ( *, * ) 'IVEC_PUSH - Fatal error!'
    write ( *, * ) '  Input dimension N is negative.'
    stop
  end if

  if ( stack1_max < stack1_num + 1 ) then
    write ( *, * ) ' '
    write ( *, * ) 'IVEC_PUSH - Fatal error!'
    write ( *, * ) '  Exceeding size of stack #1.'
    stop
  end if

  if ( stack2_max < stack2_num + n ) then
    write ( *, * ) ' '
    write ( *, * ) 'IVEC_PUSH - Fatal error!'
    write ( *, * ) '  Exceeding size of stack #2.'
    stop
  end if

  stack1_num = stack1_num + 1
  stack1(stack1_num) = n

  stack2(stack2_num+1:stack2_num+n) = x(1:n)
  stack2_num = stack2_num + n

end subroutine

subroutine ivec_pop ( n, x, stack1_max, stack1_num, stack1, stack2_max, &
  stack2_num, stack2 )

!*******************************************************************************
!
!! IVEC_POP pops an integer vector off of a stack.
!
!  Discussion:
!
!    If there are no more objects in the stack, N is returned as -1.
!
!  Modified:
!
!    09 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer N, the dimension of the vector.
!
!    Output, integer X(*), the value of the vector.
!
!    Input, integer STACK1_MAX, the maximum size of STACK1.
!
!    Input/output, integer STACK1_NUM, the current size of STACK1.
!
!    Input/output, integer STACK1(STACK1_MAX), the vector dimension stack.
!
!    Input, integer STACK2_MAX, the maximum size of STACK2.
!
!    Input/output, integer STACK2_NUM, the current size of STACK2.
!
!    Input/output, integer STACK2(STACK2_MAX), the vector value stack.
!
  implicit none

  integer n
  integer stack1_max
  integer stack2_max

  integer stack1(stack1_max)
  integer stack1_num
  integer stack2(stack2_max)
  integer stack2_num
  integer x(*)

  if ( stack1_num < 1 ) then
    n = -1
    return
  end if

  n = stack1(stack1_num)
  stack1_num = stack1_num - 1

  stack2_num = stack2_num - n
  x(1:n) = stack2(stack2_num+1:stack2_num+n)

end subroutine

subroutine d_swap_Rsp ( x, y )

!*******************************************************************************
!
!! D_SWAP swaps two real values.
!
!  Modified:
!
!    01 May 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) X, Y.  On output, the values of X and
!    Y have been interchanged.
!
  implicit none

  real ( kind = KIND_Rsp ) x
  real ( kind = KIND_Rsp ) y
  real ( kind = KIND_Rsp ) z

  z = x
  x = y
  y = z

end subroutine

function enorm0_2d_Rsp ( x0, y0, x1, y1 ) RESULT(enorm0_2D)

!*******************************************************************************
!
!! ENORM0_2D computes the Euclidean norm of (P1-P0) in 2D.
!
!  Modified:
!
!    16 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = KIND_R ) X0, Y0, X1, Y1, the coordinates of the points P0 and P1.
!
!    Output, real ( kind = KIND_R ) ENORM0_2D, the Euclidean norm of (P1-P0).
!
  implicit none

  real ( kind = KIND_Rsp ) enorm0_2d
  real ( kind = KIND_Rsp ) x0
  real ( kind = KIND_Rsp ) x1
  real ( kind = KIND_Rsp ) y0
  real ( kind = KIND_Rsp ) y1

  enorm0_2d = sqrt ( ( x1 - x0 )**2 + ( y1 - y0 )**2 )

end function

function enormsq0_2d_Rsp ( x0, y0, x1, y1 )  RESULT(enormsq0_2d)

!*******************************************************************************
!
!! ENORMSQ0_2D computes the square of the Euclidean norm of (P1-P0) in 2D.
!
!  Modified:
!
!    06 February 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = KIND_R ) X0, Y0, X1, Y1, the coordinates of the points
!    P0 and P1.
!
!    Output, real ( kind = KIND_R ) ENORMSQ0_2D, the square of the Euclidean norm of (P1-P0).
!
  implicit none

  real ( kind = KIND_Rsp ) enormsq0_2d
  real ( kind = KIND_Rsp ) x0
  real ( kind = KIND_Rsp ) x1
  real ( kind = KIND_Rsp ) y0
  real ( kind = KIND_Rsp ) y1

  enormsq0_2d = ( x1 - x0 )**2 + ( y1 - y0 )**2

end function

subroutine poly_reorder_nodes_Rsp ( nxy, x, y, npoly, poly )

!*******************************************************************************
!
!! POLY_REORDER_NODES reorders nodes of a polygon so node 1 is leftest lowest.
!
!  Modified:
!
!    12 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer NXY, the number of nodes.
!
!    Input, real ( kind = KIND_R ) X(NXY), Y(NXY), the coordinates of the nodes.
!
!    Input, integer NPOLY, the number of nodes of the polygon.
!
!    Input/output, POLY(NPOLY), the indices of the nodes.
!
  implicit none

  integer npoly
  integer nxy

  integer i
  integer imin
  integer p
  integer pmin
  integer poly(npoly)
  integer poly2(npoly)
  real ( kind = KIND_Rsp ) x(nxy)
  real ( kind = KIND_Rsp ) y(nxy)

  imin = 1
  pmin = poly(imin)

  do i = 2, npoly
    p = poly(i)
    if ( &
      ( x(p) < x(pmin) ) .or. &
      ( x(p) == x(pmin) .and. y(p) < y(pmin) ) ) then
      imin = i
      pmin = p
    end if
  end do

  if ( imin /= 1 ) then

    poly2(1:npoly+1-imin) = poly(imin:npoly)
    poly2(npoly+2-imin:npoly) = poly(1:imin-1)

    poly(1:npoly) = poly2(1:npoly)

  end if

end subroutine

subroutine triangle_contains_point_2d_Rsp ( x1, y1, x2, y2, x3, y3, x, y, inside )

!*******************************************************************************
!
!! TRIANGLE_CONTAINS_POINT_2D finds if a point is inside a triangle in 2D.
!
!  Modified:
!
!    12 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = KIND_Rsp ) X1, Y1, X2, Y2, X3, Y3, the coordinates of
!    the corners of the triangle.
!
!    Input, real ( kind = KIND_Rsp ) X, Y, the point to be checked.
!
!    Output, logical INSIDE, is .TRUE. if (X,Y) is inside
!    the triangle or on its boundary, and .FALSE. otherwise.
!
  implicit none

  integer, parameter :: N = 2
  integer, parameter :: NRHS = 1

  real ( kind = KIND_Rsp ) a(N,N+NRHS)
  real ( kind = KIND_Rsp ) c1
  real ( kind = KIND_Rsp ) c2
  integer info
  logical inside
  real ( kind = KIND_Rsp ) x
  real ( kind = KIND_Rsp ) x1
  real ( kind = KIND_Rsp ) x2
  real ( kind = KIND_Rsp ) x3
  real ( kind = KIND_Rsp ) y
  real ( kind = KIND_Rsp ) y1
  real ( kind = KIND_Rsp ) y2
  real ( kind = KIND_Rsp ) y3
!
!  Set up the linear system
!
!    ( X2-X1  X3-X1 ) C1  = X-X1
!    ( Y2-Y1  Y3-Y1 ) C2    Y-Y1
!
!  which is satisfied by the barycentric coordinates of (X,Y).
!
  a(1,1) = x2 - x1
  a(1,2) = x3 - x1
  a(1,3) = x - x1

  a(2,1) = y2 - y1
  a(2,2) = y3 - y1
  a(2,3) = y - y1
!
!  Solve the linear system.
!
  call dmat_solve ( a, N, NRHS, info )

  if ( info /= 0 ) then
    write ( *, * ) ' '
    write ( *, * ) 'TRIANGLE_CONTAINS_POINT - Fatal error!'
    write ( *, * ) '  The linear system is singular.'
    write ( *, * ) '  The input data does not form a proper triangle.'
    stop
  end if

  c1 = a(1,3)
  c2 = a(2,3)
!
!  If the point is in the triangle, its barycentric coordinates
!  must both be nonnegative, and sum to no more than 1.
!
  if ( c1 < 0._KIND_Rsp .or. c2 < 0._KIND_Rsp ) then
    inside = .false.
  else if ( 1._KIND_Rsp < c1 + c2 ) then
    inside = .false.
  else
    inside = .true.
  end if

end subroutine

subroutine line_exp_point_dist_2d_Rsp ( x1, y1, x2, y2, x, y, dist )

!*******************************************************************************
!
!! LINE_EXP_POINT_DIST_2D: distance ( explicit line, point ) in 2D.
!
!  Formula:
!
!    The explicit form of a line in 2D is:
!
!      (X1,Y1), (X2,Y2).
!
!  Modified:
!
!    27 January 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = KIND_Rsp ) X1, Y1, X2, Y2.  (X1,Y1) and (X2,Y2) are two
!    points on the line.
!
!    Input, real ( kind = KIND_Rsp ) X, Y, the point whose distance from the line is
!    to be measured.
!
!    Output, real ( kind = KIND_Rsp ) DIST, the distance from the point to the line.
!
  implicit none

  real ( kind = KIND_Rsp ) bot
  real ( kind = KIND_Rsp ) dist
  real ( kind = KIND_Rsp ) dot
  real ( kind = KIND_Rsp ) t
  real ( kind = KIND_Rsp ) x
  real ( kind = KIND_Rsp ) xn
  real ( kind = KIND_Rsp ) x1
  real ( kind = KIND_Rsp ) x2
  real ( kind = KIND_Rsp ) y
  real ( kind = KIND_Rsp ) yn
  real ( kind = KIND_Rsp ) y1
  real ( kind = KIND_Rsp ) y2

  bot = enormsq0_2d ( x1, y1, x2, y2 )

  if ( bot == 0._KIND_Rsp ) then

    xn = x1
    yn = y1
!
!  (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta).
!
!  (P-P1) dot (P2-P1) / Norm(P-P1)**2 = normalized coordinate T
!  of the projection of (P-P1) onto (P2-P1).
!
  else

    dot = ( x - x1 ) * ( x2 - x1 ) + ( y - y1 ) * ( y2 - y1 )

    t = dot / bot

    xn = x1 + t * ( x2 - x1 )
    yn = y1 + t * ( y2 - y1 )

  end if

  dist = enorm0_2d ( xn, yn, x, y )

end subroutine

subroutine dmat_solve_Rsp ( a, n, nrhs, info )

!*******************************************************************************
!
!! DMAT_SOLVE USEs Gauss-Jordan elimination to solve an N by N linear system.
!
!  Modified:
!
!    08 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real ( kind = KIND_Rsp ) A(N,N+NRHS), contains in rows and columns 1
!    to N the coefficient matrix, and in columns N+1 through
!    N+NRHS, the right hand sides.  On output, the coefficient matrix
!    area has been destroyed, while the right hand sides have
!    been overwritten with the corresponding solutions.
!
!    Input, integer NRHS, the number of right hand sides.  NRHS
!    must be at least 0.
!
!    Output, integer INFO, singularity flag.
!    0, the matrix was not singular, the solutions were computed;
!    J, factorization failed on step J, and the solutions could not
!    be computed.
!
  implicit none

  integer n
  integer nrhs

  real ( kind = KIND_Rsp ) a(n,n+nrhs)
  real ( kind = KIND_Rsp ) apivot
  real ( kind = KIND_Rsp ) factor
  integer i
  integer info
  integer ipivot
  integer j

  info = 0

  do j = 1, n
!
!  Choose a pivot row.
!
    ipivot = j
    apivot = a(j,j)

    do i = j+1, n
      if ( abs ( apivot ) < abs ( a(i,j) ) ) then
        apivot = a(i,j)
        ipivot = i
      end if
    end do

    if ( apivot == 0._KIND_Rsp ) then
      info = j
      return
    end if
!
!  Interchange.
!
    do i = 1, n + nrhs
      call d_swap ( a(ipivot,i), a(j,i) )
    end do
!
!  A(J,J) becomes 1.
!
    a(j,j) = 1._KIND_Rsp
    a(j,j+1:n+nrhs) = a(j,j+1:n+nrhs) / apivot
!
!  A(I,J) becomes 0.
!
    do i = 1, n

      if ( i /= j ) then

        factor = a(i,j)
        a(i,j) = 0._KIND_Rsp
        a(i,j+1:n+nrhs) = a(i,j+1:n+nrhs) - factor * a(j,j+1:n+nrhs)

      end if

    end do

  end do

end subroutine

subroutine d_swap_Rdp ( x, y )

!*******************************************************************************
!
!! D_SWAP swaps two real values.
!
!  Modified:
!
!    01 May 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) X, Y.  On output, the values of X and
!    Y have been interchanged.
!
  implicit none

  real ( kind = KIND_Rdp ) x
  real ( kind = KIND_Rdp ) y
  real ( kind = KIND_Rdp ) z

  z = x
  x = y
  y = z

end subroutine

function enorm0_2d_Rdp ( x0, y0, x1, y1 ) RESULT(enorm0_2d)

!*******************************************************************************
!
!! ENORM0_2D computes the Euclidean norm of (P1-P0) in 2D.
!
!  Modified:
!
!    16 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = KIND_R ) X0, Y0, X1, Y1, the coordinates of the points P0 and P1.
!
!    Output, real ( kind = KIND_R ) ENORM0_2D, the Euclidean norm of (P1-P0).
!
  implicit none

  real ( kind = KIND_Rdp ) enorm0_2d
  real ( kind = KIND_Rdp ) x0
  real ( kind = KIND_Rdp ) x1
  real ( kind = KIND_Rdp ) y0
  real ( kind = KIND_Rdp ) y1

  enorm0_2d = sqrt ( ( x1 - x0 )**2 + ( y1 - y0 )**2 )

end function

function enormsq0_2d_Rdp ( x0, y0, x1, y1 ) RESULT(enormsq0_2d)

!*******************************************************************************
!
!! ENORMSQ0_2D computes the square of the Euclidean norm of (P1-P0) in 2D.
!
!  Modified:
!
!    06 February 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = KIND_R ) X0, Y0, X1, Y1, the coordinates of the points
!    P0 and P1.
!
!    Output, real ( kind = KIND_R ) ENORMSQ0_2D, the square of the Euclidean norm of (P1-P0).
!
  implicit none

  real ( kind = KIND_Rdp ) enormsq0_2d
  real ( kind = KIND_Rdp ) x0
  real ( kind = KIND_Rdp ) x1
  real ( kind = KIND_Rdp ) y0
  real ( kind = KIND_Rdp ) y1

  enormsq0_2d = ( x1 - x0 )**2 + ( y1 - y0 )**2

end function

subroutine poly_reorder_nodes_Rdp ( nxy, x, y, npoly, poly )

!*******************************************************************************
!
!! POLY_REORDER_NODES reorders nodes of a polygon so node 1 is leftest lowest.
!
!  Modified:
!
!    12 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer NXY, the number of nodes.
!
!    Input, real ( kind = KIND_R ) X(NXY), Y(NXY), the coordinates of the nodes.
!
!    Input, integer NPOLY, the number of nodes of the polygon.
!
!    Input/output, POLY(NPOLY), the indices of the nodes.
!
  implicit none

  integer npoly
  integer nxy

  integer i
  integer imin
  integer p
  integer pmin
  integer poly(npoly)
  integer poly2(npoly)
  real ( kind = KIND_Rdp ) x(nxy)
  real ( kind = KIND_Rdp ) y(nxy)

  imin = 1
  pmin = poly(imin)

  do i = 2, npoly
    p = poly(i)
    if ( &
      ( x(p) < x(pmin) ) .or. &
      ( x(p) == x(pmin) .and. y(p) < y(pmin) ) ) then
      imin = i
      pmin = p
    end if
  end do

  if ( imin /= 1 ) then

    poly2(1:npoly+1-imin) = poly(imin:npoly)
    poly2(npoly+2-imin:npoly) = poly(1:imin-1)

    poly(1:npoly) = poly2(1:npoly)

  end if

end subroutine

subroutine triangle_contains_point_2d_Rdp ( x1, y1, x2, y2, x3, y3, x, y, inside )

!*******************************************************************************
!
!! TRIANGLE_CONTAINS_POINT_2D finds if a point is inside a triangle in 2D.
!
!  Modified:
!
!    12 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = KIND_Rdp ) X1, Y1, X2, Y2, X3, Y3, the coordinates of
!    the corners of the triangle.
!
!    Input, real ( kind = KIND_Rdp ) X, Y, the point to be checked.
!
!    Output, logical INSIDE, is .TRUE. if (X,Y) is inside
!    the triangle or on its boundary, and .FALSE. otherwise.
!
  implicit none

  integer, parameter :: N = 2
  integer, parameter :: NRHS = 1

  real ( kind = KIND_Rdp ) a(N,N+NRHS)
  real ( kind = KIND_Rdp ) c1
  real ( kind = KIND_Rdp ) c2
  integer info
  logical inside
  real ( kind = KIND_Rdp ) x
  real ( kind = KIND_Rdp ) x1
  real ( kind = KIND_Rdp ) x2
  real ( kind = KIND_Rdp ) x3
  real ( kind = KIND_Rdp ) y
  real ( kind = KIND_Rdp ) y1
  real ( kind = KIND_Rdp ) y2
  real ( kind = KIND_Rdp ) y3
!
!  Set up the linear system
!
!    ( X2-X1  X3-X1 ) C1  = X-X1
!    ( Y2-Y1  Y3-Y1 ) C2    Y-Y1
!
!  which is satisfied by the barycentric coordinates of (X,Y).
!
  a(1,1) = x2 - x1
  a(1,2) = x3 - x1
  a(1,3) = x - x1

  a(2,1) = y2 - y1
  a(2,2) = y3 - y1
  a(2,3) = y - y1
!
!  Solve the linear system.
!
  call dmat_solve ( a, N, NRHS, info )

  if ( info /= 0 ) then
    write ( *, * ) ' '
    write ( *, * ) 'TRIANGLE_CONTAINS_POINT - Fatal error!'
    write ( *, * ) '  The linear system is singular.'
    write ( *, * ) '  The input data does not form a proper triangle.'
    stop
  end if

  c1 = a(1,3)
  c2 = a(2,3)
!
!  If the point is in the triangle, its barycentric coordinates
!  must both be nonnegative, and sum to no more than 1.
!
  if ( c1 < 0._KIND_Rdp .or. c2 < 0._KIND_Rdp ) then
    inside = .false.
  else if ( 1._KIND_Rdp < c1 + c2 ) then
    inside = .false.
  else
    inside = .true.
  end if

end subroutine

subroutine line_exp_point_dist_2d_Rdp ( x1, y1, x2, y2, x, y, dist )

!*******************************************************************************
!
!! LINE_EXP_POINT_DIST_2D: distance ( explicit line, point ) in 2D.
!
!  Formula:
!
!    The explicit form of a line in 2D is:
!
!      (X1,Y1), (X2,Y2).
!
!  Modified:
!
!    27 January 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = KIND_Rdp ) X1, Y1, X2, Y2.  (X1,Y1) and (X2,Y2) are two
!    points on the line.
!
!    Input, real ( kind = KIND_Rdp ) X, Y, the point whose distance from the line is
!    to be measured.
!
!    Output, real ( kind = KIND_Rdp ) DIST, the distance from the point to the line.
!
  implicit none

  real ( kind = KIND_Rdp ) bot
  real ( kind = KIND_Rdp ) dist
  real ( kind = KIND_Rdp ) dot
  real ( kind = KIND_Rdp ) t
  real ( kind = KIND_Rdp ) x
  real ( kind = KIND_Rdp ) xn
  real ( kind = KIND_Rdp ) x1
  real ( kind = KIND_Rdp ) x2
  real ( kind = KIND_Rdp ) y
  real ( kind = KIND_Rdp ) yn
  real ( kind = KIND_Rdp ) y1
  real ( kind = KIND_Rdp ) y2

  bot = enormsq0_2d ( x1, y1, x2, y2 )

  if ( bot == 0._KIND_Rdp ) then

    xn = x1
    yn = y1
!
!  (P-P1) dot (P2-P1) = Norm(P-P1) * Norm(P2-P1) * Cos(Theta).
!
!  (P-P1) dot (P2-P1) / Norm(P-P1)**2 = normalized coordinate T
!  of the projection of (P-P1) onto (P2-P1).
!
  else

    dot = ( x - x1 ) * ( x2 - x1 ) + ( y - y1 ) * ( y2 - y1 )

    t = dot / bot

    xn = x1 + t * ( x2 - x1 )
    yn = y1 + t * ( y2 - y1 )

  end if

  dist = enorm0_2d ( xn, yn, x, y )

end subroutine

subroutine dmat_solve_Rdp ( a, n, nrhs, info )

!*******************************************************************************
!
!! DMAT_SOLVE USEs Gauss-Jordan elimination to solve an N by N linear system.
!
!  Modified:
!
!    08 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real ( kind = KIND_Rdp ) A(N,N+NRHS), contains in rows and columns 1
!    to N the coefficient matrix, and in columns N+1 through
!    N+NRHS, the right hand sides.  On output, the coefficient matrix
!    area has been destroyed, while the right hand sides have
!    been overwritten with the corresponding solutions.
!
!    Input, integer NRHS, the number of right hand sides.  NRHS
!    must be at least 0.
!
!    Output, integer INFO, singularity flag.
!    0, the matrix was not singular, the solutions were computed;
!    J, factorization failed on step J, and the solutions could not
!    be computed.
!
  implicit none

  integer n
  integer nrhs

  real ( kind = KIND_Rdp ) a(n,n+nrhs)
  real ( kind = KIND_Rdp ) apivot
  real ( kind = KIND_Rdp ) factor
  integer i
  integer info
  integer ipivot
  integer j

  info = 0

  do j = 1, n
!
!  Choose a pivot row.
!
    ipivot = j
    apivot = a(j,j)

    do i = j+1, n
      if ( abs ( apivot ) < abs ( a(i,j) ) ) then
        apivot = a(i,j)
        ipivot = i
      end if
    end do

    if ( apivot == 0._KIND_Rdp ) then
      info = j
      return
    end if
!
!  Interchange.
!
    do i = 1, n + nrhs
      call d_swap ( a(ipivot,i), a(j,i) )
    end do
!
!  A(J,J) becomes 1.
!
    a(j,j) = 1._KIND_Rdp
    a(j,j+1:n+nrhs) = a(j,j+1:n+nrhs) / apivot
!
!  A(I,J) becomes 0.
!
    do i = 1, n

      if ( i /= j ) then

        factor = a(i,j)
        a(i,j) = 0._KIND_Rdp
        a(i,j+1:n+nrhs) = a(i,j+1:n+nrhs) - factor * a(j,j+1:n+nrhs)

      end if

    end do

  end do

end subroutine

END MODULE


module object_space_mod
  implicit none
  integer, parameter :: MAXBUF=20
!Defining the object
  type :: object_space
    character(MAXBUF) :: obj_name
    real :: pos(3), vel(3), acc(3), mass
  end type object_space

contains

!Function for creating a new Object
  type(object_space) function newObject(n, p, v, m)
    implicit none
    integer, parameter :: MAXBUFF=20
    character(MAXBUFF), intent(in) :: n
    real, intent(in) :: p(3), v(3), m
    real :: a(3)=0

    newObject=object_space(n, p, v, a, m)
  end function newObject

!Subroutine for calculating the total acceleration of an object.
  subroutine total_acceleration(object, siz, list)
    implicit none
    integer, intent(in) :: object, siz
    type(object_space), intent(inout) :: list(siz)
    integer :: i, j

!zero the existing acceleration
    list(object)%acc=0

!Loop through the list, skip the object that we are currently moving and calculate total acceleration a(t)
    do i=1, siz
      if (list(object)%obj_name /= list(i)%obj_name) then
        !Calculate acceleration for all components
        do j=1, 3
          list(object)%acc(j) = list(object)%acc(j) + calc_acceleration(list(object), list(i), j)
        end do
      end if
    end do
  end subroutine total_acceleration

!Calculate acceleration for one component
  real function calc_acceleration(object1, object2, comp)
     implicit none
     type(object_space), intent(in) :: object1, object2
     real :: acc, grav_acc
     integer :: comp

     grav_acc = 4*(3.1415**2)

     if (dist_between(object1, object2) /= 0) then
       acc = grav_acc*(object2%pos(comp) - object1%pos(comp)) * object2%mass/(dist_between(object1, object2)**3)
     else
       acc = 0
     end if

     calc_acceleration = acc
  end function calc_acceleration

!Distance between objects o1 and o2
  real function dist_between(o1, o2)
    implicit none
    type(object_space), intent(in) :: o1, o2
    real :: distance

    distance = ((o2%pos(1)-o1%pos(1))**2 + (o2%pos(2)-o1%pos(2))**2 + (o2%pos(3)-o1%pos(3))**2)**0.5

    dist_between = distance
  end function dist_between

!print out info of the object
  subroutine print_object(object)
    implicit none
    type(object_space) :: object
    print *, object%obj_name, object%pos(1), object%pos(2), object%pos(3)
  end subroutine

end module


program i
  integer::b = 10
  integer::c = 15
  integer::a= b * c + c / b ** c
end program i


use PlantFEM
implicit none

integer(int32) :: i
real(real64)   :: a_n, a
type(IO_) :: f

! create a sequence
call f%open("sequence.txt","w")
! a_1 = 1.0
a_n=1.0d0
do i=1,100000
    ! a_{n+1} = a_{n} + 1 / a_{n}
    a = a_n + 1.0d0/a_n
    write(f%fh,*) i, a
    a_n = a
enddo
call f%close()

! plot 2-D graph without lines
call f%plot("sequence.txt")

! plot 2-D graph with lines
call f%plot("sequence.txt","with line")

end


!> The problem is to determine the values of x(1), x(2), ..., x(9)
!>  which solve the system of tridiagonal equations
!>     (3-2*x(1))*x(1)           -2*x(2)                   = -1
!>             -x(i-1) + (3-2*x(i))*x(i)         -2*x(i+1) = -1, i=2-8
!>                                 -x(8) + (3-2*x(9))*x(9) = -1
program example_hybrd

    use minpack, only: hybrd, enorm, dpmpar
    implicit none
    integer j, n, maxfev, ml, mu, mode, nprint, info, nfev, ldfjac, lr, nwrite
    double precision xtol, epsfcn, factor, fnorm
    double precision x(9), fvec(9), diag(9), fjac(9, 9), r(45), qtf(9), &
        wa1(9), wa2(9), wa3(9), wa4(9)

    !> Logical output unit is assumed to be number 6.
    data nwrite/6/

    n = 9

    !> The following starting values provide a rough solution.
    do j = 1, 9
        x(j) = -1.0d0
    end do

    ldfjac = 9
    lr = 45

    !> Set xtol to the square root of the machine precision.
    !>  unless high precision solutions are required,
    !>  this is the recommended setting.
    xtol = dsqrt(dpmpar(1))

    maxfev = 2000
    ml = 1
    mu = 1
    epsfcn = 0.0d0
    mode = 2
    do j = 1, 9
        diag(j) = 1.0d0
    end do
    factor = 1.0d2
    nprint = 0

    call hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, &
               mode, factor, nprint, info, nfev, fjac, ldfjac, &
               r, lr, qtf, wa1, wa2, wa3, wa4)
    fnorm = enorm(n, fvec)
    write (nwrite, 1000) fnorm, nfev, info, (x(j), j=1, n)

1000 format(5x, "FINAL L2 NORM OF THE RESIDUALS", d15.7// &
           5x, "NUMBER OF FUNCTION EVALUATIONS", i10// &
           5x, "EXIT PARAMETER", 16x, i10// &
           5x, "FINAL APPROXIMATE SOLUTION"//(5x, 3d15.7))

    !> Results obtained with different compilers or machines
    !>  may be slightly different.
    !>
    !>> FINAL L2 NORM OF THE RESIDUALS  0.1192636D-07
    !>>
    !>> NUMBER OF FUNCTION EVALUATIONS        14
    !>>
    !>> EXIT PARAMETER                         1
    !>>
    !>> FINAL APPROXIMATE SOLUTION
    !>>
    !>>  -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
    !>>  -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
    !>>  -0.6657920D+00 -0.5960342D+00 -0.4164121D+00

contains

    !> Subroutine fcn for hybrd example.
    subroutine fcn(n, x, fvec, iflag)

        implicit none
        integer n, iflag
        double precision x(n), fvec(n)

        integer k
        double precision one, temp, temp1, temp2, three, two, zero
        data zero, one, two, three/0.0d0, 1.0d0, 2.0d0, 3.0d0/

        if (iflag /= 0) go to 5

        !! Insert print statements here when nprint is positive.

        return
5       continue
        do k = 1, n
            temp = (three - two*x(k))*x(k)
            temp1 = zero
            if (k /= 1) temp1 = x(k - 1)
            temp2 = zero
            if (k /= n) temp2 = x(k + 1)
            fvec(k) = temp - temp1 - two*temp2 + one
        end do
        return

    end subroutine fcn

end program example_hybrd


! Copyright (C) 2015-2017, Simone Marsili
! All rights reserved.
! License: BSD 3 clause

module scrs
  use kinds
  implicit none
  private
  public :: compute_scores
  public :: print_mat

contains

  pure real(kflt) function frobenius(a)
    real(kflt), intent(in) :: a(:,:)

    frobenius = sqrt(sum(a**2))
  end function frobenius

  pure subroutine apc_correction(a)
    real(kflt), intent(inout) :: a(:,:)
    real(kflt), allocatable :: sums(:)
    real(kflt) :: totsum
    integer :: err
    integer :: i,j
    integer :: n

    n = size(a,1)
    allocate(sums(n),stat=err)
    do i = 1,n
       sums(i) = sum(a(:,i))
    end do
    totsum = sum(sums)
    do j = 1,n
       do i = j,n
          a(i,j) = a(i,j) - sums(i)*sums(j)/totsum
          a(j,i) = a(i,j)
       end do
    end do
    deallocate(sums)
  end subroutine apc_correction

  subroutine print_mat(mat,uscrs,frmt,nerr)
    ! https://people.sc.fsu.edu/~jburkardt/data/mm/mm.html
    real(kflt), intent(in) :: mat(:,:)
    integer, intent(in) :: uscrs
    character(1), intent(in) :: frmt
    integer, intent(out) :: nerr
    logical :: inds = .true.
    integer :: i,j,n1,n2

    nerr = 0
    ! check format
    if (.not. any(["r","c","a"] == frmt)) then
       write(0,*) "error ! unknown format for scores matrix file"
       nerr = nerr + 1
       return
    end if
    n1 = size(mat,1)
    n2 = size(mat,2)
    ! write header line
    select case(frmt)
    case("r")
       do j = 1,n1
          do i = j,n2
             write(uscrs,'(i5,1x,i5,1x,f8.4)') i, j, mat(i,j)
          end do
       end do
    case("a")
       write(uscrs,'(a)') "%%MatrixMarket matrix array real symmetric"
       write(uscrs,'(a)') "%Lower triangular, column-major order"
       write(uscrs,'(i5,1x,i5)') n1,n2
       do j = 1,n1
          do i = j,n2
             write(uscrs,'(f8.4)') mat(i,j)
          end do
       end do
    case("c")
       write(uscrs,'(a)') "%%MatrixMarket matrix coordinate real symmetric"
       write(uscrs,'(a)') "%Lower triangular, column-major order"
       write(uscrs,'(i5,1x,i5,1x,i5)') n1,n2,n1*n2
       do j = 1,n1
          do i = j,n2
             write(uscrs,'(i5,1x,i5,1x,f8.4)') i, j, mat(i,j)
          end do
       end do
    end select

  end subroutine print_mat

  subroutine compute_scores(nv,ns,couplings,ignore_pivot,scores)
    implicit none
    integer(kint), intent(in) :: nv,ns
    real(kflt), intent(in) :: couplings(ns,ns,nv,nv)
    integer, intent(in) :: ignore_pivot
    real(kflt), intent(out) :: scores(nv,nv)
    integer :: iv,jv,err,is,js
    real(kflt) :: sums(nv),rsum(ns),csum(ns),matij(ns,ns),matji(ns,ns)
    real(kflt) :: totsum
    integer :: inds(ns-1)

    scores = 0.0_kflt
    do iv = 1,nv-1
       do jv = iv+1,nv
          if (ignore_pivot >= 1 .and. ignore_pivot <= ns) then
             is = 0
             do js = 1,ns
                if (js /= ignore_pivot) then
                   is = is + 1
                   inds(is) = js
                end if
             end do
             matij = couplings(inds,inds,iv,jv)
             matji = couplings(inds,inds,jv,iv)
          else
             matij = couplings(:,:,iv,jv)
             matji = couplings(:,:,jv,iv)
          end if
          call double_center(matij)
          call double_center(matji)
          scores(iv,jv) = sum((matij + transpose(matji))**2)
          scores(jv,iv) = scores(iv,jv)
       end do
    end do
    scores = 0.5_kflt * sqrt(scores)
    do iv = 1,nv
       sums(iv) = sum(scores(:,iv))
    end do
    totsum = sum(sums)
    do jv = 1,nv
       do iv = jv,nv
          scores(iv,jv) = scores(iv,jv) - sums(iv)*sums(jv)/totsum
          scores(jv,iv) = scores(iv,jv)
       end do
    end do
  end subroutine compute_scores

  pure subroutine double_center(a)
    real(kflt), intent(inout) :: a(:,:)
    integer :: i,j,n,m
    real(kflt) :: totsum
    real(kflt), allocatable :: rsum(:),csum(:)
    integer :: err
    n = size(a,dim=1)
    m = size(a,dim=2)
    allocate(rsum(n),csum(m),stat=err)
    totsum = sum(a) / real(n*m)
    csum = sum(a,dim=2) / real(n)
    rsum = sum(a,dim=1) / real(m)
    do j = 1,m
       do i = 1,n
          a(i,j) =  a(i,j) - csum(i) - rsum(j) + totsum
       end do
    end do
    deallocate(rsum,csum)
  end subroutine double_center

end module scrs


c
c input:                  * * ****
      	subroutine lstsqr(x,y,npts,a,b,r)
c output:                          + + +
c----------------------------------------------------------------------
c
c   Linear least-squares fit: y = a + bx
c
c   Input:
c   x,y   -=- arrays containing coordinates of points to be fit
c   npts  -=- size of above arrays
c
c   Output:
c   a,b   -=- fitted constants
c   r	  -=- correlation coefficients
c
c   Non-system routines: none
c
c----------------------------------------------------------------------
      	dimension x(npts), y(npts)
      	real n
      	n=float(npts)
c
c   Initialize sums
c
      	do 10 i = 1, npts
      	  sumx  = 0.0
      	  sumy  = 0.0
      	  sumxx = 0.0
      	  sumyy = 0.0
 	  sumxy = 0.0
10	continue
c
c   Accumulate sums
c
      	do 20 i = 1, npts
      	  sumx  = sumx  + x(i)
      	  sumy  = sumy  + y(i)
      	  sumxx = sumxx + x(i)*x(i)
      	  sumyy = sumyy + y(i)*y(i)
      	  sumxy = sumxy + x(i)*y(i)
20	continue
c
c   Calculate coefficients
c
      	tmp1=sumx*sumx/n
      	tmp2=sumy*sumy/n
      	b=(sumxy-(sumx*sumy/n))/(sumxx-tmp1)
      	a=(sumy/n)-(b*sumx/n)
      	tmp3=(sumxy-(sumx*sumy/n))**2
      	tmp4=sumxx-tmp1
      	tmp5=sumyy-tmp2
      	r=tmp3/(tmp4*tmp5)
c
      	return
      	end


    Program zhptrd_example

!     ZHPTRD Example Program Text

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

!     .. Use Statements ..
      Use lapack_interfaces, Only: zhptrd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, j, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ap(:), tau(:)
      Real (Kind=dp), Allocatable :: d(:), e(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs
!     .. Executable Statements ..
      Write (nout, *) 'ZHPTRD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (ap(n*(n+1)/2), tau(n-1), d(n), e(n-1))

!     Read A from data file and copy a into AW

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)((ap(i+j*(j-1)/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
      End If

!     Reduce A to tridiagonal form
      Call zhptrd(uplo, n, ap, d, e, tau, info)

      If (info==0) Then
!       Print the diagonal and off-diagonal of tridiagonal T.
!       The absolute value of E is printed since this can vary by a change of
!       sign (corresponding to multiplying through a column of Q by -1).

        Write (nout, *)
        Write (nout, *) &
          'Diagonal and off-diagonal elements of tridiagonal form'
        Write (nout, *)
        Write (nout, 100) 'i', 'D', 'E'
        Do i = 1, n - 1
          Write (nout, 110) i, d(i), abs(e(i))
        End Do
        Write (nout, 110) n, d(n)

      Else
        Write (nout, 120) info
      End If

100   Format (5X, A, 9X, A, 12X, A)
110   Format (1X, I5, 2(1X,F12.5))
120   Format (1X, '** ZHPTRD retuned with INFO = ', I10)

    End Program


program matrix_reduce
use, intrinsic :: iso_fortran_env, only : output_unit, error_unit, &
                                          dp => REAL64
use :: mpi
implicit none
integer, parameter :: root = 0
integer :: rank, size, istat, ierr
integer :: nr_rows, nr_cols, nr_iters, iter, i, j
character(len=15) :: argv
real(kind=dp), allocatable, dimension(:, :) :: matrix, total_matrix
real(kind=dp) :: r, total

call MPI_Init(ierr)
call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
call MPI_Comm_size(MPI_COMM_WORLD, size, ierr)

! get command line arguments, and broadcast them to all
if (rank == root) then
    nr_rows = 5
    if (command_argument_count() >= 1) then
        call get_command_argument(1, argv)
        read (argv, '(I10)') nr_rows
    end if
    if (command_argument_count() >= 2) then
        call get_command_argument(2, argv)
        read (argv, '(I10)') nr_cols
    else
        nr_cols = nr_rows
    end if
    if (command_argument_count() >= 3) then
        call get_command_argument(3, argv)
        read (argv, '(I10)') nr_iters
    else
        nr_iters = 1
    end if
    write (unit=output_unit, fmt='(3(A, I10, /))') &
        'nr. rows: ', nr_rows, &
        'nr. columns: ', nr_cols, &
        'nr. iterations: ', nr_iters
end if
call MPI_Bcast(nr_rows, 1, MPI_INTEGER, root, MPI_COMM_WORLD, ierr)
call MPI_Bcast(nr_cols, 1, MPI_INTEGER, root, MPI_COMM_WORLD, ierr)
call MPI_Bcast(nr_iters, 1, MPI_INTEGER, root, MPI_COMM_WORLD, ierr)

! allocate matrix for each process
allocate(matrix(nr_rows, nr_cols), stat=istat)
if (istat /= 0) then
    write (unit=error_unit, fmt='(A)'), 'can not allocate matrix'
    call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
end if

! allocate and initialize matrix for the root process
if (rank == root) then
    allocate(total_matrix(nr_rows, nr_cols), stat=istat)
    if (istat /= 0) then
        write (unit=error_unit, fmt='(A)'), 'can not allocate total_matrix'
        call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
    end if
end if

do iter = 1, nr_iters
    call random_number(r)
    do j = 1, nr_cols
        do i = 1, nr_rows
            matrix(i, j) = 2*r + i + rank*(j - 1) + rank*size
        end do
    end do

    call MPI_Reduce(matrix, total_matrix, &
                    nr_rows*nr_cols, MPI_DOUBLE_PRECISION, &
                    MPI_SUM, root, MPI_COMM_WORLD, ierr)
    if (rank == root) then
        total = sum(total_matrix)
        write(unit=output_unit, fmt='(A, I5, F8.1)') &
            'iteration', iter, total
    end if
end do

if (rank == root .and. nr_rows < 20 .and. nr_cols < 20) then
    do i = 1, nr_rows
        write (unit=output_unit, fmt='(*(F8.1))') total_matrix(i, :)
    end do
end if

call MPI_Finalize(ierr)

end program matrix_reduce


      INTEGER FUNCTION FINDI(X,A,N)	!Binary chopper. Find i such that X = A(i)
Careful: it is surprisingly difficult to make this neat, due to vexations when N = 0 or 1.
       REAL X,A(*)		!Where is X in array A(1:N)?
       INTEGER N		!The count.
       INTEGER L,R,P		!Fingers.
        L = 0			!Establish outer bounds, to search A(L+1:R-1).
        R = N + 1		!L = first - 1; R = last + 1.
        GO TO 1			!Hop to it.
    2   L = P			!A(P) < X. Shift the left bound up: X follows A(P).
    1   P = (R - L)/2		!Probe point. Beware INTEGER overflow with (L + R)/2.
        IF (P.LE.0) GO TO 5	!Aha! Nowhere!! The span is empty.
        P = P + L		!Convert an offset from L to an array index.
        IF (X - A(P)) 3,4,2	!Compare to the probe point.
    3   R = P			!X < A(P). Shift the right bound down: X precedes A(P).
        GO TO 1			!Try again.
    4   FINDI = P		!A(P) = X. So, X is found, here!
       RETURN			!Done.
Curse it!
    5   FINDI = -L		!X is not found. Insert it at L + 1, i.e. at A(1 - FINDI).
      END FUNCTION FINDI	!A's values need not be all different, merely in order.