module dtwodq_mod

    use preci, wp => dp
    implicit none

contains

    subroutine DTWODQ(F,AA,BB,G,H,TOL,ERE,IR_0,RESULT,ERROR)

!***BEGIN PROLOGUE  TWODQ
!***DATE WRITTEN   840518   (YYMMDD)
!***REVISION DATE  840518   (YYMMDD)
!***CATEGORY NO.  D1I
!***KEYWORDS  QUADRATURE,TWO DIMENSIONAL,ADAPTIVE,CUBATURE
!***AUTHOR KAHANER,D.K.,N.B.S.
!          RECHARD,O.W.,N.B.S.
!          BARNHILL,ROBERT,UNIV. OF UTAH
!***PURPOSE  To compute the two-dimensional integral of a function
!            F over a region consisting of N triangles.
!***DESCRIPTION

!   This subroutine computes the two-dimensional integral of a
!   function F over a region consisting of N triangles.
!   A total error estimate is obtained and compared with a
!   tolerance - TOL - that is provided as input to the subroutine.
!   The error tolerance is treated as either relative or absolute
!   depending on the input value of IFLAG.  A 'Local Quadrature
!   Module' is applied to each input triangle and estimates of the
!   total integral and the total error are computed.  The local
!   quadrature module is either subroutine LQM0 or subroutine
!   LQM1 and the choice between them is determined by the
!   value of the input variable ICLOSE.

!   If the total error estimate exceeds the tolerance, the triangle
!   with the largest absolute error is divided into two triangles
!   by a median to its longest side.  The local quadrature module
!   is then applied to each of the subtriangles to obtain new
!   estimates of the integral and the error.  This process is
!   repeated until either (1) the error tolerance is satisfied,
!   (2) the number of triangles generated exceeds the input
!   parameter MAXTRI, (3) the number of integrand evaluations
!   exceeds the input parameter MEVALS, or (4) the subroutine
!   senses that roundoff error is beginning to contaminate
!   the result.

!   The user must specify MAXTRI, the maximum number of triangles
!   in the final triangulation of the region, and provide two
!   storage arrays - DATA and IWORK - whose sizes are at least
!   9*MAXTRI and 2*MAXTRI respectively.  The user must also
!   specify MEVALS, the maximum number of function evaluations
!   to be allowed.  This number will be effective in limiting
!   the computation only if it is less than 94*MAXTRI when LQM1
!   is specified or 56*MAXTRI when LQM0 is specified.

!   After the subroutine has returned to the calling program
!   with output values, it can be called again with a smaller
!   value of TOL and/or a different value of MEVALS.  The tolerance
!   can also be changed from relative to absolute
!   or vice-versa by changing IFLAG.  Unless
!   the parameters NU and ND are reset to zero the subroutine
!   will restart with the final set of triangles and output
!   values from the previous call.

!   ARGUMENTS:

!   F function subprogram defining the integrand F(u,v);
!     the actual name for F needs to be declared EXTERNAL
!     by the calling program.

!   N the number of input triangles.

!   X a 3 by N array containing the abscissae of the vertices
!     of the N triangles.

!   Y a 3 by N array containing the ordinates of the vertices
!     of the N triangles

!   TOL the desired bound on the error.  If IFLAG=0 on input,
!       TOL is interpreted as a bound on the relative error;
!       if IFLAG=1, the bound is on the absolute error.

!   ICLOSE an integer parameter that determines the selection
!          of LQM0 or LQM1.  If ICLOSE=1 then LQM1 is used.
!          Any other value of ICLOSE causes LQM0 to be used.
!          LQM0 uses function values only at interior points of
!          the triangle.  LQM1 is usually more accurate than LQM0
!          but involves evaluating the integrand at more points
!          including some on the boundary of the triangle.  It
!          will usually be better to use LQM1 unless the integrand
!          has singularities on the boundary of the triangle.

!   MAXTRI The maximum number of triangles that are allowed
!          to be generated by the computation.

!   MEVALS  The maximum number of function evaluations allowed.

!   RESULT output of the estimate of the integral.

!   ERROR output of the estimate of the absolute value of the
!         total error.

!   NU an integer variable used for both input and output.   Must
!      be set to 0 on first call of the subroutine.  Subsequent
!      calls to restart the subroutine should use the previous
!      output value.

!   ND an integer variable used for both input and output.  Must
!      be set to 0 on first call of the subroutine.  Subsequent
!      calls to restart the subroutine should use the previous
!      output value.

!   NEVALS  The actual number of function evaluations performed.

!   IFLAG on input:
!        IFLAG=0 means TOL is a bound on the relative error;
!        IFLAG=1 means TOL is a bound on the absolute error;
!        any other input value for IFLAG causes the subroutine
!        to return immediately with IFLAG set equal to 9.

!        on output:
!        IFLAG=0 means normal termination;
!        IFLAG=1 means termination for lack of space to divide
!                another triangle;
!        IFLAG=2 means termination because of roundoff noise
!        IFLAG=3 means termination with relative error <=
!                5.0* machine epsilon;
!        IFLAG=4 means termination because the number of function
!                evaluations has exceeded MEVALS.
!        IFLAG=9 means termination because of error in input flag

!   DATA a one dimensional array of length >= 9*MAXTRI
!        passed to the subroutine by the calling program.  It is
!        used by the subroutine to store information
!        about triangles used in the quadrature.

!   IWORK  a one dimensional integer array of length >= 2*MAXTRI
!          passed to the subroutine by the calling program.
!          It is used by the subroutine to store pointers
!          to the information in the DATA array.

!   The information for each triangle is contained in a nine word
!   record consisting of the error estimate, the estimate of the
!   integral, the coordinates of the three vertices, and the area.
!   These records are stored in the DATA array
!   that is passed to the subroutine.  The storage is organized
!   into two heaps of length NU and ND respectively.  The first heap
!   contains those triangles for which the error exceeds
!   epsabs*a/ATOT where epsabs is a bound on the absolute error
!   derived from the input tolerance (which may refer to relative
!   or absolute error), a is the area of the triangle, and ATOT
!   is the total area of all triangles.  The second heap contains
!   those triangles for which the error is less than or equal to
!   epsabs*a/ATOT.  At the top of each heap is the triangle with
!   the largest absolute error.

!   Pointers into the heaps are contained in the array IWORK.
!   Pointers to the first heap are contained
!   between IWORK(1) and IWORK(NU).  Pointers to the second
!   heap are contained between IWORK(MAXTRI+1) and
!   IWORK(MAXTRI+ND).  The user thus has access to the records
!   stored in the DATA array through the pointers in IWORK.
!   For example, the following two do loops will print out
!   the records for each triangle in the two heaps:

!     do 10 I=1,NU
!       PRINT*,(DATA(IWORK(I)+J),J=0,8)
!    10  continue
!     do 20 I=1,ND
!       PRINT*,(DATA(IWORK(MAXTRI+I)+J),J=0,8
!    20  continue

!   When the total number of triangles is equal to
!   MAXTRI, the program attempts to remove a triangle from the
!   bottom of the second heap and continue.  If the second heap
!   is empty, the program returns with the current estimates of
!   the integral and the error and with IFLAG set equal to 1.
!   Note that in this case the actual number of triangles
!   processed may exceed MAXTRI and the triangles stored in
!   the DATA array may not constitute a complete triangulation
!   of the region.

!   The following sample program will calculate the integral of
!   cos(x+y) over the square (0.,0.),(1.,0.),(1.,1.),(0.,1.) and
!   print out the values of the estimated integral, the estimated
!   error, the number of function evaluations, and IFLAG.

!     real (wp) X(3,2),Y(3,2),DATA(450),RES,ERR
!     integer IWORK(100),NU,ND,NEVALS,IFLAG
!     EXTERNAL F
!     X(1,1)=0.
!     Y(1,1)=0.
!     X(2,1)=1.
!     Y(2,1)=0.
!     X(3,1)=1.
!     Y(3,1)=1.
!     X(1,2)=0.
!     Y(1,2)=0.
!     X(2,2)=1.
!     Y(2,2)=1.
!     X(3,2)=0.
!     Y(3,2)=1.
!     NU=0
!     ND=0
!     IFLAG=1
!     CALL TWODQ(F,2,X,Y,1.E-04,1,50,4000,RES,ERR,NU,ND,
!    *  NEVALS,IFLAG,DATA,IWORK)
!     PRINT*,RES,ERR,NEVALS,IFLAG
!     END
!     FUNCTION F(X,Y)
!     F=COS(X+Y)
!     return
!     END

!***REFERENCES  (NONE)

!***OUTINES CALLED  HINITD,HINITU,HPACC,HPDEL,HPINS,LQM0,LQM1,
!                    TRIDV,R1MACH
!***END PROLOGUE  TWODQ

    implicit none

    integer :: n,iflag,nevals,iclose,nu,nd,mevals,maxtri
    integer, dimension(200) :: iwork
    real (wp) :: F,tol,result,error
    real (wp), dimension(3,2) :: x,y
    real (wp), dimension(900) :: data
    real (wp) :: AA,BB,G,H,ERE
    integer :: IR_0
    integer :: rndcnt
    logical :: full
    !logical :: GREATR
    real (wp) :: dat05
    real (wp) :: a,r,e,epsabs,EMACH,ATOT,fadd,newres,newerr
    real (wp), dimension(3) :: u,v
    real (wp), dimension(9) :: node,node1,node2
    save ATOT
    !external F,GREATR
    external F
    external G,H
    integer :: i, j

    EMACH = R1MACH(4)

    N = 2
    X(1,1) = AA
    Y(1,1) = G(AA)
    X(2,1) = BB
    Y(2,1) = G(BB)
    X(3,1) = BB
    Y(3,1) = H(BB)
    X(1,2) = AA
    Y(1,2) = G(AA)
    X(2,2) = BB
    Y(2,2) = H(BB)
    X(3,2) = AA
    Y(3,2) = H(AA)
    NU = 0
    ND = 0
    IFLAG = 1
    ICLOSE = 1
    MAXTRI = 100
    MEVALS = 8000

!      If heaps are empty, apply LQM to each input triangle and
!      place all of the data on the second heap.

    if((nu+nd) == 0) then
        call HINITU(maxtri,9,nu,iwork)
        call HINITD(maxtri,9,nd,iwork(maxtri+1))
        ATOT=0.0
        result=0.0
        error=0.0
        rndcnt=0
        nevals=0
        do i=1,n
            do j=1,3
                u(j)=x(j,i)
                v(j)=y(j,i)
            end do
            a=0.5*abs(u(1)*v(2)+u(2)*v(3)+u(3)*v(1) &
            -u(1)*v(3)-u(2)*v(1)-u(3)*v(2))
            ATOT=ATOT+a
            if(iclose == 1) then
                call LQM1(f,u,v,r,e)
                nevals=nevals+47
            else
                call LQM0(f,u,v,r,e)
                nevals=nevals+28
            end if
            result=result+r
            error=error+e
            node(1)=e
            node(2)=r
            node(3)=x(1,i)
            node(4)=y(1,i)
            node(5)=x(2,i)
            node(6)=y(2,i)
            node(7)=x(3,i)
            node(8)=y(3,i)
            node(9)=a
            call HPINS(maxtri,9,data,nd,iwork(maxtri+1),node,GREATR)
        end do
    end if

!      Check that input tolerance is consistent with
!      machine epsilon.

    if(iflag == 0) then
        if(tol <= 5.0*EMACH) then
            tol=5.0*EMACH
            fadd=3
        else
            fadd=0
        end if
        epsabs=tol*abs(result)
    else if(iflag == 1) then
        if(tol <= 5.0*EMACH*abs(result)) then
            epsabs=5.0*EMACH*abs(result)
        else
            fadd=0
            epsabs=tol
        end if
    else
        iflag=9
        return
    end if

!      Adjust the second heap on the basis of the current
!      value of epsabs.

    2 if(nd == 0) go to 40
    j=nd
    3 if(j == 0) go to 40
    call HPACC(maxtri,9,data,nd,iwork(maxtri+1),node,j)
    if(node(1) > epsabs*node(9)/ATOT) then
        call HPINS(maxtri,9,data,nu,iwork,node,GREATR)
        call HPDEL(maxtri,9,data,nd,iwork(maxtri+1),GREATR,j)
        if(j > nd) j=j-1
    else
        j=j-1
    end if
    go to 3

!      Beginning of main loop from here to end

    40 if(nevals >= mevals) then
        iflag=4
        return
    end if
    if(error <= epsabs) then
        if(iflag == 0) then
            if(error <= abs(result)*tol) then
                iflag=fadd
                return
            else
                epsabs=abs(result)*tol
                go to 2
            end if
        else
            if(error <= tol) then
                iflag=0
                return
            else if(error <= 5.0*EMACH*abs(result)) then
                iflag=3
                return
            else
                epsabs=5.0*EMACH*abs(result)
                go to 2
            end if
        end if
    end if

!      If there are too many triangles and second heap
!      is not empty remove bottom triangle from second
!      heap.  If second heap is empty return with iflag
!      set to 1 or 4.

    if((nu+nd) >= maxtri) then
        full= .TRUE.
        if(nd > 0) then
            iwork(nu+1)=iwork(maxtri+nd)
            nd=nd-1
        else
            iflag=1
            return
        end if
    else
        full= .FALSE.
    end if

!      Find triangle with largest error, divide it in
!      two, and apply LQM to each half.

    if(nd == 0) then
        call HPACC(maxtri,9,data,nu,iwork,node,1)
        call HPDEL(maxtri,9,data,nu,iwork,GREATR,1)
    else if(nu == 0) then
        call HPACC(maxtri,9,data,nd,iwork(maxtri+1),node,1)
        call HPDEL(maxtri,9,data,nd,iwork(maxtri+1),GREATR,1)
    else if(data(iwork(1)) >= data(iwork(maxtri+1))) then
        if(full) iwork(maxtri+nd+2)=iwork(nu)
        call HPACC(maxtri,9,data,nu,iwork,node,1)
        call HPDEL(maxtri,9,data,nu,iwork,GREATR,1)
    else
        if(full) iwork(nu+2)=iwork(maxtri+nd)
        call HPACC(maxtri,9,data,nd,iwork(maxtri+1),node,1)
        call HPDEL(maxtri,9,data,nd,iwork(maxtri+1),GREATR,1)
    end if
    dat05 = 0.5
    call tridv(node,node1,node2,dat05,1)
    do 60 j=1,3
        u(j)=node1(2*j+1)
        v(j)=node1(2*j+2)
    60 end do
    if(iclose == 1) then
        call LQM1(f,u,v,node1(2),node1(1))
        nevals=nevals+47
    else
        call LQM0(f,u,v,node1(2),node1(1))
        nevals=nevals+28
    end if
    do 70 j=1,3
        u(j)=node2(2*j+1)
        v(j)=node2(2*j+2)
    70 end do
    if(iclose == 1) then
        call LQM1(f,u,v,node2(2),node2(1))
        nevals=nevals+47
    else
        call LQM0(f,u,v,node2(2),node2(1))
        nevals=nevals+28
    end if
    newerr=node1(1)+node2(1)
    newres=node1(2)+node2(2)
    if(newerr > 0.99*node(1)) then
        if(abs(node(2)-newres) <= 1.E-04*abs(newres)) rndcnt=rndcnt+1
    end if
    result=result-node(2)+newres
    error=error-node(1)+newerr
    if(node1(1) > node1(9)*epsabs/ATOT) then
        call HPINS(maxtri,9,data,nu,iwork,node1,GREATR)
    else
        call HPINS(maxtri,9,data,nd,iwork(maxtri+1),node1,GREATR)
    end if
    if(node2(1) > node2(9)*epsabs/ATOT) then
        call HPINS(maxtri,9,data,nu,iwork,node2,GREATR)
    else
        call HPINS(maxtri,9,data,nd,iwork(maxtri+1),node2,GREATR)
    end if
    if(rndcnt >= 20) then
        iflag=2
        return
    end if
    if(iflag == 0) then
        if(epsabs < 0.5*tol*abs(result)) then
            epsabs=tol*abs(result)
            j=nu
            5 if(j == 0) go to 40
            call HPACC(maxtri,9,data,nu,iwork,node,j)
            if(node(1) <= epsabs*node(9)/ATOT) then
                call HPINS(maxtri,9,data,nd,iwork(maxtri+1),node,GREATR)
                call HPDEL(maxtri,9,data,nu,iwork,GREATR,j)
                if(j > nu) j=j-1
            else
                j=j-1
            end if
            go to 5
        end if
    end if
    go to 40

    end subroutine DTWODQ

    function GREATR(A,B,NWDS)

    implicit none

    logical :: GREATR
    integer :: NWDS
    real (wp), dimension(NWDS) :: A, B

    GREATR= A(1) > B(1)
    return

    end function GREATR

    subroutine HINITD(NMAX,NWDS,N,T)
!   PURPOSE
!         THIS ROUTINE INITIALIZES THE HEAP PROGRAMS WITH T(NMAX)
!         POINTING TO THE TOP OF THE HEAP.
!         IT IS CALLED ONCE AT THE START OF EACH NEW CALCULATION.
!   INPUT
!         NMAX=MAXIMUM NUMBER OF NODES ALLOWED BY USER
!         NWDS=NUMBER OF WORDS PER NODE
!   OUTPUT
!         N=CURRENT NUMBER OF NODES IN HEAP = 0.
!         T=INTEGER ARRAY OF POINTERS TO POTENTIAL HEAP NODES.

    implicit none

    integer, dimension(1) :: T
    integer :: NMAX, NWDS, N, I

    do I=1,NMAX
        T(I)=(NMAX-I)*NWDS+1
    end do
    N=0
    return

    end subroutine HINITD

    subroutine HINITU(NMAX,NWDS,N,T)
!        H E A P  PACKAGE
!          A COLLECTION OF PROGRAMS WHICH MAINTAIN A HEAP DATA
!          STRUCTURE.  BY CALLING THESE SUBROUTINES IT IS POSSIBLE TO
!          INSERT, DELETE, AND ACCESS AN EXISTING HEAP OR TO BUILD A
!          NEW HEAP FROM AN UNORDERED COLLECTION OF NODES. THE HEAP
!          FUNCTION IS AN ARGUMENT TO THE SUBROUTINES ALLOWING VERY
!          GENERAL ORGANIZATIONS.
!            THE USER MUST DECIDE ON THE MAXIMUM NUMBER OF NODES
!          ALLOWED AND DIMENSION THE real (wp) ARRAY DATA AND THE INTEGER
!          ARRAY T USED INTERNALLY BY THE PACKAGE.  THESE VARIABLES ARE
!          THEN PASSED THROUGH THE CALL SEQUENCE BETWEEN THE HEAP
!          PROGRAMS BUT ARE NOT IN GENERAL ACCESSED BY THE USER.  HE
!          MUST ALSO PROVIDE A HEAP FUNCTION WHOSE NAME MUST BE INCLUD-
!          ED IN AN EXTERNAL STATEMENT IN THE USER PROGRAM WHICH CALLS
!          THE HEAP SUBROUTINES.  TWO SIMPLE HEAP FUNCTIONS ARE
!          PROVIDED WITH THE PACKAGE.

!   PURPOSE
!         THIS ROUTINE INITIALIZES THE HEAP PROGRAMS WITH T(1)
!         POINTING TO THE TOP OF THE HEAP.
!         IT IS CALLED ONCE AT THE START OF EACH NEW CALCULATION
!   INPUT
!         NMAX = MAXIMUM NUMBER OF NODES ALLOWED BY USER.
!         NWDS = NUMBER OF WORDS PER NODE
!   OUTPUT
!         N = CURRENT NUMBER OF NODES IN HEAP = 0.
!         T = integer ARRAY OF POINTERS TO POTENTIAL HEAP NODES.

    implicit none

    integer, dimension(1) :: T
    integer :: NMAX, NWDS, N, I

    do I=1,NMAX
        T(I)=(I-1)*NWDS+1
    end do
    N = 0
    return

    end subroutine HINITU

    subroutine HPACC(NMAX,NWDS,DATA,N,T,XNODE,K)

!   PURPOSE
!          TO ACCESS THE K-TH NODE OF THE HEAP,
!          1 .LE. K .LE. N .LE. NMAX
!   INPUT
!        NMAX = MAXIMUM NUMBER OF NODES ALLOWED BY USER.
!        DATA = WORK AREA FOR STORING NODES.
!        N = CURRENT NUMBER OF NODES IN THE HEAP.
!        T = integer ARRAY OF POINTERS TO HEAP NODES.
!        XNODE = A real (wp) ARRAY, NWDS WORDS LONG, IN WHICH NODAL IN-
!          FORMATION WILL BE INSERTED.
!        K = THE INDEX OF THE NODE TO BE FOUND AND INSERTED INTO
!                XNODE.

!   OUTPUT
!        XNODE =  A real (wp) ARRAY.    CONTAINS IN XNODE(1),...,XNODE(NWDS)
!          THE ELEMENTS OF THE K-TH NODE.

    implicit none

    real (wp), dimension(1) :: DATA, XNODE
    integer, dimension(1) :: T
    integer :: NMAX, NWDS, N, K, I, IPJ, J

    if (K < 1 .OR. K > N .OR. N > NMAX) return
    J=T(K)-1
    do I=1,NWDS
        IPJ=I+J
        XNODE(I)=DATA(IPJ)
    end do
    return

    end subroutine HPACC

    subroutine HPBLD(NMAX,NWDS,DATA,N,T,HPFUN)

!   PURPOSE
!          BUILDS A HEAP, IN  T , FROM AN ARRAY OF  N  ELEMENTS
!            IN DATA, WHICH ARE SPACED NWDS APART.
!            AT CONCLUSION OF CALCULATION  THE TOP SATISFIES
!            HPFUN(TOP,SON) = .TRUE. FOR ANY SON.
!          USES subroutine HPGRO BY FEEDING IT ONE ELEMENT OF
!          THE ARRAY AT A TIME.

!   INPUT
!         NMAX = MAXIMUN NUMBER OF NODES ALLOWED BY USER.
!         NWDS = NUMBER OF WORDS PER NODE.
!         DATA = WORK AREA IN WHICH THE NODES ARE STORED.
!         N = CURRENT NUMBER OF NODES.
!         T = integer ARRAY OF POINTERS TO HEAP NODES.
!         HPFUN = NAME OF USER WRITTEN FUNCTION TO DETERMINE TOP NODE.
!   OUTPUT
!         DATA = WORK AREA IN WHICH THE NODES ARE STORED.
!         T = integer ARRAY OF POINTERS TO HEAP NODES.
!              IN PARTICULAR T(1) POINTS TO THE TOP.

    implicit none

    external HPFUN
    logical :: HPFUN
    real (wp), dimension(1) :: DATA
    integer, dimension(1) :: T
    integer :: NMAX, NWDS, N, INDEX

    if (NMAX < N) return
    INDEX = N/2
    1 continue
    if ( INDEX == 0) return
    call HPGRO(NMAX,NWDS,DATA,N,T,HPFUN,INDEX)
    INDEX = INDEX-1
    GO TO 1

    end subroutine HPBLD

    subroutine HPDEL(NMAX,NWDS,DATA,N,T,HPFUN,K)

!   PURPOSE
!          DELETE K-TH ELEMENT OF HEAP.  RESULTING TREE IS REHEAPED.
!   INPUT
!         NMAX = MAXIMUN NUMBER OF NODES ALLOWED BY USER.
!         NWDS = NUMBER OF WORDS PER NODE.
!         DATA = WORK AREA IN WHICH THE NODES ARE STORED.
!        N = CURRENT NUMBER OF NODES.
!        T = integer ARRAY OF POINTERS TO NODES.
!         HPFUN = NAME OF USER WRITTEN FUNCTION TO DETERMINE TOP NODE.
!         K = INDEX OF NODE TO BE DELETED
!   OUTPUT
!         N = UPDATED NUMBER OF NODES.
!         T = UPDATED integer POINTER ARRAY TO NODES.

    implicit none

    external HPFUN
    logical :: HPFUN
    real (wp), dimension(1) :: DATA
    integer, dimension(1) :: T
    integer :: NMAX, NWDS, N, K, IL, IR, JUNK, KDEL, KHALVE

    if (N == 0) return
    if (K == N) then
        N=N-1
        return
    end if
    KDEL=K
    JUNK=T(KDEL)
    T(KDEL)=T(N)
    T(N)=JUNK
    N=N-1
    10 if (KDEL == 1) then
        CALL HPGRO(NMAX,NWDS,DATA,N,T,HPFUN,KDEL)
        return
    else
        KHALVE=KDEL/2
        IL=T(KHALVE)
        IR=T(KDEL)
        if (HPFUN(DATA(IL),DATA(IR),NWDS)) then
            CALL HPGRO(NMAX,NWDS,DATA,N,T,HPFUN,KDEL)
            return
        else
            T(KHALVE)=IR
            T(KDEL)=IL
            KDEL=KHALVE
        end if
    end if
    GO TO 10

    end subroutine HPDEL

    subroutine HPGRO(NMAX,NWDS,DATA,N,T,HPFUN,I)

!   PURPOSE
!          FORMS A HEAP OUT OF A TREE. USED PRIVATELY BY HPBLD.
!          THE TOP OF THE TREE IS STORED IN LOCATION T(I).
!          FIRST SON IS IN LOCATION T(2I), NEXT SON
!          IS IN LOCATION T(2I+1).
!          THIS PROGRAM ASSUMES EACH BRANCH OF THE TREE IS A HEAP.

    implicit none

    logical :: HPFUN
    real (wp), dimension(1) :: DATA
    integer, dimension(1) :: T
    integer :: NMAX, NWDS, N, I, IL, IR, ITEMP, J, K

    if (N > NMAX) return

    K=I
    1 J=2*K

!          TEST IF ELEMENT IN J TH POSITION IS A LEAF.

    if ( J > N ) return

!          IF THERE IS MORE THAN ONE SON, FIND WHICH SON IS SMALLEST.

    if ( J == N ) GO TO 2
    IR=T(J)
    IL=T(J+1)
    if (HPFUN(DATA(IL),DATA(IR),NWDS)) J=J+1

!          IF A SON IS LARGER THAN FATHER, INTERCHANGE
!          THIS DESTROYS HEAP PROPERTY, SO MUST RE-HEAP REMAINING
!          ELEMENTS

    2 continue
    IL=T(K)
    IR=T(J)
    if (HPFUN(DATA(IL),DATA(IR),NWDS)) return
    ITEMP=T(J)
    T(J)=T(K)
    T(K)=ITEMP
    K=J
    GO TO 1
    end subroutine HPGRO

    subroutine HPINS(NMAX,NWDS,DATA,N,T,XNODE,HPFUN)

!   PURPOSE
!         THIS ROUTINE INSERTS A NODE INTO AN ALREADY EXISTING HEAP.
!             THE RESULTING TREE IS RE-HEAPED.

!   INPUT
!         NMAX = MAXIMUM NUMBER OF NODES ALLOWED BY USER.
!         NWDS = NUMBER OF WORDS PER NODE.
!         DATA = WORK AREA FOR STORING NODES.
!         N = CURRENT NUMBER OF NODES IN THE TREE.
!         T = integer ARRAY OF POINTERS TO HEAP NODES.
!         XNODE = A real (wp) ARRAY, NWDS WORDS LONG, WHICH
!                CONTAINS THE NODAL INFORMATION TO BE INSERTED.
!         HPFUN = NAME OF USER WRITTEN FUNCTION TO DETERMINE
!                THE TOP NODE.
!   OUTPUT
!         DATA = WORK AREA WITH NEW NODE INSERTED.
!         N = UPDATED NUMBER OF NODES.
!         T = UPDATED integer POINTER ARRAY.

    implicit none

    logical :: HPFUN
    real (wp) :: XNODE(1),DATA(1)
    integer :: T(1)
    integer :: NMAX, NWDS, N, I, IPJ, J, J2, JL, JR

    if (N == NMAX) return
    N=N+1
    J= T(N)-1
    do 1 I= 1,NWDS
        IPJ=I+J
        DATA(IPJ) = XNODE(I)
    1 end do
    J=N
    2 continue
    if (J == 1) return
    JR=T(J)
    J2=J/2
    JL=T(J2)
    if (HPFUN(DATA(JL),DATA(JR),NWDS)) return
    T(J2)=T(J)
    T(J)=JL
    J=J2
    GO TO 2

    end subroutine HPINS

    function LESS(A,B,NWDS)

    implicit none

    logical :: LESS
    integer :: NWDS
    real (wp), dimension(NWDS) :: A, B

    LESS= A(1) < B(1)
    return

    end function LESS

    subroutine LQM0(F,U,V,RES8,EST)

!      PURPOSE
!           TO COMPUTE - IF = INTEGRAL OF F OVER THE TRIANGLE
!           WITH VERTICES (U(1),V(1)),(U(2),V(2)),(U(3),V(3)), AND
!           ESTIMATE THE ERROR,
!                      - INTEGRAL OF ABS(F) OVER THIS TRIANGLE

!      CALLING SEQUENCE
!           CALL LQM0(F,U,V,RES11,EST)
!        PARAMETERS
!           F       - FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
!                     F(X,Y); THE ACTUAL NAME FOR F NEEDS TO BE
!                     DECLARED E X T E R N A L IN THE CALLING
!                     PROGRAM
!           U(1),U(2),U(3)- ABSCISSAE OF VERTICES
!           V(1),V(2),V(3)- ORDINATES OF VERTICES
!           RES6    - APPROXIMATION TO THE INTEGRAL IF, OBTAINED BY THE
!                     LYNESS AND JESPERSEN RULE OF DEGREE 6, USING
!                     12 POINTS
!           RES8   - APPROXIMATION TO THE INTEGRAL IF, OBTAINED BY THE
!                     LYNESS AND JESPERSEN RULE OF DEGREE 8,
!                     USING 16 POINTS
!           EST     - ESTIMATE OF THE ABSOLUTE ERROR
!           DRESC   - APPROXIMATION TO THE INTEGRAL OF ABS(F- IF/DJ),
!                     OBTAINED BY THE RULE OF DEGREE 6, AND USED FOR
!                     THE COMPUTATION OF EST

!      REMARKS
!           DATE OF LAST UPDATE : 10 APRIL 1984 O.W. RECHARD NBS

!           SUBROUTINES OR FUNCTIONS CALLED :
!                   - F (USER-SUPPLIED INTEGRAND FUNCTION)
!                   - R1MACH FOR MACHINE DEPENDENT INFORMATION

! .....................................................................

    implicit none

    real (wp) :: DJ,DF0,DRESC,EMACH,EST,F,F0, &
    RES6,RES8,U1,U2,U3,UFLOW,V1,V2,V3,W60,W80, &
    Z1,Z2,Z3,RESAB6
    real (wp) :: AMAX1,AMIN1,SQRT
    real (wp), dimension(3) :: U,V,X,Y
    real (wp), dimension(9) :: W,ZETA1,ZETA2
    real (wp), dimension(19) :: FV
    integer :: J,KOUNT,L

!            FIRST HOMOGENEOUS COORDINATES OF POINTS IN DEGREE-6
!            AND DEGREE-8 FORMULA, TAKEN WITH MULTIPLICITY 3
    DATA ZETA1(1),ZETA1(2),ZETA1(3),ZETA1(4),ZETA1(5),ZETA1(6),ZETA1(7 &
    ),ZETA1(8),ZETA1(9)/0.5014265096581342E+00, &
    &   0.8738219710169965E+00,0.6365024991213939E+00, &
    &   0.5314504984483216E-01,0.8141482341455413E-01, &
    &   0.8989055433659379E+00,0.6588613844964797E+00, &
    &   0.8394777409957211E-02,0.7284923929554041E+00/
!            SECOND HOMOGENEOUS COORDINATES OF POINTS IN DEGREE-6
!            AND DEGREE-8 FORMULA, TAKEN WITH MUNLTIPLICITY 3
    DATA ZETA2(1),ZETA2(2),ZETA2(3),ZETA2(4),ZETA2(5),ZETA2(6),ZETA2(7 &
    ),ZETA2(8),ZETA2(9)/0.2492867451709329E+00, &
    &   0.6308901449150177E-01,0.5314504984483216E-01, &
    &   0.6365024991213939E+00,0.4592925882927229E+00, &
    &   0.5054722831703103E-01,0.1705693077517601E+00, &
    &   0.7284923929554041E+00,0.8394777409957211E-02/
!           WEIGHTS OF MID-POINT OF TRIANGLE IN DEGREE-6
!           RESP. DEGREE-8 FORMULAE
    DATA W60/0.0E+00/
    DATA W80/0.1443156076777862E+00/
!           WEIGHTS IN DEGREE-6 AND DEGREE-8 RULE
    DATA W(1),W(2),W(3),W(4),W(5),W(6),W(7),W(8),W(9)/ &
    &   0.1167862757263407E+00,0.5084490637020547E-01, &
    &   0.8285107561839291E-01,0.8285107561839291E-01, &
    &   0.9509163426728497E-01,0.3245849762319813E-01, &
    &   0.1032173705347184E+00,0.2723031417443487E-01, &
    &   0.2723031417443487E-01/

!           LIST OF MAJOR VARIABLES
!           ----------------------
!           DJ      - AREA OF THE TRIANGLE
!           DRESC   - APPROXIMATION TO INTEGRAL OF
!                     ABS(F- IF/DJ)  OVER THE TRIANGLE
!           RESAB6  - APPROXIMATION TO INTEGRAL OF
!                     ABS(F) OVER THE TRIANGLE
!           X       - CARTESIAN ABSCISSAE OF THE INTEGRATION
!                     POINTS
!           Y       - CARTESIAN ORDINATES OF THE INTEGRATION
!                     POINTS
!           FV      - FUNCTION VALUES

!           COMPUTE DEGREE-6 AND DEGREE-8 RESULTS FOR IF/DJ AND
!           DEGREE-6 APPROXIMATION FOR ABS(F)

    EMACH = R1MACH(4)
    UFLOW = R1MACH(1)
    U1=U(1)
    U2=U(2)
    U3=U(3)
    V1=V(1)
    V2=V(2)
    V3=V(3)
    DJ = ABS(U1*V2-U2*V1-U1*V3+V1*U3+U2*V3-V2*U3)*0.5E+00
    F0 = F((U1+U2+U3)/3.0E+00,(V1+V2+V3)/3.0E+00)
    RES6 = F0*W60
    RESAB6 = ABS(F0)*W60
    FV(1) = F0
    KOUNT = 1
    RES8 = F0*W80
    do 50 J=1,9
        Z1 = ZETA1(J)
        Z2 = ZETA2(J)
        Z3 = 1.0E+00-Z1-Z2
        X(1) = Z1*U1+Z2*U2+Z3*U3
        Y(1) = Z1*V1+Z2*V2+Z3*V3
        X(2) = Z2*U1+Z3*U2+Z1*U3
        Y(2) = Z2*V1+Z3*V2+Z1*V3
        X(3) = Z3*U1+Z1*U2+Z2*U3
        Y(3) = Z3*V1+Z1*V2+Z2*V3
        if (J <= 4) then
            F0 = 0.0E+00
            DF0 = 0.0E+00
            do 10 L=1,3
                KOUNT = KOUNT+1
                FV(KOUNT) = F(X(L),Y(L))
                F0 = F0+FV(KOUNT)
                DF0 = DF0+ABS(FV(KOUNT))
            10 end do
            RES6 = RES6+F0*W(J)
            RESAB6 = RESAB6+DF0*W(J)
        else
            F0 = F(X(1),Y(1))+F(X(2),Y(2))+F(X(3),Y(3))
            RES8 = RES8+F0*W(J)
        end if
    50 end do

!           COMPUTE DEGREE-6 APPROXIMATION FOR THE INTEGRAL OF
!           ABS(F-IF/DJ)

    DRESC = ABS(FV(1)-RES6)*W60
    KOUNT = 2
    do 60 J=1,4
        DRESC = DRESC+(ABS(FV(KOUNT)-RES6)+ABS(FV(KOUNT+1)-RES6)+ABS( &
        FV(KOUNT+2)-RES6))*W(J)
        KOUNT = KOUNT+3
    60 end do

!           COMPUTE DEGREE-6 AND DEGREE-8 APPROXIMATIONS FOR IF,
!           AND ERROR ESTIMATE

    RES6 = RES6*DJ
    RES8 = RES8*DJ
    RESAB6 = RESAB6*DJ
    DRESC = DRESC*DJ
    EST = ABS(RES6-RES8)
    if (DRESC /= 0.0E+00) EST = AMAX1(EST,DRESC*AMIN1(1.0E+00,(20.0E+00 &
    *EST/DRESC)**1.5E+00))
    if (RESAB6 > UFLOW) EST = AMAX1(EMACH*RESAB6,EST)
    return

    end subroutine LQM0

    subroutine LQM1(F,U,V,RES11,EST)

!      PURPOSE
!           TO COMPUTE - IF = INTEGRAL OF F OVER THE TRIANGLE
!           WITH VERTICES (U(1),V(1)),(U(2),V(2)),(U(3),V(3)), AND
!           ESTIMATE THE ERROR,
!                      - INTEGRAL OF ABS(F) OVER THIS TRIANGLE

!      CALLING SEQUENCE
!           CALL LQM1(F,U,V,RES11,EST)
!        PARAMETERS
!           F       - FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
!                     F(X,Y); THE ACTUAL NAME FOR F NEEDS TO BE
!                     DECLARED E X T E R N A L IN THE CALLING
!                     PROGRAM
!           U(1),U(2),U(3)- ABSCISSAE OF VERTICES
!           V(1),V(2),V(3)- ORDINATES OF VERTICES
!           RES9    - APPROXIMATION TO THE INTEGRAL IF, OBTAINED BY THE
!                     LYNESS AND JESPERSEN RULE OF DEGREE 9, USING
!                     19 POINTS
!           RES11   - APPROXIMATION TO THE INTEGRAL IF, OBTAINED BY THE
!                     LYNESS AND JESPERSEN RULE OF DEGREE 11,
!                     USING 28 POINTS
!           EST     - ESTIMATE OF THE ABSOLUTE ERROR
!           DRESC   - APPROXIMATION TO THE INTEGRAL OF ABS(F- IF/DJ),
!                     OBTAINED BY THE RULE OF DEGREE 9, AND USED FOR
!                     THE COMPUTATION OF EST

!      REMARKS
!           DATE OF LAST UPDATE : 18 JAN 1984 D. KAHANER NBS

!           SUBROUTINES OR FUNCTIONS CALLED :
!                   - F (USER-SUPPLIED INTEGRAND FUNCTION)
!                   - R1MACH FOR MACHINE DEPENDENT INFORMATION

! .....................................................................

    implicit none

    real (wp) :: DJ,DF0,DRESC,EMACH,EST,F,F0, &
    RES9,RES11,U1,U2,U3,UFLOW,V1,V2,V3,W90,W110, &
    Z1,Z2,Z3
    real (wp) :: AMAX1,AMIN1,SQRT
    real (wp) :: RESAB9
    real (wp), dimension(3) :: U,V,X,Y
    real (wp), dimension(15) :: W,ZETA1,ZETA2
    real (wp), dimension(19) :: FV
    integer :: J,KOUNT,L

!            FIRST HOMOGENEOUS COORDINATES OF POINTS IN DEGREE-9
!            AND DEGREE-11 FORMULA, TAKEN WITH MULTIPLICITY 3
    DATA ZETA1(1),ZETA1(2),ZETA1(3),ZETA1(4),ZETA1(5),ZETA1(6),ZETA1(7 &
    ),ZETA1(8),ZETA1(9),ZETA1(10),ZETA1(11),ZETA1(12),ZETA1(13), &
    ZETA1(14),ZETA1(15)/0.2063496160252593E-01,0.1258208170141290E+00, &
    &   0.6235929287619356E+00,0.9105409732110941E+00, &
    &   0.3683841205473626E-01,0.7411985987844980E+00, &
    &   0.9480217181434233E+00,0.8114249947041546E+00, &
    &   0.1072644996557060E-01,0.5853132347709715E+00, &
    &   0.1221843885990187E+00,0.4484167758913055E-01, &
    &   0.6779376548825902E+00,0.0E+00,0.8588702812826364E+00/
!            SECOND HOMOGENEOUS COORDINATES OF POINTS IN DEGREE-9
!            AND DEGREE-11 FORMULA, TAKEN WITH MUNLTIPLICITY 3
    DATA ZETA2(1),ZETA2(2),ZETA2(3),ZETA2(4),ZETA2(5),ZETA2(6),ZETA2(7 &
    ),ZETA2(8),ZETA2(9),ZETA2(10),ZETA2(11),ZETA2(12),ZETA2(13), &
    ZETA2(14),ZETA2(15)/0.4896825191987370E+00,0.4370895914929355E+00, &
    &   0.1882035356190322E+00,0.4472951339445297E-01, &
    &   0.7411985987844980E+00,0.3683841205473626E-01, &
    &   0.2598914092828833E-01,0.9428750264792270E-01, &
    &   0.4946367750172147E+00,0.2073433826145142E+00, &
    &   0.4389078057004907E+00,0.6779376548825902E+00, &
    &   0.4484167758913055E-01,0.8588702812826364E+00,0.0E+00/
!           WEIGHTS OF MID-POINT OF TRIANGLE IN DEGREE-9
!           RESP. DEGREE-11 FORMULAE
    DATA W90/0.9713579628279610E-01/
    DATA W110/0.8797730116222190E-01/
!           WEIGHTS IN DEGREE-9 AND DEGREE-11 RULE
    DATA W(1),W(2),W(3),W(4),W(5),W(6),W(7),W(8),W(9),W(10),W(11),W(12 &
    ),W(13),W(14),W(15)/0.3133470022713983E-01,0.7782754100477543E-01, &
    &   0.7964773892720910E-01,0.2557767565869810E-01, &
    &   0.4328353937728940E-01,0.4328353937728940E-01, &
    &   0.8744311553736190E-02,0.3808157199393533E-01, &
    &   0.1885544805613125E-01,0.7215969754474100E-01, &
    &   0.6932913870553720E-01,0.4105631542928860E-01, &
    &   0.4105631542928860E-01,0.7362383783300573E-02, &
    &   0.7362383783300573E-02/

!           LIST OF MAJOR VARIABLES
!           ----------------------
!           DJ      - AREA OF THE TRIANGLE
!           DRESC   - APPROXIMATION TO INTEGRAL OF
!                     ABS(F- IF/DJ)  OVER THE TRIANGLE
!           RESAB9  - APPROXIMATION TO INTEGRAL OF
!                     ABS(F) OVER THE TRIANGLE
!           X       - CARTESIAN ABSCISSAE OF THE INTEGRATION
!                     POINTS
!           Y       - CARTESIAN ORDINATES OF THE INTEGRATION
!                     POINTS
!           FV      - FUNCTION VALUES

!           COMPUTE DEGREE-9 AND DEGREE-11 RESULTS FOR IF/DJ AND
!           DEGREE-9 APPROXIMATION FOR ABS(F)

    EMACH = R1MACH(4)
    UFLOW = R1MACH(1)
    U1=U(1)
    U2=U(2)
    U3=U(3)
    V1=V(1)
    V2=V(2)
    V3=V(3)
    DJ = ABS(U1*V2-U2*V1-U1*V3+V1*U3+U2*V3-V2*U3)*0.5E+00
    F0 = F((U1+U2+U3)/3.0E+00,(V1+V2+V3)/3.0E+00)
    RES9 = F0*W90
    RESAB9 = ABS(F0)*W90
    FV(1) = F0
    KOUNT = 1
    RES11 = F0*W110
    do 50 J=1,15
        Z1 = ZETA1(J)
        Z2 = ZETA2(J)
        Z3 = 1.0E+00-Z1-Z2
        X(1) = Z1*U1+Z2*U2+Z3*U3
        Y(1) = Z1*V1+Z2*V2+Z3*V3
        X(2) = Z2*U1+Z3*U2+Z1*U3
        Y(2) = Z2*V1+Z3*V2+Z1*V3
        X(3) = Z3*U1+Z1*U2+Z2*U3
        Y(3) = Z3*V1+Z1*V2+Z2*V3
        if (J <= 6) then
            F0 = 0.0E+00
            DF0 = 0.0E+00
            do 10 L=1,3
                KOUNT = KOUNT+1
                FV(KOUNT) = F(X(L),Y(L))
                F0 = F0+FV(KOUNT)
                DF0 = DF0+ABS(FV(KOUNT))
            10 end do
            RES9 = RES9+F0*W(J)
            RESAB9 = RESAB9+DF0*W(J)
        else
            F0 = F(X(1),Y(1))+F(X(2),Y(2))+F(X(3),Y(3))
            RES11 = RES11+F0*W(J)
        end if
    50 end do

!           COMPUTE DEGREE-9 APPROXIMATION FOR THE INTEGRAL OF
!           ABS(F-IF/DJ)

    DRESC = ABS(FV(1)-RES9)*W90
    KOUNT = 2
    do 60 J=1,6
        DRESC = DRESC+(ABS(FV(KOUNT)-RES9)+ABS(FV(KOUNT+1)-RES9)+ABS( &
        FV(KOUNT+2)-RES9))*W(J)
        KOUNT = KOUNT+3
    60 end do

!           COMPUTE DEGREE-9 AND DEGREE-11 APPROXIMATIONS FOR IF,
!           AND ERROR ESTIMATE

    RES9 = RES9*DJ
    RES11 = RES11*DJ
    RESAB9 = RESAB9*DJ
    DRESC = DRESC*DJ
    EST = ABS(RES9-RES11)
    if (DRESC /= 0.0E+00) EST = AMAX1(EST,DRESC*AMIN1(1.0E+00,(20.0E+00 &
    *EST/DRESC)**1.5E+00))
    if (RESAB9 > UFLOW) EST = AMAX1(EMACH*RESAB9,EST)
    return

    end subroutine LQM1

    subroutine tridv(node,node1,node2,coef,rank)

    implicit none

    real (wp) :: coef,coef1,temp
    real (wp), dimension(*) :: node,node1,node2
    integer :: rank, i, j
    real (wp), dimension(3) :: s
    integer, dimension(3) :: t

    coef1=1.0-coef
    s(1)=(node(3)-node(5))**2+(node(4)-node(6))**2
    s(2)=(node(5)-node(7))**2+(node(6)-node(8))**2
    s(3)=(node(3)-node(7))**2+(node(4)-node(8))**2
    t(1)=1
    t(2)=2
    t(3)=3
    do 10 i=1,2
        do 10 j=i+1,3
            if(s(i) < s(j)) then
                temp=t(i)
                t(i)=t(j)
                t(j)=temp
            end if
    10 end do
    if(t(rank) == 1)then
        node1(3)=coef*node(3)+coef1*node(5)
        node1(4)=coef*node(4)+coef1*node(6)
        node1(5)=node(5)
        node1(6)=node(6)
        node1(7)=node(7)
        node1(8)=node(8)
        node2(3)=node1(3)
        node2(4)=node1(4)
        node2(5)=node(7)
        node2(6)=node(8)
        node2(7)=node(3)
        node2(8)=node(4)
    else if(t(rank) == 2) then
        node1(3)=coef*node(5)+coef1*node(7)
        node1(4)=coef*node(6)+coef1*node(8)
        node1(5)=node(7)
        node1(6)=node(8)
        node1(7)=node(3)
        node1(8)=node(4)
        node2(3)=node1(3)
        node2(4)=node1(4)
        node2(5)=node(3)
        node2(6)=node(4)
        node2(7)=node(5)
        node2(8)=node(6)
    else
        node1(3)=coef*node(3)+coef1*node(7)
        node1(4)=coef*node(4)+coef1*node(8)
        node1(5)=node(3)
        node1(6)=node(4)
        node1(7)=node(5)
        node1(8)=node(6)
        node2(3)=node1(3)
        node2(4)=node1(4)
        node2(5)=node(5)
        node2(6)=node(6)
        node2(7)=node(7)
        node2(8)=node(8)
    end if
    node1(9)=coef*node(9)
    node2(9)=coef1*node(9)

    end subroutine tridv

! ECK R1MACH
    function R1MACH(I)

    implicit none

    integer :: I
    real (wp) :: B, X, R1MACH
!***BEGIN PROLOGUE  R1MACH
!***PURPOSE  Return floating point machine dependent constants.
!***LIBRARY   SLATEC
!***CATEGORY  R1
!***TYPE      SINGLE PRECISION (R1MACH-S, D1MACH-D)
!***KEYWORDS  MACHINE CONSTANTS
!***AUTHOR  Fox, P. A., (Bell Labs)
!           Hall, A. D., (Bell Labs)
!           Schryer, N. L., (Bell Labs)
!***DESCRIPTION
!
!   R1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  It is a function subprogram with one
!   (input) argument, and can be referenced as follows:
!
!        A = R1MACH(I)
!
!   where I=1,...,5.  The (output) value of A above is determined by
!   the (input) value of I.  The results for various values of I are
!   discussed below.
!
!   R1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!   R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
!   R1MACH(3) = B**(-T), the smallest relative spacing.
!   R1MACH(4) = B**(1-T), the largest relative spacing.
!   R1MACH(5) = LOG10(B)
!
!   Assume single precision numbers are represented in the T-digit,
!   base-B form
!
!              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!   where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and
!   EMIN .LE. E .LE. EMAX.
!
!   The values of B, T, EMIN and EMAX are provided in I1MACH as
!   follows:
!   I1MACH(10) = B, the base.
!   I1MACH(11) = T, the number of base-B digits.
!   I1MACH(12) = EMIN, the smallest exponent E.
!   I1MACH(13) = EMAX, the largest exponent E.
!
!
!***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
!                 a portable library, ACM Transactions on Mathematical
!                 Software 4, 2 (June 1978), pp. 177-188.
!***ROUTINES CALLED  XERMSG
!***REVISION HISTORY  (YYMMDD)
!   790101  DATE WRITTEN
!   960329  Modified for Fortran 90 (BE after suggestions by EG)
!***END PROLOGUE  R1MACH
!
    X = 1.0
    B = RADIX(X)
    select case (I)
        case (1)
            R1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude.
        case (2)
            R1MACH = HUGE(X)               ! the largest magnitude.
        case (3)
            R1MACH = B**(-DIGITS(X))       ! the smallest relative spacing.
        case (4)
            R1MACH = B**(1-DIGITS(X))      ! the largest relative spacing.
        case (5)
            R1MACH = LOG10(B)
        case DEFAULT
            write (*, FMT = 9000)
            9000 FORMAT ('1ERROR    1 IN R1MACH - I OUT OF BOUNDS')
            STOP
    end select
    return

    end function R1MACH

end module dtwodq_mod


!-------------------------------------------------------------------
!..AN EXPLICIT FD SOLVER FOR THE 1-D LINEAR CONVECTION EQUATION
!-------------------------------------------------------------------
Module vars
   integer, parameter :: imax=401, ntout=1
   integer :: ntmax, method
   real, dimension(imax) :: wave_n, wave_np1, wave_nm1
   real :: sigma, dx=0.1, x1 , pi= 3.1415926 !ACOS(-1.)
   real :: d, b=0.025
 End module

 program EXPLICIT_FDE
    use vars

    call INIT             !..Read the input data, and initialize the wave
    DO nt = 1,ntmax       !..Start the solution loop
       do i = 2,imax-1
          if(method .eq. 1) then
          wave_np1(i) = wave_n(i) - 0.5*sigma*(wave_n(i+1) - wave_n(i-1)) + d *(wave_n(i+1) - 2 * wave_n(i) + wave_n(i-1))
          elseif(method .eq. 2) then
                if(i.eq.2) then
                   wave_np1(i) = wave_n(i) - 0.5*sigma*(wave_n(i+1) - wave_n(i-1)) + d *(wave_n(i+1) - 2 * wave_n(i) + wave_n(i-1))
                else
                   wave_np1(i) = wave_n(i) - sigma*(wave_n(i) - wave_n(i-1)) + d *(wave_n(i) - 2 * wave_n(i-1) + wave_n(i-2))
                endif
          elseif(method .eq. 3) then
                if(nt .eq. 1) then
                   wave_np1(i) = wave_n(i) - 0.5*sigma*(wave_n(i+1) - wave_n(i-1)) + d *(wave_n(i+1) - 2 * wave_n(i) + wave_n(i-1))
                else
                   wave_np1(i) = 4*wave_n(i) - 3*wave_nm1(i) + sigma*(wave_n(i+1) - wave_n(i-1)) &
                   - 2*d*(wave_n(i+1) - 2*wave_n(i) + wave_n(i-1))
                endif
          endif
       enddo
       wave_nm1(:) = wave_n(:)
       wave_n(:) = wave_np1(:)
 !..Output intermediate solutions
       if( MOD(nt,ntout) .eq. 0 .or. nt .eq. ntmax ) call IO(nt)
    ENDDO

    stop
 end program EXPLICIT_FDE

 !------------------------------------------------------------------------
 subroutine INIT
   use vars
   write(*,'(a)')'Select method'
   write(*,'(a)')' [1] Forward time central spatial'
   write(*,'(a)')' [2] Forward time backward spatial'
   write(*,'(a)')' [3] Question 4'
   read(*,*) method
   if((method .ne. 1) .and. (method .ne. 2) .and. (method .ne. 3)) then
    write(*,'(a)') "Invalid selection"
    stop
   endif

   write(*,'(/(a))',advance='no')'  Enter sigma, d and ntmax : '
   read(*,*) sigma, d, ntmax
   x1=-imax*dx/2.
   x = x1
   do i = 1,imax             !..Initialize the wave
      wave_n(i) = exp(-b * log(2.) * (x/dx)**2)
      x = x+dx
   enddo
   call IO(0)

   return
 end subroutine INIT

 !-------------------------------------------------------------------
 subroutine  IO(nt)
    use vars
    character :: fname*32,string*6,ext*3
    write(string,'(f5.3)') float(nt)/1000
    read(string,'(2x,a3)') ext
    fname = 'wave-'//ext//'.dat'
    open(1,file=fname,form='formatted')
    !write(1,*)'ZONE'
    x = x1
    do i=1,imax
      write(1,'(2e14.6)')x, wave_n(i)
      x = x+dx
    enddo
    close(1)
    return
 end


subroutine ssrkf45(neqn,t0,u0,h,t,u,e)
!
! Subroutine ssrkf45 computes an ODE solution by the RK
! Fehlberg 45 method for one step along the solution (by
! calls to derv to define the ODE derivative vector).
! It also estimates the truncation error of the solution,
! and applies this estimate as a correction to the
! solution vector.
!
! Argument list
!
! neqn number of first order ODEs
!
! t0 initial value of independent variable
!
! u0 initial condition vector of length neqn
!
! h integration step
!
! t independent variable
!
! u ODE solution vector of length neqn after
! one rkf45 step
!
! e estimate of truncation error of the solu-
! tion vector
!
! Double precision coding is used
implicit double precision(a-h,k,o-z)
!
! Size the arrays
parameter(neq=500)
dimension ut0(neq), ut(neq), u5(neq),k1(neq), k2(neq), k3(neq),k4(neq), k5(neq), k6(neq)
dimension u0(neqn), u(neqn), e(neqn)
!
! Derivative vector at initial (base) point
call derv(neqn,t0,u0,ut0)
!
! k1, advance of dependent variable vector and
! independent variable for calculation of k2
do i=1,neqn
k1(i)=h*ut0(i)
u(i)=u0(i)+0.25d0*k1(i)
end do
t=t0+0.25d0*h
!
! Derivative vector at new u, t
call derv(neqn,t,u,ut)
!
! k2, advance of dependent variable vector and
! independent variable for calculation of k3
do i=1,neqn
k2(i)=h*ut(i)
u(i)=u0(i)+(3.0d0/32.0d0)*k1(i)+(9.0d0/32.0d0)*k2(i)
end do
t=t0+(3.0d0/8.0d0)*h
!
! Derivative vector at new u, t
call derv(neqn,t,u,ut)
!
! k3, advance of dependent variable vector and
! independent variable for calculation of k4
do i=1,neqn
k3(i)=h*ut(i)
u(i)=u0(i)+(1932.0d0/2197.0d0)*k1(i)-(7200.0d0/2197.0d0)*k2(i)+(7296.0d0/2197.0d0)*k3(i)
end do
t=t0+(12.0d0/13.0d0)*h
!
! Derivative vector at new u, t
call derv(neqn,t,u,ut)
!
! k4, advance of dependent variable vector and
! independent variable for calculation of k5
do i=1,neqn
k4(i)=h*ut(i)
u(i)=u0(i)+( 439.0d0/ 216.0d0)*k1(i)-( 8.0d0 )*k2(i)+(3680.0d0/ 513.0d0)*k3(i)-( 845.0d0/4104.0d0)*k4(i)
end do
t=t0+h
!
! Derivative vector at new u, t
call derv(neqn,t,u,ut)
!
! k5, advance of dependent variable vector and
! independent variable for calculation of k6
do i=1,neqn
k5(i)=h*ut(i)
u(i)=u0(i)-( 8.0d0/ 27.0d0)*k1(i)+( 2.0d0 )*k2(i)-(3544.0d0/2565.0d0)*k3(i)+(1859.0d0/4104.0d0)*k4(i)-( 11.0d0/ 40.0d0)*k5(i)
end do
t=t0+0.5d0*h
!
! Derivative vector at new u, t
call derv(neqn,t,u,ut)
!
! k6, stepping
do i=1,neqn
k6(i)=h*ut(i)
!
! Fourth order step
u(i)=u0(i)+( 25.0d0 / 216.0d0)*k1(i)+(1408.0d0 / 2565.0d0)*k3(i)+(2197.0d0 / 4104.0d0)*k4(i)-( 1.0d0 / 5.0d0)*k5(i)
!
! Fifth order step
u5(i)=u0(i)+( 16.0d0/ 135.0d0)*k1(i)+( 6656.0d0/12825.0d0)*k3(i)+(28561.0d0/56430.0d0)*k4(i)-( 9.0d0/ 50.0d0)*k5(i)+( 2.0d0/ 55.0d0)*k6(i)
end do
do i=1,neqn
!
! Truncation error estimate
e(i)=u5(i)-u(i)
!
! Fifth order solution vector (from (4,5) RK pair)
u(i)=u(i)+e(i)
end do
t=t0+h
return
!
! End of ssrkf45
end


!  PROGRAM: Mandelbrot area
!
!  PURPOSE: Program to compute the area of a  Mandelbrot set.
!           Correct answer should be around 1.510659.
!
!  USAGE:   Program runs without input ... just run the executable
!
!  HISTORY: Written:  (Mark Bull, August 2011).
!           Changed "comples" to "d_comples" to avoid collsion with
!           math.h complex type (Tim Mattson, September 2011)
!           Converted to Fortran90 code (Helen He, September 2017)
!           Changed from "atomic" to "critical" to match Common Core (Helen He, November 2020)

  MODULE  mandel_par_module
  implicit none

  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  INTEGER, PARAMETER :: NPOINTS = 1000
  INTEGER, PARAMETER :: MAXITER = 1000
  INTEGER :: numoutside = 0

  TYPE d_complex
     REAL(KIND = DP) :: r
     REAL(KIND = DP) :: i
  END TYPE d_complex

  contains

     SUBROUTINE testpoint(c)

! Does the iteration z=z*z+c, until |z| > 2 when point is known to be outside set
! If loop count reaches MAXITER, point is considered to be inside the set

     implicit none
     TYPE(d_complex) :: z,c
     INTEGER :: iter
     REAL(KIND = DP) :: temp

     z = c

     DO iter = 1, MAXITER
        temp = (z%r*z%r) - (z%i*z%i) + c%r
        z%i = z%r*z%i*2 + c%i
        z%r = temp

        IF ((z%r*z%r + z%i*z%i) > 4.0) THEN
           !$OMP CRITICAL
               numoutside = numoutside + 1
           !$OMP END CRITICAL
           EXIT
        ENDIF
     ENDDO

     END SUBROUTINE

  END MODULE mandel_par_module

  PROGRAM mandel_par

  USE OMP_LIB
  USE mandel_par_module
  IMPLICIT NONE

  INTEGER :: i, j
  REAL(KIND = DP) :: area, error
  REAL(KIND = DP) :: eps = 1.0e-5

  TYPE(d_complex) :: c

  CALL OMP_SET_NUM_THREADS(4)

! Loop over grid of points in the complex plane which contains the Mandelbrot set,
! testing each point to see whether it is inside or outside the set.

!$OMP PARALLEL DO DEFAULT(shared) FIRSTPRIVATE(eps) PRIVATE(c,j)

  DO i = 1, NPOINTS
  DO j = 1, NPOINTS
     c%r = -2.0 + 2.5 * DBLE(i-1) / DBLE(NPOINTS) + eps
     c%i = 1.125 * DBLE(j-1) / DBLE(NPOINTS) + eps
     CALL testpoint(c)
  ENDDO
  ENDDO
!$OMP END PARALLEL DO

! Calculate area of set and error estimate and output the results
  write(*,*)"numoutside=", numoutside

  area = 2.0*2.5*1.125 * DBLE(NPOINTS*NPOINTS - numoutside)    &
     &        / DBLE(NPOINTS*NPOINTS)
  error = area / DBLE(NPOINTS)

  WRITE(*,100) area, error
100    FORMAT("Area of Mandlebrot set = ", f12.8, f12.8)
  WRITE(*,*)"Correct answer should be around 1.510659"

  END PROGRAM mandel_par


program exo4_2

    ! Calculate and print a defined number of the Fibonacci sequence
    implicit none
    integer :: limit, index

    write(6, '(a)', advance='no') "Enter the limit of the Fibonacci sequence: "
    read(5, '(i3)') limit
    write(6, '(a, i3, a)') 'The first ', limit, ' Fibonacci number(s) are: '

    do index = 0, limit-1
        write(6, '(a, i3, a, i3)') 'Fib(', index, ') = ', fibonacci(index)
    end do

contains
    recursive integer function fibonacci(n) result(fib)
        integer, intent(in) :: n
        if ( n .eq. 0 .or. n .eq. 1 ) then
            fib = 1
        else
            fib = fibonacci(n-2) + fibonacci(n-1)
        end if
    end function fibonacci

end program exo4_2


SUBROUTINE ncr(n, r, ncomb, ier)

! Code converted using TO_F90 by Alan Miller
! Date: 2000-01-20  Time: 18:08:52

!     Calculate the number of different combinations of r objects out of n.

!     ier = 0 if no error is detected
!         = 1 if n < 1
!         = 2 if r < 0
!         = 3 if r > n
!         = 4 if nCr > 1.e+308, i.e. if it overflows.  In this case, the
!                natural log of nCr is returned.

!     Programmer: Alan.Miller @ cmis.csiro.au
!     Latest revision - 28 July 1988 (Fortran 77 version)

IMPLICIT NONE
INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)

INTEGER, INTENT(IN)     :: n
INTEGER, INTENT(IN)     :: r
REAL (dp), INTENT(OUT)  :: ncomb
INTEGER, INTENT(OUT)    :: ier

INTEGER :: rr, i, nn

INTERFACE
  FUNCTION lngamma(x) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)  :: x
    REAL (dp)              :: fn_val
  END FUNCTION lngamma
END INTERFACE

IF (n < 1) THEN
  ier = 1
ELSE IF (r < 0) THEN
  ier = 2
ELSE IF (r > n) THEN
  ier = 3
ELSE
  ier = 0
END IF
IF (ier /= 0) RETURN

IF (r <= n-r) THEN
  rr = r
ELSE
  rr = n - r
END IF

IF (rr == 0) THEN
  ncomb = 1.0_dp
  RETURN
END IF

IF (rr > 25) THEN
  ncomb = lngamma(DBLE(n+1)) - lngamma(DBLE(r+1)) - lngamma(DBLE(n-r+1))
  IF (ncomb > 709._dp) THEN
    ier = 4
  ELSE
    ncomb = EXP(ncomb)
  END IF
  RETURN
END IF

ncomb = n
i = 1
nn = n
DO
  IF (i == rr) RETURN
  nn = nn - 1
  i = i + 1
  ncomb = (ncomb * nn) / REAL(i)
END DO

RETURN
END SUBROUTINE nCr

PROGRAM test_nCr
IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

INTERFACE
  SUBROUTINE ncr(n, r, ncomb, ier)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
    INTEGER, INTENT(IN)     :: n
    INTEGER, INTENT(IN)     :: r
    REAL (dp), INTENT(OUT)  :: ncomb
    INTEGER, INTENT(OUT)    :: ier
  END SUBROUTINE ncr
END INTERFACE

INTEGER    :: n, r, ier
REAL (dp)  :: result

DO
  WRITE(*, '(a)', ADVANCE='NO') ' Enter n, r : '
  READ(*, *) n, r
  CALL nCr(n, r, result, ier)
  IF (ier /= 0) THEN
    WRITE(*, *) ' Error, IER = ', ier
    IF (ier == 4) WRITE(*, '(a, f12.5)') ' Ln(nCr) = ', result
  ELSE
    WRITE(*, '(a, g16.8)') ' nCr = ', result
  END IF
END DO

STOP
END PROGRAM test_nCr

FUNCTION lngamma(z) RESULT(lanczos)

!  Uses Lanczos-type approximation to ln(gamma) for z > 0.
!  Reference:
!       Lanczos, C. 'A precision approximation of the gamma
!               function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
!  Accuracy: About 14 significant digits except for small regions
!            in the vicinity of 1 and 2.

!  Programmer: Alan Miller
!              1 Creswick Street, Brighton, Vic. 3187, Australia
!  Latest revision - 14 October 1996

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(12, 60)
REAL(dp), INTENT(IN)  :: z
REAL(dp)              :: lanczos

! Local variables

REAL(dp)  :: a(9) = (/ 0.9999999999995183D0, 676.5203681218835D0, &
                              -1259.139216722289D0, 771.3234287757674D0, &
                              -176.6150291498386D0, 12.50734324009056D0, &
                              -0.1385710331296526D0, 0.9934937113930748D-05, &
                               0.1659470187408462D-06 /), zero = 0.D0,   &
                               one = 1.d0, lnsqrt2pi = 0.9189385332046727D0, &
                               half = 0.5d0, sixpt5 = 6.5d0, seven = 7.d0, tmp
INTEGER          :: j

IF (z <= zero) THEN
  WRITE(*, *) 'Error: zero or -ve argument for lngamma'
  RETURN
END IF

lanczos = zero
tmp = z + seven
DO j = 9, 2, -1
  lanczos = lanczos + a(j)/tmp
  tmp = tmp - one
END DO
lanczos = lanczos + a(1)
lanczos = LOG(lanczos) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
RETURN

END FUNCTION lngamma


C FILE: MBX_FORTRAN.F90
	  SUBROUTINE GAUSSIAN(g, h, c_x, c_y, w_x, w_y, s, d)
	  implicit none
C
C     Make a gaussian without background
C
      REAL*8 h, c_x, c_y, w_x, w_y										! height, center (x and y), and widths
	  REAL*8 expo														! temporary save location of exponent
	  INTEGER s, i, j													! s = roi_size
      REAL*8 g(s*s)														! g = gaussian result
	  REAL*8 d(9,9)														! d = data = pixel values
Cf2py intent(in) h, c_x, c_y, w_x, w_y, s, d							! intent(in) means input
Cf2py intent(out) g														! intent(out) means only this will be returned
Cf2py depend(c_x) g

      do i = 0, s - 1
         do j = 0, s - 1
			expo = h*exp(-(((c_x-i)/w_x)**2+((c_y-j)/w_y)**2)/2)		! calculate exponential
            g(i*s+j+1) = expo-d(i+1,j+1)								! subtract pixel value and store
         enddo
      enddo
      END

	  SUBROUTINE GS_BG(g, h, c_x, c_y, w_x, w_y, b, s, d)
	  implicit none
C
C     Make a gaussian with background
C
      REAL*8 h, c_x, c_y, w_x, w_y, b									! height, center (x and y), widths, and background
	  REAL*8 expo														! temporary save location of exponent
	  INTEGER s, i, j													! s = roi_size
      REAL*8 g(s*s)														! g = gaussian result
	  REAL*8 d(9,9)														! d = data = pixel values
Cf2py intent(in) h, c_x, c_y, w_x, w_y, s, d, b							! intent(in) means input
Cf2py intent(out) g														! intent(out) means only this will be returned
Cf2py depend(c_x) g
      do i = 0, s - 1
         do j = 0, s - 1
			expo = h*exp(-(((c_x-i)/w_x)**2+((c_y-j)/w_y)**2)/2)		! calculate exponential
            g(i*s+j+1) = expo-d(i+1,j+1)+b								! subtract pixel value and add background and store
         enddo
      enddo
      END

	  SUBROUTINE DENSE_DIF(dif, x, stp, comp, s, s2, d)
	  implicit none
C
C     Dense difference calculation
C
	  INTEGER s, s2 													! s = num of params (5 in this case), s2 = ROI size
	  REAL*8 x(5), stp													! x = params, stp = EPS^(1/3)
	  REAL*8 d(9,9)														! d = data = pixel values
	  REAL*8 dif(s2*s2, 5)												! dif = dense difference result
	  REAL*8 h(5), comp(5)												! comp = compare (all ones), h = h values (calculated first)
	  REAL*8 x1(5), x2(5), dx											! other params and difference
	  REAL*8 f2(s2*s2), f1(s2*s2), df(s2*s2)							! other function values and difference
	  INTEGER i

Cf2py intent(in) x, stp, d, comp, s, s2
Cf2py intent(out) dif
Cf2py depend(x) dif

	  h = ABS(MAX(comp, x)*stp)

	  do i =1, s														! based on scipy.optimize.least_squares (Python)
         x1 = x
		 x1(i) = x1(i) - h(i)
		 x2 = x
		 x2(i) = x2(i) + h(i)
		 dx = 2*h(i)
		 call GAUSSIAN(f1, x1(1), x1(2), x1(3), x1(4), x1(5), s2, d)
		 call GAUSSIAN(f2, x2(1), x2(2), x2(3), x2(4), x2(5), s2, d)
		 df = f2 - f1
		 dif(:,i) = df/dx
	  enddo

	  END

	  SUBROUTINE DENSE_DIF_BG(dif, x, stp, comp, s, s2, d)
	  implicit none
C
C     Dense difference calculation
C
	  INTEGER s, s2 													! s = num of params (6 in this case), s2 = ROI size
	  REAL*8 x(6), stp													! x = params, stp = EPS^(1/3)
	  REAL*8 d(9,9)														! d = data = pixel values
	  REAL*8 dif(s2*s2, 6)												! dif = dense difference result
	  REAL*8 h(6), comp(6)												! comp = compare (all ones), h = h values (calculated first)
	  REAL*8 x1(6), x2(6), dx											! other params and difference
	  REAL*8 f2(s2*s2), f1(s2*s2), df(s2*s2)							! other function values and difference
	  INTEGER i

Cf2py intent(in) x, stp, d, comp
Cf2py intent(out) dif
Cf2py depend(x) dif

	  h = ABS(MAX(comp, x)*stp)

	  do i =1, s														! based on scipy.optimize.least_squares (Python)
         x1 = x
		 x1(i) = x1(i) - h(i)
		 x2 = x
		 x2(i) = x2(i) + h(i)
		 dx = 2*h(i)
		 call GS_BG(f1, x1(1), x1(2), x1(3), x1(4), x1(5), x1(6), s2, d)
		 call GS_BG(f2, x2(1), x2(2), x2(3), x2(4), x2(5), x2(6), s2, d)
		 df = f2 - f1
		 dif(:,i) = df/dx
	  enddo

	  END

	  SUBROUTINE GAUSSIAN7(g, h, c_x, c_y, w_x, w_y, s, d)
	  implicit none
C
C     Make a gaussian without background, ROI7
C
      REAL*8 h, c_x, c_y, w_x, w_y										! height, center (x and y), and widths
	  REAL*8 expo														! temporary save location of exponent
	  INTEGER s, i, j													! s = roi_size
      REAL*8 g(s*s)														! g = gaussian result
	  REAL*8 d(7,7)														! d = data = pixel values
Cf2py intent(in) h, c_x, c_y, w_x, w_y, s, d							! intent(in) means input
Cf2py intent(out) g														! intent(out) means only this will be returned
Cf2py depend(c_x) g

      do i = 0, s - 1
         do j = 0, s - 1
			expo = h*exp(-(((c_x-i)/w_x)**2+((c_y-j)/w_y)**2)/2)		! calculate exponential
            g(i*s+j+1) = expo-d(i+1,j+1)								! subtract pixel value and store
         enddo
      enddo
      END

	  SUBROUTINE GS_BG7(g, h, c_x, c_y, w_x, w_y, b, s, d)
	  implicit none
C
C     Make a gaussian with background
C
      REAL*8 h, c_x, c_y, w_x, w_y, b									! height, center (x and y), widths, and background
	  REAL*8 expo														! temporary save location of exponent
	  INTEGER s, i, j													! s = roi_size
      REAL*8 g(s*s)														! g = gaussian result
	  REAL*8 d(7,7)														! d = data = pixel values
Cf2py intent(in) h, c_x, c_y, w_x, w_y, s, d, b							! intent(in) means input
Cf2py intent(out) g														! intent(out) means only this will be returned
Cf2py depend(c_x) g
      do i = 0, s - 1
         do j = 0, s - 1
			expo = h*exp(-(((c_x-i)/w_x)**2+((c_y-j)/w_y)**2)/2)		! calculate exponential
            g(i*s+j+1) = expo-d(i+1,j+1)+b								! subtract pixel value and add background and store
         enddo
      enddo
      END

	  SUBROUTINE DENSE_DIF7(dif, x, stp, comp, s, s2, d)
	  implicit none
C
C     Dense difference calculation
C
	  INTEGER s, s2 													! s = num of params (5 in this case), s2 = ROI size
	  REAL*8 x(5), stp													! x = params, stp = EPS^(1/3)
	  REAL*8 d(7,7)														! d = data = pixel values
	  REAL*8 dif(s2*s2, 5)												! dif = dense difference result
	  REAL*8 h(5), comp(5)												! comp = compare (all ones), h = h values (calculated first)
	  REAL*8 x1(5), x2(5), dx											! other params and difference
	  REAL*8 f2(s2*s2), f1(s2*s2), df(s2*s2)							! other function values and difference
	  INTEGER i

Cf2py intent(in) x, stp, d, comp, s, s2
Cf2py intent(out) dif
Cf2py depend(x) dif

	  h = ABS(MAX(comp, x)*stp)

	  do i =1, s														! based on scipy.optimize.least_squares (Python)
         x1 = x
		 x1(i) = x1(i) - h(i)
		 x2 = x
		 x2(i) = x2(i) + h(i)
		 dx = 2*h(i)
		 call GAUSSIAN7(f1, x1(1), x1(2), x1(3), x1(4), x1(5), s2, d)
		 call GAUSSIAN7(f2, x2(1), x2(2), x2(3), x2(4), x2(5), s2, d)
		 df = f2 - f1
		 dif(:,i) = df/dx
	  enddo

	  END

	  SUBROUTINE DENSE_DIF_BG7(dif, x, stp, comp, s, s2, d)
	  implicit none
C
C     Dense difference calculation
C
	  INTEGER s, s2 													! s = num of params (6 in this case), s2 = ROI size
	  REAL*8 x(6), stp													! x = params, stp = EPS^(1/3)
	  REAL*8 d(7,7)														! d = data = pixel values
	  REAL*8 dif(s2*s2, 6)												! dif = dense difference result
	  REAL*8 h(6), comp(6)												! comp = compare (all ones), h = h values (calculated first)
	  REAL*8 x1(6), x2(6), dx											! other params and difference
	  REAL*8 f2(s2*s2), f1(s2*s2), df(s2*s2)							! other function values and difference
	  INTEGER i

Cf2py intent(in) x, stp, d, comp
Cf2py intent(out) dif
Cf2py depend(x) dif

	  h = ABS(MAX(comp, x)*stp)

	  do i =1, s														! based on scipy.optimize.least_squares (Python)
         x1 = x
		 x1(i) = x1(i) - h(i)
		 x2 = x
		 x2(i) = x2(i) + h(i)
		 dx = 2*h(i)
		 call GS_BG7(f1, x1(1), x1(2), x1(3), x1(4), x1(5), x1(6), s2, d)
		 call GS_BG7(f2, x2(1), x2(2), x2(3), x2(4), x2(5), x2(6), s2, d)
		 df = f2 - f1
		 dif(:,i) = df/dx
	  enddo

	  END

C END FILE MBX_FORTRAN.F90


! Number F(46) is the highest allowed for integer(kind=4).  The next number,
! F(47) creates an integer overflow and produces a negative result.
!
! To test yourself, get the table of F(i) values from here:
!
!   https://oeis.org/A000045/b000045.txt
!
program fibonacci_recursive
    implicit none
    integer :: i
    integer, parameter :: LI = kind(0_8) ! Long integer kind=8
    integer(kind=LI) :: counter = 0_LI

    print '(a)', "Enter index `i` for the Fibonacci sequence"
    read *, i
    print '(2(a, i0))', "F(", i, ") = ", fib_rec(i)
    print '(a, i0, a)', "F(i) is called ", counter, " times"
contains
    recursive function fib_rec(i) result(rslt)
        integer :: rslt
        integer, intent(in) :: i

        counter = counter + 1_LI
        if (i == 0) then
            rslt = 0
        else if (i == 1) then
            rslt = 1
        else
            rslt = fib_rec(i - 1) + fib_rec(i - 2)
        end if
        return
    end function fib_rec
end program fibonacci_recursive


      FUNCTION chebev(a,b,c,m,x)
      INTEGER m
      REAL chebev,a,b,x,c(m)
      INTEGER j
      REAL d,dd,sv,y,y2
      if ((x-a)*(x-b).gt.0.) pause 'x not in range in chebev'
      d=0.
      dd=0.
      y=(2.*x-a-b)/(b-a)
      y2=2.*y
      do 11 j=m,2,-1
        sv=d
        d=y2*d-dd+c(j)
        dd=sv
11    continue
      chebev=y*d-dd+0.5*c(1)
      return
      END

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


!     file tgenbun.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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!  Purpose:
!
!     To illustrate the usage of genbun to solve the equation
!
!     (1+x)**2*(d/dx)(du/dx) - 2(1+x)(du/dx) + (d/dy)(du/dy)
!
!                  = 3(1+x)**4*sin(y)                      (1)
!
!     on the rectangle 0 < x < 1 and -pi < y < pi
!     with the boundary conditions
!
!     (du/dx)(0,y) = 4sin(y)                               (2)
!                                -pi <= y <= pi
!     u(1,y) = 16sin(y)                                    (3)
!
!     and with u periodic in y using finite differences on a
!     grid with deltax (= dx) = 1/20 and deltay (= dy) = pi/20.
!        to set up the finite difference equations we define
!     the grid points
!
!     x(i) = (i-1)dx            i=1,2,...,21
!
!     y(j) = -pi + (j-1)dy      j=1,2,...,41
!
!     and let v(i,j) be an approximation to u(x(i),y(j)).
!     numbering the grid points in this fashion gives the set
!     of unknowns as v(i,j) for i=1,2,...,20 and j=1,2,...,40.
!     hence, in the program m = 20 and n = 40.  at the interior
!     grid point (x(i),y(j)), we replace all derivatives in
!     equation (1) by second order central finite differences,
!     multiply by dy**2, and collect coefficients of v(i,j) to
!     get the finite difference equation
!
!     a(i)v(i-1,j) + b(i)v(i,j) + c(i)v(i+1,j)
!
!     + v(i,j-1) - 2v(i,j) + v(i,j+1) = f(i,j)            (4)
!
!     where s = (dy/dx)**2, and for i=2,3,...,19
!
!     a(i) = (1+x(i))**2*s + (1+x(i))*s*dx
!
!     b(i) = -2(1+x(i))**2*s
!
!     c(i) = (1+x(i))**2*s - (1+x(i))*s*dx
!
!     f(i,j) = 3(1+x(i))**4*dy**2*sin(y(j))  for j=1,2,...,40.
!
!        to obtain equations for i = 1, we replace the
!     derivative in equation (2) by a second order central
!     finite difference approximation, use this equation to
!     eliminate the virtual unknown v(0,j) in equation (4)
!     and arrive at the equation
!
!     b(1)v(1,j) + c(1)v(2,j) + v(1,j-1) - 2v(1,j) + v(1,j+1)
!
!                       = f(1,j)
!
!     where
!
!     b(1) = -2s , c(1) = 2s
!
!     f(1,j) = (11+8/dx)*dy**2*sin(y(j)),  j=1,2,...,40.
!
!     for completeness, we set a(1) = 0.
!        to obtain equations for i = 20, we incorporate
!     equation (3) into equation (4) by setting
!
!     v(21,j) = 16sin(y(j))
!
!     and arrive at the equation
!
!     a(20)v(19,j) + b(20)v(20,j)
!
!     + v(20,j-1) - 2v(20,j) + v(20,j+1) = f(20,j)
!
!     where
!
!     a(20) = (1+x(20))**2*s + (1+x(20))*s*dx
!
!     b(20) = -2*(1+x(20))**2*s
!
!     f(20,j) = (3(1+x(20))**4*dy**2 - 16(1+x(20))**2*s
!                + 16(1+x(20))*s*dx)*sin(y(j))
!
!                    for j=1,2,...,40.
!
!     for completeness, we set c(20) = 0.  hence, in the
!
!     program mperod = 1.
!
!     the periodicity condition on u gives the conditions
!
!     v(i,0) = v(i,40) and v(i,41) = v(i,1) for i=1,2,...,20.
!
!     hence, in the program nperod = 0.
!
!     The exact solution to this problem is
!
!                  u(x,y) = ((1+x)**4) * sin(y).
!
program test_genbun

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter :: M = 20, N = 40
    integer(ip), parameter :: mp1 = M + 1, np1 = N + 1
    integer(ip), parameter :: idimf = M + 2
    integer(ip)            :: i, j, ierror, mperod, nperod
    real(wp)               :: f(idimf,N), x(mp1), y(np1), dx, dy
    real(wp), dimension(M) :: a, b, c
    real(wp), parameter    :: ZERO = 0.0_wp, ONE = 1.0_wp, TWO = 2.0_wp

    ! Set boundary conditions
    mperod = 1
    nperod = 0

    ! Set mesh sizes
    dx = ONE/M
    dy = TWO_PI/N

    ! Generate grid points for later use
    do i = 1, mp1
        x(i) = real(i - 1, kind=wp) * dx
    end do

    do j = 1, N
        y(j) = -PI + real(j - 1, kind=wp) * dy
    end do

    ! Generate coefficients
    block
        real(wp) :: s, t, t2

        s = (dy/dx)**2
        do i = 2, M - 1
            t = ONE + x(i)
            t2 = t**2
            a(i) = (t2 + t * dx) * s
            b(i) = -TWO * t2 * s
            c(i) = (t2 - t * dx) * s
        end do
        a(1) = ZERO
        b(1) = -TWO * s
        c(1) = -b(1)
        b(M) = -TWO * s * (ONE + x(M))**2
        a(M) = (-b(M)/TWO) + (ONE + x(M)) * dx * s
        c(M) = ZERO
    end block

    ! Generate right hand side
    block
        real(wp)            :: s, dy2, t, t2, t4
        real(wp), parameter :: THREE = 3.0_wp, EIGHT = 8.0_wp
        real(wp), parameter :: ELEVEN = 11.0_wp, SIXTEEN = 16.0_wp

        s = (dy/dx)**2
        dy2 = dy**2
        do j = 1, N
            do i = 2, M - 1
                f(i, j) = THREE * (ONE + x(i))**4 * dy2 * sin(y(j))
            end do
        end do

        t = ONE + x(M)
        t2 = t**2
        t4 = t**4
        do j = 1, N
            f(1,j) = (ELEVEN + EIGHT/dx) * dy2 * sin(y(j))
            f(M,j) = (THREE * t4 * dy2 - SIXTEEN * t2 * s + SIXTEEN * t * s * dx) * sin(y(j))
        end do
    end block

    ! Solve real linear system on a centered grid
    call genbun(nperod, N, mperod, M, a, b, c, idimf, f, ierror)

    ! Compute discretization error. The exact solution is
    !
    ! u(x, y) = ((1+x)**4) * sin(y)
    block
        real(wp), parameter :: KNOWN_ERROR = 0.964062912725572e-2_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(M,N)

        do i = 1, M
            do j = 1, N
                exact_solution(i,j) = ((ONE + x(i))**4) * sin(y(j))
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:M,:N)))

        call check_output('genbun', ierror, KNOWN_ERROR, discretization_error)
    end block

end program test_genbun


function true_solution(x, t)

! True solution for the thin film equation,
!     q_t + (qq_xxx)_x = 0.

    implicit none
    double precision, intent(in) :: x, t
    double precision :: true_solution

    true_solution = exp(-t) * sin(x)

end function true_solution


subroutine calculate_face_velocity(u, v, uf, vf, nx, ny, xi, xf)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(in), dimension(nx,xi-1:xf+1):: u, v
real(kind=dp), intent(out), dimension(nx-1,xi-1:xf+1):: uf
real(kind=dp), intent(out), dimension(nx,xi-1:xf+1):: vf
real(kind=dp):: phi
integer:: i, j

do j = xi,xf

    do i = 2,nx-2

        phi = (u(i,j)-u(i-1,j))/(u(i+1,j) - u(i-1,j))
        uf(i,j) = 0.50d0*(u(i,j)+u(i+1,j))*phi + 0.50d0*(3.0d0*u(i,j)-u(i-1,j))*(1.0d0-phi)

    end do

end do

do j = xi,xf

    do i = 2,nx-1

        phi = (v(i,j)-v(i,j-1))/(v(i,j+1) - v(i,j-1))
        vf(i,j) = 0.50d0*(v(i,j)+v(i,j+1))*phi + 0.50d0*(3.0d0*v(i,j)-v(i,j-1))*(1.0d0-phi)

    end do

end do

if (xf .eq. ny-1) then

    do i = 2,nx-1

        vf(i,ny-1) = v(i,ny)

    end do

end if

call exchange_data(uf, nx-1, xi, xf)
call exchange_data(vf, nx, xi, xf)

end subroutine


	subroutine bilinear(r_pnt1,r_pnt2,r_pnt3,r_pnt4,r_x,r_y,r_h)

c****************************************************************
c**
c**	FILE NAME: bilinear.for
c**
c**     DATE WRITTEN: 2/16/91
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION:This routine will take four points
c**	and do a bilinear interpolation to get the value for a point
c**	assumed to lie in the interior of the 4 points.
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:
	real r_pnt1(3)		!point in quadrant 1
	real r_pnt2(3)		!point in quadrant 2
	real r_pnt3(3)		!point in quadrant 3
	real r_pnt4(3)		!point in quadrant 4
	real r_x		!x coordinate of point
	real r_y		!y coordinate of point

c   	OUTPUT VARIABLES:
        real r_h			!interpolated vaule

c	LOCAL VARIABLES:
        real r_t1,r_t2,r_h1b,r_h2b,r_y1b,r_y2b
        real r_diff

c	DATA STATEMENTS:none

C	FUNCTION STATEMENTS:none

c  	PROCESSING STEPS:

c	first find interpolation points in x direction

        r_diff=(r_pnt2(1)-r_pnt1(1))
        if ( r_diff .ne. 0 ) then
	  r_t1 = (r_x - r_pnt1(1))/r_diff
        else
          r_t1 = r_pnt1(1)
        endif
        r_diff=(r_pnt4(1)-r_pnt3(1))
        if ( r_diff .ne. 0 ) then
	  r_t2 = (r_x - r_pnt3(1))/r_diff
        else
          r_t2 = r_pnt4(1)
        endif
	r_h1b = (1.-r_t1)*r_pnt1(3) + r_t1*r_pnt2(3)
	r_h2b = (1.-r_t2)*r_pnt3(3) + r_t2*r_pnt4(3)

c	now interpolate in y direction

	r_y1b = r_t1*(r_pnt2(2)-r_pnt1(2)) + r_pnt1(2)
	r_y2b = r_t2*(r_pnt4(2)-r_pnt3(2)) + r_pnt3(2)

        r_diff=r_y2b-r_y1b
        if ( r_diff .ne. 0 ) then
	  r_h = ((r_h2b-r_h1b)/r_diff)*(r_y-r_y1b) + r_h1b
        else
          r_h = r_y2b
        endif
        end


program roots
!Este programa resuelve las raices de una ecuacion cuadratica de la forma
!A*x**2 + B*x + C = 0
implicit none
!Declaracion de variables
real :: A,B,C,dis1,dis2,discri,real_part,imag_part

write (*,*) 'Este programa resuelve para las raices de una cuadratica'

print *, 'Escribe el valor de A'
read *, A

print *, 'Escribe el valor de B'
read *, B

print *, 'Escribe el valor de C'
read *, C

discri=B**2-(4.*A*C)
     if (discri>0) then
       dis1= (-b +sqrt(discri))/(2.* A)
       print *, 'El valor de x1 =', dis1
       dis2= (-b - sqrt(discri))/ (2.* A)
       print *, 'El valor de x2 =', dis2

     else if (discri==0) then
       dis1=-b/(2.*a)
       print *, 'Esta ec. tiene dos raices reales iguales'
       print *, 'x1= x2 ', dis1

     else
       real_part = -b/(2.*A)
       imag_part = sqrt (abs(discri))/ (2. *A)
       print *, 'Esta ec. tiene raices complejas:'
       print *, 'x1= ',real_part, ' +i', imag_part
       print *, 'x1= ',real_part, ' -i', imag_part

     end if
end program


PROGRAM Assignment0
IMPLICIT NONE

REAL, Dimension(:), Allocatable:: X, V,  T
REAL:: h, dvdt, dxdt, XMid, Vmid, dxdtMid, dvdtmid, Tmid
INTEGER:: i, npts

!This program uses the modified euler method to numerically iterate an ODE between r=0 and t=50
!The ODES model a mass m attached to a spring. The program calculates m's x position and velocity
!It does this in 5E-3 steps of time and plots 10001 steps to a file called results.dat

npts=10001

Allocate(T(0:npts), X(0:npts), V(0:npts))!Creating arrays to store the data

X(0)=0; V(0)=2.0; T(0)=0; h=5.0E-3 !Setting intial boundary conditions

OPEN(10, FILE='Results.dat')

WRITE(10,*) 'set xrange [0:50.006]' !Limiting X axis to only required values, as it auto plots to 60s, leaving a lot of white space
WRITE(10,*) 'set xlabel "Time (s)"' !Labelling X axis
WRITE(10,*) 'p ''Results.dat'' u 1:2 w l t "X Position", '''' u 1:3 w l t "Velocity"' !Command plots time vs x and time vs v when file is loaded in gnuplot

DO i=1,npts

  dxdt = v(i-1)                           !dxdt is the velocity of V at that point
  dvdt = -5.0*(x(i-1))+0.5*Cos(2*T(i-1))  !dvdt the velocity acceleration at that point

  XMid = x(i-1) + 0.5*h*dxdt             !X mid = previous X value + half interval * velocity at the starting point
  VMid = V(i-1) + 0.5*h*dvdt             !V mid = previous v value + half interval * acceleration at the starting point

  dxdtmid = VMid                         !gradient at X mid = V mid
  X(i) = X(i-1)+h*dxdtMid                !Final X = X in the middle + interval * gradient at mid point
  Tmid = T(i-1)+0.5*h                    !Tmid is previous T + half interval
  dvdtMid = -5.0*XMid+0.5*Cos(2*Tmid)    !Acceleration at mid point, means the use of X mid and T mid

  V(i) = V(i-1)+h*dvdtmid                !Final V= previous V + interval * acceleration at mid point
  T(i) = T(i-1)+h                        !Final T is T plus interval

  WRITE(6,'(f6.3, f9.5, f9.5)') T(i), X(i), V(i) !Prints results to screen
  WRITE(10,'(f6.3, f9.5, f9.5)') T(i), X(i), V(i) !Prints results to file

END DO

CLOSE(10)

WRITE(6,*) 'Results written to file: ''Results.dat''. '
WRITE(6,*) 'Results are recorded in three columns, in the order of Time, X value then Velocity'

DEALLOCATE(T, X, V)

END PROGRAM

Modified Euler Spring/Modified Euler Spring.f90


module loehner_mod

use constants_mod

interface calc_loehner
    procedure calc_loehner_1d
    procedure calc_loehner_2d
    procedure calc_loehner_3d
end interface

real(dp), parameter :: eps = 0.01_dp

contains

pure function calc_loehner_1d(u) result(r)

    real(dp), intent(in)    :: u(N_NODES)
    real(dp)                :: r

    integer :: i

    real(dp) :: xtemp(2:N_NODES-1)

    do i = 2,N_NODES-1
        xtemp(i) = abs(u(i-1) - 2.0_dp*u(i) + u(i+1)) / &
            (abs(u(i+1)-u(i)) + abs(u(i)-u(i-1)) + &
            eps*(abs(u(i+1)) + 2.0_dp*abs(u(i)) + abs(u(i-1))))
    end do

    r = maxval(xtemp)

end function

pure function calc_loehner_2d(u) result(r)

    real(dp), intent(in)    :: u(N_NODES,N_NODES)
    real(dp)                :: r

    integer :: i,j

    real(dp) :: xtemp(2:N_NODES-1,1:N_NODES)
    real(dp) :: ytemp(1:N_NODES,2:N_NODES-1)

    do j = 1,N_NODES; do i = 2,N_NODES-1;
        xtemp(i,j) = abs(u(i-1,j) - 2.0_dp*u(i,j) + u(i+1,j)) / &
            (abs(u(i+1,j)-u(i,j)) + abs(u(i,j)-u(i-1,j)) + &
            eps*(abs(u(i+1,j)) + 2.0_dp*abs(u(i,j)) + abs(u(i-1,j))))
    end do; end do;

    do j = 2,N_NODES-1; do i = 1,N_NODES;
        ytemp(i,j) = abs(u(i,j-1) - 2.0_dp*u(i,j) + u(i,j+1)) / &
            (abs(u(i,j+1)-u(i,j)) + abs(u(i,j)-u(i,j-1)) + &
            eps*(abs(u(i,j+1)) + 2.0_dp*abs(u(i,j)) + abs(u(i,j-1))))
    end do; end do;

    r = max(maxval(xtemp),maxval(ytemp))

end function

pure function calc_loehner_3d(u) result(r)

    real(dp), intent(in)    :: u(N_NODES,N_NODES,N_NODES)
    real(dp)                :: r

    integer :: i,j,k

    real(dp) :: xtemp(2:N_NODES-1,1:N_NODES,1:N_NODES)
    real(dp) :: ytemp(1:N_NODES,2:N_NODES-1,1:N_NODES)
    real(dp) :: ztemp(1:N_NODES,1:N_NODES,2:N_NODES-1)

    do k = 1,N_NODES; do j = 1,N_NODES; do i = 2,N_NODES-1;
        xtemp(i,j,k) = abs(u(i-1,j,k) - 2.0_dp*u(i,j,k) + u(i+1,j,k)) / &
            (abs(u(i+1,j,k)-u(i,j,k)) + abs(u(i,j,k)-u(i-1,j,k)) + &
            eps*(abs(u(i+1,j,k)) + 2.0_dp*abs(u(i,j,k)) + abs(u(i-1,j,k))))
    end do; end do; end do;

    do k = 1,N_NODES; do j = 2,N_NODES-1; do i = 1,N_NODES;
        ytemp(i,j,k) = abs(u(i,j-1,k) - 2.0_dp*u(i,j,k) + u(i,j+1,k)) / &
            (abs(u(i,j+1,k)-u(i,j,k)) + abs(u(i,j,k)-u(i,j-1,k)) + &
            eps*(abs(u(i,j+1,k)) + 2.0_dp*abs(u(i,j,k)) + abs(u(i,j-1,k))))
    end do; end do; end do;

    do k = 2,N_NODES-1; do j = 1,N_NODES; do i = 1,N_NODES;
        ztemp(i,j,k) = abs(u(i,j,k-1) - 2.0_dp*u(i,j,k) + u(i,j,k+1)) / &
            (abs(u(i,j,k+1)-u(i,j,k)) + abs(u(i,j,k)-u(i,j,k-1)) + &
            eps*(abs(u(i,j,k+1)) + 2.0_dp*abs(u(i,j,k)) + abs(u(i,j,k-1))))
    end do; end do; end do;

    r = max(maxval(xtemp),maxval(ytemp),maxval(ztemp))

end function

!! Some experimental stuff.
!! pure function calc_loehner(u)
!!
!!     real(dp), intent(in)    :: u(N_NODES,N_NODES)
!!     real(dp)                :: calc_loehner
!!
!!     real(dp), parameter :: eps = 0.2_dp
!!
!!     real(dp) :: stencil(-1:1,-1:1)
!!     real(dp) :: xtemp(-1:1)
!!     real(dp) :: ytemp(-1:1)
!!
!!     integer :: i,j
!!
!!     stencil = matmul(fv8fv3Mat,matmul(u,fv8fv3Tam))
!!
!!     forall (j = -1:1)
!!         xtemp(j) = abs(stencil(-1,j) - 2.0_dp*stencil(0,j) + stencil(1,j)) / &
!!                  (abs(stencil(1,j)-stencil(0,j)) + abs(stencil(0,j)-stencil(-1,j)) + &
!!                  eps*(abs(stencil(1,j)) + 2.0_dp*abs(stencil(0,j)) + abs(stencil(-1,j))))
!!     end forall
!!
!!     forall (i = -1:1)
!!          ytemp(i) = abs(stencil(i,-1) - 2.0_dp*stencil(i,0) + stencil(i,1)) / &
!!              (abs(stencil(i,1)-stencil(i,0)) + abs(stencil(i,0)-stencil(i,-1)) + &
!!              eps*(abs(stencil(i,1)) + 2.0_dp*abs(stencil(i,0)) + abs(stencil(i,-1))))
!!      end forall
!!
!!     ! calc_loehner = max(maxval(xtemp),maxval(ytemp))
!!     calc_loehner = max(sum(xtemp)/3,sum(ytemp)/3)
!!
!! end function

end module


submodule(forlab_math) forlab_math_angle
    implicit none
contains

    pure module function angle_2_sp(x, y) result(angle)
        real(sp), dimension(3), intent(in) :: x, y
        real(sp) :: angle

        angle = acos(dot_product(x, y)/(norm2(x)*norm2(y)))

    end function angle_2_sp
    pure module function angle_2_dp(x, y) result(angle)
        real(dp), dimension(3), intent(in) :: x, y
        real(dp) :: angle

        angle = acos(dot_product(x, y)/(norm2(x)*norm2(y)))

    end function angle_2_dp

end submodule forlab_math_angle


      program numintgrl1
      implicit none
      integer , parameter :: rp = selected_real_kind(15)
      real (kind = rp) :: sum = 0.0_rp
      integer :: i, n
      real (kind = rp) :: a, b, deltaX
      real (kind = rp) :: x_i = 0.0_rp
      write (*,*) 'input the lower bound'
      read (*,*)  a
      write (*,*) 'input the upper bound'
      read (*,*) b
      write (*,*)  'input the number of sections in the approx.'
      read (*,*) n
      deltaX = (b-a)/n
      do i = 1, n, 1
        x_i = a + i * deltaX
!Right Riemann sum
        sum = sum + ((x_i ** 3)/2 * deltaX)
      end do
      print *, sum
      end program numintgrl1

! compile attempt (for l8r):
C $ cd \R:

C Kenneth Collins@DESKTOP-7A1A76L /cygdrive/r
C $ pwd
C /cygdrive/r

C Kenneth Collins@DESKTOP-7A1A76L /cygdrive/r
C $ gfortran R:/Fortran_wd/practiceNumIntegral1-09-12-18.f -o practiceNumIntegral1-09-12-18.exe