Device memory

• An array with custom bounds and an initial value
• Arrays of other kinds
• Resize a device array
• Allocate and copy a host array, keeping its bounds
• Copy back transposed
• Count the live device allocations

An array with custom bounds and an initial value

Allocate a rank-3 device array with lower bounds other than 1, set on the device.

call dev_alloc(fptr_dev=q_dev, lbounds=[-1,0,1], ubounds=[1,2,3], ierr=ierr, init_value=-1._R8P, label='q')
if (ierr /= 0) error stop 'device allocation failed'
call dev_memcpy_from_device(dst=q, src=q_dev)
print '(A,3(I0,A,I0,1X))', 'bounds: ', lbound(q_dev, 1), ':', ubound(q_dev, 1), lbound(q_dev, 2), ':', &
                           ubound(q_dev, 2), lbound(q_dev, 3), ':', ubound(q_dev, 3)
print '(A,L1)', 'every element set on the device to -1: ', all(q == -1._R8P)
call dev_free(q_dev)

$ memory bounds
bounds: -1:1 0:2 1:3
every element set on the device to -1: T

Arrays of other kinds

dev_alloc and the other generic procedures accept real(real64), real(real32), integer(int64), integer(int32), integer(int16), integer(int8), ranks 1 to 7.

call dev_alloc(fptr_dev=mask_dev, ubounds=[100], ierr=ierr, init_value=0_I1P, label='mask')
if (ierr /= 0) error stop 'device allocation failed'
call dev_alloc(fptr_dev=phi_dev, ubounds=[10,10], ierr=ierr, init_value=0._R4P, label='phi')
if (ierr /= 0) error stop 'device allocation failed'
call dev_get_alloc_stats(bytes=bytes)
print '(A,I0,A)', 'device memory in use: ', bytes, ' bytes (100 x 1 + 100 x 4)'
call dev_free(mask_dev)
call dev_free(phi_dev)

$ memory kinds
device memory in use: 500 bytes (100 x 1 + 100 x 4)

Resize a device array

Reallocate with another size, freeing the previous buffer.

do n=10, 40, 10 ! the previous buffer is freed at each call: no leak
   call dev_alloc_replace(fptr_dev=u_dev, ubounds=[n], ierr=ierr, init_value=real(n, R8P), label='u')
   if (ierr /= 0) error stop 'device allocation failed'
enddo
call dev_get_alloc_stats(allocs=allocs)
call dev_memcpy_from_device(dst=u, src=u_dev(1:4))
print '(A,I0,A,I0)', 'size: ', size(u_dev), ', live device allocations: ', allocs
print '(A,*(F5.1))', 'first values (set by init_value, not preserved from the previous buffer):', u
call dev_free(u_dev)

$ memory replace
size: 40, live device allocations: 1
first values (set by init_value, not preserved from the previous buffer): 40.0 40.0 40.0 40.0

WARNING

The contents are not preserved. The pointer must have a defined association status (=>null(), nullified or allocated): a pointer declared without =>null() and never assigned is undefined, and dev_alloc_replace cannot test it. dev_alloc on an associated pointer leaks its buffer.

Allocate and copy a host array, keeping its bounds

dev_assign_to_device allocates the device array and copies; with the lower bounds passed first, the bounds of the source are kept. dev_assign_from_device is the converse.

call dev_assign_to_device(lbounds=lbound(f), dst=f_dev, src=f, ierr=ierr) ! allocate f_dev(0:3,-2:2), copy f
if (ierr /= 0) error stop 'device allocation failed'
call dev_assign_from_device(lbounds=lbound(f_dev), dst=g, src=f_dev)       ! allocate g(0:3,-2:2), copy f_dev
print '(A,2(I0,A,I0,1X))', 'device bounds: ', lbound(f_dev, 1), ':', ubound(f_dev, 1), lbound(f_dev, 2), ':', &
                           ubound(f_dev, 2)
print '(A,2(I0,A,I0,1X))', 'host bounds:   ', lbound(g, 1), ':', ubound(g, 1), lbound(g, 2), ':', ubound(g, 2)
print '(A,L1)', 'same values: ', all(g == f)
call dev_free(f_dev)

$ memory assign
device bounds: 0:3 -2:2
host bounds:   0:3 -2:2
same values: T

WARNING

Without lbounds, both routines allocate the destination with lower bounds 1. Both always reallocate the destination.

Copy back transposed

Get a device array on the host with two indexes swapped: dev_memcpy_from_device with the bounds of both arrays and a host buffer of the source shape (rank 2), or dev_assign_from_device with the pair of indexes to swap (ranks 2 to 7), which allocates the result.

bb(1,:) = [1, 1] ; bb(2,:) = [2, 3] ! a_dev(1:2,1:3)
tb(1,:) = [1, 1] ; tb(2,:) = [3, 2] ! at(1:3,1:2)
call dev_memcpy_from_device(bb=bb, tb=tb, dst=at, src=a_dev, buf=buf) ! at = transpose(a_dev), through buf
print '(A,L1)', 'at == transpose(a): ', all(at == transpose(a))
call dev_assign_from_device(dst=bt, src=b_dev, ij=[1,3])             ! bt(k,j,i) = b_dev(i,j,k), allocated
print '(A,3(I0,1X))', 'shape of bt: ', shape(bt)
print '(A,L1)', 'bt(k,j,i) == b(i,j,k): ', all([(((bt(k,j,i) == b(i,j,k), i=1, 2), j=1, 3), k=1, 4)])

$ memory transpose
at == transpose(a): T
shape of bt: 4 3 2
bt(k,j,i) == b(i,j,k): T

bb(1,:) are the lower bounds and bb(2,:) the upper bounds of the device array, tb those of the transposed host array. Ranks 3 to 7 of the copy routines also take ij, the two indexes to swap; see transposed copies.

Count the live device allocations

Check at teardown that nothing leaked, on every device or on one.

call dev_get_alloc_stats(allocs=allocs, bytes=bytes)              ! on every device
print '(A,I0,A,I0,A)', 'live: ', allocs, ' allocations, ', bytes, ' bytes'
call dev_get_alloc_stats(allocs=allocs, bytes=bytes, dev_id=mydev) ! on this device only
print '(A,I0,A,I0,A)', 'on this device: ', allocs, ' allocations, ', bytes, ' bytes'
call dev_free(x_dev)
call dev_free(y_dev)
call dev_get_alloc_stats(allocs=allocs)
if (allocs /= 0_I8P) error stop 'device memory leaked'
print '(A,I0)', 'after the frees: ', allocs

$ memory stats
live: 2 allocations, 12000 bytes
on this device: 2 allocations, 12000 bytes
after the frees: 0

Unstructured allocations (dev_alloc_unstr) are not counted.