module type_ShallowWaterSolver

    use spherepack, only: &
        wp, & ! working precision
        ip, & ! integer precision
        PI, &
        Regularsphere

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: ShallowWaterSolver

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: HALF = 0.5_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp

    type, extends(RegularSphere), public :: ShallowWaterSolver
    contains
        ! Type-bound procedures
        procedure         :: spec_to_grid
        procedure         :: grid_to_spec
        procedure         :: get_vrtdivspec
        procedure         :: get_uv
        procedure, nopass :: atanxy
        procedure, nopass :: get_initial_velocity
        procedure, nopass :: sine_transform
        procedure, nopass :: cosine_transform
    end type ShallowWaterSolver

contains

    ! Purpose:
    !
    ! Computes the initial unrotated longitudinal velocity
    ! See: section 3.3
    pure function get_initial_velocity(amp, thetad) result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: amp
        real(wp), intent(in) :: thetad
        real(wp)             :: return_value

        ! Local variables
        real(wp)            :: thetab, thetae, xe, x

        thetab = -PI/6
        thetae = PI/2
        xe = 3.0e-1_wp

        x = xe*(thetad-thetab)/(thetae-thetab)

        return_value = ZERO

        if (x <= ZERO .or. x >= xe) return

        return_value = amp*exp(-ONE /x-ONE/(xe-x)+4.0_wp/xe)

    end function get_initial_velocity

    pure function atanxy(x, y) &
        result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: x
        real(wp), intent(in) :: y
        real(wp)             :: return_value

        return_value = ZERO

        if (x == ZERO .and. y == ZERO) return

        return_value = atan2(y, x)

    end function atanxy

    subroutine sine_transform(x)

        ! Dummy arguments
        real(wp), intent(inout) :: x(:)

        ! Local variables
        integer(ip) :: i, j
        real(wp)    :: arg

        associate (n => size(x))

            arg = PI/(n+1)

            block
                real(wp) :: w(n)

                do j=1, n
                    w(j) = ZERO
                    do i=1, n
                        w(j) = w(j)+x(i)*sin(real(i*j, kind=wp)*arg)
                    end do
                end do

                x = TWO * w
            end block
        end associate

    end subroutine sine_transform

    pure function cosine_transform(theta, cf) &
        result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: theta
        real(wp), intent(in) :: cf(:)
        real(wp)             :: return_value

        ! Local variables
        integer(ip) ::  i

        return_value = ZERO

        do i=1, size(cf)
            return_value = return_value+cf(i)*cos(real(i, kind=wp)*theta)
        end do

    end function cosine_transform

    ! Purpose:
    !
    ! Converts complex spectral coefficients (dataspec) to
    ! gridded data array (datagrid).
    subroutine grid_to_spec(self, datagrid, dataspec)

        ! Dummy arguments
        class(ShallowWaterSolver), intent(inout)  :: self
        real(wp),                  intent(in)     :: datagrid(:, :)
        complex(wp),               intent(out)    :: dataspec(:)

        ! Local variables
        integer(ip) :: n, m

        associate (&
            nlat => size(datagrid, dim=2), &
            nlon => size(datagrid, dim=1)  &
           )
            block
                real(wp) :: temp(nlat, nlon)

                !  Transpose data
                temp = transpose(datagrid)

                !  spherical harmonic analysis
                call self%perform_scalar_analysis(temp)

                associate (&
                    ntrunc => self%TRIANGULAR_TRUNCATION_LIMIT, &
                    a => self%workspace%scalar_coefficients%real_component, &
                    b => self%workspace%scalar_coefficients%imaginary_component &
                   )

                    !  Fill complex array dataspec with result.
                    dataspec = HALF * cmplx( &
                        [((a(m, n), n=m, ntrunc+1), m=1, ntrunc+1)], &
                        [((b(m, n), n=m, ntrunc+1), m=1, ntrunc+1)], &
                        kind=wp)

                    !  Reset constants
                    a = ZERO
                    b = ZERO
                end associate
            end block
        end associate

    end subroutine grid_to_spec

    ! Purpose:
    !
    ! Converts complex spectral coefficients (dataspec) to
    ! gridded data array (datagrid).
    !
    subroutine spec_to_grid(self, dataspec, datagrid)

        ! Dummy arguments
        class(ShallowWaterSolver), intent(inout)  :: self
        real(wp),                  intent(inout)  :: datagrid(:, :)
        complex(wp),               intent(in)     :: dataspec(:)

        ! Local variables
        integer(ip) :: n, m, nm

        associate (&
            nlat => size(datagrid, dim=2), &
            nlon => size(datagrid, dim=1)  &
           )
            block
                real(wp) :: temp(nlat, nlon)

                !  fill two real arrays (a, b) with contents of dataspec.
                associate (&
                    indxn => self%INDEX_DEGREE_N, &
                    indxm => self%INDEX_ORDER_M, &
                    a => self%workspace%scalar_coefficients%real_component, &
                    b => self%workspace%scalar_coefficients%imaginary_component &
                   )

                    a = ZERO
                    b = ZERO
                    do nm=1, size(dataspec)
                        n = indxn(nm) ! Set degree n
                        m = indxm(nm) ! Set order m
                        a(m + 1, n + 1) = TWO * real(dataspec(nm))
                        b(m + 1, n + 1) = TWO * aimag(dataspec(nm))
                    end do

                    !  Perform spherical harmonic synthesis
                    call self%perform_scalar_synthesis(temp)

                    !  Reset coefficients
                    a = ZERO
                    b = ZERO
                end associate

                !  Transpose data
                datagrid = transpose(temp)
            end block
        end associate

    end subroutine spec_to_grid

    ! Purpose:
    !
    ! Calculate spectral coefficients of vorticity and divergence
    ! (vrtspec, divspec) given input gridded winds (ugrid, vgrid).
    !
    subroutine get_vrtdivspec(self, ugrid, vgrid, vrtspec, divspec)

        ! Dummy arguments
        class(ShallowWaterSolver), intent(inout)  :: self
        real(wp),                  intent(in)     :: ugrid(:, :)
        real(wp),                  intent(in)     :: vgrid(:, :)
        complex(wp),               intent(out)    :: vrtspec(:)
        complex(wp),               intent(out)    :: divspec(:)

        ! Local variables
        real(wp)    :: fn
        integer(ip) :: n, m ! Counters

        associate (&
            nlat => size(ugrid, dim=2), &
            nlon => size(ugrid, dim=1)  &
           )
            block
                real(wp) :: v(nlat, nlon)
                real(wp) :: w(nlat, nlon)
                real(wp) :: sqnn(nlat)

                !  Transpose data.
                !  minus sign to account for difference between
                !  mathematical and geophysical spherical coords
                v = -transpose(vgrid)
                w = transpose(ugrid)

                !  Calculate vector spherical harmonic analysis.
                call self%vector_analysis_from_spherical_components(v, w)

                !  Multiply vector harmonic coefficients of winds by
                !  appropriate factors to convert into vorticity and
                !  divergence coefficients.
                associate (&
                    ntrunc => self%TRIANGULAR_TRUNCATION_LIMIT, &
                    nlat => self%NUMBER_OF_LATITUDES, &
                    rsphere => self%RADIUS_OF_SPHERE, &
                    a => self%workspace%scalar_coefficients%real_component, &
                    b => self%workspace%scalar_coefficients%imaginary_component, &
                    br => self%workspace%vector_coefficients%polar%real_component, &
                    bi => self%workspace%vector_coefficients%polar%imaginary_component, &
                    cr => self%workspace%vector_coefficients%azimuthal%real_component, &
                    ci => self%workspace%vector_coefficients%azimuthal%imaginary_component &
                   )

                    do n=1, nlat
                        fn = real(n - 1, kind=wp)
                        sqnn(n) = sqrt(fn * (fn + ONE))
                    end do

                    a = ZERO
                    b = ZERO
                    do n=1, nlat
                        a(:, n) = -(sqnn(n)/rsphere)*br(:, n)
                        b(:, n) = -(sqnn(n)/rsphere)*bi(:, n)
                    end do

                    divspec = HALF * cmplx( &
                        [((a(m, n), n=m, ntrunc+1), m=1, ntrunc+1)], &
                        [((b(m, n), n=m, ntrunc+1), m=1, ntrunc+1)], &
                        kind=wp)

                    a = ZERO
                    b = ZERO
                    do n=1, nlat
                        a(:, n) = (sqnn(n)/rsphere)*cr(:, n)
                        b(:, n) = (sqnn(n)/rsphere)*ci(:, n)
                    end do

                    vrtspec = HALF * cmplx( &
                        [((a(m, n), n=m, ntrunc+1), m=1, ntrunc+1)], &
                        [((b(m, n), n=m, ntrunc+1), m=1, ntrunc+1)], &
                        kind=wp)

                    !  Reset coefficients
                    a = ZERO
                    b = ZERO
                    br = ZERO
                    bi = ZERO
                    cr = ZERO
                    ci = ZERO
                end associate
            end block
        end associate

    end subroutine get_vrtdivspec

    ! Purpose:
    !
    ! Given spectral coefficients of vorticity and divergence
    ! (vrtspec, divspec) compute gridded winds (ugrid, vgrid)
    !
    subroutine get_uv(self, vrtspec, divspec, ugrid, vgrid)

        ! Dummy arguments
        class(ShallowWaterSolver), intent(inout) :: self
        complex(wp),               intent(in)    :: vrtspec(:)
        complex(wp),               intent(in)    :: divspec(:)
        real(wp),                  intent(out)   :: ugrid(:, :)
        real(wp),                  intent(out)   :: vgrid(:, :)

        ! Local variables
        real(wp)    :: fn
        integer(ip) :: n, m, nm ! Counters

        associate (&
            nlat => size(ugrid, dim=2), &
            nlon => size(ugrid, dim=1) &
           )
            block
                real(wp) :: v(nlat, nlon)
                real(wp) :: w(nlat, nlon)
                real(wp) :: isqnn(nlat)

                ! Multiply spectral coefficients of vorticity and divergence
                ! by appropriate factors to convert them into vector harmonic
                ! coefficients of winds.
                associate (&
                    indxn => self%INDEX_DEGREE_N, &
                    indxm => self%INDEX_ORDER_M, &
                    nlat => self%NUMBER_OF_LATITUDES, &
                    rsphere => self%RADIUS_OF_SPHERE, &
                    a => self%workspace%scalar_coefficients%real_component, &
                    b => self%workspace%scalar_coefficients%imaginary_component, &
                    br => self%workspace%vector_coefficients%polar%real_component, &
                    bi => self%workspace%vector_coefficients%polar%imaginary_component, &
                    cr => self%workspace%vector_coefficients%azimuthal%real_component, &
                    ci => self%workspace%vector_coefficients%azimuthal%imaginary_component &
                   )

                    isqnn(1) = ZERO
                    do n=2, nlat
                        fn = real(n - 1, kind=wp)
                        isqnn(n) = rsphere/sqrt(fn*(fn+ONE))
                    end do

                    ! Preset real harmonic coefficients to 0.0
                    a = ZERO
                    b = ZERO

                    ! Preset polar coefficients to 0.0
                    br = ZERO
                    bi = ZERO

                    do nm=1, size(divspec)
                        n = indxn(nm) ! Set degree n
                        m = indxm(nm) ! Set order m
                        a(m + 1, n + 1) = -TWO * real(divspec(nm))
                        b(m + 1, n + 1) = -TWO * aimag(divspec(nm))
                    end do

                    do n=1, nlat
                        br(:, n) = isqnn(n)*a(:, n)
                        bi(:, n) = isqnn(n)*b(:, n)
                    end do

                    ! Preset azimuthal coefficients to 0.0
                    cr = ZERO
                    ci = ZERO

                    do nm=1, size(divspec)
                        n = indxn(nm) ! Set degree n
                        m = indxm(nm) ! Set order m
                        a(m + 1, n + 1) = TWO * real(vrtspec(nm))
                        b(m + 1, n + 1) = TWO * aimag(vrtspec(nm))
                    end do

                    do n=1, nlat
                        cr(:, n) = isqnn(n)*a(:, n)
                        ci(:, n) = isqnn(n)*b(:, n)
                    end do

                    ! Compute vector harmonic synthesis to get winds on grid.
                    call self%perform_vector_synthesis(v, w)

                    !  Reset coefficients
                    a = ZERO
                    b = ZERO
                    br = ZERO
                    bi = ZERO
                    cr = ZERO
                    ci = ZERO
                end associate

                ! Transpose data
                ! minus sign to account for differences
                ! between mathematical and geophysical spherical coords.
                vgrid = -transpose(v)
                ugrid = transpose(w)
            end block
        end associate

    end subroutine get_uv

end module type_ShallowWaterSolver


!----------------------Subroutine--------------------------------------!
!
      SUBROUTINE POLINT( XA,YA,N,X,Y,DY,IERR )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Given arrays XA and YA, each of length N, and given a value X,
!     this routine returns a value Y, and an error estimate DY.
!     If P(X) is the polynomial of degree N-1 such that
!     P(XA(I)) = YA(I), I = 1,N, then the returned value Y = P(X).
!
!     Press, W.H., B.P. Flannery, S.A. Teukolsky, and W.T. Vetterling.
!     1986.  Numerical Recipes, The Art of Scientific Computing.
!     Cambridge University Press, Cambridge.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, February, 1999.
!     Last Modified by Mark White, Battelle, February 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( NMAX=10, EPSL=1.D-14 )
      REAL*8 XA(N),YA(N),C(NMAX),D(NMAX)
!
!----------------------Executable Lines--------------------------------!
!
      IERR = 0
      NS = 1
      DIF = ABS(X-XA(1))
!
!---  Find the index NS of the closest table entry  ---
!
      DO 11 I = 1,N
        DIFT = ABS(X-XA(I))
        IF( DIFT.LT.DIF ) THEN
          NS = I
          DIF = DIFT
        ENDIF
!
!---  Initialize the tableau fo C's and D's  ---
!
        C(I) = YA(I)
        D(I) = YA(I)
   11 CONTINUE
!
!---  Initial approximation to Y  ---
!
      Y = YA(NS)
      NS = NS-1
!
!---  Loop over the columns in the tableau and
!     update the C's and D's  ---
!
      DO 13 M = 1,N-1
        DO 12 I = 1,N-M
          HO = XA(I)-X
          HP = XA(I+M)-X
          W = C(I+1)-D(I)
          DEN = HO-HP
!
!---  Exit subroutine if two input XA's are identical,
!     within roundoff  ---
!
          IF( ABS( DEN )/EPSL.LT.EPSL ) THEN
            IERR = 1
            RETURN
          ENDIF
          DEN = W/DEN
!
!---  Update C's and D's  ---
!
          D(I) = HP*DEN
          C(I) = HO*DEN
   12   CONTINUE
!
!---  After each column in the tableau is completed,
!     decide which direction C or D to add the accumulating
!     value of Y, (i.e., which path to take
!     through the tableau - forking up or down).
!     Do this in such a way as to take the most "straight line"
!     route through the tableau to its apex, updating NS accordingly
!     to keep track.  This route keeps the partial approximations
!     centered (insofar as possible) on the target X.  The
!     last DY added is thus the error indication.  ---
!
        IF( 2*NS.LT.N-M ) THEN
          DY = C(NS+1)
        ELSE
          DY = D(NS)
          NS = NS-1
        ENDIF
        Y = Y+DY
   13 CONTINUE
!
!---  End of POLINT group
!
      RETURN
      END

!----------------------Subroutine--------------------------------------!
!
      SUBROUTINE QROMB( FUNC,V,A,B,SSX,IERR,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Returns as S the integral of the function FUNC from A to B.
!     Integration is performed by Romberg's method of order 2K, where
!     e.g., K=2 is Simpson's rule.
!
!     Press, W.H., B.P. Flannery, S.A. Teukolsky, and W.T. Vetterling.
!     1986.  Numerical Recipes, The Art of Scientific Computing.
!     Cambridge University Press, Cambridge.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, November 19, 1999.
!     Last Modified by Mark White, Battelle, November 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( EPS=1.D-6, EPSL=1.D-14 )
      PARAMETER( JMAX=20, JMAXP=JMAX+1, K=5, KM=K-1 )
!
!----------------------Type Declarations-------------------------------!
!
      REAL*8 S(JMAXP),H(JMAXP),V(10)
      INTEGER IV(10)
      EXTERNAL FUNC
!
!----------------------Executable Lines--------------------------------!
!
      IERR = 0
      ZERO = 0.D+0
!
!---  S and H store the successive trapezodial approximations and their
!     relative step-sizes.  ---
!
      H(1) = 1.D+0
      DO 10 J = 1,JMAX
        CALL TRAPZD( FUNC,V,A,B,S(J),J,IV )
        IF( J.GE.K ) THEN
          CALL POLINT( H(J-KM),S(J-KM),K,ZERO,SSX,DSS,IERR )
          IF( (ABS(DSS)-EPS*ABS(SSX))/EPSL.LT.EPSL ) RETURN
        ENDIF
        S(J+1) = S(J)
        H(J+1) = 2.5D-1*H(J)
   10 CONTINUE
      IERR = 1
!
!---  End of QROMB group
!
      RETURN
      END

!----------------------Subroutine--------------------------------------!
!
      SUBROUTINE QSIMP( FUNC,V,A,B,S,IERR )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Returns as S the integral of the function FUNC from A to B.
!     Integration is performed by Simpson's rule.
!
!     Press, W.H., B.P. Flannery, S.A. Teukolsky, and W.T. Vetterling.
!     1986.  Numerical Recipes, The Art of Scientific Computing.
!     Cambridge University Press, Cambridge.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, February, 1999.
!     Last Modified by Mark White, Battelle, February 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( EPS=1.D-6, JMAX=20 )
!
!-------------------------Type Statements------------------------------!
!
      EXTERNAL FUNC
      REAL*8 V(10)
      INTEGER IV(10)
!
!----------------------Executable Lines--------------------------------!
!
      OST = 1.D+20
      OS = -1.D+20
      DO 100 J = 1,JMAX
        CALL TRAPZD( FUNC,V,A,B,ST,J,IV )
        S = (4.D+0*ST-OST)/3.D+0
        IF( ABS(S-OS).LT.EPS*ABS(OS)) GOTO 200
        OS = S
        OST = ST
  100 CONTINUE
      IERR = 1
  200 CONTINUE
!
!---  End of QSIMP group
!
      RETURN
      END

!----------------------Subroutine--------------------------------------!
!
      SUBROUTINE TRAPZD( FUNC,V,A,B,S,N,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     This routine computes the N'th stage of refinement of an
!     extended trapezoid rule.
!
!     Press, W.H., B.P. Flannery, S.A. Teukolsky, and W.T. Vetterling.
!     1986.  Numerical Recipes, The Art of Scientific Computing.
!     Cambridge University Press, Cambridge.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, February, 1999.
!     Last Modified by Mark White, Battelle, February 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!-------------------------Type Statements------------------------------!
!
      EXTERNAL FUNC
      REAL*8 V(10)
      INTEGER IV(10)
      SAVE IT
!
!----------------------Executable Lines--------------------------------!
!
      IF( N.EQ.1 ) THEN
        S = 5.D-1*(B-A)*(FUNC(A,V,IV)+FUNC(B,V,IV))
!
!---  IT is the number of points to be added on the next call  ---
!
        IT = 1
      ELSE
        REALX = REAL(IT)
        TNM = REALX
!
!---  Spacing of the points to be added.  ---
!
        DEL = (B-A)/TNM
        X = A + 5.D-1*DEL
        SUM = 0.D+0
        DO 100 J = 1,IT
          SUM = SUM + FUNC(X,V,IV)
          X = X + DEL
  100   CONTINUE
!
!---  Replace S by its refined value  ---
!
        S = 5.D-1*(S+(B-A)*SUM/TNM)
        IT = 2*IT
      ENDIF
!
!---  End of TRAPZD group
!
      RETURN
      END

!----------------------Function----------------------------------------!
!
      FUNCTION ADRM( TMX,V,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Inverse van Genuchten function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, February, 1999.
!     Last Modified by Mark White, Battelle, February 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( SMALL=1.D-20 )
!
!-------------------------Type Statements------------------------------!
!
      REAL*8 V(10)
      INTEGER IV(10)
!
!----------------------Executable Lines--------------------------------!
!
      ADRM = 0.D+0
      FCTX = 1.D+0
      DO 200 N = 1,IV(1)
        REALX = REAL(N-1)
        IF( N.GT.1 ) FCTX = FCTX*REALX
        REALX = REAL(IV(1))
        ADRM = ADRM + ((V(1)*REALX*TMX)**(N-1))/FCTX
  200 CONTINUE
      ADRM = ADRM*V(1)*V(2)*EXP(-V(1)*REALX*TMX)
!
!---  End of ADRM group
!
      RETURN
      END

!----------------------Function----------------------------------------!
!
      FUNCTION HKI( SLX,V,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Inverse Haverkamp function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, PNNL, 17 December 2002.
!     Last Modified by Mark White, PNNL,  17 December 2002.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( EPSL=1.D-14, SMALL=1.D-20 )
!
!-------------------------Type Statements------------------------------!
!
      REAL*8 V(10)
      INTEGER IV(10)
!
!----------------------Executable Lines--------------------------------!
!
      IF( (1.D+0-SLX).LT.EPSL ) THEN
        HKI = V(1)
      ELSE
        HKI = V(1) + V(5)*((V(2)*(1.D+0-SLX)/(SLX+SMALL))**
     &    (1.D+0/V(3)))
      ENDIF
!
!---  End of HKI group
!
      RETURN
      END

!----------------------Function----------------------------------------!
!
      FUNCTION SPLNI( SLX,V,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Inverse cubic-spline or log-cubic-spline tabular function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, PNNL, 17 December 2002.
!     Last Modified by Mark White, PNNL,  17 December 2002.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!-------------------------Type Statements------------------------------!
!
      REAL*8 V(10)
      INTEGER IV(10)
      EXTERNAL FSPLNX
!
!----------------------Executable Lines--------------------------------!
!
        SPLNI = FSPLNX( SLX,IV(1),IV(2) )
!
!---  End of SPLNI group
!
      RETURN
      END

!----------------------Function----------------------------------------!
!
      FUNCTION TBLI( SLX,V,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Inverse linear or log-linear tabular function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, PNNL, 17 December 2002.
!     Last Modified by Mark White, PNNL,  17 December 2002.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!-------------------------Type Statements------------------------------!
!
      REAL*8 V(10)
      INTEGER IV(10)
      EXTERNAL FNTBLX
!
!----------------------Executable Lines--------------------------------!
!
        TBLI = FNTBLX( SLX,IV(1),IV(2),IV(3) )
!
!---  End of TBLI group
!
      RETURN
      END

!----------------------Function----------------------------------------!
!
      FUNCTION VGI( SLX,V,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Inverse van Genuchten function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, February, 1999.
!     Last Modified by Mark White, Battelle, February 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( SMALL=1.D-20 )
!
!-------------------------Type Statements------------------------------!
!
      REAL*8 V(10)
      INTEGER IV(10)
!
!----------------------Executable Lines--------------------------------!
!
      CNX = V(1)
      CMX = V(2)
      VGI = (-1.D+0 + (1.D+0/(SLX+SMALL))**(1.D+0/CMX))**(1.D+0/CNX)
!
!---  End of VGI group
!
      RETURN
      END

!----------------------Function----------------------------------------!
!
      FUNCTION VGTI( SLX,V,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Inverse van Genuchten function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, February, 1999.
!     Last Modified by Mark White, Battelle, February 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( SMALL=1.D-20 )
!
!-------------------------Type Statements------------------------------!
!
      REAL*8 V(10)
      INTEGER IV(10)
!
!----------------------Executable Lines--------------------------------!
!
      CNX = V(1)
      CMX = V(2)
      CRX = V(3)
      VGTI = (-1.D+0 + (1.D+0/(SLX+SMALL))**(1.D+0/CMX))**(1.D+0/CNX)
      VGTI = VGTI*SLX/((-1.D+0 + (-1.D+0 + SLX)*CRX)**2)
!
!---  End of VGTI group
!
      RETURN
      END

!----------------------Function----------------------------------------!
!
      FUNCTION BCI( SLX,V,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Inverse Brooks-Corey function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, February, 1999.
!     Last Modified by Mark White, Battelle, February 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( EPSL=1.D-14 )
!
!-------------------------Type Statements------------------------------!
!
      REAL*8 V(10)
      INTEGER IV(10)
!
!----------------------Executable Lines--------------------------------!
!
      CPX = V(1)
      CLX = V(2)
      IF( (1.D+0-SLX).LT.EPSL ) THEN
        BCI = CPX
      ELSE
        BCI = CPX/(SLX**(1.D+0/CLX))
      ENDIF
!
!---  End of BCI group
!
      RETURN
      END

!----------------------Function----------------------------------------!
!
      FUNCTION BCTI( SLX,V,IV )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Inverse Brooks-Corey function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, February, 1999.
!     Last Modified by Mark White, Battelle, February 19, 1999.
!     $Id: rombint.F 1080 2017-03-14 16:22:02Z d3c002 $
!
!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!
      PARAMETER( EPSL=1.D-14 )
!
!-------------------------Type Statements------------------------------!
!
      REAL*8 V(10)
      INTEGER IV(10)
!
!----------------------Executable Lines--------------------------------!
!
      CPX = V(1)
      CLX = V(2)
      CRX = V(3)
      IF( (1.D+0-SLX).LT.EPSL ) THEN
        BCTI = CPX*SLX/((-1.D+0 + (-1.D+0 + SLX)*CRX)**2)
      ELSE
        BCTI = CPX*SLX/(SLX**(1.D+0/CLX))/
     &    ((-1.D+0 + (-1.D+0 + SLX)*CRX)**2)
      ENDIF
!
!---  End of BCTI group
!
      RETURN
      END


!
!     file tsepx4.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright(c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program test_sepx4

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter      :: M = 32, N = M
    integer(ip), parameter      :: NX = M + 1, NY = N + 1
    integer(ip)                 :: i, j, mbdcnd, nbdcnd, idmn, iorder
    integer(ip)                 :: ierror, ierror2, ierror4
    real(wp), dimension(NX, NY) :: usol, grhs
    real(wp), dimension(NY)     :: bda, bdb
    real(wp)                    :: a, b, c, d, dx, dy, x, af, bf, cf, y
    real(wp)                    :: alpha, beta, dummy_variable(1)
    real(wp)                    :: pertrb, discretization_error
    real(wp)                    :: second_order_error, fourth_order_error
    real(wp), parameter         :: ZERO = 0.0_wp, ONE = 1.0_wp

    ! Set domain
    a = ZERO
    b = ONE
    c = ZERO
    d = ONE

    ! Set mesh size
    dx = (b - a)/M
    dy = (d - c)/N

    do i = 1, NX
        x = a + real(i - 1, kind=wp) * dx

        ! Set specified boundary conditions at y=c, d
        usol(i, 1) = ue(x, c)
        usol(i, NY) = ue(x, d)

        call get_coefficients_in_x_direction(x, af, bf, cf)

        do j = 1, NY
            y = c + real(j - 1, kind=wp)*dy

            ! Set right hand side
            grhs(i, j)=af*uxxe(x, y)+bf*uxe(x, y)+cf*ue(x, y)+uyye(x, y)
        end do
    end do

    ! Set mixed boundary conditions at x=a, b
    alpha = ONE
    beta = ONE
    do j = 1, NY
        y = c + real(j - 1, kind=wp) * dy
        bda(j) = uxe(a, y) + alpha * ue(a, y)
        bdb(j) = uxe(b, y) + beta * ue(b, y)
    end do

    ! Set boundary switches
    mbdcnd = 3
    nbdcnd = 1

    ! Set first dimension of usol, grhs and workspace length
    idmn = size(usol, dim=1)

    ! Obtain 2nd-order approximation
    iorder = 2

    call sepx4(iorder, a, b, M, mbdcnd, bda, alpha, bdb, beta, c, d, &
        N, nbdcnd, dummy_variable, dummy_variable, &
        get_coefficients_in_x_direction, grhs, usol, idmn, pertrb, ierror)

    ! Compute (relative) 2nd-order discretization error
    ! also reset specified boundaries and right hand side.
    discretization_error = ZERO
    do i = 1, NX
        x = a + real(i - 1, kind=wp) * dx
        usol(i, 1) = ue(x, c)
        usol(i, NY) = ue(x, d)
        call get_coefficients_in_x_direction(x, af, bf, cf)
        do j = 1, NY
            y = c + real(j - 1, kind=wp)*dy
            discretization_error = max(discretization_error, abs((usol(i, j)-ue(x, y))/ue(x, y)))

            ! Reset right hand side in grhs for 4th-order approximation call
            grhs(i, j)=af*uxxe(x, y)+bf*uxe(x, y)+cf*ue(x, y)+uyye(x, y)
        end do
    end do

    ! Set 2nd-order results
    second_order_error = discretization_error
    ierror2 = ierror

    ! Obtain 4th-order approximation
    iorder = 4
    call sepx4(iorder, a, b, M, mbdcnd, bda, alpha, bdb, beta, c, d, &
        N, nbdcnd, dummy_variable, dummy_variable, get_coefficients_in_x_direction, &
        grhs, usol, idmn, pertrb, ierror)

    ! Compute (relative) 4th-order discretization error
    discretization_error = ZERO
    do j = 1, NY
        y = c + real(j - 1, kind=wp)*dy
        do i = 1, NX
            x = a + real(i - 1, kind=wp)*dx
            discretization_error = max(discretization_error, abs((usol(i, j)-ue(x, y))/ue(x, y)))
        end do
    end do

    ! Set 4th-order results
    fourth_order_error = discretization_error
    ierror4 = ierror

    block
        real(wp), parameter :: KNOWN_2ND_ORDER_ERROR = 0.159850337215328e-3_wp
        real(wp), parameter :: KNOWN_4TH_ORDER_ERROR = 0.185748791237117e-5_wp

        call check_output('sepx4', &
            ierror2, KNOWN_2ND_ORDER_ERROR, second_order_error, &
            ierror4, KNOWN_4TH_ORDER_ERROR, fourth_order_error)

    end block
contains

    pure function ue(s, t) &
        result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: s
        real(wp), intent(in) :: t
        real(wp)             :: return_value

        return_value =(s*t)**3 + ONE

    end function ue

    pure function uxe(s, t) &
        result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: s
        real(wp), intent(in) :: t
        real(wp)          :: return_value

        ! Local variables
        real(wp), parameter :: THREE = 3.0_wp

        return_value = THREE *(s**2)*(t**3)

    end function uxe

    pure function uxxe(s, t) &
        result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: s
        real(wp), intent(in) :: t
        real(wp)             :: return_value

        ! Local variables
        real(wp), parameter :: SIX = 6.0_wp

        return_value = SIX * s *(t**3)

    end function uxxe

    pure function uyye(s, t) &
        result (return_value)

        ! Dummy arguments
        real(wp), intent(in) :: s
        real(wp), intent(in) :: t
        real(wp)             :: return_value

        ! Local variables
        real(wp), parameter :: SIX = 6.0_wp

        return_value = SIX *(s**3) * t

    end function uyye

    pure subroutine get_coefficients_in_x_direction(x, af, bf, cf)

        ! Dummy arguments
        real(wp), intent(in)  :: x
        real(wp), intent(out) :: af
        real(wp), intent(out) :: bf
        real(wp), intent(out) :: cf

        ! Local variables
        real(wp), parameter :: TWO = 2.0_wp

        !     set coefficients in the x-direction.
        af =(x + ONE)**2
        bf = TWO * (x + ONE)
        cf = -x

    end subroutine get_coefficients_in_x_direction

end program test_sepx4


MODULE Priestlytaylormod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_priestlytaylor(netRadiationEquivalentEvaporation, &
        hslope, &
        psychrometricConstant, &
        Alpha, &
        evapoTranspirationPriestlyTaylor)
        IMPLICIT NONE
        REAL, INTENT(IN) :: netRadiationEquivalentEvaporation
        REAL, INTENT(IN) :: hslope
        REAL, INTENT(IN) :: psychrometricConstant
        REAL, INTENT(IN) :: Alpha
        REAL, INTENT(OUT) :: evapoTranspirationPriestlyTaylor
        !- Description:
    !            * Title: evapoTranspirationPriestlyTaylor  Model
    !            * Author: Pierre Martre
    !            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !            * Institution: INRA Montpellier
    !            * Abstract: Calculate Energy Balance
        !- inputs:
    !            * name: netRadiationEquivalentEvaporation
    !                          ** description : net Radiation in Equivalent Evaporation
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 638.142
    !                          ** min : 0
    !                          ** max : 5000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: hslope
    !                          ** description : the slope of saturated vapor pressure temperature curve at a given temperature
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 0.584
    !                          ** min : 0
    !                          ** max : 1000
    !                          ** unit : hPa °C-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: psychrometricConstant
    !                          ** description : psychrometric constant
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.66
    !                          ** min : 0
    !                          ** max : 1
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: Alpha
    !                          ** description : Priestley-Taylor evapotranspiration proportionality constant
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 1.5
    !                          ** min : 0
    !                          ** max : 100
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
        !- outputs:
    !            * name: evapoTranspirationPriestlyTaylor
    !                          ** description : evapoTranspiration of Priestly Taylor
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        evapoTranspirationPriestlyTaylor = MAX(Alpha * hslope *  &
                netRadiationEquivalentEvaporation / (hslope + psychrometricConstant),  &
                0.0)
    END SUBROUTINE model_priestlytaylor

END MODULE


      subroutine irev_eqipsi(n_a1,n_alpha,n_beta,n_iPHI,n_iPI,nm1_ipsi,n
     &p1_ipsi,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_iPHI(Nx)
      real*8 n_iPI(Nx)
      real*8 nm1_ipsi(Nx)
      real*8 np1_ipsi(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_ipsi(i) + np1_ipsi(i)) /
     # ht - 0.1D1 * n_alpha(i) / n_a1(i) * n_iPI(i) - 0.1D1 * n_beta(i)
     #* n_iPHI(i)
      res(i)=qb
      end do
      END


	SUBROUTINE GMTOWQ ( amtrx, invers, polnr,
     +			    np, rlat, rlon, slat, slon, iret )
C************************************************************************
C* GMTOWQ								*
C* 									*
C* This subroutine converts a location from actual latitude/longitude	*
C* coordinates to latitude and longitude in a rotated coordinate, if	*
C* INVERS = .false.  The inverse transformation is done if INVERS =	*
C* .true.  Actual lat/lon coordinates are M coordinates; the lat/lon	*
C* coordinates in the rotated frame are W coordinates (map) or Q	*
C* coordinates (grid).							*
C*									*
C* This routine performs the transformation needed for the any map/grid *
C* projection.  The rotation matrix is AMTRX.  The rotation matrices	*
C* for map and grid projections are set in the update routines UPD for  *
C* map/grid projections.						*
C*									*
C* The transformation from M -> W/Q proceeds as follows:		*
C*									*
C*   1)  Transform actual lat/lon to cartesian coordinates.		*
C*									*
C*   2)  Rotate the cartesian system three times:			*
C*	 a) Through POLON = ANGLE2 to reposition xy axes 		*
C*	 b) Through POLAT = ANGLE1 to reposition xz axes		*
C*	 c) Through ROTAT = ANGLE3 to reposition yz or xy axes		*
C*									*
C*   3)  Transform from rotated cartesian to spherical W/Q coordinates.	*
C*									*
C* The inverse from W/Q -> M reverses these steps.			*
C*									*
C* The longitude rotation angle is only used for the special case when	*
C* a point falls on a pole in the rotated coordinate.  In that case,	*
C* longitude is indefinite, but for cylindrical projections a definite	*
C* longitude is required when a pole corresponds to a corner point	*
C* That is why this rotation is done.					*
C*									*
C* 									*
C* GMTOWQ ( AMTRX, INVERS, POLNR, NP, RLAT, RLON, SLAT, SLON, IRET )	*
C*									*
C* Input parameters:							*
C*	AMTRX(3,3)	REAL		Transformation matrix		*
C*	INVERS		LOGICAL		Inverse transform flag		*
C*	POLNR		REAL		Longitude rotation angle	*
C*	NP		INTEGER		Number of points		*
C* 	RLAT (NP)	REAL		Input latitudes			*
C* 	RLON (NP)	REAL		Input longitudes		*
C*									*
C* Output parameters:							*
C* 	SLAT (NP)	REAL		Output latitudes		*
C* 	SLON (NP)	REAL		Output longitudes		*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* K. Brill/EMC		 3/96						*
C* T. Lee/GSC		 7/96		Fixed pole points plot for RADAR*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
	PARAMETER	( EPS = .03 )
C*
	REAL 		amtrx (3,3)
	LOGICAL		invers
	REAL		rlat (*), rlon (*), slat (*), slon (*)
C*
	REAL		tmtrx (3,3), x (3), xp (3), phi,
     +			rlm, cosp, xx, yy
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Set the transformation matrix and look for identity matrix.
C
	IF ( .not. invers ) THEN
	    DO j = 1, 3
		DO i = 1, 3
		    tmtrx (i,j) = amtrx (i,j)
		END DO
	    END DO
	ELSE
C
C*	    The inverse is just the transpose.
C
	    DO j = 1, 3
		DO i = 1, 3
		    tmtrx (i,j) = amtrx (j,i)
		END DO
	    END DO
	END IF
C
C*	Process all the points.
C
	DO ii = 1, np
	    IF ( .not. ERMISS ( rlat (ii) ) .and.
     +		 .not. ERMISS ( rlon (ii) ) ) THEN
C
C*	        Convert from spherical to cartesian coordinates.
C
	    	phi   = rlat (ii) * DTR
	    	rlm   = rlon (ii) * DTR
	    	cosp  = COS (phi)
	    	xx    = COS (rlm)
	    	yy    = SIN (rlm)
	    	x (1) = cosp * xx
	    	x (2) = cosp * yy
	    	x (3) = SIN (phi)
C
C*	    	Rotate the coordinates and confine coordinate values.
C
	    	DO i = 1, 3
		    xp (i) = 0.
		    DO j = 1, 3
		    	xp (i) = xp (i) + tmtrx (i,j) * x (j)
		    END DO
		    IF ( xp (i) .gt. 1. ) xp (i) = 1.
		    IF ( xp (i) .lt. -1. ) xp (i) = -1.
	    	END DO
C
C*	    	Convert from cartesian to spherical coordinates.
C*		If the rotated coordinate is at a pole; then,
C*		rotate the longitude (since it is indefinite).
C
	    	slat (ii) = ASIN ( xp (3) ) * RTD
		IF ( ABS ( slat (ii) - 90. ) .lt. EPS ) THEN
		    slat (ii) = 90.
		    rcos = COS ( polnr )
		    rsin = SIN ( polnr )
		    IF ( invers ) rsin = -rsin
		    xxp = xx * rcos + yy * rsin
		    yyp = (-xx) * rsin + yy * rcos
		    slon (ii) = ATAN2 ( yyp, xxp ) * RTD
		ELSE
		    slon (ii) = ATAN2 ( xp (2), xp (1) ) * RTD
		END IF
	    ELSE
		slat (ii) = RMISSD
		slon (ii) = RMISSD
	    END IF
	END DO
C*
	RETURN
	END


!-----------------------------------------------------------------------------!
!-----------------------------------------------------------------------------!
! MAE 6263 Computational Fluid Dynamics - Project 3 !
! Sk. Mashfiqur Rahman !
!-----------------------------------------------------------------------------!
!-----------------------------------------------------------------------------!

program channel
implicit none
integer :: nx,ny,i,j,opt,nitr,ns
real*8 :: Re,pe,Tmax,nu,dy,dx,dt,rho,tolt,m
real*8 :: t1,t2,lx,ly,tol,gamma,tol1,en
real*8,allocatable ::u(:,:),v(:,:),p(:,:),hx(:,:),hy(:,:)

common/Reynolds/Re
common/contol/tol
common/density/rho

open(9,file='project3input.txt')
read(9,*)lx		    !length in x -direction
read(9,*)ly	    	!length in y -direction
read(9,*)nx		    !resolution in x direction
read(9,*)ny	    	!resolution in y direction
read(9,*)ns	    	!number of snapshots
read(9,*)gamma		!value of gamma to measure time-step size
read(9,*)rho	    !density
read(9,*)nu	    	!kinematic viscosity
read(9,*)pe	    	!Peclet number
read(9,*)Tmax		!final time
read(9,*)tol        !tolerance for iterative solvers
read(9,*)tolt       !tolerance for time integration
read(9,*)Re         !Reynolds number
read(9,*)opt    	![0]PPE without momentum interpolation, [1]PPE with momentum interpolation
close(9)

!Calculating grid spacing (spatial)
dx = lx/dfloat(nx)
dy = ly/dfloat(ny)
print*, dx
print*, dy

!Time step
!dt = ((dx*dx)*gamma) /nu
dt = Tmax/dfloat(ns)

!Initial Condition & Boundary Condition Setup
allocate(u(0:nx,0:ny))
allocate(v(0:nx,0:ny))
allocate(p(0:nx,0:ny))
allocate(hx(0:nx,0:ny))
allocate(hy(0:nx,0:ny))

do i = 0,nx
  do j = 0,ny
    u(i,j) = 0
    v(i,j) = 0
    p(i,j) = 0
  end do
end do

do j = 0,ny
    p(0,j) = 100.16d0
    p(nx,j) = 100.0d0

end do

nitr = 0
!IC File Ouput
open(20,file="InitialCondition.plt")
write(20,*)'Title="IC Data set"'
write(20,*)'variables ="x","y","u","v","p"'
close(20)

open(20,file="InitialCondition.plt",position="append")
write(20,"(a,i8,a,i8,a)")'Zone I = ',nx+1,',J=',ny+1,',F=POINT'
  do j = 0,ny
    do i = 0,nx
      write (20, '(1600F14.3)',advance="no")dfloat(i)/dfloat(ny),dfloat(j)/dfloat(ny),u(i,j),v(i,j),p(i,j)
      write(20,*) ''
    end do
  end do
close(20)

!Output file setup
open(20,file="ContourPlots.plt")
write(20,*)'Title="Transient data set"'
write(20,*)'variables ="x","y","u","v","p"'
close(20)

open(20,file="LinePlots.plt")
write(20,*)'Title="Transient data set"'
write(20,*)'variables ="x","p"'
close(20)

open(20,file="UprofileLinePlots.plt")
write(20,*)'Title="Transient data set"'
write(20,*)'variables ="u","y"'
close(20)

open(20,file="energy.plt")
write(20,*)'Title="Transient data set"'
write(20,*)'variables ="e","t"'
close(20)

open(20,file="mass.plt")
write(20,*)'Title="Transient data set"'
write(20,*)'variables ="m","t"'
close(20)

call cpu_time(t1)

!-----------------------------------------------------------------------------!
!Time integration
!-----------------------------------------------------------------------------!

tol1 = 1.0d0
do while (tol1.gt.tolt)
  tol1 = 0.0d0
  nitr = nitr + 1
call RHS(u,v,hx,hy,nx,ny,dx,dy)

if (opt==0) then
call compact(p,hx,hy,nx,ny,dx,dy,tol)
else
call momentum(p,u,v,dt,nx,ny,dx,dy,tol,nitr)
end if

call velocity(u,v,p,hx,hy,nx,ny,dx,dy,dt,tol1)

!Output .plt file for Tecplot
if (mod(nitr,500)==0) then

open(20,file="ContourPlots.plt",position="append")
write(20,"(a,i8,a,i8,a)")'Zone I = ',nx+1,',J=',ny+1,',F=POINT'
write(20,"(a,i8)")'StrandID=0,SolutionTime=',nitr
  do j = 0,ny
    do i = 0,nx
      write (20, '(1600F14.6,1600F14.6,1600F14.6,1600F14.6)',advance="no")dfloat(i)/dfloat(nx/2),&
      &dfloat(j)/dfloat(ny),u(i,j),v(i,j),p(i,j)
      write(20,*) ''
    end do
  end do
close(20)

open(20,file="LinePlots.plt",position="append")
write(20,"(a,i8,a)")'Zone I = ',ny+1,',F=POINT'
write(20,"(a,i8)")'StrandID=0,SolutionTime=',nitr
    do j = 0,ny
      write (20, '(1600F14.6,1600F14.6)',advance="no")dfloat(j)/dfloat(ny),p(nx/2,j)
      write(20,*) ''
    end do
close(20)

open(20,file="UprofileLinePlots.plt",position="append")
write(20,"(a,i8,a)")'Zone I = ',ny+1,',F=POINT'
write(20,"(a,i8)")'StrandID=0,SolutionTime=',nitr
    do j = 0,ny
      write (20, '(1600F14.6,1600F14.6)',advance="no")u(nx/2,j),dfloat(j)/dfloat(ny)
      write(20,*) ''
    end do
close(20)

en = 0.0d0
m = 0.0d0

open(20,file="energy.plt",position="append")
    do i = 0,nx
      do j = 0,ny-1
        en = en + 0.5d0*rho*u(i,j)*u(i,j)
        end do
        end do
      write (20,*) dfloat(nitr),en
      write(20,*) ''
close(20)

open(20,file="mass.plt",position="append")
      do j = 1,ny-1
        m = m + 0.5d0*(u(nx/2+1,j)+u(nx/2+1,j+1))
        end do
      write (20,*) dfloat(nitr),m*dy
      write(20,*) ''
close(20)
end if

end do

call cpu_time(t2)

open(4,file='cpu.txt')
write(4,*)"cpu time (sec)=",(t2-t1)
close(4)

end

!-----------------------------------------------------------------------------!
!Convection-diffusion
!-----------------------------------------------------------------------------!
subroutine RHS(u,v,hx,hy,nx,ny,dx,dy)
implicit none

integer :: nx,ny,i,j
real*8::dx,dy,Re
real*8,dimension(0:nx,0:ny):: u,v,hx,hy
real*8,dimension(-1:nx+1,-1:ny+1)::u2,v2
real*8,dimension(0:nx,0:ny)::udx,udy,uddx,uddy,vdx,vdy,vddx,vddy

common/Reynolds/Re

do i = 0,nx
  do j = 0,ny
    u2(i,j) = u(i,j)
    v2(i,j) = v(i,j)
  end do
end do

do j = 0,ny
  u2(-1,j) = u(nx-1,j)
  u2(nx+1,j) = u(1,j)
  v2(nx+1,j) = v(1,j)
  v2(-1,j) = v(nx-1,j)
end do

do i = 0,nx
  	do j = 1,ny-1
    if(u(i,j)>=0) then
  		udx(i,j) = (u2(i,j)-u2(i-1,j))/dx
        vdx(i,j) = (v2(i,j)-v2(i-1,j))/dx
    else if(u(i,j)<0) then
        udx(i,j) = (u2(i+1,j)-u2(i,j))/dx
        vdx(i,j) = (v2(i+1,j)-v2(i,j))/dx
    end if
	end do
    udx(i,0) = udx(i,1)
    vdx(i,0) = vdx(i,1)
    udx(i,ny) = udx(i,ny-1)
    vdx(i,ny) = vdx(i,ny-1)
end do

do i = 0,nx
  	do j = 1,ny-1
    if(v(i,j)>=0) then
  		udy(i,j) = (u2(i,j)-u2(i,j-1))/dy
        vdy(i,j) = (v2(i,j)-v2(i,j-1))/dy
    else if(v(i,j)<0) then
      udy(i,j) = (u2(i,j+1)-u2(i,j))/dy
      vdy(i,j) = (v2(i,j+1)-v2(i,j))/dy
    end if
	end do
    udy(i,0) = udy(i,1)
    vdy(i,0) = vdy(i,1)
    udy(i,ny) = udy(i,ny-1)
    vdy(i,ny) = vdy(i,ny-1)
end do

do i = 0,nx
  	do j = 1,ny-1
  		uddx(i,j) = (u2(i+1,j)+u2(i-1,j)-2.*u2(i,j))/(dx**2)
        vddx(i,j) = (v2(i+1,j)+v2(i-1,j)-2.*v2(i,j))/(dx**2)
	end do
    uddx(i,0) = uddx(i,1)
    vddx(i,0) = vddx(i,1)
    uddx(i,ny) = uddx(i,ny-1)
    vddx(i,ny) = vddx(i,ny-1)
end do

do i = 0,nx
  	do j = 1,ny-1
  		uddy(i,j) = (u2(i,j+1)+u2(i,j-1)-2d0*u2(i,j))/(dy**2)
        vddy(i,j) = (v2(i,j+1)+v2(i,j-1)-2d0*v2(i,j))/(dy**2)
	end do
    uddy(i,0) = uddy(i,1)
    vddy(i,0) = vddy(i,1)
    uddy(i,ny) = uddy(i,ny-1)
    vddy(i,ny) = vddy(i,ny-1)
end do

do i = 0,nx
	do j = 0,ny
    	hx(i,j) = -u2(i,j)*(udx(i,j))-v2(i,j)*(udy(i,j))+1/Re*(uddx(i,j)+uddy(i,j))
    	hy(i,j) = -u2(i,j)*(vdx(i,j))-v2(i,j)*(vdy(i,j))+1/Re*(vddx(i,j)+vddy(i,j))

	end do
end do

return
end

!-----------------------------------------------------------------------------!
!Pressure
!-----------------------------------------------------------------------------!
subroutine compact(p,hx,hy,nx,ny,dx,dy,tol)
implicit none

integer :: nx,ny,i,j
real*8::dy,dx,a,b,tol,err
real*8,dimension(0:nx,0:ny):: p,hx,hy,hxdx,hydy,hy2,e
real*8,dimension(0:nx,-1:ny+1)::p2,p1
real*8,dimension(-1:nx+1,0:ny)::hx2

err=1.0d0

p1(0:nx,0:ny) = p

do i = 0,nx
  do j = 0,ny
    hx2(i,j) = hx(i,j)
    hy2(i,j) = hy(i,j)
  end do
end do

do j = 0,ny
  hx2(-1,j) = hx(nx-1,j)
  hx2(nx+1,j) = hx(1,j)
end do

do i = 0,nx
  do j = 1,ny-1
    hxdx(i,j) = (hx2(i+1,j)-hx2(i-1,j))/2.0d0
    hydy(i,j) = (hy2(i,j+1)-hy2(i,j-1))/2.0d0
  end do
    hxdx(i,0)=hxdx(i,1)
    hxdx(i,ny)=hxdx(i,ny-1)
    hydy(i,0)=hydy(i,1)
    hydy(i,ny)=hydy(i,ny-1)
end do

do i=0,nx
  p1(i,-1) = p1(i,1)
  p1(i,ny+1) = p1(i,ny-1)
end do

do while(err.gt.tol)
err=0.0d0
p2 = p1
do i = 1,nx-1
  do j = 0,ny
      a = p1(i+1,j)+p2(i-1,j)+p2(i,j-1)+p1(i,j+1)
      b = hxdx(i,j) + hydy(i,j)
      p2(i,j) = a/4-(b*dx)/4
  end do
    p2(i,-1) = p2(i,1)
	p2(i,ny+1) = p2(i,ny-1)
end do

    !compute L1 norm
    do j=0,ny
    do i=0,nx
    e(i,j) = dabs(p2(i,j)-p(i,j))
    err =  e(i,j) + err
    end do
    end do

p1 = p2
do j = 0,ny
  do i = 0,nx
        p(i,j) = p1(i,j)
  end do
end do
end do

return
end

!-----------------------------------------------------------------------------!
!velocity update
!-----------------------------------------------------------------------------!
subroutine velocity(u,v,p,hx,hy,nx,ny,dx,dy,dt,tol1)
implicit none

common/density/rho

real*8::dx,dy,dt,rho,tol1
integer::nx,ny,i,j
real*8,dimension(0:nx,0:ny)::u,v,p,hx,hy,p2,s
real*8,dimension(0:nx,0:ny)::gradpx,gradpy,uo,vo

do i = 0,nx
  do j = 0,ny
    p2(i,j) = p(i,j)
  end do
end do

do i=0,nx
  do j=0,ny
    gradpx(i,j)=0.0
    gradpy(i,j)=0.0
  end do
end do

do j = 0,ny
  do i = 0,nx
        uo(i,j) = u(i,j)
        vo(i,j) = v(i,j)
end do
end do

do i = 1,nx-1
  do j = 1,ny-1
    gradpx(i,j) = (p2(i+1,j)-p2(i-1,j))/(2.*dx)
  end do
end do

do i = 1,nx-1
  	do j = 1,ny-1
    	gradpy(i,j) = (p2(i,j+1)-p2(i,j-1))/(2.*dy)
	end do
end do

do j = 0,ny
   	gradpx(0,j) = gradpx(1,j)
   	gradpx(nx,j) = gradpx(nx-1,j)
end do

do i = 0,nx
  do j = 1,ny-1
	u(i,j) = u(i,j) + dt*(hx(i,j)-gradpx(i,j))
  	v(i,j) = v(i,j) + dt*(hy(i,j)-gradpy(i,j))
  end do
end do

    !compute L1 norm
    do j=0,ny
    do i=0,nx
    s(i,j) = dabs(u(i,j)-uo(i,j))+dabs(v(i,j)-vo(i,j))
    tol1 =  s(i,j) + tol1
    end do
    end do
    print*,tol1

return
end


program cpspropagate

  use precision
  use mpi
  use globals
  use conversion
  use misc
  use setup
  use hamiltonian
  use propagate

  implicit none

  complex(cdp), dimension(:, :), allocatable :: wavefn, wavefn_t, wavefn0
  complex(cdp), dimension(:), allocatable :: espectrum
  real(fdp) :: e_before, e_after, e_start, e_finish, plotfrequency, trans, refl, trap, norm
  integer(idp) :: step, tstep
  integer(idp), dimension(4) :: potbound
  integer(idp), dimension(dim) :: nl, nu, trnl, trnu

#ifdef MPI
  call s_mpiinit()
#endif

  open(unit=potdata, status='scratch', form="formatted")

  call s_setup()

#ifdef MPI
  call s_mpiarraysize(nl, nu, trnl, trnu)
#else
  nl = (/ 1, 1 /)
  nu = (/ parameters%n(1), parameters%n(2) /)
  trnl = (/ 1, 1 /)
  trnu = (/ parameters%n(2), parameters%n(1) /)
#endif

  call s_checkrestart(nl, nu)

  allocate(wavefn(nl(1):nu(1), nl(2):nu(2)), &
       & wavefn0(nl(1):nu(1), nl(2):nu(2)), &
       & wavefn_t(nl(1):nu(1), nl(2):nu(2)), &
       & espectrum(parameters%timesteps))

  call s_restart(tstep, wavefn, wavefn0, nl, nu, e_start, espectrum)

  e_after = f_wavefnenergy(wavefn, nl, nu)

  plotfrequency = dble(parameters%timesteps)/dble(parameters&
       &%plotnumber)

  do step = tstep+1, parameters%timesteps

     e_before = e_after

     call s_display('================================================&
          &================================')
     call s_display('time step= ', char=f_numchar(step)//' / '&
          &//f_numchar(parameters%timesteps))

     !
     !  Propagate the wavefunction the required amount
     !

     call s_propagatewavefn(wavefn, nl, nu, dble(step-1)*parameters&
          &%tstep, dble(step)*parameters%tstep)

     e_after = f_wavefnenergy(wavefn, nl, nu)

     !
     !  Save the wave function to disk in a converted format for
     !  loading into Mathematica
     !
#ifndef MPI
     if (parameters%espectrum) then

        espectrum(step) = sum(wavefn*conjg(wavefn0))&
             &*product(parameters%gridspacing)

     end if
#endif

     if (parameters%plotwfn .and. ceiling(aint(dble(step)&
          &/plotfrequency)*plotfrequency) == step) then

        call s_write2drarray(real(wavefn*conjg(wavefn)), nl, nu,&
             & trim(f_numchar(step)))

     end if

     wavefn_t = wavefn

     call s_c2dfft(wavefn_t, nl, nu, fftfor)

#ifdef MPI
     call s_mpitranspose(wavefn_t, trnl, trnu)
#endif

     call s_cshift(wavefn_t, nl, nu, parameters%n(1)/2, parameters&
          &%n(2)/2)

     if (parameters%plotwfnp .and. ceiling(aint(dble(step)&
          &/plotfrequency)*plotfrequency) == step) then

        call s_write2drarray(real(wavefn_t*conjg(wavefn_t)), nl, nu,&
             & 'p.'//trim(f_numchar(step)), incboundary=.true.)

     end if

     call s_display('norm= ', realnum=f_norm(real(wavefn&
          &*conjg(wavefn)), nl, nu))
     call s_display('system energy= ', realnum=e_after)
     call s_display('change in system energy= ', realnum=e_start&
          &-e_after)

     if (parameters%tranrefl) then

        !
        !  Compute and display the amount transmitted and reflected
        !

        potbound(1) = f_gridpointx(parameters%potbound(1))
        potbound(2) = f_gridpointx(parameters%potbound(2))
        potbound(3) = f_gridpointy(parameters%potbound(3))
        potbound(4) = f_gridpointy(parameters%potbound(4))

        !
        ! Compute a normal transmission
        !

        refl = f_reflection(real(wavefn*conjg(wavefn)), nl, nu,&
             & potbound)
        trap = f_trapped(real(wavefn*conjg(wavefn)), nl, nu, potbound)
        trans = f_transmission(real(wavefn*conjg(wavefn)), nl, nu,&
             & potbound)

        norm = refl + trap + trans

        call s_display('====  Real Space  ====         Absolute      &
             &    Relative')
        call s_display('rs. norm= ', realnums=(/ norm, norm/norm /))
        call s_display('rs. reflected= ', realnums=(/ refl, refl/norm&
             & /))
        call s_display('rs. trapped= ', realnums=(/ trap, trap/norm/))
        call s_display('rs. transmitted= ', realnums=(/ trans, trans&
             &/norm /))

        !
        ! Compute transmission in momentum space
        !

        refl = f_preflection(real(wavefn_t*conjg(wavefn_t)), nl, nu)
        trans = f_ptransmission(real(wavefn_t*conjg(wavefn_t)), nl,&
             & nu)

        norm = refl + trans

        call s_display('====  Momentum Space  ====     Absolute      &
             &    Relative')
        call s_display('ms. norm= ', realnums=(/ norm, norm/norm /))
        call s_display('ms. backward= ', realnums=(/ refl, refl/norm&
             &/))
        call s_display('ms. forward= ', realnums=(/ trans, trans/norm&
             & /))

     end if

     if ((step/parameters%chkpntfreq)*parameters%chkpntfreq == step) then

        call s_checkpoint(step, wavefn, wavefn, nl, nu, e_start, espectrum)

     end if

  end do

  deallocate(wavefn, wavefn0, wavefn_t, espectrum)

  close(potdata)

#ifdef MPI
  call s_mpifinalise()
#endif

end program cpspropagate


      double precision pi,pisq,pisqo6
      parameter(pi=3.14159265358979d0,pisq=pi*pi,pisqo6=pisq/6d0)

      double precision zip,half,one,two,three,four,eight
      parameter(zip=0d0,half=0.5d0,one=1d0,two=2d0)
      parameter(three=3d0,four=4d0,eight=8d0)

      double complex im,impi,czip,chalf,cone,ctwo,c2ipi
      parameter(im=(0d0,1d0),impi=(0d0,3.14159265358979d0),
     . czip=(0d0,0d0),chalf=(0.5d0,0d0),cone=(1d0,0d0),ctwo=(2d0,0d0),
     . c2ipi=2d0*impi)

      DOUBLE COMPLEX nan
      parameter (nan = (1D123, 1D123))


      SUBROUTINE FFTSET(NP2)
      COMMON /WTABLE/ M,N,NV2,NM1,WSAVE(24)
C
      DATA PI /3.14159265/
C
      M = NP2
      N = 2**M
      NV2 = N/2
      NM1 = N-1
      LE = 1
      DO 20 L = 1,M
      WSAVE(2*L-1) = COS(PI/LE)
      WSAVE(2*L) = SIN(PI/LE)
      LE = 2*LE
  20  CONTINUE
      RETURN
      END


	SUBROUTINE MODDSRATIO
     . (ALPHA,POWER,PHI,P0,N,M,resultPSI_L,resultPSI_H)
!MS$ATTRIBUTES REFERENCE :: resultPSI_L
!MS$ATTRIBUTES REFERENCE :: resultPSI_H
	IMPLICIT NONE

	REAL ALPHA,POWER,PHI,P0,N,M,resultPSI_L,resultPSI_H
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine the value of the odds ratio that can be detected
C	with power 1-BETA from a matched case-control study.
C
C  Input prompted for from user:
C	ALPHA	Type I error probability for a two sided test
C	POWER	The desired statistical power
C	PHI		Correlation coefficient
C	P0		Probability of exposure in control group
C	N		Number of case patients
C	M		Number of matched controls per case patient
C
C  Output:
C	resultPSI_L,resultPSI_H	Odds ratio
C		-or-
C       -1 if the power associated with the odds ratio (100.) is less
C		   than 1-BETA.
C				or
C       -2 if no odds ratio exists with the required power given P0 and R.
C				or
C       -3 if N is too small to permit valid normal approximations.
C
C  Notes:
C   .	This routine was written by Dale Plummer.
C   .	Reference:
C	    Dupont, WD: "Power Calculations for Matched Case-Control
C	    Studies", Biometrics, 1988; 44:1157-1168
C   .	Link with subroutines in file SUBS.FOR
C
C-Declarations----------------------------------------------------------
C
C  Locals
C
	INTEGER ITMAX, ERRORL, ERRORH
	REAL ERRABS, ERRREL
	REAL A,B

	REAL ITERATED_POWER_FUNCTION
	EXTERNAL ITERATED_POWER_FUNCTION

	REAL XALPHA,XPOWER,XPHI,XP0,XN,XM
	COMMON/MORCOMM/XALPHA,XPOWER,XPHI,XP0,XN,XM
C
C-Code------------------------------------------------------------------
C
C
C  Load the common memory.
C
	XALPHA=ALPHA
	XPOWER=POWER
	XPHI=PHI
	XP0=P0
	XN=N
	XM=M
c
c  Find the lower solution.
c
	ERRABS = 1.0E-3
	ERRREL = 1.0E-3
	ITMAX  = 100
	A=.01
	B=.99
c	CALL ZBREN (ITERATED_POWER_FUNCTION, ERRABS, ERRREL, A, B, ITMAX)
C	RESULTPSI_L=B
	CALL BISEC(A,B,ERRABS,ERRREL,ITERATED_POWER_FUNCTION,
     .	RESULTPSI_L,ERRORL)
	IF (ERRORL.NE.0) RESULTPSI_L=-999
c
c  Find the upper solution.
c
	ERRABS = 1.0E-3
	ERRREL = 1.0E-3
	ITMAX  = 100
	A=1.01
	B=100000
C	CALL ZBREN (ITERATED_POWER_FUNCTION, ERRABS, ERRREL, A, B, ITMAX)
C	RESULTPSI_H=B
	CALL BISEC(A,B,ERRABS,ERRREL,ITERATED_POWER_FUNCTION,
     .	RESULTPSI_H,ERRORH)
	IF (ERRORH.NE.0) RESULTPSI_H=-999

	RETURN
	END
!--------------------------------------------------------------
	REAL FUNCTION ITERATED_POWER_FUNCTION(XPSI)
!
!  This is function to find the zero when determining the
!  dichotomous, independemt detectable odds ratio.
!
	IMPLICIT NONE

	REAL XPSI
	REAL SPOWER
	INTEGER ERR
	REAL ZALPHA, ZCRVALUE
	INTEGER IN, IM

 	REAL XALPHA,XPOWER,XPHI,XP0,XN,XM
	COMMON/MORCOMM/XALPHA,XPOWER,XPHI,XP0,XN,XM
     	REAL LOCALPOWER
!
!  Code.
!
	IN=XN
	IM=XM
	ZALPHA=ZCRVALUE(XALPHA/2.)
	CALL POWFCN(ZALPHA,IN,XPHI,XP0,IM,XPSI,SPOWER,ERR)
	LOCALPOWER=SPOWER
	ITERATED_POWER_FUNCTION=XPOWER-LOCALPOWER

	RETURN
	END


program tarefaa2
    implicit real(8) (a-h,o-z)
    character(70) c_filename
    character(10) c_planeta
    parameter (pi=4d0*atan(1d0))
    dimension ri(2), rmi(2), d2rdt2(2), v(2)

    n = 5d4

    open(20, file='entrada-a2-10407962.dat')

    do j = 1, 9
        read(20,*) c_planeta, a_Mp, a_raio, a_exce, v0

        write(c_filename, '(A,A,A)') 'saida-a2-', trim(c_planeta), '-10407962.dat'

        Tp = sqrt(a_raio**3d0)
        dt = Tp/n
        GMs = 4*pi**2

!        v0 = sqrt(GMs*(1-a_exce)/(a_raio*(1+a_exce)))
        v = (/0d0, v0 /)

        write(*,*) c_planeta, Tp**2/a_raio**3, v0

        ri = (/ a_raio*(1+a_exce), 0d0 /)
        rmi = ri +v*dt

        open(10, file=c_filename)

        write(10, *) ri

        do i = 1, n
            d2rdt2 = -GMs*ri/dnorm(ri)**3

            call verlet(rmi, ri, d2rdt2, dt)

            write(10, *) ri
        end do

        close(10)
    end do

contains
    function dnorm(r)
        implicit real(8) (a-h,o-z)
        dimension r(2)
        dnorm = sqrt(r(1)**2 + r(2)**2)
        return
    end function

    subroutine verlet(ri, rmi, d2rdt2, dt)
        implicit real(8) (a-h,o-z)
        dimension ri(2), rmi(2), raux(2), d2rdt2(2)

        raux = ri
        ri = 2*ri - rmi + d2rdt2*dt**2
        rmi = raux
    end subroutine

end program tarefaa2


*       Home work #1

*       Question (3)
*       Draw flow chart and write a FORTRAN program which
*       calculates (to five decimal places):
*       a) 1/1 +1/3 +1/5 +1/7 +1/21
*       b) 2/1 * 4/3 * 6/5 * 22/21

        write(*,*) ' write any number to start'
        read(*,*)a
        a=a/a
        b=a/1+a/3+a/5+a/7+a/21
        c=(2.0/1.0)*(4.0/3.0)*(6.0/5.0)*(22.0/21.0)
        write(*,*) ' (1/1 +1/3 +1/5 +1/7 +1/21) equals '
        write(*,10)b
        write(*,*)
        write(*,*) ' (2/1 * 4/3 * 6/5  * 22/21) equals '
        write(*,10)c
10      format(f 8.5)

        stop
        end


c     prog5
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	   example of the use of subroutines bndacc and bndsol to solve
c     sequentially the banded least squares problem which arises in
c     spline curve fitting.
c
      dimension x(12),y(12),b(10),g(12,5),c(12),q(4),cov(12)
c
c	 define functions p1 and p2 to be used in constructing
c	 cubic splines over uniformly spaced breakpoints.
c
      p1(t)=.25*t**2*t
      p2(t)=-(1.-t)**2*(1.+t)*.75+1.
      zero=0.
c
      write (6,230)
      mdg=12
      nband=4
      m=12
c				   set ordinates of data
      y(1)=2.2
      y(2)=4.0
      y(3)=5.0
      y(4)=4.6
      y(5)=2.8
      y(6)=2.7
      y(7)=3.8
      y(8)=5.1
      y(9)=6.1
      y(10)=6.3
      y(11)=5.0
      y(12)=2.0
c				   set abcissas of data
	   do 10 i=1,m
   10	   x(i)=2*i
c
c     begin loop thru cases using increasing nos of breakpoints.
c
	   do 150 nbp=5,10
	   nc=nbp+2
c				   set breakpoints
	   b(1)=x(1)
	   b(nbp)=x(m)
	   h=(b(nbp)-b(1))/float(nbp-1)
	   if (nbp.le.2) go to 30
		do 20 i=3,nbp
   20		b(i-1)=b(i-2)+h
   30	   continue
	   write (6,240) nbp,(b(i),i=1,nbp)
c
c     initialize ir and ip before first call to bndacc.
c
	   ir=1
	   ip=1
	   i=1
	   jt=1
   40	   mt=0
   50	   continue
	   if (x(i).gt.b(jt+1)) go to 60
c
c			 set row  for ith data point
c
	   u=(x(i)-b(jt))/h
	   ig=ir+mt
	   g(ig,1)=p1(1.-u)
	   g(ig,2)=p2(1.-u)
	   g(ig,3)=p2(u)
	   g(ig,4)=p1(u)
	   g(ig,5)=y(i)
	   mt=mt+1
	   if (i.eq.m) go to 60
	   i=i+1
	   go to 50
c
c		    send block of data to processor
c
   60	   continue
	   call bndacc (g,mdg,nband,ip,ir,mt,jt)
	   if (i.eq.m) go to 70
	   jt=jt+1
	   go to 40
c		    compute solution c()
   70	   continue
	   call bndsol (1,g,mdg,nband,ip,ir,c,nc,rnorm)
c		   write solution coefficients
	   write (6,180) (c(l),l=1,nc)
	   write (6,210) rnorm
c
c	       compute and print x,y,yfit,r=y-yfit
c
	   write (6,160)
	   jt=1
		do 110 i=1,m
   80		if (x(i).le.b(jt+1)) go to 90
		jt=jt+1
		go to 80
c
   90		u=(x(i)-b(jt))/h
		q(1)=p1(1.-u)
		q(2)=p2(1.-u)
		q(3)=p2(u)
		q(4)=p1(u)
		yfit=zero
		     do 100 l=1,4
		     ic=jt-1+l
  100		     yfit=yfit+c(ic)*q(l)
		r=y(i)-yfit
		write (6,170) i,x(i),y(i),yfit,r
  110		continue
c
c     compute residual vector norm.
c
	   if (m.le.nc) go to 150
	   sigsq=(rnorm**2)/float(m-nc)
	   sigfac=sqrt(sigsq)
	   write (6,220) sigfac
	   write (6,200)
c
c     compute and print cols. of covariance.
c
		do 140 j=1,nc
		     do 120 i=1,nc
  120		     cov(i)=zero
		cov(j)=1.
		call bndsol (2,g,mdg,nband,ip,ir,cov,nc,rdummy)
		call bndsol (3,g,mdg,nband,ip,ir,cov,nc,rdummy)
c
c    compute the jth col. of the covariance matrix.
		     do 130 i=1,nc
  130		     cov(i)=cov(i)*sigsq
  140		write (6,190) (l,j,cov(l),l=1,nc)
  150	   continue
      stop
  160 format (4h0  i,8x,1hx,10x,1hy,6x,4hyfit,4x,8hr=y-yfit/1x)
  170 format (1x,i3,4x,f6.0,4x,f6.2,4x,f6.2,4x,f8.4)
  180 format (4h0c =,10f10.5/(4x,10f10.5))
  190 format (4(02x,2i5,e15.7))
  200 format (46h0covariance matrix of the spline coefficients.)
  210 format (9h0rnorm	=,e15.8)
  220 format (9h0sigfac =,e15.8)
  230 format (50h1prog5.    execute a sequence of cubic spline fits,27h
     1to a discrete set of data.)
  240 format (1x////,11h0new case..,/47h0number of breakpoints, includin
     1g endpoints, is,i5/14h0breakpoints =,10f10.5,/(14x,10f10.5))
      end


! Copyright (c) 2017-2018 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Program test_cmaes
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_intf
  Use mlf_rsc_array
  Use mlf_utils
  Use mlf_matrix
  Use mlf_fun_intf
  Use mlf_cmaes
  Use mlf_optim
  Use test_functions
  integer :: lambda=120, ND = 30, Nmax = 2000, Niter = 30, NFirst
  integer :: larg = 32, info
  real(c_double) :: ftarget = 1.0e-10
  real(c_double), allocatable :: X0(:)
  character(len=32) :: arg
  type (mlf_maes_obj), target :: maesOpt
  type (mlf_cmaes_obj), target :: cmaesOpt
  class (mlf_matrix_es_obj), pointer :: optObj => maesOpt
  type (mlf_objective_test) :: fTest
  procedure (mlf_obj_test_fun), pointer :: optFun
  type(mlf_optim_param) :: p
  optFun => OFrosenbrock
  if(COMMAND_ARGUMENT_COUNT()>0) then
    call GET_COMMAND_ARGUMENT(1, arg, larg)
    select case (arg)
    case('sphere')
      optFun => OFsphere
    case('cigar')
      optFun => OFcigar
    case('tablet')
      optFun => OFtablet
    case('ellipsoid')
      optFun => OFellipsoid
    case('rosenbrock')
      optFun => OFrosenbrock
    case default
      print *, "Error invalid function name"
      optFun => OFrosenbrock
    end select
  endif

  if(COMMAND_ARGUMENT_COUNT()>1) then
    larg = 32
    call GET_COMMAND_ARGUMENT(2, arg, larg)
    select case (arg)
    case('cmaes')
      optObj => cmaesOpt
    case('maes')
      optObj => maesOpt
    case default
      print *, "Error invalid method name"
      optObj => cmaesOpt
    end select
  else
    optObj => cmaesOpt
  endif
   if(COMMAND_ARGUMENT_COUNT()>2) then
    larg = 32
    call GET_COMMAND_ARGUMENT(3, arg, larg)
    read(arg,*,iostat=info) ND
  endif
  if(COMMAND_ARGUMENT_COUNT()>3) then
    larg = 32
    call GET_COMMAND_ARGUMENT(4, arg, larg)
    read(arg,*,iostat=info) lambda
  endif
  if(COMMAND_ARGUMENT_COUNT()>4) then
    larg = 32
    call GET_COMMAND_ARGUMENT(5, arg, larg)
    read(arg,*,iostat=info) Nmax
  endif
  if(COMMAND_ARGUMENT_COUNT()>5) then
    larg = 32
    call GET_COMMAND_ARGUMENT(6, arg, larg)
    read(arg,*,iostat=info) ftarget
  endif
  if(COMMAND_ARGUMENT_COUNT()>6) then
    larg = 32
    call GET_COMMAND_ARGUMENT(7, arg, larg)
    read(arg,*,iostat=info) Niter
  endif
  call fTest%init(optFun, ND)
  ALLOCATE(X0(ND))
  call p%init(fTest, lambda)
  Select Type(optObj)
  class is (mlf_maes_obj)
    info = optObj%init(params = p)
  class is (mlf_cmaes_obj)
    info = optObj%init(params = p, covEvery = 1)
  End Select
  DEALLOCATE(X0)
  call optObj%constraints_step(niterMax = int(nMax, kind=8))
  call optObj%constraints_optim(targetFun = ftarget)
  Do While (optObj%step() == 0)
    print *, optObj%niter, optObj%cputime, optObj%realtime, optObj%minFun, optObj%sigma
  End Do
  print *, optObj%minX
  Select Type(optObj)
  class is (mlf_maes_obj)
    print *, "Algorithm MA-ES"
  class is (mlf_cmaes_obj)
    print *, "Algorithm CMA-ES"
  End Select
  if(COMMAND_ARGUMENT_COUNT()>0) then
    call GET_COMMAND_ARGUMENT(1, arg, larg)
    print *, "Function: ", arg
  else
    print *, "Function: rosenbrock"
  endif
  print *, "NDim: ", ND, "lambda: ", lambda, "mu: ", lambda/2
End


      SUBROUTINE laguer(a,m,x,its)
      INTEGER m,its,MAXIT,MR,MT
      REAL EPSS
      COMPLEX a(m+1),x
      PARAMETER (EPSS=2.e-7,MR=8,MT=10,MAXIT=MT*MR)
      INTEGER iter,j
      REAL abx,abp,abm,err,frac(MR)
      COMPLEX dx,x1,b,d,f,g,h,sq,gp,gm,g2
      SAVE frac
      DATA frac /.5,.25,.75,.13,.38,.62,.88,1./
      do 12 iter=1,MAXIT
        its=iter
        b=a(m+1)
        err=abs(b)
        d=cmplx(0.,0.)
        f=cmplx(0.,0.)
        abx=abs(x)
        do 11 j=m,1,-1
          f=x*f+d
          d=x*d+b
          b=x*b+a(j)
          err=abs(b)+abx*err
11      continue
        err=EPSS*err
        if(abs(b).le.err) then
          return
        else
          g=d/b
          g2=g*g
          h=g2-2.*f/b
          sq=sqrt((m-1)*(m*h-g2))
          gp=g+sq
          gm=g-sq
          abp=abs(gp)
          abm=abs(gm)
          if(abp.lt.abm) gp=gm
          if (max(abp,abm).gt.0.) then
            dx=m/gp
          else
            dx=exp(cmplx(log(1.+abx),float(iter)))
          endif
        endif
        x1=x-dx
        if(x.eq.x1)return
        if (mod(iter,MT).ne.0) then
          x=x1
        else
          x=x-dx*frac(iter/MT)
        endif
12    continue
      pause 'too many iterations in laguer'
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/laguer.for


C     LAST UPDATE 29/11/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE CIRSPL(X,Y,N,Y2)
      IMPLICIT NONE
C
C Purpose: Given arrays X and Y of length N containing a tabulated
C          function,  Yi = f(Xi),  with   X1<X2<...Xn ,  this routine
C          returns an array Y2 of length N which contains the second
C          derivatives of the interpolating function at the tabulated
C          points Xi, assuming circular boundary conditions i.e. Y0 = Yn
C
      INTEGER N
      REAL X(N),Y(N),Y2(N)
C
C Calls   0:
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      INTEGER NMAX
      PARAMETER(NMAX=50)
      REAL A(NMAX,NMAX)
      REAL DX1,DX2,DY1,DY2,D
      INTEGER INDX(NMAX)
      INTEGER I,K,IP1,IM1
C
C---------------------------------------------------------------------
C
      DO 10 I=1,N
         DO 5 K=1,N
            A(I,K) = 0.0
 5       CONTINUE
C
C========Set up circular boundary conditions
C
         IF(I.EQ.1)THEN
            IM1 = N
         ELSE
            IM1 = I - 1
         ENDIF
         IF(I.EQ.N)THEN
            IP1 = 1
         ELSE
            IP1 = I + 1
         ENDIF
         DX1 = X(I) - X(IM1)
         DX2 = X(IP1) - X(I)
         DY1 = Y(I) - Y(IM1)
         DY2 = Y(IP1) - Y(I)
         A(I,IM1) = DX1/6.0
         A(I,I) = (DX2+DX1)/3.0
         A(I,IP1) = DX2/6.0
         Y2(I) = DY2/DX2 - DY1/DX1
 10   CONTINUE
C
C========Solve linear equations for y" using LU decomposition
C
      CALL LUDCMP(A,N,NMAX,INDX,D)
      CALL LUBKSB(A,N,NMAX,INDX,Y2)
      RETURN
      END


program main
	USE Plotter
	implicit none
	integer :: i
	real :: x,y,phi,r,PI=DACOS(-1.D0)
	real,dimension(:,:),allocatable :: matrix
	phi = 0
	x = 0
	y = 0
	r = 0
	allocate(matrix(3,8400))
	do i=1,8400
		phi = phi+PI/4096.
		r=(1+sin(phi))*(1-0.9*abs(sin(4*phi)))*(0.9+0.05*cos(phi))
		matrix(1,i) = cos(phi)*r*5
		matrix(2,i) = sin(phi)*r*5
		matrix(3,i) = 0.
	end do
	!Передаём размеры окна, массив точек и их количество
	call DrawGraph(960,720,matrix,8400)
end


      SUBROUTINE MB03HZ( S11, S12, H11, H12, CO, SI )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a unitary matrix Q for a complex regular 2-by-2
C     skew-Hamiltonian/Hamiltonian pencil aS - bH with
C
C         (  S11  S12  )        (  H11  H12  )
C     S = (            ),   H = (            ),
C         (   0   S11' )        (   0  -H11' )
C
C     such that J Q' J' (aS - bH) Q is upper triangular but the
C     eigenvalues are in reversed order. The matrix Q is represented by
C
C         (  CO  SI  )
C     Q = (          ).
C         ( -SI' CO  )
C
C     The notation M' denotes the conjugate transpose of the matrix M.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     S11     (input) COMPLEX*16
C             Upper left element of the skew-Hamiltonian matrix S.
C
C     S12     (input) COMPLEX*16
C             Upper right element of the skew-Hamiltonian matrix S.
C
C     H11     (input) COMPLEX*16
C             Upper left element of the Hamiltonian matrix H.
C
C     H12     (input) COMPLEX*16
C             Upper right element of the Hamiltonian matrix H.
C
C     CO      (output) DOUBLE PRECISION
C             Upper left element of Q.
C
C     SI      (output) COMPLEX*16
C             Upper right element of Q.
C
C     METHOD
C
C     The algorithm uses unitary transformations as described on page 43
C     in [1].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, January 28, 2009.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAUEX).
C     V. Sima, Jan. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, upper
C     triangular matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   CO
      COMPLEX*16         H11, H12, S11, S12, SI
C
C     .. Local Scalars ..
      COMPLEX*16         G, TMP
C
C     .. External Subroutines ..
      EXTERNAL           ZLARTG
C
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCONJG
C
C     .. Executable Statements ..
C
      G = TWO*DBLE( H11*DCONJG( S11 ) )
      CALL ZLARTG( DCONJG( S11 )*H12 + S12*DCONJG( H11 ), G, CO, SI,
     $             TMP )
C
      RETURN
C *** Last line of MB03HZ ***
      END