Initial commit from Polytechnique Montreal

1 files changed, 578 insertions, 0 deletions

diff --git a/Ganlib/src/LCMAUX.f90 b/Ganlib/src/LCMAUX.f90
new file mode 100644
index 0000000..e6a4ee6
--- /dev/null
+++ b/Ganlib/src/LCMAUX.f90
@@ -0,0 +1,578 @@
+!
+!-----------------------------------------------------------------------
+!
+!Purpose:
+! Fortran-2003 bindings for lcm -- part 1.
+!
+!Copyright:
+! Copyright (C) 2009 Ecole Polytechnique de Montreal
+! This library is free software; you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public
+! License as published by the Free Software Foundation; either
+! version 2.1 of the License, or (at your option) any later version.
+!
+!Author(s): A. Hebert
+!
+!-----------------------------------------------------------------------
+!
+module LCMAUX
+contains
+subroutine STRCUT(name1, name2)
+   ! transform a Fortran string into a C null-terminated string
+   use, intrinsic :: iso_c_binding
+   character(kind=c_char), dimension(*) :: name1
+   character(len=*) :: name2
+   integer :: ilong
+   interface
+      subroutine strcut_c (s, ct, n) bind(c)
+         use, intrinsic :: iso_c_binding
+         character(kind=c_char), dimension(*) :: s, ct
+         integer(c_int), value :: n
+      end subroutine strcut_c
+   end interface
+   ilong=len(name2)
+   call strcut_c(name1, name2, ilong)
+end subroutine STRCUT
+!
+subroutine STRFIL(name1, name2)
+   ! transform a C null-terminated string into a Fortran string
+   use, intrinsic :: iso_c_binding
+   character(len=*) :: name1
+   character(kind=c_char), dimension(*) :: name2
+   integer :: ilong
+   interface
+      subroutine strfil_c (s, ct, n) bind(c)
+         use, intrinsic :: iso_c_binding
+         character(kind=c_char), dimension(*) :: s, ct
+         integer(c_int), value :: n
+      end subroutine strfil_c
+   end interface
+   ilong=len(name1)
+   call strfil_c(name1, name2, ilong)
+end subroutine STRFIL
+!
+function LCMARA(ilong)
+   ! allocate an array of length ilong and return a c_ptr pointer
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) LCMARA
+   integer :: ilong
+   interface
+      function setara_c (length) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) setara_c
+         integer(c_int), value :: length
+      end function setara_c
+   end interface
+   LCMARA=setara_c(ilong)
+end function LCMARA
+!
+subroutine LCMDRD(ipdata)
+   ! deallocate an array allocated by LCMARA
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) ipdata
+   interface
+      subroutine rlsara_c (ipd) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr),value :: ipd
+      end subroutine rlsara_c
+   end interface
+   call rlsara_c(ipdata)
+end subroutine LCMDRD
+!
+subroutine LCMOP(iplist, name, imp, medium, impx)
+   ! open a LCM object
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   character(len=*) :: name
+   character(kind=c_char), dimension(73) :: name73
+   integer imp, medium, impx
+   interface
+      subroutine lcmop_c (iplist, namp, imp, medium, impx) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namp
+         integer(c_int), value :: imp, medium, impx
+      end subroutine lcmop_c
+   end interface
+   call STRCUT(name73, name)
+   call lcmop_c(iplist, name73, imp, medium, impx)
+end subroutine LCMOP
+!
+subroutine LCMPPD(iplist, name, ilong, itype, pt_data)
+   ! store a record in an associative table via its c_ptr pointer
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist, pt_data
+   character(len=*),intent(in) :: name
+   character(kind=c_char), dimension(13) :: name13
+   integer :: ilong, itype
+   interface
+      subroutine lcmppd_c (iplist, namp, ilong, itype, iofdum) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namp
+         integer(c_int), value :: ilong, itype
+         type(c_ptr), value :: iofdum
+      end subroutine lcmppd_c
+   end interface
+   call STRCUT(name13, name)
+   call lcmppd_c(iplist, name13, ilong, itype, pt_data)
+   pt_data=c_null_ptr
+end subroutine LCMPPD
+!
+subroutine LCMGPD(iplist, name, pt_data)
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist, pt_data
+   character(len=*),intent(in) :: name
+   character(kind=c_char), dimension(13) :: name13
+   interface
+      subroutine lcmgpd_c (iplist, namp, iofdum) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namp
+         type(c_ptr) :: iofdum
+      end subroutine lcmgpd_c
+   end interface
+   call STRCUT(name13, name)
+   call lcmgpd_c(iplist, name13, pt_data)
+end subroutine LCMGPD
+!
+subroutine LCMLEN(iplist, name, ilong, itylcm)
+   ! recover length and type of a record in an associative table
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   character(len=*),intent(in) :: name
+   integer :: ilong, itylcm
+   character(kind=c_char), dimension(13) :: name13
+   interface
+      subroutine lcmlen_c (iplist, namp, ilong, itylcm) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namp
+         integer(c_int) :: ilong, itylcm
+      end subroutine lcmlen_c
+   end interface
+   call STRCUT(name13, name)
+   call lcmlen_c(iplist, name13, ilong, itylcm)
+end subroutine LCMLEN
+!
+subroutine LCMINF(iplist, fnamlcm, fnammy, fempty, ilong, flcml)
+   ! recover general info about a LCM object
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   character(len=*) :: fnamlcm, fnammy
+   logical :: fempty, flcml
+   integer :: empty, ilong, lcml, access
+   character(kind=c_char), dimension(73) :: namlcm
+   character(kind=c_char), dimension(13) :: nammy
+   interface
+      subroutine lcminf_c (iplist, namlcm, nammy, empty, ilong, lcml, access) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namlcm, nammy
+         integer(c_int) :: empty, ilong, lcml, access
+      end subroutine lcminf_c
+   end interface
+   call lcminf_c(iplist, namlcm, nammy, empty, ilong, lcml, access)
+   call STRFIL(fnamlcm, namlcm)
+   call STRFIL(fnammy, nammy)
+   fempty=(empty == 1)
+   flcml=(lcml == 1)
+end subroutine LCMINF
+!
+subroutine LCMNXT(iplist, name)
+   ! recover name of next record in an associative table
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   character(len=*) :: name
+   character(kind=c_char), dimension(13) :: name13
+   interface
+      subroutine lcmnxt_c (iplist, namp) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namp
+      end subroutine lcmnxt_c
+   end interface
+   call STRCUT(name13, name)
+   call lcmnxt_c(iplist, name13)
+   call STRFIL(name, name13)
+end subroutine LCMNXT
+!
+subroutine LCMVAL(iplist, name)
+   ! validate an associative table, starting from name
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   character(len=*),intent(in) :: name
+   character(kind=c_char), dimension(13) :: name13
+   interface
+      subroutine lcmval_c (iplist, namp) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namp
+      end subroutine lcmval_c
+   end interface
+   call STRCUT(name13, name)
+   call lcmval_c(iplist, name13)
+end subroutine LCMVAL
+!
+subroutine LCMDEL(iplist, name)
+   ! delete a record in an associative table
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   character(len=*),intent(in) :: name
+   character(kind=c_char), dimension(13) :: name13
+   interface
+      subroutine lcmdel_c (iplist, namp) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namp
+      end subroutine lcmdel_c
+   end interface
+   call STRCUT(name13, name)
+   call lcmdel_c(iplist, name13)
+end subroutine LCMDEL
+!
+function LCMDID(iplist, name)
+   ! create/access a daughter table in a parent table in modification mode
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: LCMDID,iplist
+   character(len=*),intent(in) :: name
+   character(kind=c_char), dimension(13) :: name13
+   interface
+      function lcmdid_c (iplist, namp) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: lcmdid_c,iplist
+         character(kind=c_char), dimension(*) :: namp
+      end function lcmdid_c
+   end interface
+   call STRCUT(name13, name)
+   LCMDID = lcmdid_c(iplist, name13)
+end function LCMDID
+!
+function LCMLID(iplist, name, ilong)
+   ! create/access a daughter list in a parent table in modification mode
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: LCMLID,iplist
+   character(len=*),intent(in) :: name
+   character(kind=c_char), dimension(13) :: name13
+   integer :: ilong
+   interface
+      function lcmlid_c (iplist, namp, ilong) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: lcmlid_c,iplist
+         character(kind=c_char), dimension(*) :: namp
+         integer(c_int), value :: ilong
+      end function lcmlid_c
+   end interface
+   call STRCUT(name13, name)
+   LCMLID = lcmlid_c(iplist, name13, ilong)
+end function LCMLID
+!
+function LCMDIL(iplist, ipos)
+   ! create/access a daughter table in a parent list in modification mode
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: LCMDIL,iplist
+   integer :: ipos
+   interface
+      function lcmdil_c (iplist, ipos) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: lcmdil_c,iplist
+         integer(c_int), value :: ipos
+      end function lcmdil_c
+   end interface
+   LCMDIL = lcmdil_c(iplist, ipos-1)
+end function LCMDIL
+!
+function LCMLIL(iplist, ipos, ilong)
+   ! create/access a daughter list in a parent list in modification mode
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: LCMLIL,iplist
+   integer :: ipos, ilong
+   interface
+      function lcmlil_c (iplist, ipos, ilong) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: lcmlil_c,iplist
+         integer(c_int), value :: ipos, ilong
+      end function lcmlil_c
+   end interface
+   LCMLIL = lcmlil_c(iplist, ipos-1, ilong)
+end function LCMLIL
+!
+function LCMGID(iplist, name)
+   ! access a daughter table/list in a parent table in read-only mode
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: LCMGID,iplist
+   character(len=*),intent(in) :: name
+   character(kind=c_char), dimension(13) :: name13
+   interface
+      function lcmgid_c (iplist, namp) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: lcmgid_c,iplist
+         character(kind=c_char), dimension(*) :: namp
+      end function lcmgid_c
+   end interface
+   call STRCUT(name13, name)
+   LCMGID = lcmgid_c(iplist, name13)
+end function LCMGID
+!
+function LCMGIL(iplist, ipos)
+   ! access a daughter table/list in a parent list in read-only mode
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: LCMGIL,iplist
+   integer :: ipos
+   interface
+      function lcmgil_c (iplist, ipos) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: lcmgil_c,iplist
+         integer(c_int), value :: ipos
+      end function lcmgil_c
+   end interface
+   LCMGIL = lcmgil_c(iplist, ipos-1)
+end function LCMGIL
+!
+subroutine LCMSIX(iplist, name, iact)
+   ! create/access a daughter table in a parent table
+   ! depreciated: better to use LCMDID
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   character(len=*),intent(in) :: name
+   integer :: iact
+   character(kind=c_char), dimension(13) :: name13
+   interface
+      subroutine lcmsix_c (iplist, namp, iact) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         character(kind=c_char), dimension(*) :: namp
+         integer(c_int), value :: iact
+      end subroutine lcmsix_c
+   end interface
+   call STRCUT(name13, name)
+   call lcmsix_c(iplist, name13, iact)
+end subroutine LCMSIX
+!
+subroutine LCMPPL(iplist, ipos, ilong, itype, pt_data)
+   ! store a record in an heterogeneous list via its c_ptr pointer
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist, pt_data
+   integer :: ipos, ilong, itype
+   interface
+      subroutine lcmppl_c (iplist, ipos, ilong, itype, iofdum) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         integer(c_int), value :: ipos, ilong, itype
+         type(c_ptr), value :: iofdum
+      end subroutine lcmppl_c
+   end interface
+   call lcmppl_c(iplist, ipos-1, ilong, itype, pt_data)
+   pt_data=c_null_ptr
+end subroutine LCMPPL
+!
+subroutine LCMLEL(iplist, ipos, ilong, itylcm)
+   ! recover length and type of a record in an heterogeneous list
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   integer :: ipos, ilong, itylcm
+   interface
+      subroutine lcmlel_c (iplist, ipos, ilong, itylcm) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         integer(c_int), value :: ipos
+         integer(c_int) :: ilong, itylcm
+      end subroutine lcmlel_c
+   end interface
+   call lcmlel_c(iplist, ipos-1, ilong, itylcm)
+end subroutine LCMLEL
+!
+subroutine LCMGPL(iplist, ipos, pt_data)
+   ! recover a record from an heterogeneous list via its c_ptr pointer
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist, pt_data
+   integer :: ipos
+   interface
+      subroutine lcmgpl_c (iplist, ipos, iofdum) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist, iofdum
+         integer(c_int), value :: ipos
+      end subroutine lcmgpl_c
+   end interface
+   call lcmgpl_c(iplist, ipos-1, pt_data)
+end subroutine LCMGPL
+!
+subroutine LCMCL(iplist, iact)
+   ! close a LCM object
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist
+   integer :: iact
+   interface
+      subroutine lcmcl_c (iplist, iact) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         integer(c_int), value :: iact
+      end subroutine lcmcl_c
+   end interface
+   call lcmcl_c(iplist, iact)
+end subroutine LCMCL
+!
+subroutine LCMEQU(iplis1, iplis2)
+   ! deep copy of a LCM object
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplis1, iplis2
+   interface
+      subroutine lcmequ_c (iplis1, iplis2) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplis1, iplis2
+      end subroutine lcmequ_c
+   end interface
+   call lcmequ_c(iplis1, iplis2)
+end subroutine LCMEQU
+!
+subroutine LCMEXP(iplist, impx, nunit, imode, idir)
+   ! import/export a LCM object
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist, file = c_null_ptr
+   integer, intent(in) :: impx, nunit, imode, idir
+   character(len=72) :: filename
+   character(kind=c_char), dimension(73) :: filename_c
+   integer(c_int) :: ier
+   interface
+      function fopen (filename_c, mode) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) fopen
+         character(kind=c_char), dimension(*) :: filename_c, mode
+      end function fopen
+   end interface
+   interface
+      function fclose (file) bind(c)
+         use, intrinsic :: iso_c_binding
+         integer(c_int) fclose
+         type(c_ptr), value :: file
+      end function fclose
+   end interface
+   interface
+      subroutine lcmexp_c (iplist, impx, file, imode, idir) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         type(c_ptr), value :: file
+         integer(c_int), value :: impx, imode, idir
+      end subroutine lcmexp_c
+   end interface
+   interface
+      function stdfil_c (s) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) stdfil_c
+         character(kind=c_char), dimension(*) :: s
+      end function stdfil_c
+   end interface
+!
+   if(nunit == 0) then
+      file=c_null_ptr
+   else if(nunit == 6) then
+      file=stdfil_c("stdout"//c_null_char)
+      flush(6)
+   else
+      inquire(nunit,name=filename)
+      close(nunit,status='keep')
+      call STRCUT(filename_c, filename)
+      if(imode == 1) then
+         if(idir == 1) then
+            file=fopen(filename_c, "wb"//c_null_char)
+         else
+            file=fopen(filename_c, "rb"//c_null_char)
+         endif
+      else if(imode == 2) then
+         if(idir == 1) then
+            file=fopen(filename_c, "w"//c_null_char)
+         else
+            file=fopen(filename_c, "r"//c_null_char)
+         endif
+      endif
+      if(.not.c_associated(file)) call XABORT('LCMEXP: UNABLE TO OPEN FILE '//filename(:44))
+   endif
+   call lcmexp_c(iplist, impx, file, imode, idir)
+   if(nunit /= 6) then
+      ier = fclose(file)
+      if(ier /= 0) call XABORT('LCMEXP: UNABLE TO CLOSE FILE '//filename(:43))
+      if(imode == 1) then
+        open(nunit,file=filename,status='old',form='unformatted',position='append')
+      else
+        open(nunit,file=filename,status='old',position='append')
+      endif
+   endif
+end subroutine LCMEXP
+!
+!-----------------------------------------------------------------------
+! additionnal lcm subroutine specific to Version 3
+! R. Chambon (based on Version 4)
+!-----------------------------------------------------------------------
+subroutine LCMEXPV3(iplist, impx, nunit, imode, idir)
+   ! import/export a LCM object V3
+   use, intrinsic :: iso_c_binding
+   type(c_ptr) :: iplist, file = c_null_ptr
+   integer, intent(in) :: impx, nunit, imode, idir
+   character(len=72) :: filename
+   character(kind=c_char), dimension(73) :: filename_c
+   integer(c_int) :: ier
+   interface
+      function fopen (filename_c, mode) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) fopen
+         character(kind=c_char), dimension(*) :: filename_c, mode
+      end function fopen
+   end interface
+   interface
+      function fclose (file) bind(c)
+         use, intrinsic :: iso_c_binding
+         integer(c_int) fclose
+         type(c_ptr), value :: file
+      end function fclose
+   end interface
+   interface
+      subroutine lcmexpv3_c (iplist, impx, file, imode, idir) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) :: iplist
+         type(c_ptr), value :: file
+         integer(c_int), value :: impx, imode, idir
+      end subroutine lcmexpv3_c
+   end interface
+   interface
+      function stdfil_c (s) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr) stdfil_c
+         character(kind=c_char), dimension(*) :: s
+      end function stdfil_c
+   end interface
+!
+   if(nunit == 0) then
+      file=c_null_ptr
+   else if(nunit == 6) then
+      file=stdfil_c("stdout"//c_null_char)
+   else
+      inquire(nunit,name=filename)
+      close(nunit,status='keep')
+      call STRCUT(filename_c, filename)
+      if(imode == 1) then
+         if(idir == 1) then
+            file=fopen(filename_c, "wb"//c_null_char)
+         else
+            file=fopen(filename_c, "rb"//c_null_char)
+         endif
+      else if(imode == 2) then
+         if(idir == 1) then
+            file=fopen(filename_c, "w"//c_null_char)
+         else
+            file=fopen(filename_c, "r"//c_null_char)
+         endif
+      endif
+      if(.not.c_associated(file)) call XABORT('LCMEXPV3: UNABLE TO OPEN FILE '//filename(:44))
+   endif
+   call lcmexpv3_c(iplist, impx, file, imode, idir)
+   if(nunit /= 6) then
+      ier = fclose(file)
+      if(ier /= 0) call XABORT('LCMEXPV3: UNABLE TO CLOSE FILE '//filename(:43))
+      if(imode == 1) then
+        open(nunit,file=filename,status='old',form='unformatted',position='append')
+      else
+        open(nunit,file=filename,status='old',position='append')
+      endif
+   endif
+end subroutine LCMEXPV3
+end module LCMAUX