mod_dtype.f90 4.03 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
module data_type

  use iso_c_binding

  implicit none

  private
  
  ! an intermediate type
  type, bind(c) :: T_param
      integer(kind=c_int) :: itype
      real(kind=c_double) :: val
      character(kind=c_char,len=30)   :: field      
  end type T_param


  ! the real type to bind
  type, bind(c) :: T_datatype

     ! a string of size 30
     character(kind=c_char,len=30) :: nickname
   
     ! a real alone
     real(kind=c_double) :: rsingle
     ! an integer alone
     integer(kind=c_int) :: isingle
     
     ! a fixed size array :
     ! contains the sizes of rtab and weird arrays in that order
     integer(kind=c_int), dimension(2) :: itab

     ! a dynamic array
     ! doesn't work like this : real(kind=c_double), dimension(:), pointer :: rtab
     type(c_ptr) :: rtab

     ! a pointer on an array of an interoperable type
     !type(T_param), dimension(:), pointer :: weird => null()
     type(c_ptr) :: weird

 end type T_datatype

 type(T_datatype), dimension(:), allocatable :: mydatas

!----------------------------------------------------------------------

 integer :: nb_data = 0

! --------------------------
! subroutines set to private
! --------------------------

 private init

! -------------------------
! subroutines set to public
! -------------------------

! wrap API

 public get_one, display_one, change_one

contains

 subroutine init()
   logical, save     :: is_first = .true.
   integer(kind=4)   :: i, j
   real(kind=8) , dimension(:), pointer :: rtab
   type(T_param), dimension(:), pointer :: weird

   rtab  => null()
   weird => null()

   if( is_first ) then
     nb_data = 5
     allocate(mydatas(nb_data))
     do i = 1, nb_data
       write(mydatas(i)%nickname,'(A,I0,A)') "data ", i, " in fortran"
       mydatas(i)%rsingle = i*0.1d0
       mydatas(i)%isingle = i
       mydatas(i)%itab = (/i,i-1/)
       allocate(rtab(i))
       rtab = (/0.1d0,0.2d0/)
       mydatas(i)%rtab = c_loc(rtab(1))
       allocate(weird(i-1))
       do j = 1, i-1
         weird(j)%itype = j
         weird(j)%val   = 0.01d0*j
         write(weird(j)%field,'(A,I0,A,I0)')  'field of ',j,' in ', i
       end do
       mydatas(i)%weird = c_loc(weird(1))
     end do

     is_first = .false.

   end if

 end subroutine

 subroutine get_one(id, d) bind(c, name='getOne')
   implicit none
   integer(kind=c_int), intent(in), value :: id
   type(T_datatype) :: d

   call init()

   if( id > nb_data ) then
     write(*,*) 'error index'
     return
   end if

   d = mydatas(id)

 end subroutine

 subroutine display_one(id) bind(c, name='displayOne')
   implicit none
   integer(kind=c_int), intent(in), value :: id
   !
   integer(kind=4) :: i
   real(kind=8) , dimension(:), pointer :: rtab
   type(T_param), dimension(:), pointer :: weird

   if( id > nb_data ) then
     write(*,*) 'error index'
     return
   end if

   print *,'T_DATA of id ', id
   print *,'  nickname : ', mydatas(id)%nickname
   print *,'  rsingle  : ', mydatas(id)%rsingle
   print *,'  isingle  : ', mydatas(id)%isingle
   print *,'  itab     : ', mydatas(id)%itab
     
   call c_f_pointer(mydatas(id)%rtab,rtab,(/mydatas(id)%itab(1)/))
   call c_f_pointer(mydatas(id)%weird,weird,(/mydatas(id)%itab(2)/))

   print *,'  rtab     : ', rtab
   do i = 1, mydatas(id)%itab(2)
     print *,'  weird  : ', i
     print *,'  --itype  : ', weird(i)%itype
     print *,'  --val    : ', weird(i)%val
     print *,'  --field  : ', weird(i)%field
   end do
 end subroutine

 subroutine change_one(id, nn, rv, iv) bind(c, name='changeOne')
   implicit none
   integer(kind=c_int), intent(in), value :: id
   real(kind=c_double), intent(in), value :: rv
   integer(kind=c_int), intent(in), value :: iv
   type(c_ptr), value :: nn
   !
   character(kind=c_char,len=30), pointer :: nname
   integer(kind=4) :: i, j

   call c_f_pointer(cptr=nn,fptr=nname)
   i = 1
   do while( i <30 .and. nname(i:i) /= c_null_char )
     i = i + 1
   end do
   mydatas(id)%nickname(1:i) = nname(1:i)
   mydatas(id)%nickname(i+1:) = ''

   mydatas(id)%rsingle  = rv
   mydatas(id)%isingle  = iv

 end subroutine
     
end module data_type