! =============================================================================
! Module to compute the eigenvalues and eigenvectors of 3x3 real symmetric
! matrices. It uses the Jacobi algorithm according to
!       Rutishauser, H. The Jacobi method for real symmetric matrices.
!       Numer. Math. 9, 1-10 (1966). https://doi.org/10.1007/BF02165223
! =============================================================================
module jacobi
    use constants, only : hundred, one, zero, f12
    implicit none

    private
        integer, parameter :: n = 3 ! we have 3x3 matrices
        double precision, parameter :: atol = 1.0e-15

    public :: jacobi_diagonalise, jacobi_eigenvalues

    contains

        pure subroutine givens(A, D, i, j, c, s, t, tau)
            double precision, intent(in)  :: A(n, n), D(n)
            integer,          intent(in)  :: i, j
            double precision, intent(out) :: c, s, t, tau
            double precision              :: theta, g, h, aij

            aij = A(i, j)
            g = hundred * dabs(aij)
            h = D(j) - D(i)
            if (dabs(h) + g == dabs(h)) then
                ! sign(A, B) returns A with the sign of B
                ! We need to add epsilon with the proper sign
                ! since h might be -epsilon causing a division by zero.
                t = aij / (h + sign(epsilon(h), h))
            else
                ! sign(A, B) returns A with the sign of B
                ! We need to add epsilon with the proper sign
                ! since aij might be -epsilon causing a division by zero.
                theta = f12 * h / (aij + sign(epsilon(aij), aij))
                t = one / (dabs(theta) + dsqrt(one + theta ** 2))
                if (theta < zero) then
                    t = -t
                endif
            endif

            ! c = cos(theta)
            c = one / dsqrt(one + t ** 2)

            ! s = sin(theta)
            s = t * c

            tau = s / (one + c)
        end subroutine

        !
        ! Jacobi algorithm -- eigenvalues and eigenvectors
        !

        ! Apply Jacobi (or Givens) rotation to make
        ! A(i, j) = 0. A' = P^T * A * P.
        ! @param[inout] A current state of 3x3 matrix
        ! @param[inout] V current state of eigenvectors
        ! @param[in] i the row
        ! @param[in] j first column with i .ne. j
        ! @param[in] k second column with i .ne. k
        pure subroutine apply_rotation_AV(A, D, Z, i, j, V)
            double precision, intent(inout) :: A(n, n), D(n), Z(n)
            integer,          intent(in)    :: i, j
            double precision, intent(inout) :: V(n, n)
            double precision                :: c, s, t, tau
            integer                         :: k
            double precision                :: g, h

            ! compute the rotation angle theta
            ! Reference:    Rutishauser, H. The Jacobi method for real symmetric matrices.
            !               Numer. Math. 9, 1-10 (1966). https://doi.org/10.1007/BF02165223

            call givens(A, D, i, j, c, s, t, tau)

            !
            ! Apply Givens rotation to matrix
            !

            h = t * A(i, j)
            Z(i) = Z(i) - h
            Z(j) = Z(j) + h
            D(i) = D(i) - h
            D(j) = D(j) + h
            A(i, j) = zero

            do k = 1, i-1
                g = A(k, i)
                h = A(k, j)
                A(k, i) = g - s * (h + g * tau)
                A(k, j) = h + s * (g - h * tau)
            enddo

            do k = i+1, j-1
                g = A(i, k)
                h = A(k, j)
                A(i, k) = g - s * (h + g * tau)
                A(k, j) = h + s * (g - h * tau)
            enddo

            do k = j+1, n
                g = A(i, k)
                h = A(j, k)
                A(i, k) = g - s * (h + g * tau)
                A(j, k) = h + s * (g - h * tau)
            enddo

            do k = 1, n
                ! accumulate eigenvector
                g = V(k, i)
                h = V(k, j)
                V(k, i) = c * g - s * h
                V(k, j) = s * g + c * h
            enddo
        end subroutine apply_rotation_AV

        ! Diagonalise a real symmetric 3x3 matrix A = V^T * D * V
        ! where D is a diagonal matrix with the eigenvalues and
        ! V is the eigenvector matrix. The eigenvalues are in
        ! descending order.
        ! The input matrix is overwritten and will be the diagonal
        ! matrix storing the eigenvalues, V contains the eigenvectors.
        ! The eigenvector V(:, i) belongs to eigenvalue A(i, i).
        ! @param[inout] A real symmetric 3x3 matrix
        ! @param[out] D eigenvalues in descending order
        ! @param[out] V eigenvector matrix
        pure subroutine jacobi_diagonalise(A, D, V)
            double precision, intent(inout) :: A(n, n)
            double precision, intent(out)   :: D(n)
            double precision, intent(out)   :: V(n, n)
            double precision                :: B(n), Z(n)
            integer                         :: i, j
            double precision                :: sm

            ! initialise eigenvector matrix to identity matrix
            do j = 1, n
                D(j) = A(j, j)
                B(j) = D(j)
                Z(j) = zero
                do i = 1, n
                    V(i, j) = zero
                    if (i == j) then
                        V(i, j) = one
                    endif
                enddo
            enddo

            ! sum of off-diagonal entries
            ! sm should convergence to zero
            sm = dabs(A(1, 2)) + dabs(A(1, 3)) + dabs(A(2, 3))

            do while (sm >= atol)

                do i = 1, n-1
                    do j = i+1, n
                        call apply_rotation_AV(A, D, Z, i, j, V)
                    enddo
                enddo

                B = B + Z
                D = B
                Z = zero
                ! update sum of off-diagonals
                sm = dabs(A(1, 2)) + dabs(A(1, 3)) + dabs(A(2, 3))
            enddo

            call sort_descending(D, V)

        end subroutine jacobi_diagonalise

        ! Sort the eigenvalues in descending order.
        ! It sorts the eigenvector matrix accordingly.
        ! @param[inout] D eigenvalues
        ! @param[inout] V eigenvector matrix
        pure subroutine sort_descending(D, V)
            double precision, intent(inout) :: D(n)
            double precision, intent(inout) :: V(n, n)
            double precision                :: teval, tevec(n)

            if (D(2) > D(1)) then
                teval = D(1)
                D(1) = D(2)
                D(2) = teval
                tevec = V(:, 1)
                V(:, 1) = V(:, 2)
                V(:, 2) = tevec
            endif

            if (D(3) > D(2)) then
                teval = D(2)
                D(2) = D(3)
                D(3) = teval
                tevec = V(:, 2)
                V(:, 2) = V(:, 3)
                V(:, 3) = tevec
            endif

            if (D(2) > D(1)) then
                teval = D(1)
                D(1) = D(2)
                D(2) = teval
                tevec = V(:, 1)
                V(:, 1) = V(:, 2)
                V(:, 2) = tevec
            endif
        end subroutine sort_descending

        !
        ! Jacobi algorithm -- eigenvalues only
        !

        pure subroutine apply_rotation(A, D, Z, i, j)
            double precision, intent(inout) :: A(n, n), D(n), Z(n)
            integer,          intent(in)    :: i, j
            double precision                :: c, s, t, tau
            integer                         :: k
            double precision                :: g, h

            ! compute the rotation angle theta
            ! Reference:    Rutishauser, H. The Jacobi method for real symmetric matrices.
            !               Numer. Math. 9, 1-10 (1966). https://doi.org/10.1007/BF02165223

            call givens(A, D, i, j, c, s, t, tau)

            !
            ! Apply Givens rotation to matrix
            !

            h = t * A(i, j)
            Z(i) = Z(i) - h
            Z(j) = Z(j) + h
            D(i) = D(i) - h
            D(j) = D(j) + h
            A(i, j) = zero

            do k = 1, i-1
                g = A(k, i)
                h = A(k, j)
                A(k, i) = g - s * (h + g * tau)
                A(k, j) = h + s * (g - h * tau)
            enddo

            do k = i+1, j-1
                g = A(i, k)
                h = A(k, j)
                A(i, k) = g - s * (h + g * tau)
                A(k, j) = h + s * (g - h * tau)
            enddo

            do k = j+1, n
                g = A(i, k)
                h = A(j, k)
                A(i, k) = g - s * (h + g * tau)
                A(j, k) = h + s * (g - h * tau)
            enddo
        end subroutine apply_rotation

        ! Diagonalise a real symmetric 3x3 matrix A = V^T * D * V
        ! where D is a diagonal matrix with the eigenvalues and
        ! V is the eigenvector matrix. The eigenvalues are in
        ! descending order.
        ! The input matrix is overwritten, the diagonal
        ! entries will be storing the eigenvalues
        ! @param[inout] A real symmetric 3x3 matrix
        ! @param[out] D eigenvalues in descending order
        pure subroutine jacobi_eigenvalues(A, D)
            double precision, intent(inout) :: A(n, n)
            double precision, intent(out)   :: D(n)
            double precision                :: B(n), Z(n)
            integer                         :: i, j
            double precision                :: sm

            ! initialise
            do j = 1, n
                D(j) = A(j, j)
                B(j) = D(j)
                Z(j) = zero
            enddo

            ! sum of off-diagonal entries
            ! sm should convergence to zero
            sm = dabs(A(1, 2)) + dabs(A(1, 3)) + dabs(A(2, 3))

            do while (sm > atol)

                do i = 1, n-1
                    do j = i+1, n
                        call apply_rotation(A, D, Z, i, j)
                    enddo
                enddo

                B = B + Z
                D = B
                Z = zero
                ! update sum of off-diagonals
                sm = dabs(A(1, 2)) + dabs(A(1, 3)) + dabs(A(2, 3))
            enddo

            call sort_eigenvalues(D)

        end subroutine jacobi_eigenvalues

        ! Sort the eigenvalues in descending order.
        ! @param[inout] D eigenvalues
        pure subroutine sort_eigenvalues(D)
            double precision, intent(inout) :: D(n)
            double precision                :: teval

            if (D(2) > D(1)) then
                teval = D(1)
                D(1) = D(2)
                D(2) = teval
            endif

            if (D(3) > D(2)) then
                teval = D(2)
                D(2) = D(3)
                D(3) = teval
            endif

            if (D(2) > D(1)) then
                teval = D(1)
                D(1) = D(2)
                D(2) = teval
            endif
        end subroutine sort_eigenvalues

end module jacobi


!>
module VortexPoint2D
    use PrecisionMod,   only: MK
    implicit none
    real(MK),parameter :: MINNORM2=1e-8
contains
    subroutine fUi_VortexPoint2D_11(DeltaP,Intensity,SmoothModel,SmoothParam,bComputeGrad,Uind, Grad)
        use MathConstants , only: twopi_inv
        implicit none
        ! Input/output arguments
        real(MK), dimension(3), intent(in) :: DeltaP       !< 3 x 1   Pcp-Pv
        real(MK), intent(in)               :: Intensity    !<  Circulation Gamma
        integer, intent(in) ,optional      :: SmoothModel  !<
        real(MK), intent(in),optional      :: SmoothParam  !<
        logical, intent(in)                :: bComputeGrad !<
        real(MK), dimension(3),intent(out) :: Uind         !< No Side effects. Note that
        real(MK), dimension(9),intent(out) :: Grad         !< No Side effects
        !         ! Variables declaration
        real(MK) :: r2     !<
        real(MK) :: factor !<
        real(MK) :: E      !<
        real(MK) :: rho2   !<
        real(MK) :: Qm     !<
        !
        ! No need of gradient in 2D
        if(bComputeGrad) then
            Grad(1:9)=0.0_MK !
        else
            Grad(1:9)=0.0_MK
        endif
        Uind=0.0_MK

        r2  = DeltaP(1)**2+ DeltaP(2)**2
        if (r2<MINNORM2) then! to avoid strong singularity
            Uind(3)=0.0_MK
            Grad(1:9)=0.0_MK
!         elseif (r2>100) then
!             Uind(3)=0.0_MK
!             Grad(1:9)=0.0_MK
        else
            select case (SmoothModel) !
            case (0) ! No mollification, exept on zero
                factor=1._MK/r2
            case (22) !
                ! Finite support
                factor=1._MK/sqrt(SmoothParam**4+r2**2)
                ! --------------------------------------------------------------------------------
                ! --- Majda Kernels
                ! --------------------------------------------------------------------------------
            case (2) ! Second order - Gaussian - Majada
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2);
                Qm     = 1._MK;
                factor = (1._MK-Qm*E)/r2;
            case(4)  ! Fourth Order - Gaussian - Majda
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2);
                Qm     = 1._MK-rho2;
                factor = (1._MK-Qm*E)/r2;
            case(6)  ! Sixth Order - Gaussian - Majda
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2);
                Qm     = (1._MK-2._MK*rho2+rho2**2/2._MK);
                factor = (1._MK-Qm*E)/r2;
            case(8)  ! Eigth Order - Gaussian - Majda
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2);
                Qm     = (1._MK-3_MK*rho2+3._MK*rho2**2/2._MK-rho2**3/6._MK);
                factor = (1._MK-Qm*E)/r2;
            case(10)  ! Tenth Order - Gaussian - Mads
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2/2._MK);  !!!!!!!! Note the 2 in the Gaussian
                Qm     = (1._MK-2._MK*rho2+3./4.*rho2**2-1./12.*rho2**3+1./384.*rho2**4);
                factor = (1._MK-Qm*E)/r2;
                ! --------------------------------------------------------------------------------
                ! --- Mads Kernel (they are the same, it's just the fact that there is a 2 in the exponential that changes things)
                ! --------------------------------------------------------------------------------
            case(102) ! Second order Gaussian - Mads
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2/2._MK);  !Note the 2 in the Gaussian
                Qm     = 1._MK;
                factor = (1._MK-Qm*E)/r2;
            case(104) ! Fourth order Gaussian - Mads
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2/2._MK);  !Note the 2 in the Gaussian
                Qm     = 1._MK-1._MK/2._MK*rho2;
                factor = (1._MK-Qm*E)/r2;
            case(106)  ! Sixth Order - Gaussian - Mads
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2/2._MK);    !Note the 2 in the Gaussian
                Qm     = (1._MK-rho2+1._MK/8._MK*rho2**2);
                factor = (1._MK-Qm*E)/r2;
            case(108)  ! Eigth Order - Gaussian - Mads
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2/2._MK);                    !Note the 2 in the Gaussian
                Qm     = (1._MK-3._MK/2._MK*rho2+3._MK/8._MK*rho2**2-1._MK/48._MK*rho2**3);
                factor = (1._MK-Qm*E)/r2;
            case(110)  ! Tenth Order - Gaussian - Mads
                rho2   = r2/SmoothParam**2;
                E      = exp(-rho2/2._MK);                               !Note the 2 in the Gaussian
                Qm     = (1._MK-2._MK*rho2+3./4.*rho2**2-1./12.*rho2**3+1./384.*rho2**4);
                factor = (1._MK-Qm*E)/r2;
            case default
                write(*,*)'2D vortex point: wrong smooth model'
                STOP -1
            end select
            factor = factor * Intensity * twopi_inv;
            Uind(1)=-DeltaP(2)*factor
            Uind(2)= DeltaP(1)*factor
            Uind(3)=0.0_MK

        endif

    end subroutine

end module VortexPoint2D


C23456789
C v0.0.1
C compile
C     f95 -shared -fPIC -o mc_pi.so mc_pi.f
C calling in R
C     dyn.load("~/a.out")
C     r = .Fortran("pso", gbest=rep(0, 4), x, y)
C sanity check on yhat
C     yhat = x %*% r$gbest
C     plot(yhat, pch=(y*2+6), col=(y*2+6))
C     abline(h=0, col="gray", lty=3)
C     legend("topleft", legend=c(0, 1), pch=c(6, 8), col=c(6, 8), bty="n")
C
C compute nn, return mse
C all hardcoded for this version
C   4 - 1
        function ann(w, x, y, yhat)
            double precision w(4, 1), x(100, 4), y(100,1), yhat(100,1)
            yhat = matmul(x, w)
            ann = sum((y-yhat)**2)/size(y)
        end function
C particle swarm optim
        subroutine pso(gbest, x, y)
        parameter (iter=1000, w=2.66, c1=.8, c2=.8, npar=12, nd=4)
        double precision par(npar, nd), pbest(npar, nd), gbest(nd)
        double precision r1(npar, nd), r2(npar, nd)
        double precision x(100, 4), y(100,1), yhat(100,1)
C initialize particles
        call random_number(par)
        call random_number(pbest)
        call random_number(gbest)
        do 99 i=1, iter
C update invdividual (personal) best
          do 69 j=1, npar
            parfit = ann(par(j, :), x, y, yhat)
            pbfit  = ann(pbest(j, :), x, y, yhat)
            if (parfit .lt. pbfit) then
              pbest(j, :) = par(j, :)
              kk = j
            end if
69        continue
C update global best
          gbfit  = ann(gbest, x, y, yhat)
          pbfit  = ann(pbest(kk, :), x, y, yhat)
          if ( pbfit  .lt. gbfit) then
            gbest  = pbest(kk, :)
          end if
C update particles
          call random_number(r1)
          call random_number(r2)
          par = w * par +
C cognitive velocity
     +      c1 * r1 * (pbest - par) +
C social velocity
     +      c2 * r2 *( transpose(spread(gbest, 2, npar)) - par)
99       continue
C        print *, gbest
C        print *, ann(gbest, x, y, yhat)
         end subroutine


!
! Perform a Jacobi sweep for a 2-d decomposition
!
      subroutine sweep2d( a, f, n, sx, ex, sy, ey, b )
      integer n, sx, ex, sy, ey
      double precision a(sx-1:ex+1, sy-1:ey+1), f(sx-1:ex+1, sy-1:ey+1), &
                       b(sx-1:ex+1, sy-1:ey+1)
!
      integer i, j
      double precision h
!
      h = 1.0d0 / dble(n+1)
      do j=sy, ey
         do i=sx, ex
            b(i,j) = 0.25 * (a(i-1,j)+a(i,j+1)+a(i,j-1)+a(i+1,j)) - &
                     h * h * f(i,j)
         enddo
      enddo
      return
      end


         subroutine test()

        implicit none
        integer ii,jj
        integer INFO2,ndim
!        real*8 aa(3,3),ee(3),ez(3)
        real*8 aa(4,4),ee(4),ez(4),bb(4,4)

       aa = 0.d0

       ndim = 4
       aa(1,1) = 2
       aa(2,2) = 2
       aa(1,2) = 1
       aa(2,1) = 1

       aa(3,3) = 3
       aa(4,4) = 3
       aa(3,4) = 1
       aa(4,3) = 1

!  DSYEV: computes all eigenvalues and, optionally, eigenvectors of a real symmetric matrix A
!  SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
!  ----------------------------
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!  A       (input/output) DOUBLE PRECISION array
!  W       (output) eigenvalues

       call dsyev('V','U',NDIM,aa,NDIM,ee,bb,3*NDIM-1,INFO2)
!       call sdiag(ndim,ndim,aa,ee,aa,ez,0)

       do ii=1,ndim
       do jj=1,ndim

          write(*,*) ii,jj,aa(jj,ii)

        enddo

        enddo
        do ii=1,ndim
          write(*,*) ii, ee(ii)
        enddo

        stop
       end


      subroutine mapc2m_inclusions(xc,yc,xp,yp,isperiodic)
      implicit none

      double precision xc,yc,xp,yp
      logical isperiodic

      double precision xc1,yc1,xp1,yp1
      double precision xlow,ylow,xhi,yhi, r1
      double precision xc0, yc0
      integer i, nbox
      logical inbox

      double precision boxes_com(6,100)
      integer n_box_com

      common /combox0/ n_box_com
      common /combox1/ boxes_com

      nbox = n_box_com

      xc0 = xc
      yc0 = yc

      if (isperiodic) then
         if (xc .lt. -1.d0) then
            xc0 = xc + 2
         elseif (xc .gt. 1.d0) then
            xc0 = xc - 2
         endif

         if (yc .lt. -1.d0) then
            yc0 = yc + 2
         elseif (yc .gt. 1.d0) then
            yc0 = yc - 2
         endif
      endif

      xp = xc0
      yp = yc0

      inbox = .false.
      do i = 1,nbox
c        # [xlow,ylow]x[xhi,yhi] are the ll and ur corners of
c        # included box in [-1,1]x[-1,1] units.
         xlow = boxes_com(1,i)
         ylow = boxes_com(2,i)
         xhi = boxes_com(3,i)
         yhi = boxes_com(4,i)

c        # Radius of enclosed circle is in 0 < r1 < 1.
         r1 = boxes_com(5,i)

c        # Scale [xlow,ylow]x[xhi,yhi] into [-1,1]x[-1,1]
         xc1 = -1.d0 + 2.d0*(xc0 - xlow)/(xhi - xlow)
         yc1 = -1.d0 + 2.d0*(yc0 - ylow)/(yhi - ylow)

         if (abs(xc1) .le. 1.d0 .and. abs(yc1) .le. 1.d0) then
            call mapc2m_inclusion2(xc1,yc1,xp1,yp1,r1)

c           # Scale physical coordinates back so that mapped
c           # region is in [xlow,ylow]x[xhi,yhi]
            xp = (xp1 + 1.d0)*(xhi - xlow)/2.d0 + xlow
            yp = (yp1 + 1.d0)*(yhi - ylow)/2.d0 + ylow
            inbox = .true.
         endif
         if (inbox) then
            exit
         endif
      enddo
      if (isperiodic) then
         if (xc .lt. -1) then
            xp = xp - 2
         elseif (xc .gt. 1) then
            xp = xp + 2
         endif
         if (yc .lt. -1) then
            yp = yp - 2
         elseif (yc .gt. 1) then
            yp = yp + 2
         endif
      endif

      end

c     # ------------------------------------------------------------------
c     MAPC2M_INCLUSION maps the grid [-1,1]x[-1,1] to a grid enclosing a
c     circle of radius r1 < 1.
c     # ------------------------------------------------------------------

      subroutine mapc2m_inclusion2(xc,yc,xp,yp,r1)
      implicit none

      double precision xc,yc,xp,yp,zp,r1

      double precision d, dinv, scale, s, r, w, ct
      logical use_convex

      d = max(abs(xc),abs(yc))
      r = max(sqrt(xc**2 + yc**2),1e-10)

      if (d .lt. r1) then
c        # --------------------------------------------------------------
c        # Map area inside of the circle
c        # -------------------------------------------------------------------

         scale = d/r

         xp = scale*xc
         yp = scale*yc

c        # Blend this map with the Cartesian map to get
c        # more Cartesian like grid near the center of the
c        # circle.  If we set this to false, we get concentric
c        # circles.
         use_convex = .true.
         if (use_convex) then
            w = (d/r1)**2
            xp = w*xp + (1.d0-w)*xc/sqrt(2.d0)
            yp = w*yp + (1.d0-w)*yc/sqrt(2.d0)
         endif
      else

c        # --------------------------------------------------------------
c        # Map area outside of the circle
c        # -------------------------------------------------------------------
         dinv = 1.d0/d

c        # d/r = cos(theta), where theta is the angle that a point
c        # makes with the x-axis.

         ct = d/r
         s = (1.d0 - r1*ct)/(1.d0 - r1)
         scale = s*(1.d0 - dinv) + dinv

         xp = scale*xc
         yp = scale*yc

      endif

      end


function esat(t)

! Computes saturation vapor pressure (Pa) from temperature (K).
!  Note: Computed with respect to liquid.

use constants

implicit none

real :: esat,t

esat=611.21*exp((17.502*(t-t0))/(t-32.18))

return
end

!===============================================================================

function potential_temp(t,p)

! Computes potential temperature from temp (K) and pressure (Pa).

use constants

implicit none

real :: t,p,potential_temp

potential_temp=t*(p0/p)**kappa

return
end

!===============================================================================

function relhum(t,mixrat,p)

! Computes relative humidity (fraction form)

implicit none

real :: t       ! Temperature (K)
real :: p       ! Pressure (Pa)
real :: mixrat  ! vapor mixing ratio
real :: mixsat  ! Saturation vapor mix. ratio
real :: relhum  ! RH (fraction)

relhum=mixrat/mixsat(t,p)

return
end

!===============================================================================

function mixsat(t,p)

! Computes saturation vapor mixing ratio as function of temp (K) and press( Pa).

use constants

implicit none

real :: esat,mixrat,p,satvpr,t,mixsat

satvpr=esat(t)
mixsat=(e*satvpr)/(p-satvpr)

return
end

!===============================================================================

function eq_potential_temp(t,p,w,rh)

! Calculates equivalent potential temperature given temperature,
! pressure, mixing ratio, and relative humidity via
! Bolton's equation.  (MWR 1980, P 1052, eq. 43)

implicit none

real :: t   ! temp (K)
real :: p   ! pressure (Pa)
real :: w   ! mixing ratio (kg/kg)
real :: rh  ! relative humidity (fraction)
real :: thtm,tlcl,eq_potential_temp

thtm=t*(100000./p)**(2./7.*(1.-(0.28*w)))
eq_potential_temp=thtm*exp((3.376/tlcl(t,rh)-0.00254)  &
                 *(w*1000.0*(1.0+0.81*w)))

return
end

!===============================================================================

function tlcl(t,rh)

! Computes the temperature of the Lifting Condensation Level
! given surface t and RH using Bolton's equation.  (MWR 1980, p 1048, #22)

implicit none

real :: denom,rh,t,term1,term2,tlcl

term1=1.0/(t-55.0)
term2=alog(rh/1.0)/2840.
denom=term1-term2
tlcl=(1.0/denom)+55.0

return
end

!===============================================================================

function dewpt(t,rh)

! Compute dew point from temperature (K) and RH (fraction).

use constants

implicit none

real :: dewpt,rh,t

dewpt=t/((-rvolv*alog(max(rh,0.01))*t)+1.0)
dewpt=min(t,dewpt)

return
end

!===============================================================================

function wobf(t)

! Name: wobuf function
!
! This function calculates the difference of the wet bulb potential
! temperatures for saturated and dry air given the temperature.
!
! It was created by Herman Wobus of the Navy Weather Research
! Facility from data in the Smithsonian Meteorological Tables.
!
!
! Let wbpts = wet bulb potential temperature for saturated air
!             at temperature t in celsius
!
! Let wbptd = wet bult potential temperature for dry air at
!             the same temperature.
!
! The Wobus function wobf (in degrees celsius) is defined by:
!
!             wobf(t) = wbpts - wbptd
!
! Although wbpts and wbptd are functions of both pressure and
! temperature, their difference is a function of temperature only.
!
! The Wobus function is useful for evaluating several thermodynamic
! quantities.
!
! If t is at 1000 mb, then t is potential temperature pt and
! wbpts = pt.  Thus,
!
!             wobf(pt) = pt - wbptd
!
! If t is at the condensation level, then t is the condensation
! temperature tc and wbpts is the wet bulb potential temperature
! wbpt.  Thus,
!
!             wobf(tc) = wbpt - wbptd
!
! Manipulating the above equations we get,
!
!             wbpt = pt - wobf(pt) + wobf(tc)   and
!
!             wbpts = pt - wobf(pt) + wobf(t)
!
! If t is equivalent potential temperature ept (implying that
! the air at 1000 mb is completely dry), then
!
!             wbpts = ept and wbptd = wbpt, thus,
!
!             wobf(ept) = ept - wbpt

implicit none

real :: pol,t,wobf,x

x=t-20.

if (x <= 0.) then
   pol=1.0              +x*(-8.8416605E-03   &
      +x*( 1.4714143E-04+x*(-9.6719890E-07   &
      +x*(-3.2607217E-08+x*(-3.8598073E-10)))))
   wobf=15.130/(pol**4)
else
   pol=1.               +x*(3.6182989E-03   &
      +x*(-1.3603273E-05+x*(4.9618922E-07   &
      +x*(-6.1059365E-09+x*(3.9401551E-11   &
      +x*(-1.2588129E-13+x*(1.6688280E-16)))))))
   wobf=(29.930/(pol**4))+(0.96*x)-14.8
endif

return
end

!===============================================================================

subroutine the2t(thetae,p,tparcel)

! Calculates temperature K) at any pressure (mb) level along a saturation
! adiabat by iteratively solving eq 2.76 from Wallace and Hobbs (1977).

! Adpated from USAF routine, B. Shaw, NOAA/FSL

use constants

implicit none

integer           :: iter
real, external    :: mixsat
real, intent(in)  :: p
real              :: tcheck
real              :: theta
real, intent(in)  :: thetae
real              :: tovtheta
real              :: arg
real, intent(out) :: tparcel
logical           :: converged

converged=.false.
tovtheta=(p/1000.)**kappa
tparcel=thetae/exp(lv*0.012/(cp*295.0))*tovtheta

do iter=1,50
   arg = lv*mixsat(tparcel,p*100.)/(cp*tparcel)
   if(arg .le. 80.)then
      theta = thetae / exp(arg)
   else
      print*,'Warning, large argument for exponent ', arg
      goto 999
   endif
   tcheck = theta * tovtheta
   if (abs(tparcel-tcheck) < 0.05) then
      converged=.true.
      exit
   endif
   tparcel=tparcel+(tcheck-tparcel)*0.3
enddo

999 continue
if (.not. converged) then
   print*,'Warning: thetae to temp calc did not converge.'
   print*,'  thetae and p:',thetae,p
   print*,'  tparcel:',tparcel
   print*,'  theta,tovtheta:',theta,tovtheta
endif

return
end

!===============================================================================

function wdir(u,v,xlon,orient,conefact)

! Computes wind direction from u/v components.  Converts the direction
!   to true direction if conefactor \= 0.

use constants

implicit none

real :: conefact,diff,orient,u,v,wdir,xlon

! Handle case where u is very small to prevent divide by 0.

if (abs(u) < 0.001) then
   if (v <= 0.) then
      wdir=0.
   else
      wdir=180.
   endif

! Otherwise, standard trig problem.

else
   wdir=270.-(atan2(v,u)*rad2deg)
   if (wdir > 360.) wdir=wdir-360.
endif

! Change to earth relative.

diff=(orient-xlon)*conefact
if (diff >  180.) diff=diff-360.
if (diff < -180.) diff=diff+360.

wdir=wdir-diff
if (wdir > 360.) wdir=wdir-360.
if (wdir < 0.) wdir=wdir+360.

return
end

!===============================================================================

function wspd(u,v)

! Computes wind velocity from u/v components.

implicit none

real :: u,v,wspd

wspd=sqrt((u*u)+(v*v))

return
end

!===============================================================================

function fahren(t)

! Converts from Celsius to fahrenheit

implicit none

real :: t,fahren

fahren=(1.8*t)+32.

return
end

!===============================================================================

function celsius(tf)

implicit none

real, parameter :: factor=5./9.
real :: tf,celsius

celsius=factor*(tf-32.)

return
end

!===============================================================================

function heatindex(temp_k,rh_pct)

! Computes heat index from a temperature (K) and RH (%).

use constants

implicit none

real :: celsius,fahren,heatindex,rh_pct,rh_pct_sqr,tf,tf_sqr,temp_k

rh_pct_sqr=rh_pct*rh_pct
tf=fahren(temp_k-t0)
tf_sqr=tf*tf

heatindex=-42.379+(2.04901523  *tf)                 &
                 +(10.1433312  *rh_pct)             &
                 -(0.22475541  *tf*rh_pct)          &
                 -(6.83783E-03 *tf_sqr)             &
                 -(5.481717E-02*rh_pct_sqr)         &
                 +(1.22874E-03 *tf_sqr*rh_pct)      &
                 +(8.52E-04    *rh_pct_sqr*tf)      &
                 -(1.99E-06    *tf_sqr*rh_pct_sqr)

heatindex=celsius(heatindex)+t0

return
end

!===============================================================================

function tw(t,td,p)

! This function returns the wet-bulb temperature tw (K)
!  given the temperature t (K), dew point td (K)
!  and pressure p (Pa).  See p.13 in stipanuk (1973), referenced
!  above, for a description of the technique.

! Baker,Schlatter	17-may-1982	original version

! Determine the mixing ratio line thru td and p.

aw=w(td,p)

! Determine the dry adiabat thru t and p.

ao=o(t,p)
pi=p

! Iterate to locate pressure pi at the intersection of the two
!  curves.  pi has been set to p for the initial guess.

do i=1,10
   x=0.02*(tmr(aw,pi)-tda(ao,pi))
   if (abs(x) < 0.01) goto 5
   pi=pi*(2.**(x))
enddo
5 continue

! Find the temperature on the dry adiabat ao at pressure pi.

ti=tda(ao,pi)

! The intersection has been located...now, find a saturation
!  adiabat thru this point.  Function os returns the equivalent
!  potential temperature (K) of a parcel saturated at temperature
!  ti and pressure pi.

aos=os(ti,pi)

! Function tsa returns the wet-bulb temperature (K) of a parcel at
!  pressure p whose equivalent potential temperature is aos.

tw=tsa(aos,p)

return
end

!===============================================================================

function w(t,p)

! This function returns the mixing ratio (kg/kg) given the temperature t (K)
!  and pressure (Pa).  The formula is quoted in most meteorological texts.

! Baker,Schlatter	17-may-1982	original version

implicit none

real :: t,p,x,esat,w

x=esat(t)
w=0.622*x/(p-x)

return
end

!===============================================================================

function o(t,p)

! G.S. Stipanuk     1973      	  original version.
! Reference stipanuk paper entitled:
!  "algorithms for generating a skew-t, log p
!     diagram and computing selected meteorological quantities."
!     atmospheric sciences laboratory
!     u.s. army electronics command
!     white sands missile range, new mexico 88002
!     33 pages
! Baker, Schlatter  17-may-1982

! This function returns potential temperature (K) given
!  temperature t (K) and pressure p (Pa) by solving the poisson
!  equation.

implicit none

real :: t,p,o

o=t*((100000./p)**.286)

return
end

!===============================================================================

function tmr(w,p)

!	g.s. stipanuk     1973      	  original version.
!	reference stipanuk paper entitled:
!            "algorithms for generating a skew-t, log p
!	     diagram and computing selected meteorological
!	     quantities."
!	     atmospheric sciences laboratory
!	     u.s. army electronics command
!	     white sands missile range, new mexico 88002
!	     33 pages
!	baker, schlatter  17-may-1982

!   this function returns the temperature (K) on a mixing
!   ratio line w (kg/kg) at pressure p (Pa). the formula is given in
!   table 1 on page 7 of stipanuk (1973).

!   initialize constants

data c1/.0498646455/,c2/2.4082965/,c3/7.07475/
data c4/38.9114/,c5/.0915/,c6/1.2035/

x=alog10(w*p*0.01/(0.622+w))
tmr=10.**(c1*x+c2)-c3+c4*((10.**(c5*x)-c6)**2.)

return
end

!===============================================================================

function tda(th,p)

!	g.s. stipanuk     1973      	  original version.
!	reference stipanuk paper entitled:
!            "algorithms for generating a skew-t, log p
!	     diagram and computing selected meteorological
!	     quantities."
!	     atmospheric sciences laboratory
!	     u.s. army electronics command
!	     white sands missile range, new mexico 88002
!	     33 pages
!	baker, schlatter  17-may-1982

! This function returns the temperature tda (K) on a dry adiabat
!  at pressure p (Pa).  The dry adiabat is given by
!  potential temperature th (K).  The computation is based on
!  poisson's equation.

implicit none

real :: th,p,tda

tda=th*((p*0.00001)**.286)

return
end

!===============================================================================

function os(t,p)

!	g.s. stipanuk     1973      	  original version.
!	reference stipanuk paper entitled:
!            "algorithms for generating a skew-t, log p
!	     diagram and computing selected meteorological
!	     quantities."
!	     atmospheric sciences laboratory
!	     u.s. army electronics command
!	     white sands missile range, new mexico 88002
!	     33 pages
!	baker, schlatter  17-may-1982

! This function returns the equivalent potential temperature os
!  (K) for a parcel of air saturated at temperature t (K)
!  and pressure p (Pa).

implicit none

real :: t,p,b,w,os

data b/2651.8986/

! b is an empirical constant approximately equal to the latent heat
!  of vaporization for water divided by the specific heat at constant
!  pressure for dry air.

os=t*((100000./p)**.286)*(exp(b*w(t,p)/t))

return
end

!===============================================================================

function tsa(os,p)

!	g.s. stipanuk     1973      	  original version.
!	reference stipanuk paper entitled:
!            "algorithms for generating a skew-t, log p
!	     diagram and computing selected meteorological
!	     quantities."
!	     atmospheric sciences laboratory
!	     u.s. army electronics command
!	     white sands missile range, new mexico 88002
!	     33 pages
!	baker, schlatter  17-may-1982

! This function returns the temperature tsa (K) on a saturation
!  adiabat at pressure p (Pa). os is the equivalent potential
!  temperature of the parcel (K). sign(a,b) replaces the
!  algebraic sign of a with that of b.
!  b is an empirical constant approximately equal to 0.001 of the latent
!  heat of vaporization for water divided by the specific heat at constant
!  pressure for dry air.

data b/2651.8986/

! tq is the first guess for tsa.

tsa=253.15

! d is an initial value used in the iteration below.

d=120.

! Iterate to obtain sufficient accuracy....see table 1, p.8
!  of stipanuk (1973) for equation used in iteration.

do i=1,12
   d=d/2.
   x=os*exp(-b*w(tsa,p)/tsa)-tsa*((100000./p)**.286)
   if (abs(x) < 1.e-7) goto 2
   tsa=tsa+sign(d,x)
enddo
2 continue

return
end


      FUNCTION gasdev( idum )
!     Returns a normally distributed deviate with zero mean and unit
! variance, using routine RAN1(idum) as the source of uniform deviates.
!     From "Numerical Recipes" by Press, Flannery, Teulolsky, Vetterling
!
      DATA iset/0/
      SAVE iset, gset
!
      IF( iset .EQ. 0 ) THEN                                            ! we don't have an extra deviate handy, so pick two
    1     v1 = 2. * ran1(idum) - 1.                                     ! uniform numbers in the square extending from
          v2 = 2. * ran1(idum) - 1.                                     ! -1 to +1 in each direction.
          r = v1*v1 + v2*v2                                             ! see if the are on the unit circle
          IF( r .GE. 1 ) GOTO 1                                         ! and if they are not, try again
          fac = SQRT( -2.*LOG(r)/r )                                    ! now make the Box-Muller transformation
          gset = v1 * fac                                               ! to get two normal deviates.  Return one
          gasdev = v2 * fac                                             ! and save the other for the next time.
          iset = 1                                                      ! set the flag
      ELSE                                                              ! we have an extra deviate handy,
          gasdev = gset                                                 ! so return it
          iset = 0                                                      ! and unset the flag
      ENDIF
      RETURN
      END


module compute_reaction_rates_module

  use bl_types
  use bl_error_module
  use probin_reactdiff_module, only : nspecies, nreactions, stoichiometric_factors, &
                                      rate_const, rate_multiplier, include_discrete_LMA_correction
  implicit none

  private

  public :: compute_reaction_rates

contains

  ! compute reaction rates in units (# reactions) / (unit time) / (unit volume)
  subroutine compute_reaction_rates(n_in,reaction_rates,dv)

    real(kind=dp_t), intent(in   ) :: n_in(:),dv
    real(kind=dp_t), intent(inout) :: reaction_rates(:)

    integer :: reaction, species

    real(kind=dp_t) :: n_nonneg(nspecies)

    n_nonneg(1:nspecies) = max(0.d0,n_in(1:nspecies))

    if(include_discrete_LMA_correction) then
       ! Use traditional LMA but correct for the fact that for binary reactions rate ~ N*(N-1) and not N^2, etc.,
       ! where N is the total number of molecules
       do reaction=1, nreactions
          !write(*,*) "reaction=", reaction, " rate_const=", rate_const(reaction), &
          !  " stochiometry=", stoichiometric_factors(1:nspecies,1,reaction)
          reaction_rates(reaction) = rate_multiplier*rate_const(reaction)
          do species=1, nspecies
             select case(stoichiometric_factors(species,1,reaction))
             case(0)
                ! Species does not participate in reaction
             case(1)
                ! Rate ~ N
                reaction_rates(reaction)= &
                     reaction_rates(reaction)*n_nonneg(species)
             case(2)
                ! Rate ~ N*(N-1)
                reaction_rates(reaction)= &
                     reaction_rates(reaction)*n_nonneg(species)*(n_nonneg(species)-1.0d0/dv)
             case(3)
                ! Rate ~ N*(N-1)*(N-2)
                reaction_rates(reaction)= &
                     reaction_rates(reaction)*n_nonneg(species)*max(n_nonneg(species)-1.0d0/dv,0.d0) &
                     *max(n_nonneg(species)-2.0d0/dv,0.d0)
             case default
                ! This is essentially impossible in practice and won't happen
                call bl_error("Stochiometric coefficients larger then 3 not supported")
             end select
          end do
          !write(*,*) "reaction=", reaction, " rate=", reaction_rates(reaction)
       end do
    else
       ! Use traditional LMA without accounting for discrete/integer nature of the molecules involved
       do reaction=1, nreactions
          ! This works since raising to the zeroth power gives unity:
          reaction_rates(reaction) = rate_multiplier*rate_const(reaction)*&
               product(n_nonneg(1:nspecies)**stoichiometric_factors(1:nspecies,1,reaction))
       end do
    end if

  end subroutine compute_reaction_rates

end module compute_reaction_rates_module


	SUBROUTINE VC_VAPR  ( t, nxy, e, iret )
C************************************************************************
C* VC_VAPR								*
C*									*
C* This subroutine computes the saturation vapor pressure corresponding *
C* to a given temperature.						*
C*									*
C* VC_VAPR ( T, NXY, E, IRET )						*
C*									*
C* Input parameters:							*
C*	T  (NXY)	REAL		Temperature (K or C)		*
C*	NXY		INTEGER		Number of points		*
C*									*
C* Output parameters:							*
C*	E  (NXY)	REAL		Vapor pressure (mb)		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC      05/92						*
C* G. Krueger/EAI        4/96   Replaced C->K constant with TMCK	*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
C*
	REAL		t (*), e (*)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret = 0
C*
	icnt = 0
	DO i = 1, nxy
	    IF ( ERMISS ( t (i) ) ) THEN
		e (i) = RMISSD
		icnt = icnt + 1
	    ELSE
	   	IF ( t (i) .gt. 70. ) THEN
C
C*		    Convert to C.
C
		    tmp = t (i) - TMCK
		ELSE
		    tmp = t (i)
		END IF
	    END IF
	    tmp = 17.67 * tmp / ( tmp + 243.5 )
	    e (i) = 6.112 * EXP ( tmp )
	END DO
C*
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


module mod_random

  ! Provides a random number generator with
  ! normal distribution, centered on zero.

  use mod_kinds, only: ik, rk

  implicit none

  private
  public :: randn

  real(rk), parameter :: pi = 4 * atan(1._rk)

  interface randn
    module procedure :: randn1d, randn2d
  end interface randn

contains

  function randn1d(n) result(r)
    ! Generates n random numbers with a normal distribution.
    integer(ik), intent(in) :: n
    real(rk) :: r(n), r2(n)
    call random_number(r)
    call random_number(r2)
    r = sqrt(-2 * log(r)) * cos(2 * pi * r2)
  end function randn1d

  function randn2d(m, n) result(r)
    ! Generates m x n random numbers with a normal distribution.
    integer(ik), intent(in) :: m, n
    real(rk) :: r(m, n), r2(m, n)
    call random_number(r)
    call random_number(r2)
    r = sqrt(-2 * log(r)) * cos(2 * pi * r2)
  end function randn2d

end module mod_random


c     Subroutine to find dew point from vapor pressure
c     AJ_Kettle, Nov7/2017

c     from wmo_8_en-2012.pdf pI.4-29

      SUBROUTINE dewfrostp_from_vpres_spres(f_ew_hpa,f_p_hpa,
     +   s_wetb_iceflag,
     +   f_dewp_c)

      IMPLICIT NONE
c************************************************************************
      REAL                :: f_dewp_c

      REAL                :: f_ew_hpa
      REAL                :: f_p_hpa

      REAL                :: f_p_coef
      CHARACTER(LEN=1)    :: s_wetb_iceflag
c************************************************************************
c     Find pressure coefficient
      f_p_coef=1.0016+3.15*10.0**(-6.0)*f_p_hpa-0.074/f_p_hpa

      IF (s_wetb_iceflag.NE.'E') THEN
       f_dewp_c=(243.12*ALOG(f_ew_hpa/(6.112*f_p_coef)))/
     +   (17.62-ALOG(f_ew_hpa/(6.112*f_p_coef)))
      ENDIF
      IF (s_wetb_iceflag.EQ.'E') THEN
       f_dewp_c=(272.62*ALOG(f_ew_hpa/(6.112*f_p_coef)))/
     +   (22.46-ALOG(f_ew_hpa/(6.112*f_p_coef)))
      ENDIF

c      f_dewp_c=(243.12*ALOG(f_ew_pa/611.2))/(17.62-ALOG(f_ew_pa/611.2))
c************************************************************************
      RETURN
      END


program sqrt

use newtonraphson
use, intrinsic :: iso_c_binding
implicit none

character(len=5) :: arg
integer :: nargs

! arguments for the fortran routines
real(8) :: input
real(8) :: x0 = 10
integer :: iterations = 10
logical(1) :: printIts = .TRUE.
real(8) :: result

! read the input argument and convert to real
nargs = command_argument_count()
if (nargs.ne.1) then
  print *, "Usage: sqrt N where N is a real number"
  stop 1
endif

call getarg(1, arg)
read(arg,*) input

! get the square root from newton raphson method
result = nr_sqrt(input, x0, iterations, printIts)

! display the results
print "(3A,F10.4)", "The square root of ",trim(arg)," is ",result

end program


subroutine DHaj(n, aj, extend, exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will compute the weights a_j that are used to
!   expand an equally sampled grid into spherical harmonics by using
!   the sampling theorem presented in Driscoll and Healy (1994).
!
!   Note that the number of samples, n, must be even! Also, a_j(1) = 0
!
!   Calling parameters
!
!       IN
!           n       Number of samples in longitude and latitude.
!
!       IN, optional
!           extend  If 1, include the latitudinal band for 90 S, which
!                   increases the dimension of aj by 1.
!
!       OUT, optional
!           aj      Vector of length n or n+1 containing the weights.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    integer, intent(in) :: n
    real(dp), intent(out) :: aj(:)
    integer, intent(in), optional :: extend
    integer, intent(out), optional :: exitstatus
    integer :: j, l, n_out, extend_grid
    real(dp) :: sum1, pi

    if (present(exitstatus)) exitstatus = 0

    pi = acos(-1.0_dp)

    if (mod(n,2) /= 0) then
        print*, "Error --- DH_aj"
        print*, "The number of samples in the equi-dimensional grid must " // &
                "be even for use with SHExpandDH"
        print*, "Input value of N is ", n
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if
    end if

    if (present(extend)) then
        if (extend == 0) then
            extend_grid = 0
            n_out = n
        else if (extend == 1) then
            extend_grid = 1
            n_out = n + 1
        else
            print*, "Error --- DHaj"
            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
        extend_grid = 0
        n_out = n
    end if

    if (size(aj) < n_out) then
        print*, "Error --- DH_aj"
        print*, "The size of AJ must be greater than or equal " // &
                "to ", n_out
        print*, "Input array is dimensioned as ", size(aj)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    do j = 0, n-1
        sum1 = 0.0_dp

        do l = 0, n/2 -1
            sum1 = sum1 + sin( dble(2*l+1) * pi * dble(j) / dble(n) ) &
                          / dble(2*l+1)
        end do

        aj(j+1) = sum1 * sin(pi * dble(j) / dble(n)) * sqrt(8.0_dp) / dble(n)

    end do

    if (extend_grid == 1) then
        aj(n_out) = 0.0_dp
    end if

end subroutine DHaj


      SUBROUTINE MB04DL( JOB, N, THRESH, A, LDA, B, LDB, ILO, IHI,
     $                   LSCALE, RSCALE, DWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To balance a pair of N-by-N real matrices (A,B). This involves,
C     first, permuting A and B by equivalence transformations to isolate
C     eigenvalues in the first 1 to ILO-1 and last IHI+1 to N elements
C     on the diagonal of A and B; and second, applying a diagonal
C     equivalence transformation to rows and columns ILO to IHI to make
C     the rows and columns as close in 1-norm as possible. Both steps
C     are optional. Balancing may reduce the 1-norms of the matrices,
C     and improve the accuracy of the computed eigenvalues and/or
C     eigenvectors in the generalized eigenvalue problem
C     A*x = lambda*B*x.
C
C     This routine may optionally improve the conditioning of the
C     scaling transformation compared to the LAPACK routine DGGBAL.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the operations to be performed on A and B:
C             = 'N':  none:  simply set ILO = 1, LSCALE(I) = 1.0 and
C                     RSCALE(I) = 1.0 for I = 1,...,N.
C             = 'P':  permute only;
C             = 'S':  scale only;
C             = 'B':  both permute and scale.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of matrices A and B.  N >= 0.
C
C     THRESH  (input) DOUBLE PRECISION
C             If JOB = 'S' or JOB = 'B', and THRESH >= 0, threshold
C             value for magnitude of the elements to be considered in
C             the scaling process: elements with magnitude less than or
C             equal to THRESH*MXNORM are ignored for scaling, where
C             MXNORM is the maximum of the 1-norms of the original
C             submatrices A(s,s) and B(s,s), with s = ILO:IHI.
C             If THRESH < 0, the subroutine finds the scaling factors
C             for which some conditions, detailed below, are fulfilled.
C             A sequence of increasing strictly positive threshold
C             values is used.
C             If THRESH = -1, the condition is that
C                max( norm(A(s,s),1)/norm(B(s,s),1),
C                     norm(B(s,s),1)/norm(S(s,s),1) )                (1)
C             has the smallest value, for the threshold values used,
C             where A(s,s) and B(s,s) are the scaled submatrices.
C             If THRESH = -2, the norm ratio reduction (1) is tried, but
C             the subroutine may return IWARN = 1 and reset the scaling
C             factors to 1, if this seems suitable. See the description
C             of the argument IWARN and FURTHER COMMENTS.
C             If THRESH = -3, the condition is that
C                norm(A(s,s),1)*norm(B(s,s),1)                       (2)
C             has the smallest value for the scaled submatrices.
C             If THRESH = -4, the norm reduction in (2) is tried, but
C             the subroutine may return IWARN = 1 and reset the scaling
C             factors to 1, as for THRESH = -2 above.
C             If THRESH = -VALUE, with VALUE >= 10, the condition
C             numbers of the left and right scaling transformations will
C             be bounded by VALUE, i.e., the ratios between the largest
C             and smallest entries in LSCALE(s) and RSCALE(s), will be
C             at most VALUE. VALUE should be a power of 10.
C             If JOB = 'N' or JOB = 'P', the value of THRESH is
C             irrelevant.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the balanced matrix A.
C             In particular, the strictly lower triangular part of the
C             first ILO-1 columns and the last N-IHI rows of A is zero.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix B.
C             On exit, the leading N-by-N part of this array contains
C             the balanced matrix B.
C             In particular, the strictly lower triangular part of the
C             first ILO-1 columns and the last N-IHI rows of B is zero.
C             If JOB = 'N', the arrays A and B are not referenced.
C
C     LDB    INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N).
C
C     ILO     (output) INTEGER
C     IHI     (output) INTEGER
C             ILO and IHI are set to integers such that on exit
C             A(i,j) = 0 and B(i,j) = 0 if i > j and
C             j = 1,...,ILO-1 or i = IHI+1,...,N.
C             If JOB = 'N' or 'S', ILO = 1 and IHI = N.
C
C     LSCALE  (output) DOUBLE PRECISION array, dimension (N)
C             Details of the permutations and scaling factors applied
C             to the left side of A and B.  If P(j) is the index of the
C             row interchanged with row j, and D(j) is the scaling
C             factor applied to row j, then
C               LSCALE(j) = P(j)    for j = 1,...,ILO-1
C                         = D(j)    for j = ILO,...,IHI
C                         = P(j)    for j = IHI+1,...,N.
C             The order in which the interchanges are made is N to
C             IHI+1, then 1 to ILO-1.
C
C     RSCALE  (output) DOUBLE PRECISION array, dimension (N)
C             Details of the permutations and scaling factors applied
C             to the right side of A and B.  If P(j) is the index of the
C             column interchanged with column j, and D(j) is the scaling
C             factor applied to column j, then
C               RSCALE(j) = P(j)    for j = 1,...,ILO-1
C                         = D(j)    for j = ILO,...,IHI
C                         = P(j)    for j = IHI+1,...,N.
C             The order in which the interchanges are made is N to
C             IHI+1, then 1 to ILO-1.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK) where
C             LDWORK = 0,   if  JOB = 'N' or JOB = 'P', or N = 0;
C             LDWORK = 6*N, if (JOB = 'S' or JOB = 'B') and THRESH >= 0;
C             LDWORK = 8*N, if (JOB = 'S' or JOB = 'B') and THRESH <  0.
C             On exit, if JOB = 'S' or JOB = 'B', DWORK(1) and DWORK(2)
C             contain the initial 1-norms of A(s,s) and B(s,s), and
C             DWORK(3) and DWORK(4) contain their final 1-norms,
C             respectively. Moreover, DWORK(5) contains the THRESH value
C             used (irrelevant if IWARN = 1 or ILO = IHI).
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  scaling has been requested, for THRESH = -2 or
C                   THRESH = -4, but it most probably would not improve
C                   the accuracy of the computed solution for a related
C                   eigenproblem (since maximum norm increased
C                   significantly compared to the original pencil
C                   matrices and (very) high and/or small scaling
C                   factors occurred). The returned scaling factors have
C                   been reset to 1, but information about permutations,
C                   if requested, has been preserved.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit.
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Balancing consists of applying an equivalence transformation
C     to isolate eigenvalues and/or to make the 1-norms of the rows
C     and columns ILO,...,IHI of A and B nearly equal. If THRESH < 0,
C     a search is performed to find those scaling factors giving the
C     smallest norm ratio or product defined above (see the description
C     of the parameter THRESH).
C
C     Assuming JOB = 'S', let Dl and Dr be diagonal matrices containing
C     the vectors LSCALE and RSCALE, respectively. The returned matrices
C     are obtained using the equivalence transformation
C
C        Dl*A*Dr and Dl*B*Dr.
C
C     For THRESH = 0, the routine returns essentially the same results
C     as the LAPACK subroutine DGGBAL [1]. Setting THRESH < 0, usually
C     gives better results than DGGBAL for badly scaled matrix pencils.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     No rounding errors appear if JOB = 'P'.
C
C     FURTHER COMMENTS
C
C     If THRESH = -2, the increase of the maximum norm of the scaled
C     submatrices, compared to the maximum norm of the initial
C     submatrices, is bounded by MXGAIN = 100.
C     If THRESH = -2, or THRESH = -4, the maximum condition number of
C     the scaling transformations is bounded by MXCOND = 1/SQRT(EPS),
C     where EPS is the machine precision (see LAPACK Library routine
C     DLAMCH).
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2015.
C
C     REVISIONS
C
C     V. Sima, Jan. 2016, Jan. 2017, Feb. 2017.
C
C     KEYWORDS
C
C     Balancing, eigenvalue, equivalence transformation, matrix algebra,
C     matrix operations.
C
C  *********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   HALF, ONE, TEN, THREE, ZERO
      PARAMETER          ( HALF  = 0.5D+0, ONE  = 1.0D+0, TEN = 1.0D+1,
     $                     THREE = 3.0D+0, ZERO = 0.0D+0 )
      DOUBLE PRECISION   MXGAIN, SCLFAC
      PARAMETER          ( MXGAIN = 1.0D+2, SCLFAC = 1.0D+1 )
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            IHI, ILO, INFO, IWARN, LDA, LDB, N
      DOUBLE PRECISION   THRESH
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), B(LDB,*), DWORK(*), LSCALE(*),
     $                   RSCALE(*)
C     .. Local Scalars ..
      LOGICAL            EVNORM, LOOP, LPERM, LSCAL, STORMN
      INTEGER            I, ICAB, IFLOW, IP1, IR, IRAB, IT, ITER, ITH,
     $                   J, JC, JP1, K, KOUNT, KS, KW1, KW2, KW3, KW4,
     $                   KW5, KW6, KW7, L, LM1, LRAB, LSFMAX, LSFMIN, M,
     $                   NR, NRP2
      DOUBLE PRECISION   AB, ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
     $                   COEF5, COR, DENOM, EPS, EW, EWC, GAMMA, GAP,
     $                   MINPRO, MINRAT, MN, MX, MXCOND, MXNORM, MXS,
     $                   NA, NA0, NAS, NB, NB0, NBS, PGAMMA, PROD, RAB,
     $                   RATIO, SFMAX, SFMIN, SUM, T, TA, TB, TC, TH,
     $                   TH0, THS
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH, DLANGE
      EXTERNAL           DDOT, DLAMCH, DLANGE, IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DSCAL, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG10, MAX, MIN, SIGN, SQRT
C
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO  = 0
      IWARN = 0
      LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' )
      LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' )
C
      IF( .NOT.LPERM .AND. .NOT.LSCAL .AND. .NOT.LSAME( JOB, 'N' ) )
     $   THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04DL', -INFO )
         RETURN
      END IF
C
      ILO = 1
      IHI = N
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
      IF( ( .NOT.LPERM .AND. .NOT.LSCAL ) .OR. N.EQ.1 ) THEN
         DUM(1) = ONE
         CALL DCOPY( N, DUM, 0, LSCALE, 1 )
         CALL DCOPY( N, DUM, 0, RSCALE, 1 )
         IF( N.EQ.1 .AND. LSCAL ) THEN
            NA0 = ABS( A(1,1) )
            NB0 = ABS( B(1,1) )
            DWORK(1) = NA0
            DWORK(2) = NB0
            DWORK(3) = NA0
            DWORK(4) = NB0
            DWORK(5) = THRESH
         END IF
         RETURN
      END IF
C
      K = 1
      L = N
C
      IF( LPERM ) THEN
C
C        Permute the matrices A and B to isolate the eigenvalues.
C
C        Find row with one nonzero in columns 1 through L.
C
   10    CONTINUE
         LM1 = L - 1
         DO 60 I = L, 1, -1
            DO 20 J = 1, LM1
               JP1 = J + 1
               IF( A(I,J).NE.ZERO .OR. B(I,J).NE.ZERO )
     $            GO TO 30
   20       CONTINUE
            J = L
            GO TO 50
C
   30       CONTINUE
            DO 40 J = JP1, L
               IF( A(I,J).NE.ZERO .OR. B(I,J).NE.ZERO )
     $            GO TO 60
   40       CONTINUE
            J = JP1 - 1
C
   50       CONTINUE
            M = L
            IFLOW = 1
            GO TO 130
   60    CONTINUE
C
C        Find column with one nonzero in rows K through N.
C
   70    CONTINUE
         DO 120 J = K, L
            DO 80 I = K, LM1
               IP1 = I + 1
               IF( A(I,J).NE.ZERO .OR. B(I,J).NE.ZERO )
     $            GO TO 90
   80       CONTINUE
            I = L
            GO TO 110
C
   90       CONTINUE
            DO 100 I = IP1, L
               IF( A(I,J).NE.ZERO .OR. B(I,J).NE.ZERO )
     $            GO TO 120
  100       CONTINUE
            I = IP1 - 1
C
  110       CONTINUE
            M = K
            IFLOW = 2
            GO TO 130
  120    CONTINUE
         GO TO 140
C
C        Permute rows M and I.
C
  130    CONTINUE
         LSCALE(M) = I
         IF( I.NE.M ) THEN
            CALL DSWAP( N-K+1, A(I,K), LDA, A(M,K), LDA )
            CALL DSWAP( N-K+1, B(I,K), LDB, B(M,K), LDB )
         END IF
C
C        Permute columns M and J.
C
         RSCALE(M) = J
         IF( J.NE.M ) THEN
            CALL DSWAP( L, A(1,J), 1, A(1,M), 1 )
            CALL DSWAP( L, B(1,J), 1, B(1,M), 1 )
         END IF
C
         IF( IFLOW.EQ.1 ) THEN
            L = LM1
            IF( L.NE.1 )
     $         GO TO 10
C
            RSCALE(1) = ONE
            LSCALE(1) = ONE
         ELSE
            K = K + 1
            GO TO 70
         END IF
      END IF
C
  140 CONTINUE
      ILO = K
      IHI = L
C
      IF( .NOT.LSCAL ) THEN
         DO 150 I = ILO, IHI
            LSCALE(I) = ONE
            RSCALE(I) = ONE
  150    CONTINUE
         RETURN
      END IF
C
      NR = IHI - ILO + 1
C
C     Compute initial 1-norms and return if ILO = N.
C
      NA0 = DLANGE( '1-norm', NR, NR, A(ILO,ILO), LDA, DWORK )
      NB0 = DLANGE( '1-norm', NR, NR, B(ILO,ILO), LDB, DWORK )
C
      IF( ILO.EQ.IHI ) THEN
         DWORK(1) = NA0
         DWORK(2) = NB0
         DWORK(3) = NA0
         DWORK(4) = NB0
         DWORK(5) = THRESH
         RETURN
      END IF
C
C     Balance the submatrices in rows ILO to IHI.
C
C     Initialize balancing and allocate work storage.
C
      KW1 = N
      KW2 = KW1 + N
      KW3 = KW2 + N
      KW4 = KW3 + N
      KW5 = KW4 + N
      DUM(1) = ZERO
C
C     Prepare for scaling.
C
      SFMIN  = DLAMCH( 'Safe minimum' )
      SFMAX  = ONE / SFMIN
      BASL   = LOG10( SCLFAC )
      LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE )
      LSFMAX = INT( LOG10( SFMAX ) / BASL )
      MXNORM = MAX( NA0, NB0 )
      LOOP   = THRESH.LT.ZERO
C
      IF( LOOP ) THEN
C
C        Compute relative threshold.
C
         NA  = NA0
         NAS = NA0
         NB  = NB0
         NBS = NB0
C
         ITH = THRESH
         MXS = MXNORM
         MX  = ZERO
         MN  = SFMAX
         IF( ITH.GE.-2 ) THEN
            IF( NA.LT.NB ) THEN
               RATIO = MIN( NB/NA, SFMAX )
            ELSE
               RATIO = MIN( NA/NB, SFMAX )
            END IF
            MINRAT = RATIO
         ELSE IF( ITH.LE.-10 ) THEN
            MXCOND = -THRESH
         ELSE
            DENOM  = MAX( ONE, MXNORM )
            PROD   = ( NA/DENOM )*( NB/DENOM )
            MINPRO = PROD
         END IF
         STORMN = .FALSE.
         EVNORM = .FALSE.
C
C        Find maximum order of magnitude of the differences in sizes of
C        the nonzero entries, not considering diag(A) and diag(B).
C
         DO 170 J = ILO, IHI
            DO 160 I = ILO, IHI
               IF( I.NE.J ) THEN
                  AB = ABS( A(I,J) )
                  IF( AB.NE.ZERO )
     $               MN = MIN( MN, AB )
                  MX = MAX( MX, AB )
               END IF
  160       CONTINUE
  170    CONTINUE
C
         DO 190 J = ILO, IHI
            DO 180 I = ILO, IHI
               IF( I.NE.J ) THEN
                  AB = ABS( B(I,J) )
                  IF( AB.NE.ZERO )
     $               MN = MIN( MN, AB )
                  MX = MAX( MX, AB )
               END IF
  180       CONTINUE
  190    CONTINUE
C
         IF( MX*SFMIN.LE.MN ) THEN
            GAP = MX/MN
         ELSE
            GAP = SFMAX
         END IF
         EPS  = DLAMCH( 'Precision' )
         ITER = MIN( INT( LOG10( GAP ) ), -INT( LOG10( EPS ) ) ) + 1
         TH   = MAX( MN, MX*EPS )/MAX( MXNORM, SFMIN )
         THS  = TH
         KW6  = KW5 + N + ILO
         KW7  = KW6 + N
         CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 )
         CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 )
C
C        Set the maximum condition number of the transformations.
C
         IF( ITH.GT.-10 )
     $      MXCOND = ONE/SQRT( EPS )
      ELSE
         TH     = MXNORM*THRESH
         ITER   = 1
         EVNORM = .TRUE.
      END IF
      TH0 = TH
C
      COEF  = ONE / DBLE( 2*NR )
      COEF2 = COEF*COEF
      COEF5 = HALF*COEF2
      NRP2  = NR + 2
      BETA  = ZERO
C
C     If THRESH < 0, use a loop to reduce the norm ratio.
C
      DO 400 K = 1, ITER
C
C        Compute right side vector in resulting linear equations.
C
         CALL DCOPY( 6*N, DUM, 0, DWORK, 1 )
         CALL DCOPY(  NR, DUM, 0, LSCALE(ILO), 1 )
         CALL DCOPY(  NR, DUM, 0, RSCALE(ILO), 1 )
         DO 210 I = ILO, IHI
            DO 200 J = ILO, IHI
               TA = ABS( A(I,J) )
               TB = ABS( B(I,J) )
               IF( TA.GT.TH ) THEN
                  TA = LOG10( TA ) / BASL
               ELSE
                  TA = ZERO
               END IF
               IF( TB.GT.TH ) THEN
                  TB = LOG10( TB ) / BASL
               ELSE
                  TB = ZERO
               END IF
               DWORK(I+KW4) = DWORK(I+KW4) - TA - TB
               DWORK(J+KW5) = DWORK(J+KW5) - TA - TB
  200       CONTINUE
  210    CONTINUE
C
         IT = 1
C
C        Start generalized conjugate gradient iteration.
C
  220    CONTINUE
C
         GAMMA = DDOT( NR, DWORK(ILO+KW4), 1, DWORK(ILO+KW4), 1 ) +
     $           DDOT( NR, DWORK(ILO+KW5), 1, DWORK(ILO+KW5), 1 )
C
         EW  = ZERO
         EWC = ZERO
         DO 230 I = ILO, IHI
            EW  = EW  + DWORK(I+KW4)
            EWC = EWC + DWORK(I+KW5)
  230    CONTINUE
C
         GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) -
     $                        COEF5*( EW - EWC  )**2
         IF( GAMMA.EQ.ZERO )
     $      GO TO 300
         IF( IT.NE.1 )
     $      BETA = GAMMA / PGAMMA
         T  = COEF5*( EWC - THREE*EW  )
         TC = COEF5*( EW  - THREE*EWC )
C
         CALL DSCAL( NR, BETA, DWORK(ILO), 1 )
         CALL DSCAL( NR, BETA, DWORK(ILO+KW1), 1 )
C
         CALL DAXPY( NR, COEF, DWORK(ILO+KW4), 1, DWORK(ILO+KW1), 1 )
         CALL DAXPY( NR, COEF, DWORK(ILO+KW5), 1, DWORK(ILO), 1 )
C
         DO 240 J = ILO, IHI
            DWORK(J)     = DWORK(J)     + TC
            DWORK(J+KW1) = DWORK(J+KW1) + T
  240    CONTINUE
C
C        Apply matrix to vector.
C
         DO 260 I = ILO, IHI
            KOUNT = 0
            SUM   = ZERO
            DO 250 J = ILO, IHI
               KS = KOUNT
               IF( A(I,J).NE.ZERO )
     $            KOUNT = KOUNT + 1
               IF( B(I,J).NE.ZERO )
     $            KOUNT = KOUNT + 1
               SUM = SUM + DBLE( KOUNT - KS )*DWORK(J)
  250       CONTINUE
            DWORK(I+KW2) = DBLE( KOUNT )*DWORK(I+KW1) + SUM
  260    CONTINUE
C
         DO 280 J = ILO, IHI
            KOUNT = 0
            SUM   = ZERO
            DO 270 I = ILO, IHI
               KS = KOUNT
               IF( A(I,J).NE.ZERO )
     $            KOUNT = KOUNT + 1
               IF( B(I,J).NE.ZERO )
     $            KOUNT = KOUNT + 1
               SUM = SUM + DBLE( KOUNT - KS )*DWORK(I+KW1)
  270       CONTINUE
            DWORK(J+KW3) = DBLE( KOUNT )*DWORK(J) + SUM
  280    CONTINUE
C
         SUM = DDOT( NR, DWORK(ILO+KW1), 1, DWORK(ILO+KW2), 1 ) +
     $         DDOT( NR, DWORK(ILO),     1, DWORK(ILO+KW3), 1 )
         ALPHA = GAMMA / SUM
C
C        Determine correction to current iteration.
C
         CMAX = ZERO
         DO 290 I = ILO, IHI
            COR = ALPHA*DWORK(I+KW1)
            IF( ABS( COR ).GT.CMAX )
     $         CMAX = ABS( COR )
            LSCALE(I) = LSCALE(I) + COR
            COR = ALPHA*DWORK(I)
            IF( ABS( COR ).GT.CMAX )
     $         CMAX = ABS( COR )
            RSCALE(I) = RSCALE(I) + COR
  290    CONTINUE
C
         IF( CMAX.GE.HALF ) THEN
C
            CALL DAXPY( NR, -ALPHA, DWORK(ILO+KW2), 1, DWORK(ILO+KW4),
     $                  1 )
            CALL DAXPY( NR, -ALPHA, DWORK(ILO+KW3), 1, DWORK(ILO+KW5),
     $                  1 )
C
            PGAMMA = GAMMA
            IT = IT + 1
            IF( IT.LE.NRP2 )
     $         GO TO 220
         END IF
C
C        End generalized conjugate gradient iteration.
C
  300    CONTINUE
C
C        Compute diagonal scaling matrices.
C
         DO 310 I = ILO, IHI
            IRAB = IDAMAX( N-ILO+1, A(I,ILO), LDA )
            RAB  = ABS( A(I,ILO+IRAB-1) )
            IRAB = IDAMAX( N-ILO+1, B(I,ILO), LDB )
            RAB  = MAX( RAB, ABS( B(I,ILO+IRAB-1) ) )
            LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE )
            IR   = LSCALE(I) + SIGN( HALF, LSCALE(I) )
            IR   = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
            LSCALE(I) = SCLFAC**IR
C
            ICAB = IDAMAX( IHI, A(1,I), 1 )
            CAB  = ABS( A(ICAB,I) )
            ICAB = IDAMAX( IHI, B(1,I), 1 )
            CAB  = MAX( CAB, ABS( B(ICAB,I) ) )
            LRAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE )
            JC = RSCALE(I) + SIGN( HALF, RSCALE(I) )
            JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LRAB )
            RSCALE(I) = SCLFAC**JC
  310    CONTINUE
C
         DO 320 I = ILO, IHI
            IF( LSCALE(I).NE.ONE .OR. RSCALE(I).NE.ONE )
     $         GO TO 330
  320    CONTINUE
C
C        Finish the procedure for all scaling factors equal to 1.
C
         NAS = NA0
         NBS = NB0
         THS = TH0
         GO TO 460
C
  330    CONTINUE
C
         IF( LOOP ) THEN
            IF( ITH.LE.-10 ) THEN
C
C              Compute the reciprocal condition number of the left and
C              right transformations. Continue the loop if it is too
C              small.
C
               IR = IDAMAX( NR, LSCALE(ILO), 1 )
               JC = IDAMAX( NR, RSCALE(ILO), 1 )
               T  = LSCALE(ILO+IR-1)
               MN = T
               DO 340 I = ILO, IHI
                  IF( LSCALE(I).LT.MN )
     $               MN = LSCALE(I)
  340          CONTINUE
               T  = MN/T
               TA = RSCALE(ILO+JC-1)
               MN = TA
               DO 350 I = ILO, IHI
                  IF( RSCALE(I).LT.MN )
     $               MN = RSCALE(I)
  350          CONTINUE
               T = MIN( T, MN/TA )
               IF( T.LT.ONE/MXCOND ) THEN
                  TH = TH*TEN
                  GO TO 400
               ELSE
                  THS    = TH
                  EVNORM = .TRUE.
                  GO TO 430
               END IF
            END IF
C
C           Compute the 1-norms of the scaled submatrices,
C           without actually scaling them.
C
            NA = ZERO
            DO 370 J = ILO, IHI
               T = ZERO
               DO 360 I = ILO, IHI
                  T = T + ABS( A(I,J) )*LSCALE(I)*RSCALE(J)
  360          CONTINUE
               IF( T.GT.NA )
     $            NA = T
  370       CONTINUE
C
            NB = ZERO
            DO 390 J = ILO, IHI
               T = ZERO
               DO 380 I = ILO, IHI
                  T = T + ABS( B(I,J) )*LSCALE(I)*RSCALE(J)
  380          CONTINUE
               IF( T.GT.NB )
     $            NB = T
  390       CONTINUE
C
            IF( ITH.GE.-4 .AND. ITH.LT.-2 ) THEN
               PROD = ( NA/DENOM )*( NB/DENOM )
               IF( MINPRO.GT.PROD ) THEN
                  MINPRO = PROD
                  STORMN = .TRUE.
                  CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 )
                  CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 )
                  NAS = NA
                  NBS = NB
                  THS = TH
               END IF
            ELSE IF( ITH.GE.-2 ) THEN
               IF( NA.LT.NB ) THEN
                  RATIO = MIN( NB/NA, SFMAX )
               ELSE
                  RATIO = MIN( NA/NB, SFMAX )
               END IF
               IF( MINRAT.GT.RATIO ) THEN
                  MINRAT = RATIO
                  STORMN = .TRUE.
                  CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 )
                  CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 )
                  MXS = MAX( NA, NB )
                  NAS = NA
                  NBS = NB
                  THS = TH
               END IF
            END IF
            TH = TH*TEN
         END IF
  400 CONTINUE
C
C     Prepare for scaling.
C
      IF( LOOP ) THEN
         IF( ITH.LE.-10 ) THEN
C
C           Could not find enough well conditioned transformations
C           for THRESH <= -10. Set scaling factors to 1 and return.
C
            DUM(1) = ONE
            CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 )
            CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 )
            IWARN = 1
            GO TO 460
         END IF
C
C        Check if scaling might reduce the accuracy when solving related
C        eigenproblems, and set the scaling factors to 1 in this case,
C        if THRESH = -2 or THRESH = -4.
C
         IF( ( MXNORM.LT.MXS .AND. MXNORM.LT.MXS/MXGAIN .AND. ITH.EQ.-2)
     $         .OR. ITH.EQ.-4 ) THEN
            IR = IDAMAX( NR, DWORK(KW6), 1 )
            JC = IDAMAX( NR, DWORK(KW7), 1 )
            T  = DWORK(KW6+IR-1)
            MN = T
            DO 410 I = KW6, KW6+NR-1
               IF( DWORK(I).LT.MN )
     $            MN = DWORK(I)
  410       CONTINUE
            T  = MN/T
            TA = DWORK(KW7+JC-1)
            MN = TA
            DO 420 I = KW7, KW7+NR-1
               IF( DWORK(I).LT.MN )
     $            MN = DWORK(I)
  420       CONTINUE
            T = MIN( T, MN/TA )
            IF( T.LT.ONE/MXCOND ) THEN
               DUM(1) = ONE
               CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 )
               CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 )
               IWARN = 1
               NAS = NA0
               NBS = NB0
               THS = TH0
               GO TO 460
            END IF
         END IF
         IF( STORMN ) THEN
            CALL DCOPY( NR, DWORK(KW6), 1, LSCALE(ILO), 1 )
            CALL DCOPY( NR, DWORK(KW7), 1, RSCALE(ILO), 1 )
         ELSE
            NAS = NA
            NBS = NB
            THS = TH
         END IF
      END IF
C
  430 CONTINUE
C
C     Row scaling.
C
      DO 440 I = ILO, IHI
         CALL DSCAL( N-ILO+1, LSCALE(I), A(I,ILO), LDA )
         CALL DSCAL( N-ILO+1, LSCALE(I), B(I,ILO), LDB )
  440 CONTINUE
C
C     Column scaling.
C
      DO 450 J = ILO, IHI
         CALL DSCAL( IHI, RSCALE(J), A(1,J), 1 )
         CALL DSCAL( IHI, RSCALE(J), B(1,J), 1 )
  450 CONTINUE
C
C     Set DWORK(1:5).
C
  460 CONTINUE
      IF( EVNORM ) THEN
         NAS = DLANGE( '1-norm', NR, NR, A(ILO,ILO), LDA, DWORK )
         NBS = DLANGE( '1-norm', NR, NR, B(ILO,ILO), LDB, DWORK )
      END IF
C
      DWORK(1) = NA0
      DWORK(2) = NB0
      DWORK(3) = NAS
      DWORK(4) = NBS
      IF( LOOP ) THEN
         DWORK(5) = THS/MAX( MXNORM, SFMIN )
      ELSE
         DWORK(5) = THRESH
      END IF
C
      RETURN
C *** Last line of MB04DL ***
      END


!
!  Find statistics of mean and covariance matrix of underlying latent vector.
!
!   beta is the estimated parameter vector.

!   thpr is a predictor vector.
!   tolsing is a tolerance for modified Cholesky decomposition.

!   covmatrix is the estimated covariance matrix of the underlying latent vector corresponding to beta.
!   meanvec is the estimated mean of the underlying latent vector.
!   Note that this routine is for the case of an underlying normal latent vector.
subroutine meancovstat(beta,thpr,tolsing,covmatrix,meanvec)
implicit none
interface
!	chol is used to compute a modified Cholesky decomposition of the n by n matrix sym.
!	The singularity tolerance is tolsing.

	function chol(sym,tolsing)
		implicit none
		real(kind=8),intent(in)::sym(:,:),tolsing
	 	real(kind=8)::chol(size(sym,1),size(sym,1))
	end function chol

!	Extract the linear component lintheta and the quadratic component quadtheta from the parameter vector beta.
	subroutine getlinquad(beta,lintheta,quadtheta)
		implicit none
		real(kind=8),intent(in)::beta(:)
		real(kind=8),intent(out)::lintheta(:,:),quadtheta(:,:,:)
	end subroutine getlinquad

!	Extract the linear component linth and the quadratic component quadth from lintheta and quadtheta for a given predictor thpr.
	subroutine getlinquadth(lintheta,quadtheta,thpr,linth,quadth)
		implicit none
		real(kind=8),intent(in)::lintheta(:,:),quadtheta(:,:,:),thpr(:)
		real(kind=8),intent(out)::linth(:),quadth(:,:)
	end subroutine getlinquadth

!	Compute inverse for n by n matrix with modified Cholesky
!	decomposition tri.
	function invert(tri)
		implicit none
		real(kind=8),intent(in)::tri(:,:)
		real(kind=8)::invert(size(tri,1),size(tri,1))
	end function invert
!		This program uses the modified Cholesky decomposition
!		in lu to solve the equation lusolve = b.

	function solve(lu,b)
		implicit none

		real(kind=8),intent(in)::lu(:,:)
		real(kind=8),intent(in)::b(:)
		real(kind=8)::solve(size(b))
	end function solve

end interface
real(kind=8),intent(in)::beta(:),thpr(:),tolsing
real(kind=8),intent(out)::covmatrix(:,:),meanvec(:)

!	covinverse is the inverse of covmatrix.
!   linth is the linear commponent of beta for thpr.
!   lintheta is a matrix version of the linear component of beta.
!   quadth is the quadratic component of beta for thpr.
!   quadtheta is an array version of the quadratic component of beta.

real(kind=8)::covinverse(size(covmatrix,1),size(covmatrix,1)),linth(size(covmatrix,1)), lintheta(size(covmatrix,1),size(thpr)),&
	quadth(size(covmatrix,1),size(covmatrix,1)),quadtheta(size(covmatrix,1),size(covmatrix,1),size(thpr))

!   Linear component of beta.
call getlinquad(beta,lintheta,quadtheta)

!   Linear component of beta for thpr.
call getlinquadth(lintheta,quadtheta,thpr,linth,quadth)

covinverse=-2.0_8*quadth

covinverse=chol(covinverse,tolsing)
!   Mean of theta.
meanvec=solve(covinverse,linth)
!	invert
covmatrix=invert(covinverse)

end subroutine meancovstat


module julia_set_mod
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none

    private
    integer, parameter :: MAX_ITERS = 255
    real(kind=DP), parameter :: MAX_NORM = 2.0_DP
    complex(kind=DP), parameter :: C = (-0.622772_DP, 0.42193_DP)

    public :: julia_iterate

contains

    elemental function julia_iterate(z0) result(n)
        implicit none
        complex(kind=DP), intent(in) :: z0
        integer :: n
        complex(kind=DP) :: z
        z = z0
        n = 0
        do while (abs(z) < MAX_NORM .and. n < MAX_ITERS)
            z = z**2 + C
            n = n + 1
        end do
    end function julia_iterate

end module julia_set_mod