> Remember that a reference to a pointer results in an automatic dereference of
its target. Thus, in
>
> pv = elemental_pointer_fun(6)
> arr(1) = pv
> deallocate (pv%vect) ! memory recovered
>
> one is deallocating the target of pv%vect, namely
"elemental_pointer_fun(6)%vect", (so to speak).
Okay. I understand. This means that using a defined assignment for the
pointer_vector type that does intrinsic assignment of pointer components instead
of pointer assignment is BAD in this case. After the function
elemental_pointer_fun has returned, "elemental_pointer_fun%vect" remains
allocated, and futhermore, there is nothing pointing to it, and hence no way of
deallocating it and recovering the memory.
All is not lost however, because I can still achieve what I wanted without using
defined assignment. In the main program I can have a separate pointer pointing
to the target vector. I can then do the intrinsic assignment of components and
deallocation afterwards. Using your example program...
program no_leaks
type p
integer, pointer, dimension(:) :: vect
end type p
type(p) pv1, pv2
integer, dimension(2), target :: target_vector
target_vector=0
! separate pointer pointing to target vector
pv1%vect => target_vector
pv2 = elemental_pointer_fun(5) ! memory leak
print *, pv2%vect
! intrinsic assignment
pv1%vect=pv2%vect
! recover memory
deallocate(pv2%vect)
nullify(pv1%vect)
print *,target_vector
contains
TYPE(p) ELEMENTAL FUNCTION &
& elemental_pointer_fun(index) RESULT(ans)
IMPLICIT NONE
INTEGER, INTENT(IN) :: index
ALLOCATE(ans%vect(2))
ans%vect=(/index,-index/)
END FUNCTION elemental_pointer_fun
end program no_leaks
I have ammended my original program so that it has no memory leaks. On compaq it
now compiles with no warnings or errors... but gives the wrong results if a
WHERE is used . (A worse situation than before). The Sun compiler gives the
correct results. I have attached the no-leaks version in case anyone wants to
have a play.
Thanks to everyone for all their help!
Paul
!==============================================================================
MODULE kind_mod
IMPLICIT NONE
PRIVATE
INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9)
INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4)
END MODULE kind_mod
!==============================================================================
MODULE pointer_mod
USE kind_mod, ONLY : I4
IMPLICIT NONE
PRIVATE
TYPE, PUBLIC :: pointer_vector_I4
INTEGER(I4), POINTER, DIMENSION(:) :: vect
END TYPE pointer_vector_I4
END MODULE pointer_mod
!==============================================================================
PROGRAM test_prog
USE pointer_mod, ONLY : pointer_vector_I4
USE kind_mod, ONLY : I4, TF
IMPLICIT NONE
INTEGER(I4), DIMENSION(12_I4), TARGET :: integer_array
LOGICAL(TF), DIMENSION(2_I4,3_I4) :: logical_array
TYPE(pointer_vector_I4), DIMENSION(6_I4) :: p_vect1
TYPE(pointer_vector_I4), DIMENSION(6_I4) :: p_vect2
INTEGER(I4) :: i
! Initialisation...
logical_array(:,1_I4:3_I4:2_I4)=.TRUE._TF
logical_array(:,2_I4)=.FALSE._TF
! **************************************************************************
! Version 1: DO-IF nonpointer version
! **************************************************************************
integer_array=0_I4
PRINT *,''
PRINT *,'DO-IF: nonpointer version'
DO i=1_I4,3_I4,1_I4
IF (logical_array(1_I4,i)) THEN
integer_array(4_I4*i-3_I4)=&
& elemental_nonpointer_fun(2_I4*i-1_I4)
integer_array(4_I4*i-2_I4)=&
& -elemental_nonpointer_fun(2_I4*i-1_I4)
ELSE
integer_array(4_I4*i-3_I4)=&
& elemental_nonpointer_fun(0_I4)
integer_array(4_I4*i-2_I4)=&
& -elemental_nonpointer_fun(0_I4)
END IF
IF (logical_array(2_I4,i)) THEN
integer_array(4_I4*i-1_I4)=&
& elemental_nonpointer_fun(2_I4*i)
integer_array(4_I4*i)=&
& -elemental_nonpointer_fun(2_I4*i)
ELSE
integer_array(4_I4*i-1_I4)=&
& elemental_nonpointer_fun(0_I4)
integer_array(4_I4*i)=&
& -elemental_nonpointer_fun(0_I4)
END IF
END DO
PRINT '(A,6L6)', 'logical_array: ',logical_array
PRINT '(A,12I3)', 'integer_array: ',integer_array
! **************************************************************************
! Version 2: DO-WHERE nonpointer version
! **************************************************************************
integer_array=0_I4
PRINT *,''
PRINT *,'DO-WHERE: nonpointer version'
DO i=1_I4,3_I4,1_I4
WHERE(logical_array((/1_I4,2_I4/),i))
integer_array((4_I4*i-3_I4):(4_I4*i-1_I4):2_I4)=&
& elemental_nonpointer_fun((/(2_I4*i-1_I4),(2_I4*i)/))
integer_array((4_I4*i-2_I4):(4_I4*i):2_I4)=&
& -elemental_nonpointer_fun((/(2_I4*i-1_I4),(2_I4*i)/))
ELSEWHERE
integer_array((4_I4*i-3_I4):(4_I4*i-1_I4):2_I4)=&
& elemental_nonpointer_fun((/0_I4,0_I4/))
integer_array((4_I4*i-2_I4):(4_I4*i):2_I4)=&
& -elemental_nonpointer_fun((/0_I4,0_I4/))
END WHERE
END DO
PRINT '(A,6L6)', 'logical_array: ',logical_array
PRINT '(A,12I3)', 'integer_array: ',integer_array
! **************************************************************************
! Version 3: FORALL-WHERE nonpointer_version
! **************************************************************************
integer_array=0_I4
PRINT *,''
PRINT *,'FORALL-WHERE: non_pointer version'
FORALL (i=1_I4:3_I4:1_I4)
WHERE(logical_array((/1_I4,2_I4/),i))
integer_array((4_I4*i-3_I4):(4_I4*i-1_I4):2_I4)=&
& elemental_nonpointer_fun((/(2_I4*i-1_I4),(2_I4*i)/))
integer_array((4_I4*i-2_I4):(4_I4*i):2_I4)=&
& -elemental_nonpointer_fun((/(2_I4*i-1_I4),(2_I4*i)/))
ELSEWHERE
integer_array((4_I4*i-3_I4):(4_I4*i-1_I4):2_I4)=&
& elemental_nonpointer_fun((/0_I4,0_I4/))
integer_array((4_I4*i-2_I4):(4_I4*i):2_I4)=&
& -elemental_nonpointer_fun((/0_I4,0_I4/))
END WHERE
END FORALL
PRINT '(A,6L6)', 'logical_array: ',logical_array
PRINT '(A,12I3)', 'integer_array: ',integer_array
! **************************************************************************
! Version 4: DO-IF pointer version
! **************************************************************************
integer_array=0_I4
PRINT *,''
PRINT *,'DO-IF: pointer version'
DO i=1_I4,6_I4
p_vect1(i)%vect => integer_array((2_I4*i-1_I4):(2_I4*i))
END DO
DO i=1_I4,3_I4
IF (logical_array(1_I4,i)) THEN
p_vect2(2_I4*i-1_I4)=elemental_pointer_fun(2_I4*i-1_I4)
ELSE
p_vect2(2_I4*i-1_I4)=elemental_pointer_fun(0_I4)
END IF
IF (logical_array(2_I4,i)) THEN
p_vect2(2_I4*i)=elemental_pointer_fun(2_I4*i)
ELSE
p_vect2(2_I4*i)=elemental_pointer_fun(0_I4)
END IF
END DO
DO i=1_I4,6_I4
p_vect1(i)%vect=p_vect2(i)%vect
END DO
DO i=6_I4,1_I4,-1_I4
DEALLOCATE(p_vect2(i)%vect)
END DO
DO i=6_I4,1_I4,-1_I4
NULLIFY(p_vect1(i)%vect)
END DO
PRINT '(A,6L6)', 'logical_array: ',logical_array
PRINT '(A,12I3)', 'integer_array: ',integer_array
! **************************************************************************
! Version 5: DO-WHERE pointer version
! **************************************************************************
integer_array=0_I4
PRINT *,''
PRINT *,'DO-WHERE: pointer version'
DO i=1_I4,6_I4
p_vect1(i)%vect => integer_array((2_I4*i-1_I4):(2_I4*i))
END DO
DO i=1_I4,3_I4
WHERE(logical_array((/1_I4,2_I4/),i))
p_vect2((2_I4*i-1_I4):(2_I4*i))=&
& elemental_pointer_fun((/(2_I4*i-1_I4),(2_I4*i)/))
ELSEWHERE
p_vect2((2_I4*i-1_I4):(2_I4*i))=&
& elemental_pointer_fun((/0_I4,0_I4/))
END WHERE
END DO
DO i=1_I4,6_I4
p_vect1(i)%vect=p_vect2(i)%vect
END DO
DO i=6_I4,1_I4,-1_I4
DEALLOCATE(p_vect2(i)%vect)
END DO
DO i=6_I4,1_I4,-1_I4
NULLIFY(p_vect1(i)%vect)
END DO
PRINT '(A,6L6)', 'logical_array: ',logical_array
PRINT '(A,12I3)', 'integer_array: ',integer_array
! **************************************************************************
! Version 6: FORALL-WHERE pointer version
! **************************************************************************
integer_array=0_I4
PRINT *,''
PRINT *,'FORALL-WHERE: pointer version'
DO i=1_I4,6_I4
p_vect1(i)%vect => integer_array((2_I4*i-1_I4):(2_I4*i))
END DO
FORALL (i=1_I4:3_I4:1_I4)
WHERE(logical_array((/1_I4,2_I4/),i))
p_vect2((2_I4*i-1_I4):(2_I4*i))=&
& elemental_pointer_fun((/(2_I4*i-1_I4),(2_I4*i)/))
ELSEWHERE
p_vect2((2_I4*i-1_I4):(2_I4*i))=&
& elemental_pointer_fun((/0_I4,0_I4/))
END WHERE
END FORALL
FORALL(i=1_I4:6_I4:1_I4)
p_vect1(i)%vect=p_vect2(i)%vect
END FORALL
DO i=6_I4,1_I4,-1_I4
DEALLOCATE(p_vect2(i)%vect)
END DO
DO i=6_I4,1_I4,-1_I4
NULLIFY(p_vect1(i)%vect)
END DO
PRINT '(A,6L6)', 'logical_array: ',logical_array
PRINT '(A,12I3)', 'integer_array: ',integer_array
CONTAINS
!---------------------------------------------------------------------------
PURE TYPE(pointer_vector_I4) ELEMENTAL FUNCTION &
& elemental_pointer_fun(index) RESULT(ans)
USE kind_mod, ONLY : I4
IMPLICIT NONE
INTEGER(I4), INTENT(IN) :: index
ALLOCATE(ans%vect(2_I4))
ans%vect=(/index,-index/)
END FUNCTION elemental_pointer_fun
!---------------------------------------------------------------------------
PURE INTEGER(I4) ELEMENTAL FUNCTION &
& elemental_nonpointer_fun(index) RESULT(ans)
USE kind_mod, ONLY : I4
IMPLICIT NONE
INTEGER(I4), INTENT(IN) :: index
ans=index
END FUNCTION elemental_nonpointer_fun
!---------------------------------------------------------------------------
END PROGRAM test_prog
!==============================================================================
|
