replacement for shrink_dp_pointer_array

octreesolve_shrink_xyz.f90

+subroutine octreesolve_shrink_xyz(threadinfo, os, new_size)
+
+! resize the x,y,z arrays.
+! Author: Douglas Guptill
+! Copyright (c) 2009 Douglas Guptill. All rights reserved.
+! 2009-07-14: new
+
+use threads
+use definitions
+
+implicit none
+
+! parameters, in
+integer new_size
+type (thread) threadinfo
+
+! parameters, in/out
+type (octreesolve) os
+
+! local variables
+integer i
+double precision, dimension(:),pointer::t
+
+! make a temporary array
+allocate  (t(new_size),stat=threadinfo%err)
+call heap (threadinfo, 't', 'octreesolve_shrink_xyz...', size(t), 'dp', +1)
+
+! shrink x...............................................
+
+! transfer the x data to it
+do i = 1, new_size
+  t(i) = os%x(i)
+enddo
+
+! delete and re-create the x array
+call heap (threadinfo, 'os%x', 'octreesolve_shrink_xyz...', size(os%x), 'dp', -1)
+deallocate(os%x)
+allocate  (os%x(new_size),stat=threadinfo%err)               
+call heap (threadinfo, 'os%x', 'octreesolve_shrink_xyz...', size(os%x), 'dp', +1)
+
+! transfer the data from the temporary array to the new x aray
+do i = 1, new_size
+  os%x(i) = t(i)
+enddo
+
+! shrink y...............................................
+
+! transfer the y data to it
+do i = 1, new_size
+  t(i) = os%y(i)
+enddo
+
+! delete and re-create the y array
+call heap (threadinfo, 'os%y', 'octreesolve_shrink_xyz...', size(os%y), 'dp', -1)
+deallocate(os%y)
+allocate  (os%y(new_size),stat=threadinfo%err)               
+call heap (threadinfo, 'os%y', 'octreesolve_shrink_xyz...', size(os%y), 'dp', +1)
+
+! transfer the data from the temporary array to the new y aray
+do i = 1, new_size
+  os%y(i) = t(i)
+enddo
+
+! shrink z...............................................
+
+! transfer the z data to it
+do i = 1, new_size
+  t(i) = os%z(i)
+enddo
+
+! delete and re-create the z array
+call heap (threadinfo, 'os%z', 'octreesolve_shrink_xyz...', size(os%z), 'dp', -1)
+deallocate(os%z)
+allocate  (os%z(new_size),stat=threadinfo%err)               
+call heap (threadinfo, 'os%z', 'octreesolve_shrink_xyz...', size(os%z), 'dp', +1)
+
+! transfer the data from the temporary array to the new z aray
+do i = 1, new_size
+  os%z(i) = t(i)
+enddo
+
+! delete the temporary array
+call heap (threadinfo, 't', 'octreesolve_shrink_xyz...', size(t), 'dp', -1)
+deallocate(t)
+
+return
+end