采用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

• 相关文章
• 全局相关文章