Skip to content

Commit 5f6b5e8

Browse files
perazzperazz
committed
ND arrays: use LAPACK internals via loops
1 parent 0e798ff commit 5f6b5e8

File tree

4 files changed

+167
-28
lines changed

4 files changed

+167
-28
lines changed

‎include/common.fypp

Lines changed: 101 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -298,4 +298,105 @@ ${prefix + joinstr.join([line.strip() for line in txt.split("\n")]) + suffix}$
298298
#:endif
299299
#:enddef
300300

301+
#!
302+
#! Generates a list of loop variables
303+
#!
304+
#! Args:
305+
#! varname(str): Name of the variable to be used as prefix
306+
#! n (int): Number of loop variables to be created
307+
#! offset (int): Optional index offset
308+
#!
309+
#! Returns:
310+
#! Variable definition string
311+
#!
312+
#! E.g.,
313+
#! loop_variables('j', 5)
314+
#! -> "j1, j2, j3, j4, j5
315+
#!
316+
#:def loop_variables(varname, n, offset=0)
317+
#:assert n > 0
318+
#:call join_lines(joinstr=", ")
319+
#:for i in range(1, n + 1)
320+
${varname}$${i+offset}$
321+
#:endfor
322+
#:endcall
323+
#:enddef
324+
325+
#! Generates an array shape specifier from an N-D array size
326+
#!
327+
#! Args:
328+
#! name (str): Name of the original variable
329+
#! rank (int): Rank of the original variable
330+
#! offset(int): optional offset of the dimension loop (default = 0)
331+
#!
332+
#! Returns:
333+
#! Array rank suffix string enclosed in braces
334+
#!
335+
#! E.g.,
336+
#! shape_from_array_size('mat', 5)}$
337+
#! -> (size(mat,1),size(mat,2),size(mat,3),size(mat,4),size(mat,5))
338+
#! shape_from_array_size('mat', 5, 2)}$
339+
#! -> (size(mat,3),size(mat,4),size(mat,5),size(mat,6),size(mat,7))
340+
#!
341+
#:def shape_from_array_size(name, rank, offset=0)
342+
#:assert rank > 0
343+
#:call join_lines(joinstr=", ", prefix="(", suffix=")")
344+
#:for i in range(1, rank + 1)
345+
size(${name}$,${i+offset}$)
346+
#:endfor
347+
#:endcall
348+
#:enddef
349+
350+
#! Generates an array shape specifier from an N-D array of sizes
351+
#!
352+
#! Args:
353+
#! name (str): Name of the original variable
354+
#! rank (int): Rank of the original variable
355+
#! offset(int): optional offset of the dimension loop (default = 0)
356+
#!
357+
#! Returns:
358+
#! Array rank suffix string enclosed in braces
359+
#!
360+
#! E.g.,
361+
#! shape_from_array_data('mat', 5)}$
362+
#! -> (1:mat(1),1:mat(2),1:mat(3),1:mat(4),1:mat(5))
363+
#! shape_from_array_data('mat', 5, 2)}$
364+
#! -> (1:mat(3),1:mat(4),1:mat(5),1:mat(6),1:mat(7))
365+
#!
366+
#:def shape_from_array_data(name, rank, offset=0)
367+
#:assert rank > 0
368+
#:call join_lines(joinstr=", ", prefix="(", suffix=")")
369+
#:for i in range(1, rank + 1)
370+
1:${name}$(${i+offset}$)
371+
#:endfor
372+
#:endcall
373+
#:enddef
374+
375+
#!
376+
#! Start a sequence of loop with indexed variables over an N-D array
377+
#!
378+
#! Args:
379+
#! varname (str): Name of the variable to be used as prefix
380+
#! matname (str): Name of the variable to be used as array
381+
#! n (int): Number of nested loops to be created (1=innermost; n=outermost)
382+
#! dim_offset (int): Optional dimension offset (1st loop is over dimension 1+dim_offset)
383+
#! intent (str): Optional indentation. Default: 8 spaces
384+
#!
385+
#!
386+
#:def loop_variables_start(varname, matname, n, dim_offset=0, indent=" "*8)
387+
#:assert n > 0
388+
#:for i in range(1, n + 1)
389+
${indent}$do ${varname}$${n+1+dim_offset-i}$ = lbound(${matname}$, ${n+1+dim_offset-i}$), ubound(${matname}$, ${n+1+dim_offset-i}$)
390+
#:endfor
391+
#:enddef
392+
393+
#:def loop_variables_end(n, indent=" "*8)
394+
#:assert n > 0
395+
#:call join_lines(joinstr="; ",prefix=indent)
396+
#:for i in range(1, n + 1)
397+
enddo
398+
#:endfor
399+
#:endcall
400+
#:enddef
401+
301402
#:endmute

‎src/stdlib_linalg.fypp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1234,7 +1234,7 @@ module stdlib_linalg
12341234
#:for rank in range(2, MAXRANK + 1)
12351235
pure module subroutine norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$(a, nrm, order, dim, err)
12361236
!> Input matrix a[..]
1237-
${rt}$, intent(in), target :: a${ranksuffix(rank)}$
1237+
${rt}$, intent(in) :: a${ranksuffix(rank)}$
12381238
!> Dimension the norm is computed along
12391239
integer(ilp), intent(in) :: dim
12401240
!> Norm of the matrix. (Same shape as `a`, with `dim` dropped).

‎src/stdlib_linalg_norms.fypp

Lines changed: 62 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -264,7 +264,7 @@ submodule(stdlib_linalg) stdlib_linalg_norms
264264
! Internal implementation
265265
pure module subroutine norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$(a, nrm, order, dim, err)
266266
!> Input matrix a[..]
267-
${rt}$, intent(in), target :: a${ranksuffix(rank)}$
267+
${rt}$, intent(in) :: a${ranksuffix(rank)}$
268268
!> Dimension to collapse by computing the norm w.r.t other dimensions
269269
! (dim must be defined before it is used for `nrm`)
270270
integer(ilp), intent(in) :: dim
@@ -276,11 +276,17 @@ submodule(stdlib_linalg) stdlib_linalg_norms
276276
type(linalg_state_type), intent(out), optional :: err
277277

278278
type(linalg_state_type) :: err_
279-
integer(ilp) :: sze,norm_request
279+
integer(ilp) :: sze,lda,norm_request,${loop_variables('j',rank-1,1)}$
280+
logical :: contiguous_data
280281
real(${rk}$) :: rorder
282+
integer(ilp), dimension(${rank}$) :: spe,spack,perm,iperm
283+
integer(ilp), dimension(${rank}$), parameter :: dim_range = [(lda,lda=1_ilp,${rank}$_ilp)]
284+
${rt}$, allocatable :: apack${ranksuffix(rank)}$
281285
intrinsic :: abs, sum, sqrt, norm2, maxval, minval, conjg
282286

283-
sze = size(a,kind=ilp)
287+
! Input matrix properties
288+
sze = size (a,kind=ilp)
289+
spe = shape(a,kind=ilp)
284290

285291
! Initialize norm to zero
286292
nrm = 0.0_${rk}$
@@ -304,28 +310,60 @@ submodule(stdlib_linalg) stdlib_linalg_norms
304310
if (err_%error()) then
305311
call linalg_error_handling(err_,err)
306312
return
307-
endif
313+
endif
308314

309-
select case(norm_request)
310-
case(NORM_ONE)
311-
nrm = sum( abs(a) , dim = dim )
312-
case(NORM_TWO)
313-
#:if rt.startswith('complex')
314-
nrm = sqrt( real( sum( a * conjg(a) , dim = dim ), ${rk}$) )
315-
#:else
316-
nrm = norm2( a , dim = dim )
317-
#:endif
318-
case(NORM_INF)
319-
nrm = maxval( abs(a) , dim = dim )
320-
case(NORM_MINUSINF)
321-
nrm = minval( abs(a) , dim = dim )
322-
case (NORM_POW_FIRST:NORM_POW_LAST)
323-
rorder = 1.0_${rk}$ / norm_request
324-
nrm = sum( abs(a) ** norm_request , dim = dim ) ** rorder
325-
case default
326-
err_ = linalg_state_type(this,LINALG_INTERNAL_ERROR,'invalid norm type after checking')
327-
call linalg_error_handling(err_,err)
328-
end select
315+
! The norm's leading dimension
316+
lda = spe(dim)
317+
318+
! Check if input column data is contiguous
319+
contiguous_data = dim==1 .or. all(norm_request/=[NORM_ONE,NORM_TWO])
320+
321+
! Get packed data with the norm dimension as the first dimension
322+
if (.not.contiguous_data) then
323+
324+
! Permute array to map dim to 1
325+
perm = [dim,pack(dim_range,dim_range/=dim)]
326+
iperm(perm) = dim_range
327+
spack = spe(perm)
328+
apack = reshape(a, shape=spack, order=iperm)
329+
330+
${loop_variables_start('j', 'apack', rank-1, 1," "*12)}$
331+
select case(norm_request)
332+
case(NORM_ONE)
333+
nrm(${loop_variables('j',rank-1,1)}$) = &
334+
asum(lda,apack(:, ${loop_variables('j',rank-1,1)}$),incx=1_ilp)
335+
case(NORM_TWO)
336+
nrm(${loop_variables('j',rank-1,1)}$) = &
337+
nrm2(lda,apack(:, ${loop_variables('j',rank-1,1)}$),incx=1_ilp)
338+
end select
339+
${loop_variables_end(rank-1," "*12)}$
340+
341+
else
342+
343+
select case(norm_request)
344+
case(NORM_ONE)
345+
${loop_variables_start('j', 'a', rank-1, 1," "*20)}$
346+
nrm(${loop_variables('j',rank-1,1)}$) = &
347+
asum(lda,a(:, ${loop_variables('j',rank-1,1)}$),incx=1_ilp)
348+
${loop_variables_end(rank-1," "*20)}$
349+
case(NORM_TWO)
350+
${loop_variables_start('j', 'a', rank-1, 1," "*20)}$
351+
nrm(${loop_variables('j',rank-1,1)}$) = &
352+
nrm2(lda,a(:, ${loop_variables('j',rank-1,1)}$),incx=1_ilp)
353+
${loop_variables_end(rank-1," "*20)}$
354+
case(NORM_INF)
355+
nrm = maxval( abs(a) , dim = dim )
356+
case(NORM_MINUSINF)
357+
nrm = minval( abs(a) , dim = dim )
358+
case (NORM_POW_FIRST:NORM_POW_LAST)
359+
rorder = 1.0_${rk}$ / norm_request
360+
nrm = sum( abs(a) ** norm_request , dim = dim ) ** rorder
361+
case default
362+
err_ = linalg_state_type(this,LINALG_INTERNAL_ERROR,'invalid norm type after checking')
363+
call linalg_error_handling(err_,err)
364+
end select
365+
366+
endif
329367

330368
end subroutine norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$
331369

‎test/linalg/test_linalg_norm.fypp

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -159,17 +159,17 @@ module test_linalg_norm
159159

160160
! Test some norms
161161
call check(error,abs(norm(a,2) - norm2(a))<tol*norm(a,2),&
162-
'Euclidean norm does not match `norm2` intrinsic')
162+
'Euclidean norm does not match ${rt}$ `norm2` intrinsic')
163163
if (allocated(error)) return
164164

165165
! Infinity norms
166166
call check(error,abs(norm(b,2)-norm2(b))<tol*norm(b,2),&
167-
'Dimmed Euclidean norm does not match `norm2` intrinsic')
167+
'Dimmed Euclidean norm does not match ${rt}$ `norm2` intrinsic')
168168
if (allocated(error)) return
169169

170170
! Test norm as collapsed around dimension
171171
do dim = 1, ndim
172-
write(msg,"('Not all dim=',i0,' Euclidean norms match `norm2` intrinsic')") dim
172+
write(msg,"('Not all dim=',i0,' Euclidean norms match ${rt}$ `norm2` intrinsic')") dim
173173
call check(error,all(abs(norm(b,2,dim)-norm2(b,dim))<tol*max(1.0_${rk}$,norm(b,2,dim))),&
174174
trim(msg))
175175
if (allocated(error)) return

0 commit comments

Comments
 (0)