!*****************************************************************************************
!>
!  This program tests codes for the least-squares solution of
!  m nonlinear equations in n variables. it consists of a driver
!  and an interface subroutine fcn. the driver reads in data,
!  calls the nonlinear least-squares 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 and jacobian
!  subroutines in the various nonlinear least-squares solvers.

program test_lmstr

    use minpack_module, only: wp, dpmpar, enorm, lmstr1
    use iso_fortran_env, only: nwrite => output_unit

    implicit none

    ! originally from file22
    integer,parameter :: ncases = 28
    integer,dimension(ncases),parameter :: nprobs  = [1,1,2,2,3,3,4,5,6,7,8,9,10,11,11,11,12,13,14,15,15,15,15,16,16,16,17,18]
    integer,dimension(ncases),parameter :: ns      = [5,5,5,5,5,5,2,3,4,2,3,4,3,6,9,12,3,2,4,1,8,9,10,10,30,40,5,11]
    integer,dimension(ncases),parameter :: ms      = [10,50,10,50,10,50,2,3,4,2,15,11,16,31,31,31,10,10,20,8,8,9,10,10,30,40,33,65]
    integer,dimension(ncases),parameter :: ntriess = [1,1,1,1,1,1,3,3,3,3,3,3,2,3,3,3,1,1,3,3,1,1,1,3,1,1,1,1]

    integer,dimension(53),parameter :: info_original = [2,3,1,1,1,1,4,2,2,2,2,2,4,4,4,1,1,1,1,1,1,1,1,5,3,5,&
                                                        1,1,1,3,3,2,3,2,3,2,1,1,1,1,4,1,1,1,2,1,2,2,2,2,2,1,1]
                                                        !! original `info` from the original minpack

    integer,dimension(:),allocatable :: iwa
    real(wp),dimension(:),allocatable :: wa
    real(wp),dimension(:,:),allocatable :: fjac
    real(wp),dimension(:),allocatable :: fvec
    real(wp),dimension(:),allocatable :: x
    integer :: i, ic, info, k, ldfjac, lwa, m, n, NFEv, NJEv,  &
               NPRob, ntries, icase
    integer :: ma(53), na(53), nf(53), nj(53), np(53), nx(53)
    real(wp) :: fnm(53)
    real(wp) :: factor, fnorm1, fnorm2

    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_abstol = 1.0e-5_wp !! abstol for matching previously generated solutions
    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 LMSTR1'
            write (nwrite, '(A/)')      ' NPROB   N    M   NFEV  NJEV  INFO  FINAL L2 NORM'
            do i = 1, ic
                write (nwrite, '(3I5, 3I6, 1X, D15.7)') np(i), na(i), ma(i), nf(i), nj(i), nx(i), fnm(i)
            end do
            stop
        else
            nprob = nprobs(icase)
            n = ns(icase)
            m = ms(icase)
            lwa = 5*n+m
            ldfjac = n
            if (allocated(iwa)) deallocate(iwa);    allocate(iwa(n))
            if (allocated(wa)) deallocate(wa);      allocate(wa(lwa))
            if (allocated(fjac)) deallocate(fjac);  allocate(fjac(n,n))
            if (allocated(fvec)) deallocate(fvec);  allocate(fvec(m))
            if (allocated(x)) deallocate(x);        allocate(x(n))

            ntries = ntriess(icase)
            factor = one
            do k = 1, ntries
                ic = ic + 1
                call initpt(n, x, NPRob, factor)
                call ssqfcn(m, n, x, fvec, NPRob)
                fnorm1 = enorm(m, fvec)
                write (nwrite, '(////5X,A,I5,5X,A,2I5,5X//)') ' PROBLEM', NPRob, ' DIMENSIONS', n, m
                NFEv = 0
                NJEv = 0
                call lmstr1(fcn, m, n, x, fvec, fjac, ldfjac, tol, info, iwa, wa, lwa)
                call ssqfcn(m, n, x, fvec, NPRob)
                fnorm2 = enorm(m, fvec)
                np(ic) = NPRob
                na(ic) = n
                ma(ic) = m
                nf(ic) = NFEv
                nj(ic) = NJEv
                nx(ic) = info
                fnm(ic) = fnorm2
                write (nwrite, '(5x,a,d15.7//5x,a,d15.7//5x,a,i10//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,   &
                        ' NUMBER OF JACOBIAN EVALUATIONS  ', NJEv,   &
                        ' EXIT PARAMETER', info, &
                        ' FINAL APPROXIMATE SOLUTION', x(1:n)
                factor = ten*factor
                call compare_solutions(ic, x, solution_reltol, solution_abstol)
            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
!  least squares solver. if iflag = 1, fcn should only call the
!  testing function subroutine ssqfcn. if iflag = i, i >= 2,
!  fcn should only call subroutine ssqjac to calculate the
!  (i-1)-st row of the jacobian. (the ssqjac subroutine provided
!  here for testing purposes calculates the entire jacobian
!  matrix and is therefore called only when iflag = 2.) each
!  call to ssqfcn or ssqjac should specify the appropriate
!  value of problem number (nprob).

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

    integer,intent(in) :: m
    integer,intent(in) :: n
    integer,intent(inout) :: Iflag
    real(wp),intent(in) :: x(n)
    real(wp),intent(inout) :: Fvec(m)
    real(wp),intent(inout) :: Fjrow(n)

    integer,parameter :: Ldfjac = 65

    integer :: j
    real(wp), save :: temp(Ldfjac, 40)
        !! this array is filled when FCN is called with IFLAG=2.
        !! When FCN is called with IFLAG=2,3,..., the argument array
        !! FJROW is filled with a row of TEMP. This will work only if
        !! TEMP is given the SAVE attribute, which was not done in
        !! the original code.

    select case (Iflag)
    case(1)
        call ssqfcn(m, n, x, Fvec, NPRob)
        NFEv = NFEv + 1
        return
    case(2)
        ! populate the temp array
        call ssqjac(m, n, x, temp, Ldfjac, NPRob)
        NJEv = NJEv + 1
    end select

    ! for iflag = 2,3,... get the row from temp
    do j = 1, n
        Fjrow(j) = temp(Iflag - 1, j)
    end do

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,-0.1000000000000000E+01_wp,&
                         -0.1000000000000000E+01_wp,-0.9999999999999992E+00_wp]
        case (  2); x = [-0.1000000000000001E+01_wp,-0.1000000000000000E+01_wp,-0.9999999999999960E+00_wp,&
                         -0.9999999999999982E+00_wp,-0.1000000000000001E+01_wp]
        case (  3); x = [ 0.2561515109810807E+03_wp,-0.1557989602750597E+02_wp, 0.1294492228753740E+03_wp,&
                         -0.7289948013753003E+01_wp,-0.1168073476708643E+03_wp]
        case (  4); x = [ 0.9059979768060809E+02_wp, 0.7667581483950413E+02_wp, 0.8463689104480578E+02_wp,&
                          0.3883790741975204E+02_wp,-0.1306368054405490E+03_wp]
        case (  5); x = [ 0.1000000000000000E+01_wp, 0.2146513294878052E+03_wp,-0.1024194005964338E+03_wp,&
                         -0.3046699664951840E+02_wp, 0.1000000000000000E+01_wp]
        case (  6); x = [ 0.1000000000000000E+01_wp,-0.1453732603711001E+03_wp, 0.1438958372244028E+03_wp,&
                         -0.3522751577398922E+02_wp, 0.1000000000000000E+01_wp]
        case (  7); x = [ 0.1000000000000000E+01_wp, 0.1000000000000000E+01_wp]
        case (  8); x = [ 0.1000000000000000E+01_wp, 0.1000000000000000E+01_wp]
        case (  9); x = [ 0.1000000000000000E+01_wp, 0.1000000000000000E+01_wp]
        case ( 10); x = [ 0.1000000000000000E+01_wp,-0.6243302423970055E-17_wp, 0.0000000000000000E+00_wp]
        case ( 11); x = [ 0.1000000000000000E+01_wp, 0.6563910805155555E-20_wp, 0.0000000000000000E+00_wp]
        case ( 12); x = [ 0.1000000000000000E+01_wp,-0.1972152263052530E-29_wp, 0.0000000000000000E+00_wp]
        case ( 13); x = [ 0.1652117596168386E-16_wp,-0.1652117596168386E-17_wp, 0.2643388153869423E-17_wp,&
                          0.2643388153869423E-17_wp]
        case ( 14); x = [ 0.2065146995210483E-16_wp,-0.2065146995210483E-17_wp, 0.3304235192336774E-17_wp,&
                          0.3304235192336774E-17_wp]
        case ( 15); x = [ 0.1290716872006552E-16_wp,-0.1290716872006552E-17_wp, 0.2065146995210478E-17_wp,&
                          0.2065146995210478E-17_wp]
        case ( 16); x = [ 0.1141248446549926E+02_wp,-0.8968279137315114E+00_wp]
        case ( 17); x = [ 0.1141300466147463E+02_wp,-0.8967960386859540E+00_wp]
        case ( 18); x = [ 0.1141278178578780E+02_wp,-0.8968051074920977E+00_wp]
        case ( 19); x = [ 0.8241057657583328E-01_wp, 0.1133036653471502E+01_wp, 0.2343694638941156E+01_wp]
        case ( 20); x = [ 0.8406666738183292E+00_wp,-0.1588480332595652E+09_wp,-0.1643786716535350E+09_wp]
        case ( 21); x = [ 0.8406666738676454E+00_wp,-0.1589461672055181E+09_wp,-0.1644649068577709E+09_wp]
        case ( 22); x = [ 0.1928078104762493E+00_wp, 0.1912626533540697E+00_wp, 0.1230528010469306E+00_wp,&
                          0.1360532211505162E+00_wp]
        case ( 23); x = [ 0.7286754737688021E+06_wp,-0.1407588031293926E+02_wp,-0.3297779778420302E+08_wp,&
                         -0.2057159419780570E+08_wp]
        case ( 24); x = [ 0.1928081061389676E+00_wp, 0.1912560109262705E+00_wp, 0.1230515496222497E+00_wp,&
                          0.1360501459183326E+00_wp]
        case ( 25); x = [ 0.5609636476947878E-02_wp, 0.6181346345409401E+04_wp, 0.3452236345945471E+03_wp]
        case ( 26); x = [ 0.8796346510290913E-11_wp, 0.3464217981622328E+05_wp, 0.9148762438218395E+03_wp]
        case ( 27); x = [-0.1572496150837810E-01_wp, 0.1012434882329655E+01_wp,-0.2329917223876732E+00_wp,&
                          0.1260431011028184E+01_wp,-0.1513730313944207E+01_wp, 0.9929972729184212E+00_wp]
        case ( 28); x = [-0.1572519013866755E-01_wp, 0.1012434858601051E+01_wp,-0.2329915458438306E+00_wp,&
                          0.1260429320891634E+01_wp,-0.1513727767065756E+01_wp, 0.9929957342632842E+00_wp]
        case ( 29); x = [-0.1572470197125892E-01_wp, 0.1012434909256583E+01_wp,-0.2329919227616438E+00_wp,&
                          0.1260432929295550E+01_wp,-0.1513733204527069E+01_wp, 0.9929990192232202E+00_wp]
        case ( 30); x = [-0.1530706441665223E-04_wp, 0.9997897039345965E+00_wp, 0.1476396349111473E-01_wp,&
                          0.1463423301458067E+00_wp, 0.1000821094549045E+01_wp,-0.2617731120707204E+01_wp,&
                          0.4104403139436332E+01_wp,-0.3143612262364274E+01_wp, 0.1052626403788084E+01_wp]
        case ( 31); x = [-0.1530703649598812E-04_wp, 0.9997897039319464E+00_wp, 0.1476396369371614E-01_wp,&
                          0.1463423282979424E+00_wp, 0.1000821103011242E+01_wp,-0.2617731140534388E+01_wp,&
                          0.4104403164498381E+01_wp,-0.3143612278569126E+01_wp, 0.1052626408013491E+01_wp]
        case ( 32); x = [-0.1530703652139991E-04_wp, 0.9997897039319481E+00_wp, 0.1476396369357189E-01_wp,&
                          0.1463423282991793E+00_wp, 0.1000821103005637E+01_wp,-0.2617731140521392E+01_wp,&
                          0.4104403164482094E+01_wp,-0.3143612278558673E+01_wp, 0.1052626408010778E+01_wp]
        case ( 33); x = [-0.6602659327962938E-08_wp, 0.1000001644118327E+01_wp,-0.5639321470774273E-03_wp,&
                          0.3478205400521048E+00_wp,-0.1567315002542552E+00_wp, 0.1052815158301577E+01_wp,&
                         -0.3247271095327381E+01_wp, 0.7288434784001158E+01_wp,-0.1027184809891813E+02_wp,&
                          0.9074113537386525E+01_wp,-0.4541375419278813E+01_wp, 0.1012011879768094E+01_wp]
        case ( 34); x = [-0.6638060464411604E-08_wp, 0.1000001644117862E+01_wp,-0.5639322103635158E-03_wp,&
                          0.3478205405045170E+00_wp,-0.1567315041009225E+00_wp, 0.1052815177233611E+01_wp,&
                         -0.3247271153548033E+01_wp, 0.7288434898122469E+01_wp,-0.1027184824156328E+02_wp,&
                          0.9074113647268060E+01_wp,-0.4541375466778046E+01_wp, 0.1012011888568983E+01_wp]
        case ( 35); x = [-0.6637951126821797E-08_wp, 0.1000001644117862E+01_wp,-0.5639322100134774E-03_wp,&
                          0.3478205405003073E+00_wp,-0.1567315040668739E+00_wp, 0.1052815177081149E+01_wp,&
                         -0.3247271153132584E+01_wp, 0.7288434897408339E+01_wp,-0.1027184824078557E+02_wp,&
                          0.9074113646748899E+01_wp,-0.4541375466584788E+01_wp, 0.1012011888538411E+01_wp]
        case ( 36); x = [ 0.9999999999999999E+00_wp, 0.1000000000000000E+02_wp, 0.1000000000000000E+01_wp]
        case ( 37); x = [ 0.2578199266368066E+00_wp, 0.2578299767645460E+00_wp]
        case ( 38); x = [-0.1159124627062127E+02_wp, 0.1320248655827936E+02_wp,-0.4035748532873218E+00_wp,&
                          0.2367362096235223E+00_wp]
        case ( 39); x = [-0.1159592742718941E+02_wp, 0.1320418669261399E+02_wp,-0.4034173629293835E+00_wp,&
                          0.2367711433462491E+00_wp]
        case ( 40); x = [-0.1159026120687546E+02_wp, 0.1320206344847849E+02_wp,-0.4036926117131069E+00_wp,&
                          0.2366618932408272E+00_wp]
        case ( 41); x = [ 0.5000000000000000E+00_wp]
        case ( 42); x = [ 0.9817314924683995E+00_wp]
        case ( 43); x = [ 0.9817314852933997E+00_wp]
        case ( 44); x = [ 0.4315366485873597E-01_wp, 0.1930916378432680E+00_wp, 0.2663285938126974E+00_wp,&
                          0.4999993346289134E+00_wp, 0.5000006653710866E+00_wp, 0.7336714061873026E+00_wp,&
                          0.8069083621567320E+00_wp, 0.9568463351412640E+00_wp]
        case ( 45); x = [ 0.4420534613578272E-01_wp, 0.1994906723098810E+00_wp, 0.2356191084710600E+00_wp,&
                          0.4160469078925981E+00_wp, 0.5000000000000000E+00_wp, 0.5839530921074020E+00_wp,&
                          0.7643808915289400E+00_wp, 0.8005093276901191E+00_wp, 0.9557946538642172E+00_wp]
        case ( 46); x = [ 0.5962026717535887E-01_wp, 0.1667087838059411E+00_wp, 0.2391710188135120E+00_wp,&
                          0.3988852903460409E+00_wp, 0.3988836678709105E+00_wp, 0.6011163321290895E+00_wp,&
                          0.6011147096539592E+00_wp, 0.7608289811864880E+00_wp, 0.8332912161940590E+00_wp,&
                          0.9403797328246412E+00_wp]
        case ( 47); x = [ 0.9794303033498616E+00_wp, 0.9794303033498616E+00_wp, 0.9794303033498616E+00_wp,&
                          0.9794303033498616E+00_wp, 0.9794303033498616E+00_wp, 0.9794303033498616E+00_wp,&
                          0.9794303033498616E+00_wp, 0.9794303033498616E+00_wp, 0.9794303033498616E+00_wp,&
                          0.1205696966501385E+01_wp]
        case ( 48); x = [ 0.9794303033498644E+00_wp, 0.9794303033498644E+00_wp, 0.9794303033498644E+00_wp,&
                          0.9794303033498644E+00_wp, 0.9794303033498644E+00_wp, 0.9794303033498644E+00_wp,&
                          0.9794303033498644E+00_wp, 0.9794303033498644E+00_wp, 0.9794303033498644E+00_wp,&
                          0.1205696966501354E+01_wp]
        case ( 49); x = [ 0.9794303033498626E+00_wp, 0.9794303033498626E+00_wp, 0.9794303033498626E+00_wp,&
                          0.9794303033498626E+00_wp, 0.9794303033498626E+00_wp, 0.9794303033498626E+00_wp,&
                          0.9794303033498626E+00_wp, 0.9794303033498626E+00_wp, 0.9794303033498626E+00_wp,&
                          0.1205696966501374E+01_wp]
        case ( 50); x = [ 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp,&
                          0.9977542164428299E+00_wp, 0.9977542164428299E+00_wp, 0.1067373506715082E+01_wp]
        case ( 51); x = [ 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp, 0.1000000000000028E+01_wp,&
                          0.9999999999988959E+00_wp]
        case ( 52); x = [ 0.3754100492440249E+00_wp, 0.1935846545431039E+01_wp,-0.1464686767487118E+01_wp,&
                          0.1286753391104384E-01_wp, 0.2212270118130775E-01_wp]
        case ( 53); x = [ 0.1309976638100963E+01_wp, 0.4315524807599997E+00_wp, 0.6336612616028594E+00_wp,&
                          0.5994285609916951E+00_wp, 0.7541797682724487E+00_wp, 0.9043000823785183E+00_wp,&
                          0.1365799495210074E+01_wp, 0.4823731997481072E+01_wp, 0.2398684751048711E+01_wp,&
                          0.4568875547914517E+01_wp, 0.5675342062730520E+01_wp]
        case default
            error stop 'invalid case'
        end select

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

!*****************************************************************************************
!>
!  This subroutine defines the jacobian matrices of eighteen
!  nonlinear least squares problems. the problem dimensions are
!  as described in the prologue comments of ssqfcn.

subroutine ssqjac(m, n, x, Fjac, Ldfjac, Nprob)
    implicit none

    integer,intent(in) :: m !! positive integer input variable.
    integer,intent(in) :: n !! positive integer input variable. n must not exceed m.
    integer,intent(in) :: Ldfjac !! a positive integer input variable not less than m
                                 !! which specifies the leading dimension of the array fjac.
    integer,intent(in) :: Nprob !! a positive integer variable which defines the
                                !! number of the problem. nprob must not exceed 18.
    real(wp),intent(in) :: x(n) !! an input array of length n.
    real(wp),intent(out) :: Fjac(Ldfjac, n) !! an m by n output array which contains the jacobian
                                            !! matrix of the nprob function 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 :: four = 4.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 :: c14 = 14.0_wp
    real(wp),parameter :: c20 = 20.0_wp
    real(wp),parameter :: c29 = 29.0_wp
    real(wp),parameter :: c45 = 45.0_wp
    real(wp),parameter :: c100 = 100.0_wp

    real(wp),parameter :: v(11) = [4.0_wp, 2.0_wp, 1.0_wp, 5.0e-1_wp, 2.5e-1_wp, 1.67e-1_wp, &
                                   1.25e-1_wp, 1.0e-1_wp, 8.33e-2_wp, 7.14e-2_wp, 6.25e-2_wp]

    integer :: i, ivar, j, k, mm1, nm1
    real(wp) :: div, dx, prod, s2, temp, ti, tmp1, tmp2, tmp3, tmp4, tpi

    Fjac(1:m, 1:n) = zero

    ! JACOBIAN ROUTINE SELECTOR.

    select case (Nprob)
    case (2)
        ! LINEAR FUNCTION - RANK 1.
        do j = 1, n
            do i = 1, m
                Fjac(i, j) = dfloat(i)*dfloat(j)
            end do
        end do
    case (3)
        ! LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
        do j = 1, n
            do i = 1, m
                Fjac(i, j) = zero
            end do
        end do
        nm1 = n - 1
        mm1 = m - 1
        if (nm1 >= 2) then
            do j = 2, nm1
                do i = 2, mm1
                    Fjac(i, j) = dfloat(i - 1)*dfloat(j)
                end do
            end do
        end if
    case (4)
        ! ROSENBROCK FUNCTION.
        Fjac(1, 1) = -c20*x(1)
        Fjac(1, 2) = ten
        Fjac(2, 1) = -one
        Fjac(2, 2) = zero
    case (5)
        ! HELICAL VALLEY FUNCTION.
        tpi = eight*atan(one)
        temp = x(1)**2 + x(2)**2
        tmp1 = tpi*temp
        tmp2 = sqrt(temp)
        Fjac(1, 1) = c100*x(2)/tmp1
        Fjac(1, 2) = -c100*x(1)/tmp1
        Fjac(1, 3) = ten
        Fjac(2, 1) = ten*x(1)/tmp2
        Fjac(2, 2) = ten*x(2)/tmp2
        Fjac(2, 3) = zero
        Fjac(3, 1) = zero
        Fjac(3, 2) = zero
        Fjac(3, 3) = one
    case (6)
        ! POWELL SINGULAR FUNCTION.
        do j = 1, 4
            do i = 1, 4
                Fjac(i, j) = zero
            end do
        end do
        Fjac(1, 1) = one
        Fjac(1, 2) = ten
        Fjac(2, 3) = sqrt(five)
        Fjac(2, 4) = -Fjac(2, 3)
        Fjac(3, 2) = two*(x(2) - two*x(3))
        Fjac(3, 3) = -two*Fjac(3, 2)
        Fjac(4, 1) = two*sqrt(ten)*(x(1) - x(4))
        Fjac(4, 4) = -Fjac(4, 1)
    case (7)
        ! FREUDENSTEIN AND ROTH FUNCTION.
        Fjac(1, 1) = one
        Fjac(1, 2) = x(2)*(ten - three*x(2)) - two
        Fjac(2, 1) = one
        Fjac(2, 2) = x(2)*(two + three*x(2)) - c14
    case (8)
        ! BARD FUNCTION.
        do i = 1, 15
            tmp1 = dfloat(i)
            tmp2 = dfloat(16 - i)
            tmp3 = tmp1
            if (i > 8) tmp3 = tmp2
            tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2
            Fjac(i, 1) = -one
            Fjac(i, 2) = tmp1*tmp2/tmp4
            Fjac(i, 3) = tmp1*tmp3/tmp4
        end do
    case (9)
        ! KOWALIK AND OSBORNE FUNCTION.
        do i = 1, 11
            tmp1 = v(i)*(v(i) + x(2))
            tmp2 = v(i)*(v(i) + x(3)) + x(4)
            Fjac(i, 1) = -tmp1/tmp2
            Fjac(i, 2) = -v(i)*x(1)/tmp2
            Fjac(i, 3) = Fjac(i, 1)*Fjac(i, 2)
            Fjac(i, 4) = Fjac(i, 3)/v(i)
        end do
    case (10)
        ! MEYER FUNCTION.
        do i = 1, 16
            temp = five*dfloat(i) + c45 + x(3)
            tmp1 = x(2)/temp
            tmp2 = exp(tmp1)
            Fjac(i, 1) = tmp2
            Fjac(i, 2) = x(1)*tmp2/temp
            Fjac(i, 3) = -tmp1*Fjac(i, 2)
        end do
    case (11)
        ! WATSON FUNCTION.
        do i = 1, 29
            div = dfloat(i)/c29
            s2 = zero
            dx = one
            do j = 1, n
                s2 = s2 + dx*x(j)
                dx = div*dx
            end do
            temp = two*div*s2
            dx = one/div
            do j = 1, n
                Fjac(i, j) = dx*(dfloat(j - 1) - temp)
                dx = div*dx
            end do
        end do
        do j = 1, n
            do i = 30, 31
                Fjac(i, j) = zero
            end do
        end do
        Fjac(30, 1) = one
        Fjac(31, 1) = -two*x(1)
        Fjac(31, 2) = one
    case (12)
        ! BOX 3-DIMENSIONAL FUNCTION.
        do i = 1, m
            temp = dfloat(i)
            tmp1 = temp/ten
            Fjac(i, 1) = -tmp1*exp(-tmp1*x(1))
            Fjac(i, 2) = tmp1*exp(-tmp1*x(2))
            Fjac(i, 3) = exp(-temp) - exp(-tmp1)
        end do
    case (13)
        ! JENNRICH AND SAMPSON FUNCTION.
        do i = 1, m
            temp = dfloat(i)
            Fjac(i, 1) = -temp*exp(temp*x(1))
            Fjac(i, 2) = -temp*exp(temp*x(2))
        end do
    case (14)
        ! BROWN AND DENNIS FUNCTION.
        do i = 1, m
            temp = dfloat(i)/five
            ti = sin(temp)
            tmp1 = x(1) + temp*x(2) - exp(temp)
            tmp2 = x(3) + ti*x(4) - cos(temp)
            Fjac(i, 1) = two*tmp1
            Fjac(i, 2) = temp*Fjac(i, 1)
            Fjac(i, 3) = two*tmp2
            Fjac(i, 4) = ti*Fjac(i, 3)
        end do
    case (15)
        ! CHEBYQUAD FUNCTION.
        dx = one/dfloat(n)
        do j = 1, n
            tmp1 = one
            tmp2 = two*x(j) - one
            temp = two*tmp2
            tmp3 = zero
            tmp4 = two
            do i = 1, m
                Fjac(i, j) = dx*tmp4
                ti = four*tmp2 + temp*tmp4 - tmp3
                tmp3 = tmp4
                tmp4 = ti
                ti = temp*tmp2 - tmp1
                tmp1 = tmp2
                tmp2 = ti
            end do
        end do
    case (16)
        ! BROWN ALMOST-LINEAR FUNCTION.
        prod = one
        do j = 1, n
            prod = x(j)*prod
            do i = 1, n
                Fjac(i, j) = one
            end do
            Fjac(j, j) = two
        end do
        do j = 1, n
            temp = x(j)
            if (temp == zero) then
                temp = one
                prod = one
                do k = 1, n
                    if (k /= j) prod = x(k)*prod
                end do
            end if
            Fjac(n, j) = prod/temp
        end do
    case (17)
        ! OSBORNE 1 FUNCTION.
        do i = 1, 33
            temp = ten*dfloat(i - 1)
            tmp1 = exp(-x(4)*temp)
            tmp2 = exp(-x(5)*temp)
            Fjac(i, 1) = -one
            Fjac(i, 2) = -tmp1
            Fjac(i, 3) = -tmp2
            Fjac(i, 4) = temp*x(2)*tmp1
            Fjac(i, 5) = temp*x(3)*tmp2
        end do
    case (18)
        ! OSBORNE 2 FUNCTION.
        do i = 1, 65
            temp = dfloat(i - 1)/ten
            tmp1 = exp(-x(5)*temp)
            tmp2 = exp(-x(6)*(temp - x(9))**2)
            tmp3 = exp(-x(7)*(temp - x(10))**2)
            tmp4 = exp(-x(8)*(temp - x(11))**2)
            Fjac(i, 1) = -tmp1
            Fjac(i, 2) = -tmp2
            Fjac(i, 3) = -tmp3
            Fjac(i, 4) = -tmp4
            Fjac(i, 5) = temp*x(1)*tmp1
            Fjac(i, 6) = x(2)*(temp - x(9))**2*tmp2
            Fjac(i, 7) = x(3)*(temp - x(10))**2*tmp3
            Fjac(i, 8) = x(4)*(temp - x(11))**2*tmp4
            Fjac(i, 9) = -two*x(2)*x(6)*(temp - x(9))*tmp2
            Fjac(i, 10) = -two*x(3)*x(7)*(temp - x(10))*tmp3
            Fjac(i, 11) = -two*x(4)*x(8)*(temp - x(11))*tmp4
        end do
    case default
        ! LINEAR FUNCTION - FULL RANK.
        temp = two/dfloat(m)
        do j = 1, n
            do i = 1, m
                Fjac(i, j) = -temp
            end do
            Fjac(j, j) = Fjac(j, j) + one
        end do
    end select

end subroutine ssqjac
!*****************************************************************************************

!*****************************************************************************************
!>
!  This subroutine specifies the standard starting points for the
!  functions defined by subroutine ssqfcn. the subroutine returns
!  in x a multiple (factor) of the standard starting point. for
!  the 11th 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.
    integer,intent(in) :: Nprob !! a positive integer input variable which defines the
                                !! number of the problem. nprob must not exceed 18.
    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.
    real(wp),intent(out) :: x(n) !! an output array of length n which contains the standard
                                 !! starting point for problem nprob multiplied by factor.

    real(wp),parameter :: zero = 0.0_wp
    real(wp),parameter :: half = 0.5_wp
    real(wp),parameter :: one = 1.0_wp
    real(wp),parameter :: two = 2.0_wp
    real(wp),parameter :: three = 3.0_wp
    real(wp),parameter :: five = 5.0_wp
    real(wp),parameter :: seven = 7.0_wp
    real(wp),parameter :: ten = 10.0_wp
    real(wp),parameter :: twenty = 20.0_wp
    real(wp),parameter :: twntf = 25.0_wp

    real(wp),parameter :: c1 = 1.2_wp
    real(wp),parameter :: c2 = 2.5e-1_wp
    real(wp),parameter :: c3 = 3.9e-1_wp
    real(wp),parameter :: c4 = 4.15e-1_wp
    real(wp),parameter :: c5 = 2.0e-2_wp
    real(wp),parameter :: c6 = 4.0e3_wp
    real(wp),parameter :: c7 = 2.5e2_wp
    real(wp),parameter :: c8 = 3.0e-1_wp
    real(wp),parameter :: c9 = 4.0e-1_wp
    real(wp),parameter :: c10 = 1.5_wp
    real(wp),parameter :: c11 = 1.0e-2_wp
    real(wp),parameter :: c12 = 1.3_wp
    real(wp),parameter :: c13 = 6.5e-1_wp
    real(wp),parameter :: c14 = 7.0e-1_wp
    real(wp),parameter :: c15 = 6.0e-1_wp
    real(wp),parameter :: c16 = 4.5_wp
    real(wp),parameter :: c17 = 5.5_wp

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

    x(1:n) = zero

    ! SELECTION OF INITIAL POINT.

    select case (Nprob)
    case (4)
        ! ROSENBROCK FUNCTION.
        x(1) = -c1
        x(2) = one
    case (5)
        ! HELICAL VALLEY FUNCTION.
        x(1) = -one
        x(2) = zero
        x(3) = zero
    case (6)
        ! POWELL SINGULAR FUNCTION.
        x(1) = three
        x(2) = -one
        x(3) = zero
        x(4) = one
    case (7)
        ! FREUDENSTEIN AND ROTH FUNCTION.
        x(1) = half
        x(2) = -two
    case (8)
        ! BARD FUNCTION.
        x(1) = one
        x(2) = one
        x(3) = one
    case (9)
        ! KOWALIK AND OSBORNE FUNCTION.
        x(1) = c2
        x(2) = c3
        x(3) = c4
        x(4) = c3
    case (10)
        ! MEYER FUNCTION.
        x(1) = c5
        x(2) = c6
        x(3) = c7
    case (11)
        ! WATSON FUNCTION.
        do j = 1, n
            x(j) = zero
        end do
    case (12)
        ! BOX 3-DIMENSIONAL FUNCTION.
        x(1) = zero
        x(2) = ten
        x(3) = twenty
    case (13)
        ! JENNRICH AND SAMPSON FUNCTION.
        x(1) = c8
        x(2) = c9
    case (14)
        ! BROWN AND DENNIS FUNCTION.
        x(1) = twntf
        x(2) = five
        x(3) = -five
        x(4) = -one
    case (15)
        ! CHEBYQUAD FUNCTION.
        h = one/dfloat(n + 1)
        do j = 1, n
            x(j) = dfloat(j)*h
        end do
    case (16)
        ! BROWN ALMOST-LINEAR FUNCTION.
        do j = 1, n
            x(j) = half
        end do
    case (17)
        ! OSBORNE 1 FUNCTION.
        x(1) = half
        x(2) = c10
        x(3) = -one
        x(4) = c11
        x(5) = c5
    case (18)
        ! OSBORNE 2 FUNCTION.
        x(1) = c12
        x(2) = c13
        x(3) = c13
        x(4) = c14
        x(5) = c15
        x(6) = three
        x(7) = five
        x(8) = seven
        x(9) = two
        x(10) = c16
        x(11) = c17
    case default
        ! LINEAR FUNCTION - FULL RANK OR RANK 1.
        do j = 1, n
            x(j) = one
        end do
    end select

    ! COMPUTE MULTIPLE OF INITIAL POINT.

    if (Factor /= one) then
        if (Nprob == 11) 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
!*****************************************************************************************

!*****************************************************************************************
!>
!  This subroutine defines the functions of eighteen nonlinear
!  least squares problems. the allowable values of (m,n) for
!  functions 1,2 and 3 are variable but with m >= n.
!  for functions 4,5,6,7,8,9 and 10 the values of (m,n) are
!  (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) and (16,3), respectively.
!  function 11 (watson) has m = 31 with n usually 6 or 9.
!  however, any n, n = 2,...,31, is permitted.
!  functions 12,13 and 14 have n = 3,2 and 4, respectively, but
!  allow any m >= n, with the usual choices being 10,10 and 20.
!  function 15 (chebyquad) allows m and n variable with m >= n.
!  function 16 (brown) allows n variable with m = n.
!  for functions 17 and 18, the values of (m,n) are
!  (33,5) and (65,11), respectively.

subroutine ssqfcn(m, n, x, Fvec, Nprob)
    implicit none

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

    real(wp),parameter :: zero = 0.0_wp
    real(wp),parameter :: zp25 = 2.5e-1_wp
    real(wp),parameter :: zp5 = 5.0e-1_wp
    real(wp),parameter :: one = 1.0_wp
    real(wp),parameter :: two = 2.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 :: c13 = 13.0_wp
    real(wp),parameter :: c14 = 14.0_wp
    real(wp),parameter :: c29 = 29.0_wp
    real(wp),parameter :: c45 = 45.0_wp

    real(wp),parameter :: v(11) =  [4.0_wp, 2.0_wp, 1.0_wp, 5.0e-1_wp, &
                                    2.5e-1_wp, 1.67e-1_wp, 1.25e-1_wp, 1.0e-1_wp, 8.33e-2_wp, 7.14e-2_wp, &
                                    6.25e-2_wp]
    real(wp),parameter :: y1(15) = [1.4e-1_wp, 1.8e-1_wp, 2.2e-1_wp, 2.5e-1_wp, 2.9e-1_wp, 3.2e-1_wp, &
                                    3.5e-1_wp, 3.9e-1_wp, 3.7e-1_wp, 5.8e-1_wp, 7.3e-1_wp, 9.6e-1_wp, &
                                    1.34_wp, 2.1_wp, 4.39_wp]
    real(wp),parameter :: y2(11) = [1.957e-1_wp, 1.947e-1_wp, &
                                    1.735e-1_wp, 1.6e-1_wp, 8.44e-2_wp, 6.27e-2_wp, 4.56e-2_wp, 3.42e-2_wp, &
                                    3.23e-2_wp, 2.35e-2_wp, 2.46e-2_wp]
    real(wp),parameter :: y3(16) = [3.478e4_wp, 2.861e4_wp, 2.365e4_wp, 1.963e4_wp, &
                                    1.637e4_wp, 1.372e4_wp, 1.154e4_wp, 9.744e3_wp, 8.261e3_wp, 7.03e3_wp, &
                                    6.005e3_wp, 5.147e3_wp, 4.427e3_wp, 3.82e3_wp, 3.307e3_wp, 2.872e3_wp]
    real(wp),parameter :: y4(33) = [8.44e-1_wp,&
                                    9.08e-1_wp, 9.32e-1_wp, 9.36e-1_wp, 9.25e-1_wp, 9.08e-1_wp, 8.81e-1_wp, &
                                    8.5e-1_wp, 8.18e-1_wp, 7.84e-1_wp, 7.51e-1_wp, 7.18e-1_wp, 6.85e-1_wp, &
                                    6.58e-1_wp, 6.28e-1_wp, 6.03e-1_wp, 5.8e-1_wp, 5.58e-1_wp, 5.38e-1_wp, &
                                    5.22e-1_wp, 5.06e-1_wp, 4.9e-1_wp, 4.78e-1_wp, 4.67e-1_wp, 4.57e-1_wp, &
                                    4.48e-1_wp, 4.38e-1_wp, 4.31e-1_wp, 4.24e-1_wp, 4.2e-1_wp, 4.14e-1_wp, &
                                    4.11e-1_wp, 4.06e-1_wp]
    real(wp),parameter :: y5(65) = [1.366_wp, &
                                    1.191_wp, 1.112_wp, 1.013_wp, 9.91e-1_wp, 8.85e-1_wp, 8.31e-1_wp, &
                                    8.47e-1_wp, 7.86e-1_wp, 7.25e-1_wp, 7.46e-1_wp, 6.79e-1_wp, 6.08e-1_wp, &
                                    6.55e-1_wp, 6.16e-1_wp, 6.06e-1_wp, 6.02e-1_wp, 6.26e-1_wp, 6.51e-1_wp, &
                                    7.24e-1_wp, 6.49e-1_wp, 6.49e-1_wp, 6.94e-1_wp, 6.44e-1_wp, 6.24e-1_wp, &
                                    6.61e-1_wp, 6.12e-1_wp, 5.58e-1_wp, 5.33e-1_wp, 4.95e-1_wp, 5.0e-1_wp, &
                                    4.23e-1_wp, 3.95e-1_wp, 3.75e-1_wp, 3.72e-1_wp, 3.91e-1_wp, 3.96e-1_wp, &
                                    4.05e-1_wp, 4.28e-1_wp, 4.29e-1_wp, 5.23e-1_wp, 5.62e-1_wp, 6.07e-1_wp, &
                                    6.53e-1_wp, 6.72e-1_wp, 7.08e-1_wp, 6.33e-1_wp, 6.68e-1_wp, 6.45e-1_wp, &
                                    6.32e-1_wp, 5.91e-1_wp, 5.59e-1_wp, 5.97e-1_wp, 6.25e-1_wp, 7.39e-1_wp, &
                                    7.1e-1_wp, 7.29e-1_wp, 7.2e-1_wp, 6.36e-1_wp, 5.81e-1_wp, 4.28e-1_wp, &
                                    2.92e-1_wp, 1.62e-1_wp, 9.8e-2_wp, 5.4e-2_wp]

    integer :: i, iev, ivar, j, nm1
    real(wp) :: div, dx, prod, sum, s1, s2, temp, &
                ti, tmp1, tmp2, tmp3, tmp4, tpi

    Fvec(1:m) = zero

    ! FUNCTION ROUTINE SELECTOR.

    select case (Nprob)
    case (2)
        ! LINEAR FUNCTION - RANK 1.
        sum = zero
        do j = 1, n
            sum = sum + dfloat(j)*x(j)
        end do
        do i = 1, m
            Fvec(i) = dfloat(i)*sum - one
        end do
    case (3)
        ! LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
        sum = zero
        nm1 = n - 1
        if (nm1 >= 2) then
            do j = 2, nm1
                sum = sum + dfloat(j)*x(j)
            end do
        end if
        do i = 1, m
            Fvec(i) = dfloat(i - 1)*sum - one
        end do
        Fvec(m) = -one
    case (4)
        ! ROSENBROCK FUNCTION.
        Fvec(1) = ten*(x(2) - x(1)**2)
        Fvec(2) = one - x(1)
    case (5)
        ! HELICAL VALLEY FUNCTION.
        tpi = eight*atan(one)
        tmp1 = sign(zp25, x(2))
        if (x(1) > zero) tmp1 = atan(x(2)/x(1))/tpi
        if (x(1) < zero) tmp1 = atan(x(2)/x(1))/tpi + zp5
        tmp2 = sqrt(x(1)**2 + x(2)**2)
        Fvec(1) = ten*(x(3) - ten*tmp1)
        Fvec(2) = ten*(tmp2 - one)
        Fvec(3) = x(3)
    case (6)
        ! 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 (7)
        ! FREUDENSTEIN AND ROTH FUNCTION.
        Fvec(1) = -c13 + x(1) + ((five - x(2))*x(2) - two)*x(2)
        Fvec(2) = -c29 + x(1) + ((one + x(2))*x(2) - c14)*x(2)
    case (8)
        ! BARD FUNCTION.
        do i = 1, 15
            tmp1 = dfloat(i)
            tmp2 = dfloat(16 - i)
            tmp3 = tmp1
            if (i > 8) tmp3 = tmp2
            Fvec(i) = y1(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3))
        end do
    case (9)
        ! KOWALIK AND OSBORNE FUNCTION.
        do i = 1, 11
            tmp1 = v(i)*(v(i) + x(2))
            tmp2 = v(i)*(v(i) + x(3)) + x(4)
            Fvec(i) = y2(i) - x(1)*tmp1/tmp2
        end do
    case (10)
        ! MEYER FUNCTION.
        do i = 1, 16
            temp = five*dfloat(i) + c45 + x(3)
            tmp1 = x(2)/temp
            tmp2 = exp(tmp1)
            Fvec(i) = x(1)*tmp2 - y3(i)
        end do
    case (11)
        ! WATSON FUNCTION.
        do i = 1, 29
            div = dfloat(i)/c29
            s1 = zero
            dx = one
            do j = 2, n
                s1 = s1 + dfloat(j - 1)*dx*x(j)
                dx = div*dx
            end do
            s2 = zero
            dx = one
            do j = 1, n
                s2 = s2 + dx*x(j)
                dx = div*dx
            end do
            Fvec(i) = s1 - s2**2 - one
        end do
        Fvec(30) = x(1)
        Fvec(31) = x(2) - x(1)**2 - one
    case (12)
        ! BOX 3-DIMENSIONAL FUNCTION.
        do i = 1, m
            temp = dfloat(i)
            tmp1 = temp/ten
            Fvec(i) = exp(-tmp1*x(1)) - exp(-tmp1*x(2)) &
                      + (exp(-temp) - exp(-tmp1))*x(3)
        end do
    case (13)
        ! JENNRICH AND SAMPSON FUNCTION.
        do i = 1, m
            temp = dfloat(i)
            Fvec(i) = two + two*temp - exp(temp*x(1)) - exp(temp*x(2))
        end do
    case (14)
        ! BROWN AND DENNIS FUNCTION.
        do i = 1, m
            temp = dfloat(i)/five
            tmp1 = x(1) + temp*x(2) - exp(temp)
            tmp2 = x(3) + sin(temp)*x(4) - cos(temp)
            Fvec(i) = tmp1**2 + tmp2**2
        end do
    case (15)
        ! CHEBYQUAD FUNCTION.
        do i = 1, m
            Fvec(i) = zero
        end do
        do j = 1, n
            tmp1 = one
            tmp2 = two*x(j) - one
            temp = two*tmp2
            do i = 1, m
                Fvec(i) = Fvec(i) + tmp2
                ti = temp*tmp2 - tmp1
                tmp1 = tmp2
                tmp2 = ti
            end do
        end do
        dx = one/dfloat(n)
        iev = -1
        do i = 1, m
            Fvec(i) = dx*Fvec(i)
            if (iev > 0) Fvec(i) = Fvec(i) + one/(dfloat(i)**2 - one)
            iev = -iev
        end do
    case (16)
        ! 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 i = 1, n
            Fvec(i) = x(i) + sum
        end do
        Fvec(n) = prod - one
    case (17)
        ! OSBORNE 1 FUNCTION.
        do i = 1, 33
            temp = ten*dfloat(i - 1)
            tmp1 = exp(-x(4)*temp)
            tmp2 = exp(-x(5)*temp)
            Fvec(i) = y4(i) - (x(1) + x(2)*tmp1 + x(3)*tmp2)
        end do
    case (18)
        ! OSBORNE 2 FUNCTION.
        do i = 1, 65
            temp = dfloat(i - 1)/ten
            tmp1 = exp(-x(5)*temp)
            tmp2 = exp(-x(6)*(temp - x(9))**2)
            tmp3 = exp(-x(7)*(temp - x(10))**2)
            tmp4 = exp(-x(8)*(temp - x(11))**2)
            Fvec(i) = y5(i) - (x(1)*tmp1 + x(2)*tmp2 + x(3)*tmp3 + x(4)*tmp4)
        end do
    case default
        ! LINEAR FUNCTION - FULL RANK.
        sum = zero
        do j = 1, n
            sum = sum + x(j)
        end do
        temp = two*sum/dfloat(m) + one
        do i = 1, m
            Fvec(i) = -temp
            if (i <= n) Fvec(i) = Fvec(i) + x(i)
        end do
    end select

end subroutine ssqfcn
!*****************************************************************************************

!*****************************************************************************************
    end program test_lmstr
!*****************************************************************************************


module mod_segment_tree
  implicit none
  integer, parameter :: DEFAULT = 1000000000
  type segment_tree
    integer :: n, p
    integer, pointer :: arr(:)
  end type segment_tree
  private
  public :: segment_tree, init_segtree, release_segtree
  public :: update, query
contains
  integer function op(x,y)
    implicit none
    integer :: x, y
    op = min(x,y)
    return
  end function op
  subroutine init_segtree(st,n)
    implicit none
    type(segment_tree) :: st
    integer, intent(in) :: n
    integer :: p
    p = 1
    do while (p.lt.n)
      p = 2*p
    end do
    st%n = n
    st%p = p
    allocate(st%arr(2*p-1))
    st%arr = DEFAULT
    return
  end subroutine init_segtree
  subroutine release_segtree(st)
    implicit none
    type(segment_tree) :: st
    if (associated(st%arr)) deallocate(st%arr)
    return
  end subroutine release_segtree
  subroutine update(st,i,v)
    implicit none
    type(segment_tree) :: st
    integer, intent(in) :: i, v
    integer :: x
    x = i+st%p-1
    st%arr(x) = v
    do while (x.gt.1)
      x = x/2
      st%arr(x) = op(st%arr(2*x),st%arr(2*x+1))
    end do
    return
  end subroutine update
  integer function query(st,a,b)
    type(segment_tree) :: st
    integer, intent(in) :: a, b
    integer :: l, r
    query = DEFAULT
    l = a+st%p-1
    r = b+st%p-1
    do while (l.le.r)
      if (mod(l,2).eq.1) then
        query = op(query,st%arr(l))
        l = l+1
      end if
      if (mod(r,2).eq.0) then
        query = op(query,st%arr(r))
        r = r-1
      end if
      l = l/2
      r = r/2
    end do
    return
  end function query
end module mod_segment_tree


! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } { "*" } { "" } }

! PR43298  Fortran library does not read in NaN, NaN(), -Inf, or Inf

! Formatted READ part of PR fortran/43298

! Test case prepared by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
program pr43298
  real(4) :: x4(7)
  real(8) :: x8(7)
  character(80) :: output

open(10, status='scratch')
!                0123456789012345678901234567890123456789012345678901234567890123456789
write(10,'(a)') "inf           nan   infinity  NaN(dx)      -INf    NAN       InFiNiTy"
rewind(10)
x4 = 0.0_4
x8 = 0.0_8
read(10,'(7f10.3)') x4
rewind(10)
read(10,'(7f10.3)') x8
write (output, '("x4 =",7G6.0)') x4
if (output.ne."x4 =  +Inf   NaN  +Inf   NaN  -Inf   NaN  +Inf") call abort
write (output, '("x8 =",7G6.0)') x8
if (output.ne."x8 =  +Inf   NaN  +Inf   NaN  -Inf   NaN  +Inf") call abort
!print '("x4 =",7G6.0)', x4
!print '("x8 =",7G6.0)', x8
end program pr43298


!
! Copyright (c) 2013, Intel Corporation
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
! * Redistributions of source code must retain the above copyright
!       notice, this list of conditions and the following disclaimer.
! * Redistributions in binary form must reproduce the above
!       copyright notice, this list of conditions and the following
!       disclaimer in the documentation and/or other materials provided
!       with the distribution.
! * Neither the name of Intel Corporation nor the names of its
!       contributors may be used to endorse or promote products
!       derived from this software without specific prior written
!       permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, ACLUDAG, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. A NO EVENT SHALL THE
! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ADIRECT,
! ACIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (ACLUDAG,
! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSAESS ATERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER A CONTRACT, STRICT
! LIABILITY, OR TORT (ACLUDAG NEGLIGENCE OR OTHERWISE) ARISAG A
! ANY WAY B OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
! *******************************************************************
!
! NAME:    Stencil
!
! PURPOSE: This program tests the efficiency with which a space-invariant,
!          linear, symmetric filter (stencil) can be applied to a square
!          grid or image.
!
! USAGE:   The program takes as input the linear
!          dimension of the grid, and the number of iterations on the grid
!
!                <progname> <iterations> <grid size>
!
!          The output consists of diagnostics to make sure the
!          algorithm worked, and of timing statistics.
!
! FUNCTIONS CALLED:
!
!          Other than standard C functions, the following functions are used in
!          this program:
!          wtime()
!
! HISTORY: - Written by Rob Van der Wijngaart, February 2009.
!          - RvdW: Removed unrolling pragmas for clarity;
!            added constant to array "in" at end of each iteration to force
!            refreshing of neighbor data in parallel versions; August 2013
!          - Converted to Fortran by Jeff Hammond, January-February 2016.
!
! *******************************************************************

subroutine initialize_w(is_star,r,W)
  use iso_fortran_env
  implicit none
  logical, intent(in) :: is_star
  integer(kind=INT32), intent(in) :: r
  real(kind=REAL64), intent(inout) :: W(-r:r,-r:r)
  integer(kind=INT32) :: ii, jj
  ! fill the stencil weights to reflect a discrete divergence operator
  W = 0.0d0
  if (is_star) then
    do ii=1,r
      W(0, ii) =  1.0d0/real(2*ii*r,REAL64)
      W(0,-ii) = -1.0d0/real(2*ii*r,REAL64)
      W( ii,0) =  1.0d0/real(2*ii*r,REAL64)
      W(-ii,0) = -1.0d0/real(2*ii*r,REAL64)
    enddo
  else
    ! Jeff: check that this is correct with the new W indexing
    do jj=1,r
      do ii=-jj+1,jj-1
        W( ii, jj) =  1.0d0/real(4*jj*(2*jj-1)*r,REAL64)
        W( ii,-jj) = -1.0d0/real(4*jj*(2*jj-1)*r,REAL64)
        W( jj, ii) =  1.0d0/real(4*jj*(2*jj-1)*r,REAL64)
        W(-jj, ii) = -1.0d0/real(4*jj*(2*jj-1)*r,REAL64)
      enddo
      W( jj, jj)  =  1.0d0/real(4*jj*r,REAL64)
      W(-jj,-jj)  = -1.0d0/real(4*jj*r,REAL64)
    enddo
  endif
end subroutine initialize_w

subroutine apply_stencil(is_star,tiling,tile_size,r,n,W,A,B)
  use iso_fortran_env
  implicit none
  logical, intent(in) :: is_star, tiling
  integer(kind=INT32), intent(in) :: tile_size, r, n
  real(kind=REAL64), intent(in) :: W(-r:r,-r:r)
  real(kind=REAL64), intent(in) :: A(n,n)
  real(kind=REAL64), intent(inout) :: B(n,n)
  integer(kind=INT32) :: i, j, ii, jj, it, jt
  if (is_star) then
    if (.not.tiling) then
      !$omp taskloop shared(W,A,B) firstprivate(r,n) private(i,j,ii,jj)
      do j=r,n-r-1
        do i=r,n-r-1
            ! do not use Intel Fortran unroll directive here (slows down)
            do jj=-r,r
              B(i+1,j+1) = B(i+1,j+1) + W(0,jj) * A(i+1,j+jj+1)
            enddo
            do ii=-r,-1
              B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
            enddo
            do ii=1,r
              B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
            enddo
        enddo
      enddo
      !$omp end taskloop
    else ! tiling
      !$omp taskloop shared(W,A,B) firstprivate(r,n,tile_size) &
      !$omp&                       private(it,jt,i,j,ii,jj)
      do jt=r,n-r-1,tile_size
        do it=r,n-r-1,tile_size
          do j=jt,min(n-r-1,jt+tile_size-1)
            do i=it,min(n-r-1,it+tile_size-1)
              do jj=-r,r
                B(i+1,j+1) = B(i+1,j+1) + W(0,jj) * A(i+1,j+jj+1)
              enddo
              do ii=-r,-1
                B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
              enddo
              do ii=1,r
                B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
              enddo
            enddo
          enddo
        enddo
      enddo
      !$omp end taskloop
    endif ! tiling
  else ! grid
    if (.not.tiling) then
      !$omp taskloop shared(W,A,B) firstprivate(r,n) private(i,j,ii,jj)
      do j=r,n-r-1
        do i=r,n-r-1
          do jj=-r,r
            do ii=-r,r
              B(i+1,j+1) = B(i+1,j+1) + W(ii,jj) * A(i+ii+1,j+jj+1)
            enddo
          enddo
        enddo
      enddo
      !$omp end taskloop
    else ! tiling
      !$omp taskloop shared(W,A,B) firstprivate(r,n,tile_size) &
      !$omp&                       private(it,jt,i,j,ii,jj)
      do jt=r,n-r-1,tile_size
        do it=r,n-r-1,tile_size
          do j=jt,min(n-r-1,jt+tile_size-1)
            do i=it,min(n-r-1,it+tile_size-1)
              do jj=-r,r
                do ii=-r,r
                  B(i+1,j+1) = B(i+1,j+1) + W(ii,jj) * A(i+ii+1,j+jj+1)
                enddo
              enddo
            enddo
          enddo
        enddo
      enddo
      !$omp end taskloop
    endif ! tiling
  endif ! star
end subroutine apply_stencil

program main
  use iso_fortran_env
  use omp_lib
  implicit none
  ! for argument parsing
  integer :: err
  integer :: arglen
  character(len=32) :: argtmp
  ! problem definition
  integer(kind=INT32) :: iterations                     ! number of times to run the pipeline algorithm
  integer(kind=INT32) ::  n                             ! linear grid dimension
  integer(kind=INT32) ::  stencil_size                  ! number of points in stencil
  integer(kind=INT32) ::  tile_size                     ! loop nest block factor
  logical :: tiling                                     ! boolean indication loop nest blocking
  logical :: is_star                                    ! true = star, false = grid
  integer(kind=INT32), parameter :: r=RADIUS            ! radius of stencil
  real(kind=REAL64) :: W(-r:r,-r:r)                     ! weights of points in the stencil
  real(kind=REAL64), allocatable :: A(:,:), B(:,:)      ! grid values
  real(kind=REAL64), parameter :: cx=1.d0, cy=1.d0
  ! runtime variables
  integer(kind=INT32) :: i, j, k
  integer(kind=INT64) :: flops                          ! floating point ops per iteration
  real(kind=REAL64) :: norm, reference_norm             ! L1 norm of solution
  integer(kind=INT64) :: active_points                  ! interior of grid with respect to stencil
  real(kind=REAL64) :: t0, t1, stencil_time, avgtime    ! timing parameters
  real(kind=REAL64), parameter ::  epsilon=1.d-8        ! error tolerance

  ! ********************************************************************
  ! read and test input parameters
  ! ********************************************************************

  write(*,'(a25)') 'Parallel Research Kernels'
  write(*,'(a52)') 'Fortran OpenMP TASKLOOP Stencil execution on 2D grid'

  if (command_argument_count().lt.2) then
    write(*,'(a17,i1)') 'argument count = ', command_argument_count()
    write(*,'(a32,a29)') 'Usage: ./stencil <# iterations> ', &
                      '<array dimension> [tile_size]'
    stop 1
  endif

  iterations = 1
  call get_command_argument(1,argtmp,arglen,err)
  if (err.eq.0) read(argtmp,'(i32)') iterations
  if (iterations .lt. 1) then
    write(*,'(a,i5)') 'ERROR: iterations must be >= 1 : ', iterations
    stop 1
  endif

  n = 1
  call get_command_argument(2,argtmp,arglen,err)
  if (err.eq.0) read(argtmp,'(i32)') n
  if (n .lt. 1) then
    write(*,'(a,i5)') 'ERROR: array dimension must be >= 1 : ', n
    stop 1
  endif

  tiling    = .false.
  tile_size = 32
  if (command_argument_count().gt.2) then
    call get_command_argument(3,argtmp,arglen,err)
    if (err.eq.0) read(argtmp,'(i32)') tile_size
    if ((tile_size .lt. 1).or.(tile_size.gt.n)) then
      write(*,'(a,i5,a,i5)') 'WARNING: tile_size ',tile_size,&
                             ' must be >= 1 and <= ',n
    else
      tiling = .true.
    endif
  endif

  ! TODO: parse runtime input for star/grid
#ifdef STAR
  is_star = .true.
#else
  is_star = .false.
#endif

  ! TODO: parse runtime input for radius

  if (r .lt. 1) then
    write(*,'(a,i5,a)') 'ERROR: Stencil radius ',r,' should be positive'
    stop 1
  else if ((2*r+1) .gt. n) then
    write(*,'(a,i5,a,i5)') 'ERROR: Stencil radius ',r,&
                           ' exceeds grid size ',n
    stop 1
  endif

  allocate( A(n,n), stat=err)
  if (err .ne. 0) then
    write(*,'(a,i3)') 'allocation of A returned ',err
    stop 1
  endif

  allocate( B(n,n), stat=err )
  if (err .ne. 0) then
    write(*,'(a,i3)') 'allocation of B returned ',err
    stop 1
  endif

  norm = 0.d0
  active_points = int(n-2*r,INT64)**2

  write(*,'(a,i8)') 'Number of threads    = ',omp_get_max_threads()
  write(*,'(a,i8)') 'Number of iterations = ', iterations
  write(*,'(a,i8)') 'Grid size            = ', n
  write(*,'(a,i8)') 'Radius of stencil    = ', r
  if (is_star) then
    write(*,'(a,a)')  'Type of stencil      = star'
    stencil_size = 4*r+1
  else
    write(*,'(a,a)')  'Type of stencil      = grid'
    stencil_size = (2*r+1)**2
  endif
  write(*,'(a)') 'Data type            = double precision'
  write(*,'(a)') 'Compact representation of stencil loop body'
  if (tiling) then
      write(*,'(a,i5)') 'Tile size            = ', tile_size
  else
      write(*,'(a)') 'Untiled'
  endif

  call initialize_w(is_star,r,W)

  !$omp parallel default(none)                                        &
  !$omp&  shared(n,A,B,W,t0,t1,iterations,tiling,tile_size,is_star)   &
  !$omp&  private(i,j,k)

  !$omp master
  !$omp taskloop firstprivate(n) shared(A,B)
  do j=1,n
    do i=1,n
      A(i,j) = cx*i+cy*j
      B(i,j) = 0.d0
    enddo
  enddo
  !$omp end taskloop

  !$omp taskwait

  t0 = 0

  do k=0,iterations

    if (k.eq.1) then
       t0 = omp_get_wtime()
    endif

    ! Apply the stencil operator
    call apply_stencil(is_star,tiling,tile_size,r,n,W,A,B)
    !$omp taskwait

    ! add constant to solution to force refresh of neighbor data, if any
    !$omp taskloop firstprivate(n) private(i,j) shared(A)
    do j=1,n
      do i=1,n
        A(i,j) = A(i,j) + 1.d0
      enddo
    enddo
    !$omp end taskloop

    !$omp taskwait

  enddo ! iterations

  t1 = omp_get_wtime()

  !$omp end master
  !$omp end parallel

  stencil_time = t1 - t0

  ! compute L1 norm in parallel
  !$omp parallel do reduction(+:norm)
  do j=r,n-r
    do i=r,n-r
      norm = norm + abs(B(i,j))
    enddo
  enddo
  !$omp end parallel do

  norm = norm / real(active_points,REAL64)

  !******************************************************************************
  !* Analyze and output results.
  !******************************************************************************

  deallocate( B )
  deallocate( A )

  ! verify correctness
  reference_norm = real(iterations+1,REAL64) * (cx + cy);
  if (abs(norm-reference_norm) .gt. epsilon) then
    write(*,'(a,f13.6,a,f13.6)') 'ERROR: L1 norm = ', norm, &
                                 ' Reference L1 norm = ', reference_norm
  else
    write(*,'(a)') 'Solution validates'
#ifdef VERBOSE
    write(*,'(a,f13.6,a,f13.6)') 'VERBOSE: L1 norm = ', norm, &
                                 ' Reference L1 norm = ', reference_norm
#endif
  endif

  flops = int(2*stencil_size+1,INT64) * active_points
  avgtime = stencil_time/iterations
  write(*,'(a,f13.6,a,f13.6)') 'Rate (MFlops/s): ',1.0d-6*flops/avgtime, &
                               ' Avg time (s): ',avgtime

end program main


SUBROUTINE clawpack5_rpn2(ixy,maxm,meqn,mwaves,maux,mbc, &
     mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =====================================================

! Roe-solver for the 2D shallow water equations
! solve Riemann problems along one slice of data.

! waves: 3
! equations: 3

! Conserved quantities:
!       1 depth
!       2 x_momentum
!       3 y_momentum

! 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

! This data is along a slice in the x-direction if ixy=1
!                            or the y-direction if ixy=2.

! On output, wave contains the waves, s the speeds,
! and amdq, apdq the decomposition of the flux difference
!   f(qr(i-1)) - f(ql(i))
! into leftgoing and rightgoing parts respectively.
! With the Roe solver we have
!    amdq  =  A^- \Delta q    and    apdq  =  A^+ \Delta q
! where A is the Roe matrix.  An entropy fix can also be incorporated
! into the flux differences.

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

! This Riemann solver differs from the original clawpack Riemann solver
! for the interleaved indices

  IMPLICIT DOUBLE PRECISION (a-h,o-z)

  DIMENSION   ql(meqn,           1-mbc:maxm+mbc)
  DIMENSION   qr(meqn,           1-mbc:maxm+mbc)
  DIMENSION    s(mwaves,         1-mbc:maxm+mbc)
  DIMENSION wave(meqn,   mwaves, 1-mbc:maxm+mbc)
  DIMENSION  apdq(meqn,          1-mbc:maxm+mbc)
  DIMENSION  amdq(meqn,          1-mbc:maxm+mbc)

!     # Gravity constant set in the shallow1D.py file
  COMMON /cparam/ grav

!     # Roe averages quantities of each interface
  PARAMETER (maxm2 = 1800)
  DOUBLE PRECISION u(-6:maxm2+7),v(-6:maxm2+7),a(-6:maxm2+7), &
       h(-6:maxm2+7)

!     local arrays
!     ------------
  DIMENSION delta(3)
  LOGICAL :: efix

  DATA efix /.TRUE./    !# Use entropy fix for transonic rarefactions

!     # Set mu to point to  the component of the system that corresponds
!     # to momentum in the direction of this slice, mv to the orthogonal
!     # momentum:

  IF (ixy == 1) THEN
     mu = 2
     mv = 3
  ELSE
     mu = 3
     mv = 2
  ENDIF

!     # Note that notation for u and v reflects assumption that the
!     # Riemann problems are in the x-direction with u in the normal
!     # direciton and v in the orthogonal direcion, but with the above
!     # definitions of mu and mv the routine also works with ixy=2
!     # and returns, for example, f0 as the Godunov flux g0 for the
!     # Riemann problems u_t + g(u)_y = 0 in the y-direction.

!     # Compute the Roe-averaged variables needed in the Roe solver.

  DO  i = 2-mbc, mx+mbc
     h(i) = (qr(1,i-1)+ql(1,i))*0.50d0
     hsqrtl = dsqrt(qr(1,i-1))
     hsqrtr = dsqrt(ql(1,i))
     hsq2 = hsqrtl + hsqrtr
     u(i) = (qr(mu,i-1)/hsqrtl + ql(mu,i)/hsqrtr) / hsq2
     v(i) = (qr(mv,i-1)/hsqrtl + ql(mv,i)/hsqrtr) / hsq2
     a(i) = dsqrt(grav*h(i))
  ENDDO

!     # now split the jump in q at each interface into waves

!     # find a1 thru a3, the coefficients of the 3 eigenvectors:
  DO  i = 2-mbc, mx+mbc
     delta(1) = ql(1,i) - qr(1,i-1)
     delta(2) = ql(mu,i) - qr(mu,i-1)
     delta(3) = ql(mv,i) - qr(mv,i-1)
     a1 = ((u(i)+a(i))*delta(1) - delta(2))*(0.50d0/a(i))
     a2 = -v(i)*delta(1) + delta(3)
     a3 = (-(u(i)-a(i))*delta(1) + delta(2))*(0.50d0/a(i))

    !        # Compute the waves.

     wave(1,1,i) = a1
     wave(mu,1,i) = a1*(u(i)-a(i))
     wave(mv,1,i) = a1*v(i)
     s(1,i) = u(i)-a(i)

     wave(1,2,i) = 0.0d0
     wave(mu,2,i) = 0.0d0
     wave(mv,2,i) = a2
     s(2,i) = u(i)

     wave(1,3,i) = a3
     wave(mu,3,i) = a3*(u(i)+a(i))
     wave(mv,3,i) = a3*v(i)
     s(3,i) = u(i)+a(i)
  ENDDO

!    # compute flux differences amdq and apdq.
!    ---------------------------------------

  IF (efix) go to 110

!     # no entropy fix
!     ----------------

!     # amdq = SUM s*wave   over left-going waves
!     # apdq = SUM s*wave   over right-going waves

    DO 100 m=1,3
        do 100 i=2-mbc, mx+mbc
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do 90 mw=1,mwaves
                if (s(mw,i) < 0.d0) then
                    amdq(m,i) = amdq(m,i) + s(mw,i)*wave(m,mw,i)
                else
                    apdq(m,i) = apdq(m,i) + s(mw,i)*wave(m,mw,i)
                endif
            90 END DO
    100 END DO
    go to 900

!-----------------------------------------------------

    110 continue

!     # With entropy fix
!     ------------------

!    # compute flux differences amdq and apdq.
!    # First compute amdq as sum of s*wave for left going waves.
!    # Incorporate entropy fix by adding a modified fraction of wave
!    # if s should change sign.

    do 200 i=2-mbc,mx+mbc
    !           check 1-wave
        him1 = qr(1,i-1)
        s0 =  qr(mu,i-1)/him1 - dsqrt(grav*him1)
    !           check for fully supersonic case :
        if (s0 > 0.0d0 .AND. s(1,i) > 0.0d0) then
            do 60 m=1,3
                amdq(m,i)=0.0d0
            60 END DO
            goto 200
        endif

        h1 = qr(1,i-1)+wave(1,1,i)
        hu1= qr(mu,i-1)+wave(mu,1,i)
        s1 = hu1/h1 - dsqrt(grav*h1) !speed just to right of 1-wave
        if (s0 < 0.0d0 .AND. s1 > 0.0d0) then
        !              transonic rarefaction in 1-wave
            sfract = s0*((s1-s(1,i))/(s1-s0))
        else if (s(1,i) < 0.0d0) then
        !              1-wave is leftgoing
            sfract = s(1,i)
        else
        !              1-wave is rightgoing
            sfract = 0.0d0
        endif
        do 120 m=1,3
            amdq(m,i) = sfract*wave(m,1,i)
        120 END DO

    !           check 2-wave
        if (s(2,i) > 0.0d0) then
        !              #2 and 3 waves are right-going
            go to 200
        endif

        do 140 m=1,3
            amdq(m,i) = amdq(m,i) + s(2,i)*wave(m,2,i)
        140 END DO

    !           check 3-wave

        hi = ql(1,i)
        s03 = ql(mu,i)/hi + dsqrt(grav*hi)
        h3=ql(1,i)-wave(1,3,i)
        hu3=ql(mu,i)-wave(mu,3,i)
        s3=hu3/h3 + dsqrt(grav*h3)
        if (s3 < 0.0d0 .AND. s03 > 0.0d0) then
        !              transonic rarefaction in 3-wave
            sfract = s3*((s03-s(3,i))/(s03-s3))
        else if (s(3,i) < 0.0d0) then
        !              3-wave is leftgoing
            sfract = s(3,i)
        else
        !              3-wave is rightgoing
            goto 200
        endif
        do 160 m=1,3
            amdq(m,i) = amdq(m,i) + sfract*wave(m,3,i)
        160 END DO
    200 END DO

!           compute rightgoing flux differences :

      DO m=1,3
         DO i = 2-mbc,mx+mbc
            df = 0.0d0
            DO  mw=1,mwaves
               df = df + s(mw,i)*wave(m,mw,i)
            END DO
            apdq(m,i)=df-amdq(m,i)
         ENDDO
      ENDDO

    900 continue
    return
  END SUBROUTINE clawpack5_rpn2


*DECK TRED2
      SUBROUTINE TRED2 (NM, N, A, D, E, Z)
C***BEGIN PROLOGUE  TRED2
C***PURPOSE  Reduce a real symmetric matrix to a symmetric tridiagonal
C            matrix using and accumulating orthogonal transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B1
C***TYPE      SINGLE PRECISION (TRED2-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TRED2,
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     This subroutine reduces a REAL SYMMETRIC matrix to a
C     symmetric tridiagonal matrix using and accumulating
C     orthogonal similarity transformations.
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 symmetric input matrix.  Only the lower
C          triangle of the matrix need be supplied.  A is a two-
C          dimensional REAL array, dimensioned A(NM,N).
C
C     On Output
C
C        D contains the diagonal elements of the symmetric tridiagonal
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the symmetric
C          tridiagonal matrix in its last N-1 positions.  E(1) is set
C          to zero.  E is a one-dimensional REAL array, dimensioned
C          E(N).
C
C        Z contains the orthogonal transformation matrix produced in
C          the reduction.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C        A and Z may coincide.  If distinct, A is unaltered.
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  (NONE)
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***END PROLOGUE  TRED2
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,*),D(*),E(*),Z(NM,*)
      REAL F,G,H,HH,SCALE
C
C***FIRST EXECUTABLE STATEMENT  TRED2
      DO 100 I = 1, N
C
         DO 100 J = 1, I
            Z(I,J) = A(I,J)
  100 CONTINUE
C
      IF (N .EQ. 1) GO TO 320
C     .......... FOR I=N STEP -1 UNTIL 2 DO -- ..........
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.0E0
         SCALE = 0.0E0
         IF (L .LT. 2) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(Z(I,K))
C
         IF (SCALE .NE. 0.0E0) GO TO 140
  130    E(I) = Z(I,L)
         GO TO 290
C
  140    DO 150 K = 1, L
            Z(I,K) = Z(I,K) / SCALE
            H = H + Z(I,K) * Z(I,K)
  150    CONTINUE
C
         F = Z(I,L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         Z(I,L) = F - G
         F = 0.0E0
C
         DO 240 J = 1, L
            Z(J,I) = Z(I,J) / H
            G = 0.0E0
C     .......... FORM ELEMENT OF A*U ..........
            DO 180 K = 1, J
  180       G = G + Z(J,K) * Z(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + Z(K,J) * Z(I,K)
C     .......... FORM ELEMENT OF P ..........
  220       E(J) = G / H
            F = F + E(J) * Z(I,J)
  240    CONTINUE
C
         HH = F / (H + H)
C     .......... FORM REDUCED A ..........
         DO 260 J = 1, L
            F = Z(I,J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  260    CONTINUE
C
  290    D(I) = H
  300 CONTINUE
C
  320 D(1) = 0.0E0
      E(1) = 0.0E0
C     .......... ACCUMULATION OF TRANSFORMATION MATRICES ..........
      DO 500 I = 1, N
         L = I - 1
         IF (D(I) .EQ. 0.0E0) GO TO 380
C
         DO 360 J = 1, L
            G = 0.0E0
C
            DO 340 K = 1, L
  340       G = G + Z(I,K) * Z(K,J)
C
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * Z(K,I)
  360    CONTINUE
C
  380    D(I) = Z(I,I)
         Z(I,I) = 1.0E0
         IF (L .LT. 1) GO TO 500
C
         DO 400 J = 1, L
            Z(I,J) = 0.0E0
            Z(J,I) = 0.0E0
  400    CONTINUE
C
  500 CONTINUE
C
      RETURN
      END


c     ============================================
      subroutine b4step2(mbc,mx,my,meqn,q,
     &            xlower,ylower,dx,dy,time,dt,maux,aux)
c     ============================================
c
c     # called before each call to step
c     # use to set time-dependent aux arrays or perform other tasks.
c
c     # make velocity time dependent, reversing flow.
c
c
      implicit double precision (a-h,o-z)
      dimension q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
      dimension aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)
      common /comvt/ tperiod,pi2
c
      if (tperiod .eq. 0.d0) then
c        # special case --- indication that velocities specified in
c        # setaux should be used for all time.
         return
         endif

       vt = dcos(pi2*(time+dt/2.d0)/tperiod)
c
       do 200 i=1-mbc,mx+mbc
          do 100 j=1-mbc,my+mbc
c           # coordinates of lower left corner of grid cell:
            xll = xlower + (i-1)*dx
            yll = ylower + (j-1)*dy

c           # difference stream function psi to get normal velocities:
            aux(1,i,j) = -(psi(xll, yll+dy) - psi(xll,yll)) / dy
            aux(2,i,j) =  (psi(xll+dx, yll) - psi(xll,yll)) / dx
c
c           # multiply by time-factor:
            aux(1,i,j) = vt * aux(1,i,j)
            aux(2,i,j) = vt * aux(2,i,j)
  100        continue
  200     continue
       return
       end


c---------------------------------------------------
      real function psr_dist(x1, y1, z1, x2, y2, z2)
c---------------------------------------------------
c
c     distance between two points (Pythag C4bc)
c
      real x1,y1,x2,y2,z1,z2
      psr_dist = sqrt((((x2 - x1) ** 2) + ((y2 - y1) ** 2)) +
     &                ((z2 - z1) **2))
      end


      SUBROUTINE PELGNO(XMOM,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  PARAMETER ESTIMATION VIA L-MOMENTS FOR THE GENERALIZED NORMAL
C  DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2, TAU-3. ABS(TAU3) MAY NOT EXCEED 0.95.
C  PARA   *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER XI, ALPHA, K (LOCATION, SCALE, SHAPE).
C
C  OTHER ROUTINES USED: DERF
C
C  METHOD: RATIONAL-FUNCTION APPROXIMATION OF K IN TERMS OF TAU-3
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(3),PARA(3)
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/
      DATA P95/0.95D0/
      DATA ROOTPI/1.772453850905516027D0/
C
C         COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATION
C         A0 IS 0.5*SQRT(3/PI)
C
      DATA A0,A1,A2,A3/
     *  0.20466534D+01,-0.36544371D+01,0.18396733D+01,-0.20360244D+00/
      DATA B1,B2,B3/-0.20182173D+01,0.12420401D+01,-0.21741801D+00/
C
C         SMALL IS USED TO TEST WHETHER SKEWNESS IS EFFECTIVELY ZERO
C
      DATA SMALL/1D-8/
C
      T3=XMOM(3)
      IF(XMOM(2).LE.ZERO.OR.DABS(T3).GE.ONE)GOTO 1000
      IF(DABS(T3).GE.P95)GOTO 1010
      IF(DABS(T3).LE.SMALL)GOTO 30
C
      TT=T3*T3
      G=-T3*(A0+TT*(A1+TT*(A2+TT*A3)))/(ONE+TT*(B1+TT*(B2+TT*B3)))
      E=DEXP(HALF*G*G)
      A=XMOM(2)*G/(E*DERF(HALF*G))
      U=XMOM(1)+A*(E-ONE)/G
      PARA(1)=U
      PARA(2)=A
      PARA(3)=G
      RETURN
C
   30 PARA(1)=XMOM(1)
      PARA(2)=XMOM(2)*ROOTPI
      PARA(3)=ZERO
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      PARA(1)=ZERO
      PARA(2)=-ONE
      PARA(3)=ZERO
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE PELGNO : L-MOMENTS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE PELGNO :',
     *  ' TAU-3 TOO LARGE FOR ROUTINE')
      END


      SUBROUTINE TKTZTK(TK,Z,NZ,L,M,N)
C
C     THIS ROUTINE  PERFORMS A COORDINATE TRANSFORMATION ON THE
C     SYMMETRIC HALF OF A 3 BY 3 MATRIX
C
      DOUBLE PRECISION TK(3,3),Z(1)
      TK(1,1)=Z(NZ  )*Z(L  )+Z(NZ+3)*Z(L+1)+Z(NZ+6)*Z(L+2)
      TK(2,1)=Z(NZ+1)*Z(L  )+Z(NZ+4)*Z(L+1)+Z(NZ+7)*Z(L+2)
      TK(3,1)=Z(NZ+2)*Z(L  )+Z(NZ+5)*Z(L+1)+Z(NZ+8)*Z(L+2)
      TK(1,2)=Z(NZ  )*Z(L+1)+Z(NZ+3)*Z(M  )+Z(NZ+6)*Z(M+1)
      TK(2,2)=Z(NZ+1)*Z(L+1)+Z(NZ+4)*Z(M  )+Z(NZ+7)*Z(M+1)
      TK(3,2)=Z(NZ+2)*Z(L+1)+Z(NZ+5)*Z(M  )+Z(NZ+8)*Z(M+1)
      TK(1,3)=Z(NZ  )*Z(L+2)+Z(NZ+3)*Z(M+1)+Z(NZ+6)*Z(N  )
      TK(2,3)=Z(NZ+1)*Z(L+2)+Z(NZ+4)*Z(M+1)+Z(NZ+7)*Z(N  )
      TK(3,3)=Z(NZ+2)*Z(L+2)+Z(NZ+5)*Z(M+1)+Z(NZ+8)*Z(N  )
      Z(L  )=Z(NZ  )*TK(1,1)+Z(NZ+3)*TK(1,2)+Z(NZ+6)*TK(1,3)
      Z(L+1)=Z(NZ  )*TK(2,1)+Z(NZ+3)*TK(2,2)+Z(NZ+6)*TK(2,3)
      Z(L+2)=Z(NZ  )*TK(3,1)+Z(NZ+3)*TK(3,2)+Z(NZ+6)*TK(3,3)
      Z(M  )=Z(NZ+1)*TK(2,1)+Z(NZ+4)*TK(2,2)+Z(NZ+7)*TK(2,3)
      Z(M+1)=Z(NZ+1)*TK(3,1)+Z(NZ+4)*TK(3,2)+Z(NZ+7)*TK(3,3)
      Z(N  )=Z(NZ+2)*TK(3,1)+Z(NZ+5)*TK(3,2)+Z(NZ+8)*TK(3,3)
      RETURN
      END


        subroutine iddr_qrpiv(m,n,a,krank,ind,ss)
c
c       computes the pivoted QR decomposition
c       of the matrix input into a, using Householder transformations,
c       _i.e._, transforms the matrix a from its input value in
c       to the matrix out with entry
c
c                               m
c       out(j,indprod(k))  =  Sigma  q(l,j) * in(l,k),
c                              l=1
c
c       for all j = 1, ..., krank, and k = 1, ..., n,
c
c       where in = the a from before the routine runs,
c       out = the a from after the routine runs,
c       out(j,k) = 0 when j > k (so that out is triangular),
c       q(1:m,1), ..., q(1:m,krank) are orthonormal,
c       indprod is the product of the permutations given by ind,
c       (as computable via the routine permmult,
c       with the permutation swapping 1 and ind(1) taken leftmost
c       in the product, that swapping 2 and ind(2) taken next leftmost,
c       ..., that swapping krank and ind(krank) taken rightmost),
c       and with the matrix out satisfying
c
c                  min(krank,m,n)
c       in(j,k)  =     Sigma      q(j,l) * out(l,indprod(k))
c                       l=1
c
c                +  epsilon(j,k),
c
c       for all j = 1, ..., m, and k = 1, ..., n,
c
c       for some matrix epsilon whose norm is (hopefully) minimized
c       by the pivoting procedure.
c       Well, technically, this routine outputs the Householder vectors
c       (or, rather, their second through last entries)
c       in the part of a that is supposed to get zeroed, that is,
c       in a(j,k) with m >= j > k >= 1.
c
c       input:
c       m -- first dimension of a and q
c       n -- second dimension of a
c       a -- matrix whose QR decomposition gets computed
c       krank -- desired rank of the output matrix
c                (please note that if krank > m or krank > n,
c                then the rank of the output matrix will be
c                less than krank)
c
c       output:
c       a -- triangular (R) factor in the QR decompositon
c            of the matrix input into the same storage locations,
c            with the Householder vectors stored in the part of a
c            that would otherwise consist entirely of zeroes, that is,
c            in a(j,k) with m >= j > k >= 1
c       ind(k) -- index of the k^th pivot vector;
c                 the following code segment will correctly rearrange
c                 the product b of q and the upper triangle of out
c                 so that b best matches the input matrix in:
c
c                 copy the non-rearranged product of q and out into b
c                 set k to krank
c                 [start of loop]
c                   swap b(1:m,k) and b(1:m,ind(k))
c                   decrement k by 1
c                 if k > 0, then go to [start of loop]
c
c       work:
c       ss -- must be at least n real*8 words long
c
c       _N.B._: This routine outputs the Householder vectors
c       (or, rather, their second through last entries)
c       in the part of a that is supposed to get zeroed, that is,
c       in a(j,k) with m >= j > k >= 1.
c
c       reference:
c       Golub and Van Loan, "Matrix Computations," 3rd edition,
c            Johns Hopkins University Press, 1996, Chapter 5.
c
        implicit none
        integer n,m,ind(n),krank,k,j,kpiv,mm,nupdate,ifrescal,
     1          loops,loop
        real*8 a(m,n),ss(n),ssmax,scal,ssmaxin,rswap,feps
c
c
        feps = .1d-16
c
c
c       Compute the sum of squares of the entries in each column of a,
c       the maximum of all such sums, and find the first pivot
c       (column with the greatest such sum).
c
        ssmax = 0
        kpiv = 1
c
        do k = 1,n
c
          ss(k) = 0
          do j = 1,m
            ss(k) = ss(k)+a(j,k)**2
          enddo ! j
c
          if(ss(k) .gt. ssmax) then
            ssmax = ss(k)
            kpiv = k
          endif
c
        enddo ! k
c
        ssmaxin = ssmax
c
        nupdate = 0
c
c
c       Set loops = min(krank,m,n).
c
        loops = krank
        if(m .lt. loops) loops = m
        if(n .lt. loops) loops = n
c
        do loop = 1,loops
c
c
          mm = m-loop+1
c
c
c         Perform the pivoting.
c
          ind(loop) = kpiv
c
c         Swap a(1:m,loop) and a(1:m,kpiv).
c
          do j = 1,m
            rswap = a(j,loop)
            a(j,loop) = a(j,kpiv)
            a(j,kpiv) = rswap
          enddo ! j
c
c         Swap ss(loop) and ss(kpiv).
c
          rswap = ss(loop)
          ss(loop) = ss(kpiv)
          ss(kpiv) = rswap
c
c
          if(loop .lt. m) then
c
c
c           Compute the data for the Householder transformation
c           which will zero a(loop+1,loop), ..., a(m,loop)
c           when applied to a, replacing a(loop,loop)
c           with the first entry of the result of the application
c           of the Householder matrix to a(loop:m,loop),
c           and storing entries 2 to mm of the Householder vector
c           in a(loop+1,loop), ..., a(m,loop)
c           (which otherwise would get zeroed upon application
c           of the Householder transformation).
c
            call idd_house(mm,a(loop,loop),a(loop,loop),
     1                     a(loop+1,loop),scal)
            ifrescal = 0
c
c
c           Apply the Householder transformation
c           to the lower right submatrix of a
c           with upper leftmost entry at position (loop,loop+1).
c
            if(loop .lt. n) then
              do k = loop+1,n
                call idd_houseapp(mm,a(loop+1,loop),a(loop,k),
     1                            ifrescal,scal,a(loop,k))
              enddo ! k
            endif
c
c
c           Update the sums-of-squares array ss.
c
            do k = loop,n
              ss(k) = ss(k)-a(loop,k)**2
            enddo ! k
c
c
c           Find the pivot (column with the greatest sum of squares
c           of its entries).
c
            ssmax = 0
            kpiv = loop+1
c
            if(loop .lt. n) then
c
              do k = loop+1,n
c
                if(ss(k) .gt. ssmax) then
                  ssmax = ss(k)
                  kpiv = k
                endif
c
              enddo ! k
c
            endif ! loop .lt. n
c
c
c           Recompute the sums-of-squares and the pivot
c           when ssmax first falls below
c           sqrt((1000*feps)^2) * ssmaxin
c           and when ssmax first falls below
c           ((1000*feps)^2) * ssmaxin.
c
            if(
     1       (ssmax .lt. sqrt((1000*feps)**2) * ssmaxin
     2        .and. nupdate .eq. 0) .or.
     3       (ssmax .lt. ((1000*feps)**2) * ssmaxin
     4        .and. nupdate .eq. 1)
     5      ) then
c
              nupdate = nupdate+1
c
              ssmax = 0
              kpiv = loop+1
c
              if(loop .lt. n) then
c
                do k = loop+1,n
c
                  ss(k) = 0
                  do j = loop+1,m
                    ss(k) = ss(k)+a(j,k)**2
                  enddo ! j
c
                  if(ss(k) .gt. ssmax) then
                    ssmax = ss(k)
                    kpiv = k
                  endif
c
                enddo ! k
c
              endif ! loop .lt. n
c
            endif
c
c
          endif ! loop .lt. m
c
c
        enddo ! loop
c
c
        return
        end