same as octreesolve_shrink_xyz, for different type

octreelsf_shrink_xyz.f90

+subroutine octreelsf_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 (octreelsf) 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', 'octreelsf_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', 'octreelsf_shrink_xyz...', size(os%x), 'dp', -1)
+deallocate(os%x)
+allocate  (os%x(new_size),stat=threadinfo%err)               
+call heap (threadinfo, 'os%x', 'octreelsf_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', 'octreelsf_shrink_xyz...', size(os%y), 'dp', -1)
+deallocate(os%y)
+allocate  (os%y(new_size),stat=threadinfo%err)               
+call heap (threadinfo, 'os%y', 'octreelsf_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', 'octreelsf_shrink_xyz...', size(os%z), 'dp', -1)
+deallocate(os%z)
+allocate  (os%z(new_size),stat=threadinfo%err)               
+call heap (threadinfo, 'os%z', 'octreelsf_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', 'octreelsf_shrink_xyz...', size(t), 'dp', -1)
+deallocate(t)
+
+return
+end

octreev_shrink_xyz.f90

+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