diff --git a/common.fpp b/common.fpp index fc1c5dfa..4bd99bb2 100644 --- a/common.fpp +++ b/common.fpp @@ -1,68 +1,97 @@ #:mute -#:set REAL_TYPE = 'real(wp)' -#:set COMPLEX_TYPE = 'complex(wp)' + +#:set REAL = 'real(wp)' +#:set COMPLEX = 'complex(wp)' +#:set PREFIX = { & + 's': { 'type': 'real(wp)', 'wp': 'REAL32'}, & + 'd': { 'type': 'real(wp)', 'wp': 'REAL64'}, & + 'c': { 'type': 'complex(wp)', 'wp': 'REAL32'}, & + 'z': { 'type': 'complex(wp)', 'wp': 'REAL64'}, & +} + +#:set ERROR = lambda pfx: { 'type': f'error: {pfx}', 'wp' : f'error: {pfx}' } + +#:set mix = lambda l, r: list(lp + rp for lp, rp in zip(l,r)) +#:set split = lambda pfx: list(pfx) if len(pfx) > 1 else pfx +#:set get_types = lambda pfxs: (pfxs[0], pfxs[0] if len(pfxs) == 1 else pfxs[1]) +#:set get = lambda pfx,what: PREFIX.get(pfx).get(what) +#:set prefix = lambda pfx, name: name.replace('?',pfx) +#:set kind = lambda pfx: get(pfx,'wp') +#:set type = lambda pfx: get(pfx,'type').replace('wp',kind(pfx)) +#:set real = lambda pfx: REAL.replace('wp',kind(pfx)) +#:set complex= lambda pfx: COMPLEX.replace('wp',kind(pfx)) + +#:set SINGLE_TYPES = ['s','c'] +#:set DOUBLE_TYPES = ['d','z'] #:set REAL_TYPES = ['s','d'] #:set COMPLEX_TYPES = ['c','z'] #:set DEFAULT_TYPES = REAL_TYPES + COMPLEX_TYPES -#:set REAL_COMPLEX_TYPES = ['sc','dz'] -#:set COMPLEX_REAL_TYPES = ['cs','zd'] -#! Function that handles mixed types conventions -#:set MIX = lambda when, use, pfx: & - use[when.index(pfx)] if pfx in when else pfx +#:set MIX_REAL_COMPLEX = mix(REAL_TYPES,COMPLEX_TYPES) +#:set MIX_COMPLEX_REAL = mix(COMPLEX_TYPES,REAL_TYPES) +#:set MIX_SINGLE_DOUBLE = mix(SINGLE_TYPES,DOUBLE_TYPES) +#:set MIX_DOUBLE_SINGLE = mix(DOUBLE_TYPES,SINGLE_TYPES) -#:set MIX_REAL_COMPLEX = lambda pfx: MIX(COMPLEX_TYPES,REAL_COMPLEX_TYPES,pfx) -#:set MIX_COMPLEX_REAL = lambda pfx: MIX(COMPLEX_TYPES,COMPLEX_REAL_TYPES,pfx) +${type('s')}$ :: variable +${get('s','wp')}$ +${prefix('s','?gemm')}$ -#:set PREFIX_TO_TYPE={ & - 's': REAL_TYPE, & - 'd': REAL_TYPE, & - 'c': COMPLEX_TYPE, & - 'z': COMPLEX_TYPE, & -} +${mix(REAL_TYPES,COMPLEX_TYPES)}$ +${mix(COMPLEX_TYPES,REAL_TYPES)}$ +${mix(SINGLE_TYPES,DOUBLE_TYPES)}$ +${mix(DOUBLE_TYPES,SINGLE_TYPES)}$ -#:set PREFIX_TO_KIND={& - 's': 'REAL32', & - 'd': 'REAL64', & - 'c': 'REAL32', & - 'z': 'REAL64', & -} +${list(map(split, mix(REAL_TYPES, COMPLEX_TYPES)))}$ +${list(map(split, mix(COMPLEX_TYPES, REAL_TYPES)))}$ +${list(map(split, mix(SINGLE_TYPES,DOUBLE_TYPES)))}$ +${list(map(split, mix(DOUBLE_TYPES,SINGLE_TYPES)))}$ -#:set TYPE_AND_KIND_TO_PREFIX = { & - 'real(REAL32)': 's', & - 'real(REAL64)': 'd', & - 'complex(REAL32)': 'c', & - 'complex(REAL64)': 'z', & -} +#:def timeit(message, code) +block +real :: t1, t2 +call cpu_time(t1) +$:code +call cpu_time(t2) +print '(A," (",G0,"s)")', ${message}$, t2-t1 +end block +#:enddef -#! Defines a optional variable, creating local corresponding variable by default -#:def optional(dtype, intent, *args) -#:for variable in args - ${dtype}$, intent(${intent}$), optional :: ${variable}$ - ${dtype}$ :: local_${variable}$ -#:endfor +#:def random_number(type, name, shape='') +#:if type.startswith('complex') + $:random_complex(type, name,shape) +#:else + call random_number(${name}$) +#:endif #:enddef -#! Handles a value of "variable" depending on "condition" -#:def optval(condition, variable, true_value, false_value) - if (${condition}$) then - ${variable}$ = ${true_value}$ - else - ${variable}$ = ${false_value}$ - end if +#:def random_complex(type, name, shape='') +#:set REAL = type.replace('complex','real') +block + ${REAL}$ :: re${shape}$ + ${REAL}$ :: im${shape}$ + call random_number(im) + call random_number(re) + ${name}$ = cmplx(re,im) +end block #:enddef -#! Handles default values of the optional -#:def defaults(**kwargs) -#:for variable, default in kwargs.items() - if (present(${variable}$)) then - local_${variable}$ = ${variable}$ - else - local_${variable}$ = ${default}$ - end if +#! Handles parameters (usage: working precision) +#:def parameter(dtype, **kwargs) +#:for variable, value in kwargs.items() + ${dtype}$, parameter :: ${variable}$ = ${value}$ #:endfor #:enddef +#! Handles importing and setting precision constants in interfaces +#:def imports(pfxs) +#:set wps = set(list(map(kind, pfxs))) +#:if len(wps) > 1 + import :: ${', '.join(wps)}$ +#:else + import :: ${''.join(wps)}$ +#:endif +#:enddef + #! Handles the input/output arguments #:def args(dtype, intent, *args) #:for variable in args @@ -70,108 +99,159 @@ #:endfor #:enddef -#! Handles parameters (usage: working precision) -#:def parameter(dtype, **kwargs) -#:for variable, value in kwargs.items() - ${dtype}$, parameter :: ${variable}$ = ${value}$ +#! Defines a optional variable, creating local corresponding variable by default +#:def optional(dtype, intent, *args) +#:for variable in args + ${dtype}$, intent(${intent}$), optional :: ${variable}$ + ${dtype}$ :: local_${variable}$ #:endfor #:enddef -#! Handles the implementation of the modern interface to each supported type and kind -#:def mfi_implement(name, supports, code, f=lambda x: x) -#:for PREFIX in supports -#:set MFI_NAME = "mfi_" + name.replace('?',f(PREFIX)) -#:set F77_NAME = name.replace('?',f(PREFIX)) -#:set TYPE = PREFIX_TO_TYPE.get(PREFIX,None) -#:set KIND = PREFIX_TO_KIND.get(PREFIX,None) -$:code(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#! Handles default values of a optional variable +#:def defaults(**kwargs) +#:for variable, default in kwargs.items() + if (present(${variable}$)) then + local_${variable}$ = ${variable}$ + else + local_${variable}$ = ${default}$ + end if #:endfor #:enddef -#! Define mfi interfaces to implemented routines -#:def mfi_interface(name, types, f=lambda x: x) -interface mfi_${name.replace('?','')}$ - #:for T in types - module procedure mfi_${name.replace('?',f(T))}$ - #:endfor -end interface +#! Handles a value of "variable" depending on "condition" +#:def optval(condition, variable, true_value, false_value) + if (${condition}$) then + ${variable}$ = ${true_value}$ + else + ${variable}$ = ${false_value}$ + end if #:enddef -#! Define f77 interfaces to implemented routines -#:def f77_interface_improved(name, types, f=lambda x: x) -interface f77_${name.replace('?','')}$ - #:for T in types - procedure :: ${name.replace('?',f(T))}$ +#:def interface(functions, procedure='procedure', name='') +interface ${name}$ + #:for function_name in functions + ${procedure}$ :: ${function_name}$ #:endfor end interface #:enddef -#! Define a f77 interfaces to the external blas/lapack library -#:def f77_interface(name, supports, code, f=lambda x: x, improved_f77=True) - +#! Interfaces for the original f77 routines +#! code must implement a routine interface +#:def f77_original(generic_name, prefixes, code) +#:set mfi = 'mfi_' + prefix('',generic_name) +#:set f77 = 'f77_' + prefix('',generic_name) +!> ${generic_name}$ supports ${', '.join(prefixes)}$. +!> See also: [[${mfi}$]], [[${f77}$]]. interface -#:for PREFIX in supports -#: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,PREFIX) +#:for pfx in prefixes +#:set name = prefix(pfx,generic_name) +#:set pfxs = list(map(split,pfx)) +$:code(name,pfxs) #:endfor end interface +#:enddef -#:if improved_f77 -$:f77_interface_improved(name, supports, f=f) -#:endif +#! Define a common interface with the original f77 interfaces +#! So you can call the original function without the prefix +#:def f77_improved(generic_name, prefixes) +#:set functions = map(lambda pfx: prefix(pfx,generic_name), prefixes) +$:interface(functions, name=f"f77_{prefix('',generic_name)}") +#:enddef + +#! In case of missing functions / extensions you can pass a code +#! in which case must provide the routine implementation +#! Must be called inside a contains block +#:def f77_implement(generic_name, prefixes, code) +#:for pfx in prefixes +#:set name = prefix(pfx,generic_name) +#:set pfxs = list(map(split,pfx)) +$:code(name,pfxs) +#:endfor +#:enddef +#:def mfi_interface(generic_name, prefixes) +#:set functions = map(lambda pfx: 'mfi_' + prefix(pfx,generic_name), prefixes) +$:interface(functions, & + procedure='module procedure', & + name=f"mfi_{prefix('',generic_name)}") #:enddef -#! Implements a f77 function / extension -#:def f77_implement(name, supports, code) -#:for PREFIX in supports -#:set NAME = name.replace('?',PREFIX) -#:set TYPE = PREFIX_TO_TYPE.get(PREFIX,None) -#:set KIND = PREFIX_TO_KIND.get(PREFIX,None) -$:code(NAME,TYPE,KIND,PREFIX) +#! Implements the modern interface in code +#! for each supported prefix combination +#! Must be called inside a contains block +#:def mfi_implement(generic_name, prefixes, code) +#:for pfx in prefixes +#:set mfi_name = 'mfi_' + prefix(pfx,generic_name) +#:set f77_name = prefix(pfx,generic_name) +#:set pfxs = list(map(split,pfx)) +$:code(mfi_name,f77_name,pfxs) #:endfor #:enddef -#! Implements a test -#:def test_implement(name, supports, code, f=lambda x: x) -#:for PREFIX in supports -#:set ORIGINAL = name.replace('?',f(PREFIX)) -#:set IMPROVED = "f77_" + name.replace('?','') -#:set MODERN = "mfi_" + name.replace('?','') -#:set TYPE = PREFIX_TO_TYPE.get(PREFIX,None) -#:set KIND = PREFIX_TO_KIND.get(PREFIX,None) -$:code(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) + +#! Implements the test for all interfaces +#! and each supported prefix combination +#! Must be called inside a contains block +#:def test_implement(generic_name, prefixes, code) +#:for pfx in prefixes +#:set f77 = prefix(pfx,generic_name) +#:set f90 = 'f77_' + prefix('',generic_name) +#:set mfi = 'mfi_' + prefix('',generic_name) +#:set pfxs = list(map(split,pfx)) +$:code(f77,f90,mfi,pfxs) #:endfor #:enddef -#! Call the subroutine test -#:def test_run(name, supports, f=lambda x: x) -#:for PREFIX in supports -#:set ORIGINAL = name.replace('?',f(PREFIX)) -#:set MODERN = "mfi_" + name.replace('?','') -@:timeit("testing ${MODERN}$ against ${ORIGINAL}$", { call test_${ORIGINAL}$ }) +#:def test_run(generic_name, prefixes) +#:for pfx in prefixes +#:set f77 = prefix(pfx,generic_name) +#:set mfi = 'mfi_' + prefix('',generic_name) +@:timeit("testing ${mfi}$ against ${f77}$", { call test_${f77}$ }) #:endfor #:enddef -#:def timeit(message, code) -block -real :: t1, t2 -call cpu_time(t1) -$:code -call cpu_time(t2) -print '(A," (",G0,"s)")', ${message}$, t2-t1 -end block +#:def rot_f77(name,pfxs) +#:set A = pfxs[0] +#:set B = A if len(pfxs) == 1 else pfxs[1] +!> ${name.upper()}$ applies a plane rotation. +pure subroutine ${name}$(n, x, incx, y, incy, c, s) + $:imports(pfxs) +@:args(${type(A)}$, in, x(*), y(*)) +@:args(${real(A)}$, in, c) +@:args(${type(B)}$, in, s) + integer, intent(in) :: n, incx, incy +end subroutine #:enddef -#:def random_complex(name, shape='') -block - ${REAL_TYPE}$ :: re${shape}$ - ${REAL_TYPE}$ :: im${shape}$ - call random_number(im) - call random_number(re) - ${name}$ = cmplx(re,im) -end block +#:def rot_mfi(mfi_name,f77_name,pfxs) +#:set A = pfxs[0] +#:set B = A if len(pfxs) == 1 else pfxs[1] +!> Given two vectors x and y, +!> each vector element of these vectors is replaced as follows: +!>```fortran +#:if type(A) == real(A) +!> xi = c*xi + s*yi +!> yi = c*yi - s*xi +#:elif type(A) == complex(A) +!> xi = c*xi + s*yi +!> yi = c*yi - conj(s)*xi +#:endif +!>``` +pure subroutine ${mfi_name}$(x, y, c, s, incx, incy) +@:args(${type(A)}$, inout, x(:), y(:)) +@:args(${real(A)}$, in, c) +@:args(${type(B)}$, in, s) +@:optional(integer, in, incx, incy) + integer :: n +@:defaults(incx=1, incy=1) + n = size(x) + call ${f77_name}$(n,x,local_incx,y,local_incy,c,s) +end subroutine #:enddef + +$:f77_original('?rot', DEFAULT_TYPES + mix(COMPLEX_TYPES,REAL_TYPES), rot_f77) +$:mfi_interface('?rot', DEFAULT_TYPES + mix(COMPLEX_TYPES,REAL_TYPES)) +$:mfi_implement('?rot', DEFAULT_TYPES + mix(COMPLEX_TYPES,REAL_TYPES), rot_mfi) + + #:endmute diff --git a/src/f77/blas.fpp b/src/f77/blas.fpp index ee91f4e8..93cc8c78 100644 --- a/src/f77/blas.fpp +++ b/src/f77/blas.fpp @@ -34,76 +34,69 @@ ! BLAS Level 1 - Extensions #:include "src/f77/blas/iamax_iamin.fypp" #:include "src/f77/blas/iamin_stub.fypp" + +#:set COLLECT = [ & + ('?copy', DEFAULT_TYPES, copy_swap), & + ('?swap', DEFAULT_TYPES, copy_swap), & + ('?axpy', DEFAULT_TYPES, axpy), & + ('?dot', REAL_TYPES, dot_product), & + ('?dotc', COMPLEX_TYPES, dot_product), & + ('?dotu', COMPLEX_TYPES, dot_product), & + ('?asum', REAL_TYPES + MIX_REAL_COMPLEX, asum_nrm2), & + ('?nrm2', REAL_TYPES + MIX_REAL_COMPLEX, asum_nrm2), & + ('?rot', DEFAULT_TYPES + MIX_COMPLEX_REAL, rot), & + ('?rotg', DEFAULT_TYPES, rotg), & + ('?rotm', REAL_TYPES, rotm), & + ('?rotmg',REAL_TYPES, rotmg), & + ('?scal', DEFAULT_TYPES + MIX_COMPLEX_REAL, scal), & + ('?gbmv', DEFAULT_TYPES, gbmv), & + ('?gemv', DEFAULT_TYPES, gemv), & + ('?ger', REAL_TYPES, ger_gerc_geru),& + ('?gerc', COMPLEX_TYPES, ger_gerc_geru),& + ('?geru', COMPLEX_TYPES, ger_gerc_geru),& + ('?hbmv', COMPLEX_TYPES, hbmv_sbmv), & + ('?hemv', COMPLEX_TYPES, hemv_symv), & + ('?her', COMPLEX_TYPES, her), & + ('?her2', COMPLEX_TYPES, her_syr2), & + ('?hpmv', COMPLEX_TYPES, hpmv_spmv), & + ('?hpr', COMPLEX_TYPES, hpr), & + ('?hpr2', COMPLEX_TYPES, hpr_spr2), & + ('?sbmv', REAL_TYPES, hbmv_sbmv), & + ('?spmv', REAL_TYPES, hpmv_spmv), & + ('?spr', REAL_TYPES, spr), & + ('?spr2', REAL_TYPES, hpr_spr2), & + ('?symv', REAL_TYPES, hemv_symv), & + ('?syr', REAL_TYPES, syr), & + ('?syr2', REAL_TYPES, her_syr2), & + ('?tbmv', DEFAULT_TYPES, tbmv_tbsv), & + ('?tbsv', DEFAULT_TYPES, tbmv_tbsv), & + ('?tpmv', DEFAULT_TYPES, tpmv_tpsv), & + ('?tpsv', DEFAULT_TYPES, tpmv_tpsv), & + ('?trmv', DEFAULT_TYPES, trmv_trsv), & + ('?trsv', DEFAULT_TYPES, trmv_trsv), & + ('?gemm', DEFAULT_TYPES, gemm), & + ('?hemm', COMPLEX_TYPES, hemm_symm), & + ('?herk', COMPLEX_TYPES, herk), & + ('?her2k',COMPLEX_TYPES, her2k), & + ('?symm', REAL_TYPES, hemm_symm), & + ('?syrk', REAL_TYPES, syrk), & + ('?syr2k',REAL_TYPES, syr2k), & + ('?trmm', DEFAULT_TYPES, trmm_trsm), & + ('?trsm', DEFAULT_TYPES, trmm_trsm), & +] #:endmute !> Improved and original F77 interfaces for BLAS module f77_blas use iso_fortran_env implicit none -! BLAS level 1 -$:f77_interface('?axpy', DEFAULT_TYPES, axpy) -$:f77_interface('?copy', DEFAULT_TYPES, copy_swap) -$:f77_interface('?dot', REAL_TYPES, dot_product) -$:f77_interface('?dotu', COMPLEX_TYPES, dot_product) -$:f77_interface('?dotc', COMPLEX_TYPES, dot_product) -$:f77_interface('?rotg', DEFAULT_TYPES, rotg) -$:f77_interface('?rotm', REAL_TYPES, rotm) -$:f77_interface('?rotmg', REAL_TYPES, rotmg) -$:f77_interface('?swap', DEFAULT_TYPES, copy_swap) - -#! Problematic functions -#! asum has special names indicating the returns are real types -$:f77_interface('?asum', DEFAULT_TYPES, asum_nrm2, MIX_REAL_COMPLEX) -#! nrm2 has the same interface as asum -$:f77_interface('?nrm2', DEFAULT_TYPES, asum_nrm2, MIX_REAL_COMPLEX) -#! scal has mixed types scalars so it can multiply a real constant by a complex vector -$:f77_interface('?scal', DEFAULT_TYPES, scal, improved_f77=False) -$:f77_interface('?scal', COMPLEX_TYPES, scal_mixed, improved_f77=False, f=MIX_COMPLEX_REAL) -$:f77_interface_improved('?scal', DEFAULT_TYPES + COMPLEX_REAL_TYPES) - -#! ?rot has mixed types scalars so it can multiply a real constant by a complex vector -$:f77_interface('?rot', DEFAULT_TYPES, rot, improved_f77=False) -$:f77_interface('?rot', COMPLEX_TYPES, rot_mixed, improved_f77=False, f=MIX_COMPLEX_REAL) -$:f77_interface_improved('?rot', DEFAULT_TYPES + COMPLEX_REAL_TYPES) - -! BLAS level 2 -$:f77_interface('?gbmv', DEFAULT_TYPES, gbmv) -$:f77_interface('?gemv', DEFAULT_TYPES, gemv) -$:f77_interface('?ger', REAL_TYPES, ger_gerc_geru) -$:f77_interface('?gerc', COMPLEX_TYPES, ger_gerc_geru) -$:f77_interface('?geru', COMPLEX_TYPES, ger_gerc_geru) -$:f77_interface('?hbmv', COMPLEX_TYPES, hbmv_sbmv) -$:f77_interface('?hemv', COMPLEX_TYPES, hemv_symv) -$:f77_interface('?her', COMPLEX_TYPES, her) -$:f77_interface('?her2', COMPLEX_TYPES, her_syr2) -$:f77_interface('?hpmv', COMPLEX_TYPES, hpmv_spmv) -$:f77_interface('?hpr', COMPLEX_TYPES, hpr) -$:f77_interface('?hpr2', COMPLEX_TYPES, hpr_spr2) -$:f77_interface('?sbmv', REAL_TYPES, hbmv_sbmv) -$:f77_interface('?spmv', REAL_TYPES, hpmv_spmv) -$:f77_interface('?spr', REAL_TYPES, spr) -$:f77_interface('?spr2', REAL_TYPES, hpr_spr2) -$:f77_interface('?symv', REAL_TYPES, hemv_symv) -$:f77_interface('?syr', REAL_TYPES, syr) -$:f77_interface('?syr2', REAL_TYPES, her_syr2) -$:f77_interface('?tbmv', DEFAULT_TYPES, tbmv_tbsv) -$:f77_interface('?tbsv', DEFAULT_TYPES, tbmv_tbsv) -$:f77_interface('?tpmv', DEFAULT_TYPES, tpmv_tpsv) -$:f77_interface('?tpsv', DEFAULT_TYPES, tpmv_tpsv) -$:f77_interface('?trmv', DEFAULT_TYPES, trmv_trsv) -$:f77_interface('?trsv', DEFAULT_TYPES, trmv_trsv) - -! BLAS level 3 -$:f77_interface('?gemm', DEFAULT_TYPES, gemm) -$:f77_interface('?hemm', COMPLEX_TYPES, hemm_symm) -$:f77_interface('?herk', COMPLEX_TYPES, herk) -$:f77_interface('?her2k', COMPLEX_TYPES, her2k) -$:f77_interface('?symm', REAL_TYPES, hemm_symm) -$:f77_interface('?syrk', REAL_TYPES, syrk) -$:f77_interface('?syr2k', REAL_TYPES, syr2k) -$:f77_interface('?trmm', DEFAULT_TYPES, trmm_trsm) -$:f77_interface('?trsm', DEFAULT_TYPES, trmm_trsm) +#:for name, supported_types, code in COLLECT +$:f77_original(name, supported_types, code) +#:endfor +#:for name, supported_types, code in COLLECT +$:f77_improved(name, supported_types) +#:endfor #:include "src/f77/blas/specific_interfaces.fypp" @@ -112,12 +105,12 @@ $:f77_interface('?trsm', DEFAULT_TYPES, trmm_trsm) #:if defined('MFI_EXTENSIONS') #:if defined('MFI_LINK_EXTERNAL') ! Link with a external source -$:f77_interface('i?amax', DEFAULT_TYPES, iamax_iamin) -$:f77_interface('i?amin', DEFAULT_TYPES, iamax_iamin) +$:f77_original('i?amax', DEFAULT_TYPES, iamax_iamin) +$:f77_original('i?amin', DEFAULT_TYPES, iamax_iamin) #:else ! Implement the blas extensions in -$:f77_interface_improved('i?amax', DEFAULT_TYPES) -$:f77_interface_improved('i?amin', DEFAULT_TYPES) +$:f77_improved('i?amax', DEFAULT_TYPES) +$:f77_improved('i?amin', DEFAULT_TYPES) contains $:f77_implement('i?amax', DEFAULT_TYPES, iamin_stub) $:f77_implement('i?amin', DEFAULT_TYPES, iamin_stub) diff --git a/src/f77/blas/asum_nrm2.fypp b/src/f77/blas/asum_nrm2.fypp index 43eecd80..0b697b8e 100644 --- a/src/f77/blas/asum_nrm2.fypp +++ b/src/f77/blas/asum_nrm2.fypp @@ -1,9 +1,9 @@ -#:def asum_nrm2(NAME,TYPE,KIND,PREFIX) +#:def asum_nrm2(NAME,pfxs) +#:set A, B = get_types(pfxs) pure function ${NAME}$(n, x, incx) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) - ${REAL_TYPE}$ :: ${NAME}$ -@:args(${TYPE}$, in, x(*)) -@:args(integer, in, n, incx) +$:imports(pfxs) + ${real(A)}$ :: ${NAME}$ +@:args(${type(B)}$, in, x(*)) +@:args(integer, in, n, incx) end function #:enddef diff --git a/src/f77/blas/axpy.fypp b/src/f77/blas/axpy.fypp index 9ce14adc..2fc24601 100644 --- a/src/f77/blas/axpy.fypp +++ b/src/f77/blas/axpy.fypp @@ -1,9 +1,10 @@ -#:def axpy(NAME,TYPE,KIND,PREFIX) +#:def axpy(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(n, a, x, incx, y, incy) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*), a) -@:args(${TYPE}$, inout, y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*), a) +@:args(${type(wp)}$, inout, y(*)) @:args(integer, in, n, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/copy_swap.fypp b/src/f77/blas/copy_swap.fypp index 703a595a..518e29c3 100644 --- a/src/f77/blas/copy_swap.fypp +++ b/src/f77/blas/copy_swap.fypp @@ -1,9 +1,10 @@ -#:def copy_swap(NAME,TYPE,KIND,PREFIX) +#:def copy_swap(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(n, x, incx, y, incy) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*)) -@:args(${TYPE}$, inout, y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*)) +@:args(${type(wp)}$, inout, y(*)) @:args(integer, in, n, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/dot_product.fypp b/src/f77/blas/dot_product.fypp index 3c5b5951..0ba86095 100644 --- a/src/f77/blas/dot_product.fypp +++ b/src/f77/blas/dot_product.fypp @@ -1,9 +1,10 @@ -#:def dot_product(NAME,TYPE,KIND,PREFIX) +#:def dot_product(NAME,pfxs) +#:set wp = pfxs[0] pure function ${NAME}$(n, x, incx, y, incy) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) - ${TYPE}$ :: ${NAME}$ -@:args(${TYPE}$, in, x(*), y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) + ${type(wp)}$ :: ${NAME}$ +@:args(${type(wp)}$, in, x(*), y(*)) @:args(integer, in, n, incx, incy) end function #:enddef diff --git a/src/f77/blas/gbmv.fypp b/src/f77/blas/gbmv.fypp index bc8bb1b6..bb81a012 100644 --- a/src/f77/blas/gbmv.fypp +++ b/src/f77/blas/gbmv.fypp @@ -1,11 +1,12 @@ -#:def gbmv(NAME,TYPE,KIND,PREFIX) +#:def gbmv(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*), x(*)) -@:args(${TYPE}$, inout, y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*), x(*)) +@:args(${type(wp)}$, inout, y(*)) @:args(character, in, trans) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, m, n, kl, ku, lda, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/gemm.fypp b/src/f77/blas/gemm.fypp index f72239ae..799a409b 100644 --- a/src/f77/blas/gemm.fypp +++ b/src/f77/blas/gemm.fypp @@ -1,11 +1,12 @@ -#:def gemm(NAME,TYPE,KIND,PREFIX) +#:def gemm(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*), b(ldb,*)) -@:args(${TYPE}$, inout, c(ldc,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*), b(ldb,*)) +@:args(${type(wp)}$, inout, c(ldc,*)) @:args(character, in, transa, transb) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, m, n, k, lda, ldb, ldc) end subroutine #:enddef diff --git a/src/f77/blas/gemv.fypp b/src/f77/blas/gemv.fypp index dbe9a7a8..7fc4a23d 100644 --- a/src/f77/blas/gemv.fypp +++ b/src/f77/blas/gemv.fypp @@ -1,11 +1,12 @@ -#:def gemv(NAME,TYPE,KIND,PREFIX) +#:def gemv(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(trans, m, n, alpha, a, lda, x, incx, beta, y, incy) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*), x(*)) -@:args(${TYPE}$, inout, y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*), x(*)) +@:args(${type(wp)}$, inout, y(*)) @:args(character, in, trans) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, m, n, lda, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/ger_gerc_geru.fypp b/src/f77/blas/ger_gerc_geru.fypp index 26b405dd..8e0a3021 100644 --- a/src/f77/blas/ger_gerc_geru.fypp +++ b/src/f77/blas/ger_gerc_geru.fypp @@ -1,10 +1,11 @@ -#:def ger_gerc_geru(NAME,TYPE,KIND,PREFIX) +#:def ger_gerc_geru(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(m, n, alpha, x, incx, y, incy, a, lda) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*), y(*)) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${TYPE}$, in, alpha) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*), y(*)) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${type(wp)}$, in, alpha) @:args(integer, in, m, n, lda, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/hbmv_sbmv.fypp b/src/f77/blas/hbmv_sbmv.fypp index 5022ca42..343ed456 100644 --- a/src/f77/blas/hbmv_sbmv.fypp +++ b/src/f77/blas/hbmv_sbmv.fypp @@ -1,11 +1,12 @@ -#:def hbmv_sbmv(NAME,TYPE,KIND,PREFIX) +#:def hbmv_sbmv(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*), x(*)) -@:args(${TYPE}$, inout, y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*), x(*)) +@:args(${type(wp)}$, inout, y(*)) @:args(character, in, uplo) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, n, k, lda, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/hemm_symm.fypp b/src/f77/blas/hemm_symm.fypp index 198b6a18..b081f681 100644 --- a/src/f77/blas/hemm_symm.fypp +++ b/src/f77/blas/hemm_symm.fypp @@ -1,11 +1,12 @@ -#:def hemm_symm(NAME,TYPE,KIND,PREFIX) +#:def hemm_symm(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*), b(ldb,*)) -@:args(${TYPE}$, inout, c(ldc,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*), b(ldb,*)) +@:args(${type(wp)}$, inout, c(ldc,*)) @:args(character, in, side, uplo) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, m, n, lda, ldb, ldc) end subroutine #:enddef diff --git a/src/f77/blas/hemv_symv.fypp b/src/f77/blas/hemv_symv.fypp index bb2aea42..5189fec9 100644 --- a/src/f77/blas/hemv_symv.fypp +++ b/src/f77/blas/hemv_symv.fypp @@ -1,11 +1,12 @@ -#:def hemv_symv(NAME,TYPE,KIND,PREFIX) +#:def hemv_symv(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, alpha, a, lda, x, incx, beta, y, incy) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*), x(*)) -@:args(${TYPE}$, inout, y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*), x(*)) +@:args(${type(wp)}$, inout, y(*)) @:args(character, in, uplo) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, n, lda, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/her.fypp b/src/f77/blas/her.fypp index 5b16518c..025825bb 100644 --- a/src/f77/blas/her.fypp +++ b/src/f77/blas/her.fypp @@ -1,9 +1,10 @@ -#:def her(NAME,TYPE,KIND,PREFIX) +#:def her(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, alpha, x, incx, a, lda) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*)) -@:args(${TYPE}$, inout, a(lda,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*)) +@:args(${type(wp)}$, inout, a(lda,*)) @:args(character, in, uplo) @:args(real(wp), in, alpha) @:args(integer, in, n, lda, incx) diff --git a/src/f77/blas/her2k.fypp b/src/f77/blas/her2k.fypp index 446c707a..e4f23880 100644 --- a/src/f77/blas/her2k.fypp +++ b/src/f77/blas/her2k.fypp @@ -1,12 +1,13 @@ -#:def her2k(NAME,TYPE,KIND,PREFIX) +#:def her2k(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) -@:args(${TYPE}$, in, b(ldb,*)) -@:args(${TYPE}$, inout, c(ldc,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) +@:args(${type(wp)}$, in, b(ldb,*)) +@:args(${type(wp)}$, inout, c(ldc,*)) @:args(character, in, trans, uplo) -@:args(${TYPE}$, in, alpha) +@:args(${type(wp)}$, in, alpha) @:args(real(wp), in, beta) @:args(integer, in, n, k, lda, ldb, ldc) end subroutine diff --git a/src/f77/blas/her_syr2.fypp b/src/f77/blas/her_syr2.fypp index 7fd4ebb2..af30ced1 100644 --- a/src/f77/blas/her_syr2.fypp +++ b/src/f77/blas/her_syr2.fypp @@ -1,11 +1,12 @@ -#:def her_syr2(NAME,TYPE,KIND,PREFIX) +#:def her_syr2(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, alpha, x, incx, y, incy, a, lda) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*), y(*)) -@:args(${TYPE}$, inout, a(lda,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*), y(*)) +@:args(${type(wp)}$, inout, a(lda,*)) @:args(character, in, uplo) -@:args(${TYPE}$, in, alpha) +@:args(${type(wp)}$, in, alpha) @:args(integer, in, n, lda, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/herk.fypp b/src/f77/blas/herk.fypp index ae233ffe..48e32053 100644 --- a/src/f77/blas/herk.fypp +++ b/src/f77/blas/herk.fypp @@ -1,9 +1,10 @@ -#:def herk(NAME,TYPE,KIND,PREFIX) +#:def herk(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, trans, n, k, alpha, a, lda, beta, c, ldc) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) -@:args(${TYPE}$, inout, c(ldc,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) +@:args(${type(wp)}$, inout, c(ldc,*)) @:args(character, in, trans, uplo) @:args(real(wp), in, alpha, beta) @:args(integer, in, n, k, lda, ldc) diff --git a/src/f77/blas/hpmv_spmv.fypp b/src/f77/blas/hpmv_spmv.fypp index 441c3107..fa3c1dc9 100644 --- a/src/f77/blas/hpmv_spmv.fypp +++ b/src/f77/blas/hpmv_spmv.fypp @@ -1,11 +1,12 @@ -#:def hpmv_spmv(NAME,TYPE,KIND,PREFIX) +#:def hpmv_spmv(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, alpha, ap, x, incx, beta, y, incy) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, ap(*), x(*)) -@:args(${TYPE}$, inout, y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, ap(*), x(*)) +@:args(${type(wp)}$, inout, y(*)) @:args(character, in, uplo) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, n, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/hpr.fypp b/src/f77/blas/hpr.fypp index dc3bb89e..20f820b5 100644 --- a/src/f77/blas/hpr.fypp +++ b/src/f77/blas/hpr.fypp @@ -1,9 +1,10 @@ -#:def hpr(NAME,TYPE,KIND,PREFIX) +#:def hpr(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, alpha, x, incx, ap) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*)) -@:args(${TYPE}$, inout, ap(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*)) +@:args(${type(wp)}$, inout, ap(*)) @:args(character, in, uplo) @:args(real(wp), in, alpha) @:args(integer, in, n, incx) diff --git a/src/f77/blas/hpr_spr2.fypp b/src/f77/blas/hpr_spr2.fypp index fdfecf82..fe7d388d 100644 --- a/src/f77/blas/hpr_spr2.fypp +++ b/src/f77/blas/hpr_spr2.fypp @@ -1,11 +1,12 @@ -#:def hpr_spr2(NAME,TYPE,KIND,PREFIX) +#:def hpr_spr2(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, alpha, x, incx, y, incy, ap) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*), y(*)) -@:args(${TYPE}$, inout, ap(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*), y(*)) +@:args(${type(wp)}$, inout, ap(*)) @:args(character, in, uplo) -@:args(${TYPE}$, in, alpha) +@:args(${type(wp)}$, in, alpha) @:args(integer, in, n, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/iamax_iamin.fypp b/src/f77/blas/iamax_iamin.fypp index 4fce6485..dfc8f544 100644 --- a/src/f77/blas/iamax_iamin.fypp +++ b/src/f77/blas/iamax_iamin.fypp @@ -1,9 +1,10 @@ -#:def iamax_iamin(NAME,TYPE,KIND,PREFIX) +#:def iamax_iamin(NAME,pfxs) +#:set wp = pfxs[0] pure function ${NAME}$(n, x, incx) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) integer :: ${NAME}$ -@:args(${TYPE}$, in, x(*)) +@:args(${type(wp)}$, in, x(*)) @:args(integer, in, n, incx) end function #:enddef diff --git a/src/f77/blas/iamin_stub.fypp b/src/f77/blas/iamin_stub.fypp index 26f2e84d..8808a67f 100644 --- a/src/f77/blas/iamin_stub.fypp +++ b/src/f77/blas/iamin_stub.fypp @@ -1,15 +1,16 @@ -#:def iamin_stub(NAME,TYPE,KIND,PREFIX) +#:def iamin_stub(NAME,pfxs) +#:set wp = pfxs[0] pure function ${NAME}$(n, x, incx) -@:parameter(integer, wp=${KIND}$) +@:parameter(integer, wp=${kind(wp)}$) integer :: ${NAME}$ -@:args(${TYPE}$, in, x(*)) +@:args(${type(wp)}$, in, x(*)) @:args(integer, in, n, incx) !If either n or incx are not positive, the routine returns 0. if (n <= 0 .or. incx <= 0) then ${NAME}$ = 0 return end if -#:if TYPE is COMPLEX_TYPE +#:if type(wp) is complex(wp) ${NAME}$ = minloc(abs(real(x(1:n:incx))) + abs(aimag(x(1:n:incx))),dim=1) #:else ${NAME}$ = minloc(x(1:n:incx),dim=1) diff --git a/src/f77/blas/rot.fypp b/src/f77/blas/rot.fypp index fdd2d5da..559b77d5 100644 --- a/src/f77/blas/rot.fypp +++ b/src/f77/blas/rot.fypp @@ -17,29 +17,16 @@ subroutine {sc,zd}rot ( real(wp) c, real(wp) s ) -#:def rot(NAME,TYPE,KIND,PREFIX) -!> ${NAME.upper()}$ applies a plane rotation. -pure subroutine ${NAME}$(n, x, incx, y, incy, c, s) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*), y(*)) +#:def rot(name,pfxs) +#:set A, B = get_types(pfxs) +!> ${name.upper()}$ applies a plane rotation. +!> ${pfxs}$ +pure subroutine ${name}$(n, x, incx, y, incy, c, s) +$:imports(pfxs) +@:args(${type(A)}$, in, x(*), y(*)) @:args(integer, in, n, incx, incy) -@:args(${REAL_TYPE}$, in, c) -@:args(${TYPE}$, in, s) +@:args(${real(A)}$, in, c) +@:args(${type(B)}$, in, s) end subroutine #:enddef - -#:def rot_mixed(NAME,TYPE,KIND,PREFIX) -!> ${NAME.upper()}$ applies a plane rotation, -!> where the cos and sin (c and s) are real -!> and the vectors x and y are complex. -pure subroutine ${NAME}$(n, x, incx, y, incy, c, s) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*), y(*)) -@:args(integer, in, n, incx, incy) -@:args(${REAL_TYPE}$, in, c, s) -end subroutine -#:enddef - #:endmute diff --git a/src/f77/blas/rotg.fypp b/src/f77/blas/rotg.fypp index e3f544a8..37082231 100644 --- a/src/f77/blas/rotg.fypp +++ b/src/f77/blas/rotg.fypp @@ -5,15 +5,16 @@ subroutine {s,d,c,z}rotg ( real(wp) c, type(wp) s ) -#:def rotg(NAME,TYPE,KIND,PREFIX) +#:def rotg(NAME,pfxs) +#:set wp = pfxs[0] !>${NAME}$ generates a Givens rotation with real cosine and complex sine: -#:if TYPE == REAL_TYPE +#:if type(wp) == real(wp) !>``` !> [ c s ] [ a ] = [ r ] !> [ -s c ] [ b ] [ 0 ] !>``` !> satisfying `c**2 + s**2 = 1`. -#:elif TYPE == COMPLEX_TYPE +#:elif type(wp) == complex(wp) !>``` !> [ c s ] [ a ] = [ r ] !> [ -conjg(s) c ] [ b ] [ 0 ] @@ -21,11 +22,11 @@ subroutine {s,d,c,z}rotg ( !> where c is real, s is complex, and `c**2 + conjg(s)*s = 1`. #:endif pure subroutine ${NAME}$(a, b, c, s) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a, b) -@:args(${REAL_TYPE}$, out, c) -@:args(${TYPE}$, out, s) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a, b) +@:args(${real(wp)}$, out, c) +@:args(${type(wp)}$, out, s) end subroutine #:enddef diff --git a/src/f77/blas/rotm.fypp b/src/f77/blas/rotm.fypp index 97d20623..3a52ec1d 100644 --- a/src/f77/blas/rotm.fypp +++ b/src/f77/blas/rotm.fypp @@ -1,9 +1,10 @@ -#:def rotm(NAME,TYPE,KIND,PREFIX) +#:def rotm(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(n, x, incx, y, incy, param) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, x(*), y(*)) -@:args(${TYPE}$, in, param(5)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, x(*), y(*)) +@:args(${type(wp)}$, in, param(5)) @:args(integer, in, n, incx, incy) end subroutine #:enddef diff --git a/src/f77/blas/rotmg.fypp b/src/f77/blas/rotmg.fypp index a41d833e..6da994f0 100644 --- a/src/f77/blas/rotmg.fypp +++ b/src/f77/blas/rotmg.fypp @@ -1,9 +1,10 @@ -#:def rotmg(NAME,TYPE,KIND,PREFIX) +#:def rotmg(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(d1, d2, x1, y1, param) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, y1) -@:args(${TYPE}$, out, param(5)) -@:args(${TYPE}$, inout, d1, d2, x1) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, y1) +@:args(${type(wp)}$, out, param(5)) +@:args(${type(wp)}$, inout, d1, d2, x1) end subroutine #:enddef diff --git a/src/f77/blas/scal.fypp b/src/f77/blas/scal.fypp index b9947ab3..7d946d02 100644 --- a/src/f77/blas/scal.fypp +++ b/src/f77/blas/scal.fypp @@ -1,21 +1,10 @@ -#:def scal(NAME,TYPE,KIND,PREFIX) +#:def scal(NAME,pfxs) +#:set A, B = get_types(pfxs) !> ${NAME.upper()}$ scales a vector by a constant. pure subroutine ${NAME}$(n, a, x, incx) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, x(*)) -@:args(${TYPE}$, in, a) +$:imports(pfxs) +@:args(${type(A)}$, inout, x(*)) +@:args(${type(B)}$, in, a) @:args(integer, in, n, incx) end subroutine #:enddef - -#:def scal_mixed(NAME,TYPE,KIND,PREFIX) -!> ${NAME.upper()}$ scales a vector by a constant. -pure subroutine ${NAME}$(n, a, x, incx) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, x(*)) -@:args(${REAL_TYPE}$, in, a) -@:args(integer, in, n, incx) -end subroutine -#:enddef diff --git a/src/f77/blas/specific_interfaces.fypp b/src/f77/blas/specific_interfaces.fypp index cbee11c3..923aa51e 100644 --- a/src/f77/blas/specific_interfaces.fypp +++ b/src/f77/blas/specific_interfaces.fypp @@ -1,5 +1,5 @@ +!> ?lamch supports s, d. See [[mfi_lamch]] for the modern version. interface - !> SLAMCH determines single precision machine parameters. pure real(REAL32) function slamch(cmach) import :: REAL32 @@ -11,7 +11,9 @@ interface import :: REAL64 character, intent(in) :: cmach end function +end interface +interface !> Compute the inner product of two vectors with extended !> precision accumulation. !> diff --git a/src/f77/blas/spr.fypp b/src/f77/blas/spr.fypp index c4c49d84..bb3a0957 100644 --- a/src/f77/blas/spr.fypp +++ b/src/f77/blas/spr.fypp @@ -1,11 +1,12 @@ -#:def spr(NAME,TYPE,KIND,PREFIX) +#:def spr(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, alpha, x, incx, ap) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*)) -@:args(${TYPE}$, inout, ap(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*)) +@:args(${type(wp)}$, inout, ap(*)) @:args(character, in, uplo) -@:args(${TYPE}$, in, alpha) +@:args(${type(wp)}$, in, alpha) @:args(integer, in, n, incx) end subroutine #:enddef diff --git a/src/f77/blas/syr.fypp b/src/f77/blas/syr.fypp index 4ed1d9c4..ce70fb40 100644 --- a/src/f77/blas/syr.fypp +++ b/src/f77/blas/syr.fypp @@ -1,11 +1,12 @@ -#:def syr(NAME,TYPE,KIND,PREFIX) +#:def syr(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, n, alpha, x, incx, a, lda) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(*)) -@:args(${TYPE}$, inout, a(lda,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(*)) +@:args(${type(wp)}$, inout, a(lda,*)) @:args(character, in, uplo) -@:args(${TYPE}$, in, alpha) +@:args(${type(wp)}$, in, alpha) @:args(integer, in, n, lda, incx) end subroutine #:enddef diff --git a/src/f77/blas/syr2k.fypp b/src/f77/blas/syr2k.fypp index 089dbb4e..f4178424 100644 --- a/src/f77/blas/syr2k.fypp +++ b/src/f77/blas/syr2k.fypp @@ -1,12 +1,13 @@ -#:def syr2k(NAME,TYPE,KIND,PREFIX) +#:def syr2k(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) -@:args(${TYPE}$, in, b(ldb,*)) -@:args(${TYPE}$, inout, c(ldc,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) +@:args(${type(wp)}$, in, b(ldb,*)) +@:args(${type(wp)}$, inout, c(ldc,*)) @:args(character, in, trans, uplo) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, n, k, lda, ldb, ldc) end subroutine #:enddef diff --git a/src/f77/blas/syrk.fypp b/src/f77/blas/syrk.fypp index 61dea546..f6813880 100644 --- a/src/f77/blas/syrk.fypp +++ b/src/f77/blas/syrk.fypp @@ -1,11 +1,12 @@ -#:def syrk(NAME,TYPE,KIND,PREFIX) +#:def syrk(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, trans, n, k, alpha, a, lda, beta, c, ldc) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) -@:args(${TYPE}$, inout, c(ldc,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) +@:args(${type(wp)}$, inout, c(ldc,*)) @:args(character, in, trans, uplo) -@:args(${TYPE}$, in, alpha, beta) +@:args(${type(wp)}$, in, alpha, beta) @:args(integer, in, n, k, lda, ldc) end subroutine #:enddef diff --git a/src/f77/blas/tbmv_tbsv.fypp b/src/f77/blas/tbmv_tbsv.fypp index c75548f8..24aae218 100644 --- a/src/f77/blas/tbmv_tbsv.fypp +++ b/src/f77/blas/tbmv_tbsv.fypp @@ -1,9 +1,10 @@ -#:def tbmv_tbsv(NAME,TYPE,KIND,PREFIX) +#:def tbmv_tbsv(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, trans, diag, n, k, a, lda, x, incx) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) -@:args(${TYPE}$, inout, x(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) +@:args(${type(wp)}$, inout, x(*)) @:args(character, in, uplo, trans, diag) @:args(integer, in, n, k, lda, incx) end subroutine diff --git a/src/f77/blas/tpmv_tpsv.fypp b/src/f77/blas/tpmv_tpsv.fypp index 20e26652..7854ee90 100644 --- a/src/f77/blas/tpmv_tpsv.fypp +++ b/src/f77/blas/tpmv_tpsv.fypp @@ -1,9 +1,10 @@ -#:def tpmv_tpsv(NAME,TYPE,KIND,PREFIX) +#:def tpmv_tpsv(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, trans, diag, n, ap, x, incx) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, ap(*)) -@:args(${TYPE}$, inout, x(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, ap(*)) +@:args(${type(wp)}$, inout, x(*)) @:args(character, in, uplo, trans, diag) @:args(integer, in, n, incx) end subroutine diff --git a/src/f77/blas/trmm_trsm.fypp b/src/f77/blas/trmm_trsm.fypp index 304230f1..79abd3de 100644 --- a/src/f77/blas/trmm_trsm.fypp +++ b/src/f77/blas/trmm_trsm.fypp @@ -1,11 +1,12 @@ -#:def trmm_trsm(NAME,TYPE,KIND,PREFIX) +#:def trmm_trsm(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) -@:args(${TYPE}$, inout, b(ldb,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) +@:args(${type(wp)}$, inout, b(ldb,*)) @:args(character, in, side, uplo, transa, diag) -@:args(${TYPE}$, in, alpha) +@:args(${type(wp)}$, in, alpha) @:args(integer, in, m, n, lda, ldb) end subroutine #:enddef diff --git a/src/f77/blas/trmv_trsv.fypp b/src/f77/blas/trmv_trsv.fypp index 1a100523..a6362dd4 100644 --- a/src/f77/blas/trmv_trsv.fypp +++ b/src/f77/blas/trmv_trsv.fypp @@ -1,9 +1,10 @@ -#:def trmv_trsv(NAME,TYPE,KIND,PREFIX) +#:def trmv_trsv(NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${NAME}$(uplo, trans, diag, n, a, lda, x, incx) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) -@:args(${TYPE}$, inout, x(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) +@:args(${type(wp)}$, inout, x(*)) @:args(character, in, uplo, trans, diag) @:args(integer, in, n, lda, incx) end subroutine diff --git a/src/f77/lapack.fpp b/src/f77/lapack.fpp index 5c776624..e8734e45 100644 --- a/src/f77/lapack.fpp +++ b/src/f77/lapack.fpp @@ -1,6 +1,6 @@ #:mute #:include "common.fpp" -#:include "src/f77/lapack/aux_lartg.fypp" +#:include "src/f77/lapack/lartg.fypp" #:include "src/f77/lapack/geqrf_gerqf.fypp" #:include "src/f77/lapack/getrf.fypp" #:include "src/f77/lapack/getri.fypp" @@ -20,38 +20,46 @@ #:include "src/f77/lapack/gelsy.fypp" #:include "src/f77/lapack/gglse.fypp" #:include "src/f77/lapack/gglsm.fypp" -#:endmute +#:set COLLECT = [ & + ('?geqrf', DEFAULT_TYPES, geqrf_gerqf), & + ('?gerqf', DEFAULT_TYPES, geqrf_gerqf), & + ('?getrf', DEFAULT_TYPES, getrf), & + ('?getri', DEFAULT_TYPES, getri), & + ('?getrs', DEFAULT_TYPES, getrs), & + ('?hetrf', COMPLEX_TYPES, hetrf), & + ('?hegv', COMPLEX_TYPES, hegv), & + ('?heevd', COMPLEX_TYPES, heevd), & + ('?gesvd', DEFAULT_TYPES, gesvd), & + ('?potrf', DEFAULT_TYPES, potrf_potri), & + ('?potri', DEFAULT_TYPES, potrf_potri), & + ('?potrs', DEFAULT_TYPES, potrs), & + ('?pocon', DEFAULT_TYPES, pocon), & + ('?heevx', COMPLEX_TYPES, heevx), & + ('?heevr', COMPLEX_TYPES, heevr), & + ('?gels', DEFAULT_TYPES, gels_gelst_getsls), & + ('?gelst', DEFAULT_TYPES, gels_gelst_getsls), & + ('?getsls', DEFAULT_TYPES, gels_gelst_getsls), & + ('?gelsd', DEFAULT_TYPES, gelsd), & + ('?gelss', DEFAULT_TYPES, gelss), & + ('?gelsy', DEFAULT_TYPES, gelsy), & + ('?gglse', DEFAULT_TYPES, gglse), & + ('?gglsm', DEFAULT_TYPES, gglsm), & + ('?lartg', DEFAULT_TYPES, lartg), & +] +#:endmute !> Improved and original F77 interfaces for LAPACK module f77_lapack use iso_fortran_env implicit none -$:f77_interface('?geqrf', DEFAULT_TYPES, geqrf_gerqf) -$:f77_interface('?gerqf', DEFAULT_TYPES, geqrf_gerqf) -$:f77_interface('?getrf', DEFAULT_TYPES, getrf) -$:f77_interface('?getri', DEFAULT_TYPES, getri) -$:f77_interface('?getrs', DEFAULT_TYPES, getrs) -$:f77_interface('?hetrf', COMPLEX_TYPES, hetrf) -$:f77_interface('?hegv', COMPLEX_TYPES, hegv) -$:f77_interface('?heevd', COMPLEX_TYPES, heevd) -$:f77_interface('?heevx', COMPLEX_TYPES, heevx) -$:f77_interface('?heevr', COMPLEX_TYPES, heevr) -$:f77_interface('?gesvd', DEFAULT_TYPES, gesvd) -$:f77_interface('?potrf', DEFAULT_TYPES, potrf_potri) -$:f77_interface('?potri', DEFAULT_TYPES, potrf_potri) -$:f77_interface('?potrs', DEFAULT_TYPES, potrs) -$:f77_interface('?pocon', DEFAULT_TYPES, pocon) -$:f77_interface('?gels', DEFAULT_TYPES, gels_gelst_getsls) -$:f77_interface('?gelst', DEFAULT_TYPES, gels_gelst_getsls) -$:f77_interface('?getsls', DEFAULT_TYPES, gels_gelst_getsls) -$:f77_interface('?gelsd', DEFAULT_TYPES, gelsd) -$:f77_interface('?gelss', DEFAULT_TYPES, gelss) -$:f77_interface('?gelsy', DEFAULT_TYPES, gelsy) -$:f77_interface('?gglse', DEFAULT_TYPES, gglse) -$:f77_interface('?gglsm', DEFAULT_TYPES, gglsm) -! Other Auxiliary Routines -$:f77_interface('?lartg', DEFAULT_TYPES, aux_lartg) +#:for name, supported_types, code in COLLECT +$:f77_original(name, supported_types, code) +#:endfor + +#:for name, supported_types, code in COLLECT +$:f77_improved(name, supported_types) +#:endfor interface f77_xerbla pure subroutine xerbla(name,info) diff --git a/src/f77/lapack/aux_lartg.fypp b/src/f77/lapack/aux_lartg.fypp deleted file mode 100644 index 6b4f43a8..00000000 --- a/src/f77/lapack/aux_lartg.fypp +++ /dev/null @@ -1,8 +0,0 @@ -#:def aux_lartg(NAME,TYPE,KIND,PREFIX) -pure subroutine ${NAME}$(f, g, c, s, r) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(real(wp), inout, c) -@:args(${TYPE}$, inout, f, g, r, s) -end subroutine -#:enddef diff --git a/src/f77/lapack/gels_gelst_getsls.fypp b/src/f77/lapack/gels_gelst_getsls.fypp index de21c0ea..4b443e15 100644 --- a/src/f77/lapack/gels_gelst_getsls.fypp +++ b/src/f77/lapack/gels_gelst_getsls.fypp @@ -12,17 +12,18 @@ subroutine {s,d,c,z}gels / gelst / getsls ( integer lwork, integer info ) -#:def gels_gelst_getsls(NAME,TYPE,KIND,PREFIX) +#:def gels_gelst_getsls(NAME,pfxs) +#:set wp=pfxs[0] !> ${NAME.upper()}$ solves overdetermined or underdetermined systems for GE matrices #:if NAME.endswith('t') !> using QR or LQ factorization with compact WY representation of Q. #:endif pure subroutine ${NAME}$(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) @:args(character, in, trans) -@:args(${TYPE}$, inout, a(lda,*), b(ldb,*)) -@:args(${TYPE}$, out, work(*)) +@:args(${type(wp)}$, inout, a(lda,*), b(ldb,*)) +@:args(${type(wp)}$, out, work(*)) @:args(integer, out, info) @:args(integer, in, m, n, lda, ldb, nrhs, lwork) end subroutine diff --git a/src/f77/lapack/gelsd.fypp b/src/f77/lapack/gelsd.fypp index 6faf8c2b..e24452ea 100644 --- a/src/f77/lapack/gelsd.fypp +++ b/src/f77/lapack/gelsd.fypp @@ -16,16 +16,17 @@ subroutine {s,d,c,z}gelsd( integer out iwork(*), integer out info ) -#:def gelsd(NAME,TYPE,KIND,PREFIX) +#:def gelsd(NAME,pfxs) +#:set wp=pfxs[0] !> ${NAME.upper()}$ computes the minimum-norm solution to a linear least squares problem for GE matrices pure subroutine ${NAME}$(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, iwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, rcond) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${TYPE}$, inout, b(ldb,*)) -@:args(${TYPE}$, out, s(*)) -@:args(${TYPE}$, out, work(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, rcond) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${type(wp)}$, inout, b(ldb,*)) +@:args(${type(wp)}$, out, s(*)) +@:args(${type(wp)}$, out, work(*)) @:args(integer, out, iwork(*)) @:args(integer, out, info, rank) @:args(integer, in, n, m, nrhs, lda, ldb, lwork) diff --git a/src/f77/lapack/gelss.fypp b/src/f77/lapack/gelss.fypp index 420cb121..79b2494d 100644 --- a/src/f77/lapack/gelss.fypp +++ b/src/f77/lapack/gelss.fypp @@ -15,16 +15,17 @@ subroutine {s,d,c,z}gelss( integer in lwork, integer out info ) -#:def gelss(NAME,TYPE,KIND,PREFIX) +#:def gelss(NAME,pfxs) +#:set wp=pfxs[0] !> ${NAME.upper()}$ solves overdetermined or underdetermined systems for GE matrices pure subroutine ${NAME}$(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, rcond) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${TYPE}$, inout, b(ldb,*)) -@:args(${TYPE}$, out, s(*)) -@:args(${TYPE}$, out, work(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, rcond) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${type(wp)}$, inout, b(ldb,*)) +@:args(${type(wp)}$, out, s(*)) +@:args(${type(wp)}$, out, work(*)) @:args(integer, out, info, rank) @:args(integer, in, n, m, nrhs, lda, ldb, lwork) end subroutine diff --git a/src/f77/lapack/gelsy.fypp b/src/f77/lapack/gelsy.fypp index 8b1391a7..4bddb8e1 100644 --- a/src/f77/lapack/gelsy.fypp +++ b/src/f77/lapack/gelsy.fypp @@ -15,16 +15,17 @@ subroutine {s,d,c,z}gelsy( integer in lwork, integer out info ) -#:def gelsy(NAME,TYPE,KIND,PREFIX) +#:def gelsy(NAME,pfxs) +#:set wp=pfxs[0] !> ${NAME.upper()}$ solves overdetermined or underdetermined systems for GE matrices pure subroutine ${NAME}$(m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank, work, lwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, rcond) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${TYPE}$, inout, b(ldb,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, rcond) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${type(wp)}$, inout, b(ldb,*)) @:args(integer, inout, jpvt(*)) -@:args(${TYPE}$, out, work(*)) +@:args(${type(wp)}$, out, work(*)) @:args(integer, out, info, rank) @:args(integer, in, n, m, nrhs, lda, ldb, lwork) end subroutine diff --git a/src/f77/lapack/geqrf_gerqf.fypp b/src/f77/lapack/geqrf_gerqf.fypp index 4c1a525a..1d8d49d5 100644 --- a/src/f77/lapack/geqrf_gerqf.fypp +++ b/src/f77/lapack/geqrf_gerqf.fypp @@ -1,11 +1,12 @@ -#:def geqrf_gerqf(NAME,TYPE,KIND,PREFIX) +#:def geqrf_gerqf(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(m,n,a,lda,tau,work,lwork,info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${TYPE}$, out, tau(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${type(wp)}$, out, tau(*)) @:args(integer, out, info) @:args(integer, in, m, n, lda, lwork) -@:args(${TYPE}$, inout, work(*)) +@:args(${type(wp)}$, inout, work(*)) end subroutine #:enddef diff --git a/src/f77/lapack/gesv.fypp b/src/f77/lapack/gesv.fypp new file mode 100644 index 00000000..2f24d4ab --- /dev/null +++ b/src/f77/lapack/gesv.fypp @@ -0,0 +1,54 @@ +#:mute +subroutine {s,d,c,z}gesv ( + integer in n, + integer in nrhs, + type(wp) inout a(lda,*), + integer in lda, + integer out ipiv(*), + type(wp) inout b(ldb,*), + integer in ldb, + integer out info +) + +#:def gesv(NAME,pfxs) +#:set wp=pfxs[0] +!> ${NAME.upper()}$ computes the solution to system +!> of linear equations \( A \times X = B \) for GE matrices +pure subroutine ${NAME}$(n,nhrs,a,lda,ipiv,b,ldb,info) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*), b(ldb,*)) +@:args(integer, out, ipiv(*)) +@:args(integer, out, info) +@:args(integer, in, n, nrhs, lda, ldb) +end subroutine +#:enddef + +subroutine dsgesv ( + integer n, + integer nrhs, + real(dp) a( lda, * ), + integer lda, + integer ipiv( * ), + real(dp) b( ldb, * ), + integer ldb, + real(dp) x( ldx, * ), + integer ldx, + real(dp) work( n, * ), + real(sp) swork( * ), + integer iter, + integer info +) + +#:def gesv_mixed(NAME,pfxs) +#:set wp=pfxs[0] +!> ${NAME.upper()}$ computes the solution to system of linear equations \( A \times X = B \) for GE matrices (mixed precision with iterative refinement) +pure subroutine ${NAME}$(n,nhrs,a,lda,ipiv,b,ldb,info) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*), b(ldb,*)) +@:args(integer, out, ipiv(*)) +@:args(integer, out, info) +@:args(integer, in, n, nrhs, lda, ldb) +end subroutine +#:enddef diff --git a/src/f77/lapack/gesvd.fypp b/src/f77/lapack/gesvd.fypp index 3fe7d4de..d133c8ef 100644 --- a/src/f77/lapack/gesvd.fypp +++ b/src/f77/lapack/gesvd.fypp @@ -1,20 +1,21 @@ -#:def gesvd(NAME,TYPE,KIND,PREFIX) -#:if TYPE == COMPLEX_TYPE +#:def gesvd(NAME,pfxs) +#:set wp=pfxs[0] +#:if type(wp) == complex(wp) pure subroutine ${NAME}$(jobu,jobvt,m,n,a,lda,s,u,ldu,vt,ldvt,work,lwork,rwork,info) #:else pure subroutine ${NAME}$(jobu,jobvt,m,n,a,lda,s,u,ldu,vt,ldvt,work,lwork,info) #:endif - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${REAL_TYPE}$, out, s(*)) -@:args(${TYPE}$, out, u(ldu,*), vt(ldvt,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${real(wp)}$, out, s(*)) +@:args(${type(wp)}$, out, u(ldu,*), vt(ldvt,*)) @:args(integer, out, info) @:args(character, in, jobu, jobvt) @:args(integer, in, m, n, lda, ldu, ldvt, lwork) -@:args(${TYPE}$, inout, work(*)) -#:if TYPE == COMPLEX_TYPE -@:args(${REAL_TYPE}$, in, rwork(*)) +@:args(${type(wp)}$, inout, work(*)) +#:if type(wp) == complex(wp) +@:args(${real(wp)}$, in, rwork(*)) #:endif end subroutine #:enddef diff --git a/src/f77/lapack/getrf.fypp b/src/f77/lapack/getrf.fypp index a137a2fd..0652fe2d 100644 --- a/src/f77/lapack/getrf.fypp +++ b/src/f77/lapack/getrf.fypp @@ -1,8 +1,9 @@ -#:def getrf(NAME,TYPE,KIND,PREFIX) +#:def getrf(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(m,n,a,lda,ipiv,info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*)) @:args(integer, out, ipiv(*)) @:args(integer, out, info) @:args(integer, in, m, n, lda) diff --git a/src/f77/lapack/getri.fypp b/src/f77/lapack/getri.fypp index 816cf2e0..eeb2c570 100644 --- a/src/f77/lapack/getri.fypp +++ b/src/f77/lapack/getri.fypp @@ -1,9 +1,10 @@ -#:def getri(NAME,TYPE,KIND,PREFIX) +#:def getri(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(n,a,lda,ipiv,work,lwork,info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${TYPE}$, inout, work(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${type(wp)}$, inout, work(*)) @:args(integer, in, ipiv(*)) @:args(integer, out, info) @:args(integer, in, n, lda, lwork) diff --git a/src/f77/lapack/getrs.fypp b/src/f77/lapack/getrs.fypp index bdacf7ea..ee58efcc 100644 --- a/src/f77/lapack/getrs.fypp +++ b/src/f77/lapack/getrs.fypp @@ -1,9 +1,10 @@ -#:def getrs(NAME,TYPE,KIND,PREFIX) +#:def getrs(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(trans,n,nrhs,a,lda,ipiv,b,ldb,info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${TYPE}$, inout, b(ldb,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${type(wp)}$, inout, b(ldb,*)) @:args(character, in, trans) @:args(integer, in, ipiv(*)) @:args(integer, out, info) diff --git a/src/f77/lapack/gglse.fypp b/src/f77/lapack/gglse.fypp index a60a4adf..779ae94b 100644 --- a/src/f77/lapack/gglse.fypp +++ b/src/f77/lapack/gglse.fypp @@ -14,12 +14,13 @@ subroutine {s,d,c,z}gglse ( integer in lwork integer out info ) -#:def gglse(NAME,TYPE,KIND,PREFIX) +#:def gglse(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(m, n, p, a, lda, b, ldb, c, d, x, work, lwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*), b(ldb,*), c(*), d(*)) -@:args(${TYPE}$, out, work(*), x(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*), b(ldb,*), c(*), d(*)) +@:args(${type(wp)}$, out, work(*), x(*)) @:args(integer, out, info) @:args(integer, in, m, n, p, lda, ldb, lwork) end subroutine diff --git a/src/f77/lapack/gglsm.fypp b/src/f77/lapack/gglsm.fypp index 7434e671..d173f1ef 100644 --- a/src/f77/lapack/gglsm.fypp +++ b/src/f77/lapack/gglsm.fypp @@ -15,12 +15,13 @@ subroutine {s,d,c,z}gglsm ( integer out info ) -#:def gglsm(NAME,TYPE,KIND,PREFIX) +#:def gglsm(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(n, m, p, a, lda, b, ldb, d, x, y, work, lwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*), b(ldb,*), d(*)) -@:args(${TYPE}$, out, work(*), x(*), y(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*), b(ldb,*), d(*)) +@:args(${type(wp)}$, out, work(*), x(*), y(*)) @:args(integer, out, info) @:args(integer, in, m, n, p, lda, ldb, lwork) end subroutine diff --git a/src/f77/lapack/heevd.fypp b/src/f77/lapack/heevd.fypp index 0b63f1a1..0265ce6b 100644 --- a/src/f77/lapack/heevd.fypp +++ b/src/f77/lapack/heevd.fypp @@ -1,14 +1,15 @@ -#:def heevd(NAME,TYPE,KIND,PREFIX) +#:def heevd(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork, iwork, liwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${REAL_TYPE}$, out, w(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${real(wp)}$, out, w(*)) @:args(integer, out, info) @:args(character, in, jobz, uplo) @:args(integer, in, n, lda, lwork, lrwork, liwork) -@:args(${TYPE}$, inout, work(*)) -@:args(${REAL_TYPE}$, inout, rwork(*)) +@:args(${type(wp)}$, inout, work(*)) +@:args(${real(wp)}$, inout, rwork(*)) @:args(integer, inout, iwork(*)) end subroutine #:enddef diff --git a/src/f77/lapack/heevr.fypp b/src/f77/lapack/heevr.fypp index 322ada70..72ce08be 100644 --- a/src/f77/lapack/heevr.fypp +++ b/src/f77/lapack/heevr.fypp @@ -1,17 +1,18 @@ -#:def heevr(NAME,TYPE,KIND,PREFIX) +#:def heevr(NAME,pfxs) +#:set wp=pfxs[0] 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}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*), z(ldz, *)) -@:args(${REAL_TYPE}$, out, w(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*), z(ldz, *)) +@:args(${real(wp)}$, out, w(*)) @:args(integer, out, info) @:args(character, in, jobz, uplo, range) -@:args(${REAL_TYPE}$, in, vl, vu, abstol) +@:args(${real(wp)}$, in, vl, vu, abstol) @:args(integer, in, n, m, lda, ldz, il, iu, lwork, lrwork, liwork) @:args(integer, in, isuppz(*)) -@:args(${TYPE}$, inout, work(*)) -@:args(${REAL_TYPE}$, inout, rwork(*)) +@:args(${type(wp)}$, inout, work(*)) +@:args(${real(wp)}$, inout, rwork(*)) @:args(integer, inout, iwork(*)) end subroutine #:enddef diff --git a/src/f77/lapack/heevx.fypp b/src/f77/lapack/heevx.fypp index ea0e35cf..9aafb7cb 100644 --- a/src/f77/lapack/heevx.fypp +++ b/src/f77/lapack/heevx.fypp @@ -1,16 +1,17 @@ -#:def heevx(NAME,TYPE,KIND,PREFIX) +#:def heevx(NAME,pfxs) +#:set wp=pfxs[0] 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}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*), z(ldz, *)) -@:args(${REAL_TYPE}$, out, w(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*), z(ldz, *)) +@:args(${real(wp)}$, out, w(*)) @:args(integer, out, info) @:args(character, in, jobz, uplo, range) -@:args(${REAL_TYPE}$, in, vl, vu, abstol) +@:args(${real(wp)}$, in, vl, vu, abstol) @:args(integer, in, n, m, lda, ldz, il, iu, lwork, lrwork, liwork, ifail) -@:args(${TYPE}$, inout, work(*)) -@:args(${REAL_TYPE}$, inout, rwork(*)) +@:args(${type(wp)}$, inout, work(*)) +@:args(${real(wp)}$, inout, rwork(*)) @:args(integer, inout, iwork(*)) end subroutine #:enddef diff --git a/src/f77/lapack/hegv.fypp b/src/f77/lapack/hegv.fypp index d1342111..5b10b041 100644 --- a/src/f77/lapack/hegv.fypp +++ b/src/f77/lapack/hegv.fypp @@ -1,14 +1,15 @@ -#:def hegv(NAME,TYPE,KIND,PREFIX) +#:def hegv(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${TYPE}$, inout, b(ldb,*)) -@:args(${REAL_TYPE}$, out, w(*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${type(wp)}$, inout, b(ldb,*)) +@:args(${real(wp)}$, out, w(*)) @:args(integer, out, info) @:args(character, in, jobz, uplo) @:args(integer, in, n, itype, lda, ldb, lwork) -@:args(${TYPE}$, inout, work(*)) -@:args(${REAL_TYPE}$, in, rwork(*)) +@:args(${type(wp)}$, inout, work(*)) +@:args(${real(wp)}$, in, rwork(*)) end subroutine #:enddef diff --git a/src/f77/lapack/hetrf.fypp b/src/f77/lapack/hetrf.fypp index 7d887efb..2e42440c 100644 --- a/src/f77/lapack/hetrf.fypp +++ b/src/f77/lapack/hetrf.fypp @@ -1,11 +1,12 @@ -#:def hetrf(NAME,TYPE,KIND,PREFIX) +#:def hetrf(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(uplo, n, a, lda, ipiv, work, lwork, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(lda,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(lda,*)) @:args(character, in, uplo) @:args(integer, in, ipiv(*)) -@:args(${TYPE}$, inout, work(*)) +@:args(${type(wp)}$, inout, work(*)) @:args(integer, out, info) @:args(integer, in, n, lda, lwork) end subroutine diff --git a/src/f77/lapack/lartg.fypp b/src/f77/lapack/lartg.fypp new file mode 100644 index 00000000..872cb12b --- /dev/null +++ b/src/f77/lapack/lartg.fypp @@ -0,0 +1,10 @@ +#:def lartg(NAME,pfxs) +#:set wp=pfxs[0] +#:set wp = pfxs[0] +pure subroutine ${NAME}$(f, g, c, s, r) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(real(wp), inout, c) +@:args(${type(wp)}$, inout, f, g, r, s) +end subroutine +#:enddef diff --git a/src/f77/lapack/pocon.fypp b/src/f77/lapack/pocon.fypp index 866aa2f2..bf085429 100644 --- a/src/f77/lapack/pocon.fypp +++ b/src/f77/lapack/pocon.fypp @@ -8,36 +8,37 @@ ! real(wp) anorm, ! real(wp) rcond, ! type(wp), dimension( * ) work, -! if REAL_TYPES then, +! if real(wp)S then, ! integer, dimension( * ) iwork, -! if COMPLEX_TYPES then, +! if complex(wp)S then, ! real(wp), dimension( * ) rwork, ! integer info !) -#:def pocon(NAME,TYPE,KIND,PREFIX) -#:set TYPE_AND_KIND = TYPE.replace('wp',KIND) +#:def pocon(NAME,pfxs) +#:set wp=pfxs[0] +#:set wp = pfxs[0] !> ${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. +!> 1-norm) of a ${type(wp)}$ Hermitian positive definite matrix using the +!> Cholesky factorization A = U**H*U or A = L*L**H computed by ${wp}$POTRF. !> An estimate is obtained for norm(inv(A)), and the reciprocal of the !> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#:if TYPE == REAL_TYPE +#:if type(wp) == real(wp) pure subroutine ${NAME}$(uplo, n, a, lda, anorm, rcond, work, iwork, info) -#:elif TYPE == COMPLEX_TYPE +#:elif type(wp) == complex(wp) pure subroutine ${NAME}$(uplo, n, a, lda, anorm, rcond, work, rwork, info) #:endif - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) @:args(character, in, uplo) @:args(integer, in, n, lda) -@:args(${TYPE}$, inout, a(lda,*)) -@:args(${REAL_TYPE}$, in, anorm) -@:args(${REAL_TYPE}$, out, rcond) -@:args(${TYPE}$, inout, work(*)) -#:if TYPE == REAL_TYPE +@:args(${type(wp)}$, inout, a(lda,*)) +@:args(${real(wp)}$, in, anorm) +@:args(${real(wp)}$, out, rcond) +@:args(${type(wp)}$, inout, work(*)) +#:if type(wp) == real(wp) @:args(integer, inout, iwork(*)) -#:elif TYPE == COMPLEX_TYPE -@:args(${REAL_TYPE}$, inout, rwork(*)) +#:elif type(wp) == complex(wp) +@:args(${real(wp)}$, inout, rwork(*)) #:endif @:args(integer, out, info) end subroutine diff --git a/src/f77/lapack/potrf_potri.fypp b/src/f77/lapack/potrf_potri.fypp index ef756730..019384db 100644 --- a/src/f77/lapack/potrf_potri.fypp +++ b/src/f77/lapack/potrf_potri.fypp @@ -1,8 +1,9 @@ -#:def potrf_potri(NAME,TYPE,KIND,PREFIX) +#:def potrf_potri(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(uplo, n, a, lda, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) @:args(character, in, uplo) @:args(integer, in, n, lda) @:args(integer, out, info) diff --git a/src/f77/lapack/potrs.fypp b/src/f77/lapack/potrs.fypp index 55bcce61..ac9fd354 100644 --- a/src/f77/lapack/potrs.fypp +++ b/src/f77/lapack/potrs.fypp @@ -1,9 +1,10 @@ -#:def potrs(NAME,TYPE,KIND,PREFIX) +#:def potrs(NAME,pfxs) +#:set wp=pfxs[0] pure subroutine ${NAME}$(uplo, n, nrhs, a, lda, b, ldb, info) - import :: ${KIND}$ -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(lda,*)) -@:args(${TYPE}$, in, b(ldb,*)) + import :: ${kind(wp)}$ +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(lda,*)) +@:args(${type(wp)}$, in, b(ldb,*)) @:args(character, in, uplo) @:args(integer, in, n, nrhs, lda, ldb) @:args(integer, out, info) diff --git a/src/mfi/blas.fpp b/src/mfi/blas.fpp index 5108464c..ec296d34 100644 --- a/src/mfi/blas.fpp +++ b/src/mfi/blas.fpp @@ -31,6 +31,54 @@ #:include "src/mfi/blas/her2k.fypp" #:include "src/mfi/blas/syr2k.fypp" #:include "src/mfi/blas/trmm_trsm.fypp" +#:set COLLECT = [ & + ('?copy', DEFAULT_TYPES, copy_swap), & + ('?swap', DEFAULT_TYPES, copy_swap), & + ('?axpy', DEFAULT_TYPES, axpy), & + ('?dot', REAL_TYPES, dot_product), & + ('?dotc', COMPLEX_TYPES, dot_product), & + ('?dotu', COMPLEX_TYPES, dot_product), & + ('?asum', REAL_TYPES + MIX_REAL_COMPLEX, asum_nrm2), & + ('?nrm2', REAL_TYPES + MIX_REAL_COMPLEX, asum_nrm2), & + ('?rot', DEFAULT_TYPES + MIX_COMPLEX_REAL, rot), & + ('?rotm', REAL_TYPES, rotm), & + ('?scal', DEFAULT_TYPES + MIX_COMPLEX_REAL, scal), & + ('?gbmv', DEFAULT_TYPES, gbmv), & + ('?gemv', DEFAULT_TYPES, gemv), & + ('?ger', REAL_TYPES, ger_gerc_geru),& + ('?gerc', COMPLEX_TYPES, ger_gerc_geru),& + ('?geru', COMPLEX_TYPES, ger_gerc_geru),& + ('?hbmv', COMPLEX_TYPES, hbmv_sbmv), & + ('?hemv', COMPLEX_TYPES, hemv_symv), & + ('?her', COMPLEX_TYPES, her), & + ('?her2', COMPLEX_TYPES, her_syr2), & + ('?hpmv', COMPLEX_TYPES, hpmv_spmv), & + ('?hpr', COMPLEX_TYPES, hpr), & + ('?hpr2', COMPLEX_TYPES, hpr_spr2), & + ('?sbmv', REAL_TYPES, hbmv_sbmv), & + ('?spmv', REAL_TYPES, hpmv_spmv), & + ('?spr', REAL_TYPES, spr), & + ('?spr2', REAL_TYPES, hpr_spr2), & + ('?symv', REAL_TYPES, hemv_symv), & + ('?syr', REAL_TYPES, syr), & + ('?syr2', REAL_TYPES, her_syr2), & + ('?tbmv', DEFAULT_TYPES, tbmv_tbsv), & + ('?tbsv', DEFAULT_TYPES, tbmv_tbsv), & + ('?tpmv', DEFAULT_TYPES, tpmv_tpsv), & + ('?tpsv', DEFAULT_TYPES, tpmv_tpsv), & + ('?trmv', DEFAULT_TYPES, trmv_trsv), & + ('?trsv', DEFAULT_TYPES, trmv_trsv), & + ('?gemm', DEFAULT_TYPES, gemm), & + ('?hemm', COMPLEX_TYPES, hemm_symm), & + ('?herk', COMPLEX_TYPES, herk), & + ('?her2k',COMPLEX_TYPES, her2k), & + ('?symm', REAL_TYPES, hemm_symm), & + ('?syrk', REAL_TYPES, syrk), & + ('?syr2k',REAL_TYPES, syr2k), & + ('?trmm', DEFAULT_TYPES, trmm_trsm), & + ('?trsm', DEFAULT_TYPES, trmm_trsm), & + ('?lamch',REAL_TYPES, lamch), & +] #:endmute !> Modern fortran interfaces for BLAS module mfi_blas @@ -40,56 +88,9 @@ use f77_blas, only: mfi_rotg => f77_rotg use f77_blas, only: mfi_rotmg => f77_rotmg implicit none -! BLAS level 1 -$:mfi_interface('?asum', REAL_TYPES + REAL_COMPLEX_TYPES) -$:mfi_interface('?nrm2', REAL_TYPES + REAL_COMPLEX_TYPES) -$:mfi_interface('?axpy', DEFAULT_TYPES) -$:mfi_interface('?copy', DEFAULT_TYPES) -$:mfi_interface('?dot', REAL_TYPES) -$:mfi_interface('?dotu', COMPLEX_TYPES) -$:mfi_interface('?dotc', COMPLEX_TYPES) -$:mfi_interface('?rot', DEFAULT_TYPES + COMPLEX_REAL_TYPES) -$:mfi_interface('?rotm', REAL_TYPES) -$:mfi_interface('?scal', DEFAULT_TYPES + COMPLEX_REAL_TYPES) -$:mfi_interface('?swap', 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) +#:for name, supported_types, code in COLLECT +$:mfi_interface(name, supported_types) +#:endfor ! Extensions ! BLAS level 1 - Utils / Extensions @@ -97,62 +98,13 @@ $:mfi_interface('?trsm', DEFAULT_TYPES) $:mfi_interface('i?amax', DEFAULT_TYPES) $:mfi_interface('i?amin', DEFAULT_TYPES) #:endif -$:mfi_interface('?lamch', REAL_TYPES) contains -! BLAS level 1 -$:mfi_implement('?nrm2', DEFAULT_TYPES, asum_nrm2, MIX_REAL_COMPLEX) -$:mfi_implement('?asum', DEFAULT_TYPES, asum_nrm2, MIX_REAL_COMPLEX) -$:mfi_implement('?axpy', DEFAULT_TYPES, axpy) -$:mfi_implement('?copy', DEFAULT_TYPES, copy_swap) -$:mfi_implement('?dot', REAL_TYPES, dot_product) -$:mfi_implement('?dotu', COMPLEX_TYPES, dot_product) -$:mfi_implement('?dotc', COMPLEX_TYPES, dot_product) -$:mfi_implement('?rot', DEFAULT_TYPES, rot) -$:mfi_implement('?rot', COMPLEX_TYPES, rot_mixed, MIX_COMPLEX_REAL) -$:mfi_implement('?rotm', REAL_TYPES, rotm) -$:mfi_implement('?scal', DEFAULT_TYPES, scal) -$:mfi_implement('?scal', COMPLEX_TYPES, scal_mixed, MIX_COMPLEX_REAL) -$:mfi_implement('?swap', DEFAULT_TYPES, copy_swap) - -! 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) -$:mfi_implement('?her2', COMPLEX_TYPES, her_syr2) -$:mfi_implement('?hpmv', COMPLEX_TYPES, hpmv_spmv) -$:mfi_implement('?hpr', COMPLEX_TYPES, hpr) -$: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, spr) -$:mfi_implement('?spr2', REAL_TYPES, hpr_spr2) -$:mfi_implement('?symv', REAL_TYPES, hemv_symv) -$:mfi_implement('?syr', REAL_TYPES, 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) -$:mfi_implement('?her2k', COMPLEX_TYPES, her2k) -$:mfi_implement('?symm', REAL_TYPES, hemm_symm) -$:mfi_implement('?syrk', REAL_TYPES, syrk) -$:mfi_implement('?syr2k', REAL_TYPES, syr2k) -$:mfi_implement('?trmm', DEFAULT_TYPES, trmm_trsm) -$:mfi_implement('?trsm', DEFAULT_TYPES, trmm_trsm) +#:for name, supported_types, code in COLLECT +$:mfi_implement(name, supported_types, code) +#:endfor ! Extensions ! BLAS level 1 - Utils / Extensions @@ -160,6 +112,5 @@ $:mfi_implement('?trsm', DEFAULT_TYPES, trmm_trsm) $:mfi_implement('i?amax', DEFAULT_TYPES, iamin_iamax) $:mfi_implement('i?amin', DEFAULT_TYPES, iamin_iamax) #:endif -$:mfi_implement('?lamch', REAL_TYPES, lamch) end module diff --git a/src/mfi/blas/asum_nrm2.fypp b/src/mfi/blas/asum_nrm2.fypp index 95c45840..de59aaa0 100644 --- a/src/mfi/blas/asum_nrm2.fypp +++ b/src/mfi/blas/asum_nrm2.fypp @@ -1,9 +1,9 @@ -#:def asum_nrm2(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def asum_nrm2(MFI_NAME,F77_NAME,pfxs) +#:set A, B = get_types(pfxs) pure function ${MFI_NAME}$(x, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(:)) + ${type(A)}$ :: ${MFI_NAME}$ +@:args(${type(B)}$, in, x(:)) @:optional(integer, in, incx) - ${REAL_TYPE}$ :: ${MFI_NAME}$ integer :: n @:defaults(incx=1) n = size(x) diff --git a/src/mfi/blas/axpy.fypp b/src/mfi/blas/axpy.fypp index 2cec836d..086fe5c0 100644 --- a/src/mfi/blas/axpy.fypp +++ b/src/mfi/blas/axpy.fypp @@ -1,9 +1,10 @@ -#:def axpy(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def axpy(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:)) +@:args(${type(wp)}$, inout, y(:)) +@:optional(${type(wp)}$, in, a) @:optional(integer, in, incx, incy) integer :: n @:defaults(a=1.0_wp, incx=1, incy=1) diff --git a/src/mfi/blas/copy_swap.fypp b/src/mfi/blas/copy_swap.fypp index 1759db48..ebf2b674 100644 --- a/src/mfi/blas/copy_swap.fypp +++ b/src/mfi/blas/copy_swap.fypp @@ -1,8 +1,9 @@ -#:def copy_swap(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def copy_swap(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(x, y, incx, incy) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(:)) -@:args(${TYPE}$, inout, y(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:)) +@:args(${type(wp)}$, inout, y(:)) @:optional(integer, in, incx, incy) integer :: n @:defaults(incx=1, incy=1) diff --git a/src/mfi/blas/dot_product.fypp b/src/mfi/blas/dot_product.fypp index 89e90369..481deaca 100644 --- a/src/mfi/blas/dot_product.fypp +++ b/src/mfi/blas/dot_product.fypp @@ -1,8 +1,9 @@ -#:def dot_product(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def dot_product(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure function ${MFI_NAME}$(x, y, incx, incy) -@:parameter(integer, wp=${KIND}$) - ${TYPE}$ :: ${MFI_NAME}$ -@:args(${TYPE}$, in, x(:), y(:)) +@:parameter(integer, wp=${kind(wp)}$) + ${type(wp)}$ :: ${MFI_NAME}$ +@:args(${type(wp)}$, in, x(:), y(:)) integer :: n @:optional(integer, in, incx, incy) @:defaults(incx=1, incy=1) diff --git a/src/mfi/blas/gbmv.fypp b/src/mfi/blas/gbmv.fypp index 0434ed46..0ffcfe73 100644 --- a/src/mfi/blas/gbmv.fypp +++ b/src/mfi/blas/gbmv.fypp @@ -1,10 +1,11 @@ -#:def gbmv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def gbmv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:), x(:)) +@:args(${type(wp)}$, inout, y(:)) @:optional(character, in, trans) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) @:optional(integer, in, kl, m, incx, incy) integer :: n, ku, lda n = size(a,2) diff --git a/src/mfi/blas/gemm.fypp b/src/mfi/blas/gemm.fypp index a907df7f..e1f77e17 100644 --- a/src/mfi/blas/gemm.fypp +++ b/src/mfi/blas/gemm.fypp @@ -1,10 +1,11 @@ -#:def gemm(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def gemm(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, b, c, transa, transb, alpha, beta) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(:,:), b(:,:)) -@:args(${TYPE}$, inout, c(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:), b(:,:)) +@:args(${type(wp)}$, inout, c(:,:)) @:optional(character, in, transa, transb) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) integer :: m, n, k, lda, ldb, ldc @:defaults(transa='N', transb='N', alpha=1.0_wp, beta=0.0_wp) lda = max(1,size(a,1)) diff --git a/src/mfi/blas/gemv.fypp b/src/mfi/blas/gemv.fypp index 10ed4e75..58677bd6 100644 --- a/src/mfi/blas/gemv.fypp +++ b/src/mfi/blas/gemv.fypp @@ -1,10 +1,11 @@ -#:def gemv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def gemv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:), x(:)) +@:args(${type(wp)}$, inout, y(:)) @:optional(character, in, trans) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) @:optional(integer, in, incx, incy) integer :: m, n, lda @:defaults(trans='N', alpha=1.0_wp, beta=0.0_wp, incx=1, incy=1) diff --git a/src/mfi/blas/ger_gerc_geru.fypp b/src/mfi/blas/ger_gerc_geru.fypp index d35cf3a0..44eb38c3 100644 --- a/src/mfi/blas/ger_gerc_geru.fypp +++ b/src/mfi/blas/ger_gerc_geru.fypp @@ -1,9 +1,10 @@ -#:def ger_gerc_geru(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def ger_gerc_geru(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:), y(:)) +@:args(${type(wp)}$, inout, a(:,:)) +@:optional(${type(wp)}$, in, alpha) @:optional(integer, in, incx, incy) integer :: m, n, lda @:defaults(alpha=1.0_wp, incx=1, incy=1) diff --git a/src/mfi/blas/hbmv_sbmv.fypp b/src/mfi/blas/hbmv_sbmv.fypp index f5c4c584..4480866e 100644 --- a/src/mfi/blas/hbmv_sbmv.fypp +++ b/src/mfi/blas/hbmv_sbmv.fypp @@ -1,10 +1,11 @@ -#:def hbmv_sbmv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def hbmv_sbmv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:), a(:,:)) +@:args(${type(wp)}$, inout, y(:)) @:optional(character, in, uplo) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) @:optional(integer, in, incx, incy) integer :: n, k, lda @:defaults(uplo='U', alpha=1.0_wp, beta=0.0_wp, incx=1, incy=1) diff --git a/src/mfi/blas/hemm_symm.fypp b/src/mfi/blas/hemm_symm.fypp index a33340a1..54e9c2c8 100644 --- a/src/mfi/blas/hemm_symm.fypp +++ b/src/mfi/blas/hemm_symm.fypp @@ -1,10 +1,11 @@ -#:def hemm_symm(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def hemm_symm(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, b, c, side, uplo, alpha, beta) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(:,:), b(:,:)) -@:args(${TYPE}$, inout, c(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:), b(:,:)) +@:args(${type(wp)}$, inout, c(:,:)) @:optional(character, in, side, uplo) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) integer :: m, n, lda, ldb, ldc @:defaults(side='L', uplo='U', alpha=1.0_wp, beta=0.0_wp) lda = max(1,size(a,1)) diff --git a/src/mfi/blas/hemv_symv.fypp b/src/mfi/blas/hemv_symv.fypp index 682f1c05..a5630637 100644 --- a/src/mfi/blas/hemv_symv.fypp +++ b/src/mfi/blas/hemv_symv.fypp @@ -1,10 +1,11 @@ -#:def hemv_symv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def hemv_symv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:), a(:,:)) +@:args(${type(wp)}$, inout, y(:)) @:optional(character, in, uplo) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) @:optional(integer, in, incx, incy) integer :: n, lda @:defaults(uplo='U', alpha=1.0_wp, beta=0.0_wp, incx=1, incy=1) diff --git a/src/mfi/blas/her.fypp b/src/mfi/blas/her.fypp index 4d57199b..6ed1101f 100644 --- a/src/mfi/blas/her.fypp +++ b/src/mfi/blas/her.fypp @@ -1,8 +1,9 @@ -#:def her(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def her(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, x, uplo, alpha, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(:)) -@:args(${TYPE}$, inout, a(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:)) +@:args(${type(wp)}$, inout, a(:,:)) @:optional(character, in, uplo) @:optional(real(wp), in, alpha) @:optional(integer, in, incx) diff --git a/src/mfi/blas/her2k.fypp b/src/mfi/blas/her2k.fypp index 3a9100db..da6f6920 100644 --- a/src/mfi/blas/her2k.fypp +++ b/src/mfi/blas/her2k.fypp @@ -1,11 +1,12 @@ -#:def her2k(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def her2k(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:)) +@:args(${type(wp)}$, in, b(:,:)) +@:args(${type(wp)}$, inout, c(:,:)) @:optional(character, in, trans, uplo) -@:optional(${TYPE}$, in, alpha) +@:optional(${type(wp)}$, in, alpha) @:optional(real(wp), in, beta) integer :: n, k, lda, ldb, ldc @:defaults(trans='N', uplo='U', alpha=1.0_wp, beta=0.0_wp) diff --git a/src/mfi/blas/her_syr2.fypp b/src/mfi/blas/her_syr2.fypp index 2f89be92..a34bf72c 100644 --- a/src/mfi/blas/her_syr2.fypp +++ b/src/mfi/blas/her_syr2.fypp @@ -1,10 +1,11 @@ -#:def her_syr2(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def her_syr2(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, x, y, uplo, alpha, incx, incy) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(:), y(:)) -@:args(${TYPE}$, inout, a(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:), y(:)) +@:args(${type(wp)}$, inout, a(:,:)) @:optional(character, in, uplo) -@:optional(${TYPE}$, in, alpha) +@:optional(${type(wp)}$, in, alpha) @:optional(integer, in, incx, incy) integer :: n, lda @:defaults(uplo='U', alpha=1.0_wp, incx=1, incy=1) diff --git a/src/mfi/blas/herk.fypp b/src/mfi/blas/herk.fypp index cfdd075f..34c2e363 100644 --- a/src/mfi/blas/herk.fypp +++ b/src/mfi/blas/herk.fypp @@ -1,8 +1,9 @@ -#:def herk(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def herk(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, c, uplo, trans, alpha, beta) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(:,:)) -@:args(${TYPE}$, inout, c(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:)) +@:args(${type(wp)}$, inout, c(:,:)) @:optional(character, in, trans, uplo) @:optional(real(wp), in, alpha, beta) integer :: n, k, lda, ldc diff --git a/src/mfi/blas/hpmv_spmv.fypp b/src/mfi/blas/hpmv_spmv.fypp index f8f78a6a..07b06435 100644 --- a/src/mfi/blas/hpmv_spmv.fypp +++ b/src/mfi/blas/hpmv_spmv.fypp @@ -1,10 +1,11 @@ -#:def hpmv_spmv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def hpmv_spmv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:), ap(:)) +@:args(${type(wp)}$, inout, y(:)) @:optional(character, in, uplo) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) @:optional(integer, in, incx, incy) integer :: n @:defaults(uplo='U', alpha=1.0_wp, beta=0.0_wp, incx=1, incy=1) diff --git a/src/mfi/blas/hpr.fypp b/src/mfi/blas/hpr.fypp index 0a260421..ef4e88e3 100644 --- a/src/mfi/blas/hpr.fypp +++ b/src/mfi/blas/hpr.fypp @@ -1,8 +1,9 @@ -#:def hpr(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def hpr(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(ap, x, uplo, alpha, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(:)) -@:args(${TYPE}$, inout, ap(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:)) +@:args(${type(wp)}$, inout, ap(:)) @:optional(character, in, uplo) @:optional(real(wp), in, alpha) @:optional(integer, in, incx) diff --git a/src/mfi/blas/hpr_spr2.fypp b/src/mfi/blas/hpr_spr2.fypp index 912c31cb..6a30ab21 100644 --- a/src/mfi/blas/hpr_spr2.fypp +++ b/src/mfi/blas/hpr_spr2.fypp @@ -1,10 +1,11 @@ -#:def hpr_spr2(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def hpr_spr2(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(ap, x, y, uplo, alpha, incx, incy) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(:), y(:)) -@:args(${TYPE}$, inout, ap(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:), y(:)) +@:args(${type(wp)}$, inout, ap(:)) @:optional(character, in, uplo) -@:optional(${TYPE}$, in, alpha) +@:optional(${type(wp)}$, in, alpha) @:optional(integer, in, incx, incy) integer :: n @:defaults(uplo='U', alpha=1.0_wp, incx=1, incy=1) diff --git a/src/mfi/blas/iamin_iamax.fypp b/src/mfi/blas/iamin_iamax.fypp index 9d98e442..c47258bd 100644 --- a/src/mfi/blas/iamin_iamax.fypp +++ b/src/mfi/blas/iamin_iamax.fypp @@ -1,8 +1,9 @@ -#:def iamin_iamax(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def iamin_iamax(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure function ${MFI_NAME}$(x, incx) -@:parameter(integer, wp=${KIND}$) +@:parameter(integer, wp=${kind(wp)}$) integer :: ${MFI_NAME}$ -@:args(${TYPE}$, in, x(:)) +@:args(${type(wp)}$, in, x(:)) @:optional(integer, in, incx) integer :: n @:defaults(incx=1) diff --git a/src/mfi/blas/lamch.fypp b/src/mfi/blas/lamch.fypp index 0ee534ab..ff784814 100644 --- a/src/mfi/blas/lamch.fypp +++ b/src/mfi/blas/lamch.fypp @@ -1,10 +1,11 @@ -#:def lamch(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def lamch(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure function ${MFI_NAME}$(cmach, kind) result(res) -@:parameter(integer, wp=${KIND}$) +@:parameter(integer, wp=${kind(wp)}$) @:args(character, in, cmach) -@:args(${TYPE}$, in, kind) +@:args(${type(wp)}$, in, kind) !! Just a kind placeholder - ${TYPE}$ :: res + ${type(wp)}$ :: res res = ${F77_NAME}$(cmach) end function #:enddef diff --git a/src/mfi/blas/rot.fypp b/src/mfi/blas/rot.fypp index 8272ba75..c6c97ff3 100644 --- a/src/mfi/blas/rot.fypp +++ b/src/mfi/blas/rot.fypp @@ -1,20 +1,21 @@ -#:def rot(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def rot(MFI_NAME,F77_NAME,pfxs) +#:set A, B = get_types(pfxs) !> Given two vectors x and y, !> each vector element of these vectors is replaced as follows: !>```fortran -#:if TYPE == REAL_TYPE +#:if type(A) == real(A) !> xi = c*xi + s*yi !> yi = c*yi - s*xi -#:elif TYPE == COMPLEX_TYPE +#:elif type(A) == complex(A) !> xi = c*xi + s*yi !> yi = c*yi - conj(s)*xi #:endif !>``` pure subroutine ${MFI_NAME}$(x, y, c, s, incx, incy) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, x(:), y(:)) -@:args(${REAL_TYPE}$, in, c) -@:args(${TYPE}$, in, s) +@:parameter(integer, wp=${kind(A)}$) +@:args(${type(A)}$, inout, x(:), y(:)) +@:args(${real(A)}$, in, c) +@:args(${type(B)}$, in, s) @:optional(integer, in, incx, incy) integer :: n @:defaults(incx=1, incy=1) @@ -22,27 +23,3 @@ pure subroutine ${MFI_NAME}$(x, y, c, s, incx, incy) call ${F77_NAME}$(n,x,local_incx,y,local_incy,c,s) end subroutine #:enddef - -#:def rot_mixed(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) -!> Given two vectors x and y, -!> each vector element of these vectors is replaced as follows: -!>```fortran -#:if TYPE == REAL_TYPE -!> xi = c*xi + s*yi -!> yi = c*yi - s*xi -#:elif TYPE == COMPLEX_TYPE -!> xi = c*xi + s*yi -!> yi = c*yi - conj(s)*xi -#:endif -!>``` -pure subroutine ${MFI_NAME}$(x, y, c, s, incx, incy) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, x(:), y(:)) -@:args(${REAL_TYPE}$, in, c, s) -@:optional(integer, in, incx, incy) - integer :: n -@:defaults(incx=1, incy=1) - n = size(x) - call ${F77_NAME}$(n,x,local_incx,y,local_incy,c,s) -end subroutine -#:enddef diff --git a/src/mfi/blas/rotm.fypp b/src/mfi/blas/rotm.fypp index 659186a2..1dfc1386 100644 --- a/src/mfi/blas/rotm.fypp +++ b/src/mfi/blas/rotm.fypp @@ -1,8 +1,9 @@ -#:def rotm(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def rotm(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(x, y, param, incx, incy) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, x(:), y(:)) -@:args(${TYPE}$, in, param(5)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, x(:), y(:)) +@:args(${type(wp)}$, in, param(5)) @:optional(integer, in, incx, incy) integer :: n @:defaults(incx=1, incy=1) diff --git a/src/mfi/blas/scal.fypp b/src/mfi/blas/scal.fypp index 06a19322..e7e2a508 100644 --- a/src/mfi/blas/scal.fypp +++ b/src/mfi/blas/scal.fypp @@ -1,9 +1,9 @@ -#:def scal(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def scal(MFI_NAME,F77_NAME,pfxs) +#:set A, B = get_types(pfxs) !> ${MFI_NAME.upper()}$ scales a vector by a constant. -pure subroutine ${MFI_NAME}$(x, a, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, x(:)) -@:args(${TYPE}$, in, a) +pure subroutine ${MFI_NAME}$(a, x, incx) +@:args(${type(A)}$, inout, x(:)) +@:args(${type(B)}$, in, a) @:optional(integer, in, incx) integer :: n @:defaults(incx=1) @@ -11,17 +11,3 @@ pure subroutine ${MFI_NAME}$(x, a, incx) call ${F77_NAME}$(n,a,x,local_incx) end subroutine #:enddef - -#:def scal_mixed(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) -!> ${MFI_NAME.upper()}$ scales a vector by a constant. -pure subroutine ${MFI_NAME}$(x, a, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, x(:)) -@:args(${REAL_TYPE}$, in, a) -@:optional(integer, in, incx) - integer :: n -@:defaults(incx=1) - n = size(x) - call ${F77_NAME}$(n,a,x,local_incx) -end subroutine -#:enddef diff --git a/src/mfi/blas/spr.fypp b/src/mfi/blas/spr.fypp index 3a5b0bd6..92a975b4 100644 --- a/src/mfi/blas/spr.fypp +++ b/src/mfi/blas/spr.fypp @@ -1,10 +1,11 @@ -#:def spr(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def spr(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(ap, x, uplo, alpha, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(:)) -@:args(${TYPE}$, inout, ap(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:)) +@:args(${type(wp)}$, inout, ap(:)) @:optional(character, in, uplo) -@:optional(${TYPE}$, in, alpha) +@:optional(${type(wp)}$, in, alpha) @:optional(integer, in, incx) integer :: n @:defaults(uplo='U', alpha=1.0_wp, incx=1) diff --git a/src/mfi/blas/syr.fypp b/src/mfi/blas/syr.fypp index be36a082..de823e20 100644 --- a/src/mfi/blas/syr.fypp +++ b/src/mfi/blas/syr.fypp @@ -1,10 +1,11 @@ -#:def syr(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def syr(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, x, uplo, alpha, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, x(:)) -@:args(${TYPE}$, inout, a(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, x(:)) +@:args(${type(wp)}$, inout, a(:,:)) @:optional(character, in, uplo) -@:optional(${TYPE}$, in, alpha) +@:optional(${type(wp)}$, in, alpha) @:optional(integer, in, incx) integer :: n, lda @:defaults(uplo='U', alpha=1.0_wp, incx=1) diff --git a/src/mfi/blas/syr2k.fypp b/src/mfi/blas/syr2k.fypp index 16670697..8642b81a 100644 --- a/src/mfi/blas/syr2k.fypp +++ b/src/mfi/blas/syr2k.fypp @@ -1,11 +1,12 @@ -#:def syr2k(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def syr2k(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] 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(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:)) +@:args(${type(wp)}$, in, b(:,:)) +@:args(${type(wp)}$, inout, c(:,:)) @:optional(character, in, trans, uplo) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) integer :: n, k, lda, ldb, ldc @:defaults(trans='N', uplo='U', alpha=1.0_wp, beta=0.0_wp) n = size(c,2) diff --git a/src/mfi/blas/syrk.fypp b/src/mfi/blas/syrk.fypp index cab2f7c3..4290595b 100644 --- a/src/mfi/blas/syrk.fypp +++ b/src/mfi/blas/syrk.fypp @@ -1,10 +1,11 @@ -#:def syrk(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def syrk(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, c, uplo, trans, alpha, beta) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(:,:)) -@:args(${TYPE}$, inout, c(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:)) +@:args(${type(wp)}$, inout, c(:,:)) @:optional(character, in, trans, uplo) -@:optional(${TYPE}$, in, alpha, beta) +@:optional(${type(wp)}$, in, alpha, beta) integer :: n, k, lda, ldc @:defaults(trans='N', uplo='U', alpha=1.0_wp, beta=0.0_wp) n = size(c,2) diff --git a/src/mfi/blas/tbmv_tbsv.fypp b/src/mfi/blas/tbmv_tbsv.fypp index 5f7f24c2..9e7a1961 100644 --- a/src/mfi/blas/tbmv_tbsv.fypp +++ b/src/mfi/blas/tbmv_tbsv.fypp @@ -1,8 +1,9 @@ -#:def tbmv_tbsv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def tbmv_tbsv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, x, uplo, trans, diag, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(:,:)) -@:args(${TYPE}$, inout, x(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:)) +@:args(${type(wp)}$, inout, x(:)) @:optional(character, in, uplo, trans, diag) @:optional(integer, in, incx) integer :: n, k, lda diff --git a/src/mfi/blas/tpmv_tpsv.fypp b/src/mfi/blas/tpmv_tpsv.fypp index b80a5986..c56083f0 100644 --- a/src/mfi/blas/tpmv_tpsv.fypp +++ b/src/mfi/blas/tpmv_tpsv.fypp @@ -1,8 +1,9 @@ -#:def tpmv_tpsv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def tpmv_tpsv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(ap, x, uplo, trans, diag, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, ap(:)) -@:args(${TYPE}$, inout, x(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, ap(:)) +@:args(${type(wp)}$, inout, x(:)) @:optional(character, in, uplo, trans, diag) @:optional(integer, in, incx) integer :: n diff --git a/src/mfi/blas/trmm_trsm.fypp b/src/mfi/blas/trmm_trsm.fypp index 1a952ce1..8e708354 100644 --- a/src/mfi/blas/trmm_trsm.fypp +++ b/src/mfi/blas/trmm_trsm.fypp @@ -1,10 +1,11 @@ -#:def trmm_trsm(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def trmm_trsm(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, b, side, uplo, transa, diag, alpha) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(:,:)) -@:args(${TYPE}$, inout, b(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:)) +@:args(${type(wp)}$, inout, b(:,:)) @:optional(character, in, side, uplo, transa, diag) -@:optional(${TYPE}$, in, alpha) +@:optional(${type(wp)}$, in, alpha) integer :: m, n, lda, ldb @:defaults(side='L', uplo='U', transa='N', diag='N', alpha=1.0_wp) m = size(b,1) diff --git a/src/mfi/blas/trmv_trsv.fypp b/src/mfi/blas/trmv_trsv.fypp index 6e185b02..82dd5a3b 100644 --- a/src/mfi/blas/trmv_trsv.fypp +++ b/src/mfi/blas/trmv_trsv.fypp @@ -1,8 +1,9 @@ -#:def trmv_trsv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def trmv_trsv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, x, uplo, trans, diag, incx) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(:,:)) -@:args(${TYPE}$, inout, x(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:)) +@:args(${type(wp)}$, inout, x(:)) @:optional(character, in, uplo, trans, diag) @:optional(integer, in, incx) integer :: n, lda diff --git a/src/mfi/lapack.fpp b/src/mfi/lapack.fpp index 80ec7279..9eb25cb7 100644 --- a/src/mfi/lapack.fpp +++ b/src/mfi/lapack.fpp @@ -11,6 +11,21 @@ #:include "src/mfi/lapack/potrf_potri.fypp" #:include "src/mfi/lapack/potrs.fypp" #:include "src/mfi/lapack/pocon.fypp" +#:set COLLECT = [ & + ('?geqrf', DEFAULT_TYPES, geqrf_gerqf), & + ('?gerqf', DEFAULT_TYPES, geqrf_gerqf), & + ('?getrf', DEFAULT_TYPES, getrf), & + ('?getri', DEFAULT_TYPES, getri), & + ('?getrs', DEFAULT_TYPES, getrs), & + ('?hetrf', COMPLEX_TYPES, hetrf), & + ('?hegv', COMPLEX_TYPES, hegv), & + ('?heevd', COMPLEX_TYPES, heevd), & + ('?gesvd', DEFAULT_TYPES, gesvd), & + ('?potrf', DEFAULT_TYPES, potrf_potri), & + ('?potri', DEFAULT_TYPES, potrf_potri), & + ('?potrs', DEFAULT_TYPES, potrs), & + ('?pocon', DEFAULT_TYPES, pocon), & +] #:endmute !> Modern fortran interfaces for LAPACK module mfi_lapack @@ -19,35 +34,15 @@ use f77_lapack use f77_lapack, only: mfi_lartg => f77_lartg implicit none -$:mfi_interface('?geqrf', DEFAULT_TYPES) -$:mfi_interface('?gerqf', DEFAULT_TYPES) -$:mfi_interface('?getrf', DEFAULT_TYPES) -$:mfi_interface('?getri', DEFAULT_TYPES) -$:mfi_interface('?getrs', DEFAULT_TYPES) -$:mfi_interface('?hetrf', COMPLEX_TYPES) -$:mfi_interface('?hegv', COMPLEX_TYPES) -$:mfi_interface('?heevd', COMPLEX_TYPES) -$:mfi_interface('?gesvd', DEFAULT_TYPES) -$:mfi_interface('?potrf', DEFAULT_TYPES) -$:mfi_interface('?potri', DEFAULT_TYPES) -$:mfi_interface('?potrs', DEFAULT_TYPES) -$:mfi_interface('?pocon', DEFAULT_TYPES) +#:for name, supported_types, code in COLLECT +$:mfi_interface(name, supported_types) +#:endfor contains -$:mfi_implement('?geqrf', DEFAULT_TYPES, geqrf_gerqf) -$:mfi_implement('?gerqf', DEFAULT_TYPES, geqrf_gerqf) -$:mfi_implement('?getrf', DEFAULT_TYPES, getrf) -$:mfi_implement('?getri', DEFAULT_TYPES, getri) -$:mfi_implement('?getrs', DEFAULT_TYPES, getrs) -$:mfi_implement('?hetrf', COMPLEX_TYPES, hetrf) -$:mfi_implement('?hegv', COMPLEX_TYPES, hegv) -$:mfi_implement('?heevd', COMPLEX_TYPES, heevd) -$:mfi_implement('?gesvd', DEFAULT_TYPES, gesvd) -$:mfi_implement('?potrf', DEFAULT_TYPES, potrf_potri) -$:mfi_implement('?potri', DEFAULT_TYPES, potrf_potri) -$:mfi_implement('?potrs', DEFAULT_TYPES, potrs) -$:mfi_implement('?pocon', DEFAULT_TYPES, pocon) +#:for name, supported_types, code in COLLECT +$:mfi_implement(name, supported_types, code) +#:endfor pure subroutine mfi_error(name, info) character(*), intent(in) :: name diff --git a/src/mfi/lapack/geqrf_gerqf.fypp b/src/mfi/lapack/geqrf_gerqf.fypp index f33dc565..29a9346e 100644 --- a/src/mfi/lapack/geqrf_gerqf.fypp +++ b/src/mfi/lapack/geqrf_gerqf.fypp @@ -1,12 +1,13 @@ -#:def geqrf_gerqf(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def geqrf_gerqf(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, tau, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) - ${TYPE}$, intent(out), optional, target :: tau(:) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) + ${type(wp)}$, intent(out), optional, target :: tau(:) @:optional(integer, out, info) integer :: m, n, lda, lwork, allocation_status, deallocation_status - ${TYPE}$, pointer :: local_tau(:), work(:) - ${TYPE}$, target :: s_work(1) + ${type(wp)}$, pointer :: local_tau(:), work(:) + ${type(wp)}$, target :: s_work(1) lda = max(1,size(a,1)) m = size(a,1) n = size(a,2) diff --git a/src/mfi/lapack/gesvd.fypp b/src/mfi/lapack/gesvd.fypp index 24fd6583..2a1d6136 100644 --- a/src/mfi/lapack/gesvd.fypp +++ b/src/mfi/lapack/gesvd.fypp @@ -1,18 +1,19 @@ -#:def gesvd(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def gesvd(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, s, u, vt, ww, job, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) -@:args(${REAL_TYPE}$, out, s(:)) - ${TYPE}$, intent(out), optional, target :: u(:,:), vt(:,:) - ${REAL_TYPE}$, intent(out), optional, target :: ww(:) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) +@:args(${real(wp)}$, out, s(:)) + ${type(wp)}$, intent(out), optional, target :: u(:,:), vt(:,:) + ${real(wp)}$, intent(out), optional, target :: ww(:) @:optional(character, in, job) @:optional(integer, out, info) character :: jobu, jobvt integer :: m, n, lda, ldu, ldvt, lwork, allocation_status, deallocation_status - ${TYPE}$, target :: s_work(1), l_a2(1,1) - ${TYPE}$, pointer :: local_u(:,:), local_vt(:,:), work(:) -#:if TYPE == COMPLEX_TYPE - ${REAL_TYPE}$, pointer :: rwork(:) + ${type(wp)}$, target :: s_work(1), l_a2(1,1) + ${type(wp)}$, pointer :: local_u(:,:), local_vt(:,:), work(:) +#:if type(wp) == complex(wp) + ${real(wp)}$, pointer :: rwork(:) #:endif @:defaults(job='N') lda = max(1,size(a,1)) @@ -52,7 +53,7 @@ pure subroutine ${MFI_NAME}$(a, s, u, vt, ww, job, info) end if allocation_status = 0 lwork = -1 -#:if TYPE == COMPLEX_TYPE +#:if type(wp) == complex(wp) allocate(rwork(5*min(m,n)), stat=allocation_status) call ${F77_NAME}$(jobu,jobvt,m,n,a,lda,s,local_u,ldu,local_vt,ldvt,s_work,lwork,rwork,local_info) #:else @@ -64,7 +65,7 @@ pure subroutine ${MFI_NAME}$(a, s, u, vt, ww, job, info) lwork = int(s_work(1)) allocate(work(lwork), stat=allocation_status) if (allocation_status == 0) then -#:if TYPE == COMPLEX_TYPE +#:if type(wp) == complex(wp) call ${F77_NAME}$(jobu,jobvt,m,n,a,lda,s,local_u,ldu,local_vt,ldvt,work,lwork,rwork,local_info) #:else call ${F77_NAME}$(jobu,jobvt,m,n,a,lda,s,local_u,ldu,local_vt,ldvt,work,lwork,local_info) @@ -78,7 +79,7 @@ pure subroutine ${MFI_NAME}$(a, s, u, vt, ww, job, info) end if deallocate(work, stat=deallocation_status) 404 continue -#:if TYPE == COMPLEX_TYPE +#:if type(wp) == complex(wp) deallocate(rwork, stat=deallocation_status) #:endif if (present(info)) then diff --git a/src/mfi/lapack/getrf.fypp b/src/mfi/lapack/getrf.fypp index be066286..f6950391 100644 --- a/src/mfi/lapack/getrf.fypp +++ b/src/mfi/lapack/getrf.fypp @@ -1,7 +1,8 @@ -#:def getrf(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def getrf(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, ipiv, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) integer, intent(out), optional, target :: ipiv(:) @:optional(integer, out, info) integer :: m, n, lda, allocation_status, deallocation_status diff --git a/src/mfi/lapack/getri.fypp b/src/mfi/lapack/getri.fypp index 97bad99b..562551de 100644 --- a/src/mfi/lapack/getri.fypp +++ b/src/mfi/lapack/getri.fypp @@ -1,10 +1,11 @@ -#:def getri(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def getri(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, ipiv, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) @:args(integer, in, ipiv(:)) - ${TYPE}$, pointer :: work(:) - ${TYPE}$ :: s_work(1) + ${type(wp)}$, pointer :: work(:) + ${type(wp)}$ :: s_work(1) @:optional(integer, out, info) integer :: n, lda, lwork, allocation_status, deallocation_status lda = max(1,size(a,1)) diff --git a/src/mfi/lapack/getrs.fypp b/src/mfi/lapack/getrs.fypp index d9cfd4ef..6cd82208 100644 --- a/src/mfi/lapack/getrs.fypp +++ b/src/mfi/lapack/getrs.fypp @@ -1,8 +1,9 @@ -#:def getrs(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def getrs(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a,ipiv,b,trans,info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) -@:args(${TYPE}$, inout, b(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) +@:args(${type(wp)}$, inout, b(:,:)) @:args(integer, in, ipiv(:)) @:optional(integer, out, info) @:optional(character, in, trans) diff --git a/src/mfi/lapack/heevd.fypp b/src/mfi/lapack/heevd.fypp index 14e79aae..8e94a41d 100644 --- a/src/mfi/lapack/heevd.fypp +++ b/src/mfi/lapack/heevd.fypp @@ -1,15 +1,16 @@ -#:def heevd(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def heevd(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, w, jobz, uplo, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) -@:args(${REAL_TYPE}$, out, w(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) +@:args(${real(wp)}$, out, w(:)) @:optional(integer, out, info) @:optional(character, in, jobz, uplo) - ${TYPE}$, pointer :: work(:) - ${REAL_TYPE}$, pointer :: rwork(:) + ${type(wp)}$, pointer :: work(:) + ${real(wp)}$, pointer :: rwork(:) integer, pointer :: iwork(:) - ${TYPE}$ :: s_work(1) - ${REAL_TYPE}$ :: s_rwork(1) + ${type(wp)}$ :: s_work(1) + ${real(wp)}$ :: s_rwork(1) integer :: s_iwork(1) integer :: n, lda, lwork, lrwork, liwork, allocation_status, deallocation_status @:defaults(jobz='N', uplo='U') diff --git a/src/mfi/lapack/heevr.fypp b/src/mfi/lapack/heevr.fypp index 989cfa22..6b6f14cb 100644 --- a/src/mfi/lapack/heevr.fypp +++ b/src/mfi/lapack/heevr.fypp @@ -1,28 +1,29 @@ #:mute -#:def heevr(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def heevr(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, w, uplo, z, vl, vu, il, iu, m, isuppz, abstol, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) -@:args(${REAL_TYPE}$, out, w(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) +@:args(${real(wp)}$, out, w(:)) @:optional(character, in, uplo) -@:optional(${REAL_TYPE}$, in, vl, vu, abstol) +@:optional(${real(wp)}$, in, vl, vu, abstol) @:optional(integer, in, il, iu) @:optional(integer, out, m) @:optional(integer, out, info) - ${TYPE}$, intent(out), optional, target :: z(:,:) + ${type(wp)}$, intent(out), optional, target :: z(:,:) integer, intent(out), optional, target :: isuppz(:) integer, pointer :: local_isuppz(:) - ${TYPE}$, pointer :: local_z(:,:) - ${TYPE}$, pointer :: work(:) - ${REAL_TYPE}$, pointer :: rwork(:) + ${type(wp)}$, pointer :: local_z(:,:) + ${type(wp)}$, pointer :: work(:) + ${real(wp)}$, pointer :: rwork(:) integer, pointer :: iwork(:) - ${TYPE}$ :: s_work(1) - ${REAL_TYPE}$ :: s_rwork(1) + ${type(wp)}$ :: s_work(1) + ${real(wp)}$ :: s_rwork(1) integer :: s_iwork(1) character :: jobz, range integer :: n, lda, ldz, lwork, lrwork, liwork, allocation_status, deallocation_status integer, target :: dummy_rank_1(1) - ${TYPE}$, target :: dummy_rank_2(1,1) + ${type(wp)}$, target :: dummy_rank_2(1,1) lda = max(1,size(a,1)) n = size(a,2) diff --git a/src/mfi/lapack/hegv.fypp b/src/mfi/lapack/hegv.fypp index df7a04d9..ef8746ad 100644 --- a/src/mfi/lapack/hegv.fypp +++ b/src/mfi/lapack/hegv.fypp @@ -1,14 +1,15 @@ -#:def hegv(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def hegv(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, b, w, itype, jobz, uplo, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:), b(:,:)) -@:args(${REAL_TYPE}$, out, w(:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:), b(:,:)) +@:args(${real(wp)}$, out, w(:)) @:optional(integer, in, itype) @:optional(character, in, jobz, uplo) @:optional(integer, out, info) - ${TYPE}$, pointer :: work(:) - ${REAL_TYPE}$, pointer :: rwork(:) - ${TYPE}$ :: s_work(1) + ${type(wp)}$, pointer :: work(:) + ${real(wp)}$, pointer :: rwork(:) + ${type(wp)}$ :: s_work(1) integer :: n, lda, ldb, lwork, allocation_status, deallocation_status @:defaults(itype=1, jobz='N', uplo='U') lda = max(1,size(a,1)) diff --git a/src/mfi/lapack/hetrf.fypp b/src/mfi/lapack/hetrf.fypp index f46902dc..3b1563a9 100644 --- a/src/mfi/lapack/hetrf.fypp +++ b/src/mfi/lapack/hetrf.fypp @@ -1,14 +1,15 @@ -#:def hetrf(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def hetrf(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, uplo, ipiv, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) integer, intent(out), optional, target :: ipiv(:) integer, pointer :: local_ipiv(:) @:optional(character, in, uplo) @:optional(integer, out, info) integer :: n, lda, lwork, allocation_status, deallocation_status - ${TYPE}$, target :: s_work(1) - ${TYPE}$, pointer :: work(:) + ${type(wp)}$, target :: s_work(1) + ${type(wp)}$, pointer :: work(:) @:defaults(uplo='U') lda = max(1,size(a,1)) n = size(a,2) diff --git a/src/mfi/lapack/pocon.fypp b/src/mfi/lapack/pocon.fypp index 0e240e7c..b3ece7e9 100644 --- a/src/mfi/lapack/pocon.fypp +++ b/src/mfi/lapack/pocon.fypp @@ -8,21 +8,22 @@ ! integer info !) -#:def pocon(MFI_NAME, F77_NAME, TYPE, KIND,PREFIX) +#:def pocon(MFI_NAME, F77_NAME, pfxs) +#:set wp = pfxs[0] !> Estimates the reciprocal of the condition number of a real symmetric / complex Hermitian positive definite matrix using the Cholesky factorization computed by ?POTRF pure subroutine ${MFI_NAME}$(a, anorm, rcond, uplo, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) -@:args(${REAL_TYPE}$, in, anorm) -@:args(${REAL_TYPE}$, out, rcond) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) +@:args(${real(wp)}$, in, anorm) +@:args(${real(wp)}$, out, rcond) @:optional(character, in, uplo) @:optional(integer, out, info) integer :: n, lda, allocation_status, deallocation_status - ${TYPE}$, pointer :: work(:) -#:if TYPE == REAL_TYPE + ${type(wp)}$, pointer :: work(:) +#:if type(wp) == real(wp) integer, pointer :: xwork(:) -#:elif TYPE == COMPLEX_TYPE - ${REAL_TYPE}$, pointer :: xwork(:) +#:elif type(wp) == complex(wp) + ${real(wp)}$, pointer :: xwork(:) #:endif @:defaults(uplo='U') lda = max(1,size(a,1)) diff --git a/src/mfi/lapack/potrf_potri.fypp b/src/mfi/lapack/potrf_potri.fypp index 326ea043..be7ad2cf 100644 --- a/src/mfi/lapack/potrf_potri.fypp +++ b/src/mfi/lapack/potrf_potri.fypp @@ -1,7 +1,8 @@ -#:def potrf_potri(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def potrf_potri(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, info, uplo) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, inout, a(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, inout, a(:,:)) @:optional(character, in, uplo) @:optional(integer, out, info) integer :: n, lda diff --git a/src/mfi/lapack/potrs.fypp b/src/mfi/lapack/potrs.fypp index aadc791d..7d41e91f 100644 --- a/src/mfi/lapack/potrs.fypp +++ b/src/mfi/lapack/potrs.fypp @@ -1,8 +1,9 @@ -#:def potrs(MFI_NAME,F77_NAME,TYPE,KIND,PREFIX) +#:def potrs(MFI_NAME,F77_NAME,pfxs) +#:set wp = pfxs[0] pure subroutine ${MFI_NAME}$(a, b, uplo, info) -@:parameter(integer, wp=${KIND}$) -@:args(${TYPE}$, in, a(:,:)) -@:args(${TYPE}$, inout, b(:,:)) +@:parameter(integer, wp=${kind(wp)}$) +@:args(${type(wp)}$, in, a(:,:)) +@:args(${type(wp)}$, inout, b(:,:)) @:optional(character, in, uplo) @:optional(integer, out, info) integer :: n, nrhs, lda, ldb diff --git a/test/blas.fpp b/test/blas.fpp index ba5cbdf4..049e14ca 100644 --- a/test/blas.fpp +++ b/test/blas.fpp @@ -1,3 +1,4 @@ +#:mute #:include "common.fpp" #:include "test/blas/asum_nrm2.fypp" #:include "test/blas/iamin_iamax.fypp" @@ -11,23 +12,29 @@ #:include "test/blas/lamch.fypp" #:include "test/blas/gemv.fypp" #:include "test/blas/gemm.fypp" +#:set COLLECT = [ & + ('?lamch',REAL_TYPES, lamch), & + ('?dot', REAL_TYPES, dot_product), & + ('?dotc', COMPLEX_TYPES, dot_product), & + ('?dotu', COMPLEX_TYPES, dot_product), & + ('?copy', DEFAULT_TYPES, copy), & + ('?swap', DEFAULT_TYPES, swap), & + ('?axpy', DEFAULT_TYPES, axpy), & + ('?gemv', DEFAULT_TYPES, gemv), & + ('?gemm', DEFAULT_TYPES, gemm), & + ('?asum', REAL_TYPES + MIX_REAL_COMPLEX, asum_nrm2), & + ('?nrm2', REAL_TYPES + MIX_REAL_COMPLEX, asum_nrm2), & + ('?rot', DEFAULT_TYPES + MIX_COMPLEX_REAL, rot), & + ('?rotg', DEFAULT_TYPES, rotg), & + ('?scal', DEFAULT_TYPES + MIX_COMPLEX_REAL, scal), & +] +#:endmute program main use iso_fortran_env implicit none -$:test_run('?lamch',REAL_TYPES) -$:test_run('?dot', REAL_TYPES) -$:test_run('?dotu', COMPLEX_TYPES) -$:test_run('?dotc', COMPLEX_TYPES) -$:test_run('?copy', DEFAULT_TYPES) -$:test_run('?swap', DEFAULT_TYPES) -$:test_run('?axpy', DEFAULT_TYPES) -$:test_run('?gemv', DEFAULT_TYPES) -$:test_run('?gemm', DEFAULT_TYPES) -$:test_run('?asum', DEFAULT_TYPES, MIX_REAL_COMPLEX) -$:test_run('?nrm2', DEFAULT_TYPES, MIX_REAL_COMPLEX) -$:test_run('?rot', DEFAULT_TYPES + COMPLEX_REAL_TYPES) -$:test_run('?rotg', DEFAULT_TYPES) -$:test_run('?scal', DEFAULT_TYPES + COMPLEX_REAL_TYPES) +#:for name, supported_types, code in COLLECT +$:test_run(name, supported_types) +#:endfor #:if defined('MFI_EXTENSIONS') $:test_run('i?amin',DEFAULT_TYPES) @@ -36,33 +43,21 @@ $:test_run('i?amax',DEFAULT_TYPES) contains -$:test_implement('?lamch',REAL_TYPES, lamch) -$:test_implement('?dot', REAL_TYPES, dot_product) -$:test_implement('?dotc', COMPLEX_TYPES, dot_product) -$:test_implement('?dotu', COMPLEX_TYPES, dot_product) -$:test_implement('?copy', DEFAULT_TYPES, copy) -$:test_implement('?swap', DEFAULT_TYPES, swap) -$:test_implement('?axpy', DEFAULT_TYPES, axpy) -$:test_implement('?gemv', DEFAULT_TYPES, gemv) -$:test_implement('?gemm', DEFAULT_TYPES, gemm) -$:test_implement('?asum', DEFAULT_TYPES, asum_nrm2, MIX_REAL_COMPLEX) -$:test_implement('?nrm2', DEFAULT_TYPES, asum_nrm2, MIX_REAL_COMPLEX) -$:test_implement('?rot', DEFAULT_TYPES, rot) -$:test_implement('?rot', COMPLEX_TYPES, rot_mixed, MIX_COMPLEX_REAL) -$:test_implement('?rotg', DEFAULT_TYPES, rotg) -$:test_implement('?scal', DEFAULT_TYPES, scal) -$:test_implement('?scal', COMPLEX_TYPES, scal_mixed, MIX_COMPLEX_REAL) +#:for name, supported_types, code in COLLECT +$:test_implement(name, supported_types,code) +#:endfor #:if defined('MFI_EXTENSIONS') $:test_implement('i?amin',DEFAULT_TYPES, iamin_iamax) $:test_implement('i?amax',DEFAULT_TYPES, iamin_iamax) #:endif - pure subroutine assert(test, msg) - logical, intent(in) :: test - character(*), intent(in) :: msg - if (.not. test) then - error stop msg - end if - end subroutine +pure subroutine assert(test, msg) + logical, intent(in) :: test + character(*), intent(in) :: msg + if (.not. test) then + error stop msg + end if +end subroutine + end program diff --git a/test/blas/asum_nrm2.fypp b/test/blas/asum_nrm2.fypp index 777b07ba..94e9706b 100644 --- a/test/blas/asum_nrm2.fypp +++ b/test/blas/asum_nrm2.fypp @@ -1,35 +1,28 @@ -#:def asum_nrm2(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def asum_nrm2(f77,f90,mfi,pfxs) +#:set A, B = get_types(pfxs) +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(A)}$ integer, parameter :: N = 20 - ${REAL_TYPE}$ :: rnd(N) - ${TYPE}$ :: array(N) - ${TYPE}$ :: res(4) + ${type(B)}$ :: array(N) + ${type(A)}$ :: res(4) integer :: i ! Test sequential array array = [(1.0_wp*i,i=1,N)] - res(1) = ${ORIGINAL}$(N, array, 1) - res(2) = mfi_${ORIGINAL}$(array) - res(3) = ${IMPROVED}$(N, array, 1) - res(4) = ${MODERN}$(array) + res(1) = ${f77}$(N, array, 1) + res(3) = ${f90}$(N, array, 1) + res(2) = mfi_${f77}$(array) + res(4) = ${mfi}$(array) call assert(all(res == res(1)), "different results for sequential array") -#:if TYPE == COMPLEX_TYPE - call random_number(rnd) - array%re = rnd - call random_number(rnd) - array%im = rnd -#:else - call random_number(array) -#:endif - res(1) = ${ORIGINAL}$(N, array, 1) - res(2) = ${IMPROVED}$(N, array, 1) - res(3) = mfi_${ORIGINAL}$(array) - res(4) = ${MODERN}$(array) + $:random_number(type(B),'array','(N)') + res(1) = ${f77}$(N, array, 1) + res(2) = ${f90}$(N, array, 1) + res(3) = mfi_${f77}$(array) + res(4) = ${mfi}$(array) call assert(all(res == res(1)), "different results for random array") end subroutine diff --git a/test/blas/axpy.fypp b/test/blas/axpy.fypp index cb9926c7..e879ad1b 100644 --- a/test/blas/axpy.fypp +++ b/test/blas/axpy.fypp @@ -1,17 +1,18 @@ -#:def axpy(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def axpy(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(wp)}$ integer, parameter :: N = 20 - ${REAL_TYPE}$ :: rnd_vector(N), rnd - ${TYPE}$ :: x(N), Y(N), & + ${real(wp)}$ :: rnd_vector(N), rnd + ${type(wp)}$ :: x(N), Y(N), & x_in(N), y_in(N), & x_rf(N), y_rf(N) - ${TYPE}$ :: alpha + ${type(wp)}$ :: alpha -#:if TYPE == COMPLEX_TYPE +#:if type(wp) == complex(wp) call random_number(rnd_vector) X%re = rnd_vector call random_number(rnd_vector) @@ -32,23 +33,23 @@ subroutine test_${ORIGINAL}$ x_in = X y_in = Y - call ${ORIGINAL}$(N, alpha, x_in, 1, y_in, 1) + call ${f77}$(N, alpha, x_in, 1, y_in, 1) x_rf = x_in y_rf = y_in x_in = X y_in = Y - call ${IMPROVED}$(N, alpha, x_in, 1, y_in, 1) + call ${f90}$(N, alpha, x_in, 1, y_in, 1) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") x_in = X y_in = Y - call mfi_${ORIGINAL}$(x_in,y_in,alpha) + call mfi_${f77}$(x_in,y_in,alpha) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") x_in = X y_in = Y - call ${MODERN}$(x_in, y_in, alpha) + call ${mfi}$(x_in, y_in, alpha) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") diff --git a/test/blas/copy.fypp b/test/blas/copy.fypp index a8648709..b3672a25 100644 --- a/test/blas/copy.fypp +++ b/test/blas/copy.fypp @@ -1,50 +1,40 @@ #:mute -#:def copy(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def copy(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(wp)}$ integer, parameter :: N = 20 - ${REAL_TYPE}$ :: rnd(N) + ${type(wp)}$ :: x(N), y(N), & + x_in(N), y_in(N), & + x_rf(N), y_rf(N) - ${TYPE}$ :: x(N), y(N), & - x_in(N), y_in(N), & - x_rf(N), y_rf(N) - -#:if TYPE == COMPLEX_TYPE - call random_number(rnd) - x%re = rnd - call random_number(rnd) - x%im = rnd - y%re = 0.0_wp - y%im = 0.0_wp -#:else - call random_number(X) - Y = 0.0_wp -#:endif + $:random_number(type(wp),'x','(N)') + $:random_number(type(wp),'y','(N)') x_in = x y_in = y ! The test is always against the original - call ${ORIGINAL}$(N, x_in, 1, y_in, 1) + call ${f77}$(N, x_in, 1, y_in, 1) x_rf = x_in y_rf = y_in x_in = x y_in = y - call ${IMPROVED}$(N, x_in, 1, y_in, 1) + call ${f90}$(N, x_in, 1, y_in, 1) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") x_in = x y_in = y - call mfi_${ORIGINAL}$(x_in, y_in) + call mfi_${f77}$(x_in, y_in) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") x_in = x y_in = y - call ${MODERN}$(x_in, y_in) + call ${mfi}$(x_in, y_in) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") end subroutine diff --git a/test/blas/dot_product.fypp b/test/blas/dot_product.fypp index 590e931c..6b68da81 100644 --- a/test/blas/dot_product.fypp +++ b/test/blas/dot_product.fypp @@ -1,34 +1,30 @@ #:mute -#:def dot_product(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def dot_product(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(wp)}$ integer, parameter :: N = 20 - ${TYPE}$ :: res, ref + ${type(wp)}$ :: res, ref - ${TYPE}$ :: x(N), y(N) + ${type(wp)}$ :: x(N), y(N) -#:if TYPE == COMPLEX_TYPE - @:random_complex(X,(N)) - @:random_complex(Y,(N)) -#:else - call random_number(X) - call random_number(Y) -#:endif + $:random_number(type(wp),'X','(N)') + $:random_number(type(wp),'Y','(N)') ! The test is always against the original - ref = ${ORIGINAL}$(N, x, 1, y, 1) + ref = ${f77}$(N, x, 1, y, 1) - res = ${IMPROVED}$(N, x, 1, y, 1) + res = ${f90}$(N, x, 1, y, 1) call assert(ref == res, "different results") - res = mfi_${ORIGINAL}$(x, y) + res = mfi_${f77}$(x, y) call assert(ref == res, "different results") - res = ${MODERN}$(x, y) + res = ${mfi}$(x, y) call assert(ref == res, "different results") end subroutine diff --git a/test/blas/gemm.fypp b/test/blas/gemm.fypp index 365303ed..32887343 100644 --- a/test/blas/gemm.fypp +++ b/test/blas/gemm.fypp @@ -1,32 +1,24 @@ -#:def gemm(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def gemm(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(wp)}$ integer, parameter :: N = 20 character, parameter :: options(*) = ['N','n','T','t','C','c'] - ${TYPE}$ :: A(N,N), B(N,N), C(N,N), & + ${type(wp)}$ :: A(N,N), B(N,N), C(N,N), & A_in(N,N), B_in(N,N), C_in(N,N),& A_rf(N,N), B_rf(N,N), C_rf(N,N) - ${TYPE}$ :: alpha, beta + ${type(wp)}$ :: alpha, beta character :: transa, transb integer :: i, j -#:if TYPE == COMPLEX_TYPE - @:random_complex(A,(N,N)) - @:random_complex(B,(N,N)) - @:random_complex(C,(N,N)) - @:random_complex(alpha) - @:random_complex(beta) -#:else - call random_number(A) - call random_number(B) - call random_number(C) - call random_number(alpha) - call random_number(beta) -#:endif - + $:random_number(type(wp),'A','(N,N)') + $:random_number(type(wp),'B','(N,N)') + $:random_number(type(wp),'C','(N,N)') + $:random_number(type(wp),'alpha') + $:random_number(type(wp),'beta') do i=1,size(options) do j=1,size(options) @@ -36,7 +28,7 @@ subroutine test_${ORIGINAL}$ A_in = A B_in = B C_in = C - call ${ORIGINAL}$(transa, transb, N, N, N, alpha, A_in, N, B_in, N, beta, C_in, N) + call ${f77}$(transa, transb, N, N, N, alpha, A_in, N, B_in, N, beta, C_in, N) A_rf = A_in B_rf = B_in C_rf = C_in @@ -44,7 +36,7 @@ subroutine test_${ORIGINAL}$ A_in = A B_in = B C_in = C - call ${IMPROVED}$(transa, transb, N, N, N, alpha, A_in, N, B_in, N, beta, C_in, N) + call ${f90}$(transa, transb, N, N, N, alpha, A_in, N, B_in, N, beta, C_in, N) call assert(all(A_in == A_rf) .and. & all(B_in == B_rf) .and. & all(C_in == C_rf), "different results") @@ -52,7 +44,7 @@ subroutine test_${ORIGINAL}$ A_in = A B_in = B C_in = C - call mfi_${ORIGINAL}$(A_in,B_in,C_in,alpha=alpha, beta=beta, transa=transa, transb=transb) + call mfi_${f77}$(A_in,B_in,C_in,alpha=alpha, beta=beta, transa=transa, transb=transb) call assert(all(A_in == A_rf) .and. & all(B_in == B_rf) .and. & all(C_in == C_rf), "different results") @@ -60,7 +52,7 @@ subroutine test_${ORIGINAL}$ A_in = A B_in = B C_in = C - call ${MODERN}$(A_in,B_in,C_in,alpha=alpha, beta=beta, transa=transa, transb=transb) + call ${mfi}$(A_in,B_in,C_in,alpha=alpha, beta=beta, transa=transa, transb=transb) call assert(all(A_in == A_rf) .and. & all(B_in == B_rf) .and. & diff --git a/test/blas/gemv.fypp b/test/blas/gemv.fypp index 5f2bbbdf..1b04d73f 100644 --- a/test/blas/gemv.fypp +++ b/test/blas/gemv.fypp @@ -1,31 +1,24 @@ -#:def gemv(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def gemv(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(wp)}$ integer, parameter :: N = 20 - ${TYPE}$ :: M(N,N), X(N), Y(N), & + ${type(wp)}$ :: M(N,N), X(N), Y(N), & M_in(N,N), X_in(N), Y_in(N),& M_rf(N,N), X_rf(N), Y_rf(N) - ${TYPE}$ :: alpha, beta + ${type(wp)}$ :: alpha, beta character, parameter :: options(*) = ['N','n','T','t','C','c'] character :: trans integer :: i -#:if TYPE == COMPLEX_TYPE - @:random_complex(M,(N,N)) - @:random_complex(X,(N)) - @:random_complex(Y,(N)) - @:random_complex(alpha) - @:random_complex(beta) -#:else - call random_number(M) - call random_number(X) - call random_number(Y) - call random_number(alpha) - call random_number(beta) -#:endif + $:random_number(type(wp),'M','(N,N)') + $:random_number(type(wp),'X','(N)') + $:random_number(type(wp),'Y','(N)') + $:random_number(type(wp),'alpha') + $:random_number(type(wp),'beta') do i=1,size(options) @@ -34,7 +27,7 @@ subroutine test_${ORIGINAL}$ M_in = M X_in = X Y_in = Y - call ${ORIGINAL}$(trans, N, N, alpha, M_in, N, X_in, 1, beta, Y_in, 1) + call ${f77}$(trans, N, N, alpha, M_in, N, X_in, 1, beta, Y_in, 1) M_rf = M_in X_rf = X_in Y_rf = Y_in @@ -42,7 +35,7 @@ subroutine test_${ORIGINAL}$ M_in = M X_in = X Y_in = Y - call ${IMPROVED}$(trans, N, N, alpha, M_in, N, X_in, 1, beta, Y_in, 1) + call ${f90}$(trans, N, N, alpha, M_in, N, X_in, 1, beta, Y_in, 1) call assert(all(M_in == M_rf) .and. & all(X_in == X_rf) .and. & all(Y_in == Y_rf), "different results") @@ -50,7 +43,7 @@ subroutine test_${ORIGINAL}$ M_in = M X_in = X Y_in = Y - call mfi_${ORIGINAL}$(M_in,X_in,Y_in,alpha=alpha, beta=beta, trans=trans) + call mfi_${f77}$(M_in,X_in,Y_in,alpha=alpha, beta=beta, trans=trans) call assert(all(M_in == M_rf) .and. & all(X_in == X_rf) .and. & all(Y_in == Y_rf), "different results") @@ -58,7 +51,7 @@ subroutine test_${ORIGINAL}$ M_in = M X_in = X Y_in = Y - call ${MODERN}$(M_in,X_in,Y_in,alpha=alpha, beta=beta, trans=trans) + call ${mfi}$(M_in,X_in,Y_in,alpha=alpha, beta=beta, trans=trans) call assert(all(M_in == M_rf) .and. & all(X_in == X_rf) .and. & diff --git a/test/blas/iamin_iamax.fypp b/test/blas/iamin_iamax.fypp index d1fd4feb..81bffc69 100644 --- a/test/blas/iamin_iamax.fypp +++ b/test/blas/iamin_iamax.fypp @@ -1,24 +1,25 @@ -#:def iamin_iamax(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def iamin_iamax(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(wp)}$ integer, parameter :: N = 20 - ${REAL_TYPE}$ :: rnd(N) - ${TYPE}$ :: array(N) + ${real(wp)}$ :: rnd(N) + ${type(wp)}$ :: array(N) integer :: res(4) integer :: i ! Test sequential array array = [(1.0_wp*i,i=1,N)] - res(1) = ${ORIGINAL}$(N, array, 1) - res(2) = mfi_${ORIGINAL}$(array) - res(3) = ${IMPROVED}$(N, array, 1) - res(4) = ${MODERN}$(array) + res(1) = ${f77}$(N, array, 1) + res(2) = mfi_${f77}$(array) + res(3) = ${f90}$(N, array, 1) + res(4) = ${mfi}$(array) call assert(all(res == res(1)), "different results for sequential array") -#:if TYPE == COMPLEX_TYPE +#:if type(wp) == complex(wp) call random_number(rnd) array%re = rnd call random_number(rnd) @@ -26,10 +27,10 @@ subroutine test_${ORIGINAL}$ #:else call random_number(array) #:endif - res(1) = ${ORIGINAL}$(N, array, 1) - res(2) = ${IMPROVED}$(N, array, 1) - res(3) = mfi_${ORIGINAL}$(array) - res(4) = ${MODERN}$(array) + res(1) = ${f77}$(N, array, 1) + res(2) = ${f90}$(N, array, 1) + res(3) = mfi_${f77}$(array) + res(4) = ${mfi}$(array) call assert(all(res == res(1)), "different results for random array") end subroutine diff --git a/test/blas/lamch.fypp b/test/blas/lamch.fypp index b8aa62c2..258e2323 100644 --- a/test/blas/lamch.fypp +++ b/test/blas/lamch.fypp @@ -1,10 +1,12 @@ #:mute -#:def lamch(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$ - use mfi_blas, only: ${MODERN}$ +#:def lamch(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$ + use mfi_blas, only: ${mfi}$ + + integer, parameter :: wp = ${kind(wp)}$ - integer, parameter :: wp = ${KIND}$ integer, parameter :: N = 20 character, parameter :: options(*) = ['E','e', & 'S','s', & @@ -16,12 +18,12 @@ subroutine test_${ORIGINAL}$ 'U','u', & 'L','l', & 'O','o'] - ${TYPE}$ :: a, b + ${type(wp)}$ :: a, b integer :: i do i=1,size(options) - a = ${ORIGINAL}$(options(i)) - b = ${MODERN}$(options(i),1.0_wp) + a = ${f77}$(options(i)) + b = ${mfi}$(options(i),1.0_wp) call assert(a == b, "different results for option "//options(i)) end do diff --git a/test/blas/rot.fypp b/test/blas/rot.fypp index 7158663f..7d5b49f3 100644 --- a/test/blas/rot.fypp +++ b/test/blas/rot.fypp @@ -1,81 +1,53 @@ #:mute -#:def rot_template(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX,mixed=False) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def rot(f77,f90,mfi,pfxs) +#:set A, B = get_types(pfxs) +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(A)}$ real(wp), parameter :: pi = 4.0_wp * atan(1.0_wp) complex(wp), parameter :: i = (0.0_wp,1.0_wp) integer, parameter :: N = 20 - ${REAL_TYPE}$ :: rnd(N) - ${TYPE}$ :: x(N), y(N), & - x_in(N), y_in(N), & - x_rf(N), y_rf(N) - ${REAL_TYPE}$ :: angle - ${REAL_TYPE}$ :: c -#:if not mixed - ${TYPE}$ :: s -#:else - ${REAL_TYPE}$ :: s -#:endif + ${type(A)}$ :: x(N), y(N), & + x_in(N), y_in(N), & + x_rf(N), y_rf(N) + real(wp) :: angle + ${real(A)}$ :: c + ${type(B)}$ :: s call random_number(angle) angle = angle * 2.0_wp * pi -#:if TYPE == COMPLEX_TYPE - call random_number(rnd) - x%re = rnd - call random_number(rnd) - x%im = rnd - call random_number(rnd) - y%re = rnd - call random_number(rnd) - y%im = rnd -#:else - call random_number(X) - call random_number(Y) -#:endif + $:random_number(type(A),'X','(N)') + $:random_number(type(A),'Y','(N)') c = cos(angle) - -#:if not mixed - s = i * sin(angle) -#:else s = sin(angle) -#:endif x_in = x y_in = y ! The test is always against the original - call ${ORIGINAL}$(N, x_in, 1, y_in, 1, c, s) + call ${f77}$(N, x_in, 1, y_in, 1, c, s) x_rf = x_in y_rf = y_in x_in = x y_in = y - call ${IMPROVED}$(N, x_in, 1, y_in, 1, c, s) + call ${f90}$(N, x_in, 1, y_in, 1, c, s) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") x_in = x y_in = y - call mfi_${ORIGINAL}$(x_in, y_in, c, s) + call mfi_${f77}$(x_in, y_in, c, s) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") x_in = x y_in = y - call ${MODERN}$(x_in, y_in, c, s) + call ${mfi}$(x_in, y_in, c, s) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") end subroutine #:enddef - -#:def rot(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -$:rot_template(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -#:enddef - -#:def rot_mixed(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -$:rot_template(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX, mixed=True) -#:enddef #:endmute diff --git a/test/blas/rotg.fypp b/test/blas/rotg.fypp index 75e0b775..df9ccce3 100644 --- a/test/blas/rotg.fypp +++ b/test/blas/rotg.fypp @@ -1,38 +1,32 @@ -#:def rotg(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$ - use mfi_blas, only: ${MODERN}$ +#:def rotg(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$ + use mfi_blas, only: ${mfi}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(wp)}$ integer, parameter :: N = 200 - ${TYPE}$ :: a, b, s - ${REAL_TYPE}$ :: c + ${type(wp)}$ :: a, b, s + ${real(wp)}$ :: c - ${TYPE}$ :: a_in, b_in, s_in - ${REAL_TYPE}$ :: c_in + ${type(wp)}$ :: a_in, b_in, s_in + ${real(wp)}$ :: c_in - ${TYPE}$ :: a_rf, b_rf, s_rf - ${REAL_TYPE}$ :: c_rf + ${type(wp)}$ :: a_rf, b_rf, s_rf + ${real(wp)}$ :: c_rf integer :: i -#:if TYPE == COMPLEX_TYPE - @:random_complex(a) - @:random_complex(b) - call random_number(c) - @:random_complex(s) -#:else - call random_number(a) - call random_number(b) - call random_number(c) - call random_number(s) -#:endif + $:random_number(type(wp),'a') + $:random_number(type(wp),'b') + $:random_number(real(wp),'c') + $:random_number(type(wp),'s') do i=1,N a_in = a b_in = b c_in = c s_in = s - call ${ORIGINAL}$(a_in, b_in, c_in, s_in) + call ${f77}$(a_in, b_in, c_in, s_in) a_rf = a_in b_rf = b_in c_rf = c_in @@ -42,7 +36,7 @@ subroutine test_${ORIGINAL}$ b_in = b c_in = c s_in = s - call ${MODERN}$(a_in, b_in, c_in, s_in) + call ${mfi}$(a_in, b_in, c_in, s_in) call assert(a_in == a_rf .and. & b_in == b_rf .and. & diff --git a/test/blas/scal.fypp b/test/blas/scal.fypp index bd5e6ee9..0efa6384 100644 --- a/test/blas/scal.fypp +++ b/test/blas/scal.fypp @@ -1,67 +1,40 @@ #:mute -#:def scal_template(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX,mixed=False) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def scal(f77,f90,mfi,pfxs) +#:set A, B = get_types(pfxs) +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(A)}$ real(wp), parameter :: pi = 4.0_wp * atan(1.0_wp) complex(wp), parameter :: i = (0.0_wp,1.0_wp) integer, parameter :: N = 20 - ${REAL_TYPE}$ :: rnd_vector(N), rnd - ${TYPE}$ :: x(N), & - x_in(N), & - x_rf(N) -#:if not mixed - ${TYPE}$ :: alpha -#:else - ${REAL_TYPE}$ :: alpha -#:endif + ${type(A)}$ :: x(N), & + x_in(N), & + x_rf(N) + ${type(B)}$ :: alpha -#:if TYPE == COMPLEX_TYPE - call random_number(rnd_vector) - x%re = rnd_vector - call random_number(rnd_vector) - x%im = rnd_vector -#:if not mixed - call random_number(rnd) - alpha%re = rnd - call random_number(rnd) - alpha%im = rnd -#:else - call random_number(alpha) -#:endif -#:else - call random_number(X) - call random_number(alpha) -#:endif + $:random_number(type(A),'X','(N)') + $:random_number(type(B),'alpha') ! The test is always against the original x_in = x - call ${ORIGINAL}$(N, alpha, x_in, 1) + call ${f77}$(N, alpha, x_in, 1) x_rf = x_in x_in = x - call ${IMPROVED}$(N, alpha, x_in, 1) + call ${f90}$(N, alpha, x_in, 1) call assert(all(x_in == x_rf), "different results") x_in = x - call mfi_${ORIGINAL}$(x_in, alpha) + call mfi_${f77}$(alpha, x_in) call assert(all(x_in == x_rf), "different results") x_in = x - call ${MODERN}$(x_in, alpha) + call ${mfi}$(alpha, x_in) call assert(all(x_in == x_rf), "different results") end subroutine #:enddef - -#:def scal(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -$:scal_template(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -#:enddef - -#:def scal_mixed(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -$:scal_template(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX, mixed=True) -#:enddef #:endmute diff --git a/test/blas/swap.fypp b/test/blas/swap.fypp index 7b29469a..8977c561 100644 --- a/test/blas/swap.fypp +++ b/test/blas/swap.fypp @@ -1,19 +1,20 @@ #:mute -#:def swap(ORIGINAL,IMPROVED,MODERN,TYPE,KIND,PREFIX) -subroutine test_${ORIGINAL}$ - use f77_blas, only: ${ORIGINAL}$, ${IMPROVED}$ - use mfi_blas, only: ${MODERN}$, mfi_${ORIGINAL}$ +#:def swap(f77,f90,mfi,pfxs) +#:set wp = pfxs[0] +subroutine test_${f77}$ + use f77_blas, only: ${f77}$, ${f90}$ + use mfi_blas, only: ${mfi}$, mfi_${f77}$ - integer, parameter :: wp = ${KIND}$ + integer, parameter :: wp = ${kind(wp)}$ integer, parameter :: N = 20 - ${REAL_TYPE}$ :: rnd(N) + ${real(wp)}$ :: rnd(N) - ${TYPE}$ :: x(N), y(N), & + ${type(wp)}$ :: x(N), y(N), & x_in(N), y_in(N), & x_rf(N), y_rf(N) -#:if TYPE == COMPLEX_TYPE +#:if type(wp) == complex(wp) call random_number(rnd) x%re = rnd call random_number(rnd) @@ -30,23 +31,23 @@ subroutine test_${ORIGINAL}$ x_in = x y_in = y ! The test is always against the original - call ${ORIGINAL}$(N, x_in, 1, y_in, 1) + call ${f77}$(N, x_in, 1, y_in, 1) x_rf = x_in y_rf = y_in x_in = x y_in = y - call ${IMPROVED}$(N, x_in, 1, y_in, 1) + call ${f90}$(N, x_in, 1, y_in, 1) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") x_in = x y_in = y - call mfi_${ORIGINAL}$(x_in, y_in) + call mfi_${f77}$(x_in, y_in) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") x_in = x y_in = y - call ${MODERN}$(x_in, y_in) + call ${mfi}$(x_in, y_in) call assert(all(x_in == x_rf) .and. all(y_in == y_rf), "different results") end subroutine