!*****************************************************************************************
!>
!  UOBYQA: **U**nconstrained **O**ptimization **BY** **Q**uadratic **A**pproximation
!
!  The purpose of UOBYQA is to seek the least value of a function F of several variables,
!  when derivatives are not available.
!  It uses a trust region method that forms quadratic models by interpolation.
!
!# References
!
!  * "UOBYQA: unconstrained optimization by
!    quadratic approximation" by M.J.D. Powell, Report DAMTP 2000/NA14,
!    University of Cambridge.
!  * "[UOBYQA: unconstrained optimization by quadratic
!    approximation](http://link.springer.com/article/10.1007%2Fs101070100290)" by
!    M.J.D. Powell, Mathematical Programming Series B, Volume
!    92, pages 555-582 (2002).
!
!# History
!  * M.J.D. Powell : It is hoped that the software will
!    be helpful to much future research and to many applications.
!    There are no restrictions on or charges for its use.
!  * Jacob Williams, July 2015 : refactoring of the code into modern Fortran.

    module uobyqa_module

    use kind_module, only: wp

    private

    abstract interface
    subroutine func (n, x, f)  !! calfun interface
        import :: wp
        implicit none
        integer :: n
        real (wp) :: x (*)
        real (wp) :: f
    end subroutine func
    end interface

    public :: uobyqa
    public :: uobyqa_test

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

!*****************************************************************************************
!>
!  This subroutine seeks the least value of a function of many variables,
!  by a trust region method that forms quadratic models by interpolation.

    subroutine uobyqa (n, x, rhobeg, rhoend, iprint, maxfun, calfun)

        implicit none

        integer,intent(in)    :: n               !! the number of variables and must be at least two
        real(wp),intent(inout),dimension(*) :: x !! Initial values of the variables must be set in X(1),X(2),...,X(N). They
                                                 !! will be changed to the values that give the least calculated F.
        real(wp),intent(in)   :: rhobeg          !! RHOBEG and RHOEND must be set to the initial and final values of a trust
                                    	         !! region radius, so both must be positive with RHOEND<=RHOBEG. Typically
                                    	         !! RHOBEG should be about one tenth of the greatest expected change to a
                                    	         !! variable, and RHOEND should indicate the accuracy that is required in
                                    	         !! the final values of the variables.
        real(wp),intent(in)   :: rhoend          !! RHOBEG and RHOEND must be set to the initial and final values of a trust
                                    	         !! region radius, so both must be positive with RHOEND<=RHOBEG. Typically
                                    	         !! RHOBEG should be about one tenth of the greatest expected change to a
                                    	         !! variable, and RHOEND should indicate the accuracy that is required in
                                    	         !! the final values of the variables.
        integer,intent(in)    :: iprint          !! The value of IPRINT should be set to 0, 1, 2 or 3, which controls the
                                    	         !! amount of printing. Specifically, there is no output if IPRINT=0 and
                                    	         !! there is output only at the return if IPRINT=1. Otherwise, each new
                                    	         !! value of RHO is printed, with the best vector of variables so far and
                                    	         !! the corresponding value of the objective function. Further, each new
                                    	         !! value of F with its variables are output if IPRINT=3.
        integer,intent(in)   :: maxfun           !! upper bound on the number of calls of CALFUN.
        procedure (func)     :: calfun           !! It must set F to the value of the objective
                                                 !! function for the variables X(1),X(2),...,X(N).

        real(wp),dimension(:),allocatable :: w
        integer :: npt,ixb,ixo,ixn,ixp,ipq,ipl,ih,ig,id,ivl,iw

        ! Partition the working space array, so that different parts of it can be
        ! treated separately by the subroutine that performs the main calculation.

        npt = (n*n+3*n+2) / 2
        ixb = 1
        ixo = ixb + n
        ixn = ixo + n
        ixp = ixn + n
        ipq = ixp + n * npt
        ipl = ipq + npt - 1
        ih = ipl + (npt-1) * npt
        ig = ih + n * n
        id = ig + n
        ivl = ih
        iw = id + n

        ! The array W will be used for working space
        allocate(w((N**4+8*N**3+23*N**2+42*N+max(2*N**2+4,18*N))/4))

        call uobyqb (n, x, rhobeg, rhoend, iprint, maxfun, npt, w(ixb), w(ixo), w(ixn), &
                     w(ixp), w(ipq), w(ipl), w(ih), w(ig), w(id), w(ivl), w(iw), calfun)

        deallocate(w)

    end subroutine uobyqa
!*****************************************************************************************

    subroutine uobyqb (n, x, rhobeg, rhoend, iprint, maxfun, npt, xbase, xopt, xnew, xpt, &
                       pq, pl, h, g, d, vlag, w, calfun)

        implicit real (wp) (a-h, o-z)

        dimension x (*), xbase (*), xopt (*), xnew (*), xpt (npt,*), pq (*), pl (npt,*), &
                  h (n,*), g (*), d (*), vlag (*), w (*)
        procedure (func) :: calfun
!
!     The arguments N, X, RHOBEG, RHOEND, IPRINT and MAXFUN are identical to
!       the corresponding arguments in SUBROUTINE UOBYQA.
!     NPT is set by UOBYQA to (N*N+3*N+2)/2 for the above dimension statement.
!     XBASE will contain a shift of origin that reduces the contributions from
!       rounding errors to values of the model and Lagrange functions.
!     XOPT will be set to the displacement from XBASE of the vector of
!       variables that provides the least calculated F so far.
!     XNEW will be set to the displacement from XBASE of the vector of
!       variables for the current calculation of F.
!     XPT will contain the interpolation point coordinates relative to XBASE.
!     PQ will contain the parameters of the quadratic model.
!     PL will contain the parameters of the Lagrange functions.
!     H will provide the second derivatives that TRSTEP and LAGMAX require.
!     G will provide the first derivatives that TRSTEP and LAGMAX require.
!     D is reserved for trial steps from XOPT, except that it will contain
!       diagonal second derivatives during the initialization procedure.
!     VLAG will contain the values of the Lagrange functions at a new point X.
!     The array W will be used for working space. Its length must be at least
!     max [ 6*N, ( N**2 + 3*N + 2 ) / 2 ].
!
!     Set some constants.
!
        one = 1.0_wp
        two = 2.0_wp
        zero = 0.0_wp
        half = 0.5_wp
        tol = 0.01_wp
        nnp = n + n + 1
        nptm = npt - 1
        nftest = max (maxfun, 1)
!
!     Initialization. NF is the number of function calculations so far.
!
        rho = rhobeg
        rhosq = rho * rho
        nf = 0
        do i = 1, n
            xbase (i) = x (i)
            do k = 1, npt
                xpt (k, i) = zero
            end do
        end do
        do k = 1, npt
            do j = 1, nptm
                pl (k, j) = zero
            end do
        end do
!
!     The branch to label 120 obtains a new value of the objective function
!     and then there is a branch back to label 50, because the new function
!     value is needed to form the initial quadratic model. The least function
!     value so far and its index are noted below.
!
30      do i = 1, n
            x (i) = xbase (i) + xpt (nf+1, i)
        end do
        go to 120
50      if (nf == 1) then
            fopt = f
            kopt = nf
            fbase = f
            j = 0
            jswitch = - 1
            ih = n
        else
            if (f < fopt) then
                fopt = f
                kopt = nf
            end if
        end if
!
!     Form the gradient and diagonal second derivatives of the initial
!     quadratic model and Lagrange functions.
!
        if (nf <= nnp) then
            jswitch = - jswitch
            if (jswitch > 0) then
                if (j >= 1) then
                    ih = ih + j
                    if (w(j) < zero) then
                        d (j) = (fsave+f-two*fbase) / rhosq
                        pq (j) = (fsave-f) / (two*rho)
                        pl (1, ih) = - two / rhosq
                        pl (nf-1, j) = half / rho
                        pl (nf-1, ih) = one / rhosq
                    else
                        pq (j) = (4.0_wp*fsave-3.0_wp*fbase-f) / (two*rho)
                        d (j) = (fbase+f-two*fsave) / rhosq
                        pl (1, j) = - 1.5_wp / rho
                        pl (1, ih) = one / rhosq
                        pl (nf-1, j) = two / rho
                        pl (nf-1, ih) = - two / rhosq
                    end if
                    pq (ih) = d (j)
                    pl (nf, j) = - half / rho
                    pl (nf, ih) = one / rhosq
                end if
!
!     Pick the shift from XBASE to the next initial interpolation point
!     that provides diagonal second derivatives.
!
                if (j < n) then
                    j = j + 1
                    xpt (nf+1, j) = rho
                end if
            else
                fsave = f
                if (f < fbase) then
                    w (j) = rho
                    xpt (nf+1, j) = two * rho
                else
                    w (j) = - rho
                    xpt (nf+1, j) = - rho
                end if
            end if
            if (nf < nnp) go to 30
!
!     Form the off-diagonal second derivatives of the initial quadratic model.
!
            ih = n
            ip = 1
            iq = 2
        end if
        ih = ih + 1
        if (nf > nnp) then
            temp = one / (w(ip)*w(iq))
            tempa = f - fbase - w (ip) * pq (ip) - w (iq) * pq (iq)
            pq (ih) = (tempa-half*rhosq*(d(ip)+d(iq))) * temp
            pl (1, ih) = temp
            iw = ip + ip
            if (w(ip) < zero) iw = iw + 1
            pl (iw, ih) = - temp
            iw = iq + iq
            if (w(iq) < zero) iw = iw + 1
            pl (iw, ih) = - temp
            pl (nf, ih) = temp
!
!     Pick the shift from XBASE to the next initial interpolation point
!     that provides off-diagonal second derivatives.
!
            ip = ip + 1
        end if
        if (ip == iq) then
            ih = ih + 1
            ip = 1
            iq = iq + 1
        end if
        if (nf < npt) then
            xpt (nf+1, ip) = w (ip)
            xpt (nf+1, iq) = w (iq)
            go to 30
        end if
!
!     Set parameters to begin the iterations for the current RHO.
!
        sixthm = zero
        delta = rho
60      tworsq = (two*rho) ** 2
        rhosq = rho * rho
!
!     Form the gradient of the quadratic model at the trust region centre.
!
70      knew = 0
        ih = n
        do j = 1, n
            xopt (j) = xpt (kopt, j)
            g (j) = pq (j)
            do i = 1, j
                ih = ih + 1
                g (i) = g (i) + pq (ih) * xopt (j)
                if (i < j) g (j) = g (j) + pq (ih) * xopt (i)
                h (i, j) = pq (ih)
            end do
        end do
!
!     Generate the next trust region step and test its length. Set KNEW
!     to -1 if the purpose of the next F will be to improve conditioning,
!     and also calculate a lower bound on the Hessian term of the model Q.
!
        call trstep (n, g, h, delta, tol, d, w(1), w(n+1), w(2*n+1), w(3*n+1), w(4*n+1), &
                     w(5*n+1), evalue)
        temp = zero
        do i = 1, n
            temp = temp + d (i) ** 2
        end do
        dnorm = min (delta, sqrt(temp))
        errtol = - one
        if (dnorm < half*rho) then
            knew = - 1
            errtol = half * evalue * rho * rho
            if (nf <= npt+9) errtol = zero
            go to 290
        end if
!
!     Calculate the next value of the objective function.
!
100     do i = 1, n
            xnew (i) = xopt (i) + d (i)
            x (i) = xbase (i) + xnew (i)
        end do
120     if (nf >= nftest) then
            if (iprint > 0) print 130
130         format (/ 4 x, 'Return from UOBYQA because CALFUN has been',&
            ' called MAXFUN times')
            go to 420
        end if
        nf = nf + 1
        call calfun (n, x, f)
        if (iprint == 3) then
            print 140, nf, f, (x(i), i=1, n)
140         format (/ 4 x, 'Function number', i6, '    F =', 1 pd18.10,&
            '    The corresponding X is:' / (2 x, 5d15.6))
        end if
        if (nf <= npt) go to 50
        if (knew ==-1) go to 420
!
!     Use the quadratic model to predict the change in F due to the step D,
!     and find the values of the Lagrange functions at the new point.
!
        vquad = zero
        ih = n
        do j = 1, n
            w (j) = d (j)
            vquad = vquad + w (j) * pq (j)
            do i = 1, j
                ih = ih + 1
                w (ih) = d (i) * xnew (j) + d (j) * xopt (i)
                if (i == j) w (ih) = half * w (ih)
                vquad = vquad + w (ih) * pq (ih)
            end do
        end do
        do k = 1, npt
            temp = zero
            do j = 1, nptm
                temp = temp + w (j) * pl (k, j)
            end do
            vlag (k) = temp
        end do
        vlag (kopt) = vlag (kopt) + one
!
!     Update SIXTHM, which is a lower bound on one sixth of the greatest
!     third derivative of F.
!
        diff = f - fopt - vquad
        sum = zero
        do k = 1, npt
            temp = zero
            do i = 1, n
                temp = temp + (xpt(k, i)-xnew(i)) ** 2
            end do
            temp = sqrt (temp)
            sum = sum + abs (temp*temp*temp*vlag(k))
        end do
        sixthm = max (sixthm, abs(diff)/sum)
!
!     Update FOPT and XOPT if the new F is the least value of the objective
!     function so far. Then branch if D is not a trust region step.
!
        fsave = fopt
        if (f < fopt) then
            fopt = f
            do i = 1, n
                xopt (i) = xnew (i)
            end do
        end if
        ksave = knew
        if (knew > 0) go to 240
!
!     Pick the next value of DELTA after a trust region step.
!
        if (vquad >= zero) then
            if (iprint > 0) print 210
210         format (/ 4 x, 'Return from UOBYQA because a trust',&
            ' region step has failed to reduce Q')
            go to 420
        end if
        ratio = (f-fsave) / vquad
        if (ratio <= 0.1_wp) then
            delta = half * dnorm
        else if (ratio <= 0.7_wp) then
            delta = max (half*delta, dnorm)
        else
            delta = max (delta, 1.25_wp*dnorm, dnorm+rho)
        end if
        if (delta <= 1.5_wp*rho) delta = rho
!
!     Set KNEW to the index of the next interpolation point to be deleted.
!
        ktemp = 0
        detrat = zero
        if (f >= fsave) then
            ktemp = kopt
            detrat = one
        end if
        do k = 1, npt
            sum = zero
            do i = 1, n
                sum = sum + (xpt(k, i)-xopt(i)) ** 2
            end do
            temp = abs (vlag(k))
            if (sum > rhosq) temp = temp * (sum/rhosq) ** 1.5_wp
            if (temp > detrat .and. k /= ktemp) then
                detrat = temp
                ddknew = sum
                knew = k
            end if
        end do
        if (knew == 0) go to 290
!
!     Replace the interpolation point that has index KNEW by the point XNEW,
!     and also update the Lagrange functions and the quadratic model.
!
240     do i = 1, n
            xpt (knew, i) = xnew (i)
        end do
        temp = one / vlag (knew)
        do j = 1, nptm
            pl (knew, j) = temp * pl (knew, j)
            pq (j) = pq (j) + diff * pl (knew, j)
        end do
        do k = 1, npt
            if (k /= knew) then
                temp = vlag (k)
                do j = 1, nptm
                    pl (k, j) = pl (k, j) - temp * pl (knew, j)
                end do
            end if
        end do
!
!     Update KOPT if F is the least calculated value of the objective
!     function. Then branch for another trust region calculation. The
!     case KSAVE>0 indicates that a model step has just been taken.
!
        if (f < fsave) then
            kopt = knew
            go to 70
        end if
        if (ksave > 0) go to 70
        if (dnorm > two*rho) go to 70
        if (ddknew > tworsq) go to 70
!
!     Alternatively, find out if the interpolation points are close
!     enough to the best point so far.
!
290     do k = 1, npt
            w (k) = zero
            do i = 1, n
                w (k) = w (k) + (xpt(k, i)-xopt(i)) ** 2
            end do
        end do
310     knew = - 1
        distest = tworsq
        do k = 1, npt
            if (w(k) > distest) then
                knew = k
                distest = w (k)
            end if
        end do
!
!     If a point is sufficiently far away, then set the gradient and Hessian
!     of its Lagrange function at the centre of the trust region, and find
!     half the sum of squares of components of the Hessian.
!
        if (knew > 0) then
            ih = n
            sumh = zero
            do j = 1, n
                g (j) = pl (knew, j)
                do i = 1, j
                    ih = ih + 1
                    temp = pl (knew, ih)
                    g (j) = g (j) + temp * xopt (i)
                    if (i < j) then
                        g (i) = g (i) + temp * xopt (j)
                        sumh = sumh + temp * temp
                    end if
                    h (i, j) = temp
                end do
                sumh = sumh + half * temp * temp
            end do
!
!     If ERRTOL is positive, test whether to replace the interpolation point
!     with index KNEW, using a bound on the maximum modulus of its Lagrange
!     function in the trust region.
!
            if (errtol > zero) then
                w (knew) = zero
                sumg = zero
                do i = 1, n
                    sumg = sumg + g (i) ** 2
                end do
                estim = rho * (sqrt(sumg)+rho*sqrt(half*sumh))
                wmult = sixthm * distest ** 1.5_wp
                if (wmult*estim <= errtol) go to 310
            end if
!
!     If the KNEW-th point may be replaced, then pick a D that gives a large
!     value of the modulus of its Lagrange function within the trust region.
!     Here the vector XNEW is used as temporary working space.
!
            call lagmax (n, g, h, rho, d, xnew, vmax)
            if (errtol > zero) then
                if (wmult*vmax <= errtol) go to 310
            end if
            go to 100
        end if
        if (dnorm > rho) go to 70
!
!     Prepare to reduce RHO by shifting XBASE to the best point so far,
!     and make the corresponding changes to the gradients of the Lagrange
!     functions and the quadratic model.
!
        if (rho > rhoend) then
            ih = n
            do j = 1, n
                xbase (j) = xbase (j) + xopt (j)
                do k = 1, npt
                    xpt (k, j) = xpt (k, j) - xopt (j)
                end do
                do i = 1, j
                    ih = ih + 1
                    pq (i) = pq (i) + pq (ih) * xopt (j)
                    if (i < j) then
                        pq (j) = pq (j) + pq (ih) * xopt (i)
                        do k = 1, npt
                            pl (k, j) = pl (k, j) + pl (k, ih) * xopt (i)
                        end do
                    end if
                    do k = 1, npt
                        pl (k, i) = pl (k, i) + pl (k, ih) * xopt (j)
                    end do
                end do
            end do
!
!     Pick the next values of RHO and DELTA.
!
            delta = half * rho
            ratio = rho / rhoend
            if (ratio <= 16.0_wp) then
                rho = rhoend
            else if (ratio <= 250.0_wp) then
                rho = sqrt (ratio) * rhoend
            else
                rho = 0.1_wp * rho
            end if
            delta = max (delta, rho)
            if (iprint >= 2) then
                if (iprint >= 3) print 390
390             format (5 x)
                print 400, rho, nf
400             format (/ 4 x, 'New RHO =', 1 pd11.4, 5 x, 'Number of',&
                        ' function values =', i6)
                print 410, fopt, (xbase(i), i=1, n)
410             format (4 x, 'Least value of F =', 1 pd23.15, 9 x,&
                'The corresponding X is:'/(2 x, 5d15.6))
            end if
            go to 60
        end if
!
!     Return from the calculation, after another Newton-Raphson step, if
!     it is too short to have been tried before.
!
        if (errtol >= zero) go to 100
420     if (fopt <= f) then
            do i = 1, n
                x (i) = xbase (i) + xopt (i)
            end do
            f = fopt
        end if
        if (iprint >= 1) then
            print 440, nf
440         format (/ 4 x, 'At the return from UOBYQA', 5 x,&
            'Number of function values =', i6)
            print 410, f, (x(i), i=1, n)
        end if

    end subroutine uobyqb

    subroutine lagmax (n, g, h, rho, d, v, vmax)

        implicit real (wp) (a-h, o-z)

        dimension g (*), h (n,*), d (*), v (*)
!
!     N is the number of variables of a quadratic objective function, Q say.
!     G is the gradient of Q at the origin.
!     H is the symmetric Hessian matrix of Q. Only the upper triangular and
!       diagonal parts need be set.
!     RHO is the trust region radius, and has to be positive.
!     D will be set to the calculated vector of variables.
!     The array V will be used for working space.
!     VMAX will be set to |Q(0)-Q(D)|.
!
!     Calculating the D that maximizes |Q(0)-Q(D)| subject to ||D|| .LEQ. RHO
!     requires of order N**3 operations, but sometimes it is adequate if
!     |Q(0)-Q(D)| is within about 0.9 of its greatest possible value. This
!     subroutine provides such a solution in only of order N**2 operations,
!     where the claim of accuracy has been tested by numerical experiments.
!
!     Preliminary calculations.
!
        half = 0.5_wp
        halfrt = sqrt (half)
        one = 1.0_wp
        zero = 0.0_wp
!
!     Pick V such that ||HV|| / ||V|| is large.
!
        hmax = zero
        do i = 1, n
            sum = zero
            do j = 1, n
                h (j, i) = h (i, j)
                sum = sum + h (i, j) ** 2
            end do
            if (sum > hmax) then
                hmax = sum
                k = i
            end if
        end do
        do j = 1, n
            v (j) = h (k, j)
        end do
!
!     Set D to a vector in the subspace spanned by V and HV that maximizes
!     |(D,HD)|/(D,D), except that we set D=HV if V and HV are nearly parallel.
!     The vector that has the name D at label 60 used to be the vector W.
!
        vsq = zero
        vhv = zero
        dsq = zero
        do i = 1, n
            vsq = vsq + v (i) ** 2
            d (i) = zero
            do j = 1, n
                d (i) = d (i) + h (i, j) * v (j)
            end do
            vhv = vhv + v (i) * d (i)
            dsq = dsq + d (i) ** 2
        end do
        if (vhv*vhv <= 0.9999_wp*dsq*vsq) then
            temp = vhv / vsq
            wsq = zero
            do i = 1, n
                d (i) = d (i) - temp * v (i)
                wsq = wsq + d (i) ** 2
            end do
            whw = zero
            ratio = sqrt (wsq/vsq)
            do i = 1, n
                temp = zero
                do j = 1, n
                    temp = temp + h (i, j) * d (j)
                end do
                whw = whw + temp * d (i)
                v (i) = ratio * v (i)
            end do
            vhv = ratio * ratio * vhv
            vhw = ratio * wsq
            temp = half * (whw-vhv)
            temp = temp + sign (sqrt(temp**2+vhw**2), whw+vhv)
            do i = 1, n
                d (i) = vhw * v (i) + temp * d (i)
            end do
        end if
!
!     We now turn our attention to the subspace spanned by G and D. A multiple
!     of the current D is returned if that choice seems to be adequate.
!
        gg = zero
        gd = zero
        dd = zero
        dhd = zero
        do i = 1, n
            gg = gg + g (i) ** 2
            gd = gd + g (i) * d (i)
            dd = dd + d (i) ** 2
            sum = zero
            do j = 1, n
                sum = sum + h (i, j) * d (j)
            end do
            dhd = dhd + sum * d (i)
        end do
        temp = gd / gg
        vv = zero
        scale = sign (rho/sqrt(dd), gd*dhd)
        do i = 1, n
            v (i) = d (i) - temp * g (i)
            vv = vv + v (i) ** 2
            d (i) = scale * d (i)
        end do
        gnorm = sqrt (gg)
        if (gnorm*dd <= 0.5e-2_wp*rho*abs(dhd) .or. vv/dd <= 1.0e-4_wp) then
            vmax = abs (scale*(gd+half*scale*dhd))
            return
        end if
!
!     G and V are now orthogonal in the subspace spanned by G and D. Hence
!     we generate an orthonormal basis of this subspace such that (D,HV) is
!     negligible or zero, where D and V will be the basis vectors.
!
        ghg = zero
        vhg = zero
        vhv = zero
        do i = 1, n
            sum = zero
            sumv = zero
            do j = 1, n
                sum = sum + h (i, j) * g (j)
                sumv = sumv + h (i, j) * v (j)
            end do
            ghg = ghg + sum * g (i)
            vhg = vhg + sumv * g (i)
            vhv = vhv + sumv * v (i)
        end do
        vnorm = sqrt (vv)
        ghg = ghg / gg
        vhg = vhg / (vnorm*gnorm)
        vhv = vhv / vv
        if (abs(vhg) <= 0.01_wp*max(abs(ghg), abs(vhv))) then
            vmu = ghg - vhv
            wcos = one
            wsin = zero
        else
            temp = half * (ghg-vhv)
            vmu = temp + sign (sqrt(temp**2+vhg**2), temp)
            temp = sqrt (vmu**2+vhg**2)
            wcos = vmu / temp
            wsin = vhg / temp
        end if
        tempa = wcos / gnorm
        tempb = wsin / vnorm
        tempc = wcos / vnorm
        tempd = wsin / gnorm
        do i = 1, n
            d (i) = tempa * g (i) + tempb * v (i)
            v (i) = tempc * v (i) - tempd * g (i)
        end do
!
!     The final D is a multiple of the current D, V, D+V or D-V. We make the
!     choice from these possibilities that is optimal.
!
        dlin = wcos * gnorm / rho
        vlin = - wsin * gnorm / rho
        tempa = abs (dlin) + half * abs (vmu+vhv)
        tempb = abs (vlin) + half * abs (ghg-vmu)
        tempc = halfrt * (abs(dlin)+abs(vlin)) + 0.25_wp * abs (ghg+vhv)
        if (tempa >= tempb .and. tempa >= tempc) then
            tempd = sign (rho, dlin*(vmu+vhv))
            tempv = zero
        else if (tempb >= tempc) then
            tempd = zero
            tempv = sign (rho, vlin*(ghg-vmu))
        else
            tempd = sign (halfrt*rho, dlin*(ghg+vhv))
            tempv = sign (halfrt*rho, vlin*(ghg+vhv))
        end if
        do i = 1, n
            d (i) = tempd * d (i) + tempv * v (i)
        end do
        vmax = rho * rho * max (tempa, tempb, tempc)

    end subroutine lagmax

    subroutine trstep (n, g, h, delta, tol, d, gg, td, tn, w, piv, z, evalue)

        implicit real (wp) (a-h, o-z)

        dimension g (*), h (n,*), d (*), gg (*), td (*), tn (*), w (*), piv (*), z (*)
!
!     N is the number of variables of a quadratic objective function, Q say.
!     G is the gradient of Q at the origin.
!     H is the Hessian matrix of Q. Only the upper triangular and diagonal
!       parts need be set. The lower triangular part is used to store the
!       elements of a Householder similarity transformation.
!     DELTA is the trust region radius, and has to be positive.
!     TOL is the value of a tolerance from the open interval (0,1).
!     D will be set to the calculated vector of variables.
!     The arrays GG, TD, TN, W, PIV and Z will be used for working space.
!     EVALUE will be set to the least eigenvalue of H if and only if D is a
!     Newton-Raphson step. Then EVALUE will be positive, but otherwise it
!     will be set to zero.
!
!     Let MAXRED be the maximum of Q(0)-Q(D) subject to ||D|| .LEQ. DELTA,
!     and let ACTRED be the value of Q(0)-Q(D) that is actually calculated.
!     We take the view that any D is acceptable if it has the properties
!
!             ||D|| .LEQ. DELTA  and  ACTRED .LEQ. (1-TOL)*MAXRED.
!
!     The calculation of D is done by the method of Section 2 of the paper
!     by MJDP in the 1997 Dundee Numerical Analysis Conference Proceedings,
!     after transforming H to tridiagonal form.
!
!     Initialization.
!
        one = 1.0_wp
        two = 2.0_wp
        zero = 0.0_wp
        delsq = delta * delta
        evalue = zero
        nm = n - 1
        do i = 1, n
            d (i) = zero
            td (i) = h (i, i)
            do j = 1, i
                h (i, j) = h (j, i)
            end do
        end do
!
!     Apply Householder transformations to obtain a tridiagonal matrix that
!     is similar to H, and put the elements of the Householder vectors in
!     the lower triangular part of H. Further, TD and TN will contain the
!     diagonal and other nonzero elements of the tridiagonal matrix.
!
        do k = 1, nm
            kp = k + 1
            sum = zero
            if (kp < n) then
                kpp = kp + 1
                do i = kpp, n
                    sum = sum + h (i, k) ** 2
                end do
            end if
            if (sum == zero) then
                tn (k) = h (kp, k)
                h (kp, k) = zero
            else
                temp = h (kp, k)
                tn (k) = sign (sqrt(sum+temp*temp), temp)
                h (kp, k) = - sum / (temp+tn(k))
                temp = sqrt (two/(sum+h(kp, k)**2))
                do i = kp, n
                    w (i) = temp * h (i, k)
                    h (i, k) = w (i)
                    z (i) = td (i) * w (i)
                end do
                wz = zero
                do j = kp, nm
                    jp = j + 1
                    do i = jp, n
                        z (i) = z (i) + h (i, j) * w (j)
                        z (j) = z (j) + h (i, j) * w (i)
                    end do
                    wz = wz + w (j) * z (j)
                end do
                wz = wz + w (n) * z (n)
                do j = kp, n
                    td (j) = td (j) + w (j) * (wz*w(j)-two*z(j))
                    if (j < n) then
                        jp = j + 1
                        do i = jp, n
                            h (i, j) = h (i, j) - w (i) * z (j) - w (j) * (z(i)-wz*w(i))
                        end do
                    end if
                end do
            end if
        end do
!
!     Form GG by applying the similarity transformation to G.
!
        gsq = zero
        do i = 1, n
            gg (i) = g (i)
            gsq = gsq + g (i) ** 2
        end do
        gnorm = sqrt (gsq)
        do k = 1, nm
            kp = k + 1
            sum = zero
            do i = kp, n
                sum = sum + gg (i) * h (i, k)
            end do
            do i = kp, n
                gg (i) = gg (i) - sum * h (i, k)
            end do
        end do
!
!     Begin the trust region calculation with a tridiagonal matrix by
!     calculating the norm of H. Then treat the case when H is zero.
!
        hnorm = abs (td(1)) + abs (tn(1))
        tdmin = td (1)
        tn (n) = zero
        do i = 2, n
            temp = abs (tn(i-1)) + abs (td(i)) + abs (tn(i))
            hnorm = max (hnorm, temp)
            tdmin = min (tdmin, td(i))
        end do
        if (hnorm == zero) then
            if (gnorm == zero) return
            scale = delta / gnorm
            do i = 1, n
                d (i) = - scale * gg (i)
            end do
            go to 370
        end if
!
!     Set the initial values of PAR and its bounds.
!
        parl = max (zero,-tdmin, gnorm/delta-hnorm)
        parlest = parl
        par = parl
        paru = zero
        paruest = zero
        posdef = zero
        iterc = 0
!
!     Calculate the pivots of the Cholesky factorization of (H+PAR*I).
!
140     iterc = iterc + 1
        ksav = 0
        piv (1) = td (1) + par
        k = 1
150     if (piv(k) > zero) then
            piv (k+1) = td (k+1) + par - tn (k) ** 2 / piv (k)
        else
            if (piv(k) < zero .or. tn(k) /= zero) go to 160
            ksav = k
            piv (k+1) = td (k+1) + par
        end if
        k = k + 1
        if (k < n) go to 150
        if (piv(k) < zero) go to 160
        if (piv(k) == zero) ksav = k
!
!     Branch if all the pivots are positive, allowing for the case when
!     G is zero.
!
        if (ksav == 0 .and. gsq > zero) go to 230
        if (gsq == zero) then
            if (par == zero) go to 370
            paru = par
            paruest = par
            if (ksav == 0) go to 190
        end if
        k = ksav
!
!     Set D to a direction of nonpositive curvature of the given tridiagonal
!     matrix, and thus revise PARLEST.
!
160     d (k) = one
        if (abs(tn(k)) <= abs(piv(k))) then
            dsq = one
            dhd = piv (k)
        else
            temp = td (k+1) + par
            if (temp <= abs(piv(k))) then
                d (k+1) = sign (one,-tn(k))
                dhd = piv (k) + temp - two * abs (tn(k))
            else
                d (k+1) = - tn (k) / temp
                dhd = piv (k) + tn (k) * d (k+1)
            end if
            dsq = one + d (k+1) ** 2
        end if
170     if (k > 1) then
            k = k - 1
            if (tn(k) /= zero) then
                d (k) = - tn (k) * d (k+1) / piv (k)
                dsq = dsq + d (k) ** 2
                go to 170
            end if
            do i = 1, k
                d (i) = zero
            end do
        end if
        parl = par
        parlest = par - dhd / dsq
!
!     Terminate with D set to a multiple of the current D if the following
!     test suggests that it suitable to do so.
!
190     temp = paruest
        if (gsq == zero) temp = temp * (one-tol)
        if (paruest > zero .and. parlest >= temp) then
            dtg = zero
            do i = 1, n
                dtg = dtg + d (i) * gg (i)
            end do
            scale = - sign (delta/sqrt(dsq), dtg)
            do i = 1, n
                d (i) = scale * d (i)
            end do
            go to 370
        end if
!
!     Pick the value of PAR for the next iteration.
!
220     if (paru == zero) then
            par = two * parlest + gnorm / delta
        else
            par = 0.5_wp * (parl+paru)
            par = max (par, parlest)
        end if
        if (paruest > zero) par = min (par, paruest)
        go to 140
!
!     Calculate D for the current PAR in the positive definite case.
!
230     w (1) = - gg (1) / piv (1)
        do i = 2, n
            w (i) = (-gg(i)-tn(i-1)*w(i-1)) / piv (i)
        end do
        d (n) = w (n)
        do i = nm, 1, - 1
            d (i) = w (i) - tn (i) * d (i+1) / piv (i)
        end do
!
!     Branch if a Newton-Raphson step is acceptable.
!
        dsq = zero
        wsq = zero
        do i = 1, n
            dsq = dsq + d (i) ** 2
            wsq = wsq + piv (i) * w (i) ** 2
        end do
        if (par == zero .and. dsq <= delsq) go to 320
!
!     Make the usual test for acceptability of a full trust region step.
!
        dnorm = sqrt (dsq)
        phi = one / dnorm - one / delta
        temp = tol * (one+par*dsq/wsq) - dsq * phi * phi
        if (temp >= zero) then
            scale = delta / dnorm
            do i = 1, n
                d (i) = scale * d (i)
            end do
            go to 370
        end if
        if (iterc >= 2 .and. par <= parl) go to 370
        if (paru > zero .and. par >= paru) go to 370
!
!     Complete the iteration when PHI is negative.
!
        if (phi < zero) then
            parlest = par
            if (posdef == one) then
                if (phi <= phil) go to 370
                slope = (phi-phil) / (par-parl)
                parlest = par - phi / slope
            end if
            slope = one / gnorm
            if (paru > zero) slope = (phiu-phi) / (paru-par)
            temp = par - phi / slope
            if (paruest > zero) temp = min (temp, paruest)
            paruest = temp
            posdef = one
            parl = par
            phil = phi
            go to 220
        end if
!
!     If required, calculate Z for the alternative test for convergence.
!
        if (posdef == zero) then
            w (1) = one / piv (1)
            do i = 2, n
                temp = - tn (i-1) * w (i-1)
                w (i) = (sign(one, temp)+temp) / piv (i)
            end do
            z (n) = w (n)
            do i = nm, 1, - 1
                z (i) = w (i) - tn (i) * z (i+1) / piv (i)
            end do
            wwsq = zero
            zsq = zero
            dtz = zero
            do i = 1, n
                wwsq = wwsq + piv (i) * w (i) ** 2
                zsq = zsq + z (i) ** 2
                dtz = dtz + d (i) * z (i)
            end do
!
!     Apply the alternative test for convergence.
!
            tempa = abs (delsq-dsq)
            tempb = sqrt (dtz*dtz+tempa*zsq)
            gam = tempa / (sign(tempb, dtz)+dtz)
            temp = tol * (wsq+par*delsq) - gam * gam * wwsq
            if (temp >= zero) then
                do i = 1, n
                    d (i) = d (i) + gam * z (i)
                end do
                go to 370
            end if
            parlest = max (parlest, par-wwsq/zsq)
        end if
!
!     Complete the iteration when PHI is positive.
!
        slope = one / gnorm
        if (paru > zero) then
            if (phi >= phiu) go to 370
            slope = (phiu-phi) / (paru-par)
        end if
        parlest = max (parlest, par-phi/slope)
        paruest = par
        if (posdef == one) then
            slope = (phi-phil) / (par-parl)
            paruest = par - phi / slope
        end if
        paru = par
        phiu = phi
        go to 220
!
!     Set EVALUE to the least eigenvalue of the second derivative matrix if
!     D is a Newton-Raphson step. SHFMAX will be an upper bound on EVALUE.
!
320     shfmin = zero
        pivot = td (1)
        shfmax = pivot
        do k = 2, n
            pivot = td (k) - tn (k-1) ** 2 / pivot
            shfmax = min (shfmax, pivot)
        end do
!
!     Find EVALUE by a bisection method, but occasionally SHFMAX may be
!     adjusted by the rule of false position.
!
        ksave = 0
340     shift = 0.5_wp * (shfmin+shfmax)
        k = 1
        temp = td (1) - shift
350     if (temp > zero) then
            piv (k) = temp
            if (k < n) then
                temp = td (k+1) - shift - tn (k) ** 2 / temp
                k = k + 1
                go to 350
            end if
            shfmin = shift
        else
            if (k < ksave) go to 360
            if (k == ksave) then
                if (pivksv == zero) go to 360
                if (piv(k)-temp < temp-pivksv) then
                    pivksv = temp
                    shfmax = shift
                else
                    pivksv = zero
                    shfmax = (shift*piv(k)-shfmin*temp) / (piv(k)-temp)
                end if
            else
                ksave = k
                pivksv = temp
                shfmax = shift
            end if
        end if
        if (shfmin <= 0.99_wp*shfmax) go to 340
360     evalue = shfmin
!
!     Apply the inverse Householder transformations to D.
!
370     nm = n - 1
        do k = nm, 1, - 1
            kp = k + 1
            sum = zero
            do i = kp, n
                sum = sum + d (i) * h (i, k)
            end do
            do i = kp, n
                d (i) = d (i) - sum * h (i, k)
            end do
        end do

    end subroutine trstep

!*****************************************************************************************
!>
!  The Chebyquad test problem (Fletcher, 1965) for N = 2,4,6,8.

    subroutine uobyqa_test ()

        implicit none

        real(wp) :: x (10)
        integer :: iprint,maxfun,i,n
        real(wp) :: rhoend,rhobeg

        iprint = 2
        maxfun = 5000
        rhoend = 1.0e-8_wp
        do n = 2, 8, 2
            do i = 1, n
                x (i) = real (i, wp) / real (n+1, wp)
            end do
            rhobeg = 0.2_wp * x (1)
            print 20, n
20          format (/ / 5 x, '******************' / 5 x, 'Results with N =', i2, / 5 x,&
                    '******************')
            call uobyqa (n, x, rhobeg, rhoend, iprint, maxfun, calfun)
        end do

    contains

        subroutine calfun (n, x, f)

            implicit none

            integer :: n
            real (wp) :: x (*)
            real (wp) :: f

            real(wp) :: y (10, 10)
            real(wp) :: sum
            integer :: j,i,iw,np

            do j = 1, n
                y (1, j) = 1.0_wp
                y (2, j) = 2.0_wp * x (j) - 1.0_wp
            end do
            do i = 2, n
                do j = 1, n
                    y (i+1, j) = 2.0_wp * y (2, j) * y (i, j) - y (i-1, j)
                end do
            end do
            f = 0.0_wp
            np = n + 1
            iw = 1
            do i = 1, np
                sum = 0.0_wp
                do j = 1, n
                    sum = sum + y (i, j)
                end do
                sum = sum / real (n, wp)
                if (iw > 0) sum = sum + 1.0_wp / real (i*i-2*i, wp)
                iw = - iw
                f = f + sum * sum
            end do

        end subroutine calfun

    end subroutine uobyqa_test
!*****************************************************************************************

!*****************************************************************************************
    end module uobyqa_module
!*****************************************************************************************


      FUNCTION EVLMEM(FDT,COF,M,PM)
      DIMENSION COF(M)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      THETA=6.28318530717959D0*FDT
      WPR=DCOS(THETA)
      WPI=DSIN(THETA)
      WR=1.D0
      WI=0.D0
      SUMR=1.
      SUMI=0.
      DO 11 I=1,M
        WTEMP=WR
        WR=WR*WPR-WI*WPI
        WI=WI*WPR+WTEMP*WPI
        SUMR=SUMR-COF(I)*SNGL(WR)
        SUMI=SUMI-COF(I)*SNGL(WI)
11    CONTINUE
      EVLMEM=PM/(SUMR**2+SUMI**2)
      RETURN
      END


      SUBROUTINE CHINT(A,B,C,CINT,N)
      DIMENSION C(N),CINT(N)
      CON=0.25*(B-A)
      SUM=0.
      FAC=1.
      DO 11 J=2,N-1
        CINT(J)=CON*(C(J-1)-C(J+1))/(J-1)
        SUM=SUM+FAC*CINT(J)
        FAC=-FAC
11    CONTINUE
      CINT(N)=CON*C(N-1)/(N-1)
      SUM=SUM+FAC*CINT(N)
      CINT(1)=2.*SUM
      RETURN
      END


program problem63
  implicit none
  integer    :: i,j,temp,number

  number=0
  do i=1,10
     do j=1,200
        temp=count_digits((1q0*i)**j)
        if (temp==j) number=number+1
     end do
  end do

  print *, number

contains

  pure function count_digits(n)
    real*16, intent(in) :: n
    real*16             :: temp
    integer             :: count_digits

    temp=log10(n)
    count_digits=int(ceiling(temp))
    if (temp==0.0) then
       count_digits=1
    else if (mod(temp,1.0q0)==0.0q0) then
       count_digits=count_digits-1
    end if

  end function count_digits

end program problem63


module mod_field

  implicit none

  private
  public :: Field

  type :: Field
    real, allocatable :: data(:)
  end type Field

end module mod_field

module mod_average

  use mod_field, only: Field

  implicit none

  private
  public :: average

  interface average
    module procedure :: average_int
    module procedure :: average_real
    module procedure :: average_logical
    module procedure :: average_field
  end interface average

contains

  pure real function average_int(x) result(res)
    integer, intent(in) :: x(:)
    res = real(sum(x), kind=kind(res)) / size(x)
  end function average_int

  pure real function average_real(x) result(res)
    real, intent(in) :: x(:)
    res = sum(x) / size(x)
  end function average_real

  pure real function average_logical(x) result(res)
    logical, intent(in) :: x(:)
    res = real(count(x), kind=kind(res)) / size(x)
  end function average_logical

  pure real function average_field(f) result(res)
    class(Field), intent(in) :: f
    res = average(f % data)
  end function average_field

end module mod_average

program test_average

  use mod_average, only: average
  use mod_field, only: field

  type(Field) :: f

  print *, average([1, 6, 4])
  print *, average([1., 6., 4.])
  print *, average([.true., .true., .false.])

  f % data = [1., 6., 4.]
  print *, average(f)

end program test_average


subroutine advance_phi(lo, hi, &
     pold, po_l1, po_l2, po_l3, po_h1, po_h2, po_h3, &
     pnew, pn_l1, pn_l2, pn_l3, pn_h1, pn_h2, pn_h3, &
     ncomp, dx, dt) bind(C, name="advance_phi")

  implicit none

  integer, intent(in) :: lo(3),hi(3), ncomp
  integer, intent(in) :: po_l1, po_l2, po_l3, po_h1, po_h2, po_h3
  integer, intent(in) :: pn_l1, pn_l2, pn_l3, pn_h1, pn_h2, pn_h3
  double precision, intent(in   ) :: pold(po_l1:po_h1,po_l2:po_h2,po_l3:po_h3,ncomp)
  double precision, intent(inout) :: pnew(pn_l1:pn_h1,pn_l2:pn_h2,pn_l3:pn_h3,ncomp)
  double precision, intent(in   ) :: dx, dt

  integer :: i,j,k,n
  double precision :: dxinv, dtdx
  double precision :: fx(lo(1):hi(1)+1,lo(2):hi(2)  ,lo(3):hi(3))
  double precision :: fy(lo(1):hi(1)  ,lo(2):hi(2)+1,lo(3):hi(3))
  double precision :: fz(lo(1):hi(1)  ,lo(2):hi(2)  ,lo(3):hi(3)+1)

  dxinv = 1.d0/dx
  dtdx = dt*dxinv

  do n = 1, ncomp
     ! x-fluxes
     do k=lo(3),hi(3)
        do j=lo(2),hi(2)
           do i=lo(1),hi(1)+1
              fx(i,j,k) = ( pold(i-1,j,k,n) - pold(i,j,k,n) ) * dxinv
           end do
        end do
     end do

     ! y-fluxes
     do k=lo(3),hi(3)
        do j=lo(2),hi(2)+1
           do i=lo(1),hi(1)
              fy(i,j,k) = ( pold(i,j-1,k,n) - pold(i,j,k,n) ) * dxinv
           end do
        end do
     end do

     ! z-fluxes
     do k=lo(3),hi(3)+1
        do j=lo(2),hi(2)
           do i=lo(1),hi(1)
              fz(i,j,k) = ( pold(i,j,k-1,n) - pold(i,j,k,n) ) * dxinv
           end do
        end do
     end do

     do k=lo(3),hi(3)
        do j=lo(2),hi(2)
           do i=lo(1),hi(1)

              pnew(i,j,k,n) = pold(i,j,k,n) - dtdx * &
                   ( fx(i+1,j,k)-fx(i,j,k) &
                   + fy(i,j+1,k)-fy(i,j,k) &
                   + fz(i,j,k+1)-fz(i,j,k) )

           end do
        end do
     end do

  end do

end subroutine advance_phi

subroutine advance_phi2(lo, hi, &
     pold, po_l1, po_l2, po_l3, po_h1, po_h2, po_h3, &
     pnew, pn_l1, pn_l2, pn_l3, pn_h1, pn_h2, pn_h3, &
     ncomp, dx, dt) bind(C, name="advance_phi2")

  implicit none

  integer, intent(in) :: lo(3),hi(3), ncomp
  integer, intent(in) :: po_l1, po_l2, po_l3, po_h1, po_h2, po_h3
  integer, intent(in) :: pn_l1, pn_l2, pn_l3, pn_h1, pn_h2, pn_h3
  double precision, intent(in   ) :: pold(po_l1:po_h1,po_l2:po_h2,po_l3:po_h3,ncomp)
  double precision, intent(inout) :: pnew(pn_l1:pn_h1,pn_l2:pn_h2,pn_l3:pn_h3,ncomp)
  double precision, intent(in   ) :: dx, dt

  integer :: i,j,k,n
  double precision :: dxinv, dtdx
  double precision :: fx(lo(1):hi(1)+1,lo(2):hi(2)  ,lo(3):hi(3))
  double precision :: fy(lo(1):hi(1)  ,lo(2):hi(2)+1,lo(3):hi(3))
  double precision :: fz(lo(1):hi(1)  ,lo(2):hi(2)  ,lo(3):hi(3)+1)

  dxinv = 1.d0/dx
  dtdx = dt*dxinv

  !$omp parallel private(i,j,k,n)

  do n = 1, ncomp
     ! x-fluxes
     !$omp do collapse(2)
     do k=lo(3),hi(3)
        do j=lo(2),hi(2)
           do i=lo(1),hi(1)+1
              fx(i,j,k) = ( pold(i-1,j,k,n) - pold(i,j,k,n) ) * dxinv
           end do
        end do
     end do
     !$omp end do nowait

     ! y-fluxes
     !$omp do collapse(2)
     do k=lo(3),hi(3)
        do j=lo(2),hi(2)+1
           do i=lo(1),hi(1)
              fy(i,j,k) = ( pold(i,j-1,k,n) - pold(i,j,k,n) ) * dxinv
           end do
        end do
     end do
     !$omp end do nowait

     ! z-fluxes
     !$omp do collapse(2)
     do k=lo(3),hi(3)+1
        do j=lo(2),hi(2)
           do i=lo(1),hi(1)
              fz(i,j,k) = ( pold(i,j,k-1,n) - pold(i,j,k,n) ) * dxinv
           end do
        end do
     end do
     !$omp end do

     !$omp do collapse(2)
     do k=lo(3),hi(3)
        do j=lo(2),hi(2)
           do i=lo(1),hi(1)

              pnew(i,j,k,n) = pold(i,j,k,n) - dtdx * &
                   ( fx(i+1,j,k)-fx(i,j,k) &
                   + fy(i,j+1,k)-fy(i,j,k) &
                   + fz(i,j,k+1)-fz(i,j,k) )

           end do
        end do
     end do
     !$omp end do

  end do

  !$omp end parallel

end subroutine advance_phi2


      s=0
      do i=1,1000
          s=s+1./i**2
      end do
      write (*,*) s
      end


      FUNCTION RANGE(GXP,GGX,GNEED)
C    RANGE CALCULATES THE RANGE (SHOT TO RECEIVER DISTANCE) FROM A SET OF
C  GROUP-DISTANCE PAIRS AND/OR THE GROUP-GROUP DISTANCE.  THIS ROUTINE ASSUMES
C  THAT THE SEISMIC LINE IS STRAIGHT!!!  RANGES ARE INTERPOLATED BETWEEN
C  GROUPS SPECIFIED AND ARE EXTRAPOLATED USING GGX FOR GROUPS LESS THAN THE
C  FIRST GIVEN OR GREATER THAN THE LAST GIVEN.  EXTRAPOLATION USES GGX*
C  (GROUP GIVEN - GROUP WANTED)+(RANGE OF THE GROUP GIVEN).
C
C  ARGUMENTS:
C    GXP   - AN ARRAY OF GROUP-DISTANCE PAIRS.  AT LEAST ONE PAIR MUST BE GIVEN.
C            EACH PAIR MUST HAVE THE GROUP NUMBER FIRST AND THE RANGE (DISTANCE)
C            SECOND.  THE GXP SET MUST BE TERMINATED BY A NEGATIVE GROUP NUMBER.
C            THUS, ODD ELEMENTS IN THE GXP ARRAY ARE GROUP NUMBERS AND THE EVEN
C            ELEMENTS ARE THE CORRESPONDING RANGES.  GROUP NUMBERS MUST INCREASE
C            IN THE GXP ARRAY.
C    GGX   - THE CONSTANT GROUP TO GROUP DISTANCE.
C    GNEED - THE GROUP NUMBER OF THE RANGE WANTED.
C
C  EXAMPLE 1:
C  GIVEN GXP(1)=24., GXP(2)=450., GXP(3)=-1.,  GGX=300. AND GNEED=20.
C  THEN RANGE=(24-20)*300.+450.=1650.
C
C  COPYRIGHTED BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, DECEMBER 1979
C
      DIMENSION GXP(1)
C
      INDEX=1                                                            /* THE FIRST GXP PAIR
   10 TEMP=GXP(INDEX)-GNEED
c      IF(TEMP)300,200,100
      IF( temp .LT. 0 ) GOTO 300
      IF( temp .EQ. 0 ) GOTO 200
  100 IF(INDEX.NE.1) GO TO 150
C****  THE GROUP WANTED IS LESS THAN THE FIRST GIVEN OR IS GREATER THAN THE LAST
C****  GIVEN, THEREFORE, EXTRAPOLATE USING GGX.
  110 CONTINUE
      RANGE=TEMP*GGX+GXP(INDEX+1)
      RETURN
  150 CONTINUE                                                           /*  INTERPOLATE TO GET THE RANGE
      RANGE=(TEMP/(GXP(INDEX)-GXP(INDEX-2)))*(GXP(INDEX-1)-
     *     GXP(INDEX+1))+GXP(INDEX+1)
      RETURN
  200 CONTINUE                                                           /*  GNEED IS GXP(INDEX) EXACTLY!!
      RANGE=GXP(INDEX+1)
      RETURN
  300 CONTINUE                                                          /*  GROUP WANTED (GNEED) IS BIGGER THAN GXP(INDEX)
      IF(GXP(INDEX+2).LT.0.) GO TO 110
      INDEX=INDEX+2
      GO TO 10
      END


subroutine s_rmsd_superimpose(num_atoms,do_count,coord1,coord2,rmsd)
!
! This subroutine compares two sets of points (atoms) of the same size (!!!),
! computes RMSD, and superimposes the two coordinate sets - by translating and
! rotating the set "coord2". Do back up the array "coord2" to produce a copy of the
! previous values, in case they need to be restored back later.
!
! This subroutine is part of the implementation of Quaternion Characteristic
! Polynomial (QCP) method, based on the code published by Naoto Hori at:
!
! https://github.com/naotohori/fQCP
!
! under BSD license. His code, in turn, is based on the C code written by Pu Liu
! and Douglas L. Theobald. The code bellow is improved and partially revised by
! Veselin Kolev <vesso.kolev@gmail.com>.
!
! To cite QCP:
!
! 1. Douglas L. Theobald (2005) "Rapid calculation of RMSD using a quaternion-based
!    characteristic polynomial." Acta Crystallographica A 61(4):478-480.
!
! 2. Pu Liu, Dmitris K. Agrafiotis, and Douglas L. Theobald (2010) "Fast
!    determination of the optimal rotational matrix for do_counted
!    superpositions." Journal of Computational Chemistry 31(7):1561-1563
!
! Author : Veselin Kolev <vesso.kolev@gmail.com>
! License: BSD
! Version: 2019011700
!
use iso_c_binding,only:C_INT,C_FLOAT
!
implicit none
!
! Interface variables:
!
integer(C_INT),intent(in)   :: num_atoms
logical,intent(in)          :: do_count(num_atoms)
real(C_FLOAT),intent(in)    :: coord1(3,num_atoms)
real(C_FLOAT),intent(inout) :: coord2(3,num_atoms)
real(C_FLOAT),intent(out)   :: rmsd
!
! Local variables:
!
integer(C_INT)              :: i
integer(C_INT)              :: j
integer(C_INT)              :: ireturn
integer(C_INT)              :: ncount
integer(C_INT),parameter    :: t(6,3)=reshape(source=(/1,1,2,2,3,3,4,1,5,2,6,3,7,1,8,2,9,3/),shape=(/6,3/))
real(C_FLOAT)               :: A(9)
real(C_FLOAT)               :: E0
real(C_FLOAT)               :: rot(9)
real(C_FLOAT)               :: coord1_bak(3,num_atoms)
real(C_FLOAT)               :: coord2_bak(3,num_atoms)
real(C_FLOAT)               :: center1(3)
real(C_FLOAT)               :: center2(3)
real(C_FLOAT)               :: x_tmp(3)

! Create a copy of the input coordinates:
!
coord1_bak=coord1(:,:)
coord2_bak=coord2(:,:)
!
! Center the atom coordinates for the first molecule:
!
call s_rmsd_center_coords(num_atoms,do_count,coord1_bak,ncount)
!
! Center the atom coordinates for the second molecule:
!
call s_rmsd_center_coords(num_atoms,do_count,coord2_bak,ncount)
!
! Compute the inner product of the coordinates of the molecules:
!
call s_rmsd_inner_product(num_atoms,do_count,coord1_bak,coord2_bak,A,E0)
!
! Compute the RMSD and the corresponding rotation matrix:
!
call s_rmsd_fast_calc_rmsd_and_rotation(A,-1,ncount,E0,rmsd,rot,ireturn)
!
! Nullify the coordinates of the responding geometric center vectors:
!
center1=0.0
center2=0.0
!
! Compute the accumulation required to obtain the coordinates of
! the geometric center vectors:
!
do i=1,num_atoms
   !
   if (do_count(i)) then
      !
      center1=center1+coord1(:,i)
      center2=center2+coord2(:,i)
      !
   end if
   !
end do
!
! Do average the accumulation to obtain the vectors of the centers:
!
center1=center1/ncount
center2=center2/ncount
!
! Use the rotation matrix computed in attempt to minimize the RMSD,
! to superimpose the coordinates of the compared molecules:
!
do i=1,num_atoms
   !
   ! Shift the atom coordinates of the first molecule with respect
   ! to their own geometric center vector:
   !
   coord2(:,i)=coord2(:,i)-center2
   !
   ! Backup the centered coordinates before starting the rotation.
   ! They will be subject of alteration during the rotation process
   ! that follows bellow!
   !
   x_tmp=coord2(:,i)
   !
   ! Do the rotation direction by direction:
   !
   do j=1,3
      !
      coord2(j,i)=rot(t(1,j))*x_tmp(t(2,j))+&
                  rot(t(3,j))*x_tmp(t(4,j))+&
                  rot(t(5,j))*x_tmp(t(6,j))
      !
   end do
   !
   ! Shift the coordinates of the atoms of the second molecule
   ! with respect to the geometric center vector of the atom coordinates
   ! of the first molecule:
   !
   coord2(:,i)=coord2(:,i)+center1
   !
end do

end subroutine s_rmsd_superimpose


      FUNCTION BESSJ1(X)
      REAL*8 Y,P1,P2,P3,P4,P5,Q1,Q2,Q3,Q4,Q5,R1,R2,R3,R4,R5,R6,
     *    S1,S2,S3,S4,S5,S6
      DATA R1,R2,R3,R4,R5,R6/72362614232.D0,-7895059235.D0,242396853.1D0
     *,
     *    -2972611.439D0,15704.48260D0,-30.16036606D0/,
     *    S1,S2,S3,S4,S5,S6/144725228442.D0,2300535178.D0,
     *    18583304.74D0,99447.43394D0,376.9991397D0,1.D0/
      DATA P1,P2,P3,P4,P5/1.D0,.183105D-2,-.3516396496D-4,.2457520174D-5
     *,
     *    -.240337019D-6/, Q1,Q2,Q3,Q4,Q5/.04687499995D0,-.2002690873D-3
     *,
     *    .8449199096D-5,-.88228987D-6,.105787412D-6/
      IF(ABS(X).LT.8.)THEN
        Y=X**2
        BESSJ1=X*(R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6)))))
     *      /(S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6)))))
      ELSE
        AX=ABS(X)
        Z=8./AX
        Y=Z**2
        XX=AX-2.356194491
        BESSJ1=SQRT(.636619772/AX)*(COS(XX)*(P1+Y*(P2+Y*(P3+Y*(P4+Y
     *      *P5))))-Z*SIN(XX)*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))))
     *      *SIGN(1.,X)
      ENDIF
      RETURN
      END


      COMPLEX*16     FUNCTION ZLADIV( X, Y )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      COMPLEX*16         X, Y
*     ..
*
*  Purpose
*  =======
*
*  ZLADIV := X / Y, where X and Y are complex.  The computation of X / Y
*  will not overflow on an intermediary step unless the results
*  overflows.
*
*  Arguments
*  =========
*
*  X       (input) COMPLEX*16
*  Y       (input) COMPLEX*16
*          The complex scalars X and Y.
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION   ZI, ZR
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLADIV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, DIMAG
*     ..
*     .. Executable Statements ..
*
      CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
     $             ZI )
      ZLADIV = DCMPLX( ZR, ZI )
*
      RETURN
*
*     End of ZLADIV
*
      END


c     subroutine nnls  (a,mda,m,n,b,x,rnorm,w,zz,index,mode)
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 june 15
c     to appear in 'solving least squares problems', prentice-hall, 1974
c
c	  **********   nonnegative least squares   **********
c
c     given an m by n matrix, a, and an m-vector, b,  compute an
c     n-vector, x, which solves the least squares problem
c
c		       a * x = b  subject to x .ge. 0
c
c     a(),mda,m,n     mda is the first dimensioning parameter for the
c		      array, a().   on entry a() contains the m by n
c		      matrix, a.	   on exit a() contains
c		      the product matrix, q*a , where q is an
c		      m by m orthogonal matrix generated implicitly by
c		      this subroutine.
c     b()     on entry b() contains the m-vector, b.   on exit b() con-
c	      tains q*b.
c     x()     on entry x() need not be initialized.  on exit x() will
c	      contain the solution vector.
c     rnorm   on exit rnorm contains the euclidean norm of the
c	      residual vector.
c     w()     an n-array of working space.  on exit w() will contain
c	      the dual solution vector.   w will satisfy w(i) = 0.
c	      for all i in set p  and w(i) .le. 0. for all i in set z
c     zz()     an m-array of working space.
c     index()	  an integer working array of length at least n.
c		  on exit the contents of this array define the sets
c		  p and z as follows..
c
c		  index(1)   thru index(nsetp) = set p.
c		  index(iz1) thru index(iz2)   = set z.
c		  iz1 = nsetp + 1 = npp1
c		  iz2 = n
c     mode    this is a success-failure flag with the following
c	      meanings.
c	      1     the solution has been computed successfully.
c	      2     the dimensions of the problem are bad.
c		    either m .le. 0 or n .le. 0.
c	      3    iteration count exceeded.  more than 3*n iterations.
c
      subroutine nnls (a,mda,m,n,b,x,rnorm,w,zz,index,mode)
      dimension a(mda,n), b(m), x(n), w(n), zz(m)
      integer index(n)
      zero=0.
      one=1.
      two=2.
      factor=0.01
c
      mode=1
      if (m.gt.0.and.n.gt.0) go to 10
      mode=2
      return
   10 iter=0
      itmax=3*n
c
c		     initialize the arrays index() and x().
c
	  do 20 i=1,n
	  x(i)=zero
   20	  index(i)=i
c
      iz2=n
      iz1=1
      nsetp=0
      npp1=1
c			      ******  main loop begins here  ******
   30 continue
c		   quit if all coefficients are already in the solution.
c			 or if m cols of a have been triangularized.
c
      if (iz1.gt.iz2.or.nsetp.ge.m) go to 350
c
c	  compute components of the dual (negative gradient) vector w().
c
	  do 50 iz=iz1,iz2
	  j=index(iz)
	  sm=zero
	      do 40 l=npp1,m
   40	      sm=sm+a(l,j)*b(l)
   50	  w(j)=sm
c				    find largest positive w(j).
   60 wmax=zero
	  do 70 iz=iz1,iz2
	  j=index(iz)
	  if (w(j).le.wmax) go to 70
	  wmax=w(j)
	  izmax=iz
   70	  continue
c
c	      if wmax .le. 0. go to termination.
c	      this indicates satisfaction of the kuhn-tucker conditions.
c
      if (wmax) 350,350,80
   80 iz=izmax
      j=index(iz)
c
c     the sign of w(j) is ok for j to be moved to set p.
c     begin the transformation and check new diagonal element to avoid
c     near linear dependence.
c
      asave=a(npp1,j)
      call h12 (1,npp1,npp1+1,m,a(1,j),1,up,dummy,1,1,0)
      unorm=zero
      if (nsetp.eq.0) go to 100
	  do 90 l=1,nsetp
   90	  unorm=unorm+a(l,j)**2
  100 unorm=sqrt(unorm)
      if (diff(unorm+abs(a(npp1,j))*factor,unorm)) 130,130,110
c
c     col j is sufficiently independent.  copy b into zz, update zz and
c   > solve for ztest ( = proposed new value for x(j) ).
c
  110	  do 120 l=1,m
  120	  zz(l)=b(l)
      call h12 (2,npp1,npp1+1,m,a(1,j),1,up,zz,1,1,1)
      ztest=zz(npp1)/a(npp1,j)
c
c				      see if ztest is positive
c     reject j as a candidate to be moved from set z to set p.
c     restore a(npp1,j), set w(j)=0., and loop back to test dual
c
      if (ztest) 130,130,140
c
c     coeffs again.
c
  130 a(npp1,j)=asave
      w(j)=zero
      go to 60
c
c     the index  j=index(iz)  has been selected to be moved from
c     set z to set p.	 update b,  update indices,  apply householder
c     transformations to cols in new set z,  zero subdiagonal elts in
c     col j,  set w(j)=0.
c
  140	  do 150 l=1,m
  150	  b(l)=zz(l)
c
      index(iz)=index(iz1)
      index(iz1)=j
      iz1=iz1+1
      nsetp=npp1
      npp1=npp1+1
c
      if (iz1.gt.iz2) go to 170
	  do 160 jz=iz1,iz2
	  jj=index(jz)
  160	  call h12 (2,nsetp,npp1,m,a(1,j),1,up,a(1,jj),1,mda,1)
  170 continue
c
      if (nsetp.eq.m) go to 190
	  do 180 l=npp1,m
  180	  a(l,j)=zero
  190 continue
c
      w(j)=zero
c				 solve the triangular system.
c				 store the solution temporarily in zz().
      assign 200 to next
      go to 400
  200 continue
c
c			******	secondary loop begins here ******
c
c			   iteration counter.
c
  210 iter=iter+1
      if (iter.le.itmax) go to 220
      mode=3
      write (6,440)
      go to 350
  220 continue
c
c		     see if all new constrained coeffs are feasible.
c				   if not compute alpha.
c
      alpha=two
	  do 240 ip=1,nsetp
	  l=index(ip)
	  if (zz(ip)) 230,230,240
c
  230	  t=-x(l)/(zz(ip)-x(l))
	  if (alpha.le.t) go to 240
	  alpha=t
	  jj=ip
  240	  continue
c
c	   if all new constrained coeffs are feasible then alpha will
c	   still = 2.	 if so exit from secondary loop to main loop.
c
      if (alpha.eq.two) go to 330
c
c	   otherwise use alpha which will be between 0. and 1. to
c	   interpolate between the old x and the new zz.
c
	  do 250 ip=1,nsetp
	  l=index(ip)
  250	  x(l)=x(l)+alpha*(zz(ip)-x(l))
c
c	 modify a and b and the index arrays to move coefficient i
c	 from set p to set z.
c
      i=index(jj)
  260 x(i)=zero
c
      if (jj.eq.nsetp) go to 290
      jj=jj+1
	  do 280 j=jj,nsetp
	  ii=index(j)
	  index(j-1)=ii
	  call g1 (a(j-1,ii),a(j,ii),cc,ss,a(j-1,ii))
	  a(j,ii)=zero
	      do 270 l=1,n
	      if (l.ne.ii) call g2 (cc,ss,a(j-1,l),a(j,l))
  270	      continue
  280	  call g2 (cc,ss,b(j-1),b(j))
  290 npp1=nsetp
      nsetp=nsetp-1
      iz1=iz1-1
      index(iz1)=i
c
c	 see if the remaining coeffs in set p are feasible.  they should
c	 be because of the way alpha was determined.
c	 if any are infeasible it is due to round-off error.  any
c	 that are nonpositive will be set to zero
c	 and moved from set p to set z.
c
	  do 300 jj=1,nsetp
	  i=index(jj)
	  if (x(i)) 260,260,300
  300	  continue
c
c	  copy b( ) into zz( ).  then solve again and loop back.
c

	  do 310 i=1,m
  310	  zz(i)=b(i)
      assign 320 to next
      go to 400
  320 continue
      go to 210
c		       ******  end of secondary loop  ******
c
  330	  do 340 ip=1,nsetp
	  i=index(ip)
  340	  x(i)=zz(ip)
c	 all new coeffs are positive.  loop back to beginning.
      go to 30
c
c			 ******  end of main loop  ******
c
c			 come to here for termination.
c		      compute the norm of the final residual vector.
c
  350 sm=zero
      if (npp1.gt.m) go to 370
	  do 360 i=npp1,m
  360	  sm=sm+b(i)**2
      go to 390
  370	  do 380 j=1,n
  380	  w(j)=zero
  390 rnorm=sqrt(sm)
      return
c
c     the following block of code is used as an internal subroutine
c     to solve the triangular system, putting the solution in zz().
c
  400	  do 430 l=1,nsetp
	  ip=nsetp+1-l
	  if (l.eq.1) go to 420
	      do 410 ii=1,ip
  410	      zz(ii)=zz(ii)-a(ii,jj)*zz(ip+1)
  420	  jj=index(ip)
  430	  zz(ip)=zz(ip)/a(ip,jj)
      go to next, (200,320)
  440 format (35h0 nnls quitting on iteration count.)
      end


C written by amazing people from PyMC team: https://github.com/pymc-devs/pymc
C Chris Fonnesbeck, Anand Patil, David Huard, John Salvatier
C copied and compiled here, because PyMC is no longer maintained, and PyMC3
C lacks mvhyperg

      DOUBLE PRECISION FUNCTION gammln(xx)
C Returns the value ln[gamma(xx)] for xx > 0.

      DOUBLE PRECISION xx
      INTEGER j
      DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)

C Internal arithmetic will be done in double precision,
C a nicety that you can omit if five-figure accuracy is good enough.

      SAVE cof,stp
      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
     +24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     +-.5395239384953d-5,2.5066282746310005d0/
      x=xx
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*dlog(tmp)-tmp
      ser=1.000000000190015d0
      do j=1,6
         y=y+1.d0
         ser=ser+cof(j)/y
      enddo
      gammln=tmp+dlog(stp*ser/x)
      return
      END

      DOUBLE PRECISION FUNCTION factln(n)
C USES gammln Returns ln(n!).

      INTEGER n
      DOUBLE PRECISION a(100),gammln, pass_val
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)

      SAVE a
C Initialize the table to negative values.
      DATA a/100*-1./
      pass_val = n + 1
      if (n.lt.0) then
c        write (*,*) 'negative factorial in factln'
        factln=-infinity
        return
      endif
C In range of the table.
      if (n.le.99) then
C If not already in the table, put it in.
        if (a(n+1).lt.0.) a(n+1)=gammln(pass_val)
        factln=a(n+1)
      else
C Out of range of the table.
        factln=gammln(pass_val)
      endif
      return
      END

      SUBROUTINE mvhyperg(x,color,k,like)

c Multivariate hypergeometric log-likelihood function
c Using the analogy of an urn filled with balls of different colors,
c the mv hypergeometric distribution describes the probability of
c drawing x(i) balls of a given color.
c
c x : (array) Number of draws for each color.
c color : (array) Number of balls of each color.

c Total number of draws = sum(x)
c Total number of balls in the urn = sum(color)

cf2py integer dimension(k),intent(in) :: x,color
cf2py integer intent(hide),depend(x) :: k=len(x)
cf2py double precision intent(out) :: like
cf2py threadsafe

      INTEGER x(k),color(k)
      INTEGER d,total,i,k
      DOUBLE PRECISION like
      DOUBLE PRECISION factln
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)

      total = 0
      d = 0
      like = 0.0
      do i=1,k
c Combinations of x balls of color i
        like = like + factln(color(i))-factln(x(i))
     +-factln(color(i)-x(i))
        if ((color(i) .LT. 0.0) .OR. (x(i) .LT. 0.0)) then
          like = -infinity
          RETURN
        endif
        d = d + x(i)
        total = total + color(i)
      enddo
      if (total .LE. 0.0) then
        like = -infinity
        RETURN
      endif
c Combinations of d draws from total
      like = like - (factln(total)-factln(d)-factln(total-d))
      return
      END


c=======================================================================
c
c     GENCHI
c
c     Chi-square distribution generator
c
c     Generates random deviate from the distribution of a chisquare
C     with DF degrees of freedom random variable.
c
c-----------------------------------------------------------------------
c
c     Copyright (c) 2014 NumX
c     All rights reserved.
c
c     This software is the confidential and proprietary information
c     of NumX. You shall not disclose such Confidential
C     Information and shall use it only in accordance with the terms
c     of the licence agreement you entered into with NumX.
c
c     author: Yann Vernaz
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION genchi(df)
c-----------------------------------------------------------------------
c
c     INPUT :
c      DF : degrees of freedom of the chisquare (DF>0)           double
c
c     Method - Uses relation between chisquare and gamma.
c
c----------------------------------------------------------------------
c
c     scalar arguments
      DOUBLE PRECISION df
c
c     external functions
c      DOUBLE PRECISION gengam
c      EXTERNAL gengam
      DOUBLE PRECISION sgamma
      EXTERNAL sgamma
c
c     executable statements
c     changed this to call sgamma directly
c   10 genchi = 2.0*gengam(1.0,df/2.0)
 10   genchi = 2.0*sgamma(df/2.0)
      RETURN
      END


Subroutine ar3jet(s, x1, x3, jl)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Common /rndf77/nseed
  Save
  c = 1./3.
  If (k(jl,2)/=21 .And. k(jl+1,2)/=21) c = 8./27.
  exp1 = 3
  exp3 = 3
  If (k(jl,2)/=21) exp1 = 2
  If (k(jl+1,2)/=21) exp3 = 2
  a = 0.24**2/s
  yma = alog(.5/sqrt(a)+sqrt(.25/a-1))
  d = 4.*c*yma
  sm1 = p(jl, 5)**2/s
  sm3 = p(jl+1, 5)**2/s
  xt2m = (1.-2.*sqrt(sm1)+sm1-sm3)*(1.-2.*sqrt(sm3)-sm1+sm3)
  xt2m = min(.25, xt2m)
  ntry = 0
  1 If (ntry==5000) Then
    x1 = .5*(2.*sqrt(sm1)+1.+sm1-sm3)
    x3 = .5*(2.*sqrt(sm3)+1.-sm1+sm3)
    Return
  End If
  ntry = ntry + 1
  xt2 = a*(xt2m/a)**(ranart(nseed)**(1./d))
  ymax = alog(.5/sqrt(xt2)+sqrt(.25/xt2-1.))
  y = (2.*ranart(nseed)-1.)*ymax
  x1 = 1. - sqrt(xt2)*exp(y)
  x3 = 1. - sqrt(xt2)*exp(-y)
  x2 = 2. - x1 - x3
  neg = 0
  If (k(jl,2)/=21 .Or. k(jl+1,2)/=21) Then
    If ((1.-x1)*(1.-x2)*(1.-x3)-x2*sm1*(1.-x1)-x2*sm3*(1.-x3)<=0. .Or. x1<=2.*sqrt(sm1)-sm1+sm3 .Or. x3<=2.*sqrt(sm3)-sm3+sm1) neg = 1
    x1 = x1 + sm1 - sm3
    x3 = x3 - sm1 + sm3
  End If
  If (neg==1) Goto 1
  fg = 2.*ymax*c*(x1**exp1+x3**exp3)/d
  xt2m = xt2
  If (fg<ranart(nseed)) Goto 1
  Return
End Subroutine ar3jet


c
c-----------------------------------------------------------------------
c subroutine:  fast
c replaces the real vector b(k), for k=1,2,...,n,
c with its finite discrete fourier transform
c-----------------------------------------------------------------------
c
      subroutine fast(b, n)
c
c the dc term is returned in location b(1) with b(2) set to 0.
c thereafter the jth harmonic is returned as a complex
c number stored as  b(2*j+1) + i b(2*j+2).
c the n/2 harmonic is returned in b(n+1) with b(n+2) set to 0.
c hence, b must be dimensioned to size n+2.
c the subroutine is called as  fast(b,n) where n=2**m and
c b is the real array described above.
c
      dimension b(2)
      common /cons/ pii, p7, p7two, c22, s22, pi2
c
c iw is a machine dependent write device number
c
      iw = i1mach(2)
c
      pii = 4.*atan(1.)
      pi8 = pii/8.
      p7 = 1./sqrt(2.)
      p7two = 2.*p7
      c22 = cos(pi8)
      s22 = sin(pi8)
      pi2 = 2.*pii
      do 10 i=1,15
        m = i
        nt = 2**i
        if (n.eq.nt) go to 20
  10  continue
      write (iw,9999)
9999  format (33h n is not a power of two for fast)
      stop
  20  n4pow = m/2
c
c do a radix 2 iteration first if one is required.
c
      if (m-n4pow*2) 40, 40, 30
  30  nn = 2
      int = n/nn
      call fr2tr(int, b(1), b(int+1))
      go to 50
  40  nn = 1
c
c perform radix 4 iterations.
c
  50  if (n4pow.eq.0) go to 70
      do 60 it=1,n4pow
        nn = nn*4
        int = n/nn
        call fr4tr(int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1),
     *      b(1), b(int+1), b(2*int+1), b(3*int+1))
  60  continue
c
c perform in-place reordering.
c
  70  call ford1(m, b)
      call ford2(m, b)
      t = b(2)
      b(2) = 0.
      b(n+1) = t
      b(n+2) = 0.
      do 80 it=4,n,2
        b(it) = -b(it)
  80  continue
      return
      end


module strength
use hamiltonian_types
use maths
use build_hamiltonian_routines
implicit none
contains

!------------------------------------------------
! Locates a given value in a vector
!------------------------------------------------
	function locate(a,b)
	integer :: locate
	real(kind=8), INTENT(IN) :: a(:), b
	integer :: location(1)
		locate = -1

		location = minloc(abs(a-b))
		if (location(1) /= 0) then
			locate = location(1)
		endif

	end function locate

!------------------------------------------------
! Returns the kronecker's delta
!------------------------------------------------
	function kronecker(a,b)
	real*8 :: kronecker
	real*8, INTENT(IN) :: a, b
		kronecker = 0.d0
		if (a == b) then
			kronecker = 1.d0
		endif
	end function kronecker

! ------------------------------------------------------------
! This function returns the matrix elements of the dipole moment in the Hund's a)
! eigenfunctions
! ------------------------------------------------------------
	function q_o_m(Lambda_up,Omega_up,J_up,M_up,Lambda_low,Omega_low,J_low,M_low)
	real*8 :: q_o_m
	real*8, INTENT(IN) :: Lambda_up, Omega_up, J_up, M_up, Lambda_low, Omega_low, J_low, M_low
	real*8 :: q_m, q_o

		q_m = qm(J_up,M_up,J_low,M_low)
		q_o = qo(Lambda_up,Omega_up,J_up,Lambda_low,Omega_low,J_low)

		q_o_m = q_o * q_m

	end function q_o_m

! ------------------------------------------------------------
! This function returns the matrix elements of q_o
! ------------------------------------------------------------
	function qm(J_up,M_up,J_low,M_low)
	real*8 :: qm
	real*8, INTENT(IN) :: J_up, M_up, J_low, M_low
	real*8 :: deltam, deltaj, J, M

		deltaj = J_up - J_low
		deltam = M_up - M_low

		J = J_low
		M = M_low
		qm = 0.d0

		if (deltam == 0.d0) then
			if (deltaj == 1.d0) then
				qm = dsqrt((J+1.d0)**2 - M**2)
			else if (deltaj == 0) then
				qm = M
			else if (deltaj == -1.d0) then
				qm = dsqrt(J**2 - M**2)
			endif
		endif

		if (dabs(deltam) == 1.d0) then
			if (deltaj == 1.d0) then
				qm = -deltam * dsqrt(0.5d0*(J+1.d0+M*deltam)*(J+2.d0+M*deltam))
			else if (deltaj == 0) then
				qm = dsqrt(0.5d0*(J-M*deltam)*(J+1.d0+M*deltam))
			else if (deltaj == -1.d0) then
				qm = deltam * dsqrt(0.5d0*(J-M*deltam)*(J-1.d0-M*deltam))
			endif
		endif

	end function qm

! ------------------------------------------------------------
! This function returns the matrix elements of q_o
! ------------------------------------------------------------
	function qo(Lambda_up,Omega_up,J_up,Lambda_low,Omega_low,J_low)
	real*8 :: qo
	real*8, INTENT(IN) :: Lambda_up, Omega_up, J_up, Lambda_low, Omega_low, J_low
	real*8 :: deltao, deltaj, Omega, J, pi_eps

		deltao = Omega_up - Omega_low
		deltaj = J_up - J_low
		pi_eps = 1.d0 + kronecker(1.d0,Lambda_up+Lambda_low)

		J = J_low
		Omega = Omega_low
		qo = 0.d0

		if (deltao == 0.d0) then
			if (deltaj == 1.d0) then
				qo = 1.d0/(J+1.d0) * dsqrt(( (J+1.d0)**2 - Omega**2)/( (2.d0*J+1.d0)*(2.d0*J+3.d0)) )
			else if (deltaj == 0) then
				qo = Omega / (J*(J+1.d0))
			else if (deltaj == -1.d0) then
				qo = 1.d0/J * dsqrt(( J**2 - Omega**2)/((2.d0*J-1.d0)*(2.d0*J+1.d0)))
			endif
		endif

		if (dabs(deltao) == 1.d0) then
			if (deltaj == 1.d0) then
				qo = -deltao/(J+1.d0) * dsqrt(pi_eps*(J+1.d0+Omega*deltao)*(J+2.d0+Omega*deltao) /&
					(2.d0*(2.d0*J+1.d0)*(2.d0*J+3.d0)))
			else if (deltaj == 0) then
				qo = 1.d0/(J*(J+1.d0)) * dsqrt(0.5d0*pi_eps*(J-Omega*deltao)*(J+1.d0+Omega*deltao))
			else if (deltaj == -1.d0) then
				qo = deltao/J * dsqrt(pi_eps*(J-Omega*deltao)*(J-1.d0-Omega*deltao) /&
					(2.d0*(2.d0*J-1.d0)*(2.d0*J+1.d0)))
			endif
		endif

	end function qo

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Strength of the Zeeman components in the Hund's case (a) coupling
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function case_a_strength(Ju,Jl,Mu,Ml,Ou,Ol,Lu,Ll)
	real(kind=8) :: case_a_strength
	real(kind=8) :: Mu, Ml, Ju, Jl, Ou, Ol, qm, ql, Lu, Ll

		qm = Mu - Ml
		ql = Ol - Ou !Ll - Lu

! Falta un factor sqrt((2Ju+1)*(2Jl+1)) ??

!		case_a_strength = w3js(int(2.d0*Jl),int(2.d0*Ju),2,int(2.d0*Ml),-int(2.d0*Mu),int(2.d0*qm)) * &
!			w3js(int(2.d0*Jl),int(2.d0*Ju),2,int(2.d0*Ol),-int(2.d0*Ou),int(2.d0*qo)) * &
!			sqrt((2.d0*Ju+1.d0)*(2.d0*Jl+1.d0))
		case_a_strength = w3js(int(2.d0*Ju),int(2.d0*Jl),2,int(2.d0*Mu),-int(2.d0*Ml),-int(2.d0*qm)) * &
			w3js(int(2.d0*Ju),int(2.d0*Jl),2,int(2.d0*Ou),-int(2.d0*Ol),int(2.d0*ql)) * sqrt((2.d0*Jl+1.d0)*(2.d0*Ju+1.d0))

	end function case_a_strength

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Strength of the Zeeman components in the Hund's case (a) coupling
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function direction_cosine_matrix(Ju,Jl,Mu,Ml,Ou,Ol,Su,Sl,Lu,Ll)
	real(kind=8) :: direction_cosine_matrix
	real(kind=8) :: Ju,Jl,Mu,Ml,Ou,Ol,Su,Sl,Lu,Ll

		direction_cosine_matrix = kronecker(Su,Sl) * q_o_m(Lu,Ou,Ju,Mu,Ll,Ol,Jl,Ml)

!		print *, direction_cosine_matrix
!		direction_cosine_matrix = kronecker(Su,Sl) * case_a_strength(Ju,Jl,Mu,Ml,Ou,Ol,Lu,Ll)
!		print*, direction_cosine_matrix
!		pause
		if (IsNan(direction_cosine_matrix)) then
			direction_cosine_matrix = 0.d0
		endif

	end function direction_cosine_matrix

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Strength of the Zeeman components in the Hund's case (a) coupling
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function transition_strength(trans,up,low)
	type(type_transition) :: trans
	real(kind=8) :: transition_strength, str
	real(kind=8) :: Ju, Jl, Mu, Ml, Ou, Ol, Su, Sl, Lu, Ll
	integer :: l1, l2, up, low

! The Hamiltonian matrix is written with the basis ordered by M value. Therefore, we have to calculate
! the direction cosine in this very same basis set in order to get correct results

		str = 0.d0

		do l1 = 1, trans%upper%hamiltonian_size
			do l2 = 1, trans%lower%hamiltonian_size

				Ju = trans%upper%ket_m_ordered(l1)%J
				Jl = trans%lower%ket_m_ordered(l2)%J
				Mu = trans%upper%ket_m_ordered(l1)%M
				Ml = trans%lower%ket_m_ordered(l2)%M
				Ou = trans%upper%ket_m_ordered(l1)%Omega
				Ol = trans%lower%ket_m_ordered(l2)%Omega
				Su = trans%upper%ket_m_ordered(l1)%Sigma
				Sl = trans%lower%ket_m_ordered(l2)%Sigma
				Lu = trans%upper%Lambda
				Ll = trans%lower%Lambda

				str = str + trans%upper%eigenvec(l1,up) * &
					direction_cosine_matrix(Ju,Jl,Mu,Ml,Ou,Ol,Su,Sl,Lu,Ll) * trans%lower%eigenvec(l2,low)

			enddo
		enddo

		transition_strength = str

	end function transition_strength

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Count the number of Zeeman components and generate the index arrays
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine count_zeeman_components(trans)
	type(type_transition) :: trans
	integer :: i, j, i2, j2, k, nJup, nJlow, ind_up, ind_low, ind_up_str, ind_low_str
	real(kind=8) :: Ju, Jl, Mu, Ml, Ou, Ol, Su, Sl, Lu, Ll, case_a_str, spli_up, spli_low, spli, m_up, m_low, str
	real(kind=8), allocatable :: direction_cosine(:,:), strength_matrix(:,:), caca(:,:)
	integer :: loc(2), l1, l2

		nJup = int(2.d0*trans%upper%J+1.d0)
		nJlow = int(2.d0*trans%lower%J+1.d0)

		k = 0
		do i = 1, trans%upper%hamiltonian_size
			do j = 1, trans%lower%hamiltonian_size
				if ( abs(trans%upper%ket(i)%M-trans%lower%ket(j)%M) <= 1.d0 .and. &
					trans%upper%active(i) /= -9999 .and. trans%lower%active(j) /= -9999) then
						k = k + 1
				endif
			enddo
		enddo
		print *, 'Number of Zeeman transitions : ', k

		open(unit=12,file='pattern.dat',action='write',status='replace')
		write(12,*) k

		k = 0
		do i = 0, 2*trans%upper%J
			m_up = -trans%upper%J + i
			do j = 0, 2*trans%lower%J
				m_low = -trans%lower%J + j

				if (dabs(m_up-m_low) <= 1.d0) then

					ind_up = locate(trans%upper%active(:),m_up)
					ind_low = locate(trans%lower%active(:),m_low)

					ind_up_str = ind_up !trans%upper%original_order(ind_up)
					ind_low_str = ind_low !trans%lower%original_order(ind_low)

! This has to be done because I am having problems with the parity of the functions
! This problems appears because my eigenfunctions still do not have a definite parity
! I have to take this into account. It is necessary to calculate the Hamiltonian and then perform combinations
! of the matrix elements according to the well-defined parity eigenfunctions of Hund's case (a)
! For the moment, this trick seems to work
					str = transition_strength(trans,ind_up_str,ind_low_str)

!					if (str**2 == 0.d0) then
!						ind_up_str = locate(trans%upper%active(2,:),m_up) !trans%upper%original_order(locate(trans%upper%active(2,:),m_up))
!						ind_low_str = locate(trans%lower%active(1,:),m_low) !trans%lower%original_order(locate(trans%lower%active(1,:),m_low))
!						str = transition_strength(trans,ind_up_str,ind_low_str)
!					endif

					spli_up = trans%upper%eigenval(ind_up)-trans%upper%Energy0
					spli_low = trans%lower%eigenval(ind_low)-trans%lower%Energy0
					spli = -(spli_up-spli_low)*(trans%wavelength*1.d-8)**2 * 1.d8

					write(*,FMT='(F5.1,1X,F5.1,1X,F13.8,3X,F13.8,3X,E13.7)') trans%upper%ket(ind_up)%M, &
							trans%lower%ket(ind_low)%M, spli, str**2
					write(12,FMT='(F5.1,1X,F5.1,1X,F13.8,3X,F13.8,3X,E13.7)') trans%upper%ket(ind_up)%M, &
							trans%lower%ket(ind_low)%M, spli, str**2

				endif
			enddo
		enddo
		close(12)

	end subroutine count_zeeman_components

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Strength of the Zeeman components
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine zeeman_strength(trans)
	type(type_transition) :: trans

! First count the number of components of the Zeeman transition
		call count_zeeman_components(trans)

	end subroutine zeeman_strength

end module strength


c       this file contains the following user-callable routines:
c
c
c       routine idd_id2svd converts an approximation to a matrix
c       in the form of an ID to an approximation in the form of an SVD.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idd_id2svd(m,krank,b,n,list,proj,u,v,s,ier,w)
c
c       converts an approximation to a matrix in the form of an ID
c       to an approximation in the form of an SVD.
c
c       input:
c       m -- first dimension of b
c       krank -- rank of the ID
c       b -- columns of the original matrix in the ID
c       list -- list of columns chosen from the original matrix
c               in the ID
c       n -- length of list and part of the second dimension of proj
c       proj -- projection coefficients in the ID
c
c       output:
c       u -- left singular vectors
c       v -- right singular vectors
c       s -- singular values
c       ier -- 0 when the routine terminates successfully;
c              nonzero otherwise
c
c       work:
c       w -- must be at least (krank+1)*(m+3*n)+26*krank**2 real*8
c            elements long
c
c       _N.B._: This routine destroys b.
c
        implicit none
        integer m,krank,n,list(n),iwork,lwork,ip,lp,it,lt,ir,lr,
     1          ir2,lr2,ir3,lr3,iind,lind,iindt,lindt,lw,ier
        real*8 b(m,krank),proj(krank,n-krank),u(m,krank),v(n,krank),
     1         w((krank+1)*(m+3*n)+26*krank**2),s(krank)
c
c
        lw = 0
c
        iwork = lw+1
        lwork = 25*krank**2
        lw = lw+lwork
c
        ip = lw+1
        lp = krank*n
        lw = lw+lp
c
        it = lw+1
        lt = n*krank
        lw = lw+lt
c
        ir = lw+1
        lr = krank*n
        lw = lw+lr
c
        ir2 = lw+1
        lr2 = krank*m
        lw = lw+lr2
c
        ir3 = lw+1
        lr3 = krank*krank
        lw = lw+lr3
c
        iind = lw+1
        lind = n/2+1
        lw = lw+1
c
        iindt = lw+1
        lindt = m/2+1
        lw = lw+1
c
c
        call idd_id2svd0(m,krank,b,n,list,proj,u,v,s,ier,
     1                   w(iwork),w(ip),w(it),w(ir),w(ir2),w(ir3),
     2                   w(iind),w(iindt))
c
c
        return
        end
c
c
c
c
        subroutine idd_id2svd0(m,krank,b,n,list,proj,u,v,s,ier,
     1                         work,p,t,r,r2,r3,ind,indt)
c
c       routine idd_id2svd serves as a memory wrapper
c       for the present routine (please see routine idd_id2svd
c       for further documentation).
c
        implicit none
c
        character*1 jobz
        integer m,n,krank,list(n),ind(n),indt(m),iftranspose,
     1          lwork,ldu,ldvt,ldr,info,j,k,ier
        real*8 b(m,krank),proj(krank,n-krank),p(krank,n),
     1         r(krank,n),r2(krank,m),t(n,krank),r3(krank,krank),
     2         u(m,krank),v(n,krank),s(krank),work(25*krank**2)
c
c
c
        ier = 0
c
c
c
c       Construct the projection matrix p from the ID.
c
        call idd_reconint(n,list,krank,proj,p)
c
c
c
c       Compute a pivoted QR decomposition of b.
c
        call iddr_qrpiv(m,krank,b,krank,ind,r)
c
c
c       Extract r from the QR decomposition.
c
        call idd_rinqr(m,krank,b,krank,r)
c
c
c       Rearrange r according to ind.
c
        call idd_rearr(krank,ind,krank,krank,r)
c
c
c
c       Transpose p to obtain t.
c
        call idd_mattrans(krank,n,p,t)
c
c
c       Compute a pivoted QR decomposition of t.
c
        call iddr_qrpiv(n,krank,t,krank,indt,r2)
c
c
c       Extract r2 from the QR decomposition.
c
        call idd_rinqr(n,krank,t,krank,r2)
c
c
c       Rearrange r2 according to indt.
c
        call idd_rearr(krank,indt,krank,krank,r2)
c
c
c
c       Multiply r and r2^T to obtain r3.
c
        call idd_matmultt(krank,krank,r,krank,r2,r3)
c
c
c
c       Use LAPACK to SVD r3.
c
        jobz = 'S'
        ldr = krank
        lwork = 25*krank**2-krank**2-4*krank
        ldu = krank
        ldvt = krank
c
        call dgesdd(jobz,krank,krank,r3,ldr,s,work,ldu,r,ldvt,
     1              work(krank**2+4*krank+1),lwork,
     2              work(krank**2+1),info)
c
        if(info .ne. 0) then
          ier = info
          return
        endif
c
c
c
c       Multiply the u from r3 from the left by the q from b
c       to obtain the u for a.
c
        do k = 1,krank
c
          do j = 1,krank
            u(j,k) = work(j+krank*(k-1))
          enddo ! j
c
          do j = krank+1,m
            u(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        iftranspose = 0
        call idd_qmatmat(iftranspose,m,krank,b,krank,krank,u,r2)
c
c
c
c       Transpose r to obtain r2.
c
        call idd_mattrans(krank,krank,r,r2)
c
c
c       Multiply the v from r3 from the left by the q from p^T
c       to obtain the v for a.
c
        do k = 1,krank
c
          do j = 1,krank
            v(j,k) = r2(j,k)
          enddo ! j
c
          do j = krank+1,n
            v(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        iftranspose = 0
        call idd_qmatmat(iftranspose,n,krank,t,krank,krank,v,r2)
c
c
        return
        end
c
c
c
c
        subroutine idd_mattrans(m,n,a,at)
c
c       transposes a to obtain at.
c
c       input:
c       m -- first dimension of a, and second dimension of at
c       n -- second dimension of a, and first dimension of at
c       a -- matrix to be transposed
c
c       output:
c       at -- transpose of a
c
        implicit none
        integer m,n,j,k
        real*8 a(m,n),at(n,m)
c
c
        do k = 1,n
          do j = 1,m
            at(k,j) = a(j,k)
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idd_matmultt(l,m,a,n,b,c)
c
c       multiplies a and b^T to obtain c.
c
c       input:
c       l -- first dimension of a and c
c       m -- second dimension of a and b
c       a -- leftmost matrix in the product c = a b^T
c       n -- first dimension of b and second dimension of c
c       b -- rightmost matrix in the product c = a b^T
c
c       output:
c       c -- product of a and b^T
c
        implicit none
        integer l,m,n,i,j,k
        real*8 a(l,m),b(n,m),c(l,n),sum
c
c
        do i = 1,l
          do k = 1,n
c
            sum = 0
c
            do j = 1,m
              sum = sum+a(i,j)*b(k,j)
            enddo ! j
c
            c(i,k) = sum
c
          enddo ! k
        enddo ! i
c
c
        return
        end
c
c
c
c
        subroutine idd_rearr(krank,ind,m,n,a)
c
c       rearranges a according to ind obtained
c       from routines iddr_qrpiv or iddp_qrpiv,
c       assuming that a = q r, where q and r are from iddr_qrpiv
c       or iddp_qrpiv.
c
c       input:
c       krank -- rank obtained from routine iddp_qrpiv,
c                or provided to routine iddr_qrpiv
c       ind -- indexing array obtained from routine iddr_qrpiv
c              or iddp_qrpiv
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix to be rearranged
c
c       output:
c       a -- rearranged matrix
c
        implicit none
        integer k,krank,m,n,j,ind(krank)
        real*8 rswap,a(m,n)
c
c
        do k = krank,1,-1
          do j = 1,m
c
            rswap = a(j,k)
            a(j,k) = a(j,ind(k))
            a(j,ind(k)) = rswap
c
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idd_rinqr(m,n,a,krank,r)
c
c       extracts R in the QR decomposition specified by the output a
c       of the routine iddr_qrpiv or iddp_qrpiv.
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a and r
c       a -- output of routine iddr_qrpiv or iddp_qrpiv
c       krank -- rank output by routine iddp_qrpiv (or specified
c                to routine iddr_qrpiv)
c
c       output:
c       r -- triangular factor in the QR decomposition specified
c            by the output a of the routine iddr_qrpiv or iddp_qrpiv
c
        implicit none
        integer m,n,j,k,krank
        real*8 a(m,n),r(krank,n)
c
c
c       Copy a into r and zero out the appropriate
c       Householder vectors that are stored in one triangle of a.
c
        do k = 1,n
          do j = 1,krank
            r(j,k) = a(j,k)
          enddo ! j
        enddo ! k
c
        do k = 1,n
          if(k .lt. krank) then
            do j = k+1,krank
              r(j,k) = 0
            enddo ! j
          endif
        enddo ! k
c
c
        return
        end


! { dg-do run }
! Check that array constructors using non-compile-time
! iterators are handled correctly.
program main
  implicit none
  call init_random_seed
contains
  SUBROUTINE init_random_seed()
    INTEGER :: i, n, clock
    INTEGER, DIMENSION(:), ALLOCATABLE :: seed

    CALL RANDOM_SEED(size = n)
    ALLOCATE(seed(n))

    CALL SYSTEM_CLOCK(COUNT=clock)

    seed = clock + 37 * (/ (i - 1, i = 1, n) /)
    CALL RANDOM_SEED(PUT = seed)

    DEALLOCATE(seed)
  END SUBROUTINE init_random_seed
end program main