#:mute
#:include "common.fpp"
#:def axpy(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(x, y, a, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    x(:))
@:args(${TYPE}$, inout, y(:))
@:optional(${TYPE}$, in, a)
@:optional(integer, in, incx, incy)
    integer :: n
@:defaults(a=1, incx=1_wp, incy=1_wp)
    N = size(X)
    call ${F77_NAME}$(n,local_a,x,local_incx,y,local_incy)
end subroutine
#:enddef

#:def copy_swap(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(x, y, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    x(:))
@:args(${TYPE}$, inout, y(:))
@:optional(integer, in, incx, incy)
    integer :: n
@:defaults(incx=1_wp, incy=1_wp)
    N = size(X)
    call ${F77_NAME}$(n,x,local_incx,y,local_incy)
end subroutine
#:enddef

#:def dot_product(MFI_NAME,F77_NAME,TYPE,KIND)
pure function ${MFI_NAME}$(x, y, incx, incy)
@:parameter(integer, wp=${KIND}$)
    ${TYPE}$ :: ${MFI_NAME}$
@:args(${TYPE}$, in, x(:), y(:))
    integer :: n
@:optional(integer, in, incx, incy)
@:defaults(incx=1_wp, incy=1_wp)
    N = size(X)
    ${MFI_NAME}$ = ${F77_NAME}$(n,x,local_incx,y,local_incy)
end function
#:enddef

#:def rotm(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(x, y, param, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, inout, x(:), y(:))
@:args(${TYPE}$, in, param(5))
@:optional(integer, in, incx, incy)
    integer :: n
@:defaults(incx=1_wp, incy=1_wp)
    N = size(X)
    call ${F77_NAME}$(n,x,local_incx,y,local_incy,param)
end subroutine
#:enddef

#:def iamin_iamax(MFI_NAME,F77_NAME,TYPE,KIND)
pure function ${MFI_NAME}$(x, incx)
@:parameter(integer, wp=${KIND}$)
    integer :: ${MFI_NAME}$
@:args(${TYPE}$, in, x(:))
@:optional(integer, in, incx)
    integer :: n
@:defaults(incx=1_wp)
    n = size(x)
    ${MFI_NAME}$ = ${F77_NAME}$(n,x,local_incx)
end function
#:enddef

#:def gbmv(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, y, kl, m, alpha, beta, trans, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    a(:,:), x(:))
@:args(${TYPE}$, inout, y(:))
@:optional(character, in, trans)
@:optional(${TYPE}$,  in, alpha, beta)
@:optional(integer,   in, kl, m, incx,  incy)
    integer :: n, ku, lda
    n = size(a,2)
    lda = max(1,size(a,1))
@:defaults(kl=(lda-1)/2, m=n, trans='N', alpha=1_wp, beta=0_wp, incx=1_wp, incy=1_wp)
    ku = lda-local_kl-1
    call ${F77_NAME}$(local_trans,local_m,n,local_kl,ku,local_alpha,a,lda,x,local_incx,local_beta,y,local_incy)
end subroutine
#:enddef

#:def gemv(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, y, trans, alpha, beta, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    a(:,:), x(:))
@:args(${TYPE}$, inout, y(:))
@:optional(character, in, trans)
@:optional(${TYPE}$,  in, alpha, beta)
@:optional(integer,   in, incx,  incy)
    integer :: m, n, lda
@:defaults(trans='N', alpha=1_wp, beta=0_wp, incx=1_wp, incy=1_wp)
    m = size(a,1)
    n = size(a,2)
    lda = max(1,m)
    call ${F77_NAME}$(local_trans,m,n,local_alpha,a,lda,x,local_incx,local_beta,y,local_incy)
end subroutine
#:enddef

#:def ger_gerc_geru(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, y, alpha, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    x(:), y(:))
@:args(${TYPE}$, inout, a(:,:))
@:optional(${TYPE}$,  in, alpha)
@:optional(integer,   in, incx, incy)
    integer :: m, n, lda
@:defaults(alpha=1_wp, incx=1_wp, incy=1_wp)
    m = size(a,1)
    n = size(a,2)
    lda = max(1,m)
    call ${F77_NAME}$(m,n,local_alpha,x,local_incx,y,local_incy,a,lda)
end subroutine
#:enddef

#:def hbmv_sbmv(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, beta, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in, x(:), a(:,:))
@:args(${TYPE}$, inout, y(:))
@:optional(character, in, uplo)
@:optional(${TYPE}$,  in, alpha, beta)
@:optional(integer,   in, incx, incy)
    integer :: n, k, lda
@:defaults(uplo='U', alpha=1_wp, beta=0_wp, incx=1_wp, incy=1_wp)
    k = size(a,1)-1
    lda = max(1,size(a,1))
    n = size(a,2)
    call ${F77_NAME}$(local_uplo,n,k,local_alpha,a,lda,x,local_incx,local_beta,y,local_incy)
end subroutine
#:enddef

#:def hemv_symv(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, beta, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in, x(:), a(:,:))
@:args(${TYPE}$, inout, y(:))
@:optional(character, in, uplo)
@:optional(${TYPE}$,  in, alpha, beta)
@:optional(integer,   in, incx, incy)
    integer :: n, lda
@:defaults(uplo='U', alpha=1_wp, beta=0_wp, incx=1_wp, incy=1_wp)
    lda = max(1,size(a,1))
    n = size(a,2)
    call ${F77_NAME}$(local_uplo,n,local_alpha,a,lda,x,local_incx,local_beta,y,local_incy)
end subroutine
#:enddef

#:def her_syr(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, uplo, alpha, incx)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    x(:))
@:args(${TYPE}$, inout, a(:,:))
@:optional(character, in, uplo)
@:optional(${TYPE}$,  in, alpha)
@:optional(integer,   in, incx)
    integer :: n, lda
@:defaults(uplo='U', alpha=1_wp, incx=1_wp)
    lda = max(1,size(a,1))
    n = size(a,2)
    call ${F77_NAME}$(local_uplo,n,local_alpha,x,local_incx,a,lda)
end subroutine
#:enddef

#:def her_syr2(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    x(:), y(:))
@:args(${TYPE}$, inout, a(:,:))
@:optional(character, in, uplo)
@:optional(${TYPE}$,  in, alpha)
@:optional(integer,   in, incx, incy)
    integer :: n, lda
@:defaults(uplo='U', alpha=1_wp, incx=1_wp, incy=1_wp)
    lda = max(1,size(a,1))
    n = size(a,2)
    call ${F77_NAME}$(local_uplo,n,local_alpha,x,local_incx,y,local_incy,a,lda)
end subroutine
#:enddef

#:def hpmv_spmv(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(ap, x, y, uplo, alpha, beta, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    x(:), ap(:))
@:args(${TYPE}$, inout, y(:))
@:optional(character, in, uplo)
@:optional(${TYPE}$,  in, alpha, beta)
@:optional(integer,   in, incx, incy)
    integer :: n
@:defaults(uplo='U', alpha=1_wp, beta=0_wp, incx=1_wp, incy=1_wp)
    n = size(x)
    call ${F77_NAME}$(local_uplo,n,local_alpha,ap,x,local_incx,local_beta,y,local_incy)
end subroutine
#:enddef

#:def hpr_spr(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(ap, x, uplo, alpha, incx)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    x(:))
@:args(${TYPE}$, inout, ap(:))
@:optional(character, in, uplo)
@:optional(${TYPE}$,  in, alpha)
@:optional(integer,   in, incx)
    integer :: n
@:defaults(uplo='U', alpha=1_wp, incx=1_wp)
    n = size(x)
    call ${F77_NAME}$(local_uplo,n,local_alpha,x,local_incx,ap)
end subroutine
#:enddef

#:def hpr_spr2(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(ap, x, y, uplo, alpha, incx, incy)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    x(:), y(:))
@:args(${TYPE}$, inout, ap(:))
@:optional(character, in, uplo)
@:optional(${TYPE}$,  in, alpha)
@:optional(integer,   in, incx, incy)
    integer :: n
@:defaults(uplo='U', alpha=1_wp, incx=1_wp, incy=1_wp)
    n = size(x)
    call ${F77_NAME}$(local_uplo,n,local_alpha,x,local_incx,y,local_incy,ap)
end subroutine
#:enddef

#:def tbmv_tbsv(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, uplo, trans, diag, incx)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in, a(:,:))
@:args(${TYPE}$, inout, x(:))
@:optional(character, in, uplo, trans, diag)
@:optional(integer,   in, incx)
    integer :: n, k, lda
@:defaults(uplo='U', trans='N', diag='N', incx=1_wp)
    k = size(a,1)-1
    lda = max(1,size(a,1))
    n = size(a,2)
    call ${F77_NAME}$(local_uplo,local_trans,local_diag,n,k,a,lda,x,local_incx)
end subroutine
#:enddef

#:def tpmv_tpsv(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(ap, x, uplo, trans, diag, incx)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    ap(:))
@:args(${TYPE}$, inout, x(:))
@:optional(character, in, uplo, trans, diag)
@:optional(integer,   in, incx)
    integer :: n
@:defaults(uplo='U', trans='N', diag='N', incx=1_wp)
    n = size(x)
    call ${F77_NAME}$(local_uplo,local_trans,local_diag,n,ap,x,local_incx)
end subroutine
#:enddef

#:def trmv_trsv(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, x, uplo, trans, diag, incx)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in, a(:,:))
@:args(${TYPE}$, inout, x(:))
@:optional(character, in, uplo, trans, diag)
@:optional(integer,   in, incx)
    integer :: n, lda
@:defaults(uplo='U', trans='N', diag='N', incx=1_wp)
    lda = max(1,size(a,1))
    n = size(a,2)
    call ${F77_NAME}$(local_uplo,local_trans,local_diag,n,a,lda,x,local_incx)
end subroutine
#:enddef

#:def gemm(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, b, c, transa, transb, alpha, beta)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    a(:,:), b(:,:))
@:args(${TYPE}$, inout, c(:,:))
@:optional(character, in, transa, transb)
@:optional(${TYPE}$,  in, alpha, beta)
    integer :: m, n, k, lda, ldb, ldc
@:defaults(transa='N', transb='N', alpha=1_wp, beta=0_wp)
    lda = max(1,size(a,1))
    ldb = max(1,size(b,1))
    ldc = max(1,size(c,1))
    m = size(c,1)
    n = size(c,2)
    if (local_transa == 'N' .or. local_transa == 'n') then
        k = size(a,2)
    else
        k = size(a,1)
    end if
    call ${F77_NAME}$(local_transa,local_transb,m,n,k,local_alpha,a,lda,b,ldb,local_beta,c,ldc)
end subroutine
#:enddef

#:def hemm_symm(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, b, c, side, uplo, alpha, beta)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    a(:,:), b(:,:))
@:args(${TYPE}$, inout, c(:,:))
@:optional(character, in, side,  uplo)
@:optional(${TYPE}$,  in, alpha, beta)
    integer :: m, n, lda, ldb, ldc
@:defaults(side='L', uplo='U', alpha=1_wp, beta=0_wp)
    lda = max(1,size(a,1))
    ldb = max(1,size(b,1))
    ldc = max(1,size(c,1))
    m = size(c,1)
    n = size(c,2)
    call ${F77_NAME}$(local_side,local_uplo,m,n,local_alpha,a,lda,b,ldb,local_beta,c,ldc)
end subroutine
#:enddef

#:def herk_syrk(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, c, uplo, trans, alpha, beta)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    a(:,:))
@:args(${TYPE}$, inout, c(:,:))
@:optional(character, in, trans, uplo)
@:optional(${TYPE}$,  in, alpha, beta)
    integer :: n, k, lda, ldc
@:defaults(trans='N', uplo='U', alpha=1_wp, beta=0_wp)
    n = size(c,2)
    if (local_trans == 'N' .or. local_trans == 'n') then
        k = size(a,2)
    else
        k = size(a,1)
    end if
    lda = max(1,size(a,1))
    ldc = max(1,size(c,1))
    call ${F77_NAME}$(local_uplo,local_trans,n,k,local_alpha,a,lda,local_beta,c,ldc)
end subroutine
#:enddef

#:def her2k_syr2k(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, b, c, uplo, trans, alpha, beta)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    a(:,:))
@:args(${TYPE}$, in,    b(:,:))
@:args(${TYPE}$, inout, c(:,:))
@:optional(character, in, trans, uplo)
@:optional(${TYPE}$,  in, alpha, beta)
    integer :: n, k, lda, ldb, ldc
@:defaults(trans='N', uplo='U', alpha=1_wp, beta=0_wp)
    n = size(c,2)
    if (local_trans == 'N' .or. local_trans == 'n') then
        k = size(a,2)
    else
        k = size(a,1)
    end if
    lda = max(1,size(a,1))
    ldb = max(1,size(b,1))
    ldc = max(1,size(c,1))
    call ${F77_NAME}$(local_uplo,local_trans,n,k,local_alpha,a,lda,b,ldb,local_beta,c,ldc)
end subroutine
#:enddef

#:def trmm_trsm(MFI_NAME,F77_NAME,TYPE,KIND)
pure subroutine ${MFI_NAME}$(a, b, side, uplo, transa, diag, alpha)
@:parameter(integer, wp=${KIND}$)
@:args(${TYPE}$, in,    a(:,:))
@:args(${TYPE}$, inout, b(:,:))
@:optional(character, in, side, uplo, transa, diag)
@:optional(${TYPE}$,  in, alpha)
    integer :: m, n, lda, ldb
@:defaults(side='L', uplo='U', transa='N', diag='N', alpha=1_wp)
    m = size(b,1)
    n = size(b,2)
    lda = max(1,size(a,1))
    ldb = max(1,size(b,1))
    call ${F77_NAME}$(local_side,local_uplo,local_transa,local_diag,m,n,local_alpha,a,lda,b,ldb)
end subroutine
#:enddef
#:endmute
module mfi_blas
use iso_fortran_env
use f77_blas
use f77_blas, only: mfi_rotmg => f77_rotmg
implicit none

! BLAS level 1
!$:mfi_interface('?asum',  DEFAULT_TYPES)
$:mfi_interface('?axpy',  DEFAULT_TYPES)
$:mfi_interface('?copy',  DEFAULT_TYPES)
!$:mfi_interface('?dot',   REAL_TYPES)
!$:mfi_interface('sdsdot', REAL_TYPES)
$:mfi_interface('?dotu',  COMPLEX_TYPES)
$:mfi_interface('?dotc',  COMPLEX_TYPES)
!$:mfi_interface('?nrm2',  DEFAULT_TYPES)
!$:mfi_interface('?rot',   DEFAULT_TYPES)
!$:mfi_interface('?rotg',  DEFAULT_TYPES)
$:mfi_interface('?rotm',  REAL_TYPES)
!$:mfi_interface('?rotmg', REAL_TYPES)
!$:f77_interface('?scal')
$:mfi_interface('?swap',  DEFAULT_TYPES)
$:mfi_interface('i?amin', DEFAULT_TYPES)
$:mfi_interface('i?amax', DEFAULT_TYPES)

! BLAS level 2
$:mfi_interface('?gbmv',  DEFAULT_TYPES)
$:mfi_interface('?gemv',  DEFAULT_TYPES)
$:mfi_interface('?ger',   REAL_TYPES)
$:mfi_interface('?gerc',  COMPLEX_TYPES)
$:mfi_interface('?geru',  COMPLEX_TYPES)
$:mfi_interface('?hbmv',  COMPLEX_TYPES)
$:mfi_interface('?hemv',  COMPLEX_TYPES)
$:mfi_interface('?her',   COMPLEX_TYPES)
$:mfi_interface('?her2',  COMPLEX_TYPES)
$:mfi_interface('?hpmv',  COMPLEX_TYPES)
$:mfi_interface('?hpr',   COMPLEX_TYPES)
$:mfi_interface('?hpr2',  COMPLEX_TYPES)
$:mfi_interface('?sbmv',  REAL_TYPES)
$:mfi_interface('?spmv',  REAL_TYPES)
$:mfi_interface('?spr',   REAL_TYPES)
$:mfi_interface('?spr2',  REAL_TYPES)
$:mfi_interface('?symv',  REAL_TYPES)
$:mfi_interface('?syr',   REAL_TYPES)
$:mfi_interface('?syr2',  REAL_TYPES)
$:mfi_interface('?tbmv',  DEFAULT_TYPES)
$:mfi_interface('?tbsv',  DEFAULT_TYPES)
$:mfi_interface('?tpmv',  DEFAULT_TYPES)
$:mfi_interface('?tpsv',  DEFAULT_TYPES)
$:mfi_interface('?trmv',  DEFAULT_TYPES)
$:mfi_interface('?trsv',  DEFAULT_TYPES)

! BLAS level 3
$:mfi_interface('?gemm',  DEFAULT_TYPES)
$:mfi_interface('?hemm',  COMPLEX_TYPES)
$:mfi_interface('?herk',  COMPLEX_TYPES)
$:mfi_interface('?her2k', COMPLEX_TYPES)
$:mfi_interface('?symm',  REAL_TYPES)
$:mfi_interface('?syrk',  REAL_TYPES)
$:mfi_interface('?syr2k', REAL_TYPES)
$:mfi_interface('?trmm',  DEFAULT_TYPES)
$:mfi_interface('?trsm',  DEFAULT_TYPES)

contains

! BLAS level 1
!$:mfi_interface('?asum',  DEFAULT_TYPES)
$:mfi_implement('?axpy',  DEFAULT_TYPES, axpy)
$:mfi_implement('?copy',  DEFAULT_TYPES, copy_swap)
!$:mfi_interface('?dot',   REAL_TYPES)
!$:mfi_interface('sdsdot', REAL_TYPES)
$:mfi_implement('?dotu',  COMPLEX_TYPES, dot_product)
$:mfi_implement('?dotc',  COMPLEX_TYPES, dot_product)
!$:mfi_interface('?nrm2',  DEFAULT_TYPES)
!$:mfi_interface('?rot',   DEFAULT_TYPES)
!$:mfi_interface('?rotg',  DEFAULT_TYPES)
$:mfi_implement('?rotm',  REAL_TYPES, rotm)
!$:mfi_implement('?rotmg', REAL_TYPES, rotmg)
!$:f77_interface('?scal')
$:mfi_implement('?swap',  DEFAULT_TYPES, copy_swap)
$:mfi_implement('i?amin', DEFAULT_TYPES, iamin_iamax)
$:mfi_implement('i?amax', DEFAULT_TYPES, iamin_iamax)

! BLAS level 2
$:mfi_implement('?gbmv',  DEFAULT_TYPES, gbmv)
$:mfi_implement('?gemv',  DEFAULT_TYPES, gemv)
$:mfi_implement('?ger',   REAL_TYPES,    ger_gerc_geru)
$:mfi_implement('?gerc',  COMPLEX_TYPES, ger_gerc_geru)
$:mfi_implement('?geru',  COMPLEX_TYPES, ger_gerc_geru)
$:mfi_implement('?hbmv',  COMPLEX_TYPES, hbmv_sbmv)
$:mfi_implement('?hemv',  COMPLEX_TYPES, hemv_symv)
$:mfi_implement('?her',   COMPLEX_TYPES, her_syr)
$:mfi_implement('?her2',  COMPLEX_TYPES, her_syr2)
$:mfi_implement('?hpmv',  COMPLEX_TYPES, hpmv_spmv)
$:mfi_implement('?hpr',   COMPLEX_TYPES, hpr_spr)
$:mfi_implement('?hpr2',  COMPLEX_TYPES, hpr_spr2)
$:mfi_implement('?sbmv',  REAL_TYPES,    hbmv_sbmv)
$:mfi_implement('?spmv',  REAL_TYPES,    hpmv_spmv)
$:mfi_implement('?spr',   REAL_TYPES,    hpr_spr)
$:mfi_implement('?spr2',  REAL_TYPES,    hpr_spr2)
$:mfi_implement('?symv',  REAL_TYPES,    hemv_symv)
$:mfi_implement('?syr',   REAL_TYPES,    her_syr)
$:mfi_implement('?syr2',  REAL_TYPES,    her_syr2)
$:mfi_implement('?tbmv',  DEFAULT_TYPES, tbmv_tbsv)
$:mfi_implement('?tbsv',  DEFAULT_TYPES, tbmv_tbsv)
$:mfi_implement('?tpmv',  DEFAULT_TYPES, tpmv_tpsv)
$:mfi_implement('?tpsv',  DEFAULT_TYPES, tpmv_tpsv)
$:mfi_implement('?trmv',  DEFAULT_TYPES, trmv_trsv)
$:mfi_implement('?trsv',  DEFAULT_TYPES, trmv_trsv)

! BLAS level 3
$:mfi_implement('?gemm',  DEFAULT_TYPES, gemm)
$:mfi_implement('?hemm',  COMPLEX_TYPES, hemm_symm)
$:mfi_implement('?herk',  COMPLEX_TYPES, herk_syrk)
$:mfi_implement('?her2k', COMPLEX_TYPES, her2k_syr2k)
$:mfi_implement('?symm',  REAL_TYPES,    hemm_symm)
$:mfi_implement('?syrk',  REAL_TYPES,    herk_syrk)
$:mfi_implement('?syr2k', REAL_TYPES,    her2k_syr2k)
$:mfi_implement('?trmm',  DEFAULT_TYPES, trmm_trsm)
$:mfi_implement('?trsm',  DEFAULT_TYPES, trmm_trsm)

end module


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(grid_transfer_routines) grid_transfer_scalar_transform

contains
    !     subroutine trssph(intl, igrida, nlona, nlata, da, igridb, nlonb, nlatb, db, ierror)
    !
    ! Purpose
    !
    !     subroutine trssph transfers data given in array da on a grid on the
    !     full sphere to data in array db on a grid on the full sphere.  the
    !     grids on which da is given and db is generated can be specified
    !     independently of each other (see description below and the arguments
    !     igrida, igridb).  for transferring vector data on the sphere, use
    !     subroutine trvsph.

    !     notice that scalar and vector quantities are fundamentally different
    !     on the sphere.  for example, vectors are discontinuous and multiple
    !     valued at the poles.  scalars are continuous and single valued at the
    !     poles. erroneous results would be produced if one attempted to transfer
    !     vector fields between grids with subroutine trssph applied to each
    !     component of the vector.
    !
    !
    ! Underlying grid assumptions and a description
    !
    !     discussions with the ncar scd data support group and others indicate
    !     there is no standard grid for storing observational or model generated
    !     data on the sphere.  subroutine trssph was designed to handle most
    !     cases likely to be encountered when moving data from one grid format
    !     to another.
    !
    !     the grid on which da is given must be equally spaced in longitude
    !     and either equally spaced or gaussian in latitude (or colatitude).
    !     longitude, which can be either the first or second dimension of da,
    !     subdivides [0, 2pi) excluding the periodic point 2pi.  (co)latitude,
    !     which can be the second or first dimension of da, has south
    !     to north or north to south orientation with increasing subscript
    !     value in da (see the argument igrida).
    !
    !     the grid on which db is generated must be equally spaced in longitude
    !     and either equally spaced or gaussian in latitude (or colatitude).
    !     longitude, which can be either the first or second dimension of db,
    !     subdivides [0, 2pi) excluding the periodic point 2pi.  (co)latitude,
    !     which can be the second or first dimension of db, has south
    !     to north or north to south orientation with increasing subscript
    !     value in db (see the argument igridb).
    !
    !     let nlon be either nlona or nlonb (the number of grid points in
    !     longitude.  the longitude grid subdivides [0, 2pi) into nlon spaced
    !     points
    !
    !          (j-1)*2.*pi/nlon  (j=1, ..., nlon).
    !
    !     it is not necessary to communicate to subroutine trssph whether the
    !     underlying grids are in latitude or colatitude.  it is only necessary
    !     to communicate whether they run south to north or north to south with
    !     increasing subscripts.  a brief discussion of latitude and colatitude
    !     follows.  equally spaced latitude grids are assumed to subdivide
    !     [-pi/2, pi/2] with the south pole at -pi/2 and north pole at pi/2.
    !     equally spaced colatitude grids subdivide [0, pi] with the north pole
    !     at 0 and south pole at pi.  equally spaced partitions on the sphere
    !     include both poles.  gaussian latitude grids subdivide (-pi/2, pi/2)
    !     and gaussian colatitude grids subdivide (0, pi).  gaussian grids do not
    !     include the poles.  the gaussian grid points are uniquely determined by
    !     the size of the partition.  they can be computed in colatitude in
    !     (0, pi) (north to south) in real by the spherepack subroutine
    !     compute_gaussian_latitudes_and_weights.  let nlat be nlata or nlatb if either the da or db grid is
    !     gaussian.  let
    !
    !        north pole                             south pole
    !        ----------                             ----------
    !           0.0    <  cth(1) < ... < cth(nlat)  <   pi
    !
    !
    !     be nlat gaussian colatitude points in the interval (0, pi) and let
    !
    !        south pole                        north pole
    !        ----------                        ----------
    !           -pi/2  < th(1) < ... < th(nlat) < pi/2
    !
    !     be nlat gaussian latitude points in the open interval (-pi/2, pi/2).
    !     these are related by
    !
    !          th(i) = -pi/2 + cth(i)  (i=1, ..., nlat)
    !
    !     if the da or db grid is equally spaced in (co)latitude then
    !
    !          ctht(i) = (i-1)*pi/(nlat-1)
    !                                               (i=1, ..., nlat)
    !          tht(i) = -pi/2 + (i-1)*pi/(nlat-1)
    !
    !     define the equally spaced (north to south) colatitude and (south to
    !     north) latitude grids.
    !
    !
    ! Method (simplified description)
    !
    !     for simplicity, assume da is a nlat by nlon data tabulation and da(i, j)
    !     is the value at latitude theta(i) and longitude phi(j).  then
    !     coefficients a(m, n) and b(m, n) can be determined so that da(i, j) is
    !     approximated by the sum
    !
    !         l-1  n
    !     (a) sum sum pbar(m, n, theta(i))*(a(m, n)*cos(m*phi(j)+b(m, n)*sin(m*phi(j))
    !         n=0 m=0
    !
    !     here pbar(n, m, theta) are the normalized associated legendre functions
    !     and l = min(nlat, (nlon+2)/2).  the determination of a(m, n) and b(m, n)
    !     is called spherical harmonic analysis. a sum of this form can then be
    !     used to regenerate the data in db on the new grid with the known
    !     a(m, n) and b(m, n).  this is referred to spherical harmonic synthesis.
    !     analysis and synthesis subroutines from the software package spherepack,
    !     are used for these purposes.
    !
    !     if da or db is not in mathematical spherical coordinates then array
    !     transposition and/or subscript reordering is used prior to harmonic
    !     analysis and after harmonic synthesis.
    !
    ! Advantages
    !
    !     the use of surface spherical harmonics to transfer spherical grid data
    !     has advantages over pointwise grid interpolation schemes on the sphere.
    !     it is highly accurate.  if p(x, y, z) is any polynomial of degree n or
    !     less in x, y, z cartesian coordinates which is restricted to the surface
    !     of the sphere, then p is exactly represented by sums of the form (a)
    !     whenever n = mino(nlat, nlon/2) (i.e., transfers with spherical harmonics
    !     have n(th) order accuracy.  by way of contrast, bilinear interpolation
    !     schemes are exact for polynomials of degree one.  bicubic interpolation
    !     is exact only for polynomials of degree three or less.  the method
    !     also produces a weighted least squares fit to the data in which waves
    !     are resolved uniformly on the full sphere.  high frequencies, induced
    !     by closeness of grid points near the poles (due to computational
    !     or observational errors) are smoothed.  finally, the method is
    !     consistent with methods used to generate data in numerical spectral
    !     models based on spherical harmonics.  for more discussion of these and
    !     related issues,  see the article: "on the spectral approximation of
    !     discrete scalar and vector functions on the sphere, " siam j. numer.
    !     anal., vol 16. dec 1979, pp. 934-949, by paul swarztrauber.
    !
    !
    ! Comment
    !
    !     on a nlon by nlat or nlat by nlon grid (gaussian or equally spaced)
    !     spherical harmonic analysis generates and synthesis utilizes
    !     min(nlat, (nlon+2)/2)) by nlat coefficients.  consequently, for
    !     da and db,  if either
    !
    !             min(nlatb, (nlonb+2)/2) < min(nlata, (nlona+2)/2)
    !
    !     or if
    !
    !             nlatb < nlata
    !
    !     then all the coefficients generated by an analysis of da cannot be used
    !     in the synthesis which generates db.  in this case "information" can be
    !     lost in generating db.  more precisely, information will be lost if the
    !     analysis of da yields nonzero coefficients which are outside the bounds
    !     determined by the db grid.  nevertheless, transference of values with
    !     spherical harmonics will yield results consistent with grid resolution
    !     and is highly accurate.
    !
    !
    ! Input arguments
    !
    ! ... intl
    !
    !     an initialization argument which should be zero on an initial call to
    !     trssph.  intl should be one if trssph is being recalled and
    !
    !          igrida, nlona, nlata, igridb, nlonb, nlatb
    !
    !     have not changed from the previous call.  if any of these arguments
    !     have changed, intl=0 must be used to avoid undetectable errors.  calls
    !     with intl=1 bypass redundant computation and save time.  it can be used
    !     when transferring multiple data sets with the same underlying grids.
    !
    !
    ! ... igrida
    !
    !     an integer vector dimensioned two which identifies the underlying grid
    !     on the full sphere for the given data array da as follows:
    !
    !     igrida(1)
    !
    !     = -1
    !     if the latitude (or colatitude) grid for da is an equally spaced
    !     partition of [-pi/2, pi/2] ( or [0, pi]) including the poles which
    !     runs north to south
    !
    !     = +1
    !     if the latitude (or colatitude) grid for da is an equally spaced
    !     partition of [-pi/2, pi/2] ( or [0, pi]) including the poles which
    !     runs south to north
    !
    !     = -2
    !     if the latitude (or colatitude) grid for da is a gaussian partition
    !     of (-pi/2, pi/2) ( or (0, pi)) excluding the poles which runs north
    !     to south
    !
    !     = +2
    !     if the latitude (or colatitude) grid for da is a gaussian partition
    !     of (-pi/2, pi/2) ( or (0, pi)) excluding the poles which runs south
    !     north
    !
    !     igrida(2)
    !
    !     = 0 if the underlying grid for da is a nlona by nlata
    !
    !     = 1 if the underlying grid for da is a nlata by nlona
    !
    !
    ! ... nlona
    !
    !     the number of longitude points on the uniform grid which partitions
    !     [0, 2pi) for the given data array da.  nlona is also the first or second
    !     dimension of da (see igrida(2)) in the program which calls trssph.
    !     nlona determines the grid increment in longitude as 2*pi/nlona. for
    !     example nlona = 72 for a five degree grid.  nlona must be greater than
    !     or equal to 4.  the efficiency of the computation is improved when
    !     nlona is a product of small prime numbers
    !
    ! ... nlata
    !
    !     the number of points in the latitude (or colatitude) grid
    !     for the given data array da.  nlata is also the first or second
    !     dimension of da (see igrida(2)) in the program which calls trssph.
    !     if nlata is odd then the equator will be located at the (nlata+1)/2
    !     gaussian grid point.  if nlata is even then the equator will be
    !     located half way between the nlata/2 and nlata/2+1 grid points.
    !
    ! Note:
    !     igrida(1)=-1 or igrida(1)=-2 and igrida(2)=1 corresponds to
    !     the "usual" mathematical spherical coordinate system required
    !     by most of the drivers in spherepack2.  igrida(1)=1 or igrida(1)=2
    !     and igrida(2)=0 corresponds to the "usual" geophysical spherical
    !     coordinate system.
    !
    ! ... da
    !
    !     a two dimensional array that contains the data to be transferred.
    !     da must be dimensioned nlona by nlata in the program calling trssph if
    !     igrida(2) = 0.  da must be dimensioned nlata by nlona in the program
    !     calling trssph if igrida(2) = 1.  if da is not properly dimensioned
    !     and if the latitude (colatitude) values do not run south to north or
    !     north to south as flagged by igrida(1) (self cannot be checked!) then
    !     incorrect results will be produced.
    !
    ! ... igridb
    !
    !     an integer vector dimensioned two which identifies the underlying grid
    !     on the full sphere for the transformed data array db as follows:
    !
    !     igridb(1)
    !
    !     = -1
    !     if the latitude (or colatitude) grid for db is an equally spaced
    !     partition of [-pi/2, pi/2] ( or [0, pi]) including the poles which
    !     north to south
    !
    !     = +1
    !     if the latitude (or colatitude) grid for db is an equally spaced
    !     partition of [-pi/2, pi/2] ( or [0, pi]) including the poles which
    !     south to north
    !
    !     = -2
    !     if the latitude (or colatitude) grid for db is a gaussian partition
    !     of (-pi/2, pi/2) ( or (0, pi)) excluding the poles which runs north to
    !     south
    !
    !     = +2
    !     if the latitude (or colatitude) grid for db is a gaussian partition
    !     of (-pi/2, pi/2) ( or (0, pi)) excluding the poles which runs south to
    !     north
    !
    !
    !     igridb(2)
    !
    !     = 0 if the underlying grid for db is a nlonb by nlatb
    !
    !     = 1 if the underlying grid for db is a nlatb by nlonb
    !
    !
    ! ... nlonb
    !
    !     the number of longitude points on the uniform grid which partitions
    !     [0, 2pi) for the transformed data array db.  nlonb is also the first or
    !     second dimension of db (see igridb(2)) in the program which calls
    !     trssph.  nlonb determines the grid increment in longitude as 2*pi/nlonb.
    !     for example nlonb = 72 for a five degree grid.  nlonb must be greater
    !     than or equal to 4.  the efficiency of the computation is improved when
    !     nlonb is a product of small prime numbers
    !
    ! ... nlatb
    !
    !     the number of points in the latitude (or colatitude) grid
    !     for the transformed data array db.  nlatb is also the first or second
    !     dimension of db (see igridb(2)) in the program which calls trssph.
    !     if nlatb is odd then the equator will be located at the (nlatb+1)/2
    !     gaussian grid point.  if nlatb is even then the equator will be
    !     located half way between the nlatb/2 and nlatb/2+1 grid points.
    !
    ! Output arguments
    !
    !
    ! ... db
    !
    !     a two dimensional array that contains the transformed data.  db
    !     must be dimensioned nlonb by nlatb in the program calling trssph if
    !     igridb(2) = 0 or 1.  db must be dimensioned nlatb by nlonb in the
    !     program calling trssph if igridb(2) = 1.  if db is not properly
    !     dimensioned and if the latitude (colatitude) values do not run south
    !     north or north to south as flagged by igrdb(1) (self cannot be checked!)
    !     then incorrect results will be produced.
    !
    ! Error argument
    !
    ! ... ierror = 0  if no errors are detected
    !
    !         = 1  if intl is not 0 or 1
    !
    !         = 2  if igrida(1) is not -1 or +1 or -2 or +2
    !
    !         = 3  if igrida(2) is not 0 or 1
    !
    !         = 4  if nlona is less than 4
    !
    !         = 5  if nlata is less than 3
    !
    !         = 6  if igridb(1) is not -1 or +1 or -2 or +2
    !
    !         = 7  if igridb(2) is not 0 or 1
    !
    !         = 8  if nlonb is less than 4
    !
    !         = 9  if nlatb is less than 3
    !
    !         =12  indicates failure in an eigenvalue routine which computes
    !              gaussian weights and points
    !
    module subroutine trssph(intl, igrida, nlona, nlata, da, igridb, nlonb, nlatb, db, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: intl
        integer(ip), intent(in)     :: igrida(2)
        integer(ip), intent(in)     :: nlona
        integer(ip), intent(in)     :: nlata
        real(wp),    intent(inout)  :: da(:,:)
        integer(ip), intent(in)     :: igridb(2)
        integer(ip), intent(in)     :: nlonb
        integer(ip), intent(in)     :: nlatb
        real(wp),    intent(out)    :: db(:,:)
        integer(ip), intent(out)    :: ierror

        ! Local variables
        integer(ip)                  :: igrda, igrdb, mdab_a, mdab_b
        real(wp), allocatable        :: wavetable_a(:), wavetable_b(:)
        integer(ip), parameter       :: NT = 1, ISYM = 0
        type(ScalarForwardTransform)  :: analysis_util
        type(ScalarBackwardTransform) :: synthesis_util

        ! Check calling arguments
        associate( &
            ig1 => igrida(1), &
            ig2 => igrida(2) &
            )
            if (intl*(intl-1)/=0) then
                ierror = 1
            else if ((ig1-1)*(ig1+1)*(ig1-2)*(ig1+2)/=0) then
                ierror = 2
            else if (ig2*(ig2-1)/=0) then
                ierror = 3
            else if (nlona < 4) then
                ierror = 4
            else if (nlata <3) then
                ierror = 5
            else if ((ig1-1)*(ig1+1)*(ig1-2)*(ig1+2) /= 0) then
                ierror = 6
            else if (ig2*(ig2-1) /= 0) then
                ierror = 7
            else if (nlonb < 4) then
                ierror = 8
            else if (nlatb < 3) then
                ierror = 9
            else
                ierror = 0
            end if
        end associate

        igrda = abs(igrida(1))
        igrdb = abs(igridb(1))

        if (igrda == 1) then
            ! Initialize wavetable for equally spaced analysis
            call analysis_util%initialize_shaec(nlata, nlona, wavetable_a, ierror)
        else
            ! Initialize wavetable for gaussian analysis
            call analysis_util%initialize_shagc(nlata, nlona, wavetable_a, ierror)
        end if

        if (igrdb == 2) then
            ! Initialize wavetable for gaussian synthesis
            call synthesis_util%initialize_shsgc(nlatb, nlonb, wavetable_b, ierror)
        else
            ! Initialize wsave for equally spaced synthesis
            call synthesis_util%initialize_shsec(nlatb, nlonb, wavetable_b, ierror)
        end if

        ! Transpose and/or reorder (co)latitude if necessary for da
        ! (arrays must have latitude (colatitude) as the first dimension
        ! and run north to south for spherepack software)
        if (igrida(2) == 0) call transpose_array(nlona, nlata, da)
        if (igrida(1) > 0) call reverse_colatitudes(nlata, nlona, da)

        mdab_a = min(nlata, (nlona + 2)/2)
        mdab_b = min(nlatb, (nlonb + 2)/2)

        block
            real(wp), dimension(mdab_a, nlata, NT) :: br_a, bi_a
            real(wp), dimension(mdab_b, nlatb, NT) :: br_b, bi_b

            if (igrda == 2) then
                ! Spherical harmonic analysis of "adjusted" da on gaussian grid
                call analysis_util%shagc(nlata, nlona, ISYM, NT, da, nlata, nlona, br_a, &
                    bi_a, mdab_a, nlata, wavetable_a, ierror)
            else
                ! Spherical harmonic analysis of "adjusted" da on equally spaced grid
                call analysis_util%shaec(nlata, nlona, ISYM, NT, da, nlata, nlona, br_a, &
                    bi_a, mdab_a, nlata, wavetable_a, ierror)
            end if

            ! Transfer da grid coefficients to db grid coefficients
            ! truncating to zero as necessary
            call transfer_scalar_coeff(mdab_a, nlata, br_a, bi_a, mdab_b, nlatb, br_b, &
                bi_b)

            if (igrdb == 1) then
                ! Spherical harmonic synthesis on nlatb by nlonb equally spaced grid
                call synthesis_util%shsec(nlatb, nlonb, ISYM, NT, db, nlatb, nlonb, br_b, &
                    bi_b, mdab_b, nlatb, wavetable_b, ierror)
            else
                ! Spherical harmonic synthesis on nlatb by nlonb gaussian grid
                call synthesis_util%shsgc(nlatb, nlonb, ISYM, NT, db, nlatb, nlonb, br_b, &
                    bi_b, mdab_b, nlatb, wavetable_b, ierror)
            end if
        end block

        ! Both da, db are currently latitude by longitude north to south arrays
        ! restore da and set db to agree with flags in igrida and igridb
        if (igrida(1) > 0) call reverse_colatitudes(nlata, nlona, da)

        if (igridb(1) > 0) call reverse_colatitudes(nlatb, nlonb, db)

        if (igrida(2) == 0) call transpose_array(nlata, nlona, da)

        if (igridb(2) == 0) call transpose_array(nlatb, nlonb, db)

        ! Release memory
        deallocate (wavetable_a)
        deallocate (wavetable_b)

    end subroutine trssph

end submodule grid_transfer_scalar_transform


module forlab_sorting
    use stdlib_kinds, only: sp, dp, qp, &
                            int8, int16, int32, int64
    use forlab_stats, only: randu
    implicit none
    private

    public :: argsort, sort

    interface argsort
        !! argsort generates the indices that would sort an array.
        module function argsort_int8(x, order)
            integer, allocatable::argsort_int8(:)
            integer(int8), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function argsort_int8
        module function argsort_int16(x, order)
            integer, allocatable::argsort_int16(:)
            integer(int16), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function argsort_int16
        module function argsort_int32(x, order)
            integer, allocatable::argsort_int32(:)
            integer(int32), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function argsort_int32
        module function argsort_int64(x, order)
            integer, allocatable::argsort_int64(:)
            integer(int64), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function argsort_int64
        module function argsort_sp(x, order)
            integer, allocatable::argsort_sp(:)
            real(sp), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function argsort_sp
        module function argsort_dp(x, order)
            integer, allocatable::argsort_dp(:)
            real(dp), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function argsort_dp
    end interface argsort

    interface sort
        module function sort_int8(x, order)
            integer(int8), allocatable::sort_int8(:)
            integer(int8), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function sort_int8
        module function sort_int16(x, order)
            integer(int16), allocatable::sort_int16(:)
            integer(int16), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function sort_int16
        module function sort_int32(x, order)
            integer(int32), allocatable::sort_int32(:)
            integer(int32), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function sort_int32
        module function sort_int64(x, order)
            integer(int64), allocatable::sort_int64(:)
            integer(int64), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function sort_int64
        module function sort_sp(x, order)
            real(sp), allocatable::sort_sp(:)
            real(sp), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function sort_sp
        module function sort_dp(x, order)
            real(dp), allocatable::sort_dp(:)
            real(dp), intent(in)::x(:)
            integer, optional, intent(in)::order
        end function sort_dp
    end interface sort

end module forlab_sorting


!!# SUBROUTINE MODULE <<USR_PolyExpoMoment>>
MODULE USR_PolyExpoMoment

!!## PURPOSE
!! Return the numerically stable calculation of the simplified
!! exponential moment functions, $PM_n(x)$.
!!
!! $$ PM_n(x) = \int_0^1 (t)^n Exp( -x t ) dt \quad n=0,1,...$$

!!## DETAILS
!! Note that Miller and Mathews have defined the exponential
!! moment functions $M_n$,
!!
!! $$ M_n(x) = \int_0^1 (1-t)^n Exp( -x t ) dt \quad n=0,1,...$$
!!
!! where the presence of $(1-t)^n$ makes it difficult to rewrite
!! moments of polynomial expressions of higher order than $t$, i.e.
!! $t^2$.

!!## DETAILS
!! Wouldn't use for $n>10$ or so, although this case is hardly ever
!! needed.

!!## REFERENCES
! D. J. Miller, K. A. Mathews*, and C. R. Brennan, "SPLIT-CELL
! DISCRETE ORDINATES TRANSPORT ON AN UNSTRUCTURED GRID OF
! TRIANGULAR CELLS", TRANSPORT THEORY AND STATISTICAL PHYSICS,
! 25(7). 833-867 (1996).

!!## OWNER
! [waw] william.wieselquist@gmail.com

!!## DEPENDENCIES
USE KND_IntrinsicTypes                  !!((01-A-KND_IntrinsicTypes.f90))
USE FUN_Factorial                       !!((06-B-FUN_Factorial.f90))
USE FUN_Integrate1_aq                   !!((06-B-FUN_Integrate1_aq.f90))
USE FUN_Default                         !!((04-A-FUN_Default.f90))
USE FUN_CoefficientBinomial             !!((10-B-FUN_CoefficientBinomial.f90))
USE FUN_STR                             !!((05-B-FUN_STR.f90))
USE FUN_FactorialLn                     !!((08-B-FUN_FactorialLn.f90))
USE FUN_IsApprox                        !!((03-A-FUN_IsApprox.f90))
USE FUN_NewFile                         !!((05-B-FUN_NewFile.f90))
USE FUN_Random                          !!((03-A-FUN_Random.f90))
USE LIB_FunctionParser                  !!((04-B-LIB_FunctionParser.f90))
USE FUN_GammaLn                         !!((05-B-FUN_GammaLn.f90))
USE LIB_NSWCspecfunc                    !!((03-C-LIB_NSWCspecfunc.f90))
USE PAR_FactorialsEtc                   !!((02-C-PAR_FactorialsEtc.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## LOCAL VARIABLES
!! * the kind for this module
INTEGER,PARAMETER  :: KIND_PM=KIND_Rdp
!! * the small $x$ value for which we start to use
!!   a series expansion (must be less than 1)
REAL(KIND_PM) :: SMALL_x=0.1_KIND_PM
!! * the default tolerance (only needed for series expansion truncation)
REAL(KIND_PM) :: PM_DEFAULT_TOL    =10._KIND_PM*EPSILON(1._KIND_PM)
REAL(KIND_PM) :: PM_DEFAULT_TESTTOL=1.E-12_KIND_PM

!!## PUBLIC ACCESS LIST
PUBLIC :: KIND_PM
PUBLIC :: SMALL_X
PUBLIC :: PM_DEFAULT_TOL
PUBLIC :: PM_DEFAULT_TESTTOL

PUBLIC :: PolyExpoMoment
PUBLIC :: PolyExpoMomentWithB
PUBLIC :: PolyExpoMoment2
PUBLIC :: PRINT_PolyExpoMoment
PUBLIC :: PRINT_PolyExpoMoment2
PUBLIC :: CHECK1_PolyExpoMoment
PUBLIC :: CHECK1_PolyExpoMoment2
PUBLIC :: CHECK1_EVAL_Pij
PUBLIC :: EVAL_Pij

LOGICAL,PARAMETER :: FORCE_FACTORIAL_EVAL = .FALSE.

CONTAINS

!!### FUNCTION <<EVAL_Pij>>
FUNCTION EVAL_Pij( i , j , b1 , bt ) RESULT(EVAL)
!!#### PURPOSE
!! Evaluate polynomial moments, $\mathcal{P}_{ij}$,
!!
!!\begin{eqnarray}\label{polymomdef}
!!\mathcal{P}_{ij} &=& \int_0^1 d\tilde{t} \, \tilde{t}^i \int_0^{B(\tilde{t})}\, \hspace{-10pt} d\tilde{s} \tilde{s}^j \\                 &=& \frac{1}{j+1} \sum_{k=0}^{j+1} \frac{(j+1)!}{(j+1-k)!\,k!} \frac{B_t^{k} B_1^{j+1-k} }{k+i+1}.\nonumber
!!\end{eqnarray}

!!#### REQUIRED INPUT
REAL(KIND_PM),INTENT(IN) :: b1,bt
INTEGER,INTENT(IN) :: i,j

!!#### REQUIRED OUTPUT
REAL(KIND_PM) :: EVAL

!!#### LOCAL VARIABLES
REAL(KIND_PM) :: factor,b1pow,btpow,sum,coeff
INTEGER :: k

!!--begin--
sum=0._KIND_PM
DO k=0,j+1

 !safer this way for large factorials
 if( FORCE_FACTORIAL_EVAL .OR. j+1>MAX_N_BinomialCoeff )then
  coeff = Exp( FactorialLn(j+1)-FactorialLn(j+1-k)-FactorialLn(k) )
 else
  coeff = c_BinomialCoeff(k,j+1)
 end if
 factor = coeff / REAL(k+i+1,KIND_PM)

 b1pow = b1**(j+1-k)
 btpow = bt**(k)
 sum = sum + b1pow*btpow*factor
 !/factor
END DO
EVAL = sum/REAL(j+1,KIND_PM)

!!--end--
END FUNCTION

!!### FUNCTION <<CHECK1_EVAL_Pij>>
FUNCTION CHECK1_EVAL_Pij() RESULT(Pass)

!!#### PURPOSE
!! Check a couple polynomial moments, $\mathcal{P}_{ij}$.

!!#### REQUIRED OUTPUT
LOGICAL :: Pass
REAL(KIND_PM) :: b1,bt,mine,exact

!!--begin--

b1=0.1_KIND_PM
bt=0.9_KIND_PM
mine = EVAL_Pij( 0 , 0 , b1 , bt )
exact = 11._KIND_PM/20._KIND_PM
Pass = IsApprox(mine,exact)
IF( .NOT.Pass )RETURN

b1=0.1_KIND_PM
bt=0.9_KIND_PM
mine = EVAL_Pij( 0 , 5 , b1 , bt )
exact = 1111111._KIND_PM/42000000._KIND_PM
Pass = IsApprox(mine,exact)
IF( .NOT.Pass )RETURN

b1=0.1_KIND_PM
bt=0.9_KIND_PM
mine = EVAL_Pij( 5 , 0 , b1 , bt )
exact = 61._KIND_PM/420._KIND_PM
Pass = IsApprox(mine,exact)
IF( .NOT.Pass )RETURN

b1=0.0_KIND_PM
bt=1.0_KIND_PM
mine = EVAL_Pij( 1 , 0 , b1 , bt )
exact = 1._KIND_PM/3._KIND_PM
Pass = IsApprox(mine,exact)
IF( .NOT.Pass )RETURN

b1=1.0_KIND_PM
bt=0.0_KIND_PM
mine = EVAL_Pij( 1 , 0 , b1 , bt )
exact = 0.5_KIND_PM
Pass = IsApprox(mine,exact)
IF( .NOT.Pass )RETURN

!!--end--
END FUNCTION

!!### SUBROUTINE <<PolyExpoMoment>>
SUBROUTINE PolyExpoMoment( MaxN , x , x0 , c , PM , tol )

!!#### PURPOSE
!! Return the simplified exponential moments $PM_n(x)$, for $n=0,1,...,N$.
!! For small arguments <x>, an expansion is used.

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: MaxN
REAL(KIND_PM),INTENT(IN) :: x
REAL(KIND_PM),INTENT(IN) :: x0,c

!!#### REQUIRED OUTPUT
REAL(KIND_PM),INTENT(OUT) :: PM(0:MaxN)

!!#### OPTIONAL INPUT

REAL(KIND_PM),INTENT(IN),OPTIONAL :: tol

!!#### LOCAL VARIABLES
INTEGER :: n,ierr
REAL(KIND_PM) :: tol_,inside,PMrecurse(0:MaxN),NInt,ZExp,ExpX,a,ans,qans

!!--begin--

tol_ = DEFAULT( PM_DEFAULT_TOL , tol )
PM = 0._KIND_PM

!standard recursive algorithm if x is not too small
IF( x>SMALL_x )THEN

 !normal forward recursion (for most cases)
 IF( x>REAL(MaxN,KIND(x)) .OR. MaxN<5 )THEN

  inside = 1._KIND_PM - EXP(-x)
  PM(0)        = inside/x0
  PMrecurse(0) = inside/x

  DO n=1,MaxN
   inside = n*PMrecurse(n-1) - EXP(-x)
   PM(n)        = inside/x0
   PMrecurse(n) = inside/x
  END DO

 !backward recursion
 ELSE

  !remove need for numerical evaluation
  ExpX = EXP(-x)
  !NInt = NPolyExpoMoment0(MaxN,x,tol_)
  a=1.0_KIND_Rdp + REAL(MaxN,KIND_Rdp)
  CALL dgrat(a, x, ans, qans, ierr)
  NInt=EXP(GammaLn(a))*ans/(x**a)
  PM(MaxN)        = c*NInt
  PMrecurse(MaxN) =   NInt
  DO n=MaxN,1,-1
   PM(n-1)        = ( x0*PMrecurse(n) + ExpX )/REAL(n,KIND(x))
   PMrecurse(n-1) = (  x*PMrecurse(n) + ExpX )/REAL(n,KIND(x))
  END DO

 END IF

!x is small (use backward recursion)
ELSE

 !get the values directly
 DO n=MaxN,0,-1
  PM(n) = c*ZeroExpansion(n,x,tol_)
 END DO

 !get the values by recursion
 !ZExp            = ZeroExpansion(MaxN,x,tol_)
 !PM(MaxN)        = c*ZExp
 !PMrecurse(MaxN) =   ZExp
 !ExpX = EXP(-x)
 !DO n=MaxN,1,-1
 ! PM(n-1)        = ( x0*PMrecurse(n) + ExpX )/REAL(n,KIND(x))
 ! PMrecurse(n-1) = (  x*PMrecurse(n) + ExpX )/REAL(n,KIND(x))
 !END DO

END IF

!!--end--
END SUBROUTINE

!!### FUNCTION <<ZeroExpansion>>
FUNCTION ZeroExpansion(n,x,tol) RESULT(val)

!!#### PURPOSE
!! Return the result MacLaurin expansion of the simplified
!! exponential moment function, $PM_n(x)$ for small $x$.

!!#### REQUIRED INPUT
!! * moment order $n$
!! * argument of simplified exponential moment function $PM_n(x)$
!! * tolerance on solution
INTEGER      ,INTENT(IN) :: n
REAL(KIND_PM),INTENT(IN) :: x,tol

!!#### LOCAL VARIABLES
INTEGER       :: k,i
REAL(KIND_PM) :: val,terms(0:100) ![hack] assume 100 terms needed at most (1-3 terms expected)
REAL(KIND_PM) :: invfact

!!--begin--

k = -1
DO
 k = k + 1

 IF( FORCE_FACTORIAL_EVAL .OR. k>MAX_N_Factorial )THEN
  invfact = EXP(-FactorialLn(k))
 ELSE
  invfact = REAL( c_InvFactorial(k) , KIND_Rdp)
 END IF

 terms(k) = invfact * (-x)**k / ( REAL(n+k+1,KIND_Rdp) )

 !WRITE(*,*)"terms(k))=",terms(k)
 !relative tolerance
 IF( ABS(terms(k))<tol*terms(0) )EXIT
END DO

!accumulate terms in reverse order to not lose precision
!(terms are monotonically decreasing with k)
val = 0._KIND_PM
DO i=k,0,-1
 val = val + terms(i)
 !WRITE(*,*)"val=",val
END DO

!!--end--
END FUNCTION

!!### SUBROUTINE <<PolyExpoMomentWithB>>
SUBROUTINE PolyExpoMomentWithB( MaxN , x , x0 , c , b , PM , tol )

!!#### PURPOSE
!! Return the simplified exponential moments $PM_n(x)$, for $n=0,1,...,N$.
!! For small arguments <x>, an expansion is used, with $b$ (instead
!! of 1) as the upper bound.

!!#### REQUIRED INPUT
INTEGER      ,INTENT(IN) :: MaxN
REAL(KIND_PM),INTENT(IN) :: x
REAL(KIND_PM),INTENT(IN) :: x0,c,b

!!#### REQUIRED OUTPUT
REAL(KIND_PM),INTENT(OUT) :: PM(0:MaxN)

!!#### OPTIONAL INPUT

REAL(KIND_PM),INTENT(IN),OPTIONAL :: tol

!!#### LOCAL VARIABLES
INTEGER       :: n,ierr
REAL(KIND_PM) :: tol_,inside,PMrecurse(0:MaxN),NInt,ZExp,ExpX,a,ans,qans

!!--begin--

tol_ = DEFAULT( PM_DEFAULT_TOL , tol )
PM = 0._KIND_PM

!standard recursive algorithm if x is not too small
IF( x>SMALL_x )THEN

 !normal forward recursion (for most cases)
 IF( x>REAL(MaxN,KIND(x)) .OR. MaxN<5 )THEN
  !write(*,*)"forward recursion, x=",x,"b=",b

  ExpX         = EXP(-x*b)
  inside       = 1._KIND_PM - ExpX
  PM(0)        = inside/x0
  PMrecurse(0) = inside/x

  DO n=1,MaxN
   inside       = n*PMrecurse(n-1) - (b**n)*ExpX
   PM(n)        = inside/x0
   PMrecurse(n) = inside/x
  END DO

 !backward recursion
 ELSE

  !write(*,*)"backward recursion"
  ExpX = EXP(-x*b)
  !remove need for numerical evaluation
  !NInt = NPolyExpoMoment0(MaxN,x,tol_)
  a=1.0_KIND_Rdp + REAL(MaxN,KIND_Rdp)
  CALL dgrat(a, x*b, ans, qans, ierr)
  NInt=EXP(GammaLn(a))*ans/(x**a)
  PM(MaxN)        = c*NInt
  PMrecurse(MaxN) =   NInt
  DO n=MaxN-1,0,-1
   PM(n)        = ( x0*PMrecurse(n+1) + (b**(n+1))*ExpX )/REAL(n+1,KIND(x))
   PMrecurse(n) = (  x*PMrecurse(n+1) + (b**(n+1))*ExpX )/REAL(n+1,KIND(x))
  END DO

 END IF

!x is small (use backward recursion)
ELSE
 !write(*,*)"small x"
 !get the values directly
 DO n=MaxN,0,-1
  PM(n) = c*ZeroExpansionWithB(n,x,tol_,b)
 END DO

END IF

!!--end--
END SUBROUTINE

!!### FUNCTION <<ZeroExpansionWithB>>
FUNCTION ZeroExpansionWithB(n,x,tol,b) RESULT(val)

!!#### PURPOSE
!! Return the result MacLaurin expansion of the simplified
!! exponential moment function, $PM_n(x)$ for small $x$.

!!#### REQUIRED INPUT
!! * moment order $n$
!! * argument of simplified exponential moment function $PM_n(x)$
!! * tolerance on solution
!! * the upper bound $b \in [0,1]$
INTEGER      ,INTENT(IN) :: n
REAL(KIND_PM),INTENT(IN) :: x,tol,b

!!#### LOCAL VARIABLES
INTEGER       :: k,i
REAL(KIND_PM) :: val,terms(0:100) ![hack] assume 100 terms needed at most (1-3 terms expected)
REAL(KIND_PM) :: invfact

!!--begin--

k = -1
DO
 k = k + 1

 IF( FORCE_FACTORIAL_EVAL .OR. k>MAX_N_Factorial )THEN
  invfact = EXP(-FactorialLn(k))
 ELSE
  invfact = REAL( c_InvFactorial(k) , KIND_Rdp)
 END IF

 terms(k) = invfact * (-x*b)**k / ( REAL(n+k+1,KIND_Rdp) )

 !relative tolerance
 IF( ABS(terms(k))<tol*terms(0) )EXIT

END DO

!accumulate terms in reverse order to not lose precision
!(terms are monotonically decreasing with k)
val = 0._KIND_PM
DO i=k,0,-1
 val = val + terms(i)
END DO

!!--end--
END FUNCTION
!!### SUBROUTINE <<PRINT_PolyExpoMoment>>
SUBROUTINE PRINT_PolyExpoMoment(N,Unit,xstart,xdiv,ndiv,tol,&
  PrintDerivative)

!!#### MODULES
USE FUN_STR                             !!((05-B-FUN_STR.f90))
USE FUN_Default                         !!((04-A-FUN_Default.f90))
USE VAR_Units,ONLY: DEFAULT_OUTPUT_UNIT !!((03-A-VAR_Units.f90))

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: N

!!#### OPTIONAL INPUT
INTEGER       ,OPTIONAL,INTENT(IN) :: Unit
REAL(KIND_PM) ,OPTIONAL,INTENT(IN) :: xstart,xdiv,tol
INTEGER       ,OPTIONAL,INTENT(IN) :: ndiv
LOGICAL       ,OPTIONAL,INTENT(IN) :: PrintDerivative

!!#### LOCAL VARIABLES
REAL(KIND_PM) :: x,PM(0:N),xstart_,xdiv_,dPM(0:N),PMlast(0:N),xlast
INTEGER        :: i,Unit_,ndiv_
LOGICAL        :: PrintDerivative_

!!--begin--
xstart_ = Default( 10._KIND_PM , xstart )
xdiv_   = Default( 10._KIND_PM , xdiv )
Unit_   = Default( DEFAULT_OUTPUT_UNIT , Unit )
ndiv_   = Default( 10 , ndiv )
PrintDerivative_ = Default( .FALSE. , PrintDerivative )

IF( .NOT.PrintDerivative_ )THEN
 x=xstart_
 DO i=1,ndiv_+1
  CALL PolyExpoMoment( N , x , x0=x , c=1._KIND_PM , PM=PM(0:N) ,tol=tol )
  WRITE(Unit_,"("//TRIM(STR(N+2))//"(E,1x))")x,PM(0:N)
  x=x/xdiv_
 END DO
ELSE
 x=xstart_
 xlast=xstart_*xdiv_
 CALL PolyExpoMoment( N , xlast , x0=xlast , c=1._KIND_PM , PM=PMlast(0:N) ,tol=tol )
 DO i=1,ndiv_+1
  CALL PolyExpoMoment( N , x , x0=x , c=1._KIND_PM , PM=PM(0:N) ,tol=tol )
  dPM = (PM-PMlast)/(x-xlast)
  WRITE(Unit_,"("//TRIM(STR(2*(N+1)+1))//"(E,1x))")x,PM(0:N),dPM(0:N)
  PMlast=PM
  xlast=x
  x=x/xdiv_
 END DO
END IF
!!--end--
END SUBROUTINE

!!### SUBROUTINE <<PRINT_PolyExpoMoment2>>
SUBROUTINE PRINT_PolyExpoMoment2(i,MaxN,bt,b1,Unit,xstart,xdiv,ndiv,tol)

!!#### MODULES
USE FUN_STR                             !!((05-B-FUN_STR.f90))
USE FUN_Default                         !!((04-A-FUN_Default.f90))
USE VAR_Units,ONLY: DEFAULT_OUTPUT_UNIT !!((03-A-VAR_Units.f90))

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: i,MaxN
REAL(KIND_PM),INTENT(IN) :: bt,b1

!!#### OPTIONAL INPUT
INTEGER       ,OPTIONAL,INTENT(IN) :: Unit
REAL(KIND_PM),OPTIONAL,INTENT(IN) :: xstart,xdiv,tol
INTEGER       ,OPTIONAL,INTENT(IN) :: ndiv

!!#### LOCAL VARIABLES
REAL(KIND_PM) :: x,PM(0:MaxN),xstart_,xdiv_
INTEGER        :: k,Unit_,ndiv_

!!--begin--
xstart_ = Default( 10._KIND_PM , xstart )
xdiv_   = Default( 10._KIND_PM , xdiv )
Unit_   = Default( DEFAULT_OUTPUT_UNIT , Unit )
ndiv_   = Default( 10 , ndiv )

x=xstart_
DO k=1,ndiv_+1
 CALL PolyExpoMoment2(i,MaxN,x,bt,b1,x0=x,c=1._KIND_PM,PM=PM)
 WRITE(Unit_,"("//TRIM(STR(MaxN+2))//"(E,1x))")x,PM(0:MaxN)
 x=x/xdiv_
END DO

!!--end--
END SUBROUTINE

!!### FUNCTION <<CHECK1_PolyExpoMoment2>>
FUNCTION CHECK1_PolyExpoMoment2(smallside,xstart,xdiv,ndiv,tol) RESULT(Pass)
!!#### PURPOSE
!! Check the 2D simplified exponential moment for:
!!
!! * positivity for all $x$
!!   $$ PM(x) >0 \forall x $$
!!
!! * boundedness for all $x$
!!   $$ PM(x) \in [0,1] \forall x $$
!!
!! * monotonic decrease with respect to $x$
!!   $$ PM(x+dx) < PM(x) \forall x $$
!!
!! * monotonic decrease with respect to $n$ and $i$
!!   $$ NI_{ni} < NI_{i'n} \quad i'<i $$
!!   $$ NI_{ni} < NI_{in'} \quad n'<n $$

!!#### REQUIRED INPUT
REAL(KIND_PM),OPTIONAL,INTENT(IN) :: smallside

!!#### OPTIONAL INPUT
REAL(KIND_PM),OPTIONAL,INTENT(IN) :: xstart,xdiv
INTEGER       ,OPTIONAL,INTENT(IN) :: ndiv
REAL(KIND_PM),OPTIONAL,INTENT(IN) :: tol

!!#### REQUIRED OUTPUT
LOGICAL :: Pass

!!#### LOCAL VARIABLES
INTEGER,PARAMETER :: MaxN=4,MaxI=4
REAL(KIND_PM) :: x,xstart_,xdiv_
INTEGER        :: k,Unit_,ndiv_,i,n
REAL(KIND_PM) :: bt,b1,tol_
LOGICAL        :: PassMonX,PassPos,PassBound,PassMonI,PassMonN
REAL(KIND_PM),ALLOCATABLE :: Allx(:),AllPM(:,:,:)
!!--begin--

xstart_ = Default( 10._KIND_PM , xstart )
xdiv_   = Default( 10._KIND_PM , xdiv )
ndiv_   = Default( 10 , ndiv )
tol_    = Default( PM_DEFAULT_TOL , tol )

!allocate local arrays and setup the x values we will test
ALLOCATE( AllX(ndiv_+1) ,AllPM(0:MaxI,0:MaxN,ndiv_+1) )
x=xstart_
DO k=1,ndiv_+1
 AllX(k)=x
 x=x/xdiv_
END DO

!NOTE
!b1 and bt must be positive and less than 1
!difference between top and bottom sides is given as
!
!         ds(t) = bt*t + b1   ,   for t=0->1
!
! thus side 1 has length b1 and
!      side 2 has length bt+b1.

IF( .NOT.PRESENT(smallside) )THEN
 !******default*******
 !     _
 ! _ - |
 ! |   |
 ! |   |
 ! - _ |
 !     -
 b1=0.9_KIND_PM
 bt=0.1_KIND_PM
ELSE
 b1=MAX(MIN(smallside,1._KIND_PM),0._KIND_PM)
 bt=1.0_KIND_PM-b1
END IF

DO k=1,ndiv_+1

 DO i=0,MaxI
  CALL PolyExpoMoment2(i,MaxN,AllX(k),bt,b1,x0=AllX(k),c=1._KIND_PM,&
    PM=AllPM(i,0:MaxN,k) , tol=tol_ )
 END DO

END DO

!check positivity and boundedness
PassPos = ALL(AllPM>=0._KIND_PM)
PassBound = ALL(AllPM<=1._KIND_PM)

!check monotonic decreasing with respect to x, i, n
PassMonI = MonoCheck1( AllPM )
PassMonN = MonoCheck2( AllPM )
PassMonX = MonoCheck3( AllPM )

!final return
Pass = PassMonX .AND. PassPos .AND. PassBound

!!wrapup
DEALLOCATE( AllX,AllPM)

!!--end--
END FUNCTION

!!### SUBROUTINE <<PolyExpoMoment2>>
SUBROUTINE PolyExpoMoment2(i,MaxN,x,bt,b1,x0,c,PM,tol)

!!#### PURPOSE
!! Return $\tilde{PM}_{in}$ for a single $i$ and all $n\in[0,MaxN]$.
!
! PM(i,n) = Integrate[ t^i * "
!             Integrate[ s^n Exp[-x s] , {s,0,bt*t+b1} ],
!               {t,0,1}]

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: i,MaxN
REAL(KIND_PM)     :: x,bt,b1,x0,c

!!#### REQUIRED OUTPUT
REAL(KIND_PM),INTENT(OUT) :: PM(0:MaxN)

!!#### OPTIONAL INPUT
REAL(KIND_PM),INTENT(IN),OPTIONAL :: tol

!!#### LOCAL VARIABLES
REAL(KIND_PM) :: PM1(0:MaxN+i),Enxb1,PMrecurse(0:MaxN),interior
INTEGER       :: n,k,kk
REAL(KIND_PM) :: terms(0:100)
REAL(KIND_PM) :: tol_,invfact

!!--begin--

tol_ = DEFAULT( PM_DEFAULT_TOL , tol )

IF( x>SMALL_X )THEN

 !get all the simplified exponential moments we need
 CALL PolyExpoMoment(MaxN+i,x*bt,x0=x*bt,c=1._KIND_PM,PM=PM1,tol=tol_)

 !get exponential term
 Enxb1 = EXP(-x*b1)

 !for each term PM(i,0),PM(i,1),...,PM(i,MaxN)
 DO n=0,MaxN

  !check if we are at the last recursion and use x0 to divide by instead of x
  IF( n==MaxN )THEN

   !first term
   IF( n==0 )THEN
    PM(0) = (1._KIND_PM/x0)*( 1._KIND_PM/(REAL(i+1,KIND_PM)) - PM1(i)*Enxb1 )
   !other terms
   ELSE
    PM(n) = (1._KIND_PM/x0)*( n*PMrecurse(n-1) - Enxb1*EVAL_DSum(n) )
   END IF

  !all but the last recursion
  ELSE

   !first term
   IF( n==0 )THEN
    interior     = 1._KIND_PM/(REAL(i+1,KIND_PM)) - PM1(i)*Enxb1
    PM(0)        = (1._KIND_PM/x0)*( interior )
    PMrecurse(0) = (1._KIND_PM/x )*( interior )
   !other terms
   ELSE
    interior = n*PMrecurse(n-1) - Enxb1*EVAL_DSum(n)
    PM(n)        = (1._KIND_PM/x0)*( interior )
    PMrecurse(n) = (1._KIND_PM/x )*( interior )
   END IF

  END IF

 END DO

!x is small
ELSE

 !for each term PM(i,0),PM(i,1),...,PM(i,MaxN)
 DO n=0,MaxN

  !go forward to find the proper truncation term
  k = -1
  DO
   k = k + 1
   IF( FORCE_FACTORIAL_EVAL .OR. k>MAX_N_InvFactorial )THEN
    invfact = EXP(-FactorialLn(k))
   ELSE
    invfact = c_InvFactorial(k)
   END IF
   terms(k) = invfact * (-x)**k * EVAL_CSum(i,n,k)
   !WRITE(*,*)"terms(k))=",terms(k)
   IF( ABS(terms(k))<tol_*terms(0) )EXIT
  END DO

  !backward to accumulate terms (prevents loss of accuracy)
  PM(n) = 0._KIND_PM
  DO kk=k,0,-1
   PM(n) = PM(n) + terms(kk)
   !WRITE(*,*)"val=",val
  END DO

 END DO

 !multiply by constant
 PM=PM*c

END IF

!!--end--
CONTAINS

FUNCTION EVAL_DSum(n) RESULT(sum)
INTEGER,INTENT(IN) :: n
REAL(KIND_PM) :: sum

!!#### LOCAL VARIABLES
INTEGER       :: m
REAL(KIND_PM) :: DCoeff(0:MaxN),coeff

!!--begin--

DO m=0,n
 IF( FORCE_FACTORIAL_EVAL .OR. n>MAX_N_BinomialCoeff )THEN
  coeff = CoefficientBinomial(n,m)
 ELSE
  coeff = c_BinomialCoeff(m,n)
 END IF
 DCoeff(m) = coeff * (bt)**m * (b1)**(n-m)
END DO

sum = 0._KIND_PM
DO m=0,n
 sum = sum + DCoeff(m)*PM1(m+i)
END DO

!!--end--
END FUNCTION

FUNCTION EVAL_CSum(i,n,k) RESULT(sum)
INTEGER,INTENT(IN) :: i,n,k
REAL(KIND_PM) :: sum

!!#### LOCAL VARIABLES
REAL(KIND_PM) :: CCoeff(0:100),coeff
INTEGER :: m

!!--begin--

DO m=0,k+n+1
 IF( FORCE_FACTORIAL_EVAL .OR. n>MAX_N_BinomialCoeff )THEN
  coeff = CoefficientBinomial(k+n+1,m)
 ELSE
  coeff = c_BinomialCoeff(m,k+n+1)
 END IF
 CCoeff(m) = coeff * (bt)**m * (b1)**(k+n+1-m)
 CCoeff(m) = CCoeff(m) /REAL(k+n+1,KIND_PM)
END DO

sum = 0._KIND_PM
DO m=0,k+n+1
 sum = sum + CCoeff(m)/REAL(m+i+1,KIND_PM)
END DO

!!--end--
END FUNCTION

END SUBROUTINE

!!### SUBROUTINE <<NPolyExpoMoment>>
SUBROUTINE NPolyExpoMoment( N , x , x0 , c , PM , tol )

!!#### PURPOSE
!! Return the simplified exponential moments $PM_n(x)$, for $n=0,1,...,N$
!! using adaptive numerical integration.

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: N
REAL(KIND_PM),INTENT(IN) :: x
REAL(KIND_PM),INTENT(IN) :: x0
REAL(KIND_PM),INTENT(IN) :: c

!!#### REQUIRED OUTPUT
REAL(KIND_PM),INTENT(OUT) :: PM(0:N)

!!#### OPTIONAL INPUT
REAL(KIND_PM),INTENT(IN),OPTIONAL :: tol

!!#### LOCAL VARIABLES
INTEGER        :: i
REAL(KIND_PM) :: tol_

!!--begin--
tol_ = Default( PM_DEFAULT_TOL , tol )
PM = 0._KIND_PM

DO i=0,N
 PM(i) = c*NPolyExpoMoment0(i,x,tol_)
END DO

!!--end--
END SUBROUTINE

!!### FUNCTION <<NPolyExpoMoment0>>
FUNCTION NPolyExpoMoment0(n,x,tol) RESULT(val)

!!#### PURPOSE
!! Return the numerical integration of the
!! simplified exponential moment function, $PM_n(x)$ for a single $n$.

!!#### REQUIRED INPUT
!! * moment order $n$
!! * argument of simplified exponential moment function $PM_n(x)$
!! * tolerance on solution
INTEGER       ,INTENT(IN) :: n
REAL(KIND_PM),INTENT(IN) :: x,tol

!!#### REQUIRED OUTPUT
REAL(KIND_PM) :: val,tol_

!!#### LOCAL VARIABLES
!REAL(KIND_PM) :: Mint___
!EXTERNAL      :: Mint___

!!--begin--

tol_ = Default( PM_DEFAULT_TOL , tol )
val = Integrate1_aq( Mint___ , (/0._KIND_PM,1._KIND_PM/) , N=10000 , tol=tol_ )

!!--end--
CONTAINS

!!### FUNCTION <<Mint___>
FUNCTION Mint___(t)

!!#### REQUIRED INPUT
REAL(KIND_PM),INTENT(IN) :: t

!!#### REQUIRED OUTPUT
REAL(KIND_PM) :: Mint___

!!--begin--

Mint___ = (t)**n * EXP(-x*t)

!!--end--
END FUNCTION

END FUNCTION

!!### SUBROUTINE <<PRINT_NPolyExpoMoment>>
SUBROUTINE PRINT_NPolyExpoMoment(N,Unit,xstart,xdiv,ndiv,tol)

!!#### MODULES
USE FUN_STR                             !!((05-B-FUN_STR.f90))
USE FUN_Default                         !!((04-A-FUN_Default.f90))
USE VAR_Units,ONLY: DEFAULT_OUTPUT_UNIT !!((03-A-VAR_Units.f90))

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: N

!!#### OPTIONAL INPUT
INTEGER       ,OPTIONAL,INTENT(IN) :: Unit
REAL(KIND_PM),OPTIONAL,INTENT(IN) :: xstart,xdiv,tol
INTEGER       ,OPTIONAL,INTENT(IN) :: ndiv

!!#### LOCAL VARIABLES
REAL(KIND_PM) :: x,PM(0:N),xstart_,xdiv_
INTEGER        :: i,Unit_,ndiv_

!!--begin--
xstart_ = Default( 10._KIND_PM , xstart )
xdiv_   = Default( 10._KIND_PM , xdiv )
Unit_   = Default( DEFAULT_OUTPUT_UNIT , Unit )
ndiv_   = Default( 10 , ndiv )

x=xstart_
DO i=1,ndiv_+1
 CALL NPolyExpoMoment( N , x , x0=x , c=1._KIND_PM , PM=PM(0:2) ,tol=tol )
 WRITE(Unit_,"("//TRIM(STR(N+2))//"(E,1x))")x,PM(0:N)
 x=x/xdiv_
END DO

!!--end--
END SUBROUTINE

FUNCTION MonoCheck3( AllPM ) RESULT(Pass)
REAL(KIND_PM),INTENT(IN) :: AllPM(:,:,:)
INTEGER :: k,i,n
LOGICAL :: Pass

!!--begin--

Loop: DO k=1,SIZE(AllPM,3)-1
 DO n=1,SIZE(AllPM,2)
  DO i=1,SIZE(AllPM,1)

   !if it is zero, then the next must be zero
   IF( AllPM(i,n,k+1)==0._KIND_PM )THEN
    Pass = AllPM(i,n,k)==0._KIND_PM
   !otherwise, the term with greater x value (k) must be less than the next term
   ELSE
    Pass = AllPM(i,n,k)<AllPM(i,n,k+1) !difference here from other monochecks
   END IF

   !failure
   IF( .NOT.Pass )THEN
    EXIT Loop
   END IF

  END DO
 END DO

END DO Loop

!!--end--
END FUNCTION

FUNCTION MonoCheck1( AllPM ) RESULT(Pass)
REAL(KIND_PM),INTENT(IN) :: AllPM(:,:,:)
INTEGER :: k,i,n
LOGICAL :: Pass

!!--begin--

Loop: DO k=1,SIZE(AllPM,3)
 DO n=1,SIZE(AllPM,2)
  DO i=1,SIZE(AllPM,1)-1

   !if it is zero, then the next must be zero
   IF( AllPM(i+1,n,k)==0._KIND_PM )THEN
    Pass = AllPM(i,n,k)==0._KIND_PM
   ELSE
    Pass = AllPM(i,n,k)>AllPM(i+1,n,k) !difference here from other monochecks
   END IF

   !failure
   IF( .NOT.Pass )THEN
    EXIT Loop
   END IF

  END DO
 END DO

END DO Loop

!!--end--
END FUNCTION

FUNCTION MonoCheck2( AllPM ) RESULT(Pass)
REAL(KIND_PM),INTENT(IN) :: AllPM(:,:,:)
INTEGER :: k,i,n
LOGICAL :: Pass

!!--begin--

Loop: DO k=1,SIZE(AllPM,3)
 DO n=1,SIZE(AllPM,2)-1
  DO i=1,SIZE(AllPM,1)

   !if it is zero, then the next must be zero
   IF( AllPM(i,n+1,k)==0._KIND_PM )THEN
    Pass = AllPM(i,n,k)==0._KIND_PM
   ELSE
    Pass = AllPM(i,n,k)>AllPM(i,n+1,k) !difference here from other monochecks
   END IF

   !failure
   IF( .NOT.Pass )THEN
    EXIT Loop
   END IF

  END DO
 END DO

END DO Loop

!!--end--
END FUNCTION

!!### FUNCTION <<CHECK1_PolyExpoMoment>>
FUNCTION CHECK1_PolyExpoMoment(tol,testtol,&
  NoisyUnit,NCount) RESULT(Pass)
!!#### PURPOSE
!! Check the polynomial exponents for simple boundedness.

!!#### REQUIRED OUTPUT
LOGICAL :: Pass

!!#### OPTIONAL INPUT
REAL(KIND_PM),OPTIONAL,INTENT(IN) :: tol,testtol
INTEGER      ,OPTIONAL,INTENT(IN) :: NoisyUnit,NCount

!!#### LOCAL VARIABLES
REAL(KIND_PM) :: tol_,testtol_,x,PM1(0:10)
INTEGER       :: NoisyUnit_,NCount_,count
INTEGER       :: i

!!--begin--

testtol_   = Default( PM_DEFAULT_TESTTOL , testtol )
tol_       = Default( PM_DEFAULT_TOL     , tol     )
NCount_    = Default( 1000               , NCount  )
NoisyUnit_ = Default( 0                  , NoisyUnit )

Pass = .TRUE.

!code to test random moments and random optical thicknesses
!!--------------------------
count = 0
DO
 i=Random((/0,10/))
 x=Random((/-1.E-20_KIND_PM,1.E+20_KIND_PM/))
 CALL PolyExpoMoment(i,x,x0=x,c=1._KIND_PM,PM=PM1(0:i),tol=tol_)
 IF( ANY(PM1(0:i)<0._KIND_PM) .OR. ANY(PM1(0:i)>1._KIND_PM) )THEN
  IF( NoisyUnit_/=0 )THEN
   WRITE(NoisyUnit_,*)"failed for i=",i
   WRITE(NoisyUnit_,*)"           x=",x
   WRITE(NoisyUnit_,*)"with values PM(0:i)=",PM1(0:i)
   WRITE(NoisyUnit_,*)"****FATAL STOP****"
  END IF
  Pass = .FALSE.
  EXIT
 END IF

 count = count+1
 IF( MOD(count,1000)==0 )THEN
  IF( NoisyUnit_/=0 )THEN
   WRITE(NoisyUnit_,*)"random moments passed ",count,"/ 100,000"
  END IF
 END IF
 IF( count==NCount_ )EXIT

END DO
!!--------------------------

END FUNCTION

END MODULE


      MODULE m_nabla
      use m_juDFT

      CONTAINS

      SUBROUTINE nabla(
     >                 ispecies,number_of_j1,grid_size,delta_x,
     >                 nstd,ntypd,j1,l1,lmax,ms,ri,psi,phi,dphi,
     <                 psi_phi)
!----------------------------------------------------------------
!
!     ispecies     ... number of the atom (itype)
!     number_of_j1 ... number of core wavefunction
!     grid_size    ... rumber of radial gridpoints (jri)
!     delta_x      ... logarithmic increment of grid (dx)
!     ri(grid_size)... radial mesh
!     nstd     ... number of corelevels (dimension)
!     ntypd    ... number of atoms (dimension)
!     j1,l1    ... quantum numbers of the core wavefunction
!     ms       ... -1/2 or +1/2 for spin 1 or 2
!     lmax     ... parameter, 3 (s,p,d,f)
!     psi(r)   ... core wavefunction
!     phi(r,l) ... valence wavefunction
!    dphi(r,l) ... radial derivative of valence wavefunction
!
!----------------------------------------------------------------
       USE m_constants
       USE m_clebsch
       USE m_intgr, ONLY : intgr3

       IMPLICIT NONE

       INTEGER, INTENT(IN) :: ispecies, number_of_j1, grid_size
       INTEGER, INTENT(IN) :: l1, lmax, nstd, ntypd
       REAL,    INTENT(IN) :: delta_x, j1, ms
       REAL,    INTENT(IN) :: psi(grid_size), ri(grid_size)
       REAL,    INTENT(IN) :: phi(grid_size,0:lmax)
       REAL,    INTENT(IN) ::dphi(grid_size,0:lmax)
       COMPLEX, INTENT(OUT):: psi_phi(nstd,(lmax+1)**2,3*ntypd)

       INTEGER :: m1, l2, m2, index, alloc_error, lmn1, lmn2
       REAL  :: result, result1, total_result, spin
       REAL  :: mu, cnst_one_over_sqrt_two, cnst_zero
       COMPLEX :: cnst_i
       REAL, DIMENSION(:), POINTER :: f
       spin = 0.50
       cnst_one_over_sqrt_two = 1.0/sqrt(2.0)
       cnst_i = cmplx(0.0,1.0)
       cnst_zero = 0.0

       NULLIFY(f)

       IF ( ASSOCIATED(f) ) THEN
        WRITE(oUnit,*)'nabla: f association status:',ASSOCIATED(f)
        STOP
       ENDIF

       ALLOCATE ( f(grid_size),STAT=alloc_error )
       IF (alloc_error /= 0)  CALL juDFT_error("Couldn't allocate f",
     +      calledby ="nabla")

       lmn1 = 2 * (number_of_j1 - 1)  * l1
       mu = -j1

       DO WHILE (mu <= j1)
        lmn1 = lmn1 + 1
        m1 = INT(mu - ms)
        lmn2 = 0
        DO l2 = 0, lmax
         DO m2 = -l2, l2
            lmn2 = lmn2 + 1
            IF(l1 == l2 + 1)THEN
             total_result = 0.00
             result  = 0.00
             result1 = 0.00
!
! (l+1)/srqt[(2l+1)(2l+3)] < phi_core | (d phi_valence / dr ) >
!
             f(:) = psi(:) * dphi(:,l2) ! assumed to be already multiplied with * ri(:) * ri(:)

             CALL intgr3(f,ri,delta_x,grid_size,result)

             result = result * (l2 + 1.00) /
     +                         sqrt((2.00*l2 +1.00)*(2.*l2+3.00))

!
!  - l(l+1)/srqt[(2l+1)(2l+3)] < phi_core | (1/r) phi_valence >
!
             f(:) = psi(:) * phi(:,l2) ! assumed to be already multiplied with 1G* ri(:)
             CALL intgr3(f,ri,delta_x,grid_size,result1)
             result1 = - result1 * l2 * (l2 + 1.0) /
     +                   sqrt((2.0 * l2 + 1.00) * (2. * l2 + 3.00))
!
! Sum up and decorate with Clebsch-Gordon coefficients
!
             result  = result + result1
             total_result = result*clebsch(real(l1),spin,mu-ms,ms,j1,mu)

             index = (ispecies - 1) * 3 + 1
             psi_phi(lmn1,lmn2,index)= cgc(l2,1,l1,m2,1,m1) *       ! left polarization
     +                                 total_result / cgc(l2,1,l1,0,0,0)

             index = index + 1
             psi_phi(lmn1,lmn2,index)= cgc(l2,1,l1,m2,-1,m1) *      ! right polarization
     +                                 total_result / cgc(l2,1,l1,0,0,0)

             index = index + 1
             psi_phi(lmn1,lmn2,index)= cgc(l2,1,l1,m2,0,m1) *        ! z-polarization
     +                                 total_result / cgc(l2,1,l1,0,0,0)

            ELSEIF(l1== l2-1)THEN

              result  =  cnst_zero
              result1 =  cnst_zero
!
! l/srqt[(2l-1)(2l+1)] < phi_core | (d phi_valence / dr ) >
!
              f(:) = psi(:)* dphi(:,l2)   * ri(:) * ri(:)
              CALL intgr3(f,ri,delta_x,grid_size,result)
              result = result * l2 / sqrt((2.0*l2 - 1.0)*(2.0*l2 + 1.0))
!
!   l(l+1)/srqt[(2l-1)(2l+1)] < phi_core | (1/r) phi_valence >
!
              f(:) = psi(:)* phi(:,l2) * ri(:)
              CALL intgr3(f,ri,delta_x,grid_size,result1)
              result1 = result1 * l2 * (l2 + 1.0) /
     +                  sqrt((2.00 * l2 - 1.00) * (2.00 * l2 + 1.00))
!
! Sum up and decorate with Clebsch-Gordon coefficients
!
              result = result + result1
              total_result= result*clebsch(real(l1),spin,mu-ms,ms,j1,mu)

              index = (ispecies - 1) * 3 + 1
              psi_phi(lmn1,lmn2,index) = cgc(l2,1,l1,m2,1,m1) *          ! left polarization
     +                                 total_result / cgc(l2,1,l1,0,0,0)
              index = index + 1
              psi_phi(lmn1,lmn2,index) = cgc(l2,1,l1,m2,-1,m1) *         ! right polarization
     +                                 total_result / cgc(l2,1,l1,0,0,0)
              index = index + 1
              psi_phi(lmn1,lmn2,index) = cgc(l2,1,l1,m2,0,m1) *          ! z-polarization
     +                                 total_result / cgc(l2,1,l1,0,0,0)
            ENDIF
          ENDDO
        ENDDO
        mu = mu + 1.00
       ENDDO
       DEALLOCATE(f,STAT=alloc_error)
       IF (alloc_error /= 0)  CALL juDFT_error("Couldn't deallocate f"
     +      ,calledby ="nabla")
      END SUBROUTINE nabla

      FUNCTION cgc(l1,l2,l3,m1,m2,m3)

      IMPLICIT NONE
      INTEGER :: l1, l2, l3, m1, m2, m3
      REAL  :: two_l1p1, two_l1p2, l1pm3, l1pm3p1, l1mm3p1, l1mm3, cgc

      IF (m3 /= m1 + m2) THEN
       cgc = 0.0
       RETURN
      END IF
!     gb  m3 = m1 + m2
      two_l1p1 = 2 * l1 + 1
      two_l1p2 = 2 * l1 + 2
      l1pm3 = l1 + m3
      l1pm3p1 = l1 + m3 + 1
      l1mm3p1 = l1 - m3 + 1
      l1mm3 = l1 - m3
      cgc = 0.0
      IF (l3 == l1 + 1) THEN
          IF (m2 == 1) then
           cgc = sqrt( (l1pm3 * l1pm3p1) / (two_l1p1 * two_l1p2))
          ELSEIF (m2 == 0) THEN
           cgc = sqrt( (l1mm3p1 * l1pm3p1) / (two_l1p1 * (l1 + 1)))
          ELSEIF (m2 == -1) THEN
           cgc = sqrt( (l1mm3 * l1mm3p1) / (two_l1p1 * two_l1p2))
          END IF
      ELSE IF(l3 == l1 -1) THEN
          IF (m2 == 1) then
           cgc = sqrt( (l1mm3 * l1mm3p1) / (2.0 * l1 * two_l1p1))
          ELSEIF (m2 == 0) THEN
           cgc = -sqrt( (l1mm3 * l1pm3) / (l1 * (two_l1p1)))
          ELSEIF (m2 == -1) THEN
           cgc = sqrt( (l1pm3p1 * l1pm3) / (2.0 * l1 * two_l1p1))
          END IF
      END IF
      END FUNCTION cgc

      END MODULE m_nabla


  subroutine epslon(epse,epso,epsedn,epsodn,ls_node)

      use mod_param, only : jcap,ls_max_node,kind_evod
      use mod_param, only : len_trie_ls,len_trio_ls,ls_dim
      implicit none

      real(kind=kind_evod)   epse(len_trie_ls)
      real(kind=kind_evod)   epso(len_trio_ls)
      real(kind=kind_evod) epsedn(len_trie_ls)
      real(kind=kind_evod) epsodn(len_trio_ls)
      integer                  ls_node(ls_dim,3)
      integer                  l,locl,n
      integer                  indev
      integer                  indod
      real(kind=kind_evod) f1,f2,rn,val
      real(kind=kind_evod) cons0     !constant
       integer                  indlsev,jbasev
       integer                  indlsod,jbasod

      include 'function_indlsev.h'
      include 'function_indlsod.h'

      cons0=0.0d0     !constant
!!......................................................................

      do locl=1,ls_max_node
              l=ls_node(locl,1)
         jbasev=ls_node(locl,2)
         indev=indlsev(l,l)
         epse  (indev)=cons0     !constant
         epsedn(indev)=cons0     !constant
          indev=indev+1

         do n=l+2,jcap+1,2
            rn=n
            f1=n*n-l*l
            f2=4*n*n-1
            val=sqrt(f1/f2)
            epse  (indev)=val
            epsedn(indev)=val/rn
            indev=indev+1
         enddo

      enddo

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

      do locl=1,ls_max_node
              l=ls_node(locl,1)
         jbasod=ls_node(locl,3)
         indod=indlsod(l+1,l)

         do n=l+1,jcap+1,2
            rn=n
            f1=n*n-l*l
            f2=4*n*n-1
            val=sqrt(f1/f2)
            epso  (indod)=val
            epsodn(indod)=val/rn
            indod=indod+1
         enddo

      enddo

      return
  end


C Copyright(C) 2011 Sandia Corporation.  Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C certain rights in this software
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C * Redistributions of source code must retain the above copyright
C    notice, this list of conditions and the following disclaimer.
C
C * Redistributions in binary form must reproduce the above
C   copyright notice, this list of conditions and the following
C   disclaimer in the documentation and/or other materials provided
C   with the distribution.
C
C * Neither the name of Sandia Corporation nor the names of its
C   contributors may be used to endorse or promote products derived
C   from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C     -*- Mode: fortran -*-
C=======================================================================
      SUBROUTINE SPOFF (XN, YN, ZN, NSPL, ZS, XS, XS2, YS, YS2,
     &     SLTOP, SLBOT, NUMNP, NDIM )
C=======================================================================

C     --*** SPLXYZ *** (GEN3D) Calculate 3D coordinates for Spline projection
C     --   Written by Amy Gilkey - revised 05/09/88
C     --   Modified by Greg Sjaardema - 02/06/89
C     --
C     --WRPXYZ calculates the coordinate array for the 3D warp translations.
C     --
C     --Parameters:
C     --   XN, YN, ZN - IN/OUT - the coordinates, modified
C     --   NSPL - Number of points on spline curve
C     --   ZS, XS, YS - IN - spline point coordinates
C     --   XS2, YS2 - spline slopes
C     --   SLTOP, SLBOT - slopes at top and bottom of spline
C     --   NUMNP - number of nodal points
C     --   NDIM - spatial dimension (2 or 3)
C     --

      REAL XN(*), YN(*), ZN(*)
      REAL ZS(NSPL), XS(NSPL), XS2(NSPL), YS(NSPL), YS2(NSPL)
      REAL SLTOP(2), SLBOT(2)

C$$$      CALL RDSPLN (.TRUE., NDB, SLTOP, SLBOT, NSPL, ZS, XS, YS)

      CALL SPLINE (ZS, XS, NSPL, SLTOP(1), SLBOT(1), XS2)
      CALL SPLINE (ZS, YS, NSPL, SLTOP(2), SLBOT(2), YS2)

      KLO = 1

      DO 80 INP = 1, NUMNP
         Z = ZN(INP)
         CALL HUNT (ZS, NSPL, Z, KLO)
         IF (KLO .EQ. NSPL) KLO = KLO - 1
         IF (KLO .EQ.    0) KLO = KLO + 1

         H  = ZS(KLO+1) - ZS(KLO)
         A  = (ZS(KLO+1)-Z)/H
         B  = (Z-ZS(KLO))/H

         XOFF = A * XS(KLO) + B * XS(KLO+1) +
     *        ((A**3-A) * XS2(KLO)+(B**3-B)*XS2(KLO+1)) * (H**2) / 6.

         YOFF = A * YS(KLO) + B * YS(KLO+1) +
     *        ((A**3-A) * YS2(KLO)+(B**3-B)*YS2(KLO+1)) * (H**2) / 6.

         XN(INP) = XN(INP) + XOFF
         YN(INP) = YN(INP) + YOFF
   80 CONTINUE

      RETURN
      END


  SUBROUTINE cyl_to_tilt

    USE constants
    USE fields
    USE tracers
    USE diagnostic
    USE injection
    !
    IMPLICIT none
    !
    !
    ! Rotates from a nontilted cylindrical coordinate system to a
    ! tilted magnetic plane.
    !

    DOUBLE PRECISION :: Rcurv_inv

    IF (rot_type=='pos') THEN
      ! could be some mistakes with Rcurv factors here: KBG 17 Feb 2010
      pos_tilt(1) = 	   pos_cyl(1)
      ! must use r\phi instead of just \phi - using the r = R_c approximation for consistency with Bratio not depdnt on r
      pos_tilt(2) =     Rcurv*pos_cyl(2)*cosineoftheta + pos_cyl(3)*sineoftheta
      pos_tilt(3) = -1.*Rcurv*pos_cyl(2)*sineoftheta   + pos_cyl(3)*cosineoftheta

      vel_tilt(1) =      vel_cyl(1)
      vel_tilt(2) = 	   vel_cyl(2)*cosineoftheta + vel_cyl(3)*sineoftheta
      vel_tilt(3) =  -1.*vel_cyl(2)*sineoftheta   + vel_cyl(3)*cosineoftheta
    ELSE IF (rot_type=='Efield') THEN
      stop 'E_rotate cylinder to tilted cylinder is not set up...stopping'
      E_tilt(1) = 0.
      E_tilt(2) = 0.
      E_tilt(3) = 0.
    END IF

  END SUBROUTINE cyl_to_tilt


C======================================================================
C         Z C B
C======================================================================

      Double precision FUNCTION ZCB(K1,K2,K3)
C
C     CB =  3j(k1,0,k2,0,k3,0)**2
C
      Real *8 A,B
C
      ZCB=0.0
C
      M=K1+K2+K3
      N=M/2
      IF(N+N.NE.M) RETURN
      M=M+1
C
      N1=N-K1
      N2=N-K2
      N3=N-K3
      IF(N1.LT.0.OR.N2.LT.0.OR.N3.LT.0) RETURN
      M1=N1+N1
      M2=N2+N2
      M3=N3+N3
C
      A=1.0
C
      DO 1 I=2,M
      K=-1                    ! the extent of integer I in units of 1/2
      IF(M1.GE.I) K=K+1
      IF(M2.GE.I) K=K+1
      IF(M3.GE.I) K=K+1
      IF(N .GE.I) K=K+2
      IF(N1.GE.I) K=K-2
      IF(N2.GE.I) K=K-2
      IF(N3.GE.I) K=K-2
c
      IK=IABS(K)
      B=DBLE(I)
      IF(K.GT.0) THEN
        DO 3 J=1,IK
         A=A*B
    3   Continue
      END IF
      IF(K.LT.0) THEN
        DO 2 J=1,IK
         A=A/B
    2   Continue
      END IF
c
    1   Continue
c
      ZCB=A
      RETURN
      END


*> \brief \b ZDOTU
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY)
*
*       .. Scalar Arguments ..
*       INTEGER INCX,INCY,N
*       ..
*       .. Array Arguments ..
*       COMPLEX*16 ZX(*),ZY(*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZDOTU forms the dot product of two complex vectors
*>      ZDOTU = X^T * Y
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>         number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] ZX
*> \verbatim
*>          ZX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>         storage spacing between elements of ZX
*> \endverbatim
*>
*> \param[in] ZY
*> \verbatim
*>          ZY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*>          INCY is INTEGER
*>         storage spacing between elements of ZY
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level1
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>     jack dongarra, 3/11/78.
*>     modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
*  =====================================================================
      COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY)
*
*  -- Reference BLAS level1 routine (version 3.7.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER INCX,INCY,N
*     ..
*     .. Array Arguments ..
      COMPLEX*16 ZX(*),ZY(*)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      COMPLEX*16 ZTEMP
      INTEGER I,IX,IY
*     ..
      ZTEMP = (0.0d0,0.0d0)
      ZDOTU = (0.0d0,0.0d0)
      IF (N.LE.0) RETURN
      IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
*        code for both increments equal to 1
*
         DO I = 1,N
            ZTEMP = ZTEMP + ZX(I)*ZY(I)
         END DO
      ELSE
*
*        code for unequal increments or equal increments
*          not equal to 1
*
         IX = 1
         IY = 1
         IF (INCX.LT.0) IX = (-N+1)*INCX + 1
         IF (INCY.LT.0) IY = (-N+1)*INCY + 1
         DO I = 1,N
            ZTEMP = ZTEMP + ZX(IX)*ZY(IY)
            IX = IX + INCX
            IY = IY + INCY
         END DO
      END IF
      ZDOTU = ZTEMP
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR SEULEX ON KS PROBLEM
C * * * * * * * * * * * * * * * * * * * * * * * * *
        IMPLICIT REAL*8 (A-H,O-Z)
C --- PARAMETERS FOR SEULEX (BANDED JACOBIAN)
        PARAMETER (MMM=9,KM=12)
        PARAMETER (NH=2**MMM,N=2*NH,ND=2*NH-2)
        PARAMETER (IJAC=1,MLJAC=0,MUJAC=0,IMAS=0)
        PARAMETER (LJAC=MLJAC+MUJAC+1,LE=2*MLJAC+MUJAC+1)
        PARAMETER (LWORK=ND*(2*LJAC+LE+KM+8)+4*KM+20,LIWORK=2*ND+KM+20)
C --- DECLARATIONS
        DIMENSION Y(ND),WORK(LWORK),IWORK(LIWORK),U(N)
        COMMON/TRANS/QQ,UZERO
        REAL*4 TARRAY(2),TRESULT
        EXTERNAL FKS,JKS,SOLOUT
C --- DATA FOR THE PROBLEM
        QQ=0.025D0
c ------ FILE DE DONNEES ----------
        OPEN(8,FILE='res_seulex')
        REWIND 8
C --- LOOP FOR DIFFERENT TOLERANCES
        NTOLMN=2
        NTOLMX=10
        NTOLDF=4
        NRLOOP=(NTOLMX-NTOLMN)*NTOLDF+1
        TOLST=0.1D0**NTOLMN
        TOLFC=0.1D0**(1.D0/NTOLDF)
        DO 30 NTOL=1,NRLOOP
C --- OUTPUT DURING INTEGRATION ---
        IOUT=0
C --- INITIAL VALUES
        T=0.0D0
C --- INITIAL POSITIONS IN Y-SPACE ----
        AN=N
        DO I=1,N
         DELX=1.D0/AN
         X=DELX*(I-1)
         U1=MIN(X-0.0D0,0.1D0-X)
         U2=20.D0*(X-0.2D0)*(0.3D0-X)
         U3=MIN(X-0.6D0,0.7D0-X)
         U4=MIN(X-0.9D0,1.0D0-X)
         U(I)=16.D0*MAX(0.D0,U1,U2,U3,U4)
        END DO
C ---  FOURIER TRANSFORM ---
        CALL REALFT(U,NH,+1)
        DO I=1,N
         U(I)=U(I)/AN
        END DO
C --- INITIAL POSITION IN FOURIER MODES ---
        UZERO=U(1)
        DO I=1,ND
         Y(I)=U(I+2)
        END DO
        U(1)=UZERO
        U(2)=0.D0
        DO I=3,N
         U(I)=Y(I-2)
        END DO
        CALL REALFT(U,NH,-1)
        DO I=1,N
         U(I)=2.D0*U(I)
        END DO
C --- ENDPOINT OF INTEGRATION
         TEND=100.0D0
C --- REQUIRED TOLERANCE
         RTOL=TOLST
         ATOL=RTOL
         ITOL=0
C --- INITIAL STEP SIZE
         H=1.0D-6
C --- SET DEFAULT VALUES
         DO I=1,20
          IWORK(I)=0
          WORK(I)=0.D0
         END DO
         IFCN=0
C --- CALL OF THE SUBROUTINE SEULEX
        CALL DTIME(TARRAY,TRESULT)
         CALL SEULEX(ND,FKS,IFCN,T,Y,TEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JKS,IJAC,MLJAC,MUJAC,
     &                  JKS,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT SOLUTION
        CALL DTIME(TARRAY,TRESULT)
        WRITE(8,9921)(Y(I),I=1,10)
        WRITE(8,9921)(Y(I),I=11,100,5)
        WRITE(8,9921)(Y(I),I=101,1024,50)
 9921   FORMAT(1X,F22.16)
C --- PRINT STATISTICS
        WRITE(8,*)TARRAY(1)
        WRITE (8,*)(IWORK(J),J=14,20)
        WRITE(6,*)' ***** TOL=',RTOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (IWORK(J),J=14,20)
 91     FORMAT(' fcn=',I5,' jac=',I4,' step=',I4,
     &        ' accpt=',I4,' rejct=',I3,' dec=',I4,
     &        ' sol=',I5)
C -------- NEW TOLERANCE ---
        TOLST=TOLST*TOLFC
        IF (TARRAY(1).GT.1000.) STOP
 30     CONTINUE
        STOP
        END

        SUBROUTINE SOLOUT (NR,XOLD,X,Y,RC,LRC,IC,LIC,N,RPAR,IPAR,IRTRN)
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),RC(LRC),IC(LIC)
          IF(MOD(NR,10).EQ.1) WRITE (6,99) X,Y(1),Y(2),NR-1
 99     FORMAT(1X,'X =',F7.4,'    Y =',2E18.10,'    NSTEP =',I4)
        RETURN
        END


      REAL FUNCTION SDOT(N,SX,INCX,SY,INCY)
*     .. Scalar Arguments ..
      INTEGER INCX,INCY,N
*     ..
*     .. Array Arguments ..
      REAL SX(*),SY(*)
*     ..
*
*  Purpose
*  =======
*
*     forms the dot product of two vectors.
*     uses unrolled loops for increments equal to one.
*     jack dongarra, linpack, 3/11/78.
*     modified 12/3/93, array(1) declarations changed to array(*)
*
*

*     .. Local Scalars ..
      REAL STEMP
      INTEGER I,IX,IY,M,MP1
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MOD
*     ..
      STEMP = 0.0e0
      SDOT = 0.0e0
      IF (N.LE.0) RETURN
      IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
*
*        code for unequal increments or equal increments
*          not equal to 1
*
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
          STEMP = STEMP + SX(IX)*SY(IY)
          IX = IX + INCX
          IY = IY + INCY
   10 CONTINUE
      SDOT = STEMP
      RETURN
*
*        code for both increments equal to 1
*
*
*        clean-up loop
*
   20 M = MOD(N,5)
      IF (M.EQ.0) GO TO 40
      DO 30 I = 1,M
          STEMP = STEMP + SX(I)*SY(I)
   30 CONTINUE
      IF (N.LT.5) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
          STEMP = STEMP + SX(I)*SY(I) + SX(I+1)*SY(I+1) +
     +            SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4)
   50 CONTINUE
   60 SDOT = STEMP
      RETURN
      END


PROGRAM SubcellReconstructionTest

  USE KindModule, ONLY: &
    DP, Zero, One
  USE ProgramHeaderModule, ONLY: &
    nX, nNodesX, nDOFX, nDimsX
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE ReferenceElementModuleX, ONLY: &
    InitializeReferenceElementX, &
    FinalizeReferenceElementX
  USE ReferenceElementModuleX_Lagrange, ONLY: &
    InitializeReferenceElementX_Lagrange, &
    FinalizeReferenceElementX_Lagrange
  USE SubcellReconstructionModule, ONLY: &
    InitializeSubcellReconstruction, &
    FinalizeSubcellReconstruction, &
    ProjectionMatrix, &
    ReconstructionMatrix
  USE UtilitiesModule, ONLY: &
    WriteMatrix

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
             = 'SubcellReconstructionTest', &
           nX_Option &
             = [ 2, 2, 1 ], &
           swX_Option &
             = [ 0, 0, 0 ], &
           bcX_Option &
             = [ 0, 0, 0 ], &
           xL_Option &
             = [ 0.0_DP, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 1.0_DP, 1.0_DP, 1.0_DP ], &
           nE_Option &
             = 1, &
           eL_Option &
             = 0.0_DP, &
           eR_Option &
             = 1.0_DP, &
           nNodes_Option &
             = 2, &
           CoordinateSystem_Option &
             = 'CARTESIAN', &
           BasicInitialization_Option &
             = .TRUE. )

  CALL InitializeReferenceElementX

  CALL InitializeReferenceElementX_Lagrange

  CALL InitializeSubcellReconstruction

  CALL WriteMatrix &
         ( nDOFX, nDOFX, ProjectionMatrix, 'ProjectionMatrix.dat' )

  CALL WriteMatrix &
         ( nDOFX, nDOFX, ReconstructionMatrix, 'ReconstructionMatrix.dat' )

  CALL FinalizeSubcellReconstruction

  CALL FinalizeReferenceElementX

  CALL FinalizeReferenceElementX_Lagrange

  CALL FinalizeProgram

END PROGRAM SubcellReconstructionTest


!   --------------------------------------------------------------------
!   DMET DELUX 2000	Subrutine	bckalk
!   --------------------------------------------------------------------
!   HENSIKT :
!   Beregner dempingskoeffisienter og fjærkoeffisienter
!
!   METODE :
!   Tar inn frekvensvektor og konstanter fra lektergeometri. Beregner
!   og sender videre dempings- og fjærkoeffisienter for hiv og stamp.
!
!   KALLESEKVENS:
!   CALL bckalk(n,nl,rho,g,omega,L,Br,D,GML,B33,B55,C33,C55)
!
!   PARAMETERE:
!   Navn	I/O	Type			Innhold/Beskrivelse
!   ....................................................................
!   omega	I	flyttals vektor		bølgefrekvens
!   n		I	heltall			antall frekvensintervaller
!   nl		I/O	heltall			antall lektere
!   k		I	flyttallsvektor		bølgetall
!   zeta_an	I	flyttallsvektor		bølgeamplitude
!   hs		I	heltall	  		signifikant bølgehøyde
!   tp		I	heltall			midlere periode
!   gamma	I	heltall			toppethetsfaktor
!   pi		I	flyttall		pi
!   g		I/O	flyttall		tyngdelfeltsakselerasjon
!   sn		O	flyttallsvektor		spekterverdi
!   a		I/O	heltall			nedre frekvensverdi
!   b		I/O	heltall			øvre frekvensverdi
!   H3		I/O	flyttalls matrise	transferfunksjon hiv
!   H5		I/O	flyttalls matrise	transferfunksjon stamp
!   delta3	I/O	flyttalls matrise	fasevinkel hiv
!   delta5	I/O	flyttalls matrise	fasevinkel stamp
!   A33		I/O	flyttalls matrise	tilleggsmasse hiv
!   A55		I/O 	flyttalls matrise	tilleggsmasse stamp
!   B33		I/O	flyttalls matrise	demping hiv
!   B55		I/O	flyttalls matrise	demping stamp
!   C33		I/O	flyttalls vektor	fjørkoeffisient hiv
!   C55		I/O	flyttalls vektor	fjærkoeffisient stamp
!   L		I/O	heltalls vektor		lengde på lekter
!   Br		I/O 	heltalls vektor		bredde på lekter
!   D		I/O	flyttalls vektor	dypgang på lekter
!   H		I/O	flyttalls vektor	dybde i riss for lekter
!   M		I/O	flyttalls vektor	masse lekter
!   GML		I/O	flyttalls vektor	langskips metasenter
!   I33		I/O	flyttall vektor		andre arealmoment tverrskips
!   I55		I/O	flyttalls vektor	andre arealmoment langskips
!   pi		I/O	flyttall		pi
!   rho		I/O	flyttal			tetthet sjøvann
!   g		I/O	flyttall		tyngdeakselerasjonen
!
!
!   INTERNE VARIABLE:
!   Navn			Funksjon
!   .....................................................................
!   i,j				tellevariabler
!   oomegaA,oomegaB		omregning av frekvens
!   B33plot			plotteverdi avlest tilleggsmasse
!
!   SKRIVEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   B33plot.txt			skriver resultat for visuell kontroll
!
!
!   --------------------------------------------------------------------
!
!   Programmert av:	     Tor Erik Larsen
!   Dato/Versjon  : 	     27.04.15 / 1.0
!
!   --------------------------------------------------------------------

!Starter subrutine og erklærer alle variable og vektorer
SUBROUTINE bckalk(n,nl,rho,g,omega,L,Br,D,GML,B33,B55,C33,C55)
IMPLICIT NONE
INTEGER::i,j,n,nl
REAL::rho,g
REAL,DIMENSION(1:nl)::L,Br,D,GML,C33,C55
REAL,DIMENSION(1:n,1:nl)::B33,B55,B33plot
DOUBLE PRECISION,DIMENSION(1:n)::omega,oomegaA,oomegaB

!Beregner x-aksen for koeffisientene
DO i=1,n
   oomegaA(i) = omega(i)*SQRT(Br(1)/(2.0*g))
   oomegaB(i) = omega(i)*SQRT(Br(2)/(2.0*g))
END DO

!Beregner B33_2D plotteverdi for lekter A, sjetteegradspolynom
DO i=1,n
   IF (oomegaA(i) < 1.47) THEN
      B33plot(i,1) = (  &
           0.985*oomegaA(i)**6 &
           - 5.368*oomegaA(i)**5 + 10.474*oomegaA(i)**4 &
           - 7.778*oomegaA(i)**3 + 0.077*oomegaA(i)**2 &
           + 1.727*oomegaA(i)**1 + 0.004 &
           )
   ELSE
      B33plot(i,1) = 0.001
END IF
END DO

!Beregner B33_2D plotteverdi for lekter B, femtegradspolynom
DO i=1,n
   IF (oomegaB(i) < 2.03) THEN
   B33plot(i,2) = ( &
        - 0.220*oomegaB(i)**5 &
        + 0.547*oomegaB(i)**4 + 1.431*oomegaB(i)**3 &
        - 5.396*oomegaB(i)**2 + 4.212*oomegaB(i)**1 &
        + 0.017 &
        )
ELSE
   B33plot(i,2) = 0.001
END IF
END DO

!Beregner fullengde B33, ved å gange A33_2D med lengde L
DO i=1,n
   B33(i,1) = L(1) * B33plot(i,1) * (rho*Br(1)*D(1) * &
        SQRT((2.0*g) / Br(1)) )
   B33(i,2) = L(2) * B33plot(i,2) * (rho*Br(2)*D(2) * &
        SQRT( (2.0*g) / Br(2) ) )
END DO

!Beregner koeffisientene i stamp, A55 og B55, UT FRA A33_2D
DO i=1,n
   B55(i,1) = (L(1)**2 / 12) * B33(i,1)
   B55(i,2) = (L(2)**2 / 12) * B33(i,2)
END DO

!Beregner fjærkoeffisientene C33 og C55
DO j=1,nl
   C33(j) = rho*g*L(j)*Br(j)
   C55(j) = rho*g*L(j)*Br(j)*D(j)*GML(j)
END DO

!Bygger plottefil for å sjekke at koeffisientene er regnet riktig
OPEN(44,FILE="B33plot.txt",ACTION="WRITE",STATUS="UNKNOWN")
DO i=1,n
   WRITE(44,*) oomegaA(i), B33plot(i,1), oomegaB(i), B33plot(i,2)
END DO
CLOSE(44)

!Gir tilbake kontrollen til hovedprogram og avslutter subrutine
RETURN
END SUBROUTINE