subroutine octreev_shrink_xyz(os, threadinfo) ! resize the x,y,z arrays. ! Author: Douglas Guptill ! Copyright (c) 2009 Douglas Guptill. All rights reserved. ! 2009-07-27: new, from a copy of octreesolve_shring_xyz, ! and identical to it, ! except for the type of the first parameter. ! I wish I knew a better way.! use threads use definitions implicit none ! parameters, in type (thread) threadinfo ! parameters, in/out type (octreev) os ! local variables integer i, new_size double precision, dimension(:),pointer::t new_size = os%nnode ! make a temporary array allocate (t(new_size),stat=threadinfo%err) call heap (threadinfo, 't', 'octreev_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', 'octreev_shrink_xyz...', size(os%x), 'dp', -1) deallocate(os%x) allocate (os%x(new_size),stat=threadinfo%err) call heap (threadinfo, 'os%x', 'octreev_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', 'octreev_shrink_xyz...', size(os%y), 'dp', -1) deallocate(os%y) allocate (os%y(new_size),stat=threadinfo%err) call heap (threadinfo, 'os%y', 'octreev_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', 'octreev_shrink_xyz...', size(os%z), 'dp', -1) deallocate(os%z) allocate (os%z(new_size),stat=threadinfo%err) call heap (threadinfo, 'os%z', 'octreev_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', 'octreev_shrink_xyz...', size(t), 'dp', -1) deallocate(t) return end