真他妈的晕

function getptr(...)
  type(XXX),pointer,dimension(:) :: getptr

  call fetchptr(... getptr)
end function

...

mydata => getptr(..)
...

事实证明getptr指向的XXX类型对象会在getptr函数返回前被finalize。如果采用subroutine形式实现getptr就不会。

真是坑爹啊

When finalization occurs

1 Finalization occurs for the target of a pointer when the pointer is deallocated. If an object is allocated through pointer allocation and later becomes unreachable because all pointers to that object have had their pointer association status changed, finalization on the object does not occur.

指针被释放时，指向目标的final过程被调用。如果被动态开辟的对象失去所有指针引用，则final过程无法被调用。

2 Finalization of an allocatable entity occurs with the entity is deallocated.

allocatable的对象被释放时，对象的final过程被调用。

3 Finalization for a nonpointer, nonallocatable object that is not a dummy argument or function result occurs immediately, before the object is undefined by the execution of a RETURN or END statement. If the object is defined in a module and no active procedures are still referencing the module, finalization does not take place.

非指针，非allocatable，不是哑元，不是返回值，这样的对象在所在域的RETURN or END时会被自动fanalize。module中的鼓励对象，无法finalize。

4 Finalization of a structure constructor referenced by an executable construct occurs after execution of the innermost executable construct containing the reference.

5 Finalization for a function referenced by an executable construct takes place after execution of the innermost executable construct containing the reference.

6 Finalization for the result of a function referenced by a specification expression in a scoping unit takes place before the first statement in the scoping unit executes.

7 Finalization of a nonpointer, nonallocatable object that is an actual argument associated with an INTENT(OUT) dummy argument occurs when a procedure using the argument is invoked.

8 Finalization of a variable in an intrinsic assignment statement takes place after evaluation of the expression and before the definition of the variable.

Non-finalized entities

If program execution is terminated, either by an error, such as an allocation failure, or by the execution of a STOP or END PROGRAM statement, entities existing immediately prior to termination are not finalized.

主程序结束前，还未释放的对象无法自动finalize

A nonpointer, nonallocatable object that has the SAVE attribute or that you specify in the main program is never finalized as a direct consequence of the execution of a RETURN or END statement

http://chasm-interop.sourceforge.net/

http://software.intel.com/en-us/forums/showthread.php?t=40376&wapkw=%28%2Bfortran...%29

http://coding.derkeiler.com/Archive/Fortran/comp.lang.fortran/2004-06/0500.html

http://publib.boulder.ibm.com/infocenter/cellcomp/v9v111/index.jsp?topic=/com.ibm.xlf111.cell.doc/xlflr/f90pass.htm

gfortran 4.5不行， ifort 12可以

program tt
  use iso_c_binding
  implicit none
  integer,target :: a(100),n,i,j
  integer,pointer,dimension(:) :: ptr
  integer,pointer,dimension(:,:) :: p2d,p2d2
  type(c_ptr) :: cptr

  do n=1,100; a(n)=n;enddo
  ptr(0:29) => a(71:100)
  write(*,*) ptr

  p2d2(0:9,0:9) => a
  do j=0,9;do i=0,9
  write(*,*) i,j,p2d2(i,j)
  enddo;enddo
end

采用fortran 2003标准iso_c_binding模块完成

program test
  use iso_c_binding
  implicit none
  
  interface getptr
  function fgetptr(string,ilen,ni,nj)
  use iso_c_binding
  implicit none
  real,pointer,dimension(:,:) :: fgetptr
  integer :: ilen,ni,nj
  character ::string(ilen)
  end function
  function ggetptr(string,ilen,irank,ishape)
  use iso_c_binding
  implicit none
  real,pointer,dimension(:,:) :: ggetptr
  integer :: ilen,irank
  integer :: ishape(irank)
  character ::string(ilen)
  end function

  function hgetptr(string,ilen,ishape)
  use iso_c_binding
  implicit none
  real,pointer,dimension(:,:) :: hgetptr
  integer :: ilen
  integer,dimension(:) :: ishape
  character ::string(ilen)
  end function    
  end interface   
  
  interface
    function getchar(string)
    character,pointer,dimension(:) :: getchar,string
    end function
  end interface
  
  type(c_ptr) :: p
  !character,target :: string(400)
  character,pointer,dimension(:) :: string,pp
  real,pointer,dimension(:,:) :: idata
  integer :: ishape(2)
  ishape(1) = 25
  ishape(2) = 4

  allocate(string(400))
  
  call convt1(string, 25,4,idata)
  
  write(*,*) '============================='
  idata => fgetptr(string,400,25,4)
  write(*,*) idata
  
  write(*,*) '============================='
  idata => ggetptr(string,400,2,ishape)
  write(*,*) idata
  
  write(*,*) '============================='
  idata => getptr(getchar(string),400,ishape)
  write(*,*) idata
  
end

function getchar(string)
   character,pointer,dimension(:) :: getchar,string
   
   getchar => string
   
end function


function fgetptr(string,ilen,ni,nj)
  use iso_c_binding
  implicit none
  real,pointer,dimension(:,:) :: fgetptr
  integer :: ilen,ni,nj
  character ::string(ilen)
  !
  type(c_ptr) :: p
  
  write(*,*) size(string)
  p = c_loc(string)
  CALL c_f_pointer(p,fgetptr,(/ni,nj/))
  
end function



function ggetptr(string,ilen,irank,ishape)
  use iso_c_binding
  implicit none
  real,pointer,dimension(:,:) :: ggetptr
  integer :: ilen,irank
  integer :: ishape(irank)
  character ::string(ilen)
  !
  type(c_ptr) :: p
  
  write(*,*) size(string)
  p = c_loc(string)
  CALL c_f_pointer(p,ggetptr,ishape)
  
end function



function hgetptr(string,ilen,ishape)
  use iso_c_binding
  implicit none
  real,pointer,dimension(:,:) :: hgetptr
  integer :: ilen
  integer,dimension(:) :: ishape
  character ::string(ilen)
  !
  type(c_ptr) :: p
  integer :: irank 
  irank = size(shape(hgetptr)) 
  
  write(*,*) size(string),irank
  p = c_loc(string)
  CALL c_f_pointer(p,hgetptr,ishape(1:irank))
  
end function


subroutine convt1(odata, ni,nj,tdata)
  implicit none
  integer :: ni,nj
  real,target :: odata(ni,nj)
  real,pointer,dimension(:,:) :: tdata
  
  integer :: i,j
  real :: n
  n=1.
  do j=1,nj
  do i=1,ni
    odata(i,j) = n
    n=n+1. 
  enddo
  enddo
  
  return
end subroutine