diff --git a/README.md b/README.md index 81aa376d..cfa88ad7 100644 --- a/README.md +++ b/README.md @@ -167,11 +167,11 @@ Most of BLAS level 1 routines can be replaced by intrinsincs and other features Here are some extensions that may be useful. Again, BLAS level 1 routines can be replaced by intrinsincs and other features in modern fortran. -| done? | name | description | modern alternative | -| ----- | ----- | -------------------------------------------------------- | ------------------- | -| :+1: | iamax | Index of the maximum absolute value element of a vector | [maxval](https://gcc.gnu.org/onlinedocs/gfortran/MAXVAL.html), [maxloc](https://gcc.gnu.org/onlinedocs/gfortran/MAXLOC.html) | -| :+1: | iamin | Index of the minimum absolute value element of a vector | [minval](https://gcc.gnu.org/onlinedocs/gfortran/MINVAL.html), [minloc](https://gcc.gnu.org/onlinedocs/gfortran/MINLOC.html) | -| :+1: | lamch | Determines single precision machine parameters. | [huge](https://gcc.gnu.org/onlinedocs/gfortran/intrinsic-procedures/huge.html), [tiny](https://gcc.gnu.org/onlinedocs/gfortran/intrinsic-procedures/tiny.html), [epsilon](https://gcc.gnu.org/onlinedocs/gfortran/intrinsic-procedures/epsilon.html) | +| done? | name | description | modern alternative | obs | +| ----- | ----- | -------------------------------------------------------- | ------------------- | --- | +| :+1: | iamax | Index of the maximum absolute value element of a vector | [maxval](https://gcc.gnu.org/onlinedocs/gfortran/MAXVAL.html), [maxloc](https://gcc.gnu.org/onlinedocs/gfortran/MAXLOC.html) | | +| :+1: | iamin | Index of the minimum absolute value element of a vector | [minval](https://gcc.gnu.org/onlinedocs/gfortran/MINVAL.html), [minloc](https://gcc.gnu.org/onlinedocs/gfortran/MINLOC.html) | | +| :( | lamch | Determines single precision machine parameters. | [huge](https://gcc.gnu.org/onlinedocs/gfortran/intrinsic-procedures/huge.html), [tiny](https://gcc.gnu.org/onlinedocs/gfortran/intrinsic-procedures/tiny.html), [epsilon](https://gcc.gnu.org/onlinedocs/gfortran/intrinsic-procedures/epsilon.html) | Obs: had to turn it into a subroutine as fortran can't create a interface with the same arguments: `call mfi_lamch(cmach, output)`, for values of cmach see: [lamch](https://www.netlib.org/lapack//explore-html/d4/d86/group__lamch.html)| ### LAPACK #### Linear Equation Routines diff --git a/common.fpp b/common.fpp index 52617cdd..54d3cbfc 100644 --- a/common.fpp +++ b/common.fpp @@ -68,7 +68,7 @@ #:set F77_NAME = f"f77_{name.replace('?','')}" #: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,name.replace('?',PREFIX)) #:endfor #:enddef diff --git a/src/f77/blas.fpp b/src/f77/blas.fpp index 85714d10..069e1c8f 100644 --- a/src/f77/blas.fpp +++ b/src/f77/blas.fpp @@ -443,5 +443,18 @@ contains $:f77_implement('i?amin', DEFAULT_TYPES, iamin_stub) #:endif #:endif + +interface + pure real(REAL32) function slamch(cmach) + import :: REAL32 + character, intent(in) :: cmach + end function + + pure real(REAL64) function dlamch(cmach) + import :: REAL64 + character, intent(in) :: cmach + end function +end interface + end module diff --git a/src/mfi/blas.fpp b/src/mfi/blas.fpp index adf71a15..18f87022 100644 --- a/src/mfi/blas.fpp +++ b/src/mfi/blas.fpp @@ -1,6 +1,16 @@ #:mute #:include "common.fpp" -#:def axpy(MFI_NAME,F77_NAME,TYPE,KIND) + +#:def lamch(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) +pure subroutine ${MFI_NAME}$(cmach, res) +@:parameter(integer, wp=${KIND}$) +@:args(${TYPE}$, out, res) +@:args(character, in, cmach) + res = ${ORIGINAL_NAME}$(cmach) +end subroutine +#:enddef + +#:def axpy(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(x, y, a, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:)) @@ -14,7 +24,7 @@ pure subroutine ${MFI_NAME}$(x, y, a, incx, incy) end subroutine #:enddef -#:def copy_swap(MFI_NAME,F77_NAME,TYPE,KIND) +#:def copy_swap(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(x, y, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:)) @@ -27,7 +37,7 @@ pure subroutine ${MFI_NAME}$(x, y, incx, incy) end subroutine #:enddef -#:def dot_product(MFI_NAME,F77_NAME,TYPE,KIND) +#:def dot_product(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure function ${MFI_NAME}$(x, y, incx, incy) @:parameter(integer, wp=${KIND}$) ${TYPE}$ :: ${MFI_NAME}$ @@ -40,7 +50,7 @@ pure function ${MFI_NAME}$(x, y, incx, incy) end function #:enddef -#:def rotm(MFI_NAME,F77_NAME,TYPE,KIND) +#:def rotm(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(x, y, param, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, x(:), y(:)) @@ -53,7 +63,7 @@ pure subroutine ${MFI_NAME}$(x, y, param, incx, incy) end subroutine #:enddef -#:def iamin_iamax(MFI_NAME,F77_NAME,TYPE,KIND) +#:def iamin_iamax(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure function ${MFI_NAME}$(x, incx) @:parameter(integer, wp=${KIND}$) integer :: ${MFI_NAME}$ @@ -66,7 +76,7 @@ pure function ${MFI_NAME}$(x, incx) end function #:enddef -#:def gbmv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def gbmv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, y, kl, m, alpha, beta, trans, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:), x(:)) @@ -83,7 +93,7 @@ pure subroutine ${MFI_NAME}$(a, x, y, kl, m, alpha, beta, trans, incx, incy) end subroutine #:enddef -#:def gemv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def gemv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, y, trans, alpha, beta, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:), x(:)) @@ -100,7 +110,7 @@ pure subroutine ${MFI_NAME}$(a, x, y, trans, alpha, beta, incx, incy) end subroutine #:enddef -#:def ger_gerc_geru(MFI_NAME,F77_NAME,TYPE,KIND) +#:def ger_gerc_geru(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, y, alpha, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:), y(:)) @@ -116,7 +126,7 @@ pure subroutine ${MFI_NAME}$(a, x, y, alpha, incx, incy) end subroutine #:enddef -#:def hbmv_sbmv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def hbmv_sbmv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, beta, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:), a(:,:)) @@ -133,7 +143,7 @@ pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, beta, incx, incy) end subroutine #:enddef -#:def hemv_symv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def hemv_symv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, beta, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:), a(:,:)) @@ -149,7 +159,7 @@ pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, beta, incx, incy) end subroutine #:enddef -#:def her(MFI_NAME,F77_NAME,TYPE,KIND) +#:def her(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, uplo, alpha, incx) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:)) @@ -165,7 +175,7 @@ pure subroutine ${MFI_NAME}$(a, x, uplo, alpha, incx) end subroutine #:enddef -#:def syr(MFI_NAME,F77_NAME,TYPE,KIND) +#:def syr(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, uplo, alpha, incx) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:)) @@ -181,7 +191,7 @@ pure subroutine ${MFI_NAME}$(a, x, uplo, alpha, incx) end subroutine #:enddef -#:def her_syr2(MFI_NAME,F77_NAME,TYPE,KIND) +#:def her_syr2(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:), y(:)) @@ -197,7 +207,7 @@ pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, incx, incy) end subroutine #:enddef -#:def hpmv_spmv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def hpmv_spmv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(ap, x, y, uplo, alpha, beta, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:), ap(:)) @@ -212,7 +222,7 @@ pure subroutine ${MFI_NAME}$(ap, x, y, uplo, alpha, beta, incx, incy) end subroutine #:enddef -#:def hpr(MFI_NAME,F77_NAME,TYPE,KIND) +#:def hpr(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(ap, x, uplo, alpha, incx) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:)) @@ -227,7 +237,7 @@ pure subroutine ${MFI_NAME}$(ap, x, uplo, alpha, incx) end subroutine #:enddef -#:def spr(MFI_NAME,F77_NAME,TYPE,KIND) +#:def spr(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(ap, x, uplo, alpha, incx) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:)) @@ -242,7 +252,7 @@ pure subroutine ${MFI_NAME}$(ap, x, uplo, alpha, incx) end subroutine #:enddef -#:def hpr_spr2(MFI_NAME,F77_NAME,TYPE,KIND) +#:def hpr_spr2(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(ap, x, y, uplo, alpha, incx, incy) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, x(:), y(:)) @@ -257,7 +267,7 @@ pure subroutine ${MFI_NAME}$(ap, x, y, uplo, alpha, incx, incy) end subroutine #:enddef -#:def tbmv_tbsv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def tbmv_tbsv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, uplo, trans, diag, incx) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:)) @@ -273,7 +283,7 @@ pure subroutine ${MFI_NAME}$(a, x, uplo, trans, diag, incx) end subroutine #:enddef -#:def tpmv_tpsv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def tpmv_tpsv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(ap, x, uplo, trans, diag, incx) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, ap(:)) @@ -287,7 +297,7 @@ pure subroutine ${MFI_NAME}$(ap, x, uplo, trans, diag, incx) end subroutine #:enddef -#:def trmv_trsv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def trmv_trsv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, x, uplo, trans, diag, incx) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:)) @@ -302,7 +312,7 @@ pure subroutine ${MFI_NAME}$(a, x, uplo, trans, diag, incx) end subroutine #:enddef -#:def gemm(MFI_NAME,F77_NAME,TYPE,KIND) +#:def gemm(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, b, c, transa, transb, alpha, beta) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:), b(:,:)) @@ -325,7 +335,7 @@ pure subroutine ${MFI_NAME}$(a, b, c, transa, transb, alpha, beta) end subroutine #:enddef -#:def hemm_symm(MFI_NAME,F77_NAME,TYPE,KIND) +#:def hemm_symm(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, b, c, side, uplo, alpha, beta) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:), b(:,:)) @@ -343,7 +353,7 @@ pure subroutine ${MFI_NAME}$(a, b, c, side, uplo, alpha, beta) end subroutine #:enddef -#:def herk(MFI_NAME,F77_NAME,TYPE,KIND) +#:def herk(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, c, uplo, trans, alpha, beta) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:)) @@ -364,7 +374,7 @@ pure subroutine ${MFI_NAME}$(a, c, uplo, trans, alpha, beta) end subroutine #:enddef -#:def syrk(MFI_NAME,F77_NAME,TYPE,KIND) +#:def syrk(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, c, uplo, trans, alpha, beta) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:)) @@ -385,7 +395,7 @@ pure subroutine ${MFI_NAME}$(a, c, uplo, trans, alpha, beta) end subroutine #:enddef -#:def her2k(MFI_NAME,F77_NAME,TYPE,KIND) +#:def her2k(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, b, c, uplo, trans, alpha, beta) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:)) @@ -409,7 +419,7 @@ pure subroutine ${MFI_NAME}$(a, b, c, uplo, trans, alpha, beta) end subroutine #:enddef -#:def syr2k(MFI_NAME,F77_NAME,TYPE,KIND) +#:def syr2k(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, b, c, uplo, trans, alpha, beta) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:)) @@ -432,7 +442,7 @@ pure subroutine ${MFI_NAME}$(a, b, c, uplo, trans, alpha, beta) end subroutine #:enddef -#:def trmm_trsm(MFI_NAME,F77_NAME,TYPE,KIND) +#:def trmm_trsm(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, b, side, uplo, transa, diag, alpha) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:)) @@ -516,6 +526,7 @@ $:mfi_interface('i?amax', DEFAULT_TYPES) #:if defined('MFI_EXTENSIONS') $:mfi_interface('i?amin', DEFAULT_TYPES) #:endif +$:mfi_interface('?lamch', REAL_TYPES) contains @@ -579,5 +590,6 @@ $:mfi_implement('i?amax', DEFAULT_TYPES, iamin_iamax) #:if defined('MFI_EXTENSIONS') $:mfi_implement('i?amin', DEFAULT_TYPES, iamin_iamax) #:endif +$:mfi_implement('?lamch', REAL_TYPES, lamch) end module diff --git a/src/mfi/lapack.fpp b/src/mfi/lapack.fpp index 81e172ca..b6d3beec 100644 --- a/src/mfi/lapack.fpp +++ b/src/mfi/lapack.fpp @@ -1,7 +1,7 @@ #:mute #:include "common.fpp" -#:def geqrf_gerqf(MFI_NAME,F77_NAME,TYPE,KIND) +#:def geqrf_gerqf(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, tau, info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:)) @@ -48,7 +48,7 @@ pure subroutine ${MFI_NAME}$(a, tau, info) end subroutine #:enddef -#:def getrf(MFI_NAME,F77_NAME,TYPE,KIND) +#:def getrf(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, ipiv, info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:)) @@ -81,7 +81,7 @@ pure subroutine ${MFI_NAME}$(a, ipiv, info) end subroutine #:enddef -#:def getri(MFI_NAME,F77_NAME,TYPE,KIND) +#:def getri(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, ipiv, info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:)) @@ -112,7 +112,7 @@ pure subroutine ${MFI_NAME}$(a, ipiv, info) end subroutine #:enddef -#:def getrs(MFI_NAME,F77_NAME,TYPE,KIND) +#:def getrs(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a,ipiv,b,trans,info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:)) @@ -135,7 +135,7 @@ pure subroutine ${MFI_NAME}$(a,ipiv,b,trans,info) end subroutine #:enddef -#:def hetrf(MFI_NAME,F77_NAME,TYPE,KIND) +#:def hetrf(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, uplo, ipiv, info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:)) @@ -174,7 +174,7 @@ pure subroutine ${MFI_NAME}$(a, uplo, ipiv, info) end subroutine #:enddef -#:def gesvd(MFI_NAME,F77_NAME,TYPE,KIND) +#:def gesvd(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, s, u, vt, ww, job, info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:)) @@ -265,7 +265,7 @@ pure subroutine ${MFI_NAME}$(a, s, u, vt, ww, job, info) end subroutine #:enddef -#:def hegv(MFI_NAME,F77_NAME,TYPE,KIND) +#:def hegv(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, b, w, itype, jobz, uplo, info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:), b(:,:)) @@ -306,7 +306,7 @@ pure subroutine ${MFI_NAME}$(a, b, w, itype, jobz, uplo, info) end subroutine #:enddef -#:def heevd(MFI_NAME,F77_NAME,TYPE,KIND) +#:def heevd(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, w, jobz, uplo, info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:)) @@ -357,7 +357,7 @@ pure subroutine ${MFI_NAME}$(a, w, jobz, uplo, info) end subroutine #:enddef -#:def potrf_potri(MFI_NAME,F77_NAME,TYPE,KIND) +#:def potrf_potri(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, info, uplo) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, inout, a(:,:)) @@ -376,7 +376,7 @@ pure subroutine ${MFI_NAME}$(a, info, uplo) end subroutine #:enddef -#:def potrs(MFI_NAME,F77_NAME,TYPE,KIND) +#:def potrs(MFI_NAME,F77_NAME,TYPE,KIND,ORIGINAL_NAME) pure subroutine ${MFI_NAME}$(a, b, uplo, info) @:parameter(integer, wp=${KIND}$) @:args(${TYPE}$, in, a(:,:))