EQuUs_C.f90

Go to the documentation of this file.

!======================================================================
!     Wrapper module to support the conversion of Fortran types into C compatible types.
!     This file is part of the EQuUs package. (for details see: http://eqt.elte.hu/equus/home)
!     Copyright (C) 2016 Peter Rakyta, Ph.D.
!
!     This program is free software: you can redistribute it and/or modify
!     it under the terms of the GNU General Public License as published by
!     the Free Software Foundation, either version 3 of the License, or
!     (at your option) any later version.
! 
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program.  If not, see http://www.gnu.org/licenses/.
!     
!======================================================================
MODULE equus_c

  use iso_c_binding


integer, parameter, public :: dp = selected_real_kind(14,100)
integer, parameter, public :: sp = selected_real_kind(6,30)


! DESCRIPTION:
type, public :: eqelement
! Number of dimensions of the element
  TYPE(c_ptr) :: dim
! Array of dimensions 
  TYPE(c_ptr) :: dims
! C type pointer to the value of the element
  TYPE(c_ptr) :: value
! MATLAB class id of the value (see http://www.mathworks.com/help/matlab/apiref/mxclassid.html)
  TYPE(c_ptr) :: classid
! String containing the variable name
  TYPE(c_ptr) :: elementname
end type

! DESCRIPTION:
type, public :: eqstruct
! C type pointer pointing to the array of EQuUs element prototypes
  TYPE(c_ptr) :: fields
! Number of the stored EQuUs element prototypes
  integer :: numfields
end type


interface assocelement
  module procedure associntelement
  module procedure assocrealelement
  module procedure associntvectorelement
  module procedure associntmatrixelement
  module procedure assocrealvectorelement
  module procedure assocrealmatrixelement
  module procedure assoclogicalelement
  module procedure assocstringelement
  module procedure assocstringelement2
  module procedure assocstructelement
end interface

interface allocateelement
  module procedure allocateelementarray
  module procedure allocateelementsingle
end interface


!****************************************************************      
  CONTAINS
!****************************************************************


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine addelement( eq_elements, eq_element )
    TYPE(eqelement), pointer :: eq_element
    TYPE(eqelement), pointer :: eq_elements(:)
    TYPE(eqelement), pointer :: eq_elements_new(:)
    integer elementNum



    if (.not.ASSOCIATED(eq_elements)) then
      allocate(eq_elements(1))
      eq_elements(1) = eq_element
      return
    end if

    elementnum = SIZE( eq_elements, 1)
    allocate( eq_elements_new(elementnum+1) )

    do idx = 1, elementnum
      eq_elements_new(idx) = eq_elements(idx)
    end do

    eq_elements_new(elementnum+1) = eq_element

    deallocate( eq_elements )
    allocate( eq_elements(elementnum+1) )
    do idx = 1, elementnum+1
      eq_elements(idx) = eq_elements_new(idx)
    end do

    deallocate( eq_elements_new )
    
  end subroutine addelement


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine allocateelementarray( eq_elements, num )
    TYPE(eqelement), pointer :: eq_elements(:)
    integer :: num
    integer :: idx

    allocate( eq_elements(num) )

    do idx = 1, num
      eq_elements(idx)%elementname = c_loc( null() )
      eq_elements(idx)%dim = c_loc( null() )
      eq_elements(idx)%dims = c_loc( null() )
      eq_elements(idx)%value = c_loc( null() )
      eq_elements(idx)%classID = c_loc( null() )
    end do

  end subroutine allocateelementarray


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine allocateelementsingle( eq_element )
    TYPE(eqelement), pointer :: eq_element

    allocate( eq_element )

    eq_element%elementname = c_loc( null() )
    eq_element%dim = c_loc( null() )
    eq_element%dims = c_loc( null() )
    eq_element%value = c_loc( null() )
    eq_element%classID = c_loc( null() )

  end subroutine allocateelementsingle

!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine deallocateelement( eq_element )
    TYPE(eqelement) :: eq_element

    byte, pointer :: ptr => null()

    call c_f_pointer( eq_element%elementname, ptr )
    if (ASSOCIATED(ptr)) then
      deallocate( ptr )
      nullify (ptr )
    end if

    call c_f_pointer( eq_element%dim, ptr )
    if (ASSOCIATED(ptr)) then
      deallocate( ptr )
      nullify (ptr )
    end if

    call c_f_pointer( eq_element%dims, ptr )
    if (ASSOCIATED(ptr)) then
      deallocate( ptr )
      nullify (ptr )
    end if

    call c_f_pointer( eq_element%value, ptr )
    if (ASSOCIATED(ptr)) then
      deallocate( ptr )
      nullify (ptr )
    end if

    call c_f_pointer( eq_element%classID, ptr )
    if (ASSOCIATED(ptr)) then
      deallocate( ptr )
      nullify (ptr )
    end if

  end subroutine deallocateelement


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine assocstructelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    TYPE(eqstruct) :: value
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)

    allocate( dims(1), stat=iostat)
    dims(1) = 1

    allocate( dim(1), stat=iostat)
    dim(1) = 1
    allocate( classid(1), stat=iostat)
    classid(1) = 2


    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc(value)
    eq_element%classID = c_loc(classid(1))

  end subroutine assocstructelement

!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine assocstringelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    character(len=*), pointer :: value(:)
    TYPE(c_ptr), pointer :: values(:)
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)
    integer idx

    allocate( dims(1), stat=iostat)
    dims(1) = SIZE( value,1)

    allocate( dim(1), stat=iostat)
    dim(1) = 1
    allocate( classid(1), stat=iostat)
    classid(1) = 4

    allocate(values( dims(1) ))
    do idx = 1, dims(1) 
      value(idx) = trim(value(idx))//c_null_char
      values(idx) = c_loc( value(idx) )
    end do

    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc( values(1) )
    eq_element%classID = c_loc(classid(1))

  end subroutine assocstringelement



!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine assocstringelement2( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    character(len=*) :: value
    character(len(trim(value))+1), pointer :: value_tmp
    TYPE(c_ptr), pointer :: values(:)
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)
    integer idx

    allocate( dims(1), stat=iostat)
    dims(1) = 1

    allocate( dim(1), stat=iostat)
    dim(1) = 1
    allocate( classid(1), stat=iostat)
    classid(1) = 4

    allocate(values(1))
    allocate(value_tmp)
    value_tmp = trim(value)//c_null_char
    values(1) = c_loc(value_tmp)

    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc( values(1) )
    eq_element%classID = c_loc(classid(1))

  end subroutine assocstringelement2


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine assoclogicalelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    logical :: value
    integer, pointer :: pvalue(:)
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)

    allocate( dims(1), stat=iostat)
    dims(1) = 1

    allocate( pvalue(1), stat=iostat)
    if ( value.eqv..true.)  then
      pvalue(1) = 1
    else
      pvalue(1) = 0
    endif

    allocate( dim(1), stat=iostat)
    dim(1) = 1
    allocate( classid(1), stat=iostat)
    classid(1) = 3

    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc(pvalue(1))
    eq_element%classID = c_loc(classid(1))

  end subroutine assoclogicalelement


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine associntelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    integer :: value
    integer, pointer :: pvalue(:)
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)


    allocate( dims(1), stat=iostat)
    dims(1) = 1

    allocate(pvalue(1), stat=iostat)
    pvalue(1) = value

    allocate( dim(1), stat=iostat)
    dim(1) = 1
    allocate( classid(1), stat=iostat)
    classid(1) = 12

    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc(pvalue(1))
    eq_element%classID = c_loc(classid(1))

  end subroutine associntelement


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine assocrealelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    real(dp) :: value
    real(dp), pointer :: pvalue
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)

    allocate( dims(1), stat=iostat)
    dims(1) = 1

    allocate(pvalue, stat=iostat)
    pvalue = value

    allocate( dim(1), stat=iostat)
    dim(1) = 1
    allocate( classid(1), stat=iostat)
    if ( dp.EQ.8) then
      classid(1) = 6
    else
      print *, 'Undetermined real type !!!!!!!!!!!'
      classid(1) = 0
    end if

    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc(pvalue)
    eq_element%classID = c_loc(classid(1))

  end subroutine assocrealelement



!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine associntvectorelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    integer, pointer :: value(:)
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)


    allocate( dims(1), stat=iostat)
    dims(1) = SIZE(value, 1)

    allocate( dim(1), stat=iostat)
    dim(1) = 1
    allocate( classid(1), stat=iostat)
    classid(1) = 12


    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc(value(1))
    eq_element%classID = c_loc(classid(1))

  end subroutine associntvectorelement


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine associntmatrixelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    integer, pointer :: value(:,:)
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)

    allocate( dims(2), stat=iostat)
    dims(1) = SIZE(value, 1)
    dims(2) = SIZE(value, 2)

    allocate( dim(1), stat=iostat)
    dim(1) = 2
    allocate( classid(1), stat=iostat)
    classid(1) = 12

    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc(value(1,1))
    eq_element%classID = c_loc(classid(1))

  end subroutine associntmatrixelement


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine assocrealvectorelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    real(dp), pointer :: value(:)
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)

    allocate( dims(1), stat=iostat)
    dims(1) = SIZE(value, 1)

    allocate( dim(1), stat=iostat)
    dim(1) = 1
    allocate( classid(1), stat=iostat)
    if ( dp.EQ.8) then
      classid(1) = 6
    else
      print *, 'Undetermined real type !!!!!!!!!!!'
      classid(1) = 0
    end if


    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc(value(1))
    eq_element%classID = c_loc(classid(1))

  end subroutine assocrealvectorelement



!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine assocrealmatrixelement( eq_element, elementname, value )
  
    TYPE(eqelement) :: eq_element
    character(len=*) :: elementname
    character(len(elementname)+1), pointer :: pelementname
    real(dp), pointer :: value(:,:)
    integer, pointer :: dims(:)
    integer, pointer :: dim(:)
    integer, pointer :: classID(:)

    allocate( dims(2), stat=iostat)

    dims(1) = SIZE(value, 1)
    dims(2) = SIZE(value, 2)

    allocate( dim(1), stat=iostat)
    dim(1) = 2
    allocate( classid(1), stat=iostat)
    if ( dp.EQ.8) then
      classid(1) = 6
    else
      print *, 'Undetermined real type !!!!!!!!!!!'
      classid(1) = 0
    end if

    allocate(pelementname)
    pelementname = trim(elementname)//c_null_char

    eq_element%elementname = c_loc(pelementname)
    eq_element%dim = c_loc(dim(1))
    eq_element%dims = c_loc( dims(1) )
    eq_element%value = c_loc(value(1,1))
    eq_element%classID = c_loc(classid(1))

  end subroutine assocrealmatrixelement






end module