!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_synthesis_routines) scalar_synthesis_regular_grid

contains

    !
    !     subroutine shsec(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
    !                      wshsec, ierror)
    !
    !     subroutine shsec performs the spherical harmonic synthesis
    !     on the arrays a and b and stores the result in the array g.
    !     the synthesis is performed on an equally spaced grid.  the
    !     associated legendre functions are recomputed rather than stored
    !     as they are in subroutine shses.  the synthesis is described
    !     below at output parameter g.
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     isym   = 0  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere.  i.e. on the
    !                 array g(i, j) for i=1, ..., nlat and j=1, ..., nlon.
    !                 (see description of g below)
    !
    !            = 1  g is antisymmetric about the equator. the synthesis
    !                 is performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !
    !            = 2  g is symmetric about the equator. the synthesis is
    !                 performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !     nt     the number of syntheses.  in the program that calls shsec,
    !            the arrays g, a and b can be three dimensional in which
    !            case multiple syntheses will be performed.  the third
    !            index is the synthesis index which assumes the values
    !            k=1, ..., nt.  for a single synthesis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that the arrays g, a and b
    !            have only two dimensions.
    !
    !     idg    the first dimension of the array g as it appears in the
    !            program that calls shsec.  if isym equals zero then idg
    !            must be at least nlat.  if isym is nonzero then idg
    !            must be at least nlat/2 if nlat is even or at least
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     jdg    the second dimension of the array g as it appears in the
    !            program that calls shsec.  jdg must be at least nlon.
    !
    !     a, b    two or three dimensional arrays (see the input parameter
    !            nt) that contain the coefficients in the spherical harmonic
    !            expansion of g(i, j) given below at the definition of the
    !            output parameter g.  a(m, n) and b(m, n) are defined for
    !            indices m=1, ..., mmax and n=m, ..., nlat where mmax is the
    !            maximum (plus one) longitudinal wave number given by
    !            mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !            mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     mdab   the first dimension of the arrays a and b as it appears
    !            in the program that calls shsec. mdab must be at least
    !            min(nlat, (nlon+2)/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndab   the second dimension of the arrays a and b as it appears
    !            in the program that calls shsec. ndab must be at least nlat
    !
    !     wshsec an array which must be initialized by subroutine shseci.
    !            once initialized, wshsec can be used repeatedly by shsec
    !            as long as nlon and nlat remain unchanged.  wshsec must
    !            not be altered between calls of shsec.
    !
    !     lshsec the dimension of the array wshsec as it appears in the
    !            program that calls shsec. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsec must be at least
    !
    !            2*nlat*l2+3*((l1-2)*(2*nlat-l1-1))/2+nlon+15
    !
    !     output parameters
    !
    !     g      a two or three dimensional array (see input parameter
    !            nt) that contains the spherical harmonic synthesis of
    !            the arrays a and b at the colatitude point theta(i) =
    !            (i-1)*pi/(nlat-1) and longitude point phi(j) =
    !            (j-1)*2*pi/nlon. the index ranges are defined above at
    !            at the input parameter isym.  for isym=0, g(i, j) is
    !            given by the the equations listed below.  symmetric
    !            versions are used when isym is greater than zero.
    !
    !     the normalized associated legendre functions are given by
    !
    !     pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
    !                       *sin(theta)**m/(2**n*factorial(n)) times the
    !                       (n+m)th derivative of (x**2-1)**n with respect
    !                       to x=cos(theta)
    !
    !     define the maximum (plus one) longitudinal wave number
    !     as   mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !          mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     then g(i, j) = the sum from n=0 to n=nlat-1 of
    !
    !                   HALF*pbar(0, n, theta(i))*a(1, n+1)
    !
    !              plus the sum from m=1 to m=mmax-1 of
    !
    !                   the sum from n=m to n=nlat-1 of
    !
    !              pbar(m, n, theta(i))*(a(m+1, n+1)*cos(m*phi(j))
    !                                    -b(m+1, n+1)*sin(m*phi(j)))
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of idg
    !            = 6  error in the specification of jdg
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lshsec
    !
    module subroutine shsec(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wshsec, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: g(idg, jdg, nt)
        integer(ip), intent(in)  :: idg
        integer(ip), intent(in)  :: jdg
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wshsec(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: imid, ist, labc, ls
        integer(ip) :: lzz1, mmax, nln, lwork
        integer(ip)             :: required_wavetable_size
        type(SpherepackUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshsec(nlat, nlon)

        call util%check_scalar_transform_inputs(isym, idg, jdg, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshsec, ierror)

        ! Check error flag
        if (ierror /= 0) return

        mmax = min(nlat, nlon/2+1)
        imid = (nlat + 1)/2
        lzz1 = 2*nlat*imid
        labc = 3*((mmax-2)*(2*nlat-mmax-1))/2

        select case (isym)
            case (0)
                ls = nlat
                ist = imid
            case default
                ls = imid
                ist = 0
        end select

        nln = nt*ls*nlon

        ! Set required workspace size
        lwork = nln+max(ls*nlon, 3*nlat*imid)

        block
            real(wp)    :: work(lwork)
            integer(ip) :: jw1, jw2, iw1

            jw1 = ist + 1
            jw2 = nln + 1
            iw1 = lzz1+labc+1

            call shsec_lower_utility_routine(nlat, isym, nt, g, idg, jdg, a, b, &
                mdab, ndab, imid, ls, nlon, work, work(jw1:), work(jw2:), work(jw2:), wshsec, wshsec(iw1:))
        end block

    end subroutine shsec

    !     subroutine shseci(nlat, nlon, wshsec, ierror)
    !
    !     subroutine shseci initializes the array wshsec which can then
    !     be used repeatedly by subroutine shsec.
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     lshsec the dimension of the array wshsec as it appears in the
    !            program that calls shseci. the array wshsec is an output
    !            parameter which is described below. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsec must be at least
    !
    !            2*nlat*l2+3*((l1-2)*(2*nlat-l1-1))/2+nlon+15
    !
    !     output parameters
    !
    !     wshsec an array which is initialized for use by subroutine shsec.
    !            once initialized, wshsec can be used repeatedly by shsec
    !            as long as nlon and nlat remain unchanged.  wshsec must
    !            not be altered between calls of shsec.
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lshsec
    !
    module subroutine shseci(nlat, nlon, wshsec, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: wshsec(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: imid, iw1
        integer(ip) :: labc, lzz1, mmax, ldwork
        type(SpherepackUtility) :: util

        associate (lshsec => size(wshsec))

            imid = (nlat + 1)/2
            mmax = min(nlat, nlon/2+1)
            lzz1 = 2*nlat*imid
            labc = 3*((mmax-2)*(2*nlat-mmax-1))/2

            ! Check calling arguments
            if (nlat < 3) then
                ierror = 1
            else if (nlon < 4) then
                ierror = 2
            else if (lshsec < lzz1+labc+nlon+15) then
                ierror = 3
            else
                ierror = 0
            end if

            ! Check error flag
            if (ierror /= 0) return

            ! Set required workspace size
            ldwork = nlat + 1

            block
                real(wp) :: dwork(ldwork)
                call util%initialize_scalar_synthesis_regular_grid(nlat, nlon, wshsec, dwork)
            end block

            ! set workspace index
            iw1 = lzz1+labc+1

            call util%hfft%initialize(nlon, wshsec(iw1:))
        end associate

    end subroutine shseci

    subroutine shsec_lower_utility_routine(nlat, isym, nt, g, idgs, jdgs, a, b, mdab, ndab, imid, &
        idg, jdg, ge, go, work, pb, walin, whrfft)

        real(wp) :: a
        real(wp) :: b
        real(wp) :: g
        real(wp) :: ge
        real(wp) :: go
        integer(ip) :: i
        integer(ip) :: i3
        integer(ip) :: idg
        integer(ip) :: idgs
        integer(ip) :: imid
        integer(ip) :: imm1
        integer(ip) :: isym
        integer(ip) :: j
        integer(ip) :: jdg
        integer(ip) :: jdgs
        integer(ip) :: k
        integer(ip) :: ls
        integer(ip) :: m
        integer(ip) :: mdab
        integer(ip) :: mdo
        integer(ip) :: mmax
        integer(ip) :: modl
        integer(ip) :: mp1
        integer(ip) :: mp2
        integer(ip) :: ndab
        integer(ip) :: ndo
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nlp1
        integer(ip) :: np1
        integer(ip) :: nt
        real(wp) :: pb
        real(wp) :: walin
        real(wp) :: whrfft
        real(wp) :: work

        ! Purpose:
        !
        ! Requirements
        !
        ! whrfft must have at least nlon+15 locations
        ! walin must have 3*l*imid + 3*((l-3)*l+2)/2 locations
        ! zb must have 3*l*imid locations
        !
        dimension g(idgs, jdgs, nt), a(mdab, ndab, nt), b(mdab, ndab, nt), &
            ge(idg, jdg, nt), go(idg, jdg, nt), pb(imid, nlat, 3), walin(*), &
            whrfft(*), work(*)

        type(SpherepackUtility) :: util

        ls = idg
        nlon = jdg
        mmax = min(nlat, nlon/2+1)

        if (2*mmax-1 > nlon) then
            mdo = mmax-1
        else
            mdo = mmax
        end if

        nlp1 = nlat+1
        modl = mod(nlat, 2)

        if (modl /= 0) then
            imm1 = imid-1
        else
            imm1 = imid
        end if

        do k=1, nt
            ge(1: ls, 1: nlon, k)=0.0_wp
        end do

        if_block: block

            if (isym /= 1) then
                call util%compute_legendre_polys_regular_grid(2, nlat, nlon, 0, pb, i3, walin)
                do k=1, nt
                    do np1=1, nlat, 2
                        do i=1, imid
                            ge(i, 1, k)=ge(i, 1, k)+a(1, np1, k)*pb(i, np1, i3)
                        end do
                    end do
                end do

                if (mod(nlat, 2) == 0) then
                    ndo = nlat-1
                else
                    ndo = nlat
                end if

                do mp1=2, mdo
                    m = mp1-1
                    call util%compute_legendre_polys_regular_grid(2, nlat, nlon, m, pb, i3, walin)
                    do np1=mp1, ndo, 2
                        do k=1, nt
                            do i=1, imid
                                ge(i, 2*mp1-2, k) = ge(i, 2*mp1-2, k)+a(mp1, np1, k)*pb(i, np1, i3)
                                ge(i, 2*mp1-1, k) = ge(i, 2*mp1-1, k)+b(mp1, np1, k)*pb(i, np1, i3)
                            end do
                        end do
                    end do
                end do

                if (.not.(mdo == mmax .or. mmax > ndo)) then
                    call util%compute_legendre_polys_regular_grid(2, nlat, nlon, mdo, pb, i3, walin)
                    do np1=mmax, ndo, 2
                        do k=1, nt
                            do i=1, imid
                                ge(i, 2*mmax-2, k) = ge(i, 2*mmax-2, k)+a(mmax, np1, k)*pb(i, np1, i3)
                            end do
                        end do
                    end do
                end if
                if (isym == 2) exit if_block
            end if

            call util%compute_legendre_polys_regular_grid(1, nlat, nlon, 0, pb, i3, walin)

            do k=1, nt
                do np1=2, nlat, 2
                    do i=1, imm1
                        go(i, 1, k)=go(i, 1, k)+a(1, np1, k)*pb(i, np1, i3)
                    end do
                end do
            end do

            if (mod(nlat, 2) /= 0) then
                ndo = nlat-1
            else
                ndo = nlat
            end if

            do mp1=2, mdo
                mp2 = mp1+1
                m = mp1-1
                call util%compute_legendre_polys_regular_grid(1, nlat, nlon, m, pb, i3, walin)
                do np1=mp2, ndo, 2
                    do k=1, nt
                        do i=1, imm1
                            go(i, 2*mp1-2, k) = go(i, 2*mp1-2, k)+a(mp1, np1, k)*pb(i, np1, i3)
                            go(i, 2*mp1-1, k) = go(i, 2*mp1-1, k)+b(mp1, np1, k)*pb(i, np1, i3)
                        end do
                    end do
                end do
            end do

            mp2 = mmax+1

            if (mdo == mmax .or. mp2 > ndo) exit if_block

            call util%compute_legendre_polys_regular_grid(1, nlat, nlon, mdo, pb, i3, walin)

            do np1=mp2, ndo, 2
                do k=1, nt
                    do i=1, imm1
                        go(i, 2*mmax-2, k) = go(i, 2*mmax-2, k)+a(mmax, np1, k)*pb(i, np1, i3)
                    end do
                end do
            end do

        end block if_block

        do k=1, nt

            if (mod(nlon, 2) == 0) ge(1: ls, nlon, k) = TWO*ge(1: ls, nlon, k)

            call util%hfft%backward(ls, nlon, ge(:, :, k), ls, whrfft)
        end do

        select case (isym)
            case (0)
                do k=1, nt
                    do j=1, nlon
                        do i=1, imm1
                            g(i, j, k) = HALF*(ge(i, j, k)+go(i, j, k))
                            g(nlp1-i, j, k) = HALF*(ge(i, j, k)-go(i, j, k))
                        end do
                        if (modl /= 0) g(imid, j, k) = HALF*ge(imid, j, k)
                    end do
                end do
            case default
                do k=1, nt
                    g(1: imid, 1: nlon, k) = HALF*ge(1: imid, 1: nlon, k)
                end do
        end select

    end subroutine shsec_lower_utility_routine

end submodule scalar_synthesis_regular_grid


subroutine new_game(matrix,matrix_rows)
	implicit none!all variables must be declared
	character(8)::datechar='--------'!this character variable stores the current date for the names of the output files
	character(10)::timechar='----------'!this character variable stores the current time for the names of the output files
	integer(4)::i=0!auxiliary counter
	integer(4)::j=0!auxiliary counter
	integer(4),intent(inout)::matrix(matrix_rows,9)!all the number cells are here
	integer(4),intent(inout)::matrix_rows!this is the amount of rows that the matrix has at a certain moment
	integer(4)::seed(8)=0!seed for the random number generator
	call date_and_time(date=datechar,time=timechar,values=seed)!creating a seed using the clock of the computer
	call srand(1000*seed(8)+3*seed(7)*seed(6)/10)!initializing the random number generator
	do j=1,9
		do i=1,matrix_rows
			matrix(i,j)=nint(rand()*8.,4)+1!generating the random initial values for the matrix between 1 and 9
		end do
	end do
	return
end subroutine new_game


!  *********************************************************************
!  *                                                                   *
!  *                       subroutine dcvmt2                           *
!  *                                                                   *
!  *********************************************************************
!  Double Precision Version 1.11
!  Written by Gordon A. Fenton, TUNS, July 17, 1992
!  Latest Update: Jun 9, 1999
!
!  PURPOSE   computes the covariance matrix between local averages needed
!            by LAS2G.
!
!  This routine computes the three covariance matrices, R (9x9), B (4x4),
!  and S (9x4), required by LAS2G. The matrices R and B represent the
!  covariances between a 3 x 3 array of equal sized local average elements
!  and a 2 x 2 subarray respectively, numbered as follows;
!
!              |-- Dx--|   R Array                         B Array
!        ---   -------------------------           -------------------------
!         |    |       |       |       |           |       |       |       |
!         Dy   |   7   |   8   |   9   |           |       |       |       |
!         |    |       |       |       |           |       |       |       |
!        ---   -------------------------           -------------------------
!              |       |       |       |           |       |       |       |
!              |   4   |   5   |   6   |           |   3   |   4   |       |
!              |       |       |       |           |       |       |       |
!              -------------------------           -------------------------
!              |       |       |       |           |       |       |       |
!              |   1   |   2   |   3   |           |   1   |   2   |       |
!              |       |       |       |           |       |       |       |
!              -------------------------           -------------------------
!
!                                        Figure 1
!
!  Notice that the array B is just equal to selected elements of the array R
!  (ie. B(1,1) = R(1,1), B(1,4) = R(1,5), etc.). S represents the 9x4
!  covariance matrix between a doubly large array and an interior subdivided
!  2 x 2 array as shown, where the numbering of the larger array is the same
!  as on the left in Figure 1.
!
!              |--2Dx--|
!        ---   -------------------------
!         |    |       |       |       |
!        2Dy   |       |       |       |
!         |    |       |       |       |
!        ---   -------------------------
!              |       | 3 | 4 |       |
!              |       |-------|       |                     Figure 2
!              |       | 1 | 2 |       |
!              -------------------------
!              |       |       |       |
!              |       |       |       |
!              |       |       |       |
!              -------------------------
!
!  Finally note that the random process is assumed to be quadrant symmetric
!  (that is the covariance function is even in each individual lag component)
!  to reduce the total number of covariance calculations.
!
!  Arguments to this routine are as follows;
!
!    dvarfn     external double precision function which returns the
!               variance of a local average of size X x Y. This function
!               is referenced using the call "V = dvarfn(X,Y)" (other
!               parameters to the function must be passed via common blocks).
!               On each invocation, this routine calls DVARFN approximately
!               225 times (via DCVAA2 and DCVAB2).
!
!    R          double precision array of size at least 9 x 9 which on output
!               will contain the covariance matrix between the local average
!               elements shown above in Figure 1, left. Note that since R is
!               symmetric, only the upper triangular values are actually
!               stored (this is to be compatible with DSIFA). (output)
!
!    ir         leading dimension of the array R as specified in the calling
!               routine. (input)
!
!    B          double precision array of size at least 4 x 4 which on output
!               will contain the covariance matrix between the local average
!               elements shown above in Figure 1, right. Note that since B is
!               symmetric, only the upper triangular values are actually
!               stored (to be compatible with DCHOL2). (output)
!
!    ib         leading dimension of the array B as specified in the calling
!               routine. (input)
!
!    S          double precision array of size at least 9 x 4 which on output
!               will contain the covariances between the set of subdivided
!               central elements and the parent 3 x 3 set of doubly large
!               elements (see Figure 2). (output)
!
!    is         leading dimension of the array S as specified in the calling
!               routine. (input)
!
!    Dx         x-dimension of the subdivided elements. The dimension of the
!               parent elements is assumed to be 2*Dx. (input)
!
!    Dy         y-dimension of the subdivided elements. The dimension of the
!               parent elements is assumed to be 2*Dy. (input)
!
!    lformR     logical flag which is true if the matrix R is to be formed
!               (in some cases, only the smaller matrix B is required). (input)
!
!  REVISION HISTORY:
!  1.1	eliminated unused local variable `m' (Dec 5/96)
!  1.11	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!----------------------------------------------------------------------------
      subroutine dcvmt2( dvarfn, R, ir, B, ib, S, is, Dx, Dy, lformR )
      implicit real*8 (a-h,o-z)
      dimension R(ir,*), B(ib,*), S(is,*)
      logical lformR
      external dvarfn
      data zero/0.d0/, half/0.5d0/, one/1.d0/, onept5/1.5d0/
      data two/2.d0/, twopt5/2.5d0/
!					first find B (upper triangle only)
      B(1,1) = dcvaa2(dvarfn,Dx,Dy,zero,zero)
      B(1,2) = dcvaa2(dvarfn,Dx,Dy,one,zero)
      B(1,3) = dcvaa2(dvarfn,Dx,Dy,zero,one)
      B(1,4) = dcvaa2(dvarfn,Dx,Dy,one,one)
      B(2,2) = B(1,1)
      B(2,3) = B(1,4)
      B(2,4) = B(1,3)
      B(3,3) = B(1,1)
      B(3,4) = B(1,2)
      B(4,4) = B(1,1)
!					now find R optionally (upper triangle)
      if( lformR ) then
         R(1,1) = B(1,1)
         R(2,2) = B(1,1)
         R(3,3) = B(1,1)
         R(4,4) = B(1,1)
         R(5,5) = B(1,1)
         R(6,6) = B(1,1)
         R(7,7) = B(1,1)
         R(8,8) = B(1,1)
         R(9,9) = B(1,1)

         R(1,2) = B(1,2)
         R(2,3) = B(1,2)
         R(4,5) = B(1,2)
         R(5,6) = B(1,2)
         R(7,8) = B(1,2)
         R(8,9) = B(1,2)

         R(1,3) = dcvaa2(dvarfn,Dx,Dy,two,zero)
         R(4,6) = R(1,3)
         R(7,9) = R(1,3)

         R(1,4) = B(1,3)
         R(2,5) = B(1,3)
         R(3,6) = B(1,3)
         R(4,7) = B(1,3)
         R(5,8) = B(1,3)
         R(6,9) = B(1,3)

         R(1,5) = B(1,4)
         R(2,6) = B(1,4)
         R(4,8) = B(1,4)
         R(5,9) = B(1,4)
         R(2,4) = B(1,4)
         R(3,5) = B(1,4)
         R(5,7) = B(1,4)
         R(6,8) = B(1,4)

         R(1,6) = dcvaa2(dvarfn,Dx,Dy,two,one)
         R(4,9) = R(1,6)
         R(3,4) = R(1,6)
         R(6,7) = R(1,6)
         R(1,7) = dcvaa2(dvarfn,Dx,Dy,zero,two)
         R(2,8) = R(1,7)
         R(3,9) = R(1,7)
         R(1,8) = dcvaa2(dvarfn,Dx,Dy,one,two)
         R(2,9) = R(1,8)
         R(2,7) = R(1,8)
         R(3,8) = R(1,8)
         R(1,9) = dcvaa2(dvarfn,Dx,Dy,two,two)
         R(3,7) = R(1,9)
      endif
!				now find S
      S(1,1) = dcvab2(dvarfn,Dx,Dy, onept5, onept5 )
      S(2,1) = dcvab2(dvarfn,Dx,Dy, half,   onept5 )
      S(3,1) = dcvab2(dvarfn,Dx,Dy, twopt5, onept5 )
      S(4,1) = dcvab2(dvarfn,Dx,Dy, onept5, half   )
      S(5,1) = dcvab2(dvarfn,Dx,Dy, half,   half   )
      S(6,1) = dcvab2(dvarfn,Dx,Dy, twopt5, half   )
      S(7,1) = dcvab2(dvarfn,Dx,Dy, onept5, twopt5 )
      S(8,1) = dcvab2(dvarfn,Dx,Dy, half,   twopt5 )
      S(9,1) = dcvab2(dvarfn,Dx,Dy, twopt5, twopt5 )
      S(1,2) = S(3,1)
      S(2,2) = S(2,1)
      S(3,2) = S(1,1)
      S(4,2) = S(6,1)
      S(5,2) = S(5,1)
      S(6,2) = S(4,1)
      S(7,2) = S(9,1)
      S(8,2) = S(8,1)
      S(9,2) = S(7,1)
      S(1,3) = S(7,1)
      S(2,3) = S(8,1)
      S(3,3) = S(9,1)
      S(4,3) = S(4,1)
      S(5,3) = S(5,1)
      S(6,3) = S(6,1)
      S(7,3) = S(1,1)
      S(8,3) = S(2,1)
      S(9,3) = S(3,1)
      S(1,4) = S(9,1)
      S(2,4) = S(8,1)
      S(3,4) = S(7,1)
      S(4,4) = S(6,1)
      S(5,4) = S(5,1)
      S(6,4) = S(4,1)
      S(7,4) = S(3,1)
      S(8,4) = S(2,1)
      S(9,4) = S(1,1)

      return
      end


C++------------------------------------------------------------------
C Program APP_FLATTENING
C (Cf Sandage et al 1970, Ap.J. 160, 831.
C  and Binney 1978, MNRAS
C
C JLP Version of 10-02-88
C------------------------------------------------------------------
	PROGRAM APP_FLATTENING
	IMPLICIT REAL*8 (A-H,O-Z)

	PARAMETER (IDIM=1000)
	REAL*8 WORK(6000)
	REAL*4 XPLOT(IDIM),YPLOT(IDIM)
	INTEGER*4 IWORK(1000)
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40,PLOTDEV*32
	CHARACTER ANS*1,NAME*40

	EXTERNAL GAUSS_OBLATE,GAUSS_PROLATE,
     1	BINO_OBLATE,BINO_PROLATE

	COMMON/APFLAT_GAUSS/Q0,SIGMA,B1
	COMMON/APFLAT_BINO/AA,Q00,PP,B11

10	FORMAT(A)
	PRINT 11
11	FORMAT(' PROGRAM APP_FLATTENING   VERSION OF 10-02-88-',/,
     1	'        (Nota : E=10*(1-b/a),  q=b/a)',/)

C Number of points for the graphs:
	PRINT *,' NUMBER OF POINTS (50?)'
	READ(5,*) NPTS

88	PRINT 12
12	FORMAT(' MENU :',/,
     1	' 1. OBLATE OBJECTS WITH GAUSSIAN DISTRIBUTION',/,
     1	' 2. PROLATE OBJECTS WITH GAUSSIAN DISTRIBUTION',/,
     1	' 3. OBLATE OBJECTS WITH SKEWED BINOMIAL DISTRIBUTION',/,
     1	' 4. PROLATE OBJECTS WITH SKEWED BINOMIAL DISTRIBUTION',/,
     1	' 10. EXIT',/,
     1	' ENTER YOUR CHOICE')
	READ(5,*) IOPT
	IF(IOPT.GT.4.OR.IOPT.LT.1)GO TO 99
C-----
	IF(IOPT.EQ.1.OR.IOPT.EQ.2)THEN
	  PRINT *,' GAUSSIAN DISTRIBUTION'
	  PRINT *,' ENTER E0 (0.<E0<10.) AND SIGMA :'
	  READ(5,*) E0,SIGMA
	  Q0=1.-E0/10.
	  SIGMA=SIGMA/10.
	ELSEIF(IOPT.EQ.3.OR.IOPT.EQ.4)THEN
	  PRINT *,' SKEWED BINOMIAL DISTRIBUTION'
	  PRINT *,' ENTER a, q0 AND p     (0 < q0 < 1.  with a > q0)'
	  READ(5,*) AA,Q00,PP
	  Q0=Q00
	ENDIF

	DO IB=1,NPTS
	   B1=FLOAT(IB)/FLOAT(NPTS+1)
C For reasons internal to fortran common syntax :
	   B11=B1

C***************
C Calling NAG routine D01AKF to integrate the profile

C Absolute and relative accuracy :
	  EPSABS=0.0001
	  EPSREL=0.001

C Troncation : the apparent flattening is always larger (i.e. b1/a1 > q)
C (remember a1=1) than the real flattening og the galaxy.
	  QMIN=0.
	  QMAX=B1

C Size of work areas WORK (real*8) and IWORK (integer) :
	  LWORK=6000
	  LIWORK=1000
	  IFAIL=1
	  ISAFE=0

	    IF(IOPT.EQ.1)THEN
	      CALL D01AKF(GAUSS_OBLATE,QMIN,QMAX,EPSABS,EPSREL,RESULT,
     1	ABSERR,WORK,LWORK,IWORK,LIWORK,IFAIL)
	    ELSEIF(IOPT.EQ.2)THEN
	      CALL D01AKF(GAUSS_PROLATE,QMIN,QMAX,EPSABS,EPSREL,RESULT,
     1	ABSERR,WORK,LWORK,IWORK,LIWORK,IFAIL)
	    ELSEIF(IOPT.EQ.3)THEN
	      CALL D01AKF(BINO_OBLATE,QMIN,QMAX,EPSABS,EPSREL,RESULT,
     1	ABSERR,WORK,LWORK,IWORK,LIWORK,IFAIL)
	    ELSEIF(IOPT.EQ.4)THEN
	      CALL D01AKF(BINO_PROLATE,QMIN,QMAX,EPSABS,EPSREL,RESULT,
     1	ABSERR,WORK,LWORK,IWORK,LIWORK,IFAIL)
	    ENDIF

	  IF(IFAIL.NE.0)THEN
	   PRINT *,' WARNING : FAILURE IN D01AKF, IFAIL =',IFAIL
	  ENDIF

C Load the arrays XPLOT, YPLOT
	  XPLOT(IB)=10*(1.-B1)
	  YPLOT(IB)=RESULT
	END DO

C Normalization to 100 objects:
	SUM=0.
	 DO I=1,NPTS
	   SUM=YPLOT(I)+SUM
	 END DO
	 DO I=1,NPTS
	   YPLOT(I)=100.*YPLOT(I)/SUM
	 END DO

C Possibility of storing the output in a file :
	PRINT *,' DO YOU WANT TO STORE THE RESULT IN A FILE ?(N)'
	READ(5,10) ANS
	 IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
5	   PRINT *,'NAME OF THE FILE ?'
	   READ(5,10) NAME
	   OPEN(1,FILE=NAME,STATUS='NEW',ERR=5)
	   WRITE(1,*) NPTS
	   DO I=1,NPTS
	     WRITE(1,*) XPLOT(I),YPLOT(I)
	   END DO
	   CLOSE(1)
	 ENDIF

	PRINT *,' Now displaying the curve'
	PRINT *,' GRAPHIC DEVICE ? (TEKTRO, FILE, ...)'
	READ(5,10) PLOTDEV
	PRINT *,' TITLE ?'
	READ(5,10) TITLE
	CHAR1=' 10*(1 - B/A)'
	CHAR2=' Relative Frequency'
	CALL DISPLAY(XPLOT,YPLOT,1,NPTS,CHAR1,CHAR2,
     1	TITLE,PLOTDEV)

C Possibility of displaying the model :
	PRINT *,' DO YOU WANT TO DISPLAY THE DEPROJECTED',
     1	' DISTRIBUTION ?(N)'
	  READ(5,10) ANS
	  IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
	    PRINT *,' TITLE ?'
	    READ(5,10) TITLE

C Gaussian option :
	    IF(IOPT.EQ.1.OR.IOPT.EQ.2)THEN
	      CT0=-1./(2*SIGMA*SIGMA)
	        DO I=1,NPTS
	          Q=FLOAT(I)/FLOAT(NPTS+1)
	          XPLOT(I)=10*(1.-Q)
	          YPLOT(I)=DEXP(CT0*(Q-Q0)*(Q-Q0))
	        END DO

C Skewed binomial distribution:
	    ELSE
	      DO I=1,NPTS
	        Q=FLOAT(I)/FLOAT(NPTS+1)
	        XPLOT(I)=10*(1.-Q)
	        YPLOT(I)=((1.+(Q-Q0)/AA)**SNGL(PP))*DEXP(PP*(Q0-Q))
	      END DO
	    ENDIF

	    CALL DISPLAY(XPLOT,YPLOT,1,NPTS,CHAR1,CHAR2,
     1	TITLE,PLOTDEV)

	  ENDIF

	GO TO 88

99	STOP

	END

C--------------------------------------------------------------
C Function GAUSS_OBLATE, called by D01AKF.
C Generates the value to be integrated at the point X
C--------------------------------------------------------------
	REAL*8 FUNCTION GAUSS_OBLATE(Q)
	IMPLICIT REAL*8 (A-H,O-Z)
	COMMON/APFLAT_GAUSS/Q0,SIGMA,B1

C Gaussian distribution :
	  CT0=-1./(2*SIGMA*SIGMA)
	  FQ=DEXP(CT0*(Q-Q0)*(Q-Q0))
	  GAUSS_OBLATE=FQ*B1/DSQRT((B1*B1-Q*Q)*(1.-Q*Q))

	RETURN
	END
C--------------------------------------------------------------
C Function GAUSS_PROLATE, called by D01AKF.
C Generates the value to be integrated at the point X
C--------------------------------------------------------------
	REAL*8 FUNCTION GAUSS_PROLATE(Q)
	IMPLICIT REAL*8 (A-H,O-Z)
	COMMON/APFLAT_GAUSS/Q0,SIGMA,B1

C Gaussian distribution :
	  CT0=-1./(2*SIGMA*SIGMA)
	  FQ=DEXP(CT0*(Q-Q0)*(Q-Q0))
	  GAUSS_PROLATE=FQ*(Q/B1)*(Q/B1)/DSQRT((B1*B1-Q*Q)*(1.-Q*Q))

	RETURN
	END
C--------------------------------------------------------------
C Function BINO_OBLATE, called by D01AKF.
C Generates the value to be integrated at the point X
C--------------------------------------------------------------
	REAL*8 FUNCTION BINO_OBLATE(Q)
	IMPLICIT REAL*8 (A-H,O-Z)
	COMMON/APFLAT_BINO/AA,Q0,PP,B1

C Skewed binomial distribution :
	  FQ=((1.+(Q-Q0)/AA)**SNGL(PP))*DEXP(PP*(Q0-Q))
	  BINO_OBLATE=FQ*B1/DSQRT((B1*B1-Q*Q)*(1.-Q*Q))

	RETURN
	END
C--------------------------------------------------------------
C Function BINO_PROLATE, called by D01AKF.
C Generates the value to be integrated at the point X
C--------------------------------------------------------------
	REAL*8 FUNCTION BINO_PROLATE(Q)
	IMPLICIT REAL*8 (A-H,O-Z)
	COMMON/APFLAT_BINO/AA,Q0,PP,B1

C Skewed binomial distribution :
	  FQ=((1.+(Q-Q0)/AA)**SNGL(PP))*DEXP(PP*(Q0-Q))
	  BINO_PROLATE=FQ*(Q/B1)*(Q/B1)/DSQRT((B1*B1-Q*Q)*(1.-Q*Q))

	RETURN
	END


! Given a scalar field f(x), calculate g(x) = (x/x_bar) - 1, where x_bar is the mean. "Overdensity" is a misnomer because this can
! be used for any scalar field, not just density. But I don't know what the technical term for this is.

subroutine calc_overdensity(density, lo, hi, ng, mean_density_inv, overdensity)
    use, intrinsic :: iso_c_binding
    implicit none

    integer(c_int), intent(in) :: lo(3), hi(3), ng
    real(c_double), intent(in) :: density (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
    real(c_double), intent(in) :: mean_density_inv

    real(c_double), intent(out) :: overdensity (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)

    integer :: i, j, k

    do k = lo(3), hi(3)
      do j = lo(2), hi(2)
        do i = lo(1), hi(1)
          overdensity (i, j, k, 1) = density (i, j, k, 1) * mean_density_inv - 1.0
        end do
      end do
    end do

end subroutine calc_overdensity


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                          SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c                             August 2003
c
c
c     This version of gaqd implements the method presented in:
c     P. N. swarztrauber, Computing the points and weights for
c     Gauss-Legendre quadrature, SIAM J. Sci. Comput.,
c     24(2002) pp. 945-954.
c
c     It the version that is new to spherepack 3.1
c     The w and lwork arrays are dummy and included only to
c     permit a simple pluggable exchange with the
c     old gaqd in spherepack 3.0.
c
c
c
      SUBROUTINE DGAQD(NLAT,THETA,WTS,W,LWORK,IERROR)
      DOUBLE PRECISION EPS
      DOUBLE PRECISION DDZEPS
      DOUBLE PRECISION SGND
C*PT*WARNING* Already double-precision
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 2001 by ucar                 .
c  .                                                             .
c  .       university corporation for atmospheric research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c                             February 2002
c
c     gauss points and weights are computed using the fourier-newton
c     described in "on computing the points and weights for
c     gauss-legendre quadrature", paul n. swarztrauber, siam journal
c     on scientific computing that has been accepted for publication.
c     This routine is faster and more accurate than older program
c     with the same name.
c
c     subroutine gaqd computes the nlat gaussian colatitudes and weights
c     in double precision. the colatitudes are in radians and lie in the
c     in the interval (0,pi).
c
c     input parameters
c
c     nlat    the number of gaussian colatitudes in the interval (0,pi)
c             (between the two poles).  nlat must be greater than zero.
c
c     w       unused double precision variable that permits a simple
c             exchange with the old routine with the same name
c             in spherepack.
c
c     lwork   unused variable that permits a simple exchange with the
c             old routine with the same name in spherepack.
c
c     output parameters
c
c     theta   a double precision array with length nlat
c             containing the gaussian colatitudes in
c             increasing radians on the interval (0,pi).
c
c     wts     a double precision array with lenght nlat
c             containing the gaussian weights.
c
c     ierror = 0 no errors
c            = 1 if nlat.le.0
c
c  *****************************************************************
c
      DOUBLE PRECISION THETA(NLAT),WTS(NLAT),W,X,PI,PIS2,DTHETA,DTHALF,
     +                 CMAX,ZPREV,ZLAST,ZERO,ZHOLD,PB,DPB,DCOR,SUM,CZ
c
c     check work space length
c
      IERROR = 1
      IF (NLAT.LE.0) RETURN
      IERROR = 0
c
c     compute weights and points analytically when nlat=1,2
c
      IF (NLAT.EQ.1) THEN
C*PT*WARNING* Constant already double-precision
          THETA(1) = DACOS(0.0d0)
C*PT*WARNING* Constant already double-precision
          WTS(1) = 2.0d0
          RETURN
      END IF
      IF (NLAT.EQ.2) THEN
C*PT*WARNING* Constant already double-precision
C*PT*WARNING* Constant already double-precision
          X = DSQRT(1.0d0/3.0d0)
          THETA(1) = DACOS(X)
          THETA(2) = DACOS(-X)
C*PT*WARNING* Constant already double-precision
          WTS(1) = 1.0d0
C*PT*WARNING* Constant already double-precision
          WTS(2) = 1.0d0
          RETURN
      END IF
C*PT*WARNING* Constant already double-precision
      EPS = SQRT(DDZEPS(1.0d0))
      EPS = EPS*SQRT(EPS)
C*PT*WARNING* Constant already double-precision
C*PT*WARNING* Constant already double-precision
      PIS2 = 2.0d0*DATAN(1.0d0)
      PI = PIS2 + PIS2
      MNLAT = MOD(NLAT,2)
      NS2 = NLAT/2
      NHALF = (NLAT+1)/2
      IDX = NS2 + 2
c
      CALL DCPDP(NLAT,CZ,THETA(NS2+1),WTS(NS2+1))
c
      DTHETA = PIS2/NHALF
C*PT*WARNING* Constant already double-precision
      DTHALF = DTHETA/2.0d0
C*PT*WARNING* Constant already double-precision
      CMAX = .2d0*DTHETA
c
c     estimate first point next to theta = pi/2
c
      IF (MNLAT.NE.0) THEN
          ZERO = PIS2 - DTHETA
          ZPREV = PIS2
          NIX = NHALF - 1
      ELSE
          ZERO = PIS2 - DTHALF
          NIX = NHALF
      END IF
    9 IT = 0
   10 IT = IT + 1
      ZLAST = ZERO
c
c     newton iterations
c
      CALL DTPDP(NLAT,ZERO,CZ,THETA(NS2+1),WTS(NS2+1),PB,DPB)
      DCOR = PB/DPB
      SGND = 1.0D0
C*PT*WARNING* Constant already double-precision
      IF (DCOR.NE.0.0d0) SGND = DCOR/DABS(DCOR)
      DCOR = SGND*MIN(DABS(DCOR),CMAX)
      ZERO = ZERO - DCOR
      IF (DABS(ZERO-ZLAST).GT.EPS*DABS(ZERO)) GO TO 10
      THETA(NIX) = ZERO
      ZHOLD = ZERO
c      wts(nix) = (nlat+nlat+1)/(dpb*dpb)
c
c     yakimiw's formula permits using old pb and dpb
c
      WTS(NIX) = (NLAT+NLAT+1)/ (DPB+PB*DCOS(ZLAST)/DSIN(ZLAST))**2
      NIX = NIX - 1
      IF (NIX.EQ.0) GO TO 30
      IF (NIX.EQ.NHALF-1) ZERO = 3.0D0*ZERO - PI
      IF (NIX.LT.NHALF-1) ZERO = ZERO + ZERO - ZPREV
      ZPREV = ZHOLD
      GO TO 9
c
c     extend points and weights via symmetries
c
   30 IF (MNLAT.NE.0) THEN
          THETA(NHALF) = PIS2
          CALL DTPDP(NLAT,PIS2,CZ,THETA(NS2+1),WTS(NS2+1),PB,DPB)
          WTS(NHALF) = (NLAT+NLAT+1)/ (DPB*DPB)
      END IF
      DO I = 1,NS2
          WTS(NLAT-I+1) = WTS(I)
          THETA(NLAT-I+1) = PI - THETA(I)
      END DO
C*PT*WARNING* Constant already double-precision
      SUM = 0.0d0
      DO I = 1,NLAT
          SUM = SUM + WTS(I)
      END DO
      DO I = 1,NLAT
C*PT*WARNING* Constant already double-precision
          WTS(I) = 2.0d0*WTS(I)/SUM
      END DO
      RETURN
      END
      SUBROUTINE DCPDP(N,CZ,CP,DCP)
C*PT*WARNING* Already double-precision
c
c     computes the fourier coefficients of the legendre
c     polynomial p_n^0 and its derivative.
c     n is the degree and n/2 or (n+1)/2
c     coefficients are returned in cp depending on whether
c     n is even or odd. The same number of coefficients
c     are returned in dcp. For n even the constant
c     coefficient is returned in cz.
c
      DOUBLE PRECISION CP(N/2+1),DCP(N/2+1),T1,T2,T3,T4,CZ

      NCP = (N+1)/2
C*PT*WARNING* Constant already double-precision
      T1 = -1.0d0
C*PT*WARNING* Constant already double-precision
      T2 = N + 1.0d0
C*PT*WARNING* Constant already double-precision
      T3 = 0.0d0
C*PT*WARNING* Constant already double-precision
      T4 = N + N + 1.0d0
      IF (MOD(N,2).EQ.0) THEN
C*PT*WARNING* Constant already double-precision
          CP(NCP) = 1.0d0
          DO J = NCP,2,-1
C*PT*WARNING* Constant already double-precision
              T1 = T1 + 2.0d0
C*PT*WARNING* Constant already double-precision
              T2 = T2 - 1.0d0
C*PT*WARNING* Constant already double-precision
              T3 = T3 + 1.0d0
C*PT*WARNING* Constant already double-precision
              T4 = T4 - 2.0d0
              CP(J-1) = (T1*T2)/ (T3*T4)*CP(J)
          END DO
C*PT*WARNING* Constant already double-precision
          T1 = T1 + 2.0d0
C*PT*WARNING* Constant already double-precision
          T2 = T2 - 1.0d0
C*PT*WARNING* Constant already double-precision
          T3 = T3 + 1.0d0
C*PT*WARNING* Constant already double-precision
          T4 = T4 - 2.0d0
          CZ = (T1*T2)/ (T3*T4)*CP(1)
          DO J = 1,NCP
              DCP(J) = (J+J)*CP(J)
          END DO
      ELSE
C*PT*WARNING* Constant already double-precision
          CP(NCP) = 1.0d0
          DO J = NCP - 1,1,-1
C*PT*WARNING* Constant already double-precision
              T1 = T1 + 2.0d0
C*PT*WARNING* Constant already double-precision
              T2 = T2 - 1.0d0
C*PT*WARNING* Constant already double-precision
              T3 = T3 + 1.0d0
C*PT*WARNING* Constant already double-precision
              T4 = T4 - 2.0d0
              CP(J) = (T1*T2)/ (T3*T4)*CP(J+1)
          END DO
          DO J = 1,NCP
              DCP(J) = (J+J-1)*CP(J)
          END DO
      END IF
      RETURN
      END
      SUBROUTINE DTPDP(N,THETA,CZ,CP,DCP,PB,DPB)
C*PT*WARNING* Already double-precision
c
c     computes pn(theta) and its derivative dpb(theta) with
c     respect to theta
c
      DOUBLE PRECISION CP(N/2+1),DCP(N/2+1),CZ,PB,DPB,FN,THETA,CDT,SDT,
     +                 CTH,STH,CHH
c
      FN = N
      CDT = DCOS(THETA+THETA)
      SDT = DSIN(THETA+THETA)
      IF (MOD(N,2).EQ.0) THEN
c
c     n even
c
          KDO = N/2
C*PT*WARNING* Constant already double-precision
          PB = .5d0*CZ
C*PT*WARNING* Constant already double-precision
          DPB = 0.0d0
          IF (N.GT.0) THEN
              CTH = CDT
              STH = SDT
              DO 170 K = 1,KDO
c      pb = pb+cp(k)*cos(2*k*theta)
                  PB = PB + CP(K)*CTH
c      dpb = dpb-(k+k)*cp(k)*sin(2*k*theta)
                  DPB = DPB - DCP(K)*STH
                  CHH = CDT*CTH - SDT*STH
                  STH = SDT*CTH + CDT*STH
                  CTH = CHH
  170         CONTINUE
          END IF
      ELSE
c
c     n odd
c
          KDO = (N+1)/2
C*PT*WARNING* Constant already double-precision
          PB = 0.0d0
C*PT*WARNING* Constant already double-precision
          DPB = 0.0d0
          CTH = DCOS(THETA)
          STH = DSIN(THETA)
          DO 190 K = 1,KDO
c      pb = pb+cp(k)*cos((2*k-1)*theta)
              PB = PB + CP(K)*CTH
c      dpb = dpb-(k+k-1)*cp(k)*sin((2*k-1)*theta)
              DPB = DPB - DCP(K)*STH
              CHH = CDT*CTH - SDT*STH
              STH = SDT*CTH + CDT*STH
              CTH = CHH
  190     CONTINUE
      END IF
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDZEPS(X)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION X
C*PT*WARNING* Already double-precision
c
c     estimate unit roundoff in quantities of size x.
c
      DOUBLE PRECISION A,B,C,EPS
C*PT*WARNING* Constant already double-precision
C*PT*WARNING* Constant already double-precision
c
c     this program should function properly on all systems
c     satisfying the following two assumptions,
c        1.  the base used in representing floating point
c            numbers is not a power of three.
c        2.  the quantity  a  in statement 10 is represented to
c            the accuracy used in floating point variables
c            that are stored in memory.
c     the statement number 10 and the go to 10 are intended to
c     force optimizing compilers to generate code satisfying
c     assumption 2.
c     under these assumptions, it should be true that,
c            a  is not exactly equal to four-thirds,
c            b  has a zero for its last bit or digit,
c            c  is not exactly equal to one,
c            eps  measures the separation of 1.0 from
c                 the next larger floating point number.
c     the developers of eispack would appreciate being informed
c     about any systems where these assumptions do not hold.
c
c     this version dated 4/6/83.
c
      A = 4.0d0/3.0d0
C*PT*WARNING* Constant already double-precision
   10 B = A - 1.0d0
      C = B + B + B
C*PT*WARNING* Constant already double-precision
      EPS = ABS(C-1.0d0)
C*PT*WARNING* Constant already double-precision
      IF (EPS.EQ.0.0d0) GO TO 10
      DDZEPS = EPS*DABS(X)
      RETURN
      END


! Copyright 2016 Krysta M Bouzek
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at

!    http://www.apache.org/licenses/LICENSE-2.0

!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.

! https://en.wikipedia.org/wiki/Discounted_cumulative_gain
module ranking_ndcg
    use qsort
    implicit none

    real, parameter :: tol = 1.0E-5
contains

    ! Elementwise log base 2 of x.
    ! @param x: Array to get log base 2 of.
    ! @return: Log base 2 of input array.
    pure function log2(x)
        ! I am mildly surprised Fortran does not have this
        real, intent(in), dimension(:) :: x
        real, dimension(size(x)) :: log2
        log2 = log(x) / log(2.0)
    end function

    ! Create a new subarray of A with size == len.
    ! Will be padded with initval if necessary.
    ! Only the first min(len, size(A)) elements of A will be copied.
    ! @param A: The array to copy and pad.
    ! @param initval: The padding value to use.
    ! @param len: The length of the returned array.
    ! @returns: A new padded/clamped array as described above.
    pure function pad(A, initval, len)
        integer, intent(in), dimension(:) :: A
        integer, intent(in) :: initval, len
        integer, dimension(max(len, size(A))) :: pad
        integer :: i

        pad = initval

        ! copy whatever is possible from A
        do i=1, size(A)
            pad(i) = A(i)
        end do
    end function pad

    ! Calculate cumulative gain.
    ! This ignores the position of a result, but may still be generally useful.

    ! @param relevance: Graded relevances of the results.
    pure integer function rank_cg(relevance)
        integer, intent(in), dimension(:) :: relevance

        rank_cg = 0.0D0
        if (size(relevance) < 1) then
            return
        end if

        rank_cg = sum(relevance)
    end function rank_cg

    ! Calculate discounted cumulative gain.
    !
    ! @param relevance: Graded and ordered relevances of the results.
    ! @param alternate: True to use the alternate scoring (intended to
    ! place more emphasis on relevant results).
    pure real function rank_dcg(relevance, alternate)
        integer, intent(in), dimension(:) :: relevance
        logical, intent(in) :: alternate
        double precision, dimension(size(relevance)) :: log2i
        ! placeholders
        integer :: i, p

        rank_dcg = 0.0

        if (size(relevance) < 1) then
            return
        end if

        p = size(relevance)

        if (alternate) then
            ! from wikipedia: "An alternative formulation of
            ! DCG[5] places stronger emphasis on retrieving relevant documents"

            log2i = log2((/ (i, i=1, p) /) + 1.0)
            rank_dcg = sum(((2 ** (1.0 * relevance)) - 1.0) / log2i)
        else
            ! slightly different than wikipedia so I don't have to declare
            ! two arrays; this one only uses elements 2 onward
            log2i = log2((/ (i, i=1, p) /) * 1.0)
            rank_dcg = relevance(1) + sum(relevance(2:) / log2i(2:))
        end if
    end function rank_dcg

    ! Calculate ideal discounted cumulative gain (maximum possible DCG).
    !
    ! @param relevance: Graded and ordered relevances of the results.
    ! @param alternate: True to use the alternate scoring (intended to
    ! place more emphasis on relevant results).
    real function rank_idcg(relevance, alternate)
        integer, intent(in), dimension(:) :: relevance
        logical, intent(in) :: alternate
        integer, dimension(size(relevance)) :: rel

        rank_idcg = 0.0
        if (size(relevance) < 1) then
            return
        end if

        ! guard copy before sort, and negate for descending sort
        rel = -1 * relevance
        ! sort in descending order
        call quicksort(rel)
        ! negate again for proper DCG calculation
        rank_idcg = rank_dcg(-1 * rel, alternate)
    end function rank_idcg

    ! Calculate normalized discounted cumulative gain.
    !
    ! @param relevance: Graded and ordered relevance array of the results.
    ! @param nranks: Number of ranks to use when calculating NDCG.
    ! Will be used to rightpad with zeros if len(relevance) is less
    ! than nranks
    ! @param alternate: True to use the alternate scoring (intended to
    ! place more emphasis on relevant results).
    real function rank_ndcg(relevance, nranks, alternate)
          integer, intent(in), dimension(:) :: relevance
          logical, intent(in) :: alternate
          integer, intent(in) :: nranks
          integer, dimension(nranks) :: rel
          real :: ideal_dcg

          rank_ndcg = 0.0

          if (size(relevance) < 1 .OR. nranks < 1) then
              return
          end if

          rel = pad(relevance, 0, size(rel))

          ideal_dcg = rank_idcg(rel, alternate)
          if (abs(ideal_dcg - 0) < tol) then
              return
          end if

          rank_ndcg = rank_dcg(rel, alternate) / ideal_dcg

    end function rank_ndcg
end module ranking_ndcg


!
! ej9a.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program ej9b
use precision, pr => dp

implicit none
integer                 :: i, j, k, n
real(pr), parameter     :: e = 5._pr, h = 1e-4
real(pr)                :: alpha, t0, tf, t, et, d
real(pr), dimension(:)  :: xi(4), xi_1(4), k1(4), k2(4), k3(4), k4(4), x0(4)

open(unit=10, file='ej9b_e5.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#  t   q1   q2   p1   p2   e"

! x0 = (/ 2._pr, 0._pr, 0._pr, sqrt(2._pr*e - 4._pr) /)
alpha = 0.05_pr
t0 = 0._pr
tf = 15000._pr
n = int((tf-t0)/h)
x0(2) = 0  ! elijo q_2 == 0
t = 0._pr

d = 2._pr * sqrt(e)/10._pr  ! ancho barrido de espacio de fase
do k = 0, 10
    x0(3) = -sqrt(e) + real(k, pr) * d
    do j = 0, 10
        x0(1) = -sqrt(e) + real(j, pr) * d

        x0(4) = 2._pr * e - x0(3)*x0(3) - x0(1)*x0(1)
        if (x0(4) < 0) cycle
        x0(4) = sqrt(x0(4))
        xi = x0
        do i =1, n
            xi_1 = xi
            k1 = h * f(xi_1, alpha)
            k2 = h * f(xi_1 + k1*0.5_pr, alpha)
            k3 = h * f(xi_1 + k2*0.5_pr, alpha)
            k4 = h * f(xi_1 + k3, alpha)

            xi = xi_1 + (k1 + 2._pr * k2 + 2._pr * k3 + k4) / 6._pr
            t = t0 + i * h

            et = 0.5_pr*(xi(1)*xi(1)+xi(2)*xi(2)+xi(3)*xi(3)+xi(4)*xi(4)) + &
                & alpha * xi(1)*xi(1)*xi(2)*xi(2)

            if (xi(2)*xi_1(2) <= 0._pr) then
                if (xi(4) > 0._pr) then
                    write(10, *) t, xi(1), xi(2), xi(3), xi(4), et
                end if
            end if

        end do
    end do
end do
contains

function f(x, alpha)
integer(kind=8), parameter :: n = 4
real (pr) :: f(n)
real (pr), intent(in) :: x(n), alpha

    f(1) = x(3)
    f(2) = x(4)
    f(3) = -x(1) - alpha*x(1)*x(2)*x(2)
    f(4) = -x(2) - alpha*x(1)*x(1)*x(2)

end function f

end program ej9b


! Small program to demonstrate brute-force segment-segment intersection
! Frank Everdij 20081124
!
program insect

use mod_reallocate
use mod_bruteforce
use mod_writevtu

implicit none

! index 1 = red; index 2 = blue

integer, dimension(2) :: ne, nn, etype, nseg
integer :: nofd
integer :: nin, i, j
real(4) :: starttime,stoptime,seconds

integer, dimension(:), allocatable :: redelem,blueelem
real(8), dimension(:,:), allocatable :: rednode,bluenode
integer, dimension(:,:), allocatable :: redsegment,bluesegment
real(8), dimension(:,:), pointer  :: intersections

nin=10000
nullify(intersections)

! Start with reading the mesh and discontinuities

! Read the Red mesh
call readgmshconst('red.msh',ne(1),nn(1),etype(1))
allocate(redelem(etype(1)*ne(1)),rednode(nn(1),2))
call readgmsh('red.msh',ne(1),nn(1),etype(1),redelem,rednode)

write (*,*) "red mesh"
write (*,*) " nodes ",nn(1)," elements ",ne(1)," type ",etype(1)
call writemesh('red.vtu',ne(1),nn(1),etype(1),redelem,rednode)

! Read the Blue mesh
call readgmshconst('blue.msh',ne(2),nn(2),etype(2))
allocate(blueelem(etype(2)*ne(2)),bluenode(nn(2),2))
call readgmsh('blue.msh',ne(2),nn(2),etype(2),blueelem,bluenode)

write (*,*) "blue mesh"
write (*,*) " nodes ",nn(2)," elements ",ne(2)," type ",etype(2)
call writemesh('blue.vtu',ne(2),nn(2),etype(2),blueelem,bluenode)

! build "red" and "blue" segment lists from mesh and discontinuity data

allocate(redsegment(etype(1)*ne(1),2))
call createsegment(ne(1),etype(1),redelem,nseg(1),redsegment)

write (*,*) "red segments ",nseg(1)

allocate(bluesegment(etype(2)*ne(2),2))
call createsegment(ne(2),etype(2),blueelem,nseg(2),bluesegment)

write (*,*) "blue segments ",nseg(2)
write (*,*) "# of Possible intersections: ",nseg(1)*nseg(2)

! Perform brute-force search over all red-segment-blue-segment combinations

starttime=seconds(0.0)
call bruteforce(nn,nseg,rednode,redsegment(1:nseg(1),1:2),bluenode, &
&    bluesegment(1:nseg(2),1:2),nin,intersections)
stoptime=seconds(starttime)

write(*,*) "time for bruteforce search: ",stoptime
write(*,*) "found ",nin," intersections"

! output the intersection points

call writepoints('intersect.vtu',nin,intersections)

deallocate(redelem,rednode,blueelem,bluenode,redsegment,bluesegment,intersections)

end program insect


      SUBROUTINE waldrop(obsd, persist, fcst, climo, n)
!translated from John Waldrop writings Apr  1  1997
!Robert Grumbine 1 May 2014

      IMPLICIT none

      INTEGER n
      REAL obsd(n), persist(n), fcst(n), climo(n)
      REAL a(n), b(n), c(n)
      REAL r1, r2, r3
      REAL ss1, ss2
      REAL mse1, mse2, mse3
      REAL correl, sumx, sumx2, sumxy

      a = persist - obsd
      b = fcst    - obsd
      c = climo   - obsd

      mse3 = sumx2(c,n)
      mse2 = sumx2(b,n)
      mse1 = sumx2(a,n)
!Murphy Skill score -- mse vs. reference
      ss1 = 1 - mse1/mse3
      ss2 = 1 - mse2/mse3

      r1 = correl(obsd, persist, n)
      r2 = correl(obsd, fcst, n)
      r3 = correl(obsd, climo, n)

      WRITE (*,*) mse1, mse2, mse3, ss1, ss2, r1, r2, r3

      RETURN
      END


! This routine solves the linear system A X = B using the SVD technique
! The diagonal elements of the covariance matrix are returned in B
!
Subroutine SVD_solve(NP, SVD_threshold, A, B, X, Zeroed)
  USE nr
  USE Debug_module
  Implicit None
  Integer :: NP, i_param, j_param
  Real, Dimension (NP) :: X, B
  Real, Dimension (NP,NP) :: A
  Real(kind=8), Dimension (NP) :: Xdp, Bdp, W
  Real(kind=8), Dimension (NP,NP) :: Adp, V
  Logical, Dimension (NP) :: Zeroed
  Real :: Wmax, SVD_threshold
!
  Adp=A
  Bdp=B
  Call SVDcmp(Adp, W, V)
  If (Debug_errorflags(flag_svdcmp) .ge. 1) then
     X(:)=0.
     Call Debug_Log('Error in svdcmp... returning from SVD_solve with X=0',2)
     Return
  End if
  Wmax=Maxval(W)
  Zeroed(1:NP)=.FALSE.
  Do i_param=1, NP
     If (W(i_param) .lt. SVD_threshold*Wmax) then
        W(i_param)=0.
        Zeroed(i_param)=.TRUE.
     End if
  End do
  Call SVBKSB(Adp, W, V, Bdp, Xdp)
  B=Bdp
  X=Xdp
  A=Adp
  B(1:NP)=0.
  Do i_param=1, NP
     Do j_param=1, NP
        If (.not. Zeroed(j_param)) Then
           If (Abs(V(i_param,j_param)) .gt. .1) then
!          If there is a significant contribution from this w(j_param) to
!          the B(i_param), then add it.
!        Numerical recipes formula
!              B(i_param)=B(i_param)+V(i_param,j_param)*V(i_param,j_param)/ &
!                   (W(j_param)*W(j_param))
!        Diagonal of A^-1 calculated from A=UWV^t => A^-1=V(1/w)U^t
              B(i_param)=B(i_param)+&
                   V(i_param, j_param)*A(i_param, j_param)/W(j_param)
           End if
        Else
!          If there is a significant contribution from a zeroed eigenvalue
!          to the B(i_param), then make it infinity.
           If (Abs(V(i_param,j_param)) .gt. .1) &
                B(i_param)=100.
        End if
     End do
  End do
!  B(1:NP)=Sqrt(B(1:NP))
  Return
!
End Subroutine SVD_solve


Module grid_vectors_module
  !!----------------------------------------------------
  !! Module containing type and functions pertaining to
  !! calculating finite-difference grid contributions
  !! for non-orthonormal grids.
  !!
  !! Written by I.J. Bush
  !!----------------------------------------------------

  Use numbers_module, Only : wp

  Implicit None

  Type, Public :: grid_vectors
    !!----------------------------------------------------
    !! Type to handle grids of arbitrary size and orientation
    !! and the calculation of relevant parameters thereof
    !!
    !! Written by I.J. Bush
    !!----------------------------------------------------
    Real( wp ), Dimension( :, : ), Allocatable, Private :: dir_vecs
    Real( wp ),                                 Private :: volume
    Real( wp ), Dimension( :, : ), Allocatable, Private :: inv_vecs
  Contains
    Procedure, Public :: set_dir_vecs
    Procedure, Public :: get_dir_vec
    Procedure, Public :: get_volume
    Procedure, Public :: get_inv_vec
  End type grid_vectors

  Private

Contains

  Subroutine set_dir_vecs( g, vecs )
    !!----------------------------------------------------
    !! Set grid vectors as an NxN array (vecs) and thereby
    !! calculate the various properties for use with the
    !! rest of the solvers
    !!
    !! Written by I.J. Bush
    !!----------------------------------------------------

    Class( grid_vectors )        , Intent( InOut ) :: g
    Real( wp ), Dimension( :, : ), Intent( In    ) :: vecs

    Real( wp ) :: V

    g%dir_vecs = vecs

    Call givens_invert( g%dir_vecs, g%inv_vecs, V )
    g%volume = Abs( V )

  End Subroutine set_dir_vecs

  Pure Function get_dir_vec( g, which ) Result( v )
    !!----------------------------------------------------
    !! Get the direction of a given (which) vector from
    !! the direction vecs
    !!
    !! Written by I.J. Bush
    !!----------------------------------------------------

    Real( wp ), Dimension( : ), Allocatable :: v

    Class( grid_vectors ), Intent( In ) :: g
    Integer              , Intent( In ) :: which

    v = g%dir_vecs( :, which )

  End Function get_dir_vec

  Pure Function get_inv_vec( g, which ) Result( v )
    !!----------------------------------------------------
    !! Get the inverse direction vectors
    !!
    !! Written by I.J. Bush
    !!----------------------------------------------------

    Real( wp ), Dimension( : ), Allocatable :: v

    Class( grid_vectors ), Intent( In ) :: g
    Integer              , Intent( In ) :: which

    v = g%inv_vecs( which, : )

  End Function get_inv_vec

  Pure Function get_volume( g ) Result( V )
    !!----------------------------------------------------
    !! Get the volume element from the vectors
    !!
    !! Written by I.J. Bush
    !!----------------------------------------------------

    Real( wp ) :: V

    Class( grid_vectors ), Intent( In ) :: g

    V = g%volume

  End Function get_volume

  Subroutine givens_invert( A, B, det )
    !!----------------------------------------------------
    !! Invert the matrix A, returning the inverse in B
    !! and the determinant of A in det
    !!
    !! NOT FOR USE ON LARGE MATRICES
    !!
    !! Really designed as a robust, not totally disastorous, way
    !! to find inverse lattice vectors and the volume of the unit cell
    !! ( i.e. the determinant )
    !!
    !! The method used is to QR factorise ( in fact LQ factorise ),
    !! invert the triangular matrix and the from that form the
    !! inverse of the original matrix. The determinant is simply the
    !! product of the diagonal elements of the triangular matrix.
    !! Method chosen as easy to implement and nicely numerically stable,
    !! especially for the small matrices need here.
    !!
    !! Written by I.J. Bush
    !!----------------------------------------------------

    Real( wp ), Dimension( 1:, 1: ),               Intent( In    )           :: A
    Real( wp ), Dimension(  :,  : ), Allocatable,  Intent(   Out )           :: B
    Real( wp )                     ,               Intent(   Out ), Optional :: det

    Real( wp ), Dimension( :, : ), Allocatable :: Q, L

    Real( wp ) :: theta, c, s
    Real( wp ) :: ann, anm
    Real( wp ) :: Lim, Lin
    Real( wp ) :: Qmi, Qni
    Real( wp ) :: mv

    Integer :: dim
    Integer :: m, n
    Integer :: i

    Allocate( B, Mold = A )

    ! Size of the problem
    dim = Size( A, dim = 1 )

    ! The factors of the matrix A
    Allocate( L( 1:dim, 1:dim ) )
    Allocate( Q( 1:dim, 1:dim ) )

    ! Factorise A by Givens rotations
    L = A
    Q = 0.0_wp
    Do i = 1, dim
      Q( i, i ) = 1.0_wp
    End Do
    LQ_factorise: Do m = 2, dim
      Do n = 1, m - 1
        ! For element mn generate the rotation which
        ! will zero that element
        ann = L( n, n )
        anm = L( n, m )
        theta = atan2( - anm, ann )
        c = Cos( theta )
        s = Sin( theta )
        ! And apply that rotation to the original matrix
        Do i = 1, Dim
          Lim = L( i, m )
          Lin = L( i, n )
          L( i, n ) = c * Lin - s * Lim
          L( i, m ) = c * Lim + s * Lin
        End Do
        ! And then apply the rotation to the orthognal matrix
        Do i = 1, Dim
          Qmi = Q( m, i )
          Qni = Q( n, i )
          Q( n, i ) = c * Qni - s * Qmi
          Q( m, i ) = c * Qmi + s * Qni
        End Do
      End Do
    End Do LQ_factorise

    ! Now invert the triangular matrix, returning the inverse in B
    B(  1, 1  ) = 1.0_wp / L( 1, 1 )
    B(  1, 2: ) = 0.0_wp
    Do m = 2, dim
      Do n = 1, m
        mv = 0.0_wp
        Do i = 1, m - 1
          mv = mv - L( m, i ) * B( i, n )
        End Do
        If( m == n ) Then
          mv = mv + 1.0_wp
        End If
        mv = mv / L( m, m )
        B( m, n ) = mv
      End Do
      B( m, n: ) = 0.0_wp
    End Do

    ! The inverse of A is now trivially formed
    B = Matmul( Transpose( Q ), B )

    ! And generate the determinant
    If( Present( det ) ) Then
      det = 1.0_wp
      Do i = 1, dim
        det = det * L( i, i )
      End Do
    End If

    Deallocate( Q )
    Deallocate( L )

  End Subroutine givens_invert

End Module grid_vectors_module


 implicit none

 integer :: i

 i=(-2)**31  ! the 31 power if -2 is OK
! i=-2**31   ! - (the 31 power of 2) is not allowed by the compiler
 print*,i
 i=i-1
 print*,i

 end


!#######################################################################
! This Fortran 90 code is compatible with the F language subset
! a compiler can be found from http://www.fortran.com/imagine1
!#######################################################################

module numeric_kinds

    implicit none

    integer, parameter, public :: &
        i4b = selected_int_kind(9), &
        i2b = selected_int_kind(4), &
        i1b = selected_int_kind(2), &
        sp = kind(1.0), &
        dp = selected_real_kind(2*precision(1.0_sp)), &
        lgt = kind(.true.)
    real(kind=dp), parameter, public :: &
        pi = 3.141592653589793238462643383279502884197_sp, &
        pio2 = 1.57079632679489661923132169163975144209858_sp, &
        twopi = 6.283185307179586476925286766559005768394_sp
    real(kind=dp), parameter, public :: &
        pi_d = 3.141592653589793238462643383279502884197_dp, &
        pio2_d = 1.57079632679489661923132169163975144209858_dp, &
        twopi_d = 6.283185307179586476925286766559005768394_dp

end module numeric_kinds