diff options
Diffstat (limited to 'Ganlib/src/LCMAUX.f90')
| -rw-r--r-- | Ganlib/src/LCMAUX.f90 | 578 |
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 |