(update) Added ?LAMCH

14NGiestas · Nov 26, 2024 · bff02b8 · bff02b8
1 parent d16c1cc
commit bff02b8
Show file tree

Hide file tree

Showing 5 changed files with 68 additions and 43 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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