!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine meshquality(netet_,kontet,cotet,quality,ielem)
!
!     calculate the element quality. The measure used is proportional
!     to the ratio of the longest edge divided by the radius of the
!     inscribed sphere. The proportionality constant is such that
!     the quality is 1 for an equilateral tetrahedron. For all other
!     elements it exceeds 1. The bigger this number, the worse the
!     quality
!
!     if ielem>0 the quality for this element is calculated, if
!     ielem=0 the quality for all elements in the mesh is determined
!
      implicit none
!
      integer netet_,kontet(4,*),ielem,i,j,nodes(4),n1,n2,ine(2,6)
!
      real*8 cotet(3,*),quality(*),volume,surface(4),totsurface,alpha,
     &     edgelength(6),hmax,radius
!
      data ine /1,2,2,3,1,3,1,4,2,4,3,4/
!
!     alpha is the proporionality factor
!
      alpha=dsqrt(6.d0)/12.d0
!
      if(ielem.eq.0) then
!
!     calculating the quality for all elements
!
        do i=1,netet_
          if(kontet(1,i).ne.0) then
            do j=1,4
              nodes(j)=kontet(j,i)
            enddo
!
!     calculating the volume of the element
!
            call calcvol(nodes(1),nodes(2),nodes(3),nodes(4),cotet,
     &           volume)
            if(volume.le.0.d0) volume=1.d-30
!
!     calculating area of each face in the element
!
            call calcsurf(nodes(1),nodes(2),nodes(3),cotet,
     &           surface(1))
            call calcsurf(nodes(2),nodes(3),nodes(4),cotet,
     &           surface(2))
            call calcsurf(nodes(3),nodes(4),nodes(1),cotet,
     &           surface(3))
            call calcsurf(nodes(4),nodes(1),nodes(2),cotet,
     &           surface(4))
!
!     calculating the total surface
!
            totsurface=surface(1)+surface(2)+surface(3)+surface(4)
!
!     radius of the inscribed sphere
!
            radius=3.d0*volume/totsurface
!
!     length of each edge
!
            do j=1,6
              n1=nodes(ine(1,j))
              n2=nodes(ine(2,j))
              edgelength(j)=dsqrt((cotet(1,n1)-cotet(1,n2))**2+
     &             (cotet(2,n1)-cotet(2,n2))**2+
     &             (cotet(3,n1)-cotet(3,n2))**2)
            enddo
!
!     maximum edge length
!
            hmax=maxval(edgelength)
!
!     quality
!
            quality(i)=alpha*hmax/radius
!
!     are the next lines really needed?
!
c            if(quality(i).lt.1.d0) then
c              quality(i)=1.d0/quality(i)
c           endif
          endif
        enddo
      else
!
!     calculating the quality for just one element
!
        i=ielem
!
        if(kontet(1,i).ne.0) then
          do j=1,4
            nodes(j)=kontet(j,i)
          enddo
!
!     calculating the volume of the element
!
          call calcvol(nodes(1),nodes(2),nodes(3),nodes(4),cotet,
     &         volume)
          if(volume.le.0.d0) volume=1.d-30
!
!     calculating area of each face in the element
!
          call calcsurf(nodes(1),nodes(2),nodes(3),cotet,
     &         surface(1))
          call calcsurf(nodes(2),nodes(3),nodes(4),cotet,
     &         surface(2))
          call calcsurf(nodes(3),nodes(4),nodes(1),cotet,
     &         surface(3))
          call calcsurf(nodes(4),nodes(1),nodes(2),cotet,
     &         surface(4))
!
!     calculating the total surface
!
          totsurface=surface(1)+surface(2)+surface(3)+surface(4)
!
!     radius of the inscribed sphere
!
          radius=3.d0*volume/totsurface
!
!     length of each edge
!
          do j=1,6
            n1=nodes(ine(1,j))
            n2=nodes(ine(2,j))
            edgelength(j)=dsqrt((cotet(1,n1)-cotet(1,n2))**2+
     &           (cotet(2,n1)-cotet(2,n2))**2+
     &           (cotet(3,n1)-cotet(3,n2))**2)
          enddo
!
!     maximum edge length
!
          hmax=maxval(edgelength)
!
!     quality
!
          quality(i)=alpha*hmax/radius
!
!     are the next lines really needed?
!
c          if(quality(i).lt.1.d0) then
c            quality(i)=1.d0/quality(i)
c          endif
        endif
      endif
!
      return
      end


!
! Program to test the Interpolate_Utility module procedures
!
PROGRAM Test_Interpolate_Utility

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module usage
  USE Type_Kinds,          ONLY: fp=>fp_kind
  USE Message_Handler,     ONLY: SUCCESS, FAILURE, Display_Message
  USE File_Utility,        ONLY: Get_Lun
  USE Search_Utility,      ONLY: Value_Locate
  USE Interpolate_Utility, ONLY: Linear_Interpolate, &
                                 Polynomial_Interpolate, &
                                 Spline_Initialize, Spline_Interpolate
  ! Disable implicit typing
  IMPLICIT NONE

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'Test_Interpolate_Utility'
  CHARACTER(*), PARAMETER :: PROGRAM_RCS_ID = &
  INTEGER,      PARAMETER :: N  = 25
!  INTEGER,      PARAMETER :: N  = 12
  INTEGER,      PARAMETER :: NI = 78
  INTEGER,      PARAMETER :: NORDERS = 6
  INTEGER,      PARAMETER, DIMENSION(NORDERS) :: ORDER=(/1,3,5,7,9,11/)
  REAL(fp),     PARAMETER :: ZERO = 0.0_fp
  CHARACTER(*), PARAMETER, DIMENSION(2) :: FTYPE=(/'scalar','rank-1'/)

  ! ---------
  ! Variables
  ! ---------
  CHARACTER(256) :: message
  INTEGER :: Error_Status
  INTEGER :: IO_Status
  INTEGER :: FileID
  INTEGER :: i, j, k
  REAL(fp), DIMENSION(N) :: x, y
  REAL(fp), DIMENSION(N) :: y2
  REAL(fp), DIMENSION(NI) :: xInt, yTrue
  INTEGER,  DIMENSION(NI) :: x_idx
  REAL(fp), DIMENSION(NI,2)         :: LinInt
  REAL(fp), DIMENSION(NI,NORDERS,2) :: PolyInt
  REAL(fp), DIMENSION(NI,2)         :: SplineInt
  REAL(fp), DIMENSION(2)         :: LinError
  REAL(fp), DIMENSION(NORDERS,2) :: PolyError
  REAL(fp), DIMENSION(2)         :: SplineError

  ! ------------------------------
  ! Create the data to interpolate
  ! ------------------------------
  ! Define the x-data
  x = (/ 0.0_fp,  0.01_fp, 0.05_fp, 0.12_fp, 0.14_fp, &
         0.22_fp, 0.30_fp, 0.32_fp, 0.33_fp, 0.335_fp,&
         0.36_fp, 0.39_fp, 0.40_fp, 0.405_fp,0.44_fp, &
         0.5_fp,  0.54_fp, 0.62_fp, 0.64_fp, 0.65_fp, &
         0.66_fp, 0.70_fp, 0.75_fp, 0.79_fp, 0.80_fp /)
!  x = (/ 0.0_fp,  0.12_fp,  0.22_fp, 0.32_fp, &
!         0.36_fp, 0.44_fp,  0.45_fp, 0.54_fp, &
!         0.64_fp, 0.70_fp,  0.72_fp, 0.80_fp /)
  ! Calculate the y-data
  y = Func(x)

  ! -----------------------------------------------------
  ! Create regular grid at which interpolates are desired
  ! -----------------------------------------------------
  xInt = (/ ( REAL(i-1), i=1,NI ) /) / REAL(NI-1)
  xInt = xInt * ( MAXVAL(x) - MINVAL(x) ) + MINVAL(x)
  ! Calculate the true curve
  yTrue = Func( xInt )

  ! --------------------
  ! Interpolate the data
  ! --------------------
  ! Initialise error sums
  PolyError   = ZERO
  SplineError = ZERO
  WRITE( *, '( /5x, "Interpolating...." )' )
  ! Linear scalar
  x_idx = Value_Locate(x,xint)
  DO i = 1, NI
    Error_Status = Linear_Interpolate( x, y, xInt(i), LinInt(i,1) )
  END DO
  LinError(1) = SUM(ABS(yTrue-LinInt(:,1)))

  ! Linear rank-1
  Error_Status = Linear_Interpolate( x, y, xInt, LinInt(:,2) )
  LinError(2) = SUM(ABS(yTrue-LinInt(:,2)))

  ! Polynomial scalar
  x_idx = Value_Locate(x,xint)
  DO j = 1, NORDERS
    DO i = 1, NI
      Error_Status = Polynomial_Interpolate( x, y, &
                                             xInt(i), PolyInt(i,j,1), &
                                             x_idx=x_idx(i), &
                                             Order=ORDER(j) )
    END DO
    PolyError(j,1) = SUM(ABS(yTrue-PolyInt(:,j,1)))
  END DO

  ! Polynomial rank-1
  DO j = 1, NORDERS
    Error_Status = Polynomial_Interpolate( x, y, &
                                           xInt, PolyInt(:,j,2), &
                                           Order=ORDER(j) )
    PolyError(j,2) = SUM(ABS(yTrue-PolyInt(:,j,2)))
  END DO

  ! Spline scalar
  Error_Status = Spline_Initialize( x, y, y2 )
  DO i = 1, NI
    Error_Status = Spline_Interpolate( x, y, xInt(i), SplineInt(i,1), y2=y2 )
  END DO
  SplineError(1) = SUM(ABS(yTrue-SplineInt(:,1)))

  ! Spline rank-1
  Error_Status = Spline_Interpolate( x, y, xInt, SplineInt(:,2) )
  SplineError(2) = SUM(ABS(yTrue-SplineInt(:,2)))

  ! ----------------------
  ! Output the error summs
  ! ----------------------
  WRITE( *, '( /5x, "Error sums, SUM(ABS(yTrue-yInt)):" )' )
  DO k = 1, 2
    WRITE( *, '( 5x, "LinInt ", a, ": ", es13.6 )' ) FTYPE(k), LinError(k)
  END DO
  DO k = 1, 2
    WRITE( *, '( 5x, "PolyInt ", a )' ) FTYPE(k)
    DO j = 1, NORDERS
      WRITE( *, '( 7x, "Order ", i2, ": ", es13.6 )' ) ORDER(j),PolyError(j,k)
    END DO
  END DO
  DO k = 1, 2
    WRITE( *, '( 5x, "SplineInt ", a, ": ", es13.6 )' ) FTYPE(k), SplineError(k)
  END DO

  ! -----------------------
  ! Write the original data
  ! -----------------------
  FileID = Open_File('orig_xy.dat')
  DO i = 1, N
    WRITE( FileID, '( 2( 1x, es20.11e3 ) )' ) x(i), y(i)
  END DO
  CLOSE( FileID )

  ! ----------------------------------
  ! Write the linear interpolated data
  ! ----------------------------------
  DO k = 1, 2
    IF( k==1 ) THEN
      FileID=Open_File('linint-scalar_xy.dat')
    ELSE
      FileID=Open_File('linint-rank1_xy.dat')
    END IF
    DO i = 1, NI
      WRITE( FileID, '( 12(1x,es20.11e3,:) )' ) xInt(i), yTrue(i), LinInt(i,k)
    END DO
    CLOSE( FileID )
  END DO

  ! --------------------------------------
  ! Write the polynomial interpolated data
  ! --------------------------------------
  DO k = 1, 2
    IF( k==1 ) THEN
      FileID=Open_File('polyint-scalar_xy.dat')
    ELSE
      FileID=Open_File('polyint-rank1_xy.dat')
    END IF
    DO i = 1, NI
      WRITE( FileID, '( 12(1x,es20.11e3,:) )' ) xInt(i), yTrue(i), (PolyInt(i,j,k),j=1,NORDERS)
    END DO
    CLOSE( FileID )
  END DO

  ! Write the spline interpolated data
  ! ----------------------------------
  DO k = 1, 2
    IF( k==1 ) THEN
      FileID=Open_File('splineint-scalar_xy.dat')
    ELSE
      FileID=Open_File('splineint-rank1_xy.dat')
    END IF
    DO i = 1, NI
      WRITE( FileID, '( 12(1x,es20.11e3,:))' ) xInt(i), yTrue(i), SplineInt(i,k)
    END DO
    CLOSE( FileID )
  END DO

CONTAINS

  FUNCTION Func( x ) RESULT( y )
    REAL(fp), DIMENSION(:), INTENT(IN) :: x
    REAL(fp), DIMENSION(SIZE(x)) :: y
    INTEGER,  PARAMETER :: N_COEFF = 5
    REAL(fp), PARAMETER, DIMENSION( 0:N_COEFF ) :: COEFF = &
      (/   0.2_fp, -25.0_fp,  200.0_fp, &
        -675.0_fp, 900.0_fp, -400.0_fp  /)
    INTEGER :: i
    y = COEFF( N_COEFF )
    DO i = N_COEFF - 1, 0, -1
      y = ( x * y ) + COEFF( i )
    END DO
  END FUNCTION Func

  FUNCTION Open_File( Filename ) RESULT( FileID )
    CHARACTER(*), INTENT(IN) :: Filename
    INTEGER :: FileID
    FileID = Get_Lun()
    OPEN( FileID, FILE   = Filename, &
                  FORM   = 'FORMATTED', &
                  ACCESS = 'SEQUENTIAL', &
                  STATUS = 'REPLACE' )
  END FUNCTION Open_File

END PROGRAM Test_Interpolate_Utility


*======================================================================*
*
      SUBROUTINE Store_roots
*
      INCLUDE 'parameters.f'
*
************************************************************************
*                                                                      *
*     Stores the square root of the integers from 0 to 2*Nmax in       *
*     the array "root", and square roots of the factorials in "fact"   *
*                                                                      *
************************************************************************
*
      integer i
      real*8 root(0:2*Nmax), fact(0:2*Nmax)
      common /sqrts/ root, fact
*
      root(0) = 0.d0
      fact(0) = 1.d0
      do i=1,2*Nmax
         root(i) = dsqrt((0.d0+i))
         fact(i) = root(i)*fact(i-1)
      end do
*
      end
*
*======================================================================*
*
      SUBROUTINE Fill_G
*
      INCLUDE 'parameters.f'
*
************************************************************************
*                                                                      *
*     Fills the array G(nu,n,m) with the functions g_{\nu n}^m as      *
*     defined in equation (2.6) of the paper.                          *
*                                                                      *
************************************************************************
*
      integer nu,n,m,im
      real*8 root(0:2*Nmax), fact(0:2*Nmax)
      common /sqrts/ root, fact
*
      do nu=0,Nmax
         do n=0,Nmax
            do m=-Nmax,Nmax
               g(nu,n,m) = 0.d0
            end do
            g(nu,n,n) = 1.d0
            do m=n-1,1,-1
               g(nu,n,m) = (nu+m+1.d0)*g(nu,n,m+1)/(0.d0+n-m)
            end do
            g(nu,n,-n) = 1.d0
            if (n .NE. 0) then
               g(nu,n,-n+1) = (nu+n)*g(nu,n,-n)
               do m=-n+1,-2
                  g(nu,n,m+1) = (nu-m)*g(nu,n,m)/(n+m+1.d0)
               end do
               g(nu,n,0) = g(nu,n-1,0)*(nu+n)/(0.d0+n)
            else
               g(nu,n,0) = 1.d0
            end if
         end do
      end do
*
      do n=0,Nmax
         do m=-n,n
            if (m .LT. 0) then
               im = -m
            else
               im = m
            end if
            FracH(n,n,m) = 1.d0
            do nu=n-1,im,-1
               FracH(n,nu,m) = root(2*nu+3)*root(nu-im+1)*
     +              FracH(n,nu+1,m)/(root(2*nu+1)*root(nu+im+1))
            end do
            do nu=n+1,Nmax
               FracH(n,nu,m) = root(2*nu-1)*root(nu+im)*FracH(n,nu-1,m)/
     +              (root(2*nu+1)*root(nu-im))
            end do
         end do
      end do
*
      end
*
*======================================================================*
*
      real*8 FUNCTION H(n,m)
*
      INCLUDE 'parameters.f'
*
************************************************************************
*                                                                      *
*     The function H(n,m) is the constant h_n^m as                     *
*     defined in equation (2.6) of the paper.                          *
*                                                                      *
************************************************************************
*
      integer n,m,im
      real*8 root(0:2*Nmax), fact(0:2*Nmax)
      common /sqrts/ root, fact
*
      if (m .LT. 0) then
         im = -m
      else
         im = m
      end if
      H = root(2*n+1)*fact(n-im)/fact(n+im)
      H = H/(2.d0*dsqrt(pi))
*
      end
*
*======================================================================*
*
      SUBROUTINE Set_N
*
      INCLUDE 'parameters.f'
*
************************************************************************
*                                                                      *
*     Fixes the following constants:                                   *
*        Neach(i): the number of n-terms of Lamb's solution to be used *
*                  for particle i                                      *
*        NN(i,j) : the N-value relevant to the separation between      *
*                  particles i and j (used for rotation matrices)      *
*        MainN   : the maximum of Neach(i) across all particles        *
*                                                                      *
*     The method is based on equation (2.33) of the paper.             *
*                                                                      *
*     If parameter NFUDGE is set to TRUE, the code will not abort if   *
*     the matrices are too small for optimal accuracy; a warning       *
*     message is printed out.                                          *
*                                                                      *
************************************************************************
*
      integer i,j
      real*8 zeta,q
*
      do i=1,Nspheres
         Neach(i) = 1
      end do
      MainN = 1
      do i=1,Nspheres
         do j=i+1,Nspheres
            zeta = 2.d0*dabs(r(i,j))/(radius(i)+radius(j))
            q = 0.5d0*(zeta - dsqrt(zeta**2 - 4.d0))
            NN(i,j) = int(dlog(globalerror)/dlog(q))+1
c-----c
            if (NN(i,j) .GT. Nmax) then
               if (NFUDGE) then
                  print *,'Using fudge for N'
                  NN(i,j) = Nmax
               else
                  print *,'Warning: N about to be too small',i,j,NN(i,j)
               end if
            end if
c-----c
            NN(j,i) = NN(i,j)
            if (NN(i,j) .GT. Neach(i)) then
               Neach(i) = NN(i,j)
            end if
            if (NN(i,j) .GT. Neach(j)) then
               Neach(j) = NN(i,j)
            end if
            if (NN(i,j) .GT. MainN) then
               MainN = NN(i,j)
            end if
         end do
      end do
*
      if (MainN .GT. Nmax) then
         print *,MainN,Nmax
         STOP 'Nmax is too small (or spheres too close)'
      end if
*
      end
*
*======================================================================*
*
      SUBROUTINE Update_Fields(i)
*
      INCLUDE 'parameters.f'
*
      integer i,j,m,n

***********************************************************************
*                                                                     *
*     This subroutine completes a reflection by:                      *
*     * Adding X(*,i,2,*,*) to X(*,i,1,*,*);                          *
*     * Moving X(*,i,3,*,*) to X(*,i,2,*,*); and                      *
*     * Setting X(*,i,3,*,*) to zero ready for the next reflection    *
*     * Setting X(*,i,4,*,*) to zero ready for the next reflection    *
*                                                                     *
***********************************************************************
*
      do j=1,2
         do n=0,Neach(i)
            do m=-n,n
               A(j,i,1,n,m) = A(j,i,1,n,m) + A(j,i,2,n,m)
               A(j,i,2,n,m) = A(j,i,3,n,m)
               A(j,i,3,n,m) = 0.d0
               B(j,i,1,n,m) = B(j,i,1,n,m) + B(j,i,2,n,m)
               B(j,i,2,n,m) = B(j,i,3,n,m)
               B(j,i,3,n,m) = 0.d0
               C(j,i,1,n,m) = C(j,i,1,n,m) + C(j,i,2,n,m)
               C(j,i,2,n,m) = C(j,i,3,n,m)
               C(j,i,3,n,m) = 0.d0
               D(j,i,1,n,m) = D(j,i,1,n,m) + D(j,i,2,n,m)
               D(j,i,2,n,m) = 0.d0
               E(j,i,1,n,m) = E(j,i,1,n,m) + E(j,i,2,n,m)
               E(j,i,2,n,m) = 0.d0
               F(j,i,1,n,m) = F(j,i,1,n,m) + F(j,i,2,n,m)
               F(j,i,2,n,m) = 0.d0
            end do
         end do
      end do
*
      end
*
*======================================================================*
*
      real*8 FUNCTION Find_force(k,p)
*
      INCLUDE 'parameters.f'
*
************************************************************************
*                                                                      *
*     Calculates the magnitude of the additional velocity contribution *
*     contained in the fields X(*,k,p,*,*). Result is the sum of the   *
*     magnitudes of velocity and angular velocity vectors. Used to     *
*     determine when to terminate the iterations; was also handy for   *
*     debugging.                                                       *
*                                                                      *
************************************************************************
*
*     Inputs
      integer k,p
*
*     Internal variables
      integer i,j
      real*8 Fxr, Fyr, Fzr, Fxi, Fyi, Fzi, H
      real*8 Txr, Tyr, Tzr, Txi, Tyi, Tzi, Torque
      real*8 Uxr, Uyr, Uzr, Uxi, Uyi, Uzi
      real*8 Oxr, Oyr, Ozr, Oxi, Oyi, Ozi
      real*8 V(1:2,-1:1), O(1:2,-1:1)
*
      do i=1,2
         do j=-1,1
            V(i,j) = H(1,j)*(-5.d0*A(i,k,p,1,j)/radius(k)**3 +
     +           1.5d0*C(i,k,p,1,j)/radius(k) +
     +           D(i,k,p,1,j))
            O(i,j) = H(1,j)*(B(i,k,p,1,j)/radius(k)**3+E(i,k,p,1,j))
         end do
      end do
      Uxr = V(1,0)
      Uxi = V(2,0)
      Uyr = -1.d0*(V(1,1)-V(1,-1))
      Uyi = -1.d0*(V(2,1)-V(2,-1))
      Uzr = -1.d0*(V(2,1)+V(2,-1))
      Uzi = V(1,1)+V(1,-1)
*
      Oxr = O(1,0)
      Oxi = O(2,0)
      Oyr = O(1,-1)-O(1,1)
      Oyi = O(2,-1)-O(2,1)
      Ozr = -1.d0*(O(2,1)+O(2,-1))
      Ozi = O(1,1)+O(1,-1)
*
      Find_force = Uxr**2.d0 + Uyr**2.d0 + Uzr**2.d0 +
     +     Uxi**2.d0 + Uyi**2.d0 + Uzi**2.d0
      Torque = Oxr**2.d0 + Oyr**2.d0 + Ozr**2.d0 +
     +     Oxi**2.d0 + Oyi**2.d0 + Ozi**2.d0
*
      Find_force = 6.d0*pi*radius(k)*
     +     (dsqrt(Find_force) + dsqrt(Torque))
*
      end
*
*======================================================================*


      SUBROUTINE SPOLZ2(A,Z)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-04-27 SPOLZ2 Krogh   Changes to use .C. and C%%.
c>> 1996-03-30 SPOLZ2 Krogh   Added external statement.
C>> 1996-01-18 SPOLZ2 Krogh   Added code for M77CON for conversion to C.
C>> 1992-03-13 SPOLZ2 FTK     Removed implicit statements.
C>> 1987-02-25 SPOLZ2 Lawson  Initial code.
c--S Replaces "?": ?POLZ2
c++ Default NO_COMPLEX = .C. | (.N. == 'D')
c++ Default COMPLEX = ~NO_COMPLEX
C
C     ------------------------------------------------------------------
C
C     Find the two roots of the quadratic polynomial
C               A(1)*X*X + A(2)*X + A(3)
C     Return the roots as the complex numbers (Z(1), Z(2)) and
C     (Z(3), Z(4)) if Z is not complex, else return the two complex
C     numbers, Z(1) and Z(2).
C     Require A(1) .ne. 0.
C
C     Method:
C     Divide through by A(1). New polynomial is
C            X*X + P*X + Q
C     Let U = -P/2
C     Roots are U + SQRT(U*U-Q) and U - SQRT(U*U-Q).
C     Avoid computing U*U explicity if it might overflow or
C     underflow. In case of real roots, U + Z and U - Z, the first
C     root is  U + SIGN(U)*ABS(Z) and the second is Q / Z(1).
C
c     C. L. Lawson & S. Chiu, JPL, 1987 Feb 16.
C     ------------------------------------------------------------------
C
      EXTERNAL R1MACH
      REAL             A(3),AQ,AU,C1,C16,C2,D,R1MACH,F,HALF,ONE,P,Q
      REAL             U,V,W,ZERO
      PARAMETER(ZERO=0.E0, HALF=.5E0, ONE=1.E0, C16=16.E0)
      LOGICAL FIRST
c++ CODE for COMPLEX is active
      COMPLEX Z(2), R1, R2
c++ CODE for NO_COMPLEX is inactive
C      REAL             Z(4), R1, R2, R3, R4
c++ END
C
      SAVE FIRST, C1, C2
C
      DATA FIRST / .TRUE. /
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF (FIRST) THEN
        FIRST = .FALSE.
C
C     R1MACH(1) is the underflow limit.
C
        C1 = SQRT(R1MACH(1)*C16)
C
C     R1MACH(2) is the overflow limit.
C
        C2 = SQRT(R1MACH(2)/C16)
      END IF
C
      IF (A(1) .EQ. ZERO) THEN
        CALL ERMSG('SPOLZ2',1,0,'A(1) .EQ. 0.','.')
        R1 = ZERO
        R2 = ZERO
c++ CODE for NO_COMPLEX is inactive
C        R3 = ZERO
C        R4 = ZERO
c++ END
        GO TO 99
      ELSE
        P = A(2) / A(1)
        Q = A(3) / A(1)
      END IF
C
      IF (Q .EQ. ZERO) THEN
        R1 = ZERO
c++ CODE for COMPLEX is active
        R2 = -P
c++ CODE for NO_COMPLEX is inactive
C        R2 = ZERO
C        R3 = -P
C        R4 = ZERO
c++ END
        GO TO 99
      END IF
C
      IF (P .EQ. ZERO) THEN
        W = SQRT(ABS(Q))
        IF (Q .GT. ZERO) THEN
c++ CODE for COMPLEX is active
          R1 = CMPLX(ZERO,W)
          R2 = CMPLX(ZERO,-W)
c++ CODE for NO_COMPLEX is inactive
C          R1 = ZERO
C          R2 = W
C          R3 = ZERO
C          R4 = -W
c++ END
        ELSE
c++ CODE for COMPLEX is active
          R1 = CMPLX(W,ZERO)
          R2 = CMPLX(-W,ZERO)
c++ CODE for NO_COMPLEX is inactive
C          R1 = W
C          R2 = ZERO
C          R3 = -W
C          R4 = ZERO
c++ END
        END IF
        GO TO 99
      END IF
      U = -P * HALF
C
C     Compute D having the sign of U*U-Q
C         and F = SQRT(ABS(U*U-Q))
C
      AU = ABS(U)
      IF (AU .GT. C2) THEN
        D = ONE - (Q/U) / U
        F = AU * SQRT(ABS(D))
      ELSE IF (AU .LT. C1) THEN
        AQ = ABS(Q)
        D = U * (U/AQ) - SIGN(ONE, Q)
        F = SQRT(AQ) * SQRT(ABS(D))
      ELSE
        D = U*U - Q
        F = SQRT(ABS(D))
      END IF
C
      IF (D .EQ. ZERO) THEN
c++ CODE for COMPLEX is active
        R1 = CMPLX(U,ZERO)
        R2 = R1
c++ CODE for NO_COMPLEX is inactive
C        R1 = U
C        R2 = ZERO
C        R3 = R1
C        R4 = ZERO
c++ END
      ELSE
        IF (D .GT. ZERO) THEN
          IF (U .GT. ZERO) THEN
            V = U + F
          ELSE
            V = U - F
          END IF
c++ CODE for COMPLEX is active
          R1 = CMPLX(V,ZERO)
          R2 = CMPLX(Q/V,ZERO)
c++ CODE for NO_COMPLEX is inactive
C          R1 = V
C          R2 = ZERO
C          R3 = Q/V
C          R4 = ZERO
c++ END
        ELSE
c++ CODE for COMPLEX is active
          R1 = CMPLX(U,F)
          R2 = CMPLX(U,-F)
c++ CODE for NO_COMPLEX is inactive
C          R1 = U
C          R2 = F
C          R3 = U
C          R4 = -F
c++ END
        END IF
      END IF
C
   99 CONTINUE
      Z(1) = R1
      Z(2) = R2
c++ CODE for NO_COMPLEX is inactive
C      Z(3) = R3
C      Z(4) = R4
c++ END
      RETURN
      END


    Program dhgeqz_example

!     DHGEQZ 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_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgeqrf, dggbal, dgghd3, dhgeqz, dormqr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, ihi, ilo, info, irows, jwork, lda, ldb, ldq, ldz, &
        lwork, n
      Character (1) :: compq, compz, job
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), alphai(:), alphar(:), b(:, :), &
        beta(:), lscale(:), q(:, :), rscale(:), tau(:), work(:), z(:, :)
!     .. Intrinsic Procedures ..
      Intrinsic :: nint
!     .. Executable Statements ..
      Write (nout, *) 'DHGEQZ Example Program Results'
      Flush (nout)

!     Skip heading in data file

      Read (nin, *)
      Read (nin, *) n
      ldq = 1
      ldz = 1
      lda = n
      ldb = n
      lwork = 6*n
      Allocate (alphai(n), alphar(n), beta(n), a(lda,n), lscale(n), &
        q(ldq,ldq), rscale(n), b(ldb,n), tau(n), work(lwork), z(ldz,ldz))

!     READ matrix A from data file
      Read (nin, *)(a(i,1:n), i=1, n)

!     READ matrix B from data file
      Read (nin, *)(b(i,1:n), i=1, n)

!     Balance matrix pair (A,B)
      job = 'B'

      Call dggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, &
        info)

!     Matrix A after balancing

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
        'Matrix A after balancing', ifail)

      Write (nout, *)
      Flush (nout)

!     Matrix B after balancing

      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, b, ldb, &
        'Matrix B after balancing', ifail)

      Write (nout, *)
      Flush (nout)

!     Reduce B to triangular form using QR
      irows = ihi + 1 - ilo

      Call dgeqrf(irows, irows, b(ilo,ilo), ldb, tau, work, lwork, info)

!     Apply the orthogonal transformation to matrix A
      Call dormqr('L', 'T', irows, irows, irows, b(ilo,ilo), ldb, tau, &
        a(ilo,ilo), lda, work, lwork, info)

!     Compute the generalized Hessenberg form of (A,B) -> (H,T)
      compq = 'N'
      compz = 'N'

      Call dgghd3(compq, compz, irows, 1, irows, a(ilo,ilo), lda, b(ilo,ilo), &
        ldb, q, ldq, z, ldz, work, lwork, info)

!     Matrix A (H) in generalized Hessenberg form.

      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
        'Matrix A in Hessenberg form', ifail)

      Write (nout, *)
      Flush (nout)

!     Matrix B (T) in generalized Hessenberg form.

      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, b, ldb, &
        'Matrix B is triangular', ifail)

!     Routine DHGEQZ
!     Workspace query: jwork = -1

      jwork = -1
      job = 'E'

      Call dhgeqz(job, compq, compz, n, ilo, ihi, a, lda, b, ldb, alphar, &
        alphai, beta, q, ldq, z, ldz, work, jwork, info)

      Write (nout, *)
      Write (nout, 100) nint(work(1))
      Write (nout, 110) lwork
      Write (nout, *)

!     Compute the generalized Schur form
!     if the workspace lwork is adequate

      If (nint(work(1))<=lwork) Then

        Call dhgeqz(job, compq, compz, n, ilo, ihi, a, lda, b, ldb, alphar, &
          alphai, beta, q, ldq, z, ldz, work, lwork, info)

!       Print the generalized eigenvalues

        Write (nout, 120)

        Do i = 1, n
          If (beta(i)/=0.0E0_dp) Then
            Write (nout, 130) i, '(', alphar(i)/beta(i), ',', &
              alphai(i)/beta(i), ')'
          Else
            Write (nout, 150) i
          End If
        End Do
      Else
        Write (nout, 140)
      End If

100   Format (1X, 'Minimal required LWORK = ', I6)
110   Format (1X, 'Actual value of  LWORK = ', I6)
120   Format (1X, 'Generalized eigenvalues')
130   Format (1X, I4, 5X, A, F7.3, A, F7.3, A)
140   Format (1X, 'Insufficient workspace allocated for call to DHGEQZ')
150   Format (1X, I4, 'Eigenvalue is infinite')
    End Program


!*==srotg.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b SROTG
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE SROTG(SA,SB,C,S)
!
!       .. Scalar Arguments ..
!       REAL C,S,SA,SB
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    SROTG construct givens plane rotation.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in,out] SA
!> \verbatim
!>          SA is REAL
!> \endverbatim
!>
!> \param[in,out] SB
!> \verbatim
!>          SB is REAL
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is REAL
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is REAL
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, linpack, 3/11/78.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SROTG(Sa,Sb,C,S)
      IMPLICIT NONE
!*--SROTG73
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      REAL C , S , Sa , Sb
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      REAL r , roe , scale , z
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , SIGN , SQRT
!     ..
      scale = ABS(Sa) + ABS(Sb)
      IF ( scale==0.0 ) THEN
         C = 1.0
         S = 0.0
         r = 0.0
         z = 0.0
      ELSE
         roe = Sb
         IF ( ABS(Sa)>ABS(Sb) ) roe = Sa
         r = scale*SQRT((Sa/scale)**2+(Sb/scale)**2)
         r = SIGN(1.0,roe)*r
         C = Sa/r
         S = Sb/r
         z = 1.0
         IF ( ABS(Sa)>ABS(Sb) ) z = S
         IF ( ABS(Sb)>=ABS(Sa) .AND. C/=0.0 ) z = 1.0/C
      ENDIF
      Sa = r
      Sb = z
      END SUBROUTINE SROTG


*----------------------------------------------------------------------*
      subroutine regular_tikhonov(ncol,nlin,mat,sv,omega2)
*----------------------------------------------------------------------*
*     multiplies the columns of the input matrix with a regularization
*     factor based on the corresponding singular value,
*     in order to achieve Tikhonov regularization.
*     We assume that the input matrix already contains sv^(-1/2),
*     such that the needed factor is sv/sqrt(sv^2+omega2)
*
*     matthias, jul 2012
*----------------------------------------------------------------------*
      implicit none

      integer, intent(in) ::
     &     ncol, nlin
      real(8), intent(inout) ::
     &     mat(nlin,ncol)
      real(8), intent(in) ::
     &     sv(ncol), omega2

      real(8) ::
     &     fac
      integer ::
     &     icol
      real(8), external ::
     &     ddot

      if (nlin.eq.0) return

c dbg
c          write(*,*) 'before Tikhonov:'
c          call wrtmat2(mat,nlin,ncol,nlin,ncol)
c          write(*,*) 'singular values:'
c          call wrtmat2(sv,1,ncol,1,ncol)
c dbgend

      do icol = 1, ncol
        fac = sv(icol)/sqrt(sv(icol)**2+omega2)
c        ! modified regularization: s^-1/2 --> 1/(s^2+omega2)^0.25
c        fac = sqrt(sv(icol))/((sv(icol)**2+omega2)**0.25d0)
c        ! mod: just unitary matrix
c        fac = sqrt(sv(icol))
        mat(1:nlin,icol) = fac * mat(1:nlin,icol)
      end do
c dbg
c          write(*,*) 'after Tikhonov:'
c          call wrtmat2(mat,nlin,ncol,nlin,ncol)
c          write(*,*) 'norms:'
c          do icol = 1, ncol
c            fac = ddot(nlin,mat(1,icol),1,mat(1,icol),1)
c            if (fac.gt.1d-12) print *,icol,fac
c          end do
c dbgend

      return
      end


program main
    implicit none
    integer :: counter
    !integer :: counter2
    real :: sum = 0
    integer :: factorial

    do counter = 1, 10
        !factorial = 1
        !do counter2 = 2, n
        !    factorial = factorial * counter2
        !end do
        sum = sum + 1.0 / factorial(counter)
    end do
    write (*,'(A, F0.6)') 'The result of 1/1!+1/2!+1/3!+1/$!+9+...+1/10! is ', sum
end program main

function factorial(n)
    implicit none
    integer :: n
    integer :: factorial
    integer :: counter

    factorial = 1
    do counter = 2, n
        factorial = factorial * counter
    end do
    return
end function


program leap_year
    implicit none

    print *, 1899, is_leap_year(1899)
    print *, 1936, is_leap_year(1936)
    print *, 1900, is_leap_year(1900)
    print *, 2000, is_leap_year(2000)

contains

    logical function is_leap_year(year)
        implicit none
        integer :: year

        if (mod(year, 4) == 0) then
            if (mod(year, 100) == 0) then
                if (mod(year, 400) == 0) then
                    is_leap_year = .true.
                else
                    is_leap_year = .false.
                end if
            else
                is_leap_year = .true.
            end if
        else
            is_leap_year = .false.
        end if
    end function is_leap_year

end program leap_year


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file shagc.f
c
c     this file contains code and documentation for subroutines
c     shagc and shagci
c
c ... files which must be loaded with shagc.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c
c     subroutine shagc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    +                 wshagc,lshagc,work,lwork,ierror)
c
c     subroutine shagc performs the spherical harmonic analysis
c     on the array g and stores the result in the arrays a and b.
c     the analysis is performed on a gaussian grid in colatitude
c     and an equally spaced grid in longitude.  the associated
c     legendre functions are recomputed rather than stored as they
c     are in subroutine shags.  the analysis is described below
c     at output parameters a,b.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the analysis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the analysis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of analyses.  in the program that calls shagc,
c            the arrays g,a and b can be three dimensional in which
c            case multiple analyses will be performed.  the third
c            index is the analysis index which assumes the values
c            k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     g      a two or three dimensional array (see input parameter
c            nt) that contains the discrete function to be analyzed.
c            g(i,j) contains the value of the function at the gaussian
c            point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon
c            the index ranges are defined above at the input parameter
c            isym.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shagc. if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg must
c            be at least nlat/2 if nlat is even or at least (nlat+1)/2
c            if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shagc. jdg must be at least nlon.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shagc. mdab must be at least
c            min0((nlon+2)/2,nlat) if nlon is even or at least
c            min0((nlon+1)/2,nlat) if nlon is odd
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shaec. ndab must be at least nlat
c
c     wshagc an array which must be initialized by subroutine shagci.
c            once initialized, wshagc can be used repeatedly by shagc.
c            as long as nlat and nlon remain unchanged.  wshagc must
c            not be altered between calls of shagc.
c
c     lshagc the dimension of the array wshagc as it appears in the
c            program that calls shagc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshagc must be at least
c
c                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shagc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if isym is zero then lwork must be at least
c
c                      nlat*(nlon*nt+max0(3*l2,nlon))
c
c            if isym is not zero then lwork must be at least
c
c                      l2*(nlon*nt+max0(3*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     a,b    both a,b are two or three dimensional arrays (see input
c            parameter nt) that contain the spherical harmonic
c            coefficients in the representation of g(i,j) given in the
c            discription of subroutine shagc. for isym=0, a(m,n) and
c            b(m,n) are given by the equations listed below. symmetric
c            versions are used when isym is greater than zero.
c
c     definitions
c
c     1. the normalized associated legendre functions
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta).
c
c     2. the fourier transform of g(i,j).
c
c     c(m,i)          = 2/nlon times the sum from j=1 to j=nlon of
c                       g(i,j)*cos((m-1)*(j-1)*2*pi/nlon)
c                       (the first and last terms in this sum
c                       are divided by 2)
c
c     s(m,i)          = 2/nlon times the sum from j=2 to j=nlon of
c                       g(i,j)*sin((m-1)*(j-1)*2*pi/nlon)
c
c
c     3. the gaussian points and weights on the sphere
c        (computed by subroutine gaqd).
c
c        theta(1),...,theta(nlat) (gaussian pts in radians)
c        wts(1),...,wts(nlat) (corresponding gaussian weights)
c
c     4. the maximum (plus one) longitudinal wave number
c
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c
c     then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b
c     are given by
c
c     a(m+1,n+1)     =  the sum from i=1 to i=nlat of
c                       c(m+1,i)*wts(i)*pbar(m,n,theta(i))
c
c     b(m+1,n+1)      = the sum from i=1 to nlat of
c                       s(m+1,i)*wts(i)*pbar(m,n,theta(i))
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshagc
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c
c     subroutine shagci(nlat,nlon,wshagc,lshagc,dwork,ldwork,ierror)
c
c     subroutine shagci initializes the array wshagc which can then
c     be used repeatedly by subroutines shagc. it precomputes
c     and stores in wshagc quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshagc an array which must be initialized by subroutine shagci.
c            once initialized, wshagc can be used repeatedly by shagc
c            as long as nlat and nlon remain unchanged.  wshagc must
c            not be altered between calls of shagc.
c
c     lshagc the dimension of the array wshagc as it appears in the
c            program that calls shagc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshagc must be at least
c
c                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
C*PL*ERROR* Comment line too long
c     dwork   a double precision work array that does not have to be saved.
c
c     ldwork  the dimension of the array dwork as it appears in the
c            program that calls shagci. ldwork must be at least
c
c                nlat*(nlat+4)
c
c     output parameter
c
c     wshagc an array which must be initialized before calling shagc or
c            once initialized, wshagc can be used repeatedly by shagc or
c            as long as nlat and nlon remain unchanged.  wshagc must not
c            altered between calls of shagc.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshagc
c            = 4  error in the specification of ldwork
c            = 5  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
c ****************************************************************
      SUBROUTINE DSHAGC(NLAT,NLON,ISYM,NT,G,IDG,JDG,A,B,MDAB,NDAB,
     +                  WSHAGC,LSHAGC,WORK,LWORK,IERROR)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHAGC
      DOUBLE PRECISION WORK
c     subroutine shagc performs the spherical harmonic analysis on
c     a gaussian grid on the array(s) in g and returns the coefficients
c     in array(s) a,b. the necessary legendre polynomials are computed
c     as needed in this version.
c
      DIMENSION G(IDG,JDG,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),
     +          WSHAGC(LSHAGC),WORK(LWORK)
c     check input parameters
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.1) RETURN
c     set upper limit on m for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set gaussian point nearest equator pointer
      LATE = (NLAT+MOD(NLAT,2))/2
c     set number of grid points for analysis/synthesis
      LAT = NLAT
      IF (ISYM.NE.0) LAT = LATE
      IERROR = 5
      IF (IDG.LT.LAT) RETURN
      IERROR = 6
      IF (JDG.LT.NLON) RETURN
      IERROR = 7
      IF (MDAB.LT.L) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      L1 = L
      L2 = LATE
      IERROR = 9
c     check permanent work space length
      IF (LSHAGC.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 10
c     check temporary work space length
      IF (ISYM.EQ.0) THEN
          IF (LWORK.LT.NLAT* (NLON*NT+MAX0(3*L2,NLON))) RETURN
      ELSE
c     isym.ne.0
          IF (LWORK.LT.L2* (NLON*NT+MAX0(3*NLAT,NLON))) RETURN
      END IF
      IERROR = 0
c     starting address for gaussian wts in shigc and fft values
      IWTS = 1
      IFFT = NLAT + 2*NLAT*LATE + 3* (L* (L-1)/2+ (NLAT-L)* (L-1)) + 1
c     set pointers for internal storage of g and legendre polys
      IPMN = LAT*NLON*NT + 1
      CALL DSHAGC1(NLAT,NLON,L,LAT,ISYM,G,IDG,JDG,NT,A,B,MDAB,NDAB,
     +             WSHAGC,WSHAGC(IWTS),WSHAGC(IFFT),LATE,WORK(IPMN),
     +             WORK)
      RETURN
      END
      SUBROUTINE DSHAGC1(NLAT,NLON,L,LAT,MODE,GS,IDG,JDG,NT,A,B,MDAB,
     +                  NDAB,W,WTS,WFFT,LATE,PMN,G)
      DOUBLE PRECISION GS
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION W
      DOUBLE PRECISION WTS
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION PMN
      DOUBLE PRECISION G
      DOUBLE PRECISION SFN
      DOUBLE PRECISION T1
      DOUBLE PRECISION T2
      DIMENSION GS(IDG,JDG,NT),A(MDAB,NDAB,NT),B(MDAB,NDAB,NT),
     +          G(LAT,NLON,NT)
      DIMENSION W(1),WTS(NLAT),WFFT(1),PMN(NLAT,LATE,3)
c     set gs array internally in shagc1
      DO 100 K = 1,NT
          DO 100 J = 1,NLON
              DO 100 I = 1,LAT
                  G(I,J,K) = GS(I,J,K)
  100 CONTINUE
c     do fourier transform
      DO 101 K = 1,NT
          CALL DHRFFTF(LAT,NLON,G(1,1,K),LAT,WFFT,PMN)
  101 CONTINUE
c     scale result
      SFN = 2.0D0/DBLE(NLON)
      DO 102 K = 1,NT
          DO 102 J = 1,NLON
              DO 102 I = 1,LAT
                  G(I,J,K) = SFN*G(I,J,K)
  102 CONTINUE
c     compute using gaussian quadrature
c     a(n,m) = s (ga(theta,m)*pnm(theta)*sin(theta)*dtheta)
c     b(n,m) = s (gb(theta,m)*pnm(theta)*sin(theta)*dtheta)
c     here ga,gb are the cos(phi),sin(phi) coefficients of
c     the fourier expansion of g(theta,phi) in phi.  as a result
c     of the above fourier transform they are stored in array
c     g as follows:
c     for each theta(i) and k= l-1
c     ga(0),ga(1),gb(1),ga(2),gb(2),...,ga(k-1),gb(k-1),ga(k)
c     correspond to (in the case nlon=l+l-2)
c     g(i,1),g(i,2),g(i,3),g(i,4),g(i,5),...,g(i,2l-4),g(i,2l-3),g(i,2l-
c     initialize coefficients to zero
      DO 103 K = 1,NT
          DO 103 NP1 = 1,NLAT
              DO 103 MP1 = 1,L
                  A(MP1,NP1,K) = 0.0D0
                  B(MP1,NP1,K) = 0.0D0
  103 CONTINUE
c     set m+1 limit on b(m+1) calculation
      LM1 = L
      IF (NLON.EQ.L+L-2) LM1 = L - 1
      IF (MODE.EQ.0) THEN
c     for full sphere (mode=0) and even/odd reduction:
c     overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i)
c     overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i)
          NL2 = NLAT/2
          DO 104 K = 1,NT
              DO 104 J = 1,NLON
                  DO 105 I = 1,NL2
                      IS = NLAT - I + 1
                      T1 = G(I,J,K)
                      T2 = G(IS,J,K)
                      G(I,J,K) = WTS(I)* (T1+T2)
                      G(IS,J,K) = WTS(I)* (T1-T2)
  105             CONTINUE
c     adjust equator if necessary(nlat odd)
                  IF (MOD(NLAT,2).NE.0) G(LATE,J,K) = WTS(LATE)*
     +                G(LATE,J,K)
  104     CONTINUE
c     set m = 0 coefficients first
          M = 0
          CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
          DO 106 K = 1,NT
              DO 106 I = 1,LATE
                  IS = NLAT - I + 1
                  DO 107 NP1 = 1,NLAT,2
c     n even
                      A(1,NP1,K) = A(1,NP1,K) + G(I,1,K)*PMN(NP1,I,KM)
  107             CONTINUE
                  DO 108 NP1 = 2,NLAT,2
c     n odd
                      A(1,NP1,K) = A(1,NP1,K) + G(IS,1,K)*PMN(NP1,I,KM)
  108             CONTINUE
  106     CONTINUE
c     compute coefficients for which b(m,n) is available
          DO 109 MP1 = 2,LM1
              M = MP1 - 1
              MP2 = M + 2
c     compute pmn for all i and n=m,...,l-1
              CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
              DO 110 K = 1,NT
                  DO 111 I = 1,LATE
                      IS = NLAT - I + 1
c     n-m even
                      DO 112 NP1 = MP1,NLAT,2
                          A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                                   G(I,2*M,K)*PMN(NP1,I,KM)
                          B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                                   G(I,2*M+1,K)*PMN(NP1,I,KM)
  112                 CONTINUE
c     n-m odd
                      DO 113 NP1 = MP2,NLAT,2
                          A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                                   G(IS,2*M,K)*PMN(NP1,I,KM)
                          B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                                   G(IS,2*M+1,K)*PMN(NP1,I,KM)
  113                 CONTINUE
  111             CONTINUE
  110         CONTINUE
  109     CONTINUE
          IF (NLON.EQ.L+L-2) THEN
c     compute a(l,np1) coefficients only
              M = L - 1
              CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
              DO 114 K = 1,NT
                  DO 114 I = 1,LATE
                      IS = NLAT - I + 1
c     n-m even
                      DO 124 NP1 = L,NLAT,2
                          A(L,NP1,K) = A(L,NP1,K) +
     +                                 0.5D0*G(I,NLON,K)*PMN(NP1,I,KM)
  124                 CONTINUE
                      LP1 = L + 1
c     n-m odd
                      DO 125 NP1 = LP1,NLAT,2
                          A(L,NP1,K) = A(L,NP1,K) +
     +                                 0.5D0*G(IS,NLON,K)*PMN(NP1,I,KM)
  125                 CONTINUE
  114         CONTINUE
          END IF
      ELSE
c     half sphere
c     overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1,...,nlate/2
          NL2 = NLAT/2
          DO 116 K = 1,NT
              DO 116 J = 1,NLON
                  DO 115 I = 1,NL2
                      G(I,J,K) = WTS(I)* (G(I,J,K)+G(I,J,K))
  115             CONTINUE
c     adjust equator separately if a grid point
                  IF (NL2.LT.LATE) G(LATE,J,K) = WTS(LATE)*G(LATE,J,K)
  116     CONTINUE
c     set m = 0 coefficients first
          M = 0
          CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
          MS = 1
          IF (MODE.EQ.1) MS = 2
          DO 117 K = 1,NT
              DO 117 I = 1,LATE
                  DO 117 NP1 = MS,NLAT,2
                      A(1,NP1,K) = A(1,NP1,K) + G(I,1,K)*PMN(NP1,I,KM)
  117     CONTINUE
c     compute coefficients for which b(m,n) is available
          DO 118 MP1 = 2,LM1
              M = MP1 - 1
              MS = MP1
              IF (MODE.EQ.1) MS = MP1 + 1
c     compute pmn for all i and n=m,...,nlat-1
              CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
              DO 119 K = 1,NT
                  DO 119 I = 1,LATE
                      DO 119 NP1 = MS,NLAT,2
                          A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                                   G(I,2*M,K)*PMN(NP1,I,KM)
                          B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                                   G(I,2*M+1,K)*PMN(NP1,I,KM)
  119         CONTINUE
  118     CONTINUE
          IF (NLON.EQ.L+L-2) THEN
c     compute coefficient a(l,np1) only
              M = L - 1
              CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
              NS = L
              IF (MODE.EQ.1) NS = L + 1
              DO 120 K = 1,NT
                  DO 120 I = 1,LATE
                      DO 120 NP1 = NS,NLAT,2
                          A(L,NP1,K) = A(L,NP1,K) +
     +                                 0.5D0*G(I,NLON,K)*PMN(NP1,I,KM)
  120         CONTINUE
          END IF
      END IF
      RETURN
      END
      SUBROUTINE DSHAGCI(NLAT,NLON,WSHAGC,LSHAGC,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHAGC
c     this subroutine must be called before calling shagc with
c     fixed nlat,nlon. it precomputes quantites such as the gaussian
c     points and weights, m=0,m=1 legendre polynomials, recursion
c     recursion coefficients.
      DIMENSION WSHAGC(LSHAGC)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+MOD(NLAT,2))/2
      L1 = L
      L2 = LATE
      IERROR = 3
c     check permanent work space length
      IF (LSHAGC.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 4
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
c     set pointers
      I1 = 1
      I2 = I1 + NLAT
      I3 = I2 + NLAT*LATE
      I4 = I3 + NLAT*LATE
      I5 = I4 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I6 = I5 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I7 = I6 + L* (L-1)/2 + (NLAT-L)* (L-1)
c     set indices in temp work for double precision gaussian wts and pts
      IDTH = 1
      IDWTS = IDTH + NLAT
      IW = IDWTS + NLAT
      CALL DSHAGCI1(NLAT,NLON,L,LATE,WSHAGC(I1),WSHAGC(I2),WSHAGC(I3),
     +              WSHAGC(I4),WSHAGC(I5),WSHAGC(I6),WSHAGC(I7),
     +              DWORK(IDTH),DWORK(IDWTS),DWORK(IW),IERROR)
      IF (IERROR.NE.0) IERROR = 5
      RETURN
      END
      SUBROUTINE DSHAGCI1(NLAT,NLON,L,LATE,WTS,P0N,P1N,ABEL,BBEL,CBEL,
     +                    WFFT,DTHETA,DWTS,WORK,IER)
      DOUBLE PRECISION WTS
      DOUBLE PRECISION P0N
      DOUBLE PRECISION P1N
      DOUBLE PRECISION ABEL
      DOUBLE PRECISION BBEL
      DOUBLE PRECISION CBEL
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION FN
      DOUBLE PRECISION FM
      DIMENSION WTS(NLAT),P0N(NLAT,LATE),P1N(NLAT,LATE),ABEL(1),BBEL(1),
     +          CBEL(1),WFFT(1)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION PB,DTHETA(NLAT),DWTS(NLAT),WORK(*),W
c     compute the nlat  gaussian points and weights, the
c     m=0,1 legendre polys for gaussian points and all n,
c     and the legendre recursion coefficients
c     define index function used in storing
c     arrays for recursion coefficients (functions of (m,n))
c     the index function indx(m,n) is defined so that
c     the pairs (m,n) map to [1,2,...,indx(l-1,l-1)] with no
c     "holes" as m varies from 2 to n and n varies from 2 to l-1.
c     (m=0,1 are set from p0n,p1n for all n)
c     define for 2.le.n.le.l-1
      INDX(M,N) = (N-1)* (N-2)/2 + M - 1
c     define index function for l.le.n.le.nlat
      IMNDX(M,N) = L* (L-1)/2 + (N-L-1)* (L-1) + M - 1
c     preset quantites for fourier transform
      CALL DHRFFTI(NLON,WFFT)
c     compute double precision gaussian points and weights
c     lw = 4*nlat*(nlat+1)+2
      LW = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHETA,DWTS,W,LW,IER)
      IF (IER.NE.0) RETURN
c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      DO 100 I = 1,NLAT
          WTS(I) = DWTS(I)
  100 CONTINUE
c     initialize p0n,p1n using double precision dnlfk,dnlft
      DO 101 NP1 = 1,NLAT
          DO 101 I = 1,LATE
              P0N(NP1,I) = 0.0D0
              P1N(NP1,I) = 0.0D0
  101 CONTINUE
c     compute m=n=0 legendre polynomials for all theta(i)
      NP1 = 1
      N = 0
      M = 0
      CALL DDNLFK(M,N,WORK)
      DO 103 I = 1,LATE
          CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
          P0N(1,I) = PB
  103 CONTINUE
c     compute p0n,p1n for all theta(i) when n.gt.0
      DO 104 NP1 = 2,NLAT
          N = NP1 - 1
          M = 0
          CALL DDNLFK(M,N,WORK)
          DO 105 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P0N(NP1,I) = PB
  105     CONTINUE
c     compute m=1 legendre polynomials for all n and theta(i)
          M = 1
          CALL DDNLFK(M,N,WORK)
          DO 106 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P1N(NP1,I) = PB
  106     CONTINUE
  104 CONTINUE
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      DO 107 N = 2,NLAT
          FN = DBLE(N)
          MLIM = MIN0(N,L)
          DO 107 M = 2,MLIM
              FM = DBLE(M)
              IMN = INDX(M,N)
              IF (N.GE.L) IMN = IMNDX(M,N)
              ABEL(IMN) = DSQRT(((2*FN+1)* (FM+FN-2)* (FM+FN-3))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              BBEL(IMN) = DSQRT(((2*FN+1)* (FN-FM-1)* (FN-FM))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              CBEL(IMN) = DSQRT(((FN-FM+1)* (FN-FM+2))/
     +                    (((FN+FM-1)* (FN+FM))))
  107 CONTINUE
      RETURN
      END


      subroutine compute_ptheta(ctfm,ctfmp,n_Athth,n_beta,n_divbeta,x,Nx
     &,hx,myzero,vee,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 vee
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_Athth(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = 0.5000000000000000D0 / ctfmp(i) * (-0.1D1 * n_Athth(i - 1) +
     #n_Athth(i + 1)) / hx * n_beta(i) + 0.2D1 / ctfm(i) * n_Athth(i) *
     #n_beta(i) - 0.6666666666666667D0 * n_Athth(i) * vee * n_divbeta(i)
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END


      subroutine ire_eqrpsi(n_a1,n_alpha,n_beta,n_rPHI,n_rPI,nm1_rpsi,np
     &1_rpsi,Nx,ht,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_rPHI(Nx)
      real*8 n_rPI(Nx)
      real*8 nm1_rpsi(Nx)
      real*8 np1_rpsi(Nx)
      real*8 res
      real*8 qb
      res = 0.0D0
      do i=1, Nx, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_rpsi(i) + np1_rpsi(i)) /
     # ht - 0.1D1 * n_alpha(i) / n_a1(i) * n_rPI(i) - 0.1D1 * n_beta(i)
     #* n_rPHI(i)
      res = res + qb**2
      end do
      res = sqrt(res/(1*Nx))
      END


module module1
  implicit none
contains
  real function calc_it(x,y)
    real , intent(in):: x,y
    calc_it = sqrt(x**2 + y**2)
  end function calc_it
end module module1


!----------------------------------------------------------------------
! Subroutine: handy_step
!> Purpose: HANDY integration step
!>

!> Author: Benjamin Menetrier
!>

!> Licensing: this code is distributed under Apache License 2.0
!----------------------------------------------------------------------
subroutine handy_step(state_in,par,state_out)

use handy_mod
implicit none

! Passed variables
type(statetype),intent(in) :: state_in
type(partype),intent(in) :: par
type(statetype),intent(inout) :: state_out

! Local variables
real :: wth,omega,cc,ce,alphac,alphae

! Diagnostics
wth = par%rho*state_in%xc + par%kappa*par%rho*state_in%xe
if (abs(wth)>0.0) then
   omega = state_in%w/wth
else
   omega = huge(1.0)
end if
cc = min(1.0,omega)*par%s*state_in%xc
ce = min(1.0,omega)*par%kappa*par%s*state_in%xe
if (abs(par%s*state_in%xc)>0.0) then
   alphac = par%alpham + max(0.0,1.0-cc/(par%s*state_in%xc))*(par%alphamax - par%alpham)
else
   alphac = 0.0
endif
if (abs(par%s*state_in%xe)>0.0) then
   alphae = par%alpham + max(0.0,1.0-ce/(par%s*state_in%xe))*(par%alphamax - par%alpham)
else
   alphae = 0.0
end if

! Variables
state_out%xc = par%betac*state_in%xc - alphac*state_in%xc
state_out%xe = par%betae*state_in%xe - alphae*state_in%xe
if (par%nature_switch) then
   state_out%y = par%gamma*state_in%y*(par%lambda - state_in%y) - par%delta*state_in%xc*state_in%y
else
   state_out%y = -par%delta*state_in%xc*state_in%y
end if
state_out%w = par%delta*state_in%xc*state_in%y - cc - ce

end subroutine handy_step


module xc_mod
   use ISO_C_BINDING
   implicit none

contains

   !
   ! Calculates XC LDA density and potential from the charge density "n".
   !
   subroutine getvxc_scalar(n, relat, c_light, exc, Vxc) bind(C)
      real(c_double), intent(in) :: n ! charge density (scalar)
      real(c_double), intent(in) :: c_light ! speed of light
      logical(c_bool), intent(in) :: relat ! if .true. returns RLDA, otherwise LDA
      real(c_double), intent(out) :: exc ! XC density
      real(c_double), intent(out) :: Vxc ! XC potential

      real(c_double), parameter :: y0 = -0.10498_8
      real(c_double), parameter :: b = 3.72744_8
      real(c_double), parameter :: c = 12.9352_8
      real(c_double), parameter :: A = 0.0621814_8
      real(c_double), parameter :: pi = 3.1415926535897932384626433832795_8

      !     c = 137.0359895

      real(8) :: Q, rs, y, ec, ex, Vc, Vx, beta, mu, R, S

      if (n < epsilon(1.0_8)) then
         exc = 0
         Vxc = 0
         return
      end if

      Q = sqrt(4 * c - b**2)
      rs = (3 / (4 * pi * n))**(1.0_8 / 3)
      y = sqrt(rs)
      ec = A / 2 * (log(y**2 / get_Y(y, b, c)) + 2 * b / Q * atan(Q / (2 * y + b))  &
         - b * y0 / get_Y(y0, b, c) * (&
            log((y - y0)**2 / get_Y(y, b, c)) &
               + 2 * (b + 2 * y0) / Q * atan(Q / (2 * y + b)) &
            ))
      Vc = ec - A / 6 * (c * (y - y0) - b * y0 * y) / ((y - y0) * get_Y(y, b, c))
      ex = -3 / (4 * pi) * (3 * pi**2 * n)**(1.0_8 / 3)
      Vx = 4 * ex / 3

      if (relat) then
         beta = -4 * pi * ex / (3 * c_light)
         mu = sqrt(1 + beta**2)
         R = 1 - 3 * ((beta * mu - log(beta + mu)) / (beta ** 2))**2 / 2
         S = 3 * log(beta + mu) / (2 * beta * mu) - 1.0_8 / 2

         ex = ex * R
         Vx = Vx * S
      end if
      exc = ex + ec
      Vxc = Vx + Vc
   end subroutine

   function get_Y(y, b, c)
      real(8), intent(in) :: y, b, c
      real(8) :: get_Y
      get_Y = y**2 + b * y + c
   end function

end module xc_mod


      subroutine vapoprs(sfctmp,sfcprs,q2sat,q2)
      parameter ( T0 = 273.16 )
c
c  estimate the specific humidity, q2 in kg/kg, (Noah refer as the vapor
c  mixing ratio) from air temperature, sfctmp in K deg., and pressure,
c  sfcprs in Pa, q2sat is the saturation mixing ratio
c  First, Popov's empirical relationship (adjusted to SnowMIP2 data) is used
c  to estimate vapor pressure:
c       e2 = 446.02*EXP(0.0579*sfctmp), in Pa
c  Then, it's converted into mixin ratio:
c       q2 = 0.622*e2/(sfcprs-(1-0.622)*e2), in kg/kg
c
c  calculate saturation mixing ratio
cfews      es=esat(sfctmp)
cfews      q2sat=0.622*es/(SFCPRS-(1.-0.622)*es)

c  then estimate actual mixing ratio
      e2 = 446.02*EXP(0.0579*(sfctmp-T0))
      q2 = 0.622*e2/(SFCPRS-(1.-0.622)*e2)
      if(q2 .lt. 0.1E-5) q2=0.1E-5
      if(q2 .ge. q2sat) q2=q2sat*0.99

      return
      end


      subroutine phase2(r,p1,p2,p3,p4,wt,*)
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'x1x2.f'
c---- generate phase space for 2-->2 process
c---- r(mxdim),p1(4),p2(4) are inputs reversed in sign
c---- from physical values
c---- phase space for -p1-p2 --> p3+p4
c---- with all 2 pi's (ie 1/(2*pi)^2)
      double precision r(mxdim)
      double precision p1(4),p2(4),p3(4),p4(4)
      double precision cosphi,sinphi,u,phi,rtshat,costh,sinth
      double precision wt,wt0
      include 'energy.f'
      parameter(wt0=1d0/8d0/pi)
      rtshat=dsqrt(xx(1)*xx(2))*sqrts
C write out vectors in +,-,T,T notation
      u=r(3)
      costh=2d0*u-1d0
      sinth=dsqrt(1d0-costh**2)
      phi=two*pi*r(4)
      sinphi=dsin(phi)
      cosphi=dcos(phi)

      p3(4)=+half*sqrts*(u*xx(1)+(1d0-u)*xx(2))
      p3(1)=+half*sinth*sinphi*rtshat
      p3(2)=+half*sinth*cosphi*rtshat
      p3(3)=+half*sqrts*(u*xx(1)-(1d0-u)*xx(2))

      p4(4)=+half*sqrts*((1d0-u)*xx(1)+u*xx(2))
      p4(1)=-half*sinth*sinphi*rtshat
      p4(2)=-half*sinth*cosphi*rtshat
      p4(3)=+half*sqrts*((1d0-u)*xx(1)-u*xx(2))

c---debug
      write(6,*) 'p3',p3(4),p3(3),p3(2),p3(1)
      write(6,*) 'p4',p4(4),p4(3),p4(2),p4(1)

      p3(4)=+u*p1(4)+(one-u)*p2(4)
      p3(1)=+half*sinth*sinphi*rtshat
      p3(2)=+half*sinth*cosphi*rtshat
      p3(4)=+u*p1(3)+(one-u)*p2(3)

      p4(4)=+(one-u)*p1(4)+u*p2(4)
      p4(1)=-half*sinth*sinphi*rtshat
      p4(2)=-half*sinth*cosphi*rtshat
      p4(3)=+(one-u)*p1(3)+u*p2(3)

      write(6,*) 'p3',p3(4),p3(3),p3(2),p3(1)
      write(6,*) 'p4',p4(4),p4(3),p4(2),p4(1)
c      pause
      wt=wt0

      end


! { dg-do run }
! PR 27662. Don't zero the first stride to indicate a temporary. It
! may be used later.
program pr27662
 implicit none
 real(kind=kind(1.0d0)), dimension (2, 2):: x, y, z;
 integer i, j
 x(1,1) = 1.d0
 x(2,1) = 0.d0
 x(1,2) = 0.d0
 x(2,2) = 1.d0
 z = matmul (x, transpose (test ()))
 do i = 1, size (x, 1)
   do j = 1, size (x, 2)
     if (x (i, j) .ne. z (i, j)) call abort ()
   end do
 end do

contains
 function test () result (res)
   real(kind=kind(1.0d0)), dimension(2,2) :: res
   res(1,1) = 1.d0
   res(2,1) = 0.d0
   res(1,2) = 0.d0
   res(2,2) = 1.d0
 end function
end


! =============================================================================
!                                   Mergesort
!   Sort an array of values in ascending order and return also the
!   re-ordering of the indices (in order to sort other arrays accordingly).
!
!   Implemented according to Ottmann, T. and Widmayer, P., Algorithmen
!   und Datenstrukturen, 4. Auflage, 2002, Spektrum Akademischer Verlag
! =============================================================================
module merge_sort
    implicit none

    private :: mergesort, merging, imergesort, imerging

    ! 23 August 2021
    ! https://fortran-lang.discourse.group/t/question-about-interfaces-and-submodules/584
    interface msort
        module procedure :: dmsort
        module procedure :: imsort
    end interface

    contains

        ! a  : value array to sort
        ! ai : index array
        subroutine dmsort(a, ai)
            double precision, intent(inout) :: a(:)
            integer, intent(out)            :: ai(:)
            integer                         :: n, m

            m = size(a)

            do n = 1, m
                ai(n) = n
            enddo

            call mergesort(a, ai, 1, m)

        end subroutine dmsort

        recursive subroutine mergesort(a, ai, l, r)
            double precision, intent(inout) :: a(:)
            integer,          intent(inout) :: ai(:)
            integer,          intent(in)    :: l, r
            integer                         :: m

            if (l < r) then
                m = (l + r) / 2

                call mergesort(a, ai, l, m)
                call mergesort(a, ai, m + 1, r)

                call merging(a, ai, l, m, r)
            endif
        end subroutine mergesort

        subroutine merging(a, ai, l, m, r)
            double precision, intent(inout) :: a(:)
            integer,          intent(inout) :: ai(:)
            integer,          intent(in)    :: l, m, r
            double precision                :: b(r)
            integer                         :: bi(r)
            integer                         :: i, j, k, h

            i = l
            j = m + 1
            k = l

            do while ((i <= m) .and. (j <= r))
                if (a(i) <= a(j)) then
                    b(k) = a(i)
                    bi(k) = ai(i)
                    i = i + 1
                else
                    b(k) = a(j)
                    bi(k) = ai(j)
                    j = j + 1
                endif
                k = k + 1
            enddo

            if (i > m) then
                do h = j, r
                    b(k + h - j) = a(h)
                    bi(k + h - j) = ai(h)
                enddo
            else
                do h = i, m
                    b(k + h - i) = a(h)
                    bi(k + h - i) = ai(h)
                enddo
            endif

            do h = l, r
                a(h) = b(h)
                ai(h) = bi(h)
            enddo
        end subroutine merging

        ! a  : value array to sort
        ! ai : index array
        subroutine imsort(a, ai)
            integer, intent(inout) :: a(:)
            integer, intent(out)            :: ai(:)
            integer                         :: n, m

            m = size(a)

            do n = 1, m
                ai(n) = n
            enddo

            call imergesort(a, ai, 1, m)

        end subroutine imsort

        recursive subroutine imergesort(a, ai, l, r)
            integer, intent(inout) :: a(:)
            integer, intent(inout) :: ai(:)
            integer, intent(in)    :: l, r
            integer                :: m

            if (l < r) then
                m = (l + r) / 2

                call imergesort(a, ai, l, m)
                call imergesort(a, ai, m + 1, r)

                call imerging(a, ai, l, m, r)
            endif
        end subroutine imergesort

        subroutine imerging(a, ai, l, m, r)
            integer, intent(inout) :: a(:)
            integer, intent(inout) :: ai(:)
            integer, intent(in)    :: l, m, r
            integer                :: b(r)
            integer                :: bi(r)
            integer                :: i, j, k, h

            i = l
            j = m + 1
            k = l

            do while ((i <= m) .and. (j <= r))
                if (a(i) <= a(j)) then
                    b(k) = a(i)
                    bi(k) = ai(i)
                    i = i + 1
                else
                    b(k) = a(j)
                    bi(k) = ai(j)
                    j = j + 1
                endif
                k = k + 1
            enddo

            if (i > m) then
                do h = j, r
                    b(k + h - j) = a(h)
                    bi(k + h - j) = ai(h)
                enddo
            else
                do h = i, m
                    b(k + h - i) = a(h)
                    bi(k + h - i) = ai(h)
                enddo
            endif

            do h = l, r
                a(h) = b(h)
                ai(h) = bi(h)
            enddo
        end subroutine imerging

end module merge_sort


!! This would generally be supplied by the user

SUBROUTINE  rpn2qad_flux(meqn,maux,idir,iface,q,auxvec, &
                  auxvec_edge,flux)

    IMPLICIT NONE

    INTEGER meqn,maux,idir, iface
    DOUBLE PRECISION q(meqn), flux(meqn)
    DOUBLE PRECISION auxvec(maux), auxvec_edge(maux)

    DOUBLE PRECISION urot, nv(2), u(2)
    INTEGER m

    u(1) = auxvec(2)
    u(2) = auxvec(3)

    nv(1) = auxvec(4+2*iface)
    nv(2) = auxvec(5+2*iface)

    urot = nv(1)*u(1) + nv(2)*u(2)

    DO m = 1,meqn
        !! Don't scale the flux here
        flux(m) = urot*q(m)
    ENDDO

END SUBROUTINE rpn2qad_flux

SUBROUTINE  rpn2qad_zero(meqn,maux, idir, iface, q, &
                         auxvec, auxvec_edge,flux)
    IMPLICIT NONE

    INTEGER meqn,maux,idir, iface
    DOUBLE PRECISION q(meqn), flux(meqn)
    DOUBLE PRECISION auxvec(maux), auxvec_edge(maux)
    INTEGER m

    DO m = 1,meqn
        flux(m) = 0
    END DO

END  SUBROUTINE RPN2QAD_ZERO


      program convolvef

!     Reads in a (short) pulse that is convolved with (longer)
!         waveform.  Lengths are n_p and n_w.  Output (conv)
!         has length n_w + n_p + 1.  delta must be same for both.
!
!     Easiily expanded to read in multiple waveforms.
!
!     If disc_conv is "y", the output is not premultilied by delta
!         and the begin time for the pulse is treated as zero.  The
!         result for "y" is the sae as one gets from SAC convolve.

      implicit none

      integer i,j
!     Define the Maximum length of waveform
      integer MAX
      parameter (MAX=10000)

      real waveform, pulse, ytmp, conv
      dimension waveform(MAX),pulse(MAX),ytmp(MAX),conv(MAX)
      character*16 kevnm

!     Declare Variables used in the rsac1() calls
      real b_w, delta, b_p, factor, b_p_in
      integer n_w, n_p, nmarg, iargc
      character*80 wf_name, p_name, c_name, kname
      character*1 disc_conv
      integer nerr

      nmarg = iargc()
      if (nmarg .eq. 0) then
        write(*,*) 'Usage: convolvef p_name wf_name c_name disc_conv'
        write(*,*) '  where the first three arguments are filenames'
        write(*,*) '  for pulse, waveform, and convolution output.'
        write(*,*) 'If disc_conv is y, it uses a discrete convolution'
        write(*,*) '  and the pulse begin time is set to zero.  This'
        write(*,*) '  reproduces the result one gets for SAC convolve.'
        write(*,*) 'If disc_conv is n, pulse begin time is unchanged'
        write(*,*) '  and the output is multiolied by delta, which is'
        write(*,*) '  what one has in a time-series covolution.'
        stop
      end if
      call getarg(1,p_name)
      call getarg(2,wf_name)
      call getarg(3,c_name)
      call getarg(4,disc_conv)

!   Read in pulse time series
      call rsac1(p_name, pulse, n_p, b_p, delta, MAX, nerr)

      if(nerr .NE. 0) then
         write(*,*)'Error reading in file: ',p_name
         call exit(-1)
      endif

!     Test if want to do a discrete convolution

      factor = delta
      b_p_in = b_p
      if (disc_conv .eq. 'y') then
         factor = 1.0
         b_p_in = 0.0
      endif

!     If wanted to do more than one waveform, do loop starts here

!     Read in waveform time series

      call rsac1(wf_name, waveform, n_w, b_w, delta, MAX, nerr)

      if(nerr .NE. 0) then
         write(*,*)'Error reading in file: ',wf_name
         call exit(-1)
      endif

!     Do the convolution

      call td_conv(waveform,n_w,pulse,n_p,conv,delta,factor,b_p_in)

      call setnhv('npts',n_w+n_p-1,nerr)
      kevnm = 'Convolution'
      call setkhv ('kevnm', kevnm, nerr)

!     Write the SAC file
      call wsac0(c_name, ytmp, conv, nerr)
      if(nerr .NE. 0) then
         write(*,*)'Error writing out file: ',c_name,nerr
         call exit(-1)
      endif

!     If doing more than one waveform, do loop stops here

      call exit(0)

      end program convolvef

      subroutine td_conv(waveform,n_w,pulse,n_p,conv,delta,factor,b_p)
!
!     waveform of length n_w is the time series against which pulse
!         of length n_p is convolved.  Output: conv of length n_w+n_w+1.
!         waveform and pulse are unchanged.
!     If a time-series convolution, b_p is the input value and factor
!         is delta, if a discrete cnovolution, b+p is zero and factor=1.
!     The convoluton is done as an inner product in the time
!         domain.
!     Stops if n_w < n_p.
!
!     Arthur Snoke 2015

      implicit none
      real*4 waveform(*), pulse(*), conv(*)
      real*4 delta,b_p,temp,factor
      integer n_p, n_w, j_1, i, j

      if (n_p .ge. n_w) then
         write(*,*) 'Need more points in waveform than pulse'
         write(*,*) 'n_w and n_p:',n_w, n_p
         stop
      end if

      j_1 = -nint(b_p/delta)+1
      do i=1,n_w+n_p-1
         temp = 0.0
         do j=1,n_w
            if (i.ge.(j-j_1) .and. n_p.ge.(i-j+j_1)) then
               temp = temp + waveform(j)*pulse(i-j+j_1)
            endif
         end do
         conv(i) = factor*temp
      end do
      return
      end


program main

!*****************************************************************************80
!
!! MAIN is the main program for WAVE_MPI.
!
!  Discussion:
!
!    WAVE_MPI solves the wave equation in parallel using MPI.
!
!    Discretize the equation for u(x,t):
!      d^2 u/dt^2 - c^2 * d^2 u/dx^2 = 0  for 0 < x < 1, 0 < t
!    with boundary conditions:
!      u(0,t) = u0(t) = sin ( 2 * pi * ( 0 - c * t ) )
!      u(1,t) = u1(t) = sin ( 2 * pi * ( 1 - c * t ) )
!    and initial conditions:
!         u(x,0) = g(x,t=0) =                sin ( 2 * pi * ( x - c * t ) )
!      dudt(x,0) = h(x,t=0) = - 2 * pi * c * cos ( 2 * pi * ( x - c * t ) )
!
!    by:
!
!      alpha = c * dt / dx.
!
!      U(x,t+dt) = 2 U(x,t) - U(x,t-dt)
!        + alpha^2 ( U(x-dx,t) - 2 U(x,t) + U(x+dx,t) ).
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    17 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Geoffrey Fox, Mark Johnson, Gregory Lyzenga, Steve Otto, John Salmon,
!    David Walker,
!    Solving problems on concurrent processors,
!    Volume 1: General Techniques and Regular Problems,
!    Prentice Hall, 1988,
!    ISBN: 0-13-8230226,
!    LC: QA76.5.F627.
!
!  Local parameters:
!
!    Local, real ( kind = 8 ) DT, the time step.
!
!    Local, integer ( kind = 4 ) ID, the MPI process ID.
!
!    Local, integer ( kind = 4 ) N_GLOBAL, the total number of points.
!
!    Local, integer ( kind = 4 ) N_LOCAL, the number of points visible to
!    this process.
!
!    Local, integer ( kind = 4 ) NSTEPS, the number of time steps.
!
!    Local, integer ( kind = 4 ) P, the number of MPI processes.
!
  use mpi

  implicit none

  real ( kind = 8 ), parameter :: dt = 0.00125
  integer ( kind = 4 ) error
  integer ( kind = 4 ) i_global_hi
  integer ( kind = 4 ) i_global_lo
  integer ( kind = 4 ) id
  integer ( kind = 4 ), parameter :: n_global = 401
! integer ( kind = 4 ), parameter :: n_global = 101
  integer ( kind = 4 ) n_local
  integer ( kind = 4 ), parameter :: nsteps = 4000
! integer ( kind = 4 ), parameter :: nsteps = 2
  integer ( kind = 4 ) p
  real ( kind = 8 ), allocatable :: u1_local(:)
  real ( kind = 8 ) wtime
!
!  Initialize MPI.
!
  call MPI_Init ( error )

  call MPI_Comm_rank ( MPI_COMM_WORLD, id, error )

  call MPI_Comm_size ( MPI_COMM_WORLD, p, error )

  if ( id == 0 ) then
    call timestamp ( )
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'MPI_WAVE:'
    write ( *, '(a)' ) '  FORTRAN90 version.'
    write ( *, '(a)' ) '  Estimate a solution of the wave equation using MPI.'
    write ( *, '(a)' ) ''
    write ( *, '(a,i2,a)' ) '  Using ', p, ' processes.'
    write ( *, '(a,i6,a)' ) '  Using a total of ', n_global, ' points.'
    write ( *, '(a,i6,a,g14.6)' ) '  Using ', nsteps, ' time steps of size ', dt
    write ( *, '(a,g14.6)' ) '  Computing final solution at time ', dt * nsteps
  end if

  wtime = MPI_Wtime ( )
!
!  Determine N_LOCAL
!
  i_global_lo = (   id       * ( n_global - 1 ) ) / p
  i_global_hi = ( ( id + 1 ) * ( n_global - 1 ) ) / p
  if ( 0 < id ) then
    i_global_lo = i_global_lo - 1
  end if

  n_local = i_global_hi + 1 - i_global_lo
  allocate ( u1_local(1:n_local) )
!
!  Update N_LOCAL values.
!
  call update ( id, p, n_global, n_local, nsteps, dt, u1_local )
!
!  Collect local values into global array.
!
  call collect ( id, p, n_global, n_local, nsteps, dt, u1_local )
!
!  Report elapsed wallclock time.
!
  wtime = MPI_Wtime ( ) - wtime

  if ( id == 0 ) then
    write ( *, '(a)' ) ''
    write ( *, '(a,g14.6,a)' ) &
      '  Elapsed wallclock time was ', wtime, ' seconds.'
  end if
!
!  Terminate MPI.
!
  call MPI_Finalize ( error )
!
!  Free memory.
!
  deallocate ( u1_local )
!
!  Terminate.
!
  if ( id == 0 ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'WAVE_MPI:'
    write ( *, '(a)' ) '  Normal end of execution.'
    write ( *, '(a)' ) ''
    call timestamp ( )
  end if

  stop
end
subroutine update ( id, p, n_global, n_local, nsteps, dt, u1_local )

!*****************************************************************************80
!
!! UPDATE advances the solution a given number of time steps.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    17 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) ID, the identifier of this process.
!
!    Input, integer ( kind = 4 ) P, the number of processes.
!
!    Input, integer ( kind = 4 ) N_GLOBAL, the total number of points.
!
!    Input, integer ( kind = 4 ) N_LOCAL, the number of points visible to
!    this process.
!
!    Input, integer ( kind = 4 ) NSTEPS, the number of time steps.
!
!    Input, real ( kind = 8 ) DT, the size of the time step.
!
!    Output, real ( kind = 8 ) U1_LOCAL(N_LOCAL), the portion of the solution
!    at the last time, as evaluated by this process.
!
  use mpi

  implicit none

  integer ( kind = 4 ) n_local

  real ( kind = 8 ) alpha
  real ( kind = 8 ) c
  real ( kind = 8 ) dt
  real ( kind = 8 ) dudt
  real ( kind = 8 ) dx
  integer ( kind = 4 ) error
  real ( kind = 8 ) exact
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i_global
  integer ( kind = 4 ) i_global_hi
  integer ( kind = 4 ) i_global_lo
  integer ( kind = 4 ) i_local
  integer ( kind = 4 ) i_local_hi
  integer ( kind = 4 ) i_local_lo
  integer ( kind = 4 ) id
  integer ( kind = 4 ) j
  integer ( kind = 4 ), parameter :: ltor = 20
  integer ( kind = 4 ) n_global
  integer ( kind = 4 ) nsteps
  integer ( kind = 4 ) p
  integer ( kind = 4 ), parameter :: rtol = 10
  integer ( kind = 4 ) status(MPI_STATUS_SIZE)
  real ( kind = 8 ) t
  real ( kind = 8 ) u0_local(n_local)
  real ( kind = 8 ) u1_local(n_local)
  real ( kind = 8 ) u2_local(n_local)
  real ( kind = 8 ) x
!
!  Determine the value of ALPHA.
!
  c = 1.0D+00
  dx = 1.0D+00 / real ( n_global - 1, kind = 8 )
  alpha = c * dt / dx

  if ( 1.0D+00 <= abs ( alpha ) ) then

    if ( id == 0 ) then
      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'UPDATE - Warning!'
      write ( *, '(a)' ) '  1 <= |ALPHA| = | C * dT / dX |.'
      write ( *, '(a,g14.6)' ) '  C = ', c
      write ( *, '(a,g14.6)' ) '  dT = ', dt
      write ( *, '(a,g14.6)' ) '  dX = ', dx
      write ( *, '(a,g14.6)' ) '  ALPHA = ', alpha
      write ( *, '(a)' ) '  Computation will not be stable!'
    end if

    call MPI_Finalize ( error )
    stop 1

  end if
!
!  The global array of N_GLOBAL points must be divided up among the processes.
!  Each process stores about 1/P of the total + 2 extra slots.
!
  i_global_lo = (   id       * ( n_global - 1 ) ) / p
  i_global_hi = ( ( id + 1 ) * ( n_global - 1 ) ) / p
  if ( 0 < id ) then
    i_global_lo = i_global_lo - 1
  end if

  i_local_lo = 0
  i_local_hi = i_global_hi - i_global_lo

  t = 0.0D+00
  do i_global = i_global_lo, i_global_hi
    x = real ( i_global, kind = 8 ) / real ( n_global - 1, kind = 8 )
    i_local = i_global - i_global_lo
    u1_local(i_local+1) = exact ( x, t )
  end do

  do i_local = i_local_lo, i_local_hi
    u0_local(i_local+1) = u1_local(i_local+1)
  end do
!
!  Take NSTEPS time steps.
!
  do i = 1, nsteps

    t = dt * real ( i, kind = 8 )
!
!  For the first time step, we need to use the initial derivative information.
!
    if ( i == 1 ) then

      do i_local = i_local_lo + 1, i_local_hi - 1
        i_global = i_global_lo + i_local
        x = real ( i_global, kind = 8 ) / real ( n_global - 1, kind = 8 )
        u2_local(i_local+1) = &
          +         0.5D+00 * alpha * alpha   * u1_local(i_local-1+1) &
          + ( 1.0D+00 -       alpha * alpha ) * u1_local(i_local+0+1)   &
          +         0.5D+00 * alpha * alpha   * u1_local(i_local+1+1) &
          +                                dt * dudt ( x, t )
      end do
!
!  After the first time step, we can use the previous two solution estimates.
!
    else

      do i_local = i_local_lo + 1, i_local_hi - 1
        u2_local(i_local+1) = &
          +               alpha * alpha   * u1_local(i_local-1+1) &
          + 2.0 * ( 1.0 - alpha * alpha ) * u1_local(i_local+0+1)   &
          +               alpha * alpha   * u1_local(i_local+1+1) &
          -                                 u0_local(i_local+0+1)
      end do

    end if
!
!  Exchange data with "left-hand" neighbor.
!
    if ( 0 < id ) then
      call MPI_Send ( u2_local(i_local_lo+2), 1, MPI_DOUBLE_PRECISION, &
        id - 1, rtol, MPI_COMM_WORLD, error )
      call MPI_Recv ( u2_local(i_local_lo+1), 1, MPI_DOUBLE_PRECISION, &
        id - 1, ltor, MPI_COMM_WORLD, status, error )
    else
      x = 0.0D+00
      u2_local(i_local_lo+1) = exact ( x, t )
    end if
!
!  Exchange data with "right-hand" neighbor.
!
    if ( id < p - 1 ) then
      call MPI_Send ( u2_local(i_local_hi), 1, MPI_DOUBLE_PRECISION, id + 1, &
        ltor, MPI_COMM_WORLD, error )
      call MPI_Recv ( u2_local(i_local_hi+1),   1, MPI_DOUBLE_PRECISION, &
        id + 1, rtol, MPI_COMM_WORLD, status, error )
    else
      x = 1.0D+00
      u2_local(i_local_hi+1) = exact ( x, t )
    end if
!
!  Shift data for next time step.
!
    do i_local = i_local_lo, i_local_hi
      u0_local(i_local+1) = u1_local(i_local+1)
      u1_local(i_local+1) = u2_local(i_local+1)
    end do

  end do

  return
end
subroutine collect ( id, p, n_global, n_local, nsteps, dt, u_local )

!*****************************************************************************80
!
!! COLLECT has workers send results to the master, which prints them.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    17 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) ID, the identifier of this process.
!
!    Input, integer ( kind = 4 ) P, the number of processes.
!
!    Input, integer ( kind = 4 ) N_GLOBAL, the total number of points.
!
!    Input, integer ( kind = 4 ) N_LOCAL, the number of points visible
!    to this process.
!
!    Input, integer ( kind = 4 ) NSTEPS, the number of time steps.
!
!    Input, real ( kind = 8 ) DT, the size of the time step.
!
!    Input, real ( kind = 8 ) U_LOCAL(N_LOCAL), the final solution estimate
!    computed by this process.
!
  use mpi

  implicit none

  integer ( kind = 4 ) n_global
  integer ( kind = 4 ) n_local

  integer ( kind = 4 ) buffer(2)
  integer ( kind = 4 ), parameter :: collect1 = 10
  integer ( kind = 4 ), parameter :: collect2 = 20
  real ( kind = 8 ) dt
  integer ( kind = 4 ) error
  real ( kind = 8 ) exact
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i_global
  integer ( kind = 4 ) i_global_hi
  integer ( kind = 4 ) i_global_lo
  integer ( kind = 4 ) i_local
  integer ( kind = 4 ) i_local_hi
  integer ( kind = 4 ) i_local_lo
  integer ( kind = 4 ) id
  integer ( kind = 4 ) j
  integer ( kind = 4 ) n_local2
  integer ( kind = 4 ) nsteps
  integer ( kind = 4 ) p
  integer ( kind = 4 ) status(MPI_STATUS_SIZE)
  real ( kind = 8 ) t
  real ( kind = 8 ), allocatable :: u_global(:)
  real ( kind = 8 ) u_local(n_local)
  real ( kind = 8 ) x

  i_global_lo = (   id       * ( n_global - 1 ) ) / p
  i_global_hi = ( ( id + 1 ) * ( n_global - 1 ) ) / p
  if ( 0 < id ) then
    i_global_lo = i_global_lo - 1
  end if

  i_local_lo = 0
  i_local_hi = i_global_hi - i_global_lo
!
!  Master collects worker results into the U_GLOBAL array.
!
  if ( id == 0 ) then
!
!  Create the global array.
!
    allocate ( u_global(1:n_global) )
!
!  Copy the master's results into the global array.
!
    do i_local = i_local_lo, i_local_hi
      i_global = i_global_lo + i_local - i_local_lo
      u_global(i_global+1) = u_local(i_local+1)
    end do
!
!  Contact each worker.
!
    do i = 1, p - 1
!
!  Message "collect1" contains the global index and number of values.
!
      call MPI_Recv ( buffer, 2, MPI_INTEGER, i, collect1, MPI_COMM_WORLD, &
        status, error )

      i_global_lo = buffer(1)
      n_local2 = buffer(2)

      if ( i_global_lo < 0 ) then
        write ( *, '(a,i6)' ) '  Illegal I_GLOBAL_LO = ', i_global_lo
        call MPI_Finalize ( error )
        stop 1
      else if ( n_global <= i_global_lo + n_local2 - 1 ) then
        write ( *, '(a,i6)' ) '  Illegal I_GLOBAL_LO + N_LOCAL = ', &
          i_global_lo + n_local2
        call MPI_Finalize ( error )
        stop 1
      end if
!
!  Message "collect2" contains the values.
!
      call MPI_Recv ( u_global(i_global_lo+1), n_local2, MPI_DOUBLE_PRECISION, &
        i, collect2, MPI_COMM_WORLD, status, error )

    end do
!
!  Print the results.
!
    t = dt * real ( nsteps, kind = 8 )
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) '    I      X     F(X)   Exact'
    write ( *, '(a)' ) ''
    do i_global = 0, n_global - 1
      x = real ( i_global, kind = 8 ) / real ( n_global - 1, kind = 8 )
      write ( *, '(2x,i3,2x,f6.3,2x,f6.3,2x,f6.3)' ) &
        i_global, x, u_global(i_global+1), exact ( x, t )
    end do

    deallocate ( u_global )
!
!  Workers send results to process 0.
!
  else
!
!  Message "collect1" contains the global index and number of values.
!
    buffer(1) = i_global_lo
    buffer(2) = n_local
    call MPI_Send ( buffer, 2, MPI_INTEGER, 0, collect1, MPI_COMM_WORLD, error )
!
!  Message "collect2" contains the values.
!
    call MPI_Send ( u_local, n_local, MPI_DOUBLE_PRECISION, 0, collect2, &
      MPI_COMM_WORLD, error )

  end if

  return
end
function exact ( x, t )

!*****************************************************************************80
!
!! EXACT evaluates the exact solution
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    17 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) X, the location.
!
!    Input, real ( kind = 8 ) T, the time.
!
!    Output, real ( kind = 8 ) EXACT, the value of the exact solution.
!
  implicit none

  real ( kind = 8 ), parameter :: c = 1.0D+00
  real ( kind = 8 ) exact
  real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00
  real ( kind = 8 ) t
  real ( kind = 8 ) x

  exact = sin ( 2.0D+00 * pi * ( x - c * t ) )

  return
end
function dudt ( x, t )

!*****************************************************************************80
!
!! DUDT evaluates the partial derivative dudt.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    17 November 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) X, the location.
!
!    Input, real ( kind = 8 ) T, the time.
!
!    Output, real ( kind = 8 ) DUDT, the value of the time derivative of
!    the solution.
!
  implicit none

  real ( kind = 8 ), parameter :: c = 1.0D+00
  real ( kind = 8 ) dudt
  real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00
  real ( kind = 8 ) t
  real ( kind = 8 ) x

  dudt = - 2.0D+00 * pi * c * cos ( 2.0D+00 * pi * ( x - c * t ) )

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


  x_cp = x
  size_x = SIZE(x_cp)
  CALL c_sort(x_cp,size_x)
  IF (MOD(size_x,2) == 0) THEN
     res = (x_cp(size_x / 2) + x_cp(size_x / 2 + 1)) / REAL(2,prec)
  ELSE
     res = x_cp(size_x / 2 + 1)
  END IF


subroutine unsteady_functions(ap_zero, u, v, f_uvel, f_vvel, aw, ae, as, an, p_uf, p_vf, su, sv, fu, fv, rho, dx, dy, imax, jmax, xi, xf)
use parameters
use kind_parameters
implicit none

integer, intent(in):: imax, jmax, xi, xf
real(kind=dp), intent(in), dimension(imax, xi-1:xf+1):: u, v, rho, aw, ae, as, an
real(kind=dp), intent(inout), dimension(imax, xi-1:xf+1):: su, sv, ap_zero, fu, fv
real(kind=dp), intent(in) :: dx(imax), dy(jmax)
real(kind=dp), dimension(imax, xi-1:xf+1):: f_uvel, f_vvel
real(kind=dp), dimension(imax-1, xi-1:xf+1):: p_uf
real(kind=dp), dimension(imax, xi-1:xf+1):: p_vf
integer:: iu, ju, iv, jv

do ju = xi,xf

    do iu = 2,imax-1

    f_uvel(iu,ju) = (-(aw(iu,ju)+ae(iu,ju)+as(iu,ju)+an(iu,ju))*u(iu,ju)+aw(iu,ju)*u(iu-1,ju)+ae(iu,ju)*u(iu+1,ju)+as(iu,ju)*u(iu,ju-1)+an(iu,ju)*u(iu,ju+1)+dy(ju)*(p_uf(iu-1,ju)-p_uf(iu,ju)) + fu(iu,ju))/(rho(iu,ju)*dy(ju)*dx(iu))

    end do

end do

do jv = xi,xf

    do iv = 2,imax-1

     f_vvel(iv,jv) = (-(aw(iv,jv)+ae(iv,jv)+as(iv,jv)+an(iv,jv))*v(iv,jv)+aw(iv,jv)*v(iv-1,jv)+ae(iv,jv)*v(iv+1,jv)+an(iv,jv)*v(iv,jv+1)+as(iv,jv)*v(iv,jv-1)+dx(iv)*(p_vf(iv,jv-1)-p_vf(iv,jv)) + fv(iv,jv))/(rho(iv,jv)*dx(iv)*dy(jv))

    end do

end do

call exchange_data(f_uvel, imax, xi, xf)
call exchange_data(f_vvel, imax, xi, xf)

do ju = xi,xf

 do iu = 2,imax-1

  ap_zero(iu,ju) = rho(iu,ju)*dx(iu)*dy(ju)/(time_step*A22)

 end do

end do

call exchange_data(ap_zero, imax, xi, xf)

end subroutine