(enh) Added PREFIX and a PREFIX modifying function as optional: asum …

…and sdsdot implemented

common.fpp

@@ -75,7 +75,7 @@
 #:set F77_NAME = name.replace('?',PREFIX)
 #:set TYPE = PREFIX_TO_TYPE.get(PREFIX,None)
 #:set KIND = PREFIX_TO_KIND.get(PREFIX,None)
-$:code(MFI_NAME,F77_NAME,TYPE,KIND)
+$:code(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX)
 #:endfor
 #:enddef
 
@@ -89,25 +89,25 @@ end interface
 #:enddef
 
 #! Define f77 interfaces to implemented routines
-#:def f77_interface_internal(name, types)
+#:def f77_interface_internal(name, types, f=lambda x: x)
 interface f77_${name.replace('?','')}$
     #:for T in types
-    procedure :: ${name.replace('?',T)}$
+    procedure :: ${name.replace('?',f(T))}$
     #:endfor
 end interface
 #:enddef
 
 #! Define a f77 interfaces to the external blas/lapack library
-#:def f77_interface(name, supports, code)
+#:def f77_interface(name, supports, code, f=lambda x: x)
 interface
 #:for PREFIX in supports
-#:set NAME = name.replace('?',PREFIX)
+#:set NAME = name.replace('?',f(PREFIX))
 #:set TYPE = PREFIX_TO_TYPE.get(PREFIX,None)
 #:set KIND = PREFIX_TO_KIND.get(PREFIX,None)
-$:code(NAME,TYPE,KIND)
+$:code(NAME,TYPE,KIND,PREFIX)
 #:endfor
 end interface
-$:f77_interface_internal(name, supports)
+$:f77_interface_internal(name, supports, f=f)
 #:enddef
 
 #! Implements a f77 function / extension

src/f77/blas.fpp

@@ -4,6 +4,7 @@
 #:include "src/f77/blas/axpy.fypp"
 #:include "src/f77/blas/copy_swap.fypp"
 #:include "src/f77/blas/dot_product.fypp"
+#:include "src/f77/blas/sdsdot.fypp"
 #:include "src/f77/blas/rotm.fypp"
 #:include "src/f77/blas/rotmg.fypp"
 #:include "src/f77/blas/gbmv.fypp"
@@ -32,6 +33,7 @@
 #:include "src/f77/blas/iamax_iamin.fypp"
 #:include "src/f77/blas/iamin_stub.fypp"
 #:endmute
+!> Improved and original F77 interfaces for blas
 module f77_blas
 use iso_fortran_env
 implicit none
@@ -43,11 +45,13 @@ implicit none
 !https://spec.oneapi.com/versions/latest/elements/oneMKL/source/domains/blas/scal.html#onemkl-blas-scal
 
 ! BLAS level 1
-!!$:f77_interface('?asum',  DEFAULT_TYPES, asum, result=REAL_TYPES)
+$:f77_interface('?asum',  DEFAULT_TYPES, asum, &
+    f=lambda pfx: 'sc' if pfx == 'c' else &
+                  'dz' if pfx == 'z' else pfx) 
 $:f77_interface('?axpy',  DEFAULT_TYPES, axpy)
 $:f77_interface('?copy',  DEFAULT_TYPES, copy_swap)
-!$:f77_interface('?dot',  REAL_TYPES, dot_product, result=REAL_TYPES)
-!$:f77_interface('sdsdot')
+$:f77_interface('?dot',   REAL_TYPES,    dot_product)
+$:f77_interface('sdsdot', ['s'],         sdsdot)
 $:f77_interface('?dotu',  COMPLEX_TYPES, dot_product)
 $:f77_interface('?dotc',  COMPLEX_TYPES, dot_product)
 !$:f77_interface('?nrm2', DEFAULT_TYPES, nrm2, result=REAL_TYPES)

src/f77/blas/asum.fypp

@@ -1,8 +1,8 @@
-#:def asum(NAME,TYPE,KIND)
+#:def asum(NAME,TYPE,KIND,PREFIX)
 pure function ${NAME}$(n, x, incx)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)
-    ${TYPE}$ :: ${NAME}$
+    ${REAL_TYPE}$ :: ${NAME}$
 @:args(${TYPE}$, in, x(*))
 @:args(integer,  in, n, incx)
 end function

src/f77/blas/axpy.fypp

@@ -1,4 +1,4 @@
-#:def axpy(NAME,TYPE,KIND)
+#:def axpy(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(n, a, x, incx, y, incy)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/copy_swap.fypp

@@ -1,4 +1,4 @@
-#:def copy_swap(NAME,TYPE,KIND)
+#:def copy_swap(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(n, x, incx, y, incy)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/dot_product.fypp

@@ -1,4 +1,4 @@
-#:def dot_product(NAME,TYPE,KIND)
+#:def dot_product(NAME,TYPE,KIND,PREFIX)
 pure function ${NAME}$(n, x, incx, y, incy)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/gbmv.fypp

@@ -1,4 +1,4 @@
-#:def gbmv(NAME,TYPE,KIND)
+#:def gbmv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/gemm.fypp

@@ -1,4 +1,4 @@
-#:def gemm(NAME,TYPE,KIND)
+#:def gemm(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/gemv.fypp

@@ -1,4 +1,4 @@
-#:def gemv(NAME,TYPE,KIND)
+#:def gemv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/ger_gerc_geru.fypp

@@ -1,4 +1,4 @@
-#:def ger_gerc_geru(NAME,TYPE,KIND)
+#:def ger_gerc_geru(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(m, n, alpha, x, incx, y, incy, a, lda)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/hbmv_sbmv.fypp

@@ -1,4 +1,4 @@
-#:def hbmv_sbmv(NAME,TYPE,KIND)
+#:def hbmv_sbmv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/hemm_symm.fypp

@@ -1,4 +1,4 @@
-#:def hemm_symm(NAME,TYPE,KIND)
+#:def hemm_symm(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/hemv_symv.fypp

@@ -1,4 +1,4 @@
-#:def hemv_symv(NAME,TYPE,KIND)
+#:def hemv_symv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/her.fypp

@@ -1,4 +1,4 @@
-#:def her(NAME,TYPE,KIND)
+#:def her(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, alpha, x, incx, a, lda)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/her2k.fypp

@@ -1,4 +1,4 @@
-#:def her2k(NAME,TYPE,KIND)
+#:def her2k(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/her_syr2.fypp

@@ -1,4 +1,4 @@
-#:def her_syr2(NAME,TYPE,KIND)
+#:def her_syr2(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, alpha, x, incx, y, incy, a, lda)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/herk.fypp

@@ -1,4 +1,4 @@
-#:def herk(NAME,TYPE,KIND)
+#:def herk(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/hpmv_spmv.fypp

@@ -1,4 +1,4 @@
-#:def hpmv_spmv(NAME,TYPE,KIND)
+#:def hpmv_spmv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, alpha, ap, x, incx, beta, y, incy)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/hpr.fypp

@@ -1,4 +1,4 @@
-#:def hpr(NAME,TYPE,KIND)
+#:def hpr(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, alpha, x, incx, ap)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/hpr_spr2.fypp

@@ -1,4 +1,4 @@
-#:def hpr_spr2(NAME,TYPE,KIND)
+#:def hpr_spr2(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, alpha, x, incx, y, incy, ap)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/iamax_iamin.fypp

@@ -1,4 +1,4 @@
-#:def iamax_iamin(NAME,TYPE,KIND)
+#:def iamax_iamin(NAME,TYPE,KIND,PREFIX)
 pure function ${NAME}$(n, x, incx)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/iamin_stub.fypp

@@ -1,4 +1,4 @@
-#:def iamin_stub(NAME,TYPE,KIND)
+#:def iamin_stub(NAME,TYPE,KIND,PREFIX)
 pure function ${NAME}$(n, x, incx)
 @:parameter(integer, wp=${KIND}$)
     integer :: ${NAME}$

src/f77/blas/rotm.fypp

@@ -1,4 +1,4 @@
-#:def rotm(NAME,TYPE,KIND)
+#:def rotm(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(n, x, incx, y, incy, param)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/rotmg.fypp

@@ -1,4 +1,4 @@
-#:def rotmg(NAME,TYPE,KIND)
+#:def rotmg(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(d1, d2, x1, y1, param)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/sdsdot.fypp

@@ -0,0 +1,17 @@
+
+#:def sdsdot(NAME,TYPE,KIND,PREFIX)
+!> Compute the inner product of two vectors with extended
+!> precision accumulation.
+!>
+!> Returns S.P. result with dot product accumulated in D.P.
+!> SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
+!> where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
+!> defined in a similar way using INCY.
+pure function ${NAME}$(n, sb, sx, incx, sy, incy)
+    import :: ${KIND}$
+@:parameter(integer, wp=${KIND}$)
+    ${TYPE}$ :: ${NAME}$
+@:args(${TYPE}$, in, sx(*), sy(*), sb)
+@:args(integer,  in, n, incx, incy)
+end function
+#:enddef

src/f77/blas/spr.fypp

@@ -1,4 +1,4 @@
-#:def spr(NAME,TYPE,KIND)
+#:def spr(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, alpha, x, incx, ap)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/syr.fypp

@@ -1,4 +1,4 @@
-#:def syr(NAME,TYPE,KIND)
+#:def syr(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, alpha, x, incx, a, lda)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/syr2k.fypp

@@ -1,4 +1,4 @@
-#:def syr2k(NAME,TYPE,KIND)
+#:def syr2k(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/syrk.fypp

@@ -1,4 +1,4 @@
-#:def syrk(NAME,TYPE,KIND)
+#:def syrk(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/tbmv_tbsv.fypp

@@ -1,4 +1,4 @@
-#:def tbmv_tbsv(NAME,TYPE,KIND)
+#:def tbmv_tbsv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, trans, diag, n, k, a, lda, x, incx)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/tpmv_tpsv.fypp

@@ -1,4 +1,4 @@
-#:def tpmv_tpsv(NAME,TYPE,KIND)
+#:def tpmv_tpsv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, trans, diag, n, ap, x, incx)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/trmm_trsm.fypp

@@ -1,4 +1,4 @@
-#:def trmm_trsm(NAME,TYPE,KIND)
+#:def trmm_trsm(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/blas/trmv_trsv.fypp

@@ -1,4 +1,4 @@
-#:def trmv_trsv(NAME,TYPE,KIND)
+#:def trmv_trsv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, trans, diag, n, a, lda, x, incx)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack.fpp

@@ -15,6 +15,7 @@
 #:include "src/f77/lapack/potrs.fypp"
 #:include "src/f77/lapack/pocon.fypp"
 #:endmute
+!> Improved and original F77 interfaces for LAPACK
 module f77_lapack
 use iso_fortran_env
 implicit none

src/f77/lapack/aux_lartg.fypp

@@ -1,4 +1,4 @@
-#:def aux_lartg(NAME,TYPE,KIND)
+#:def aux_lartg(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(f, g, c, s, r)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/geqrf_gerqf.fypp

@@ -1,4 +1,4 @@
-#:def geqrf_gerqf(NAME,TYPE,KIND)
+#:def geqrf_gerqf(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(m,n,a,lda,tau,work,lwork,info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/gesvd.fypp

@@ -1,4 +1,4 @@
-#:def gesvd(NAME,TYPE,KIND)
+#:def gesvd(NAME,TYPE,KIND,PREFIX)
 #:if TYPE == COMPLEX_TYPE
 pure subroutine ${NAME}$(jobu,jobvt,m,n,a,lda,s,u,ldu,vt,ldvt,work,lwork,rwork,info)
 #:else

src/f77/lapack/getrf.fypp

@@ -1,4 +1,4 @@
-#:def getrf(NAME,TYPE,KIND)
+#:def getrf(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(m,n,a,lda,ipiv,info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/getri.fypp

@@ -1,4 +1,4 @@
-#:def getri(NAME,TYPE,KIND)
+#:def getri(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(n,a,lda,ipiv,work,lwork,info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/getrs.fypp

@@ -1,4 +1,4 @@
-#:def getrs(NAME,TYPE,KIND)
+#:def getrs(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(trans,n,nrhs,a,lda,ipiv,b,ldb,info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/heevd.fypp

@@ -1,4 +1,4 @@
-#:def heevd(NAME,TYPE,KIND)
+#:def heevd(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork, iwork, liwork, info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/heevr.fypp

@@ -1,4 +1,4 @@
-#:def heevr(NAME,TYPE,KIND)
+#:def heevr(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(jobz,range,uplo,n,a,lda,vl,vu,il,iu,abstol,m,w,z,ldz,&
                          isuppz,work,lwork,rwork,lrwork,iwork,liwork,info)
     import :: ${KIND}$

src/f77/lapack/heevx.fypp

@@ -1,4 +1,4 @@
-#:def heevx(NAME,TYPE,KIND)
+#:def heevx(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(jobz,range,uplo,n,a,lda,vl,vu,il,iu,abstol,m,w,z,ldz,&
                          work,lwork,rwork,lrwork,iwork,liwork,ifail,info)
     import :: ${KIND}$

src/f77/lapack/hegv.fypp

@@ -1,4 +1,4 @@
-#:def hegv(NAME,TYPE,KIND)
+#:def hegv(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/hetrf.fypp

@@ -1,4 +1,4 @@
-#:def hetrf(NAME,TYPE,KIND)
+#:def hetrf(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, a, lda, ipiv, work, lwork, info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/pocon.fypp

@@ -12,11 +12,10 @@
 !   integer,      dimension( * )   iwork,
 ! if COMPLEX_TYPES then,
 !   real(wp),     dimension( * )   rwork,
-!   integer                        info 
+!   integer                        info
 !)
-#:def pocon(NAME, TYPE, KIND)
+#:def pocon(NAME,TYPE,KIND,PREFIX)
 #:set TYPE_AND_KIND = TYPE.replace('wp',KIND)
-#:set PREFIX        = TYPE_AND_KIND_TO_PREFIX.get(TYPE_AND_KIND).upper()
 !> ${NAME}$ estimates the reciprocal of the condition number (in the
 !> 1-norm) of a ${TYPE_AND_KIND}$ Hermitian positive definite matrix using the
 !> Cholesky factorization A = U**H*U or A = L*L**H computed by ${PREFIX}$POTRF.

src/f77/lapack/potrf_potri.fypp

@@ -1,4 +1,4 @@
-#:def potrf_potri(NAME,TYPE,KIND)
+#:def potrf_potri(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, a, lda, info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/f77/lapack/potrs.fypp

@@ -1,4 +1,4 @@
-#:def potrs(NAME,TYPE,KIND)
+#:def potrs(NAME,TYPE,KIND,PREFIX)
 pure subroutine ${NAME}$(uplo, n, nrhs, a, lda, b, ldb, info)
     import :: ${KIND}$
 @:parameter(integer, wp=${KIND}$)

src/mfi/blas.fpp

@@ -29,6 +29,7 @@
 #:include "src/mfi/blas/syr2k.fypp"
 #:include "src/mfi/blas/trmm_trsm.fypp"
 #:endmute
+!> Modern fortran interfaces for BLAS
 module mfi_blas
 use iso_fortran_env
 use f77_blas

src/mfi/blas/axpy.fypp

@@ -1,4 +1,4 @@
-#:def axpy(MFI_NAME,F77_NAME,TYPE,KIND)
+#:def axpy(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX)
 pure subroutine ${MFI_NAME}$(x, y, a, incx, incy)
 @:parameter(integer, wp=${KIND}$)
 @:args(${TYPE}$, in,    x(:))

src/mfi/blas/copy_swap.fypp

@@ -1,4 +1,4 @@
-#:def copy_swap(MFI_NAME,F77_NAME,TYPE,KIND)
+#:def copy_swap(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX)
 pure subroutine ${MFI_NAME}$(x, y, incx, incy)
 @:parameter(integer, wp=${KIND}$)
 @:args(${TYPE}$, in,    x(:))