module brown_m
!! Contains routines for evaluating **B**._d_**W** in the SDE for Brownian Dynamics
!! simulation.

use iso_c_binding, only: c_loc, c_ptr, c_f_pointer
use mkl_blas
use mkl_lapack
use constants_m
use random_m
use strings_m
use logger_m

implicit none

private
public :: brn_init, brn_finish, brn_calc_dw, brn_calc_bdw

character(4) :: meth
    !!Method to use for generating Brownian terms. Possible values are
    !!'CHOL' or 'LANC'.
integer :: sizm
    !!Size of the mobility matrix
integer :: s
    !!Number of Brownian vectors to be generated; equivalent to block size in the
    !!block Lanczos algorithm.
integer :: dimk_min = 2
    !!Minimum dimension of KSP
integer :: dimk_max
    !!Maximum dimension of KSP
real(rp) :: ethres = 1.0e-3_rp
    !!Error threshold for KSP-based method.
real(rp), dimension(:,:), allocatable :: bdw_old
    !!(`sizm`, `s`) array. Stores B.dw at previous iteration.
real(rp), dimension(:,:), allocatable :: lncv
    !!(`sizm`, `s*dimk_max`) array. Stores the Lanczos vectors.
real(rp), dimension(:), allocatable :: eigvlh
    !!(`s*dimk_max`,) array. Eigenvalues of the tridiagonal/block triadiagonal
    !! matrix H generated by the Lanczos algorithm.
real(rp), dimension(:,:), allocatable :: eigvch
    !!(`s*dimk_max`, `s*dimk_max`) array. Eigenvectors of the matrix H.
real(rp), dimension(:,:), allocatable :: w
    !!(`sizm`, `s`) array. Used for generating the Lanczos vectors.
real(rp), dimension(:), allocatable :: h_d
    !!(`dimk_max`,) array. Diagonal of the symmetric tridiagonal matrix H
    !! generated in case of `s = 1`.
real(rp), dimension(:), allocatable :: h_sd
    !!(`dimk_max`,) array. Subdiagonal of the symmetric tridiagonal matrix H
    !! generated in case of `s = 1`.
real(rp), dimension(:), allocatable :: tau
    !! (`s`,) array. Used in the QR decomposition of `w`.
real(rp), dimension(:,:), allocatable :: matr
    !! (`s`,`s`) array. Used in the QR decomposition of `w`.
real(rp), dimension(:,:), allocatable :: h_bd
    !!(`s`, `s*dimk_max`) array. Diagonal blocks of the matrix H.
    !!Used for KSP with `s > 1`.
real(rp), dimension(:,:), allocatable :: h_bsd
    !!(`s`, `s*dimk_max`) array. Subdiagonal blocks of the matrix H.
    !!Used for KSP with `s > 1`.
real(rp), dimension(:,:), allocatable :: h_bnd
    !!(`2*s`, `s*dimk_max`) array. Matrix H in banded storage.
    !!Used for KSP with `s > 1`.
real(rp), dimension(:,:), allocatable :: tmp
    !!(`s*dimk_max`, `2*s`) array used as temporary storage space.
real(rp), dimension(:), allocatable :: work
    !!Workspace array for LAPACK routines.
integer, dimension(:), allocatable :: iwork
    !!Workspace array for LAPACK routines.

contains

!*******************************************************************************

subroutine brn_init(n, nblks, mth, f, e)
    !! Performs initial setup.

    integer, intent(in) :: n
        !! Size of the mobility matrix.
    integer, intent(in) :: nblks
        !! Number of **B**._d_**W** vectors to generate for the same mobility matrix.
        !! `1 <= nblks < n`.
    character(4), intent(in) :: mth
        !! Method for calculating the Brownian terms. `mth = 'CHOL'` for
        !! Cholesky decomposition; `mth = 'LANC'` for KSP-based method.
    integer, intent(in), optional :: f
        !! For KSP-based method, maximum number of iterations.
        !! Must be present if `mth = 'LANC'`. `f` must be less than `n`.
    real(rp), intent(in), optional :: e
        !! For KSP-based method, error threshold for convergence.
        !! Must be present if `mth = 'LANC'`.

    sizm = n; s = nblks; meth = mth

    if (meth == 'CHOL') then
        !Nothing to do here.
    else if (meth == 'LANC') then
        dimk_max = max(dimk_min, f) + 1
        !Adding 1 to ensure dimk_max > dimk_min
        ethres = e

        allocate( bdw_old(sizm, s) )
        allocate( lncv(sizm,s*dimk_max) )
        allocate( eigvlh(s*dimk_max) )
        allocate( eigvch(s*dimk_max,s*dimk_max) )
        allocate( w(sizm,s))
        allocate( tmp(s*dimk_max,2*s))
        if (s == 1) then
            allocate( h_d(dimk_max) )
            allocate( h_sd(dimk_max) )
        else
            allocate( tau(s))
            allocate( matr(s,s))
            allocate( h_bd(s,s*dimk_max) )
            allocate( h_bsd(s,s*dimk_max) )
            allocate( h_bnd(2*s,s*dimk_max))
        end if
    end if

    end subroutine

!*******************************************************************************

subroutine brn_finish()
    !! Performs cleanup.

    if (allocated(bdw_old)) deallocate(bdw_old)
    if (allocated(lncv))    deallocate(lncv)
    if (allocated(eigvlh))  deallocate(eigvlh)
    if (allocated(eigvch))  deallocate(eigvch)
    if (allocated(w))       deallocate(w)
    if (allocated(tmp))     deallocate(tmp)

    if (allocated(h_d))     deallocate(h_d)
    if (allocated(h_sd))    deallocate(h_sd)
    if (allocated(tau))     deallocate(tau)
    if (allocated(matr))    deallocate(matr)
    if (allocated(h_bd))    deallocate(h_bd)
    if (allocated(h_bsd))   deallocate(h_bsd)
    if (allocated(h_bnd))   deallocate(h_bnd)

    if (allocated(work))    deallocate(work)
    if (allocated(iwork))   deallocate(iwork)

    end subroutine

!*******************************************************************************

subroutine brn_calc_bdw(mob, bdw, ierr, lconv, f)
    !! Main driver routine for calculating **B**._d_**W**.

    real(rp), dimension(:,:), intent(in out) :: mob
        !! (`sizm`,`sizm`) symmetric positive definite matrix.
        !! On _entry_, contains the mobility matrix.  On _return_, if `meth = 'CHOL'`,
        !! the upper triangular part is overwritten with the result of Cholesky
        !! decomposition.  The strictly lower triangular part is left intact.
    real(rp), dimension(:,:), intent(in out) :: bdw
        !! (`sizm`,`s`) matrix.
        !! On _entry_, contains `s` column vectors drawn from standard normal
        !! distribution. On _return_, the `s` columns are overwritten with the
        !! result of **B**.d**W**.
    integer, intent(out) :: ierr
        !! Error flag.
    logical, intent(out), optional :: lconv
        !! If `meth = 'LANC'`, returns *true* if converged, *false* otherwise.
    integer, intent(out), optional :: f
        !! If `meth = 'LANC'`, the number of iterations performed.
    integer :: f_
    logical :: lconv_

    if (meth == 'CHOL') then
        call calc_bdw_cholesky(mob, bdw, ierr)
    else if (meth == 'LANC') then
        if (s == 1) then
            call calc_bdw_lanc(mob, bdw, lconv_, f_, ierr)
        else
            call calc_bdw_blanc(mob, bdw, lconv_, f_, ierr)
        end if
    end if
    if (present(lconv)) lconv = lconv_
    if (present(f)) f = f_

    end subroutine

!*******************************************************************************

subroutine calc_bdw_lanc(mob, bdw, lconv, f, ierr)
 !! Implements Lanczos algorithm for calculating **B**._d_**W**.

    real(rp), dimension(:,:), intent(in) :: mob
        !! (`sizm`,`sizm`) symmetric positive definite matrix.
    real(rp), dimension(:,:), intent(in out) :: bdw
        !! (`sizm`,1) array.
        !! On _entry_, contains a vector drawn from standard normal
        !! distribution. On _return_, is overwritten with the result of
        !! **B**._d_**W**.
    logical, intent(out) :: lconv
        !! Returns *true* if converged, *false* otherwise.
    integer, intent(out) :: f
        !! The number of iterations performed.
    integer, intent(out) :: ierr
        !! Error flag.
    integer :: j, info, lwork, liwork
    real(rp), dimension(1) :: qwork  !Size 1 array for workspace query.
    integer, dimension(1)  :: qiwork !Size 1 array for workspace query.
    real(rp) :: normz, err
    character(len=256) :: msg

    lconv = .false.; ierr = 0; f = 0
    lncv = 0.0_rp; h_d = 0.0_rp; h_sd = 0.0_rp
    eigvlh = 0.0_rp; eigvch = 0.0_rp
    w = 0.0_rp; tmp = 0.0_rp; bdw_old = 0.0_rp

    !Workspace query
    if ((.not. allocated(work)) .or. (.not. allocated(iwork))) then
        call dstevd('V', dimk_max, eigvlh, tmp(1:dimk_max,1), eigvch, dimk_max, &
                    qwork, -1, qiwork, -1, info)
        if (info /= 0) then
            write(msg,'(a,i0,a)') '<calc_bdw_lanc> dstevd err = ', info, &
                ' on workspace query'
            call logger%log_msg(msg)
            ierr = 1; return
        end if
        lwork = int(qwork(1)); liwork = qiwork(1)
        allocate( work(lwork) ); allocate( iwork(liwork) )
    end if

    !Lanczos process
    normz = norm2(bdw(:,1))
    lncv(:,1) = bdw(:,1)/normz

    do j = 1, dimk_max
        f = f + 1 !Iteration count
        call dsymv('L', sizm, 1.0_rp, mob, sizm, lncv(:,j), 1, 0.0_rp, w(:,1), 1)
        if (j > 1) then
            w(:,1) = w(:,1) - h_sd(j-1)*lncv(:,j-1)
        end if
        h_d(j) = dot_product(w(:,1), lncv(:,j))

        if (j < dimk_max) then
            w(:,1) = w(:,1) - h_d(j)*lncv(:,j)
            h_sd(j) = norm2(w(:,1))
            lncv(:,j+1) = w(:,1)/h_sd(j)
        end if

        !Calculate B.dW and check for convergence
        if (j >= dimk_min) then
            eigvlh(1:j) = h_d(1:j)
            tmp(1:j,1) = h_sd(1:j)

            !Eigen decomposition of H = P * d * P^T
            !eigvlh[1:j] <- d; eigvch[1:j,1:j] <- P
            call dstevd('V', j, eigvlh(1:j), tmp(1:j,1), eigvch, dimk_max, &
                    work, size(work), iwork, size(iwork), info)
            if (info /= 0) then
                write(msg,'(a,i0,a,i0)') '<calc_bdw_lanc> dstevd err = ', info, &
                    ' on iteration ', j
                call logger%log_msg(msg)
                ierr = 1; return
            end if

            !eigvlh(1:j) <- d^(1/2)
            eigvlh(1:j) = sqrt(eigvlh(1:j))

            !tmp[1:j,1] <- d^(1/2) * P^T * e_1, where e_1 if the first column of
            !an identity matrix of size j.
            tmp(1:j,1) = eigvch(1,1:j)
            tmp(1:j,1) = eigvlh(1:j)*tmp(1:j,1)

            !tmp[1:j,2] <- P * tmp[1:j,1]
            call dgemv('N', j, j, 1.0_rp, eigvch, dimk_max, tmp(1:j,1), 1, &
                        0.0_rp, tmp(1:j,2), 1)

            !bdw <- normz * lncv[:,1:j] * tmp[1:j,2]
            call dgemv('N', sizm, j, normz, lncv, sizm, tmp(1:j,2), 1, &
                        0.0_rp, bdw, 1)

            !Error calculation for j > dimk_min. For j = dimk_min just save
            !bdw for error calculation in the next iteration.
            if (j > dimk_min) then
                err = norm2(bdw(:,1) - bdw_old(:,1))/norm2(bdw_old(:,1))
                if (err <= ethres) then
                    lconv = .true.; exit
                end if
            end if
            bdw_old = bdw
        end if
    end do

    end subroutine

!*******************************************************************************

subroutine calc_bdw_blanc(mob, bdw, lconv, f, ierr)
    !! Implements block Lanczos algorithm for calculating **B**._d_**W**.

    real(rp), dimension(:,:), intent(in) :: mob
        !! (`sizm`,`sizm`) symmetric positive definite matrix.
    real(rp), dimension(:,:), intent(in out) :: bdw
        !! (`sizm`,`s`) matrix.
        !! On _entry_, contains `s` column vectors drawn from standard normal
        !! distribution. On _return_, the `s` columns are overwritten with the
        !! result of **B**._d_**W**.
    logical, intent(out) :: lconv
        !! Returns *true* if converged, *false* otherwise.
    integer, intent(out) :: f
        !! The number of iterations performed.
    integer, intent(out) :: ierr
        !! Error flag.
    real(rp) :: err
    integer :: j, jb, irow, jcol
    integer :: jgbeg, jgend, igbeg, ig, jg
    integer :: info, lwork, liwork
    real(rp), dimension(1) :: qwork
    integer, dimension(1)  :: qiwork
    character(len=256) :: msg

    lconv = .false.; ierr = 0; f = 0
    lncv = 0.0_rp;  h_bd = 0.0_rp; h_bsd = 0.0_rp
    eigvlh = 0.0_rp; eigvch = 0.0_rp
    w = 0.0_rp; tmp = 0.0_rp; bdw_old = 0.0_rp
    tau = 0.0_rp; matr = 0.0_rp; h_bnd = 0.0_rp

    !Workspace query
    if (.not. allocated(work)) then
        call dgeqp3(sizm, s, bdw, sizm, qiwork, tau, qwork, -1, info)
        if (info /= 0) then
            write(msg,'(a,i0,a)') '<calc_bdw_blanc> dgeqp3 err = ', info, &
                ' on workspace query'
            call logger%log_msg(msg)
            ierr = 1; return
        end if
        lwork = int( qwork(1) )

        call dorgqr(sizm, s, s, bdw, sizm, tau, qwork, -1, info)
        if (info /= 0) then
            write(msg,'(a,i0,a)') '<calc_bdw_blanc> dorgqr err = ', info, &
                ' on workspace query'
            call logger%log_msg(msg)
            ierr = 1; return
        end if
        lwork = max( lwork, int(qwork(1)) )

        call dsbevd('V', 'L', dimk_max*s, 2*s-1, h_bnd, 2*s, &
            eigvlh, eigvch, s*dimk_max, qwork, -1, qiwork, -1, info)
        if (info /= 0) then
            write(msg,'(a,i0,a)') '<calc_bdw_blanc> dsbevd err = ', info, &
                ' on workspace query'
            call logger%log_msg(msg)
            ierr = 1; return
        end if
        lwork = max( lwork, int(qwork(1)) )
        liwork = qiwork(1)

        allocate(work(lwork)); allocate(iwork(liwork))
    end if

    !Lanczos process
    !Reduced QR factorization of bdw with pivoting. The results overwrite bdw.
    iwork = 0; qwork = 0.0_rp
    call dgeqp3(sizm, s, bdw, sizm, iwork, tau, work, size(work), info)
    if (info /= 0) then
       write(msg,'(a,i0,a)') '<calc_bdw_blanc> dgeqp3 err = ', info, &
           ' on iteration 0'
       call logger%log_msg(msg)
       ierr = 1; return
    end if

    !Extract the (s,s) permuted upper triangular matrix R and store it in matr.
    do jcol = 1, s
        matr(1:jcol, iwork(jcol)) = bdw(1:jcol, jcol)
    end do

    !Extract the (sizm,s) matrix Q and store it in lncv[:,1:s].
    call dorgqr(sizm, s, s, bdw, sizm, tau, work, size(work), info)
    if (info /= 0) then
        write(msg,'(a,i0,a)') '<calc_bdw_blanc> dorgqr err = ', info, &
            ' on iteration 0'
        call logger%log_msg(msg)
        ierr = 1; return
    end if
    lncv(:,1:s) = bdw

    do j = 1, dimk_max
        f = f + 1 !Iteration count
        !W <- mob * V_j
        jgbeg = (j-1)*s+1; jgend = j*s
        call dsymm('L', 'L', sizm, s, 1.0_rp, mob, sizm, &
                    lncv(:,jgbeg:jgend), sizm, 0.0_rp, w, sizm )

        if (j > 1) then
            !W -> W - V_(j-1) * H_(j-1,j)
            !   = W - V_(j-1) * H_(j,j-1)^T, using the subdiagonal block
            jgbeg = (j-2)*s+1; jgend = (j-1)*s
            call dgemm('N', 'T', sizm, s, s, -1.0_rp, lncv(:,jgbeg:jgend), sizm, &
                        h_bsd(:,jgbeg:jgend), s, 1.0_rp, w, sizm)
        end if

        !H_(j,j) <- V_j^T * W
        jgbeg = (j-1)*s+1; jgend = j*s
        call dgemm('T', 'N', s, s, sizm, 1.0_rp, lncv(:,jgbeg:jgend), sizm, &
                    w, sizm, 0.0_rp, h_bd(:,jgbeg:jgend), s)

        if (j < dimk_max) then
            !W -> W - V_(j) * H_(j,j)
            !Note: H_(j,j) is symmetric.
            jgbeg = (j-1)*s+1; jgend = j*s
            call dsymm('R', 'L', sizm, s, -1.0_rp, h_bd(:,jgbeg:jgend), &
                        s, lncv(:,jgbeg:jgend), sizm, 1.0_rp, w, sizm)

            !Reduced QR factorization of w.
            iwork = 0
            call dgeqp3(sizm, s, w, sizm, iwork, tau, work, size(work), info)
            if (info /= 0) then
                write(msg,'(a,i0,a,i0)') '<calc_bdw_blanc> dgeqp3 err = ', info, &
                    ' on iteration ', j
                call logger%log_msg(msg)
                ierr = 1; return
            end if

            !Extract the (s,s) permuted upper triangular matrix R and store
            !it in H_(j+1,j).
            do jcol = 1, s
                h_bsd(1:jcol, (j-1)*s+iwork(jcol)) = w(1:jcol, jcol)
            end do

            !Extract the (sizm,s) matrix Q and store it in V_(j+1).
            call dorgqr(sizm, s, s, w, sizm, tau, work, size(work), info)
            if (info /= 0) then
                write(msg,'(a,i0,a,i0)') '<calc_bdw_blanc> dorgqr err = ', info, &
                    ' on iteration ', j
                call logger%log_msg(msg)
                ierr = 1; return
            end if
            jgbeg = j*s+1; jgend = (j+1)*s
            lncv(:,jgbeg:jgend) = w
        end if

        !Calculate B.dW and check for convergence
        if (j >= dimk_min) then
            jgbeg = (j-1)*s+1; jgend = j*s
            !Create matrix H in band storage format, in preparation for eigen
            !decomposition with symmetric band matrix routine.
            h_bnd = 0.0_rp
            do jb = 1, j
                jgbeg = (jb-1)*s; igbeg = jgbeg
                do jcol = 1,s
                    jg = jgbeg + jcol
                    do irow = jcol,s
                        ig = igbeg + irow
                        h_bnd(ig-jg+1,jg) = h_bd(irow, jg)
                    end do
                end do
            end do

            do jb = 1, (j-1)
                jgbeg = (jb-1)*s; igbeg = jb*s
                do jcol = 1,s
                    jg = jgbeg + jcol
                    do irow = 1,s
                        ig = igbeg + irow
                        h_bnd(ig-jg+1,jg) = h_bsd(irow, jg)
                    end do
                end do
            end do

            !Eigen decomposition of H = P * d * P^T
            !eigvlh <- d; eigvch <- P
            call dsbevd('V', 'L', j*s, 2*s-1, h_bnd(:,1:j*s), 2*s, eigvlh, &
                        eigvch, s*dimk_max, work, size(work), iwork, &
                        size(iwork), info)
            if (info /= 0) then
                write(msg,'(a,i0,a,i0)') '<calc_bdw_blanc> dsbevd err = ', info, &
                    ' on iteration ', j
                call logger%log_msg(msg)
                ierr = 1; return
            end if

            !Square root of the eigen values
            eigvlh(1:j*s) = sqrt(eigvlh(1:j*s))

            !tmp[1:j*s,1:s] <- eigvch[1:s,1:j*s]^T * matr
            call dgemm('T', 'N', j*s, s, s, 1.0_rp, eigvch, s*dimk_max, &
                        matr, s, 0.0_rp, tmp(:,1:s), s*dimk_max)

            !tmp[1:j*s,1:s] <- eigvlh[1:j*s] * tmp[1:j*s,1:s]
            do jcol = 1, s
                tmp(1:j*s,jcol) = eigvlh(1:j*s)*tmp(1:j*s,jcol)
            end do

            !tmp[1:j*s,s+1:2*s] <- eigvch[1:j*s,1:j*s] * tmp[1:j*s,1:s]
            call dgemm('N', 'N', j*s, s, j*s, 1.0_rp, eigvch, s*dimk_max, &
                        tmp(:,1:s), s*dimk_max, 0.0_rp, tmp(:,s+1:2*s), s*dimk_max)

            !bdw <- lncv[:,1:j*s] * tmp[1:j*s,s+1:2*s]
            call dgemm('N', 'N', sizm, s, j*s, 1.0_rp, lncv, sizm, &
                    tmp(:,s+1:2*s), s*dimk_max, 0.0_rp, bdw, sizm)

            !Error calculation for j > dimk_min. For j == dimk_min just save
            !bdw for error calculation in the next iteration. Using 1-norm as
            !the matrix norm here.
            if (j > dimk_min) then
                err = maxval(sum(abs(bdw-bdw_old), 1)) &
                    / maxval(sum(abs(bdw_old), 1))
                if (err <= ethres) then
                    lconv = .true.; f = j
                    exit
                end if
            end if
            bdw_old = bdw
        end if
    end do

    end subroutine

!******************************************************************************

subroutine calc_bdw_cholesky(mob, bdw, ierr)
    !! Calculates **B**._d_**W** using Cholesky decomposition.

    real(rp), dimension(:,:), intent(in out) :: mob
        !! (`sizm`,`sizm`) symmetric positive definite matrix.
        !! On _entry_, contains the mobility matrix.  On _return_,
        !! the upper triangular part is overwritten with the result of Cholesky
        !! decomposition.  The strictly lower triangular part is left intact.
    real(rp), dimension(:,:), intent(in out) :: bdw
        !! (`sizm`,`s`) matrix.
        !! On _entry_, contains `s` column vectors drawn from standard normal
        !! distribution. On _return_, the `s` columns are overwritten with the
        !! result of **B**._d_**W**.
    integer, intent(out) :: ierr
        !! Error flag.
    integer :: info
    character(len=256) :: msg

    ierr = 0

    !Cholesky decomposition: mob = U^T * U. The upper triangular part of mob is
    !overwritten with U. The strictly lower triangular part of mob is not
    !accessed.
    call dpotrf('U', sizm, mob, sizm, info)
    if (info /= 0) then
        write(msg,'(a,i0)') '<calc_bdw_cholesky> dpotrf err = ', info
        call logger%log_msg(msg)
        ierr = 1; return
    end if

    !Product of U (stored in the upper triangular part of mob) with each of the
    !random vectors: bdw = U*bdw
    if (s == 1) then
        call dtrmv('U', 'N', 'N', sizm, mob, sizm, bdw(:,1), 1)
    else
        call dtrmm('L', 'U', 'N', 'N', sizm, s, 1.0_rp, mob, sizm, bdw, sizm)
    end if

    end subroutine

!*******************************************************************************

subroutine brn_calc_dw(dw)
    !! Calculates standard normally distributed random vectors.

    real(rp), dimension(:,:), target, intent(out) :: dw
        !! (`n`,`m`) array.
    real(rp), dimension(:), pointer :: vec_dw
    type(c_ptr) :: loc_dw
    integer :: n, m

    n = size(dw,1); m = size(dw,2)
    dw = 0.0_rp
    loc_dw = c_loc(dw)
    call c_f_pointer(loc_dw, vec_dw, [n*m])
    call get_rv_gaussian(0.0_rp, 1.0_rp, vec_dw, 1000000)

    end subroutine

!*******************************************************************************

subroutine calc_bdw_lanc_sor(mob, bdw, lconv, f, ierr)

    real(rp), dimension(:,:), intent(in) :: mob
        !! (`sizm`,`sizm`) symmetric positive definite matrix.
    real(rp), dimension(:,:), intent(in out) :: bdw
        !! (`sizm`,1) array.
        !! On _entry_, contains a vector drawn from standard normal
        !! distribution. On _return_, is overwritten with the result of
        !! **B**.d**W**.
    logical, intent(out) :: lconv
        !! Returns *true* if converged, *false* otherwise.
    integer, intent(out) :: f
        !! The number of iterations performed.
    integer, intent(out) :: ierr
        !! Error flag.
    integer :: j, info, lwork, liwork, k
    real(rp), dimension(1) :: qwork  !Size 1 array for workspace query.
    integer, dimension(1)  :: qiwork !Size 1 array for workspace query.
    real(rp), dimension(dimk_max) :: errbnd
    real(rp), dimension(sizm) :: ritzv
    real(rp) :: normz, err, normm
    character(len=256) :: msg

    lconv = .false.; ierr = 0; f = 0
    tmp = 0.0_rp; eigvlh = 0.0_rp; eigvch = 0.0_rp
    h_d = 0.0_rp; h_sd = 0.0_rp
    bdw_old = 0.0_rp; lncv = 0.0_rp; w = 0.0_rp

    !Workspace query
    if ((.not. allocated(work)) .or. (.not. allocated(iwork))) then
        call dstevd('V', dimk_max, eigvlh, tmp(1:dimk_max,1), eigvch, dimk_max, &
                    qwork, -1, qiwork, -1, info)
        if (info /= 0) then
            write(msg,'(a,i0,a)') '<calc_bdw_lanc_sor> dstevd err = ', info, &
                ' on workspace query'
            call logger%log_msg(msg)
            ierr = 1; return
        end if
        lwork = int(qwork(1)); liwork = qiwork(1)
        allocate( work(lwork) ); allocate( iwork(liwork) )
    end if

    !Lanczos process
    normz = norm2(bdw(:,1))
    normm = maxval(sum(abs(mob),1))
    lncv(:,1) = bdw(:,1)/normz

    do j = 1, dimk_max
        f = f + 1 !Iteration count
        call dsymv('L', sizm, 1.0_rp, mob, sizm, lncv(:,j), 1, 0.0_rp, w(:,1), 1)
        if (j > 1) then
            w(:,1) = w(:,1) - h_sd(j-1)*lncv(:,j-1)
        end if
        h_d(j) = dot_product(w(:,1), lncv(:,j))

        if (j < dimk_max) then
            w(:,1) = w(:,1) - h_d(j)*lncv(:,j)
            do k = 1, j
                if (errbnd(k) < sqrt(epsilon(1.0_rp)*normm)) then
                    call dgemv('N', sizm, j, 1.0_rp, lncv, sizm, eigvch(:,k), 1, &
                                0.0_rp, ritzv, 1)
                    w(:,1) = w(:,1) - dot_product(ritzv,w(:,1))*ritzv
                end if
            end do
            h_sd(j) = norm2(w(:,1))
            lncv(:,j+1) = w(:,1)/h_sd(j)
        end if

        !Compute eigenvalues, eigenvectors and error bounds for H
        if (j > 1) then
            eigvlh(1:j) = h_d(1:j)
            tmp(1:j,1) = h_sd(1:j)

            !Eigen decomposition of H = P * d * P^T
            !eigvlh[1:j] <- d; eigvch[1:j,1:j] <- P
            call dstevd('V', j, eigvlh(1:j), tmp(1:j,1), eigvch, dimk_max, &
                    work, size(work), iwork, size(iwork), info)
            if (info /= 0) then
                write(msg,'(a,i0,a,i0)') '<calc_bdw_lanc_sor> dstevd err = ', info, &
                    ' on iteration ', j
                call logger%log_msg(msg)
                ierr = 1; return
            end if
            errbnd(1:j) = abs(h_sd(j))*eigvch(j,1:j)
        end if

        !Calculate B.dW and check for convergence
        if (j >= dimk_min) then
            !eigvlh(1:j) <- d^(1/2)
            eigvlh(1:j) = sqrt(eigvlh(1:j))

            !tmp[1:j,1] <- d^(1/2) * P^T * e_1, where e_1 if the first column of
            !an identity matrix of size j.
            tmp(1:j,1) = eigvch(1,1:j)
            tmp(1:j,1) = eigvlh(1:j)*tmp(1:j,1)

            !tmp[1:j,2] <- P * tmp[1:j,1]
            call dgemv('N', j, j, 1.0_rp, eigvch, dimk_max, tmp(1:j,1), 1, &
                        0.0_rp, tmp(1:j,2), 1)

            !bdw <- normz * lncv[:,1:j] * tmp[1:j,2]
            call dgemv('N', sizm, j, normz, lncv, sizm, tmp(1:j,2), 1, &
                        0.0_rp, bdw, 1)

            !Error calculation for j > dimk_min. For j = dimk_min just save
            !bdw for error calculation in the next iteration.
            if (j > dimk_min) then
                err = norm2(bdw(:,1) - bdw_old(:,1))/norm2(bdw_old(:,1))
                !write(*,*) j, 'err = ', err
                if (err <= ethres) then
                    lconv = .true.
                    exit
                end if
            end if
            bdw_old = bdw
        end if
    end do

    end subroutine

!*******************************************************************************

end module brown_m


Subroutine hijwds(ia, idh, xhigh)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /wood/r, d, fnorm, w
  Dimension iaa(20), rr(20), dd(20), ww(20)
  External rwdsax, wdsax
  Save
  Data iaa/2, 4, 12, 16, 27, 32, 40, 56, 63, 93, 184, 197, 208, 7*0./
  Data rr/0.01, .964, 2.355, 2.608, 2.84, 3.458, 3.766, 3.971, 4.214, 4.87, 6.51, 6.38, 6.624, 7*0./
  Data dd/0.5882, .322, .522, .513, .569, .61, .586, .5935, .586, .573, .535, .535, .549, 7*0./
  Data ww/0.0, .517, -0.149, -0.051, 0., -0.208, -0.161, 13*0./
  a = ia
  d = 0.54
  r = 1.19*a**(1./3.) - 1.61*a**(-1./3.)
  w = 0.
  Do i = 1, 13
    If (ia==iaa(i)) Then
      r = rr(i)
      d = dd(i)
      w = ww(i)
    End If
  End Do
  fnorm = 1.0
  xlow = 0.
  xhigh = r + 12.*d
  If (w<-0.01) Then
    If (xhigh>r/sqrt(abs(w))) xhigh = r/sqrt(abs(w))
  End If
  fgaus = gauss1(rwdsax, xlow, xhigh, 0.001)
  fnorm = 1./fgaus
  If (idh==1) Then
    hint1(72) = r
    hint1(73) = d
    hint1(74) = w
    hint1(75) = fnorm/4.0/hipr1(40)
  Else If (idh==2) Then
    hint1(76) = r
    hint1(77) = d
    hint1(78) = w
    hint1(79) = fnorm/4.0/hipr1(40)
  End If
  Call hifun(idh, xlow, xhigh, rwdsax)
  Return
End Subroutine hijwds


      SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To estimate the system order, based on the singular values of the
C     relevant part of the triangular factor of the concatenated block
C     Hankel matrices.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     CTRL    CHARACTER*1
C             Specifies whether or not the user's confirmation of the
C             system order estimate is desired, as follows:
C             = 'C':  user's confirmation;
C             = 'N':  no confirmation.
C             If  CTRL = 'C',  a reverse communication routine,  IB01OY,
C             is called, and, after inspecting the singular values and
C             system order estimate,  n,  the user may accept  n  or set
C             a new value.
C             IB01OY  is not called by the routine if CTRL = 'N'.
C
C     Input/Output Parameters
C
C     NOBR    (input) INTEGER
C             The number of block rows,  s,  in the processed input and
C             output block Hankel matrices.  NOBR > 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     SV      (input) DOUBLE PRECISION array, dimension ( L*NOBR )
C             The singular values of the relevant part of the triangular
C             factor from the QR factorization of the concatenated block
C             Hankel matrices.
C
C     N       (output) INTEGER
C             The estimated order of the system.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             Absolute tolerance used for determining an estimate of
C             the system order. If  TOL >= 0,  the estimate is
C             indicated by the index of the last singular value greater
C             than or equal to  TOL.  (Singular values less than  TOL
C             are considered as zero.) When  TOL = 0,  an internally
C             computed default value,  TOL = NOBR*EPS*SV(1),  is used,
C             where  SV(1)  is the maximal singular value, and  EPS  is
C             the relative machine precision (see LAPACK Library routine
C             DLAMCH). When  TOL < 0,  the estimate is indicated by the
C             index of the singular value that has the largest
C             logarithmic gap to its successor.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 3:  all singular values were exactly zero, hence  N = 0.
C                   (Both input and output were identically zero.)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The singular values are compared to the given, or default TOL, and
C     the estimated order  n  is returned, possibly after user's
C     confirmation.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999.
C
C     REVISIONS
C
C     August 2000.
C
C     KEYWORDS
C
C     Identification methods, multivariable systems, singular value
C     decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, N, NOBR
      CHARACTER          CTRL
C     .. Array Arguments ..
      DOUBLE PRECISION   SV(*)
C     .. Local Scalars ..
      DOUBLE PRECISION   GAP, RNRM, TOLL
      INTEGER            I, IERR, LNOBR
      LOGICAL            CONTRL
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL           IB01OY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, LOG10
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      CONTRL = LSAME( CTRL, 'C' )
      LNOBR  = L*NOBR
      IWARN  = 0
      INFO   = 0
      IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( NOBR.LE.0 ) THEN
         INFO = -2
      ELSE IF( L.LE.0 ) THEN
         INFO = -3
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB01OD', -INFO )
         RETURN
      END IF
C
C     Set  TOL  if necessay.
C
      TOLL = TOL
      IF ( TOLL.EQ.ZERO)
     $   TOLL = DLAMCH( 'Precision' )*SV(1)*DBLE( NOBR )
C
C     Obtain the system order.
C
      N = 0
      IF ( SV(1).NE.ZERO ) THEN
         N = NOBR
         IF ( TOLL.GE.ZERO) THEN
C
C           Estimate  n  based on the tolerance  TOLL.
C
            DO 10 I = 1, NOBR - 1
               IF ( SV(I+1).LT.TOLL ) THEN
                  N = I
                  GO TO 30
               END IF
   10       CONTINUE
         ELSE
C
C           Estimate  n  based on the largest logarithmic gap between
C           two consecutive singular values.
C
            GAP = ZERO
            DO 20 I = 1, NOBR - 1
               RNRM = SV(I+1)
               IF ( RNRM.NE.ZERO ) THEN
                  RNRM = LOG10( SV(I) ) - LOG10( RNRM )
                  IF ( RNRM.GT.GAP ) THEN
                     GAP = RNRM
                     N = I
                  END IF
               ELSE
                  IF ( GAP.EQ.ZERO )
     $               N = I
                  GO TO 30
               END IF
   20       CONTINUE
         END IF
      END IF
C
   30 CONTINUE
      IF ( N.EQ.0 ) THEN
C
C        Return with  N = 0  if all singular values are zero.
C
         IWARN = 3
         RETURN
      END IF
C
      IF ( CONTRL ) THEN
C
C        Ask confirmation of the system order.
C
         CALL IB01OY( LNOBR, NOBR-1, N, SV, IERR )
      END IF
      RETURN
C
C *** Last line of IB01OD ***
      END


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! The ODE Function of Chemical Model File
!
! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : kpp_achem_gas_Function.f90
! Time                 : Thu Jun 11 11:33:46 2015
! Working directory    : /gpfsm/dnb32/adarmeno/models/geos-5/heracles-UNSTABLE-DEV_MICROPHYSICS/src/GEOSgcs_GridComp/GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphV
! Equation file        : kpp_achem_gas.kpp
! Output root filename : kpp_achem_gas
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE kpp_achem_gas_Function

  USE kpp_achem_gas_Parameters
  IMPLICIT NONE

! A - Rate for each equation
  REAL(kind=dp) :: A(NREACT)

CONTAINS

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Fun - time derivatives of variables - Agregate form
!   Arguments :
!      V         - Concentrations of variable species (local)
!      F         - Concentrations of fixed species (local)
!      RCT       - Rate constants (local)
!      Vdot      - Time derivative of variable species concentrations
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Fun ( V, F, RCT, Vdot )

! V - Concentrations of variable species (local)
  REAL(kind=dp) :: V(NVAR)
! F - Concentrations of fixed species (local)
  REAL(kind=dp) :: F(NFIX)
! RCT - Rate constants (local)
  REAL(kind=dp) :: RCT(NREACT)
! Vdot - Time derivative of variable species concentrations
  REAL(kind=dp) :: Vdot(NVAR)

! Computation of equation rates
  A(1) = RCT(1)*V(1)*F(2)
  A(2) = RCT(2)*V(1)*F(2)
  A(3) = RCT(3)*V(1)*F(1)
  A(4) = RCT(4)*V(2)*F(2)
  A(5) = RCT(5)*V(3)*F(2)

! Aggregate function
  Vdot(1) = -A(1)-A(2)-A(3)
  Vdot(2) = A(1)+0.75*A(2)+A(3)-A(4)
  Vdot(3) = -A(5)
  Vdot(4) = 0.25*A(2)
  Vdot(5) = A(4)

END SUBROUTINE Fun

! End of Fun function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

END MODULE kpp_achem_gas_Function


      SUBROUTINE NF01BS( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS,
     $                   GNORM, IPVT, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the QR factorization of the Jacobian matrix J, as
C     received in compressed form from SLICOT Library routine NF01BD,
C
C            /  dy(1)/dwb(1)  |  dy(1)/ dtheta  \
C       Jc = |       :        |       :         | ,
C            \  dy(L)/dwb(L)  |  dy(L)/ dtheta  /
C
C     and to apply the transformation Q on the error vector e (in-situ).
C     The factorization is J*P = Q*R, where Q is a matrix with
C     orthogonal columns, P a permutation matrix, and R an upper
C     trapezoidal matrix with diagonal elements of nonincreasing
C     magnitude for each block column (see below). The 1-norm of the
C     scaled gradient is also returned.
C
C     Actually, the Jacobian J has the block form
C
C       dy(1)/dwb(1)       0         .....       0        dy(1)/dtheta
C            0        dy(2)/dwb(2)   .....       0        dy(2)/dtheta
C          .....         .....       .....     .....         .....
C            0           .....         0    dy(L)/dwb(L)  dy(L)/dtheta
C
C     but the zero blocks are omitted. The diagonal blocks have the
C     same size and correspond to the nonlinear part. The last block
C     column corresponds to the linear part. It is assumed that the
C     Jacobian matrix has at least as many rows as columns. The linear
C     or nonlinear parts can be empty. If L <= 1, the Jacobian is
C     represented as a full matrix.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of columns of the Jacobian matrix J.
C             N = BN*BSN + ST >= 0.  (See parameter description below.)
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters describing the structure of the
C             matrix J, as follows:
C             IPAR(1) must contain ST, the number of parameters
C                     corresponding to the linear part.  ST >= 0.
C             IPAR(2) must contain BN, the number of blocks, BN = L,
C                     for the parameters corresponding to the nonlinear
C                     part.  BN >= 0.
C             IPAR(3) must contain BSM, the number of rows of the blocks
C                     J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the
C                     number of rows of the matrix J, if BN <= 1.
C                     BN*BSM >= N, if BN > 0;
C                     BSM >= N,    if BN = 0.
C             IPAR(4) must contain BSN, the number of columns of the
C                     blocks J_k, k = 1:BN.  BSN >= 0.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 4.
C
C     FNORM   (input) DOUBLE PRECISION
C             The Euclidean norm of the vector e.  FNORM >= 0.
C
C     J       (input/output) DOUBLE PRECISION array, dimension (LDJ, NC)
C             where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
C             On entry, the leading NR-by-NC part of this array must
C             contain the (compressed) representation (Jc) of the
C             Jacobian matrix J, where NR = BSM if BN <= 1, and
C             NR = BN*BSM, if BN > 1.
C             On exit, the leading N-by-NC part of this array contains
C             a (compressed) representation of the upper triangular
C             factor R of the Jacobian matrix. The matrix R has the same
C             structure as the Jacobian matrix J, but with an additional
C             diagonal block. Note that for efficiency of the later
C             calculations, the matrix R is delivered with the leading
C             dimension MAX(1,N), possibly much smaller than the value
C             of LDJ on entry.
C
C     LDJ     (input/output) INTEGER
C             The leading dimension of array J.
C             On entry, LDJ >= MAX(1,NR).
C             On exit,  LDJ >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (NR)
C             On entry, this array contains the vector e,
C             e = vec( Y - y ), where Y is set of output samples, and
C             vec denotes the concatenation of the columns of a matrix.
C             On exit, this array contains the updated vector Z*Q'*e,
C             where Z is the block row permutation matrix used in the
C             QR factorization of J (see METHOD).
C
C     JNORMS  (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the Euclidean norms of the columns
C             of the Jacobian matrix, considered in the initial order.
C
C     GNORM   (output) DOUBLE PRECISION
C             If FNORM > 0, the 1-norm of the scaled vector J'*e/FNORM,
C             with each element i further divided by JNORMS(i) (if
C             JNORMS(i) is nonzero).
C             If FNORM = 0, the returned value of GNORM is 0.
C
C     IPVT    (output) INTEGER array, dimension (N)
C             This array defines the permutation matrix P such that
C             J*P = Q*R. Column j of P is column IPVT(j) of the identity
C             matrix.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1,      if N = 0 or BN <= 1 and BSM = N = 1;
C                               otherwise,
C             LDWORK >= 4*N+1,  if BN <= 1 or  BSN = 0;
C             LDWORK >= JWORK,  if BN >  1 and BSN > 0, where JWORK is
C                               given by the following procedure:
C              JWORK  = BSN + MAX(3*BSN+1,ST);
C              JWORK  = MAX(JWORK,4*ST+1),         if BSM > BSN;
C              JWORK  = MAX(JWORK,(BSM-BSN)*(BN-1)),
C                                                  if BSN < BSM < 2*BSN.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     A QR factorization with column pivoting of the matrix J is
C     computed, J*P = Q*R.
C
C     If l = L > 1, the R factor of the QR factorization has the same
C     structure as the Jacobian, but with an additional diagonal block.
C     Denote
C
C         /   J_1    0    ..   0   |  L_1  \
C         |    0    J_2   ..   0   |  L_2  |
C     J = |    :     :    ..   :   |   :   | .
C         |    :     :    ..   :   |   :   |
C         \    0     0    ..  J_l  |  L_l  /
C
C     The algorithm consists in two phases. In the first phase, the
C     algorithm uses QR factorizations with column pivoting for each
C     block J_k, k = 1:l, and applies the orthogonal matrix Q'_k to the
C     corresponding part of the last block column and of e. After all
C     block rows have been processed, the block rows are interchanged
C     so that the zeroed submatrices in the first l block columns are
C     moved to the bottom part. The same block row permutation Z is
C     also applied to the vector e. At the end of the first phase,
C     the structure of the processed matrix J is
C
C         /   R_1    0    ..   0   |  L^1_1  \
C         |    0    R_2   ..   0   |  L^1_2  |
C         |    :     :    ..   :   |    :    | .
C         |    :     :    ..   :   |    :    |
C         |    0     0    ..  R_l  |  L^1_l  |
C         |    0     0    ..   0   |  L^2_1  |
C         |    :     :    ..   :   |    :    |
C         \    0     0    ..   0   |  L^2_l  /
C
C     In the second phase, the submatrix L^2_1:l is triangularized
C     using an additional QR factorization with pivoting. (The columns
C     of L^1_1:l are also permuted accordingly.) Therefore, the column
C     pivoting is restricted to each such local block column.
C
C     If l <= 1, the matrix J is triangularized in one phase, by one
C     QR factorization with pivoting. In this case, the column
C     pivoting is global.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     Feb. 22, 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Jacobian matrix, matrix algebra,
C     matrix operations, Wiener system.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDJ, LDWORK, LIPAR, N
      DOUBLE PRECISION  FNORM, GNORM
C     .. Array Arguments ..
      INTEGER           IPAR(*), IPVT(*)
      DOUBLE PRECISION  DWORK(*), E(*), J(*), JNORMS(*)
C     .. Local Scalars ..
      INTEGER           BN, BSM, BSN, I, IBSM, IBSN, IBSNI, ITAU, JL,
     $                  JLM, JWORK, K, L, M, MMN, NTHS, ST, WRKOPT
      DOUBLE PRECISION  SUM
C     .. External Functions ..
      DOUBLE PRECISION  DDOT, DNRM2
      EXTERNAL          DDOT, DNRM2
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEQP3, DLACPY, DLAPMT, DORMQR, DSWAP,
     $                  MD03BX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      INFO = 0
      IF ( N.LT.0 ) THEN
         INFO = -1
      ELSEIF( LIPAR.LT.4 ) THEN
         INFO = -3
      ELSEIF ( FNORM.LT.ZERO ) THEN
         INFO = -4
      ELSEIF ( LDJ.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE
         ST   = IPAR(1)
         BN   = IPAR(2)
         BSM  = IPAR(3)
         BSN  = IPAR(4)
         NTHS = BN*BSN
         MMN  = BSM - BSN
         IF ( BN.GT.0 ) THEN
            M = BN*BSM
         ELSE
            M = N
         END IF
         IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN
            INFO = -2
         ELSEIF ( N.NE.NTHS + ST ) THEN
            INFO = -1
         ELSEIF ( M.LT.N ) THEN
            INFO = -2
         ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN
            INFO = -6
         ELSE
            IF ( N.EQ.0 ) THEN
               JWORK = 1
            ELSEIF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN
               IF ( BN.LE.1 .AND. BSM.EQ.1 .AND. N.EQ.1 ) THEN
                  JWORK = 1
               ELSE
                  JWORK = 4*N + 1
               END IF
            ELSE
               JWORK = BSN + MAX( 3*BSN + 1, ST )
               IF ( BSM.GT.BSN ) THEN
                  JWORK = MAX( JWORK, 4*ST + 1 )
                  IF ( BSM.LT.2*BSN )
     $               JWORK = MAX( JWORK, MMN*( BN - 1 ) )
               END IF
            END IF
            IF ( LDWORK.LT.JWORK )
     $         INFO = -12
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'NF01BS', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      GNORM = ZERO
      IF ( N.EQ.0 ) THEN
         LDJ = 1
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN
C
C        Special case, l <= 1 or BSN = 0: the Jacobian is represented
C        as a full matrix.
C        (Note: Comments in the code beginning "Workspace:" describe the
C        minimal amount of real workspace needed at that point in the
C        code, as well as the preferred amount for good performance.
C        NB refers to the optimal block size for the immediately
C        following subroutine, as returned by ILAENV.)
C
C        Workspace: need:    4*N + 1;
C                   prefer:  3*N + ( N+1 )*NB.
C
         CALL MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT,
     $                DWORK, LDWORK, INFO )
         RETURN
      END IF
C
C     General case: l > 1 and BSN > 0.
C     Initialize the column pivoting indices.
C
      DO 10 I = 1, N
         IPVT(I) = 0
   10 CONTINUE
C
C     Compute the QR factorization with pivoting of J.
C     Pivoting is done separately on each block column of J.
C
      WRKOPT = 1
      IBSN   = 1
      JL     = LDJ*BSN + 1
      JWORK  = BSN + 1
C
      DO 30 IBSM = 1, M, BSM
C
C        Compute the QR factorization with pivoting of J_k, and apply Q'
C        to the corresponding part of the last block-column and of e.
C        Workspace: need:    4*BSN + 1;
C                   prefer:  3*BSN + ( BSN+1 )*NB.
C
         CALL DGEQP3( BSM, BSN, J(IBSM), LDJ, IPVT(IBSN), DWORK,
     $                DWORK(JWORK), LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         IF ( IBSM.GT.1 ) THEN
C
C           Adjust the column pivoting indices.
C
            DO 20 I = IBSN, IBSN + BSN - 1
               IPVT(I) = IPVT(I) + IBSN - 1
   20       CONTINUE
C
         END IF
C
         IF ( ST.GT.0 ) THEN
C
C           Workspace: need:    BSN + ST;
C                      prefer:  BSN + ST*NB.
C
            CALL DORMQR( 'Left', 'Transpose', BSM, ST, BSN, J(IBSM),
     $                   LDJ, DWORK, J(JL), LDJ, DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         END IF
C
C        Workspace: need:    BSN + 1;
C                   prefer:  BSN + NB.
C
         CALL DORMQR( 'Left', 'Transpose', BSM, 1, BSN, J(IBSM), LDJ,
     $                DWORK, E(IBSM), BSM, DWORK(JWORK), LDWORK-JWORK+1,
     $                INFO )
         JL   = JL   + BSM
         IBSN = IBSN + BSN
   30 CONTINUE
C
      IF ( MMN.GT.0 ) THEN
C
C        Case BSM > BSN.
C        Compute the original column norms for the first block column
C        of Jc.
C        Permute the rows of the first block column to move the zeroed
C        submatrices to the bottom. In the same loops, reshape the
C        first block column of R to have the leading dimension N.
C
         L = IPVT(1)
         JNORMS(L) = ABS( J(1) )
         IBSM = BSM + 1
         IBSN = BSN + 1
C
         DO 40 K = 1, BN - 1
            J(IBSN) = J(IBSM)
            L = IPVT(IBSN)
            JNORMS(L) = ABS( J(IBSN) )
            IBSM = IBSM + BSM
            IBSN = IBSN + BSN
   40    CONTINUE
C
         IBSN = IBSN + ST
C
         DO 60 I = 2, BSN
            IBSM = ( I - 1 )*LDJ + 1
            JL   = I
C
            DO 50 K = 1, BN
C
               DO 45 L = 0, I - 1
                  J(IBSN+L) = J(IBSM+L)
   45          CONTINUE
C
               L = IPVT(JL)
               JNORMS(L) = DNRM2( I, J(IBSN), 1 )
               IBSM = IBSM + BSM
               IBSN = IBSN + BSN
               JL   = JL   + BSN
   50       CONTINUE
C
            IBSN = IBSN + ST
   60    CONTINUE
C
C        Permute the rows of the second block column of Jc and of
C        the vector e.
C
         JL = LDJ*BSN
         IF ( BSM.GE.2*BSN ) THEN
C
C           A swap operation can be used.
C
            DO 80 I = 1, ST
               IBSN = BSN + 1
C
               DO 70 IBSM = BSM + 1, M, BSM
                  CALL DSWAP( MMN, J(JL+IBSM), 1, J(JL+IBSN), 1 )
                  IBSN = IBSN + BSN
   70          CONTINUE
C
               JL = JL + LDJ
   80       CONTINUE
C
C           Permute the rows of e.
C
            IBSN = BSN + 1
C
            DO 90 IBSM = BSM + 1, M, BSM
               CALL DSWAP( MMN, E(IBSM), 1, E(IBSN), 1 )
               IBSN = IBSN + BSN
   90       CONTINUE
C
         ELSE
C
C           A swap operation cannot be used.
C           Workspace: need:    ( BSM-BSN )*( BN-1 ).
C
            DO 110 I = 1, ST
               IBSN  = BSN + 1
               JLM   = JL  + IBSN
               JWORK = 1
C
               DO 100 IBSM = BSM + 1, M, BSM
                  CALL DCOPY( MMN, J(JLM), 1, DWORK(JWORK), 1 )
C
                  DO 105 K = JL, JL + BSN - 1
                     J(IBSN+K) = J(IBSM+K)
  105             CONTINUE
C
                  JLM   = JLM   + BSM
                  IBSN  = IBSN  + BSN
                  JWORK = JWORK + MMN
  100          CONTINUE
C
               CALL DCOPY( MMN*( BN-1 ), DWORK, 1, J(JL+IBSN), 1 )
               JL = JL + LDJ
  110       CONTINUE
C
C           Permute the rows of e.
C
            IBSN  = BSN + 1
            JLM   = IBSN
            JWORK = 1
C
            DO 120 IBSM = BSM + 1, M, BSM
               CALL DCOPY( MMN, E(JLM),  1, DWORK(JWORK), 1 )
C
               DO 115 K = 0, BSN - 1
                  E(IBSN+K) = E(IBSM+K)
  115          CONTINUE
C
               JLM   = JLM   + BSM
               IBSN  = IBSN  + BSN
               JWORK = JWORK + MMN
  120       CONTINUE
C
            CALL DCOPY( MMN*( BN-1 ), DWORK, 1, E(IBSN), 1 )
         END IF
C
         IF ( ST.GT.0 ) THEN
C
C           Compute the QR factorization with pivoting of the submatrix
C           L^2_1:l, and apply Q' to the corresponding part of e.
C
C           Workspace: need:    4*ST + 1;
C                      prefer:  3*ST + ( ST+1 )*NB.
C
            JL    = ( LDJ + BN )*BSN + 1
            ITAU  = 1
            JWORK = ITAU + ST
            CALL DGEQP3( MMN*BN, ST, J(JL), LDJ, IPVT(NTHS+1),
     $                   DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1,
     $                   INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C           Permute columns of the upper part of the second block
C           column of Jc.
C
            CALL DLAPMT( .TRUE., NTHS, ST, J(JL-NTHS), LDJ,
     $                   IPVT(NTHS+1) )
C
C           Adjust the column pivoting indices.
C
            DO 130 I = NTHS + 1, N
               IPVT(I) = IPVT(I) + NTHS
  130       CONTINUE
C
C           Workspace: need:    ST + 1;
C                      prefer:  ST + NB.
C
            CALL DORMQR( 'Left', 'Transpose', MMN*BN, 1, ST, J(JL), LDJ,
     $                   DWORK(ITAU), E(IBSN), LDJ, DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C           Reshape the second block column of R to have the leading
C           dimension N.
C
            IBSN = N*BSN + 1
            CALL DLACPY( 'Full', N, ST, J(LDJ*BSN+1), LDJ, J(IBSN), N )
C
C           Compute the original column norms for the second block
C           column.
C
            DO 140 I = NTHS + 1, N
               L = IPVT(I)
               JNORMS(L) = DNRM2( I, J(IBSN), 1 )
               IBSN = IBSN + N
  140       CONTINUE
C
         END IF
C
      ELSE
C
C        Case BSM = BSN.
C        Compute the original column norms for the first block column
C        of Jc.
C
         IBSN = 1
C
         DO 160 I = 1, BSN
            JL = I
C
            DO 150 K = 1, BN
               L = IPVT(JL)
               JNORMS(L) = DNRM2( I, J(IBSN), 1 )
               IBSN = IBSN + BSN
               JL   = JL   + BSN
  150       CONTINUE
C
            IBSN = IBSN + ST
  160    CONTINUE
C
         DO 170 I = NTHS + 1, N
            IPVT(I) = I
  170    CONTINUE
C
      END IF
C
C     Compute the norm of the scaled gradient.
C
      IF ( FNORM.NE.ZERO ) THEN
C
         DO 190 IBSN = 1, NTHS, BSN
            IBSNI = IBSN
C
            DO 180 I = 1, BSN
               L = IPVT(IBSN+I-1)
               IF ( JNORMS(L).NE.ZERO ) THEN
                  SUM   = DDOT( I, J(IBSNI), 1, E(IBSN), 1 )/FNORM
                  GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) )
               END IF
               IBSNI = IBSNI + N
  180       CONTINUE
C
  190    CONTINUE
C
         IBSNI = N*BSN + 1
C
         DO 200 I = NTHS + 1, N
            L = IPVT(I)
            IF ( JNORMS(L).NE.ZERO ) THEN
               SUM   = DDOT( I, J(IBSNI), 1, E, 1 )/FNORM
               GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) )
            END IF
            IBSNI = IBSNI + N
  200    CONTINUE
C
      END IF
C
      LDJ = N
      DWORK(1) = WRKOPT
      RETURN
C
C *** Last line of NF01BS ***
      END


!
!     ------------------------------------------------------------------
!     S L O P E
!     ------------------------------------------------------------------
!
      subroutine slope
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
      use radial_C
      use nel_C
      use fo_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:45:37  11/20/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      use polint_I
      implicit none
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: j, i
      real(double), dimension(4) :: xa, ya
      real(double) :: daz
!-----------------------------------------------
!      PARAMETER (NWD=128,NOD=220)
!      character*3 el
!      COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
!      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
!     :       (IQMAX,MAX(1))
!      COMMON /NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7),el(nwd)
!      COMMON /FO/IWF(2),NCLOS(2),NOPEN(2),MAXNFO
!     Determine the starting parameter az =  p(r)/r^(l+1)|r=0
      do j = 1, maxnfo
         do i = 4, 1, -1
            xa(i) = r(i)
            ya(i) = p(i,j)*dsqrt(r(i))/dexp((l(j)+1.D0)*dlog(r(i)))
         end do
         call polint (xa, ya, 4, 0.D0, az(j), daz)
      end do
      return
      end subroutine slope


      subroutine ygam1s(alf,bet,gam,yg,n)
!----------------------------------------------------------------------
!   changed on February 11, 2008 by MP, KP.
!
!   Purpose           - calculates Gamma       (alpha,beta,gamma)
!                                       -1,-1,n
!
!                                  Gamma       (alpha,beta,gamma)
!                                       -2,-1,n
!
!   Remarks:         1: see R.A.Sack, C.C.J.Roothaan, and W.Kolos,
!                         J. Math. Phys., v.8 (1967) 1093, for notation
!
!----------------------------------------------------------------------
      implicit          real (16) (a-h,o-z)
      parameter         (lenl=200,lenl2=3*lenl)
      real (16), parameter :: zero = 0.0q0
      real (16), parameter :: one  = 1.0q0
      real (16), parameter :: threshold  = 0.05q0
      real (16)         yg(0:lenl,2)
      real (16), dimension(0:lenl2) :: cc,dd,ee,ff,gg,hh,ii1,ii2
!
      epsm = epsilon(one)
      agam = abs(gam)
      if (agam >= threshold) then
         nl = n
      else if (agam == zero) then
         nl = n+1
      else
         nadd = int(log(epsm)/log(agam))+5
         nl = n+nadd
         if (nl > lenl2) then
            write (*,*) 'Error!!! Insufficient array length in YGAM1!'
            stop
         end if
      end if
!
      ainv = one/(bet+gam)
      binv = one/(alf+gam)
      ginv = one/(alf+bet)
!
!                       b/[(b+c)(b-c)]*ln[(a+b)/(a+c)]
!
      if (bet > gam) then
         u = (bet-gam)/(alf+gam)
         ab = alf+bet
!
         call dplog(u,nl-1,gg)
!
         cc(0) = gg(0)
         cc(1) = gg(1)*binv
         temp = binv
         do i=2,nl-1
            temp = temp*binv
            cc(i) = gg(i)*temp
         end do
         ee(0) = bet*cc(0)
         do j=1,nl-1
            do i=0,nl-j-1
               cc(i) = binv*((i+j-1)*cc(i)-ab*cc(i+1))
            end do
            ee(j) = bet*cc(0)
         end do
         ee(0) = ainv*ee(0)
         do j=1,nl-1
            ee(j) = ainv*(j*ee(j-1)+ee(j))
         end do
         ee(0) = binv*ee(0)
         do j=1,nl-1
            ee(j) = binv*(j*ee(j-1)+ee(j))
         end do
      else
         u = (gam-bet)/(alf+bet)
         ag = alf+gam
!
         call dplog(u,nl-1,gg)
!
         cc(0) = gg(0)
         cc(1) = gg(1)*ginv
         ee(0) = bet*cc(0)
         ee(1) = bet*cc(1)
         temp = ginv
         do i=2,nl-1
            temp = temp*ginv
            cc(i) = gg(i)*temp
            ee(i) = bet*cc(i)
         end do
         ee(0) = ainv*ee(0)
         do j=1,nl-1
            ee(j) = ainv*(j*ee(j-1)+ee(j))
         end do
         do j=0,nl-1
            ee(j) = ginv*ee(j)
         end do
      end if
!
!                       a/[(a+c)(a-c)]*ln[(a+b)/(b+c)]
!                         and (a+b)/[(b+c)(a-c)]*ln[(a+b)/(b+c)]
!
      if (alf > gam) then
         u = (alf-gam)/(bet+gam)
         ab = alf+bet
!
         call dplog(u,nl-1,gg)
!
         cc(0) = gg(0)
         cc(1) = gg(1)*ainv
         temp = ainv
         do i=2,nl-1
            temp = temp*ainv
            cc(i) = gg(i)*temp
         end do
         dd(0) = alf*cc(0)
         hh(0) = ab*cc(0)
         do j=1,nl-1
            do i=0,nl-j-1
               cc(i) = ainv*((i+j-1)*cc(i)-ab*cc(i+1))
            end do
            dd(j) = alf*cc(0)
            hh(j) = ab*cc(0)
         end do
         dd(0) = binv*dd(0)
         hh(0) = ainv*hh(0)
         do j=1,nl-1
            dd(j) = binv*(j*dd(j-1)+dd(j))
            hh(j) = ainv*(j*hh(j-1)+hh(j))
         end do
         dd(0) = ainv*dd(0)
         hh(0) = ainv*hh(0)
         do j=1,nl-1
            dd(j) = ainv*(j*dd(j-1)+dd(j))
            hh(j) = ainv*(j*hh(j-1)+hh(j))
         end do
      else
         u = (gam-alf)/(alf+bet)
         bg = bet+gam
!
         call dplog(u,nl-1,gg)
!
         cc(0) = gg(0)
         cc(1) = gg(1)*ginv
         dd(0) = alf*cc(0)
         dd(1) = alf*cc(1)
         temp = ginv
         do i=2,nl-1
            temp = temp*ginv
            cc(i) = gg(i)*temp
            dd(i) = alf*cc(i)
         end do
         dd(0) = binv*dd(0)
         hh(0) = ainv*cc(0)
         do j=1,nl-1
            dd(j) = binv*(j*dd(j-1)+dd(j))
            hh(j) = ainv*(j*hh(j-1)+cc(j))
         end do
         do j=0,nl-1
            dd(j) = ginv*dd(j)
         end do
      end if
!
!                       Gamma       (alpha,beta,gamma)
!                            -1,-1,n
!
      if (agam >= threshold) then
         gl = log((alf+gam)/(bet+gam))
         dilog1 = dilog((alf+bet)/(alf+gam))
         dilog2 = dilog((alf+bet)/(bet+gam))
         yg(0,1) = (gl**2+2*(dilog1+dilog2)+pi**2/3)/(4*gam)
         gaminv = one/gam
         do i=1,n
            yg(i,1) = gaminv*(i*yg(i-1,1)-dd(i-1)-ee(i-1))
         end do
      else
         cc(nl) = one
         do i=nl,1,-1
            cc(i-1) = (gam*cc(i)+dd(i-1)+ee(i-1))/i
         end do
         do i=0,n
            yg(i,1) = cc(i)
         end do
      end if
!
!                       Gamma       (alpha,beta,gamma)
!                            -2,-1,n
!
      clogbg = log(bet+gam)
      ff(0) = clogbg**2/2
      ff(1) = -clogbg*ainv
      temp = ainv
      ff(2) = ainv*(ff(1)+temp)
      do i=3,n
         temp = temp*ainv*(i-2)
         ff(i) = ainv*((i-1)*ff(i-1)+temp)
      end do
!
      if (agam < threshold) then
         dilog2 = dilog((alf+bet)/(bet+gam))
      end if
      ag = alf+gam
      gg(0) = ag*yg(0,1)
      yg(0,2) = ff(0)+dilog2-gg(0)
      do i=1,n
         gg(i)= -i*yg(i-1,1)+ag*yg(i,1)
         yg(i,2) = ff(i)-hh(i-1)-gg(i)
      end do

!     added 06.01.2008 by MP
!     derivatives over -c of -log(b+c)+pi^2/6+1
!

      ii1(0) = -log(bet+gam) + Pi**2/6 + 1
      ii1(1)=ainv

      do i=2,n
       ii1(i)=(i-1)*ii1(i-1)*ainv
      enddo

      yg(0,2) = yg(0,2)+ii1(0)

      do i=1,n
       yg(i,2) = yg(i,2)+ii1(i)
      enddo

      return
      end


PROGRAM array_test
  IMPLICIT NONE
  !Runs 1->10
  INTEGER, DIMENSION(10) :: array1
  !Runs 1->10 but now made explicit
  INTEGER, DIMENSION(1:10) :: array2
  !Runs 0->9
  INTEGER, DIMENSION(0:9) :: array3
  !Runs -5->4
  INTEGER, DIMENSION(-5:4) :: array4

  PRINT *, 'Array1 :', SIZE(array1), LBOUND(array1), UBOUND(array1)
  PRINT *, 'Array2 :', SIZE(array2), LBOUND(array2), UBOUND(array2)
  PRINT *, 'Array3 :', SIZE(array3), LBOUND(array3), UBOUND(array3)
  PRINT *, 'Array4 :', SIZE(array4), LBOUND(array4), UBOUND(array4)

END PROGRAM array_test


      PROGRAM xsobseq
C     driver for routine sobseq
      INTEGER j,jj
      REAL x(3)
      call sobseq(-1,x)
      do 11 jj=1,32
        call sobseq(3,x)
        write(*,'(3(1x,f10.5),1x,i5)') (x(j),j=1,3),jj
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xsobseq.for


program main
    use SiCroF
    implicit none
    integer,parameter :: n = 10000
    type(Random_) :: random
    type(MPI_)    :: MPIdata
    double precision :: a(n)
    integer :: i

    call MPIdata%start()
    call random%init()
    do i=1,n
        a(i)=random%random()
    enddo
    call quicksort(a)
    call MPIdata%end()

end program


 SUBROUTINE elem05(TASK, nelms, elsnam, dtime, ttime, istop, &
                   lnod, flag1, flag2)

 !master routine for element 05 (TLF) 3-D solid-shell prism element

 USE ctrl_db, ONLY: ndime, ndofn, npoin, dtscal
 USE outp_db, ONLY: sumat, iwrit
 USE ele05_db
 USE npo_db
 USE static_db, ONLY : smass
 USE sms_db, ONLY : selective_mass_scaling, sms_ns , sms_name, sms_thl, sms_alp

 IMPLICIT NONE
 CHARACTER(len=*),INTENT(IN):: TASK

 ! optional parameters

 LOGICAL, OPTIONAL :: flag1,flag2
 CHARACTER (len=*), OPTIONAL :: elsnam
 INTEGER (kind=4), OPTIONAL :: istop,nelms(:)
 INTEGER (kind=4), POINTER, OPTIONAL :: lnod(:,:)
 REAL (kind=8), OPTIONAL :: dtime,ttime

 ! Local variables
 CHARACTER (len=mnam) :: sname
 INTEGER (kind=4) :: nreqs, narch, nnode, nelem,  ngaus, i
 TYPE (ele05_set), POINTER :: elset, anter
 LOGICAL ::  quad
 LOGICAL :: sms
 REAL (kind=8) :: thl,alp

 IF ( .NOT.ASSOCIATED (head) ) RETURN  !no element sets

 NULLIFY (anter)      !nullify pointer to previous set
 elset => head        !point to first set of elements

 DO                   !loop over the element sets
   ! recover control variables for present element set
   CALL comm05 (1,nnode,nelem,nreqs,narch,sname,elset,ngaus,quad)

   SELECT CASE (TRIM(task)) !according to the requested task

   CASE ('GAUSSC')      !compute initial constants
     IF( .NOT.elset%gauss)THEN
       CALL gaus05(elset%head,coord,istop,elset%angdf,elset%locax,nnode,quad, &
                   elset%isg,elset%psg,ngaus)
       elset%gauss = .TRUE.
     END IF

!   CASE ('LOADPL')      !compute gravity load vector
!    CALL load05 (igrav, loadv(:,:,iload), gv, gravy, elset%head,ngaus)

   CASE ('CLOSEF')      !close output file
     CALL close1(nreqs,narch)

   CASE ('LUMASS')
     CALL luma05(elset%head,emass, sumat)

   CASE ('SLUMAS')      !compute (lumped) mass vector

     sms = .FALSE.
     thl = 0d0
     IF( selective_mass_scaling )THEN
       DO i=1,sms_ns
         IF(TRIM(sms_name(i)) == TRIM(sname) )THEN
           alp = sms_alp(i)
           thl = sms_thl(i)
           sms = .TRUE.
           EXIT
         END IF
       END DO
     END IF
     CALL slum05( nelem, elset%head, smass, coora, elset%btscal, dtscal, sms, alp, thl)

   CASE ('NEW   ','NSTRA1','NSTRA2')  !release DOFs and other tasks
     CALL acvd05(ifpre,elset%head,elset%lface,nelem,nnode)

   CASE ('UPDLON')      !updates internal node numbers
     CALL updl05 (elset, oldlb)

   CASE ('OUTDYN')      !output variables for post-processing

     IF(flag1.OR.flag2) CALL outd05 (flag1,flag2, iwrit, &
            elset%head, nreqs, narch, elset%ngrqs, ttime, ngaus, elset%isg,elset%psg)

   CASE ('RESVPL')      !compute internal nodal forces
     CALL resv05 (nelem,elset%head, coora, resid, istop, ttime, elset%small, ngaus, &
                  quad, nnode)

   CASE ('DUMPIN')      !dumps variables for restart
     CALL dump05 ( elset )

   CASE ('WRTPOS')      !writes geometric variables for post-process
     CALL mase05 ( nreqs, nelem, elset%head, elset%ngrqs, narch, &
                   elset%angdf, sname, ngaus, elset%locax )
     elset%narch = narch              !keep output file

   CASE ('INCDLT')      !compute critical time increment
     sms = .FALSE.
     thl = 0d0
     IF( selective_mass_scaling )THEN
       DO i=1,sms_ns
         IF(TRIM(sms_name(i)) == TRIM(sname) )THEN
           alp = sms_alp(i)
           thl = sms_thl(i)
           sms = .TRUE.
           EXIT
         END IF
       END DO
     END IF
     CALL delt05 ( nelem, elset%head, dtime, coora, elset%btscal, sms, alp, thl)

   !CASE ('SPBACK')
   !    CALL outs05 (elset, label)

   CASE ('SEARCH')      !search if set named SNAME exists
     IF( flag2 )EXIT
     flag2 = elsnam == sname
     IF (flag2) EXIT

   CASE ('SURFAC','BOUNDA')
     IF( flag2 )EXIT
     flag2 = elsnam == sname
     IF (flag2) THEN
       ! get surface definition from the element set
       CALL surf05 (elset%head,elset%nelem)
       EXIT
     END IF

   CASE ('NODSET')      !compute nodes set from element set
     IF( flag2 )EXIT
     flag2 = elsnam == sname
     IF (flag2) THEN
       ! extracts nodes used in the discretization to nodset
       !CALL nods05(nelem, nnode, elset%head, label)
       EXIT
     END IF

    CASE('SLNODS')
      IF( flag2 )EXIT
       flag2 = TRIM(elsnam) == TRIM(sname)
       IF (flag2) THEN
         ! extracts element connectivities into array IMAT
         CALL slno05(nelem,nnb,elset%head,lnod)
         EXIT
       END IF

   CASE ('SECDAT')
     IF( flag2 )EXIT
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) THEN
       !  extract SECTIONs used in the set
       !CALL secd05 (elset%head,elset%nelem,ivect)
       EXIT
     END IF

   CASE ('EXPORT')
     IF( flag2 )EXIT
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) THEN
       !export set data
       CALL expo05 (elset,flag1,istop)
       EXIT
     END IF

   END SELECT

   IF ( ASSOCIATED (elset%next) ) THEN   !more sets to process
     elset => elset%next                 !point to next set
   ELSE
     EXIT
   END IF

 END DO

 !     delete null elements sets after Nodal Updating
 IF( TRIM(task) == 'UPDLON')THEN
   NULLIFY (anter)
   elset => head
   DO
     IF(.NOT.ASSOCIATED(elset))EXIT
     IF( elset%nelem == 0 )THEN
       CALL del_ele05 (head, anter, elset)
       nelms( 5) = nelms( 5) - 1
     END IF
     IF (ASSOCIATED(elset))THEN
       anter => elset
       elset => elset%next
     ELSE IF(ASSOCIATED(anter))THEN
       elset => anter%next
     ELSE IF (ASSOCIATED(head)) THEN
       elset => head
     ELSE
       EXIT
     END IF
   END DO
 END IF

 RETURN

 END SUBROUTINE elem05


module constants_m
  implicit none

  ! << f90 constants >>
  integer, parameter :: SI = selected_int_kind(8)
  integer, parameter :: DI = selected_int_kind(16)
  integer, parameter :: SR = selected_real_kind(6)
  integer, parameter :: DR = selected_real_kind(12)

  ! << Mathematical constants >
  real(DR), parameter :: EPS = 1e-5
  integer(DR), parameter :: INF = 1e+5

  ! <<IO constants >
  ! in : 読み込みファイルのための装置番号
  integer(SI),parameter :: IN = 17
  ! in2 : 読み込みファイルのための装置番号
  integer(SI),parameter :: IN2 = 18
  integer(SI),parameter :: PARAM = 19
  integer(SI),parameter :: OUT = 20
  integer(SI),parameter :: OUT2 = 21

  ! <<MPI constants >
  integer(SI),parameter :: ROOT = 0

  integer(SI),parameter :: DEV = 5

end module constants_m


Living in Davis one is often exposed to English, Spanish and Greek.  To assist with deciphering Fraternity and Sororities Sorority names, or for reference in your math courses, use the following table:

Does this page contribute anything that isnt already found in the wiki:WikiPedia:Greek_alphabet Wikipedia article on the Greek alphabet?  ...especially, anything of specific relevance to Davis?
  On my first pass through I didnt add links from each letter to the organizations that refer to themselves as such, but that would help to make it Davis relevant.


program kvsTest
      implicit none

      logical   	kvscheckown
C     cinfo is an opaque type holding KVS connection info.
      integer*4 	cinfo(3), rank, nclones, chunk, limit, psum(3)
      integer   	i, sum /0/, work /0/
      integer		t0, time
      character*10	cchunk, climit

C     Disable kvs tracing.
      cinfo(3) = 0
C     Connect to the key/value service.
      call kvsconnect(cinfo)

C     Figure out our role in this run.
      call slurmme(rank, nclones)
      print '(I4,A4,I4,A9,I6)',
     $     'Rank ', rank, ' of ', nclones

C     Get run parameters.
      if ( rank .eq. 0 ) then
C        Request input via KVS from a web inteface.
         call kvsget(cinfo, 'Loop limit?%10s', climit)
         read(climit, '(I10)') limit
         call kvsget(cinfo, 'Chunk?%10s', cchunk)
         read(cchunk, '(I10)') chunk
C        Send some HTML to the web inteface.
         call kvsput(cinfo, '@Run info',
     $        '
Looping '//climit//
     $        ' times, in chunks of size '//cchunk//'.
', 70)
C        Let the clones know.
         call kvsput(cinfo, 'limit', limit, 4)
         call kvsput(cinfo, 'chunk', chunk, 4)
      else
         call kvsview(cinfo, 'limit', limit)
         call kvsview(cinfo, 'chunk', chunk)
      endif

C     The work in this loop will be split among all participants into
C     blocks of size "chunk".
      t0 = time()
      do i = 0, limit-1
         if ( kvscheckown(cinfo, rank, nclones, chunk, 'ticket') ) then
            sum = sum + 2*i + 1
            work = work + 1
C     Arrange for some clones to be slower than others.
            call sleep(mod(rank,2)+1)
         endif
      enddo
      psum(1) = rank
      psum(2) = work
      psum(3) = sum

C     Merge partial results.
      call kvsput(cinfo, 'psum', psum, 4*3)

      if ( rank .eq. 0 ) then
         sum = 0
         do i = 1, nclones
            call kvsget(cinfo, 'psum', psum)
            print *, psum(1), ' ', psum(2), ' => ', psum(3)
            sum = sum + psum(3)
         enddo
         print *, 'Sum of the first ', limit, ' odd integers: ', sum
         print *, 'Elapsed: ', time() - t0
      endif
      stop
      end


! { dg-do run }
! Testcase for SIGN() with integer arguments
! Check that:
!   + SIGN() evaluates its arguments only once
!   + SIGN() works on large values
!   + SIGN() works with parameter arguments
! Contributed by FX Coudert <fxcoudert@gmail.com>
program sign1
  implicit none
  integer(kind=1), parameter :: one1 = 1_1, mone1 = -1_1
  integer(kind=2), parameter :: one2 = 1_2, mone2 = -1_2
  integer(kind=4), parameter :: one4 = 1_4, mone4 = -1_4
  integer(kind=8), parameter :: one8 = 1_8, mone8 = -1_8
  integer(kind=1) :: i1, j1
  integer(kind=2) :: i2, j2
  integer(kind=4) :: i4, j4
  integer(kind=8) :: i8, j8
  integer :: i = 1

  i1 = huge(0_1) ; j1 = -huge(0_1)
  if (sign(i1, j1) /= j1) STOP 1
  if (sign(j1, i1) /= i1) STOP 2
  if (sign(i1,one1) /= i1 .or. sign(j1,one1) /= i1) STOP 3
  if (sign(i1,mone1) /= j1 .or. sign(j1,mone1) /= j1) STOP 4

  i2 = huge(0_2) ; j2 = -huge(0_2)
  if (sign(i2, j2) /= j2) STOP 5
  if (sign(j2, i2) /= i2) STOP 6
  if (sign(i2,one2) /= i2 .or. sign(j2,one2) /= i2) STOP 7
  if (sign(i2,mone2) /= j2 .or. sign(j2,mone2) /= j2) STOP 8

  i4 = huge(0_4) ; j4 = -huge(0_4)
  if (sign(i4, j4) /= j4) STOP 9
  if (sign(j4, i4) /= i4) STOP 10
  if (sign(i4,one4) /= i4 .or. sign(j4,one4) /= i4) STOP 11
  if (sign(i4,mone4) /= j4 .or. sign(j4,mone4) /= j4) STOP 12

  i8 = huge(0_8) ; j8 = -huge(0_8)
  if (sign(i8, j8) /= j8) STOP 13
  if (sign(j8, i8) /= i8) STOP 14
  if (sign(i8,one8) /= i8 .or. sign(j8,one8) /= i8) STOP 15
  if (sign(i8,mone8) /= j8 .or. sign(j8,mone8) /= j8) STOP 16

  if (sign(foo(i), 1) /= 1) STOP 1
  if (sign(foo(i), -1) /= -2) STOP 2
  if (sign(42, foo(i)) /= 42) STOP 3
  if (sign(42, -foo(i)) /= -42) STOP 4
  if (i /= 5) STOP 5

  if (sign(bar(), 1) /= 1) STOP 6
  if (sign(bar(), -1) /= -2) STOP 7
  if (sign(17, bar()) /= 17) STOP 8
  if (sign(17, -bar()) /= -17) STOP 9
  if (bar() /= 5) STOP 10

contains

  integer function foo(i)
    integer :: i
    foo = i
    i = i + 1
  end function

  integer function bar()
    integer, save :: i = 0
    i = i + 1
    bar = i
  end function
end


      program prog
      integer base_size
      parameter(base_size=3)
      dimension nums(base_size * 2)
      call sub(nums)
      write(6, *) nums
      end

      subroutine sub(nums)
      integer base_size
      parameter(base_size=3)
      dimension nums(base_size * 2)
      do i=1,base_size*2
        nums(i) = 61 + i * 7
      enddo
      end


module type_SphericalGrid

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        TWO_PI

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: SphericalGrid

    ! Parameter confined to the module
    real(wp), parameter :: ZERO = 0.0_wp

    type, public, abstract :: SphericalGrid
        ! Type components
        logical,                       public :: initialized = .false.
        integer(ip),                   public :: NUMBER_OF_LONGITUDES = 0  ! number of longitudinal points
        integer(ip),                   public :: NUMBER_OF_LATITUDES = 0 ! number of latitudinal points
        real(wp),                      public :: LONGITUDINAL_MESH = ZERO ! Only used in RegularGrid
        real(wp),         allocatable, public :: latitudes(:)  ! 0 <= theta <= pi
        real(wp),         allocatable, public :: longitudes(:) ! 0 <= phi <= 2*p
        character(len=:), allocatable, public :: grid_type
    contains
        ! Type-bound procedures
        procedure, public :: destroy_grid
        procedure, public :: get_equally_spaced_longitudes
        procedure, public :: print_to_unformatted_binary_files
        ! Deferred type-bound procedures
        procedure(assert_init), deferred, public :: assert_initialized
    end type SphericalGrid

    ! Declare interfaces for deferred type-bound procedures
    abstract interface
        subroutine assert_init(self, routine)
            import:: SphericalGrid

            ! Dummy arguments
            class(SphericalGrid), intent(inout) :: self
            character(len=*),     intent(in)    :: routine
        end subroutine assert_init
    end interface

contains

    subroutine destroy_grid(self)

        ! Dummy arguments
        class(SphericalGrid), intent(inout)  :: self

        ! Check flag
        if (.not.self%initialized) return

        !  Release memory
        if (allocated(self%grid_type)) deallocate (self%grid_type)
        if (allocated(self%longitudes)) deallocate (self%longitudes)
        if (allocated(self%latitudes)) deallocate (self%latitudes)

        ! Reset constants
        self%NUMBER_OF_LONGITUDES = 0
        self%NUMBER_OF_LATITUDES = 0
        self%LONGITUDINAL_MESH = ZERO

        ! Reset initialization flag
        self%initialized = .false.

    end subroutine destroy_grid

    subroutine get_equally_spaced_longitudes(self, nlon, phi)

        ! Dummy arguments
        class(SphericalGrid),  intent(inout)  :: self
        integer(ip),           intent(in)     :: nlon ! number of longitudinal points
        real(wp), allocatable, intent(out)    :: phi(:)  ! longitudes: 0 <= phi <= 2*pi

        ! Local variables
        integer(ip) :: i ! counter

        !  Check validity of calling argument
        if (nlon <= 0) then
            error stop 'Object of class(SphericalGrid): '&
                //'invalid calling argument nlon <= 0 '&
                //'in get_equally_spaced_longitudes'
        end if

        !  Allocate memory
        allocate (phi(nlon))

        !  Compute equally space (uniform) longitudinal grid
        associate (dphi => self%LONGITUDINAL_MESH)

            ! Set equally spaced (uniform) mesh size
            dphi= TWO_PI / nlon

            ! Compute grid
            phi = [(real(i - 1, kind=wp) * dphi, i=1, nlon)]
        end associate

    end subroutine get_equally_spaced_longitudes

    subroutine print_to_unformatted_binary_files(self, header)

        ! Dummy arguments
        class(SphericalGrid), intent(inout) :: self
        character(len=*),     intent(in)    :: header

        ! Local variables
        integer(ip)  :: file_unit

        ! Check if object is usable
        call self%assert_initialized('print_to_unformatted_binary_files')

        ! Write latitudes
        associate (theta => self%latitudes)
            open( newunit=file_unit, &
                file=header//self%grid_type//'_latitudes.dat', &
                status='replace', action='write', &
                form='unformatted', access='stream')
            write (file_unit) theta
            close( file_unit)
        end associate

        ! Write longitudes
        associate (phi => self%longitudes)
            open( newunit=file_unit, &
                file=header//self%grid_type//'_longitudes.dat', &
                status='replace', action='write', &
                form='unformatted', access='stream')
            write (file_unit) phi
            close( file_unit)
        end associate

    end subroutine print_to_unformatted_binary_files

end module type_SphericalGrid


    subroutine chimie(co2t,alk,ch,h2co3,hco3,co3,ak1,ak2)
!   -----------------------------------------------------
    implicit none

    double precision co2t,alk,ch,h2co3,hco3,co3,ak1,ak2

    hco3=co2t/(ch/ak1+1.+ak2/ch)
    co3=ak2*hco3/ch
    h2co3=hco3*ch/ak1
    return
    end


	FUNCTION PR_CLOA  ( clcx )
C************************************************************************
C* PR_CLOA								*
C*									*
C* This function computes XCLO from CLCx.  The output is the 		*
C* fractional cloud coverage; x may be L, M, H or T.  The cloud		*
C* coverage values and the corresponding fractional equivalents are:	*
C*									*
C*         CLCx      CLOUD TYPE              XCLO			*
C*									*
C*          0        missing                 0.00			*
C*          1        clear                   0.00			*
C*          2        scattered               0.40			*
C*          3        broken                  0.75			*
C*          4        overcast                1.00			*
C*          5        obscured                1.00			*
C*          6        thin scatterd           0.25			*
C*          7        thin broken             0.60			*
C*          8        thin overcast           0.90			*
C*          9        partially obscured      0.00			*
C*									*
C* REAL PR_CLOA  ( CLCX )						*
C*									*
C* Input parameters:							*
C*	CLCX		REAL		Numeric cloud coverage		*
C*									*
C* Output parameters:							*
C*	PR_CLOA		REAL		Fractional cloud coverage	*
C**									*
C* Log:									*
C* I. Graffman/RDS	11/84						*
C* M. desJardins/GSFC	10/87	Rewritten				*
C* G. Huffman/GSC       7/88   	Documentation and error check		*
C* K. Brill/NMC		11/91	Changed cloud fractions			*
C************************************************************************
        INCLUDE		'GEMPRM.PRM'
C*
	REAL		cloud ( 0: 9 )
C*
	DATA		cloud / 0., 0., .4, .75, 1., 1., .25,
     +				.6, .9, 0. /
C------------------------------------------------------------------------
	icld = clcx
C
C*	If range is invalid, return no clouds.
C
	IF  ( ( icld .lt. 0 ) .or. ( icld .gt. 9 ) )  icld = 0
C
C*	Get fraction from table.
C
	PR_CLOA = cloud ( icld )
C
	RETURN
	END