mod_dtype.f90 3.6 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
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
! --------------------------

! none

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

! wrap API

 public get_one

contains

 subroutine get_one(id, d) bind(c, name='getOne')
   implicit none
   integer(kind=c_int), intent(in), value :: id
   type(T_datatype) :: d
   !
   logical, save     :: is_first = .true.
   integer(kind=4)   :: i
   real(kind=8) , dimension(:), pointer :: rtab
   type(T_param), dimension(:), pointer :: weird

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

     is_first = .false.

   end if

   d = mydatas(1)

 end subroutine

 subroutine display(id) bind(c, name='display')
   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

   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(id, nn, rv, iv) bind(c, name='change')
   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

   call c_f_pointer(cptr=nn,fptr=nname)
   i = 0
   do while( i <30 .and. nname(i+1:i+1) /= 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