Skip to content

Commit cb9a7fc

Browse files
perazzperazz
committed
generalize interface (rank-agnostic)
1 parent 3762517 commit cb9a7fc

File tree

2 files changed

+57
-34
lines changed

2 files changed

+57
-34
lines changed

‎src/stdlib_linalg_state.fypp

Lines changed: 56 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -271,22 +271,21 @@ module stdlib_linalg_state
271271

272272
!> Error creation message, with location location
273273
pure type(linalg_state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
274-
v1,v2,v3,v4,v5)
274+
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
275275

276276
!> Location
277277
character(len=*),intent(in) :: where_at
278278

279279
!> Input error flag
280280
integer,intent(in) :: flag
281281

282-
!> Optional scalar arguments
283-
class(*),optional,intent(in) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
284-
285-
!> Optional vector arguments
286-
class(*),optional,intent(in),dimension(:) :: v1,v2,v3,v4,v5
282+
!> Optional rank-agnostic arguments
283+
class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
284+
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
287285

288286
!> Create state with no message
289-
new_state = new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,v1,v2,v3,v4,v5)
287+
new_state = new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
288+
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
290289

291290
!> Add location
292291
if (len_trim(where_at) > 0) new_state%where_at = adjustl(where_at)
@@ -295,16 +294,15 @@ module stdlib_linalg_state
295294

296295
!> Error creation message, from N input variables (numeric or strings)
297296
pure type(linalg_state_type) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
298-
v1,v2,v3,v4,v5) result(new_state)
297+
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) &
298+
result(new_state)
299299

300300
!> Input error flag
301301
integer,intent(in) :: flag
302302

303-
!> Optional scalar arguments
304-
class(*),optional,intent(in) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
305-
306-
!> Optional vector arguments
307-
class(*),optional,intent(in),dimension(:) :: v1,v2,v3,v4,v5
303+
!> Optional rank-agnostic arguments
304+
class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
305+
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
308306

309307
! Init object
310308
call new_state%destroy()
@@ -314,36 +312,62 @@ module stdlib_linalg_state
314312

315313
!> Set chain
316314
new_state%message = ""
317-
call append(new_state%message,a1)
318-
call append(new_state%message,a2)
319-
call append(new_state%message,a3)
320-
call append(new_state%message,a4)
321-
call append(new_state%message,a5)
322-
call append(new_state%message,a6)
323-
call append(new_state%message,a7)
324-
call append(new_state%message,a8)
325-
call append(new_state%message,a9)
326-
call append(new_state%message,a10)
327-
call appendv(new_state%message,v1)
328-
call appendv(new_state%message,v2)
329-
call appendv(new_state%message,v3)
330-
call appendv(new_state%message,v4)
331-
call appendv(new_state%message,v5)
315+
call appendr(new_state%message,a1)
316+
call appendr(new_state%message,a2)
317+
call appendr(new_state%message,a3)
318+
call appendr(new_state%message,a4)
319+
call appendr(new_state%message,a5)
320+
call appendr(new_state%message,a6)
321+
call appendr(new_state%message,a7)
322+
call appendr(new_state%message,a8)
323+
call appendr(new_state%message,a9)
324+
call appendr(new_state%message,a10)
325+
call appendr(new_state%message,a11)
326+
call appendr(new_state%message,a12)
327+
call appendr(new_state%message,a13)
328+
call appendr(new_state%message,a14)
329+
call appendr(new_state%message,a15)
330+
call appendr(new_state%message,a16)
331+
call appendr(new_state%message,a17)
332+
call appendr(new_state%message,a18)
333+
call appendr(new_state%message,a19)
334+
call appendr(new_state%message,a20)
332335

333336
end function new_state_nowhere
334337

338+
! Append a generic value to the error flag (rank-agnostic)
339+
pure subroutine appendr(msg,a,prefix)
340+
class(*),optional,intent(in) :: a(..)
341+
character(len=*),intent(inout) :: msg
342+
character,optional,intent(in) :: prefix
343+
344+
character(len=MSG_LENGTH) :: buffer
345+
346+
if (present(a)) then
347+
select rank (v=>a)
348+
rank (0)
349+
call append (msg,v,prefix)
350+
rank (1)
351+
call appendv(msg,v)
352+
rank default
353+
write (buffer,'(i0)') rank(v)
354+
msg = trim(msg)//' <ERROR: INVALID RANK>'
355+
356+
end select
357+
endif
358+
359+
end subroutine appendr
360+
335361
! Append a generic value to the error flag
336362
pure subroutine append(msg,a,prefix)
337-
class(*),optional,intent(in) :: a
363+
class(*),intent(in) :: a
338364
character(len=*),intent(inout) :: msg
339365
character,optional,intent(in) :: prefix
340366

341367
character(len=MSG_LENGTH) :: buffer,buffer2
342368
character(len=2) :: sep
343369
integer :: ls
344370

345-
if (.not. present(a)) return
346-
347371
! Do not add separator if this is the first instance
348372
sep = ' '
349373
ls = merge(1,0,len_trim(msg) > 0)
@@ -385,14 +409,13 @@ module stdlib_linalg_state
385409

386410
! Append a generic vector to the error flag
387411
pure subroutine appendv(msg,a)
388-
class(*),optional,intent(in) :: a(:)
412+
class(*),intent(in) :: a(:)
389413
character(len=*),intent(inout) :: msg
390414

391415
integer :: j,ls
392416
character(len=MSG_LENGTH) :: buffer,buffer2,buffer_format
393417
character(len=2) :: sep
394418

395-
if (.not. present(a)) return
396419
if (size(a) <= 0) return
397420

398421
! Default: separate elements with one space

‎test/linalg/test_linalg.fypp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -959,7 +959,7 @@ contains
959959

960960
#:endif
961961

962-
state = linalg_state_type(LINALG_SUCCESS,' 32-bit array: ',v1=[(1.0_sp,0.0_sp),(0.0_sp,1.0_sp)])
962+
state = linalg_state_type(LINALG_SUCCESS,' 32-bit array: ',[(1.0_sp,0.0_sp),(0.0_sp,1.0_sp)])
963963
call check(error, state%message== &
964964
' 32-bit array: [(1.00000000E+00,0.00000000E+00) (0.00000000E+00,1.00000000E+00)]', &
965965
"malformed state message with 32-bit real array.")

0 commit comments

Comments
 (0)