initial upload
This commit is contained in:
352
src/lg_fc_wrappers.f90
Normal file
352
src/lg_fc_wrappers.f90
Normal file
@@ -0,0 +1,352 @@
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! f90 wrappers calling cmo_get_info for C codes
|
||||
! pass mesh object pointer and scalars
|
||||
! These use cmo_get_attinfo for attribute name
|
||||
! check return type of data I=1,R=2,C=3,pointer=4
|
||||
!!! -------------------------------------------------------------------
|
||||
|
||||
!!! -------------------------------------------------------------------
|
||||
! get INT value fc_cmo_get_int
|
||||
! const char* cmo, const char* att,
|
||||
! integer ival
|
||||
!!! -------------------------------------------------------------------
|
||||
!!!
|
||||
subroutine fc_cmo_get_int(cmoname, attname, ival, ierr)
|
||||
|
||||
implicit none
|
||||
|
||||
!!!! arguments passed from C routine
|
||||
|
||||
character*(*) cmoname, attname
|
||||
integer ival,ierr
|
||||
|
||||
!!!! local variables and dummy args for cmo_get_attinfo
|
||||
pointer (ipdum, intdum)
|
||||
integer intdum(*)
|
||||
character*32 cdum
|
||||
real*8 xdum
|
||||
integer ilocal
|
||||
|
||||
integer i,clen,alen
|
||||
integer ilen,ityp,ierror
|
||||
integer icharlnf
|
||||
|
||||
!!!! begin
|
||||
ierr=0
|
||||
clen=icharlnf(cmoname)
|
||||
alen=icharlnf(attname)
|
||||
|
||||
! WRITE(*,'(A,1X,A,1X,A)') &
|
||||
! 'fc_cmo_get_int for cmo: ',cmoname(1:clen),attname(1:alen)
|
||||
|
||||
if (sizeof(ival) .ne. 8) then
|
||||
print*,"ERROR: sizeof ival not 8: ",sizeof(ival)
|
||||
ierr= -1
|
||||
return
|
||||
endif
|
||||
|
||||
call cmo_get_attinfo( &
|
||||
attname(1:alen), cmoname(1:clen), &
|
||||
ilocal,xdum,cdum,ipdum,ilen,ityp,ierror)
|
||||
|
||||
! INT type 1 and ilen 1
|
||||
if (ityp.ne.1 .or. ilen.ne.1) then
|
||||
WRITE(*,'(1X,A)')'Warning: INT type and length should be: 1 1'
|
||||
WRITE(*,'(1X,A,I3,I3)')&
|
||||
'Got type and length: ',ityp,ilen
|
||||
endif
|
||||
|
||||
if (ierror .ne. 0) then
|
||||
WRITE(*,'(1X,A)')'ERROR from cmo_get_attinfo: ',ierror
|
||||
return
|
||||
endif
|
||||
|
||||
ival = ilocal
|
||||
|
||||
return
|
||||
end subroutine fc_cmo_get_int
|
||||
|
||||
!!! -------------------------------------------------------------------
|
||||
! get DOUBLE value fc_cmo_get_double
|
||||
! const char* cmo, const char* att,
|
||||
! double xval
|
||||
!!! -------------------------------------------------------------------
|
||||
!!!
|
||||
subroutine fc_cmo_get_double(cmoname, attname, xval, ierr)
|
||||
|
||||
implicit none
|
||||
|
||||
!!!! arguments passed from C routine
|
||||
|
||||
character*(*) cmoname, attname
|
||||
real*8 xval
|
||||
integer ierr
|
||||
|
||||
!!!! local variables
|
||||
pointer (ipdum, intdum)
|
||||
integer intdum(*)
|
||||
integer idum
|
||||
character*32 cdum
|
||||
real*8 xlocal
|
||||
|
||||
integer i,clen,alen
|
||||
integer ilen,ityp,ierror
|
||||
integer icharlnf
|
||||
|
||||
|
||||
!!!! begin
|
||||
ierr = 0
|
||||
clen=icharlnf(cmoname)
|
||||
alen=icharlnf(attname)
|
||||
|
||||
! WRITE(*,'(A,1X,A,1X,A)') &
|
||||
! 'fc_cmo_get_double for cmo: ',cmoname(1:clen),attname(1:alen)
|
||||
|
||||
if (sizeof(xval) .ne. 8) then
|
||||
print*,"ERROR: sizeof xval not 8: ",sizeof(xval)
|
||||
ierr= -1
|
||||
return
|
||||
endif
|
||||
|
||||
call cmo_get_attinfo( &
|
||||
attname(1:alen), cmoname(1:clen), &
|
||||
idum,xlocal,cdum,ipdum,ilen,ityp,ierror)
|
||||
|
||||
! DOUBLE type 2 and ilen 1
|
||||
if (ityp.ne.2 .or. ilen.ne.1) then
|
||||
WRITE(*,'(1X,A)') &
|
||||
'Warning: DOUBLE type and length should be: 2 1'
|
||||
WRITE(*,'(1X,A,I3,I3)')&
|
||||
'Got type and length: ',ityp,ilen
|
||||
endif
|
||||
|
||||
if (ierror .ne. 0) then
|
||||
WRITE(*,'(1X,A)')'ERROR from cmo_get_attinfo: ',ierror
|
||||
return
|
||||
endif
|
||||
|
||||
xval = xlocal
|
||||
|
||||
!DEBUG WRITE(*,'(1X,A,1pe15.7)') 'xlocal = ',xlocal
|
||||
! WRITE(*,'(1X,A,1pe15.7)') 'xval = ',xval
|
||||
|
||||
return
|
||||
end subroutine fc_cmo_get_double
|
||||
|
||||
!!! -------------------------------------------------------------------
|
||||
! get VINT pointer fc_cmo_get_vint
|
||||
! const char* cmo, const char* att,
|
||||
! long** iptr, long* nlen,
|
||||
! size_t cmolen, size_t attlen
|
||||
!!! -------------------------------------------------------------------
|
||||
|
||||
subroutine fc_cmo_get_vint(cmoname,attname,ptr_int,nlength,ierr)
|
||||
|
||||
implicit none
|
||||
|
||||
!!!! arguments passed from C routine
|
||||
|
||||
character*(*) cmoname, attname
|
||||
pointer (ptr_int, ipointee)
|
||||
integer ipointee(*)
|
||||
integer nlength
|
||||
integer ierr
|
||||
|
||||
!!!! local vars
|
||||
integer ilocal(*)
|
||||
pointer (ip_local, ilocal)
|
||||
|
||||
integer i,clen,alen
|
||||
integer ilen,ityp,ierror
|
||||
integer icharlnf
|
||||
|
||||
!!!! begin
|
||||
ierr = 0
|
||||
clen=icharlnf(cmoname)
|
||||
alen=icharlnf(attname)
|
||||
|
||||
! WRITE(*,'(A,1X,A,1X,A)') &
|
||||
! 'fc_cmo_get_vint for cmo: ',cmoname(1:clen),attname(1:alen)
|
||||
|
||||
if (sizeof(ptr_int) .ne. 8) then
|
||||
print*,"ERROR: sizeof ptr_int not 8: ",sizeof(ptr_int)
|
||||
ierr= -1
|
||||
return
|
||||
endif
|
||||
if (sizeof(nlength) .ne. 8) then
|
||||
print*,"ERROR: sizeof nlength not 8: ",sizeof(nlength)
|
||||
ierr= -1
|
||||
return
|
||||
endif
|
||||
|
||||
call cmo_get_info(attname(1:alen),cmoname(1:clen), &
|
||||
ip_local,ilen,ityp,ierror)
|
||||
|
||||
! VINT pointer type 4 and length
|
||||
if (ityp.ne.4 .or. ilen.le.0) then
|
||||
WRITE(*,'(1X,A)')'Warning: VINT pointer type should be: 4'
|
||||
WRITE(*,'(1X,A,I3,I3)') &
|
||||
'Got type and length: ',ityp,ilen
|
||||
endif
|
||||
|
||||
if (ierror .ne. 0) then
|
||||
WRITE(*,'(1X,A)')'ERROR from cmo_get_attinfo: ',ierror
|
||||
return
|
||||
endif
|
||||
|
||||
nlength = ilen
|
||||
ptr_int = loc(ilocal)
|
||||
|
||||
!DEBUG WRITE(*,'(1X,A,5I6)') 'ilocal = ', (ilocal(i), i=1,5)
|
||||
! WRITE(*,'(1X,A,5I6)') 'ipointee = ', (ipointee(i), i=1,5)
|
||||
|
||||
return
|
||||
end subroutine fc_cmo_get_vint
|
||||
|
||||
!!! -------------------------------------------------------------------
|
||||
! get VDOUBLE pointer fc_cmo_get_vdouble
|
||||
! const char* cmo, const char* att,
|
||||
! double** iptr, long* nlen,
|
||||
! size_t cmolen, size_t attlen
|
||||
!!! -------------------------------------------------------------------
|
||||
|
||||
subroutine fc_cmo_get_vdouble( &
|
||||
cmoname,attname,ptr_dbl,nlength,ierr)
|
||||
|
||||
implicit none
|
||||
|
||||
!!!! arguments passed from C routine
|
||||
|
||||
character*(*) cmoname, attname
|
||||
pointer (ptr_dbl, xpointee)
|
||||
real*8 xpointee(*)
|
||||
integer nlength
|
||||
integer ierr
|
||||
|
||||
!!!! local vars
|
||||
real*8 xlocal(*)
|
||||
pointer (ip_local, xlocal)
|
||||
|
||||
integer i,clen,alen
|
||||
integer ilen,ityp,ierror
|
||||
integer icharlnf
|
||||
|
||||
!!!! begin
|
||||
ierr = 0
|
||||
clen=icharlnf(cmoname)
|
||||
alen=icharlnf(attname)
|
||||
|
||||
! WRITE(*,'(A,1X,A,1X,A)') &
|
||||
! 'fc_cmo_get_vdouble for cmo: ',cmoname(1:clen),attname(1:alen)
|
||||
|
||||
if (sizeof(ptr_dbl) .ne. 8) then
|
||||
print*,"ERROR: sizeof ptr_dbl not 8: ",sizeof(ptr_dbl)
|
||||
ierr= -1
|
||||
return
|
||||
endif
|
||||
if (sizeof(nlength) .ne. 8) then
|
||||
print*,"ERROR: sizeof nlength not 8: ",sizeof(nlength)
|
||||
ierr= -1
|
||||
return
|
||||
endif
|
||||
|
||||
call cmo_get_info(attname(1:alen),cmoname(1:clen), &
|
||||
ip_local,ilen,ityp,ierror)
|
||||
|
||||
! VDOUBLE pointer type 4 and length
|
||||
if (ityp.ne.4 .or. ilen.le.0) then
|
||||
WRITE(*,'(1X,A)')'Warning: VDOUBLE pointer type should be: 4'
|
||||
WRITE(*,'(1X,A,I3,I3)')&
|
||||
'Got type and length: ',ityp,ilen
|
||||
endif
|
||||
|
||||
if (ierror .ne. 0) then
|
||||
WRITE(*,'(1X,A)')'ERROR from cmo_get_attinfo: ',ierror
|
||||
return
|
||||
endif
|
||||
|
||||
nlength = ilen
|
||||
ptr_dbl = loc(xlocal)
|
||||
|
||||
!DEBUG WRITE(*,'(1X,A,5f5.2)') 'xlocal = ', (xlocal(i), i=1,5)
|
||||
! WRITE(*,'(1X,A,5f5.2)') 'xpointee = ', (xpointee(i), i=1,5)
|
||||
|
||||
return
|
||||
end subroutine fc_cmo_get_vdouble
|
||||
|
||||
!!! -------------------------------------------------------------------
|
||||
! fpass_types
|
||||
! test routine for passing scalars and pointers
|
||||
!
|
||||
! C++ declare:
|
||||
! void fpass_types_( double** xptr, long** iptr, long* nval, double* xval );
|
||||
!
|
||||
! C++ code section:
|
||||
! double xval = 0;
|
||||
! long nval = 0;
|
||||
! double *xptr;
|
||||
! long *iptr;
|
||||
! fpass_types_(&xptr, &iptr, &nval, &xval);
|
||||
! printf("*xptr = ");
|
||||
! for( i = 0; i < nval; i = i + 1 ){
|
||||
! printf(" %6.1f ", *(xptr+i));
|
||||
! }
|
||||
!!! -------------------------------------------------------------------
|
||||
|
||||
subroutine fpass_types(ptr_real, ptr_int, nval, xval)
|
||||
|
||||
implicit none
|
||||
|
||||
!!!! arguments passed from C main
|
||||
pointer (ptr_real, xpointee)
|
||||
real*8 xpointee(*)
|
||||
pointer (ptr_int, ipointee)
|
||||
integer ipointee(*)
|
||||
|
||||
integer nval
|
||||
real*8 xval
|
||||
|
||||
!!!! local vars
|
||||
integer i
|
||||
|
||||
real*8 xlocal(5)
|
||||
pointer (ptr_local, xlocal)
|
||||
|
||||
!!!! important, pointees need allocated data
|
||||
real*8 darray(5)
|
||||
integer iarray(5)
|
||||
data darray /0.0,1.0,2.0,3.0,4.0/
|
||||
data iarray /5,6,7,8,9/
|
||||
|
||||
!!!! begin
|
||||
|
||||
! assign array length and max value to passed vars
|
||||
nval=5
|
||||
xval=9.
|
||||
|
||||
print*,"sizeof ptr_local : ",sizeof(ptr_local)
|
||||
print*,"sizeof ptr_real : ",sizeof(ptr_real)
|
||||
print*,"sizeof ptr_int : ",sizeof(ptr_int)
|
||||
print*,"sizeof arg xval : ",sizeof(xval)
|
||||
print*,"sizeof arg nval : ",sizeof(nval)
|
||||
|
||||
WRITE(*,*)
|
||||
WRITE(*,'(1X,A,5F6.1)') 'the data: ', darray
|
||||
ptr_local = LOC(darray)
|
||||
ptr_real = LOC(darray)
|
||||
ptr_int = LOC(iarray)
|
||||
|
||||
! pointee declared size 5
|
||||
WRITE(*,'(1X,A,5F6.1)') 'xlocal = ', xlocal
|
||||
|
||||
! pointee declared unknown size
|
||||
WRITE(*,'(1X,A,5F6.1)') 'xpointee = ', (xpointee(i), i=1,5)
|
||||
WRITE(*,'(1X,A,5I6)') 'ipointee = ', (ipointee(i), i=1,5)
|
||||
|
||||
xval=xpointee(5)
|
||||
WRITE(*,'(1X,A,F6.1)') 'xval = ',xval
|
||||
WRITE(*,'(1X,A,I6)') 'nval = ',nval
|
||||
|
||||
return
|
||||
end subroutine fpass_types
|
||||
|
||||
Reference in New Issue
Block a user