!*****************************************************************************************
!>
!  This program tests codes for the solution of n nonlinear
!  equations in n variables. it consists of a driver and an
!  interface subroutine fcn. the driver reads in data, calls the
!  nonlinear equation solver, and finally prints out information
!  on the performance of the solver. this is only a sample driver,
!  many other drivers are possible. the interface subroutine fcn
!  is necessary to take into account the forms of calling
!  sequences used by the function subroutines in the various
!  nonlinear equation solvers.

program test_hybrd

    use minpack_module, only: wp, dpmpar, enorm, hybrd1
    use iso_fortran_env, only: output_unit

    implicit none

    ! originally from file21
    integer,parameter :: ncases = 22
    integer,dimension(ncases),parameter :: nprobs = [1,2,3,4,5,6,6,7,7,7,7,7,8,8,8,9,10,10,11,12,13,14]
    integer,dimension(ncases),parameter :: ns = [2,4,2,4,3,6,9,5,6,7,8,9,10,30,40,10,1,10,10,10,10,10]
    integer,dimension(ncases),parameter :: ntriess = [3,3,2,3,3,2,2,3,3,3,1,1,3,1,1,3,3,3,3,3,3,3]

    integer,dimension(55),parameter :: info_original = [1,1,1,4,4,4,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,&
                                                        1,1,1,4,4,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,4,1,1,&
                                                        1,1,1,1,1,1,1,1,1]

    integer :: i, ic, info, k, lwa, n, NFEv, NPRob, ntries, icase
    integer,dimension(55) :: na, nf, np, nx
    real(wp),dimension(55) :: fnm
    real(wp) :: factor, fnorm1, fnorm2
    real(wp),dimension(:),allocatable :: fvec, wa, x

    integer, parameter :: nwrite = output_unit !! logical output unit
    real(wp), parameter :: one = 1.0_wp
    real(wp), parameter :: ten = 10.0_wp
    real(wp), parameter :: tol = sqrt(dpmpar(1))
    real(wp), parameter :: solution_reltol = 1.0e-4_wp !! reltol for matching previously generated solutions

    ic = 0
    do icase = 1, ncases+1

        if (icase == ncases+1) then
            write (nwrite, '(A,I3,A/)') '1SUMMARY OF ', ic, ' CALLS TO HYBRD1'
            write (nwrite, '(A/)')      ' NPROB   N    NFEV  INFO  FINAL L2 NORM'
            do i = 1, ic
                write (nwrite, '(i4, i6, i7, i6, 1x, d15.7)') np(i), na(i), nf(i), nx(i), fnm(i)
            end do
            stop
        else
            nprob = nprobs(icase)
            n = ns(icase)
            lwa = (n*(3*n+13))/2
            ntries = ntriess(icase)

            if (allocated(fvec)) deallocate(fvec)
            if (allocated(wa)) deallocate(wa)
            if (allocated(x)) deallocate(x)
            allocate(fvec(n))
            allocate(wa(lwa))
            allocate(x(n))

            factor = one
            do k = 1, ntries
                ic = ic + 1
                call initpt(n, x, NPRob, factor)
                call vecfcn(n, x, fvec, NPRob)
                fnorm1 = enorm(n, fvec)
                write (nwrite, '(////5x,A,I5,5X,A,I5,5X//)') ' PROBLEM', NPRob, ' DIMENSION', n
                NFEv = 0
                call hybrd1(fcn, n, x, fvec, tol, info, wa, lwa)
                fnorm2 = enorm(n, fvec)
                np(ic) = NPRob
                na(ic) = n
                nf(ic) = NFEv
                nx(ic) = info
                fnm(ic) = fnorm2
                write (nwrite, '(5X,A,D15.7//5X,A,D15.7//5X,A,I10//5X,A,18X,I10//5X,A//,*(5X,5D15.7/))') &
                               ' INITIAL L2 NORM OF THE RESIDUALS', fnorm1, &
                               ' FINAL L2 NORM OF THE RESIDUALS  ', fnorm2, &
                               ' NUMBER OF FUNCTION EVALUATIONS  ', NFEv,   &
                               ' EXIT PARAMETER', info, &
                               ' FINAL APPROXIMATE SOLUTION', x(1:n)
                factor = ten*factor
                call compare_solutions(ic, x, solution_reltol, tol)
            end do
        end if
    end do

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compare with previously generated solutions.

    subroutine compare_solutions(ic, x, reltol, abstol)

    implicit none

    integer,intent(in) :: ic !! problem number (index is `solution` vector)
    real(wp),dimension(:),intent(in) :: x !! computed `x` vector from the method
    real(wp),intent(in) :: reltol !! relative tolerance for `x` to pass
    real(wp),intent(in) :: abstol !! absolute tolerance for `x` to pass

    real(wp),dimension(size(x)) :: diff, absdiff, reldiff

    if (info_original(ic)<5) then    ! ignore any where the original minpack failed
        diff = solution(ic) - x
        absdiff = abs(diff)
        if (any(absdiff>abstol)) then ! first do an absolute diff
            ! also do a rel diff if the abs diff fails (also protect for divide by zero)
            reldiff = absdiff
            where (solution(ic) /= 0.0_wp) reldiff = absdiff / abs(solution(ic))
            if (any(reldiff > reltol)) then
                write(nwrite,'(A)') 'Failed case'
                write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
                write(nwrite, '(/5x, a//(5x, 5d15.7))')  'Computed x: ', x
                write(nwrite, '(/5x, a//(5x, 5d15.7))')  'absdiff: ', absdiff
                write(nwrite, '(/5x, a//(5x, 5d15.7))')  'reldiff: ', reldiff
                error stop ! test failed
            end if
        end if
    end if

    end subroutine compare_solutions
!*****************************************************************************************

!*****************************************************************************************
!>
!  The calling sequence of fcn should be identical to the
!  calling sequence of the function subroutine in the nonlinear
!  equation solver. fcn should only call the testing function
!  subroutine vecfcn with the appropriate value of problem
!  number (nprob).

    subroutine fcn(n, x, Fvec, Iflag)
        implicit none

        integer, intent(in) :: n !! the number of variables.
        real(wp), intent(in) :: x(n) !! independent variable vector
        real(wp), intent(out) :: fvec(n) !! value of function at `x`
        integer, intent(inout) :: iflag !! set to <0 to terminate execution

        call vecfcn(n, x, Fvec, NPRob)
        NFEv = NFEv + 1

    end subroutine fcn
!*****************************************************************************************

!*****************************************************************************************
!>
!  Replaced statement function in original code.

    pure elemental function dfloat(i) result(f)
        implicit none
        integer, intent(in) :: i
        real(wp) :: f
        f = real(i, wp)
    end function dfloat
!*****************************************************************************************

!*****************************************************************************************
!>
!  Get expected `x` vectors for each case.

    pure function solution(nprob) result(x)

        implicit none

        integer,intent(in) :: nprob
        real(wp),dimension(:),allocatable :: x

        select case (nprob)
        case (1); x = [0.1000000000000000E+01_wp,0.1000000000000000E+01_wp]
        case (2); x = [0.1000000000000000E+01_wp,0.1000000000000000E+01_wp]
        case (3); x = [0.1000000000000000E+01_wp,0.1000000000000054E+01_wp]
        case (4); x = [-0.1717232736993598E-17_wp,0.1717232736993598E-18_wp,0.4885791716489701E-17_wp,&
                        0.4885791716489701E-17_wp]
        case (5); x = [0.1137338840805565E-17_wp,-0.1137338840805565E-18_wp,0.1509231876962185E-17_wp,&
                        0.1509231876962185E-17_wp]
        case (6); x = [0.2071578632741476E-17_wp,-0.2071578632741476E-18_wp,0.3365608460018520E-17_wp,&
                        0.3365608460018520E-17_wp]
        case (7); x = [0.1098159327798559E-04_wp,0.9106146740037904E+01_wp]
        case (8); x = [0.1098159288127784E-04_wp,0.9106146743611500E+01_wp]
        case (9); x = [-0.9679740249513952E+00_wp,0.9471391408446626E+00_wp,-0.9695163103174519E+00_wp,&
                        0.9512476657649955E+00_wp]
        case (10); x = [-0.9679740249362032E+00_wp,0.9471391408151544E+00_wp,-0.9695163103329795E+00_wp,&
                        0.9512476657950136E+00_wp]
        case (11); x = [-0.9679740247487649E+00_wp,0.9471391404515958E+00_wp,-0.9695163105216826E+00_wp,&
                        0.9512476661606586E+00_wp]
        case (12); x = [0.1000000000000010E+01_wp,-0.1612103012704913E-13_wp,-0.8125674485239315E-34_wp]
        case (13); x = [0.1000000000004274E+01_wp,0.1388633807362216E-10_wp,0.0000000000000000E+00_wp]
        case (14); x = [0.9999999999999840E+00_wp,0.1238719384388127E-14_wp,0.0000000000000000E+00_wp]
        case (15); x = [-0.1572508640134011E-01_wp,0.1012434869369118E+01_wp,-0.2329916259567960E+00_wp,&
                        0.1260430087800365E+01_wp,-0.1513728922723441E+01_wp,0.9929964324318560E+00_wp]
        case (16); x = [-0.1572508639053690E-01_wp,0.1012434869369907E+01_wp,-0.2329916259623205E+00_wp,&
                        0.1260430087870332E+01_wp,-0.1513728922830754E+01_wp,0.9929964324984680E+00_wp]
        case (17); x = [-0.1530703652147214E-04_wp,0.9997897039319488E+00_wp,0.1476396369354227E-01_wp,&
                        0.1463423282995085E+00_wp,0.1000821103004075E+01_wp,-0.2617731140517609E+01_wp,&
                        0.4104403164477184E+01_wp,-0.3143612278555425E+01_wp,0.1052626408009917E+01_wp]
        case (18); x = [-0.1530703713913476E-04_wp,0.9997897039319459E+00_wp,0.1476396369267279E-01_wp,&
                        0.1463423283016577E+00_wp,0.1000821102994390E+01_wp,-0.2617731140495362E+01_wp,&
                        0.4104403164446781E+01_wp,-0.3143612278533631E+01_wp,0.1052626408003180E+01_wp]
        case (19); x = [0.8375125649983552E-01_wp,0.3127292952224503E+00_wp,0.5000000000008663E+00_wp,&
                        0.6872707047760241E+00_wp,0.9162487435008237E+00_wp]
        case (20); x = [0.6872707047770207E+00_wp,0.9162487435004409E+00_wp,0.4999999999996554E+00_wp,&
                        0.8375125649942240E-01_wp,0.3127292952234606E+00_wp]
        case (21); x = [0.5000000001403082E+00_wp,0.6872707047172968E+00_wp,0.8375125651152422E-01_wp,&
                        0.3127292951388482E+00_wp,0.9162487434920225E+00_wp]
        case (22); x = [0.6687659094768218E-01_wp,0.3666822990106460E+00_wp,0.2887406733471217E+00_wp,&
                        0.7112593271119373E+00_wp,0.6333177005294922E+00_wp,0.9331234090531204E+00_wp]
        case (23); x = [0.9331234090539151E+00_wp,0.2887406731191550E+00_wp,0.6687659094608109E-01_wp,&
                        0.7112593268807791E+00_wp,0.3666822992420550E+00_wp,0.6333177007580146E+00_wp]
        case (24); x = [0.3666822992460977E+00_wp,0.6333177007631426E+00_wp,0.7112593268766961E+00_wp,&
                        0.6687659094559376E-01_wp,0.9331234090527033E+00_wp,0.2887406731157666E+00_wp]
        case (25); x = [0.5806914977912385E-01_wp,0.2351716115667845E+00_wp,0.3380440957994889E+00_wp,&
                        0.4999999991484015E+00_wp,0.6619559063505691E+00_wp,0.7648283868041619E+00_wp,&
                        0.9419308505514702E+00_wp]
        case (26); x = [0.3380440947502161E+00_wp,0.4999999997939603E+00_wp,0.2351716123793344E+00_wp,&
                        0.7648283876237569E+00_wp,0.9419308503662596E+00_wp,0.5806914962097134E-01_wp,&
                        0.6619559054655015E+00_wp]
        case (27); x = [-0.3267366079625573E+02_wp,-0.2996209843926172E+02_wp,-0.8587775264169514E+02_wp,&
                        0.2222113097994968E+02_wp,0.5957249137089175E+02_wp,-0.1038025653217158E+01_wp,&
                        0.8600842862942351E+02_wp]
        case (28); x = [0.4985640222318974E-01_wp,0.1986351285003365E+00_wp,0.2698288337443381E+00_wp,&
                        0.4992723176748156E+00_wp,0.5007277255753518E+00_wp,0.7301712224978171E+00_wp,&
                        0.8013649159179719E+00_wp,0.9501436601762751E+00_wp]
        case (29); x = [0.4420534615691015E-01_wp,0.1994906721904692E+00_wp,0.2356191086780681E+00_wp,&
                        0.4160469078466623E+00_wp,0.4999999996232831E+00_wp,0.5839530926716184E+00_wp,&
                        0.7643808911925417E+00_wp,0.8005093278089829E+00_wp,0.9557946538314642E+00_wp]
        case (30); x = [0.1000000000000008E+01_wp,0.1000000000000008E+01_wp,0.1000000000000008E+01_wp,&
                        0.1000000000000008E+01_wp,0.1000000000000008E+01_wp,0.1000000000000008E+01_wp,&
                        0.1000000000000008E+01_wp,0.1000000000000008E+01_wp,0.1000000000000008E+01_wp,&
                        0.9999999999999193E+00_wp]
        case (31); x = [0.1000000000000002E+01_wp,0.1000000000000002E+01_wp,0.1000000000000002E+01_wp,&
                        0.1000000000000002E+01_wp,0.1000000000000002E+01_wp,0.1000000000000002E+01_wp,&
                        0.1000000000000002E+01_wp,0.1000000000000002E+01_wp,0.1000000000000002E+01_wp,&
                        0.9999999999999805E+00_wp]
        case (32); x = [0.1000000000000126E+01_wp,0.1000000000000126E+01_wp,0.1000000000000126E+01_wp,&
                        0.1000000000000126E+01_wp,0.1000000000000126E+01_wp,0.1000000000000126E+01_wp,&
                        0.1000000000000126E+01_wp,0.1000000000000126E+01_wp,0.1000000000000126E+01_wp,&
                        0.9999999999987337E+00_wp]
        case (33); x = [0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,&
                        0.1000000000000116E+01_wp,0.1000000000000116E+01_wp,0.9999999999965015E+00_wp]
        case (34); x = [0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,0.9999999999999820E+00_wp,&
                        0.1000000000000726E+01_wp]
        case (35); x = [-0.4316498251876486E-01_wp,-0.8157715653538729E-01_wp,-0.1144857143805310E+00_wp,&
                        -0.1409735768625996E+00_wp,-0.1599086961819857E+00_wp,-0.1698772023127759E+00_wp,&
                        -0.1690899837812081E+00_wp,-0.1552495352218312E+00_wp,-0.1253558916789345E+00_wp,&
                        -0.7541653368589182E-01_wp]
        case (36); x = [-0.4316498251881876E-01_wp,-0.8157715653546944E-01_wp,-0.1144857143805966E+00_wp,&
                        -0.1409735768626190E+00_wp,-0.1599086961819499E+00_wp,-0.1698772023126901E+00_wp,&
                        -0.1690899837811062E+00_wp,-0.1552495352217907E+00_wp,-0.1253558916789970E+00_wp,&
                        -0.7541653368596339E-01_wp]
        case (37); x = [-0.4316498254524553E-01_wp,-0.8157715658128553E-01_wp,-0.1144857144024714E+00_wp,&
                        -0.1409735768723229E+00_wp,-0.1599086963003020E+00_wp,-0.1698772022538506E+00_wp,&
                        -0.1690899837944776E+00_wp,-0.1552495352060321E+00_wp,-0.1253558916432041E+00_wp,&
                        -0.7541653366609002E-01_wp]
        case (38); x = [-0.1528138835625800E+00_wp]
        case (39); x = [-0.1528138835625801E+00_wp]
        case (40); x = [-0.1528138835625801E+00_wp]
        case (41); x = [-0.4316498251876487E-01_wp,-0.8157715653538730E-01_wp,-0.1144857143805310E+00_wp,&
                        -0.1409735768625996E+00_wp,-0.1599086961819857E+00_wp,-0.1698772023127759E+00_wp,&
                        -0.1690899837812081E+00_wp,-0.1552495352218312E+00_wp,-0.1253558916789344E+00_wp,&
                        -0.7541653368589175E-01_wp]
        case (42); x = [-0.4316498251881876E-01_wp,-0.8157715653546946E-01_wp,-0.1144857143805966E+00_wp,&
                        -0.1409735768626190E+00_wp,-0.1599086961819498E+00_wp,-0.1698772023126901E+00_wp,&
                        -0.1690899837811062E+00_wp,-0.1552495352217907E+00_wp,-0.1253558916789970E+00_wp,&
                        -0.7541653368596334E-01_wp]
        case (43); x = [-0.4316498251876519E-01_wp,-0.8157715653538752E-01_wp,-0.1144857143805303E+00_wp,&
                        -0.1409735768625980E+00_wp,-0.1599086961819844E+00_wp,-0.1698772023127748E+00_wp,&
                        -0.1690899837812073E+00_wp,-0.1552495352218307E+00_wp,-0.1253558916789341E+00_wp,&
                        -0.7541653368589159E-01_wp]
        case (44); x = [0.5526115715943968E-01_wp,0.5695713693095779E-01_wp,0.5889020336090119E-01_wp,&
                        0.6113556183519356E-01_wp,0.6377799292665667E-01_wp,0.6700414432471043E-01_wp,&
                        0.2079417258113421E+00_wp,0.1642681193175131E+00_wp,0.8643704095817571E-01_wp,&
                        0.9133212907808361E-01_wp]
        case (45); x = [0.3439628896235289E-01_wp,0.3503231575416022E-01_wp,0.3571919583574593E-01_wp,&
                        0.3646522422001942E-01_wp,0.3728091174083566E-01_wp,0.3817986258974846E-01_wp,&
                        0.3918014109819012E-01_wp,0.4030650261419996E-01_wp,0.1797201916815169E+00_wp,&
                        0.1562408814749922E+00_wp]
        case (46); x = [0.1888395221036672E+02_wp,0.2516777354434988E+02_wp,0.1888527511739392E+02_wp,&
                        0.1888602114554983E+02_wp,0.1888683683452867E+02_wp,0.1888773578345333E+02_wp,&
                        0.1888873606083097E+02_wp,0.1888986242379029E+02_wp,0.1902927611240455E+02_wp,&
                        0.1900579680335179E+02_wp]
        case (47); x = [0.9999999999999992E+00_wp,0.9999999999999984E+00_wp,0.9999999999999977E+00_wp,&
                        0.9999999999999969E+00_wp,0.9999999999999961E+00_wp,0.9999999999999953E+00_wp,&
                        0.9999999999999946E+00_wp,0.9999999999999938E+00_wp,0.9999999999999930E+00_wp,&
                        0.9999999999999922E+00_wp]
        case (48); x = [0.1000000000000000E+01_wp,0.1000000000000000E+01_wp,0.1000000000000000E+01_wp,&
                        0.1000000000000000E+01_wp,0.1000000000000001E+01_wp,0.1000000000000001E+01_wp,&
                        0.1000000000000001E+01_wp,0.1000000000000001E+01_wp,0.1000000000000001E+01_wp,&
                        0.1000000000000001E+01_wp]
        case (49); x = [0.1000000000000000E+01_wp,0.1000000000000000E+01_wp,0.1000000000000000E+01_wp,&
                        0.1000000000000000E+01_wp,0.1000000000000000E+01_wp,0.1000000000000000E+01_wp,&
                        0.1000000000000000E+01_wp,0.1000000000000000E+01_wp,0.1000000000000000E+01_wp,&
                        0.1000000000000000E+01_wp]
        case (50); x = [-0.5707221307212121E+00_wp,-0.6818069509055232E+00_wp,-0.7022100775689857E+00_wp,&
                        -0.7055106309936168E+00_wp,-0.7049061557572888E+00_wp,-0.7014966060124587E+00_wp,&
                        -0.6918893211477919E+00_wp,-0.6657965141985400E+00_wp,-0.5960351099566767E+00_wp,&
                        -0.4164122574358191E+00_wp]
        case (51); x = [-0.5707221320932939E+00_wp,-0.6818069495100820E+00_wp,-0.7022100764111258E+00_wp,&
                        -0.7055106298493696E+00_wp,-0.7049061556844529E+00_wp,-0.7014966070294095E+00_wp,&
                        -0.6918893223739674E+00_wp,-0.6657965143753547E+00_wp,-0.5960351092038981E+00_wp,&
                        -0.4164122574142932E+00_wp]
        case (52); x = [-0.5707221320171143E+00_wp,-0.6818069499829604E+00_wp,-0.7022100760171542E+00_wp,&
                        -0.7055106298955310E+00_wp,-0.7049061557301967E+00_wp,-0.7014966070327222E+00_wp,&
                        -0.6918893223590803E+00_wp,-0.6657965144072677E+00_wp,-0.5960351090088830E+00_wp,&
                        -0.4164122575177334E+00_wp]
        case (53); x = [-0.4283028636053099E+00_wp,-0.4765964242962535E+00_wp,-0.5196524638125549E+00_wp,&
                        -0.5580993246169652E+00_wp,-0.5925061569509362E+00_wp,-0.6245036821428087E+00_wp,&
                        -0.6232394714478015E+00_wp,-0.6213938418388717E+00_wp,-0.6204535966122983E+00_wp,&
                        -0.5864692707477792E+00_wp]
        case (54); x = [-0.4283028634881692E+00_wp,-0.4765964236396713E+00_wp,-0.5196524642776766E+00_wp,&
                        -0.5580993248351936E+00_wp,-0.5925061568131795E+00_wp,-0.6245036817962692E+00_wp,&
                        -0.6232394720687789E+00_wp,-0.6213938417874499E+00_wp,-0.6204535965224117E+00_wp,&
                        -0.5864692707287930E+00_wp]
        case (55); x = [-0.4283028635608067E+00_wp,-0.4765964243232715E+00_wp,-0.5196524637037395E+00_wp,&
                        -0.5580993248328234E+00_wp,-0.5925061568292707E+00_wp,-0.6245036822076749E+00_wp,&
                        -0.6232394714256790E+00_wp,-0.6213938418143937E+00_wp,-0.6204535966527651E+00_wp,&
                        -0.5864692707189498E+00_wp]

        case default
            error stop 'invalid case'
        end select

    end function solution
!*****************************************************************************************

!*****************************************************************************************
!>
!  This subroutine defines fourteen test functions. the first
!  five test functions are of dimensions 2,4,2,4,3, respectively,
!  while the remaining test functions are of variable dimension
!  n for any n greater than or equal to 1 (problem 6 is an
!  exception to this, since it does not allow n = 1).

    subroutine vecfcn(n, x, Fvec, Nprob)
        implicit none

        integer, intent(in) :: n !! a positive integer input variable.
        integer, intent(in) :: nprob !! a positive integer input variable which defines the
                                     !! number of the problem. nprob must not exceed 14.
        real(wp), intent(in) :: x(n) !! an input array of length n.
        real(wp), intent(out) :: fvec(n) !! an output array of length n which contains the nprob
                                         !! function vector evaluated at x.

        real(wp), parameter :: zero = 0.0_wp
        real(wp), parameter :: one = 1.0_wp
        real(wp), parameter :: two = 2.0_wp
        real(wp), parameter :: three = 3.0_wp
        real(wp), parameter :: five = 5.0_wp
        real(wp), parameter :: eight = 8.0_wp
        real(wp), parameter :: ten = 10.0_wp
        real(wp), parameter :: c1 = 1.0e4_wp
        real(wp), parameter :: c2 = 1.0001_wp
        real(wp), parameter :: c3 = 2.0e2_wp
        real(wp), parameter :: c4 = 2.02e1_wp
        real(wp), parameter :: c5 = 1.98e1_wp
        real(wp), parameter :: c6 = 1.8e2_wp
        real(wp), parameter :: c7 = 2.5e-1_wp
        real(wp), parameter :: c8 = 5.0e-1_wp
        real(wp), parameter :: c9 = 2.9e1_wp

        integer :: i, iev, ivar, j, k, k1, k2, kp1, ml, mu
        real(wp) :: h, prod, sum, sum1, sum2, temp, temp1, &
                    temp2, ti, tj, tk, tpi

        fvec(1:n) = zero

        ! PROBLEM SELECTOR.

        select case (Nprob)
        case (2)
            ! POWELL SINGULAR FUNCTION.
            Fvec(1) = x(1) + ten*x(2)
            Fvec(2) = sqrt(five)*(x(3) - x(4))
            Fvec(3) = (x(2) - two*x(3))**2
            Fvec(4) = sqrt(ten)*(x(1) - x(4))**2
        case (3)
            ! POWELL BADLY SCALED FUNCTION.
            Fvec(1) = c1*x(1)*x(2) - one
            Fvec(2) = exp(-x(1)) + exp(-x(2)) - c2
        case (4)
            ! WOOD FUNCTION.
            temp1 = x(2) - x(1)**2
            temp2 = x(4) - x(3)**2
            Fvec(1) = -c3*x(1)*temp1 - (one - x(1))
            Fvec(2) = c3*temp1 + c4*(x(2) - one) + c5*(x(4) - one)
            Fvec(3) = -c6*x(3)*temp2 - (one - x(3))
            Fvec(4) = c6*temp2 + c4*(x(4) - one) + c5*(x(2) - one)
        case (5)
            ! HELICAL VALLEY FUNCTION.
            tpi = eight*atan(one)
            if (x(1) > zero) then
                temp1 = atan(x(2)/x(1))/tpi
            else if (x(1) < zero) then
                temp1 = atan(x(2)/x(1))/tpi + c8
            else
                temp1 = sign(c7, x(2)) ! does this ever happen?
            end if
            temp2 = sqrt(x(1)**2 + x(2)**2)
            Fvec(1) = ten*(x(3) - ten*temp1)
            Fvec(2) = ten*(temp2 - one)
            Fvec(3) = x(3)
        case (6)
            ! WATSON FUNCTION.
            do k = 1, n
                Fvec(k) = zero
            end do
            do i = 1, 29
                ti = dfloat(i)/c9
                sum1 = zero
                temp = one
                do j = 2, n
                    sum1 = sum1 + dfloat(j - 1)*temp*x(j)
                    temp = ti*temp
                end do
                sum2 = zero
                temp = one
                do j = 1, n
                    sum2 = sum2 + temp*x(j)
                    temp = ti*temp
                end do
                temp1 = sum1 - sum2**2 - one
                temp2 = two*ti*sum2
                temp = one/ti
                do k = 1, n
                    Fvec(k) = Fvec(k) + temp*(dfloat(k - 1) - temp2)*temp1
                    temp = ti*temp
                end do
            end do
            temp = x(2) - x(1)**2 - one
            Fvec(1) = Fvec(1) + x(1)*(one - two*temp)
            Fvec(2) = Fvec(2) + temp
        case (7)
            ! CHEBYQUAD FUNCTION.
            do k = 1, n
                Fvec(k) = zero
            end do
            do j = 1, n
                temp1 = one
                temp2 = two*x(j) - one
                temp = two*temp2
                do i = 1, n
                    Fvec(i) = Fvec(i) + temp2
                    ti = temp*temp2 - temp1
                    temp1 = temp2
                    temp2 = ti
                end do
            end do
            tk = one/dfloat(n)
            iev = -1
            do k = 1, n
                Fvec(k) = tk*Fvec(k)
                if (iev > 0) Fvec(k) = Fvec(k) + one/(dfloat(k)**2 - one)
                iev = -iev
            end do
        case (8)
            ! BROWN ALMOST-LINEAR FUNCTION.
            sum = -dfloat(n + 1)
            prod = one
            do j = 1, n
                sum = sum + x(j)
                prod = x(j)*prod
            end do
            do k = 1, n
                Fvec(k) = x(k) + sum
            end do
            Fvec(n) = prod - one
        case (9)
            ! DISCRETE BOUNDARY VALUE FUNCTION.
            h = one/dfloat(n + 1)
            do k = 1, n
                temp = (x(k) + dfloat(k)*h + one)**3
                temp1 = zero
                if (k /= 1) temp1 = x(k - 1)
                temp2 = zero
                if (k /= n) temp2 = x(k + 1)
                Fvec(k) = two*x(k) - temp1 - temp2 + temp*h**2/two
            end do
        case (10)
            ! DISCRETE INTEGRAL EQUATION FUNCTION.
            h = one/dfloat(n + 1)
            do k = 1, n
                tk = dfloat(k)*h
                sum1 = zero
                do j = 1, k
                    tj = dfloat(j)*h
                    temp = (x(j) + tj + one)**3
                    sum1 = sum1 + tj*temp
                end do
                sum2 = zero
                kp1 = k + 1
                if (n >= kp1) then
                    do j = kp1, n
                        tj = dfloat(j)*h
                        temp = (x(j) + tj + one)**3
                        sum2 = sum2 + (one - tj)*temp
                    end do
                end if
                Fvec(k) = x(k) + h*((one - tk)*sum1 + tk*sum2)/two
            end do
        case (11)
            ! TRIGONOMETRIC FUNCTION.
            sum = zero
            do j = 1, n
                Fvec(j) = cos(x(j))
                sum = sum + Fvec(j)
            end do
            do k = 1, n
                Fvec(k) = dfloat(n + k) - sin(x(k)) - sum - dfloat(k)*Fvec(k)
            end do
        case (12)
            ! VARIABLY DIMENSIONED FUNCTION.
            sum = zero
            do j = 1, n
                sum = sum + dfloat(j)*(x(j) - one)
            end do
            temp = sum*(one + two*sum**2)
            do k = 1, n
                Fvec(k) = x(k) - one + dfloat(k)*temp
            end do
        case (13)
            ! BROYDEN TRIDIAGONAL FUNCTION.
            do k = 1, n
                temp = (three - two*x(k))*x(k)
                temp1 = zero
                if (k /= 1) temp1 = x(k - 1)
                temp2 = zero
                if (k /= n) temp2 = x(k + 1)
                Fvec(k) = temp - temp1 - two*temp2 + one
            end do
        case (14)
            ! BROYDEN BANDED FUNCTION.
            ml = 5
            mu = 1
            do k = 1, n
                k1 = max(1, k - ml)
                k2 = min(k + mu, n)
                temp = zero
                do j = k1, k2
                    if (j /= k) temp = temp + x(j)*(one + x(j))
                end do
                Fvec(k) = x(k)*(two + five*x(k)**2) + one - temp
            end do
        case default
            ! ROSENBROCK FUNCTION.
            Fvec(1) = one - x(1)
            Fvec(2) = ten*(x(2) - x(1)**2)
        end select

    end subroutine vecfcn
!*****************************************************************************************

!*****************************************************************************************
!>
!  This subroutine specifies the standard starting points for
!  the functions defined by subroutine vecfcn. the subroutine
!  returns in x a multiple (factor) of the standard starting
!  point. for the sixth function the standard starting point is
!  zero, so in this case, if factor is not unity, then the
!  subroutine returns the vector  x(j) = factor, j=1,...,n.

    subroutine initpt(n, x, Nprob, Factor)

        implicit none

        integer, intent(in) :: n !! a positive integer input variable.
        real(wp), intent(out) :: x(n) !! an output array of length n which contains the standard
                                      !! starting point for problem nprob multiplied by factor.
        integer, intent(in) :: Nprob !! a positive integer input variable which defines the
                                     !! number of the problem. nprob must not exceed 14.
        real(wp), intent(in) :: Factor !! an input variable which specifies the multiple of
                                       !! the standard starting point. if factor is unity, no
                                       !! multiplication is performed.

        integer :: ivar, j
        real(wp) :: h, tj

        real(wp), parameter :: zero = 0.0_wp
        real(wp), parameter :: half = 0.5_wp
        real(wp), parameter :: one = 1.0_wp
        real(wp), parameter :: three = 3.0_wp
        real(wp), parameter :: c1 = 1.2_wp

        x(1:n) = zero

        ! selection of initial point.

        select case (nprob)
        case (2)
            ! powell singular function.
            x(1) = three
            x(2) = -one
            x(3) = zero
            x(4) = one
        case (3)
            ! powell badly scaled function.
            x(1) = zero
            x(2) = one
        case (4)
            ! wood function.
            x(1) = -three
            x(2) = -one
            x(3) = -three
            x(4) = -one
        case (5)
            ! helical valley function.
            x(1) = -one
            x(2) = zero
            x(3) = zero
        case (6)
            ! watson function.
            do j = 1, n
                x(j) = zero
            end do
        case (7)
            ! chebyquad function.
            h = one/dfloat(n + 1)
            do j = 1, n
                x(j) = dfloat(j)*h
            end do
        case (8)
            ! brown almost-linear function.
            do j = 1, n
                x(j) = half
            end do
        case (9, 10)
            ! discrete boundary value and integral equation functions.
            h = one/dfloat(n + 1)
            do j = 1, n
                tj = dfloat(j)*h
                x(j) = tj*(tj - one)
            end do
        case (11)
            ! trigonometric function.
            h = one/dfloat(n)
            do j = 1, n
                x(j) = h
            end do
        case (12)
            ! variably dimensioned function.
            h = one/dfloat(n)
            do j = 1, n
                x(j) = one - dfloat(j)*h
            end do
        case (13, 14)
            ! broyden tridiagonal and banded functions.
            do j = 1, n
                x(j) = -one
            end do
        case default
            ! rosenbrock function.
            x(1) = -c1
            x(2) = one
        end select

        ! compute multiple of initial point.

        if (factor /= one) then
            if (nprob == 6) then
                do j = 1, n
                    x(j) = factor
                end do
            else
                do j = 1, n
                    x(j) = factor*x(j)
                end do
            end if
        end if

    end subroutine initpt
!*****************************************************************************************

!*****************************************************************************************
end program test_hybrd
!*****************************************************************************************


          PROGRAM MAIN
          USE OMP_LIB
          IMPLICIT NONE

          INTEGER :: i, id, nthreads
          INTEGER, PARAMETER :: num_steps=100000000
          REAL*8 :: x, pi, sum, step
          REAL*8 :: start_time, run_time

          sum = 0.0

          step = 1.0 / num_steps

          CALL OMP_SET_NUM_THREADS(NTHREADS)
          start_time = OMP_GET_WTIME()

!$OMP PARALLEL PRIVATE(i,x)
!$OMP DO REDUCTION(+:sum)
          DO i = 1, num_steps
             x = (i - 0.5) * step
             sum = sum + 4.0 / (1.0 + x * x)
          ENDDO
!$OMP END DO
!$OMP END PARALLEL

          pi = step * sum
          run_time = OMP_GET_WTIME() - start_time
          WRITE(*,100) pi, run_time
100       FORMAT('pi is ',f15.8,' in ',f8.3,' secs')

          END PROGRAM MAIN


! { dg-do compile }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! PR 77915 - ICE of matmul with forall.
program x
  integer, parameter :: d = 3
  real,dimension(d,d,d) :: cube,xcube
  real, dimension(d,d) :: cmatrix
  integer :: i,j
  forall(i=1:d,j=1:d)
     xcube(i,j,:) = matmul(cmatrix,cube(i,j,:))
  end forall
end program x

! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "original" } }


      SUBROUTINE MB02XD( FORM, STOR, UPLO, F, M, N, NRHS, IPAR, LIPAR,
     $                   DPAR, LDPAR, A, LDA, B, LDB, ATA, LDATA, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve a set of systems of linear equations, A'*A*X = B, or,
C     in the implicit form, f(A)*X = B, with A'*A or f(A) positive
C     definite, using symmetric Gaussian elimination.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FORM    CHARACTER*1
C             Specifies the form in which the matrix A is provided, as
C             follows:
C             = 'S' :  standard form, the matrix A is given;
C             = 'F' :  the implicit, function form f(A) is provided.
C             If FORM = 'F', then the routine F is called to compute the
C             matrix A'*A.
C
C     STOR    CHARACTER*1
C             Specifies the storage scheme for the symmetric
C             matrix A'*A, as follows:
C             = 'F' :  full storage is used;
C             = 'P' :  packed storage is used.
C
C     UPLO    CHARACTER*1
C             Specifies which part of the matrix A'*A is stored, as
C             follows:
C             = 'U' :  the upper triagular part is stored;
C             = 'L' :  the lower triagular part is stored.
C
C     Function Parameters
C
C     F       EXTERNAL
C             If FORM = 'F', then F is a subroutine which calculates the
C             value of f(A) = A'*A, for given A.
C             If FORM = 'S', then F is not called.
C
C             F must have the following interface:
C
C             SUBROUTINE F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A,
C            $              LDA, ATA, LDATA, DWORK, LDWORK, INFO )
C
C             where
C
C             STOR    (input) CHARACTER*1
C                     Specifies the storage scheme for the symmetric
C                     matrix A'*A, as follows:
C                     = 'F' :  full storage is used;
C                     = 'P' :  packed storage is used.
C
C             UPLO    (input) CHARACTER*1
C                     Specifies which part of the matrix A'*A is stored,
C                     as follows:
C                     = 'U' :  the upper triagular part is stored;
C                     = 'L' :  the lower triagular part is stored.
C
C             N       (input) INTEGER
C                     The order of the matrix A'*A.  N >= 0.
C
C             IPAR    (input) INTEGER array, dimension (LIPAR)
C                     The integer parameters describing the structure of
C                     the matrix A.
C
C             LIPAR   (input) INTEGER
C                     The length of the array IPAR.  LIPAR >= 0.
C
C             DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C                     The real parameters needed for solving the
C                     problem.
C
C             LDPAR   (input) INTEGER
C                     The length of the array DPAR.  LDPAR >= 0.
C
C             A       (input) DOUBLE PRECISION array, dimension
C                     (LDA, NC), where NC is the number of columns.
C                     The leading NR-by-NC part of this array must
C                     contain the (compressed) representation of the
C                     matrix A, where NR is the number of rows of A
C                     (function of IPAR entries).
C
C             LDA     (input) INTEGER
C                     The leading dimension of the array A.
C                     LDA >= MAX(1,NR).
C
C             ATA     (output) DOUBLE PRECISION array,
C                              dimension (LDATA,N),    if STOR = 'F',
C                              dimension (N*(N+1)/2),  if STOR = 'P'.
C                     The leading N-by-N (if STOR = 'F'), or N*(N+1)/2
C                     (if STOR = 'P') part of this array contains the
C                     upper or lower triangle of the matrix A'*A,
C                     depending on UPLO = 'U', or UPLO = 'L',
C                     respectively, stored either as a two-dimensional,
C                     or one-dimensional array, depending on STOR.
C
C             LDATA   (input) INTEGER
C                     The leading dimension of the array ATA.
C                     LDATA >= MAX(1,N), if STOR = 'F'.
C                     LDATA >= 1,        if STOR = 'P'.
C
C             DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C                     The workspace array for subroutine F.
C
C             LDWORK  (input) INTEGER
C                     The size of the array DWORK (as large as needed
C                     in the subroutine F).
C
C             INFO    INTEGER
C                     Error indicator, set to a negative value if an
C                     input scalar argument is erroneous, and to
C                     positive values for other possible errors in the
C                     subroutine F. The LAPACK Library routine XERBLA
C                     should be used in conjunction with negative INFO.
C                     INFO must be zero if the subroutine finished
C                     successfully.
C
C             Parameters marked with "(input)" must not be changed.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix A'*A, the number of columns of the
C             matrix A, and the number of rows of the matrix X.  N >= 0.
C
C     NRHS    (input) INTEGER
C             The number of columns of the matrices B and X.  NRHS >= 0.
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             If FORM = 'F', the integer parameters describing the
C             structure of the matrix A.
C             This parameter is ignored if FORM = 'S'.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 0.
C
C     DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C             If FORM = 'F', the real parameters needed for solving
C             the problem.
C             This parameter is ignored if FORM = 'S'.
C
C     LDPAR   (input) INTEGER
C             The length of the array DPAR.  LDPAR >= 0.
C
C     A       (input) DOUBLE PRECISION array,
C                     dimension (LDA, N),  if FORM = 'S',
C                     dimension (LDA, NC), if FORM = 'F', where NC is
C                     the number of columns.
C             If FORM = 'S', the leading M-by-N part of this array
C             must contain the matrix A.
C             If FORM = 'F', the leading NR-by-NC part of this array
C             must contain an appropriate representation of matrix A,
C             where NR is the number of rows.
C             If FORM = 'F', this array is not referenced by this
C             routine itself, except in the call to the routine F.
C
C     LDA     INTEGER
C             The leading dimension of array A.
C             LDA >= MAX(1,M),  if FORM = 'S';
C             LDA >= MAX(1,NR), if FORM = 'F'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB, NRHS)
C             On entry, the leading N-by-NRHS part of this array must
C             contain the right hand side matrix B.
C             On exit, if INFO = 0 and M (or NR) is nonzero, the leading
C             N-by-NRHS part of this array contains the solution X of
C             the set of systems of linear equations A'*A*X = B or
C             f(A)*X = B. If M (or NR) is zero, then B is unchanged.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     ATA     (output) DOUBLE PRECISION array,
C                      dimension (LDATA,N),    if STOR = 'F',
C                      dimension (N*(N+1)/2),  if STOR = 'P'.
C             The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if
C             STOR = 'P') part of this array contains the upper or lower
C             triangular Cholesky factor of the matrix A'*A, depending
C             on UPLO = 'U', or UPLO = 'L', respectively, stored either
C             as a two-dimensional, or one-dimensional array, depending
C             on STOR.
C
C     LDATA   INTEGER
C             The leading dimension of the array ATA.
C             LDATA >= MAX(1,N), if STOR = 'F'.
C             LDATA >= 1,        if STOR = 'P'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, then the (i,i) element of the
C                   triangular factor of the matrix A'*A is exactly
C                   zero (the matrix A'*A is exactly singular);
C                   if INFO = j > n, then F returned with INFO = j-n.
C
C     METHOD
C
C     The matrix A'*A is built either directly (if FORM = 'S'), or
C     implicitly, by calling the routine F. Then, A'*A is Cholesky
C     factored and its factor is used to solve the set of systems of
C     linear equations, A'*A*X = B.
C
C     REFERENCES
C
C     [1] Golub, G.H. and van Loan, C.F.
C         Matrix Computations. Third Edition.
C         M. D. Johns Hopkins University Press, Baltimore, 1996.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Blackford, Demmel, J.,
C         Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S.,
C         McKenney, A., Sorensen, D.
C         LAPACK Users' Guide: Third Edition, SIAM, Philadelphia, 1999.
C
C     NUMERICAL ASPECTS
C
C     For speed, this routine does not check for near singularity of the
C     matrix A'*A. If the matrix A is nearly rank deficient, then the
C     computed X could be inaccurate. Estimates of the reciprocal
C     condition numbers of the matrices A and A'*A can be obtained
C     using LAPACK routines DGECON and DPOCON (DPPCON), respectively.
C
C     The approximate number of floating point operations is
C        (M+3)*N**2/2 + N**3/6 + NRHS*N**2, if FORM = 'S',
C        f + N**3/6 + NRHS*N**2,            if FORM = 'F',
C     where M is the number of rows of A, and f is the number of
C     floating point operations required by the subroutine F.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001.
C
C     REVISIONS
C
C     V. Sima, Mar. 2002.
C
C     KEYWORDS
C
C     Linear system of equations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         FORM, STOR, UPLO
      INTEGER           INFO, LDA, LDATA, LDB, LDPAR, LDWORK, LIPAR, M,
     $                  N, NRHS
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ATA(*), B(LDB,*), DPAR(*), DWORK(*)
      INTEGER           IPAR(*)
C     .. Local Scalars ..
      INTEGER           IERR, J, J1
      LOGICAL           FULL, MAT, UPPER
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMV, DPOTRF, DPOTRS, DPPTRF, DPPTRS, DSYRK, F,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     ..
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      MAT   = LSAME( FORM, 'S' )
      FULL  = LSAME( STOR, 'F' )
      UPPER = LSAME( UPLO, 'U' )
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN
         INFO = -1
      ELSEIF ( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN
         INFO = -2
      ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -3
      ELSEIF ( M.LT.0 ) THEN
         INFO = -5
      ELSEIF ( N.LT.0 ) THEN
         INFO = -6
      ELSEIF ( NRHS.LT.0 ) THEN
         INFO = -7
      ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN
         INFO = -9
      ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN
         INFO = -11
      ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.M ) ) THEN
         INFO = -13
      ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSEIF ( LDATA.LT.1 .OR. ( FULL .AND. LDATA.LT.N ) ) THEN
         INFO = -17
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02XD', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. ( MAT .AND. M.EQ.0 ) )
     $   RETURN
C
C     Build a triangle of the matrix A'*A.
C
      IF ( MAT ) THEN
C
C        Matrix A is given in the usual form.
C
         IF ( FULL ) THEN
            CALL DSYRK( UPLO, 'Transpose', N, M, ONE, A, LDA, ZERO,
     $                  ATA, LDATA )
         ELSEIF ( UPPER ) THEN
            J1 = 1
C
            DO 10 J = 1, N
               CALL DGEMV( 'Transpose', M, J, ONE, A, LDA, A(1,J), 1,
     $                     ZERO, ATA(J1), 1 )
               J1 = J1 + J
   10       CONTINUE
C
         ELSE
            J1 = 1
C
            DO 20 J = 1, N
               CALL DGEMV( 'Transpose', M, N-J+1, ONE, A(1,J), LDA,
     $                     A(1,J), 1, ZERO, ATA(J1), 1 )
               J1 = J1 + N - J + 1
   20       CONTINUE
C
         ENDIF
C
      ELSE
C
C        Implicit form, A'*A = f(A).
C
         CALL F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, ATA,
     $           LDATA, DWORK, LDWORK, IERR )
         IF ( IERR.NE.0 ) THEN
            INFO = N + IERR
            RETURN
         ENDIF
C
      ENDIF
C
C     Factor the matrix A'*A.
C
      IF ( FULL ) THEN
         CALL DPOTRF( UPLO, N, ATA, LDATA, IERR )
      ELSE
         CALL DPPTRF( UPLO, N, ATA, IERR )
      ENDIF
C
      IF ( IERR.NE.0 ) THEN
         INFO = IERR
         RETURN
      ENDIF
C
C     Solve the set of linear systems.
C
      IF ( FULL ) THEN
         CALL DPOTRS( UPLO, N, NRHS, ATA, LDATA, B, LDB, IERR )
      ELSE
         CALL DPPTRS( UPLO, N, NRHS, ATA, B, LDB, IERR )
      ENDIF
C
C *** Last line of MB02XD ***
      END


c
c -------------------------------------------------------------
c
      subroutine vrm(qr,ql,rx,ixmin,ixmax,iflip,msize)

      implicit double precision (a-h,o-z)
      include "cuserdt.i"

      parameter ( psmall = 1d-07 , rsmall = 1d-07)

      dimension qr(4,msize),ql(4,msize)
      dimension rx(4,msize)
      dimension rhor(msize),ur(msize),pr(msize),utr(msize)
      dimension rhol(msize),ul(msize),pl(msize),utl(msize)
      dimension clsqp(msize),clsqm(msize),pstar(msize)
      dimension zp(msize),zm(msize),ustarm(msize),ustarp(msize)
      dimension zsum(msize)
      data      itno/2/, small/1.d-6/
c
      if (ixmax .gt. msize) then
         write(6,*)" need to increase msize in vrm to ", ixmax
         stop
      endif

      gp1g2i = (gamma+1.d0)/(2.d0*gamma)
c
c     # vector Riemann solver
c     # Given conserved variables, compute
c     # conserved variables at interface by solving riemann problem
c     # only solve neighboring vertical interfaces
c     # as in Van Leer MUSCL paper # 5 (1979), JCP
c
c      iflip = 1 indicates the normal velocity is in
c                qr(k,2) and the tangential in qr(k,3)
c            = 0 indicates the reverse.
c
      inorm = 3 - iflip
      itan  = 2 + iflip

      do 10 k = ixmin, ixmax
         rhor(k) = qr(1,k)
         ur(k)   = qr(inorm,k)
         utr(k)  = qr(itan,k)
         pr(k)   = qr(4,k)
         rhol(k) = ql(1,k)
         ul(k)   = ql(inorm,k)
         utl(k)  = ql(itan,k)
         pl(k)   = ql(4,k)
  10     continue
c
c     # iterate to find pstar, ustar:
c
      do 20 k = ixmin, ixmax
         clsqp(k) = gamma*rhol(k)*pl(k)
         clsqm(k) = gamma*rhor(k)*pr(k)
         wp = dsqrt(clsqp(k))
         wm = dsqrt(clsqm(k))
         pstar(k) = (wp*pr(k)+ wm*pl(k)- wm*wp
     &      *(ur(k)- ul(k)))/(wp+ wm)
         pstar(k) = dmax1(pstar(k),small)
  20     continue
c
      do 30 iter = 1, itno
         do 30 k = ixmin, ixmax
           wsqp = clsqp(k)*(1.d0+gp1g2i*(pstar(k)/pl(k)-1.d0))
           wp   = dsqrt(wsqp)
           wsqm = clsqm(k)*(1.d0+gp1g2i*(pstar(k)/pr(k)-1.d0))
           wm   = dsqrt(wsqm)
c
           zp(k) = 2.d0*wp*wsqp/(wsqp+clsqp(k))
           zm(k) = 2.d0*wm*wsqm/(wsqm+clsqm(k))
c
           ustarm(k) = ur(k)-(pr(k)-pstar(k))/wm
           ustarp(k) = ul(k)+(pl(k)-pstar(k))/wp
           zsum(k) = zp(k)+zm(k)
           epsp = zp(k)*zm(k)*(ustarm(k)-ustarp(k))/zsum(k)
           pstar(k) = pstar(k)-epsp
           pstar(k) = dmax1(pstar(k),small)
  30       continue
c
      do 40 k = ixmin, ixmax
         ustar = (zp(k)*ustarm(k)+zm(k)*ustarp(k))/zsum(k)
         sein  = -dsign(1.d0,ustar)
         if (sein .ge. 0.d0) then
            uo = ur(k)
            po = pr(k)
            ro = rhor(k)
            utgdnv = utr(k)
         else
            uo = ul(k)
            po = pl(k)
            ro = rhol(k)
            utgdnv = utl(k)
         endif
         co = dsqrt(po*gamma/ro)

         dummy = pstar(k)-po
         wo = gamma*ro*po*(1.d0+gp1g2i*dummy/po)
         rstar = ro/(1.d0-ro*dummy/wo)
         wo = dsqrt(wo)
         cstar = dsqrt(gamma*pstar(k)/rstar)
         wso = sein*uo+co
         wsi = sein*ustar+cstar
         ushok = sein*ustar+wo/rstar
         if (dummy .ge. 0.d0) then
            wsi = ushok
            wso = ushok
         else
            wsi = wsi
            wso = wso
         endif
         t4 = (wso+wsi)/dmax1(wso-wsi,wso+wsi,small)
         t4 = .5d0*(t4+1.d0)
         t5  = 1.d0-t4
         t3  = t4*cstar+t5*co
         rgdnv = t4*rstar+t5*ro
         ugdnv = t4*ustar+t5*uo
         pgdnv = t3*t3*rgdnv/gamma

         if (wso .ge. 0.d0) then
            pgdnv = pgdnv
            rgdnv = rgdnv
            ugdnv = ugdnv
         else
            pgdnv = po
            rgdnv = ro
            ugdnv = uo
         endif

         if (wsi .lt. 0.d0) then
            pgdnv = pgdnv
            rgdnv = rgdnv
            ugdnv = ugdnv
         else
            pgdnv = pstar(k)
            rgdnv = rstar
            ugdnv = ustar
         endif

         rx(1,k)     = rgdnv*ugdnv
         rx(inorm,k) = rx(1,k)*ugdnv + pgdnv
         rx(itan,k)  = rx(1,k)*utgdnv
         rx(4,k)     = rx(1,k)*(pgdnv*gamma/(rgdnv*gamma1)+
     &                 .5d0*(ugdnv**2 + utgdnv**2))
 40   continue
c
      return
      end


      double complex function fc002(msq,taugs,qsq)
      implicit none
      double precision qsq,msq,qsqhat,taugs,qgs,cgs2
      double complex lnrat,I3me

      qsqhat=qsq-msq
      qgs=qsqhat-taugs
      cgs2=(qsqhat-taugs)**2-4d0*taugs*msq

      fc002 =
     &  - 1.D0/12.D0*qgs*cgs2**(-1)*msq
     &  + 1.D0/6.D0*cgs2**(-1)*msq*taugs
     &  + 1.D0/12.D0*cgs2**(-1)*msq**2*taugs*qsq**(-1)
     &  + 1.D0/12.D0*cgs2**(-1)*msq**2
     &  - 1.D0/12.D0*cgs2**(-1)*msq**3*qsq**(-1)
     &  - I3me(msq,taugs,qsq)*cgs2**(-2)*msq**2*taugs**3
     &  + 1.D0/2.D0*lnrat( - taugs,msq)*qgs*cgs2**(-2)*msq*taugs**2
     &  - 1.D0/12.D0*lnrat( - taugs,msq)*qgs*cgs2**(-1)*taugs
     &  - 1.D0/2.D0*lnrat( - qsqhat,msq)*qgs*cgs2**(-2)*msq*taugs**2*
     & qsq**(-1)*qsqhat
     &  + 1.D0/12.D0*lnrat( - qsqhat,msq)*qgs*cgs2**(-1)*msq*qsq**(-1)*
     & qsqhat
     &  + 1.D0/12.D0*lnrat( - qsqhat,msq)*qgs*cgs2**(-1)*taugs*
     & qsq**(-1)*qsqhat
     &
      fc002 = fc002 - lnrat( - qsqhat,msq)*cgs2**(-2)*msq**2*taugs**2*
     & qsq**(-1)*qsqhat
     &  - 1.D0/12.D0*lnrat( - qsqhat,msq)*cgs2**(-1)*msq**2*taugs*
     & qsq**(-2)*qsqhat
     &  - 1.D0/12.D0*lnrat( - qsqhat,msq)*cgs2**(-1)*msq**2*qsq**(-1)*
     & qsqhat
     &  + 1.D0/12.D0*lnrat( - qsqhat,msq)*cgs2**(-1)*msq**3*qsq**(-2)*
     & qsqhat
     &

      return
      end

      double complex function fc00(msq,taugs,qsq)
      implicit none
      double precision qsq,msq,qsqhat,taugs,qgs,cgs2
      double complex lnrat,I3me

      qsqhat=qsq-msq
      qgs=qsqhat-taugs
      cgs2=(qsqhat-taugs)**2-4d0*taugs*msq

      fc00 =
     &  - 1.D0/2.D0*I3me(msq,taugs,qsq)*cgs2**(-1)*msq*taugs**2
     &  + 1.D0/4.D0*lnrat( - taugs,msq)*qgs*cgs2**(-1)*taugs
     &  - 1.D0/4.D0*lnrat( - qsqhat,msq)*qgs*cgs2**(-1)*taugs*qsq**(-1)
     & *qsqhat
     &  - 1.D0/2.D0*lnrat( - qsqhat,msq)*cgs2**(-1)*msq*taugs*qsq**(-1)
     & *qsqhat
     &

      return
      end


      subroutine dflux(ny,il,jl,ie,je,ib,jb,
     & w,p,
     & pori, porj,
     & fw, radi, radj,
c    no flo_params used
     & rfil,vis2,vis4)
c
c     arg list above is:
c
c     dims
c
c     flow_var
c     mesh_var
c     solv_var
c
c     flo_param
c     solv_param
c
c
c
c     ******************************************************************
c     *                                                                *
c     *   upwind biasing by artificial dissipation using               *
c     *   blended first and third order fluxes                         *
c     *                                                                *
c     ******************************************************************
c
c     w(i,j,1)  = density
c     w(i,j,2)  = momentum in x direction
c     w(i,j,3)  = momentum in y direction
c     w(i,j,4)  = total energy
c
c     ******************************************************************
c
c      use dims
c
c     ******************************************************************
c
c      use flo_var
c      use mesh_var
c      use solv_var
c
c     ******************************************************************
c
c      use flo_param
c      use solv_param
c
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
c     input variables
c
c     ******************************************************************
c     from dims
      integer, intent(in) :: ny,il,jl,ie,je,ib,jb

c     from flo_var
      real(8), intent(inout), dimension(0:ib,0:jb,4) :: w
      real(8), intent(inout), dimension(0:ib,0:jb) :: p

c     from mesh_var
      real(8), intent(in), dimension(1:il,2:jl)   :: pori
      real(8), intent(in), dimension(2:il,1:jl)   :: porj

c     from solv_var
      real(8), intent(inout), dimension(0:ib,0:jb,4) :: fw
      real(8), intent(inout), dimension(0:ib,0:jb)   :: radi,radj

c     from solv_param
      real(8), intent(in)     :: rfil, vis2, vis4

c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i,j,n
c
c     ******************************************************************
c
      real(8)     :: fis2,fis4,sfil,plim,tol,rad
c
c     ******************************************************************
c
      real(8), dimension(0:ib,0:jb)   :: dp
      real(8), dimension(0:ie,0:je)   :: d
      real(8), dimension(il,jl)       :: e,gs
      real(8), dimension(il,jl)       :: dis2,dis4
c
c     ******************************************************************
c
      fis2      = 2.*rfil*vis2
      fis4      = rfil*vis4/16.
      sfil      = 1.  -rfil
      plim      = .001
      tol       = .25
c
c     replace the energy by the enthalpy
c
      do j=0,jb
      do i=0,ib
         w(i,j,4)  = w(i,j,4)  +p(i,j)
      end do
      end do
c
c     dissipation in the i direction
c
      do j=2,jl
         do i=1,ie
            dp(i,j)   = abs((p(i+1,j)  -2.*p(i,j)  +p(i-1,j))/
     .                      (p(i+1,j)  +2.*p(i,j)  +p(i-1,j)  +plim))
         end do
         dp(0,j)   = dp(1,j)
         dp(ib,j)  = dp(ie,j)
      end do

      do j=2,jl
      do i=1,il
         rad       = min(radi(i+1,j),radi(i,j))
         dis2(i,j) = fis2*rad*
     .               min(tol,max(dp(i+2,j),dp(i+1,j),dp(i,j),dp(i-1,j)))
         dis4(i,j) = fis4*rad
         dis4(i,j) = dim(dis4(i,j),dis2(i,j))
      end do
      end do

      do n=1,4

      do j=2,jl
      do i=0,ie
         d(i,j)    = w(i+1,j,n)  -w(i,j,n)
      end do
      end do

      do j=2,jl
      do i=1,il
         e(i,j)    = d(i+1,j)  -2.*d(i,j)  +d(i-1,j)
      end do
      end do

      do j=2,jl
      do i=1,il
         gs(i,j)   = pori(i,j)*(dis2(i,j)*d(i,j)  -dis4(i,j)*e(i,j))
      end do
      end do

      do j=2,jl
      do i=2,il
         fw(i,j,n) = sfil*fw(i,j,n)  +gs(i-1,j)  -gs(i,j)
      end do
      end do

      end do

      if (ny.lt.3) go to 11
c
c     dissipation in the j direction
c
      do j=1,je
      do i=2,il
         dp(i,j)   = abs((p(i,j+1)  -2.*p(i,j)  +p(i,j-1))/
     .                   (p(i,j+1)  +2.*p(i,j)  +p(i,j-1)  +plim))
      end do
      end do

      do i=2,il
         rad         = min(radj(i,2),radj(i,1))
         dis2(i,1)   = fis2*rad*
     .                 min(tol,max(dp(i,3),dp(i,2),dp(i,1)))
         dis4(i,1)   = fis4*rad
         dis4(i,1)   = dim(dis4(i,1),dis2(i,1))
         rad         = min(radj(i,jl+1),radj(i,jl))
         dis2(i,jl)  = fis2*rad*
     .                 min(tol,max(dp(i,jl+1),dp(i,jl),dp(i,jl-1)))
         dis4(i,jl)  = fis4*rad
         dis4(i,jl)  = dim(dis4(i,jl),dis2(i,jl))
      end do

      do j=2,ny
      do i=2,il
         rad       = min(radj(i,j+1),radj(i,j))
         dis2(i,j) = fis2*rad*
     .               min(tol,max(dp(i,j+2),dp(i,j+1),dp(i,j),dp(i,j-1)))
         dis4(i,j) = fis4*rad
         dis4(i,j) = dim(dis4(i,j),dis2(i,j))
      end do
      end do

      do n=1,4

      do j=0,je
      do i=2,il
         d(i,j)    = w(i,j+1,n)  -w(i,j,n)
      end do
      end do

      do j=1,jl
      do i=2,il
         e(i,j)    = d(i,j+1)  -2.*d(i,j)  +d(i,j-1)
      end do
      end do

      do j=1,jl
      do i=2,il
         gs(i,j)   = porj(i,j)*(dis2(i,j)*d(i,j)  -dis4(i,j)*e(i,j))
      end do
      end do

      do j=2,jl
      do i=2,il
         fw(i,j,n) = fw(i,j,n)  +gs(i,j-1)  -gs(i,j)
      end do
      end do

      end do
c
c     replace the enthalpy by the energy
c
   11 do j=0,jb
      do i=0,ib
         w(i,j,4)  = w(i,j,4)  -p(i,j)
      end do
      end do

      return

      end


      subroutine r8mkspl2p(fun,x,nx,th,nth,fspl,nf3,wk,inwk,
     >   ilinx,ilinth,ier)
C
C  create a bicubic periodic spline with knots at grid points and
C  function values from the callable function `fun' passed.
C
C  use bpspline to setup the spline coefficients
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nth,nf3,inwk,nx,ix,ith
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 fun
!============
      external fun                      ! passed real function(x,th)
      REAL*8 x(nx)                        ! x coordinate array
      REAL*8 th(nth)                      ! th coordinate array
C
C  output:
C
      REAL*8 fspl(4,4,nf3,nth)            ! function data / spline coeff array
      REAL*8 wk(inwk)                     ! workspace -- at least 5*max(nx,nth)
C
      integer ilinx                     ! output =1 if x(1...nx) evenly spaced
      integer ilinth                    ! output =1 if th(1..nth) evenly spaced
C
      integer ier                       ! completion code from bpspline 0=OK
C
C----------------------------
C
      ier=0
      if(nf3.lt.nx) then
         write(6,'('' ?mkspl2p -- array dim error, nf3.lt.nx'')')
         ier=1
      endif
      if(inwk.lt.5*max(nx,nth)) then
         write(6,'('' ?mkspl2p -- array dim error, inwk too small'')')
         ier=2
      endif
C
      do ix=1,nx
         do ith=1,nth
            fspl(1,1,ix,ith)=fun(x(ix),th(ith))
         enddo
      enddo
C
      call r8bpspline(x,nx,th,nth,fspl,nf3,wk,inwk,ilinx,ilinth,ier)
C
      return
      end


SUBROUTINE lumass ()

  ! *** calculates lumped mass for each element & assembles global mass matrix

  USE cms_db
  USE ctrl_db, ONLY: ndime, ndofn, npoin, neq, numct, mscal, ascal
  USE outp_db, ONLY: sumat,iwrit
  USE npo_db, ONLY :  emass,ymass,label,ifact,ifpre
  USE kinc_db, ONLY : ndumn,npsdf,nesdf,ftsdf
  USE ndp_db, ONLY : nndp
  USE sms_db, ONLY : selective_mass_scaling, fibre_mass

  IMPLICIT NONE

  INTEGER (kind=4) :: i,ipoin,chnode
  REAL    (kind=8) :: xcmas(ndofn)

  INTERFACE
    INCLUDE 'elemnt.h'
    INCLUDE 'contac.h'
  END INTERFACE

  emass = 0d0 !initializes mass matrix

  IF (nconm > 0) THEN  !add concentrated masses
    IF(iwrit == 1) WRITE(lures,"(5x,'Concentrated Masses')",ERR=9999)

    DO i = 1,nconm
      ipoin = nodcms(i)
      ipoin = chnode(ipoin)
      xcmas(1:ndofn) = cmass(1:ndofn,i)
      IF(iwrit == 1)WRITE(lures,"(i8,6f10.3)",ERR=9999) label(ipoin),xcmas
      emass(1:ndofn,ipoin) = emass(1:ndofn,ipoin) + xcmas
    END DO
  END IF

  sumat = 0d0

  CALL elemnt ('LUMASS')  !compute element masses
  IF( numct > 0) CALL contac ('LUMASS',0)  !contact surface mass
  CALL elemnt ('RIGBDY')  !center or mass of rigid bodies
  IF( ndumn > 0) CALL rigbdc (nndp)

  WRITE(lures, "(//'Total Mass of the System (Without Point Masses):', &
               & e15.7)",ERR=9999) sumat

  IF(iwrit == 1) THEN
    IF(ndime == 2)WRITE(lures,"(//,'  Lumped Mass Matrix' /,          &
                              &    ' Node',6X,'X',11X,'Y',11X,'a')",ERR=9999)
    IF(ndime == 3)WRITE(lures,"(//,'  Lumped Mass Matrix' /,' Node',  &
                & 6X,'X',11X,'Y',11X,'z',10x,'RX',10X,'RY',10X,'RZ')",ERR=9999)
    DO ipoin=1,npoin
      WRITE(lures,"(i5,6e12.4)",ERR=9999) label(ipoin),emass(1:ndofn,ipoin)
    END DO
  END IF
  IF (ascal) CALL scale_mass( mscal ) ! auto-scale mass matrix factor evaluation
  emass = emass*mscal !scale mass

!           Assembles mass for active DOFs
  ymass = 0d0
  CALL ensmal(ndofn*npoin,neq,ifpre(1,1),emass(1,1),ymass(1),npsdf(1),nesdf(1),ftsdf(1))
  IF( selective_mass_scaling )CALL fibre_mass( emass )
  DO i=1,neq
    ymass(i) = 1d0/ymass(i)
  END DO
RETURN
9999 CALL runen2('')
END SUBROUTINE lumass


!>
!! This module contains the functions for the discrete advection operator. A first order upwind discretization is used for the coarse method, a 5th order WENO for the fine.
!!
MODULE advection

USE omp_lib, only : omp_get_thread_num
USE upwind,  only : UpwindFluxes
USE weno5,   only : WenoFluxes
USE fluxes,  only : InitializeFluxes, FinalizeFluxes, param, FluxI, FluxJ, FluxK

PRIVATE
PUBLIC :: GetRHSAdvection, InitializeAdvection, FinalizeAdvection

CONTAINS

    !> Function to evaluate the discrete advection operator.
    !! @param[in] Q The solution Q
    !! @param[out] RQ The discrete advection operator applied to Q.
    !! @param[in] order Either 1 for upwind or 5 for WENO5.
    SUBROUTINE GetRHSAdvection(Q, RQ, dx, dy, dz, i_start, i_end, j_start, j_end, k_start, k_end, order)

        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), INTENT(IN)  :: Q
        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), INTENT(OUT) :: RQ
        DOUBLE PRECISION, INTENT(IN)  :: dx, dy, dz
        INTEGER,          INTENT(IN)  :: i_start, i_end, j_start, j_end, k_start, k_end, order

        ! The current offset values better be in the range defined by the maximum offsets during initialization, otherwise
        ! you will get nice array out of bounds errors.
        param%i_start = i_start
        param%i_end   = i_end
        param%j_start = j_start
        param%j_end   = j_end
        param%k_start = k_start
        param%k_end   = k_end

        ! Update fluxes according to selected order
        SELECT CASE (order)

            CASE (1)
                CALL UpwindFluxes(Q)
            CASE (5)
                CALL WenoFluxes(Q)
            CASE DEFAULT
                WRITE(*,'(A,I2,A)') 'Now implementation available for order = ', order, ' .. now exiting'
                STOP
        END SELECT

       ! Right hand side \\( F_{\\text{adv}} \\) is given by the flux divergence
        CALL GetFluxDivergence(RQ, dx, dy, dz)

    END SUBROUTINE GetRHSAdvection

    !> Initializes the advection module and allocates required memory in the fluxes module.
    !! @param[in] i_min Minimum index in x direction
    !! @param[in] i_max Maximum index in x direction
    !! @param[in] j_min Minimum index in y direction
    !! @param[in] j_max Maximum index in y direction
    !! @param[in] k_min Minimun index in z direction
    !! @param[in] k_max Maximum index in z direction
    !! @param[in] Nthreads Number of OpenMP threads. Set to 1 when using MPI.
    !! @param[in] echo_on If true, the code produces a bunch of status messages during runtime.
    SUBROUTINE InitializeAdvection(i_min, i_max, j_min, j_max, k_min, k_max, Nthreads, echo_on)

        INTEGER, INTENT(IN) :: Nthreads, i_min, i_max, j_min, j_max, k_min, k_max
        LOGICAL, INTENT(IN) :: echo_on

        CALL InitializeFluxes(i_min, i_max, j_min, j_max, k_min, k_max, Nthreads, echo_on)

    END SUBROUTINE InitializeAdvection

    !> Finalizes the advection module and deallocates memory in the fluxes module.
    SUBROUTINE FinalizeAdvection()
        CALL FinalizeFluxes
    END SUBROUTINE FinalizeAdvection

    !> For computed fluxes f(q), compute the flux divergence
    !! \\( f(q)_x + f(q)_y + f(q)_z \\)
    !! @param[out] RQ the divergence of the flux f(Q)
    SUBROUTINE GetFluxDivergence(RQ, dx, dy, dz)

        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), INTENT(OUT) :: RQ
        DOUBLE PRECISION, INTENT(IN)  :: dx, dy, dz

        DOUBLE PRECISION :: coeff_x, coeff_y, coeff_z
        INTEGER          :: i, j, k, thread_nr

        coeff_x   = 1.0_8/dx
        coeff_y   = 1.0_8/dy
        coeff_z   = 1.0_8/dz

        thread_nr = omp_get_thread_num()

        DO k=param%k_start,param%k_end
            DO j=param%j_start,param%j_end
                DO i=param%i_start,param%i_end
                    RQ(i,j,k) = -coeff_x*( FluxI(i+1,j,   k,   thread_nr) - FluxI(i,j,k,thread_nr) ) &
                                -coeff_y*( FluxJ(i,  j+1, k,   thread_nr) - FluxJ(i,j,k,thread_nr) ) &
                                -coeff_z*( FluxK(i,  j,   k+1, thread_nr) - FluxK(i,j,k,thread_nr) )
                END DO
            END DO
        END DO

    END SUBROUTINE GetFluxDivergence

END MODULE advection


*DECK RG
      SUBROUTINE RG (NM, N, A, WR, WI, MATZ, Z, IV1, FV1, IERR)
C***BEGIN PROLOGUE  RG
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real general matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A2
C***TYPE      SINGLE PRECISION (RG-S, CG-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     To find the eigenvalues and eigenvectors (if desired)
C     of a REAL GENERAL matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the real general matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A has been destroyed.
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues.  The eigenvalues are unordered except
C          that complex conjugate pairs of eigenvalues appear consecu-
C          tively with the eigenvalue having the positive imaginary part
C          first.  If an error exit is made, the eigenvalues should be
C          correct for indices IERR+1, IERR+2, ..., N.  WR and WI are
C          one-dimensional REAL arrays, dimensioned WR(N) and WI(N).
C
C        Z contains the real and imaginary parts of the eigenvectors
C          if MATZ is not zero.  If the J-th eigenvalue is real, the
C          J-th column of Z contains its eigenvector.  If the J-th
C          eigenvalue is complex with positive imaginary part, the
C          J-th and (J+1)-th columns of Z contain the real and
C          imaginary parts of its eigenvector.  The conjugate of this
C          vector is the eigenvector for the conjugate eigenvalue.
C          Z is a two-dimensional REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30 iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
C                     computed.
C
C        IV1 and FV1 are one-dimensional temporary storage arrays of
C          dimension N.  IV1 is of type INTEGER and FV1 of type REAL.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  BALANC, BALBAK, ELMHES, ELTRAN, HQR, HQR2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C   921103  Corrected description of IV1.  (DWL, FNF and WRB)
C***END PROLOGUE  RG
C
      INTEGER N,NM,IS1,IS2,IERR,MATZ
      REAL A(NM,*),WR(*),WI(*),Z(NM,*),FV1(*)
      INTEGER IV1(*)
C
C***FIRST EXECUTABLE STATEMENT  RG
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 CALL  BALANC(NM,N,A,IS1,IS2,FV1)
      CALL  ELMHES(NM,N,IS1,IS2,A,IV1)
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  HQR(NM,N,IS1,IS2,A,WR,WI,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  ELTRAN(NM,N,IS1,IS2,A,IV1,Z)
      CALL  HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  BALBAK(NM,N,IS1,IS2,FV1,N,Z)
   50 RETURN
      END


      FUNCTION COSD(X)
          IMPLICIT NONE
          REAL :: COSD, UMR
          REAL, INTENT(IN) :: X
          UMR  = ATAN(1.0)*4./180.
          COSD = COS(X*UMR)

      END FUNCTION COSD

      FUNCTION SIND(X)
          IMPLICIT NONE
          REAL :: SIND, UMR
          REAL, INTENT(IN) :: X
          UMR  = ATAN(1.0)*4./180.
          SIND = SIN(X*UMR)

      END FUNCTION SIND


!---------------------------------------------------------------------------------------
!  This program computes the flux surfaces - Ay, by reading the the inplane magnetic field
!  components from data/bx.gda and data/bz.gda, taking the curl, and solving the needed
!  Poisson equation
!
!  This version is for a single sheet - periodic in x, with conducting BC in z
!---------------------------------------------------------------------------------------

module fft
    implicit none
    integer(kind=8) forward,inverse
    real(kind=8) norm,kx,pi
    real(kind=8), allocatable, dimension(:) :: kx2,in,out
    INTEGER FFTW_PATIENT
    PARAMETER (FFTW_PATIENT=32)
    INTEGER FFTW_R2HC
    PARAMETER (FFTW_R2HC=0)
    INTEGER FFTW_HC2R
    PARAMETER (FFTW_HC2R=1)
    INTEGER FFTW_RODFT00
    PARAMETER (FFTW_RODFT00=7)
    INTEGER FFTW_RODFT01
    PARAMETER (FFTW_RODFT01=8)
    INTEGER FFTW_RODFT10
    PARAMETER (FFTW_RODFT10=9)
    INTEGER FFTW_REDFT01
    PARAMETER (FFTW_REDFT01=4)
    INTEGER FFTW_REDFT10
    PARAMETER (FFTW_REDFT10=5)
end module fft

program translate
    use fft
    use hdf5
    implicit none
    integer input_record,output_record,input_error,output_error,record_length,it1,it2,i,j,it,interval
    integer(kind=4) :: nx,ny,nz
    real(kind=4) :: diff,xmax,ymax,zmax,time
    real(kind=4), allocatable, dimension(:,:) :: bx,bz,Ay,curlb
    real(kind=4), allocatable, dimension(:,:,:) :: tmp_array
    real(kind=8) :: dx,dz
    logical :: hdf5_fields  ! whether fields are saved in HDF5 format
    character(len=8) :: cit
    character(len=128) :: filename, groupname
    integer(hid_t) :: file_id, group_id, dataset_id, filespace
    integer(hsize_t), dimension(3) :: dset_dims, dset_dims_max
    integer :: error

    ! Range of time slices to convert.  Make big and let error terminate program
    it1 = 0
    it2 = 53
    interval = 11754
    hdf5_fields = .true.
    output_record = 0

    ! ! Open data information file to find out the size of the arrays
    ! open(unit=10,file='data/info',access='stream',status='old',form='unformatted')
    ! ! Read data from info  file
    ! read(10)nx,ny,nz
    ! read(10)xmax,ymax,zmax
    ! close(10)

    nx = 12288
    ny = 1
    nz = 12288
    xmax = 1536.0
    ymax = 0.25
    zmax = 1536.0

    ! Cell size

    dx = xmax/real(nx)
    dz = zmax/real(nz)

    ! Echo this information

    print *,"---------------------------------------------------"
    print *,"xmax=",xmax,"    zmax=",zmax
    print *,"nx=",nx,"   nz=",nz
    print *,"dx=",dx,"   dz=",dz
    print *,"---------------------------------------------------"

    ! Initialize FFT library

    allocate(in(nx))
    allocate(out(nx))
    norm = 1.0d0/sqrt(real(nx))
    call dfftw_plan_r2r_1d(forward,nx,in,out,FFTW_R2HC,FFTW_PATIENT)
    call dfftw_plan_r2r_1d(inverse,nx,in,out,FFTW_HC2R,FFTW_PATIENT)

    ! Wavectors in x direction ( Half-Complex Format )
    ! See page 10 of FFTW-3.0 manual for description

    allocate(kx2(nx))
    pi = acos(-1.0d0)
    kx2(1)=0.0d0
    do j=1,nx/2
        kx = (2.0d0*pi*real(j)/xmax)
        diff = sin(kx*dx/2.0d0)/(kx*dx/2.0d0)
        kx2(j+1) = (kx*diff)**2
    enddo
    do j=1,(nx+1)/2-1
        kx = (2.0d0*pi*real(j)/xmax)
        diff = sin(kx*dx/2.0d0)/(kx*dx/2.0d0)
        kx2(nx+1-j) = (kx*diff)**2
    enddo

    ! Allocate storage space for fields and moments

    allocate(bx(nx,nz))
    allocate(bz(nx,nz))
    allocate(Ay(nx,nz))
    allocate(curlb(nx,nz))
    allocate(tmp_array(nz,1,nx))

    ! Set record length for gda files

    ! Use this for Bill's gda format with extra time and it records
    ! inquire(iolength=record_length)bx,time,it

    ! Use this if you are only saving the matrix in the gda file
    inquire(iolength=record_length)bx

    ! *** WARNING - also make the read statments below consistent ***

    print *," Setting record length=",record_length

    ! Open all of the direct access binary files (Bill's preferred data format)
    ! Loop over time slices

    do input_record = it1,it2
        write(cit,'(I0)') input_record * interval
        print *,"Reading record=",input_record

        if (hdf5_fields) then
            call h5open_f(error)
            filename = "field_hdf5/T."//trim(cit)//"/fields_"//trim(cit)//".h5"
            groupname = "Timestep_"//trim(cit)
            call h5fopen_f(filename, H5F_ACC_RDWR_F, file_id, error, &
                access_prp=h5p_default_f)
            call h5gopen_f(file_id, groupname, group_id, error)

            ! bx
            call h5dopen_f(group_id, "cbx", dataset_id, error)
            call h5dget_space_f(dataset_id, filespace, error)
            call h5Sget_simple_extent_dims_f(filespace, dset_dims, dset_dims_max, error)
            call h5dread_f(dataset_id, H5T_NATIVE_REAL, tmp_array, dset_dims, error)
            call h5sclose_f(filespace, error)
            call h5dclose_f(dataset_id, error)
            bx = transpose(tmp_array(:,1,:))

            ! bz
            call h5dopen_f(group_id, "cbz", dataset_id, error)
            call h5dget_space_f(dataset_id, filespace, error)
            call h5Sget_simple_extent_dims_f(filespace, dset_dims, dset_dims_max, error)
            call h5dread_f(dataset_id, H5T_NATIVE_REAL, tmp_array, dset_dims, error)
            call h5sclose_f(filespace, error)
            call h5dclose_f(dataset_id, error)
            bz = transpose(tmp_array(:,1,:))

            call h5gclose_f(group_id, error)
            call h5fclose_f(file_id, error)
        else
            open(unit=20,file='data/bx.gda',access='direct',&
                recl=record_length,status='unknown',form='unformatted',action='read')
            open(unit=30,file='data/bz.gda',access='direct',&
                recl=record_length,status='unknown',form='unformatted',action='read')

            ! Read magnetic field data

            read(20, rec=input_record+1)bx
            read(30, rec=input_record+1)bz
            close(20)
            close(30)
        endif

        ! Compute Curl of magnetic field

        print *,"Computing curl"

        do i=2,nx-1
            do j=2,nz-1
                curlb(i,j) = (bx(i,j+1)-bx(i,j-1))/(2.0*dz) - (bz(i+1,j)-bz(i-1,j))/(2.0*dx)
                ! curlb(i,j) = (bx(i,k,j+1)-bx(i,k,j-1))/(2.0*dz) - (bz(i+1,k,j)-bz(i-1,k,j))/(2.0*dx)
            enddo
        enddo
        curlb(1,:) = curlb(2,:)
        curlb(nx,:) = curlb(nx-1,:)
        curlb(:,1) = curlb(:,nz-1)
        curlb(:,nz) = curlb(:,2)

        ! Solve Poisson equation

        print *,"Solving Poisson"
        call poisson(dx,nx,dz,nz,curlb,Ay,bx)

        ! Save flux surfaces

        print *,"Saving Ay"
        output_record = output_record +1
        open(unit=40,file='data/Ay.gda',access='direct', &
         recl=record_length,status='unknown',form='unformatted',action='write')
        !write(40,rec=output_record)Ay,time,it
        write(40,rec=output_record)Ay
        close(40)
    enddo

    deallocate(in, out)
    deallocate(kx2)
    deallocate(bx, bz, Ay, curlb, tmp_array)
end program translate

subroutine poisson(dx,nx,dz,nz,rho,phi,bx)
    use fft
    implicit none
    integer nx,nz,i,j
    real(kind=4) phi(nx,nz),rho(nx,nz),bx(nx,nz)
    real(kind=8) dx,dz,dx2,dz2,ak(nx,nz)
    real(kind=8) d(nz),g(nz),w(nz),rhs(nz),cycle(nx,nz)
    real(kind=8) error,maxerror,delsq,bsum

    ! Do internal calculation in double precision to avoid round-off on large grids

    ! Constants

    dz2 = dz**2
    dx2 = dx**2

    ! fft in x-direction
    do j=1,nz
        in(:) = -dz2*real(rho(:,j),kind=8)
        call dfftw_execute(forward)
        ak(:,j) = norm*out(:)
    enddo

    ! Now do a tri-diagonal solve across the z-direction

    do i=1,nx
        d(:) = -2.0d0 - dz2*kx2(i)
        d(1) = -3.0d0 - dz2*kx2(i)  ! phi=0 at z=0
        d(nz) = -3.0d0 - dz2*kx2(i) ! phi = 0 at z=zmax - fix this below
        w(1) = 1.0d0/d(1)
        g(1) = ak(i,1)/d(1)
        do j=2,nz
            w(j) = 1.0d0/(d(j)-w(j-1))
            g(j) = (ak(i,j)-g(j-1))*w(j)
        enddo
        ak(i,nz) = g(nz)
        do j=nz-1,1,-1
            ak(i,j) = g(j) - w(j)*ak(i,j+1)
        enddo
    enddo

    ! Now take inverse FFT

    do j=1,nz
        in(:) = ak(:,j)
        call dfftw_execute(inverse)
        ak(:,j) = norm*out(:)
    enddo

    ! Now add correction for oblique or asymmetric layers

    bsum = 0.0d0
    do i=1,nx
        do j=1,nz
            bsum = bsum + bx(i,j)
        enddo
    enddo
    bsum = -bsum/real(nz*nx)

    do i=1,nx
        do j=1,nz
            ak(i,j) = ak(i,j) + bsum*real(j-nz/2)*dz
        enddo
    enddo

    ! Do error check on solution

    maxerror = 0.0
    do i=2,nx-1
        do j=2,nz-1
            delsq = (ak(i+1,j)-2.0*ak(i,j)+ak(i-1,j))/dx2 + (ak(i,j+1)-2.0*ak(i,j)+ak(i,j-1))/dz2
            error = abs(real(rho(i,j),kind=8) + delsq)
            if (error > maxerror) maxerror=error
        enddo
    enddo
    print *,"Error in poisson solve = ", maxerror

    ! Return solution in single precision
    phi(:,:) = real(ak(:,:),kind=4)
    return
end subroutine poisson


! =========================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =========================================================

! Solve Riemann problems for the 1D advection equation q_t + u(x)*q_x = 0
! with variable u(x) in non-conservative form (the color equation)

! waves:     1
! equations: 1

! Conserved quantities:
!       1 q

! Auxiliary variables:
!       1 velocity

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q

! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routine step1, rp is called with ql = qr = q.

    implicit double precision (a-h,o-z)
    dimension   ql(meqn,1-mbc:maxmx+mbc)
    dimension   qr(meqn,1-mbc:maxmx+mbc)
    dimension  auxl(maux,1-mbc:maxmx+mbc)
    dimension  auxr(maux,1-mbc:maxmx+mbc)
    dimension    s(mwaves,1-mbc:maxmx+mbc)
    dimension wave(meqn, mwaves,1-mbc:maxmx+mbc)
    dimension amdq(meqn,1-mbc:maxmx+mbc)
    dimension apdq(meqn,1-mbc:maxmx+mbc)
    common /comrp/ u

    do 30 i=2-mbc,mx+mbc

    !        # Compute the wave and speed

        u = dmin1(auxr(1,i-1),0.d0) +  dmax1(auxl(1,i),0.d0)

    !        # the formula below seems to work as well...
    !        u = 0.5d0 * (auxr(1,i-1) +  auxl(1,i))

        wave(1,1,i) = ql(1,i) - qr(1,i-1)
        s(1,i) = u
        amdq(1,i) = dmin1(auxr(1,i-1), 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(auxl(1,i),   0.d0) * wave(1,1,i)
    30 END DO

    return
    end subroutine rp1