mirror of
https://github.com/saitohirga/WSJT-X.git
synced 2024-11-21 19:55:20 -05:00
Improved C/Fortran string interoperation, and fix azel.dat updates
The azel.dat file is no longer written with future Doppler correction information designed for rigs that can't do CAT QSY commands while transmitting.
This commit is contained in:
Bill Somerville
parent
731dfc5c6f
commit
22f66795a1
@ -358,6 +358,8 @@ endif (WIN32)
|
||||
|
||||
set (wsjt_FSRCS
|
||||
# put module sources first in the hope that they get rebuilt before use
|
||||
lib/types.f90
|
||||
lib/C_interface_module.f90
|
||||
lib/shmem.f90
|
||||
lib/crc.f90
|
||||
lib/fftw3mod.f90
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
module astro_module
|
||||
use, intrinsic :: iso_c_binding, only : c_int, c_double, c_bool, c_char, c_ptr, c_size_t, c_f_pointer
|
||||
implicit none
|
||||
|
||||
private
|
||||
@ -7,50 +6,37 @@ module astro_module
|
||||
|
||||
contains
|
||||
|
||||
subroutine astrosub(nyear,month,nday,uth8,freq8,mygrid_cp,mygrid_len, &
|
||||
hisgrid_cp,hisgrid_len,AzSun8,ElSun8,AzMoon8,ElMoon8,AzMoonB8,ElMoonB8, &
|
||||
subroutine astrosub(nyear,month,nday,uth8,freq8,mygrid_cp, &
|
||||
hisgrid_cp,AzSun8,ElSun8,AzMoon8,ElMoon8,AzMoonB8,ElMoonB8, &
|
||||
ntsky,ndop,ndop00,RAMoon8,DecMoon8,Dgrd8,poloffset8,xnr8,techo8,width1, &
|
||||
width2,bTx,AzElFileName_cp,AzElFileName_len,jpleph_cp,jpleph_len) &
|
||||
width2,bTx,AzElFileName_cp,jpleph_file_name_cp) &
|
||||
bind (C, name="astrosub")
|
||||
|
||||
integer, parameter :: dp = selected_real_kind(15, 50)
|
||||
use :: types, only: dp
|
||||
use :: C_interface_module, only: C_int, C_double, C_bool, C_ptr, C_string_value, assignment(=)
|
||||
|
||||
integer(c_int), intent(in), value :: nyear, month, nday
|
||||
real(c_double), intent(in), value :: uth8, freq8
|
||||
real(c_double), intent(out) :: AzSun8, ElSun8, AzMoon8, ElMoon8, AzMoonB8, &
|
||||
integer(C_int), intent(in), value :: nyear, month, nday
|
||||
real(C_double), intent(in), value :: uth8, freq8
|
||||
real(C_double), intent(out) :: AzSun8, ElSun8, AzMoon8, ElMoon8, AzMoonB8, &
|
||||
ElMoonB8, Ramoon8, DecMoon8, Dgrd8, poloffset8, xnr8, techo8, width1, &
|
||||
width2
|
||||
integer(c_int), intent(out) :: ntsky, ndop, ndop00
|
||||
logical(c_bool), intent(in), value :: bTx
|
||||
type(c_ptr), intent(in), value :: mygrid_cp, hisgrid_cp, AzElFileName_cp, jpleph_cp
|
||||
integer(c_size_t), intent(in), value :: mygrid_len, hisgrid_len, AzElFileName_len, jpleph_len
|
||||
integer(C_int), intent(out) :: ntsky, ndop, ndop00
|
||||
logical(C_bool), intent(in), value :: bTx
|
||||
type(C_ptr), value, intent(in) :: mygrid_cp, hisgrid_cp, AzElFileName_cp, &
|
||||
jpleph_file_name_cp
|
||||
|
||||
character(len=6) :: mygrid, hisgrid
|
||||
character(kind=c_char, len=:), allocatable :: AzElFileName
|
||||
character(len=:), allocatable :: AzElFileName
|
||||
character(len=1) :: c1
|
||||
integer :: ih, im, imin, is, isec, nfreq, nRx
|
||||
real(dp) :: AzAux, ElAux, dbMoon8, dfdt, dfdt0, doppler, doppler00, HA8, sd8, xlst8
|
||||
character*256 jpleph_file_name
|
||||
common/jplcom/jpleph_file_name
|
||||
|
||||
block
|
||||
character(kind=c_char, len=mygrid_len), pointer :: mygrid_fp
|
||||
character(kind=c_char, len=hisgrid_len), pointer :: hisgrid_fp
|
||||
character(kind=c_char, len=AzElFileName_len), pointer :: AzElFileName_fp
|
||||
character(kind=c_char, len=jpleph_len), pointer :: jpleph_fp
|
||||
call c_f_pointer(cptr=mygrid_cp, fptr=mygrid_fp)
|
||||
mygrid = mygrid_fp
|
||||
mygrid_fp => null()
|
||||
call c_f_pointer(cptr=hisgrid_cp, fptr=hisgrid_fp)
|
||||
hisgrid = hisgrid_fp
|
||||
hisgrid_fp => null()
|
||||
call c_f_pointer(cptr=AzElFileName_cp, fptr=AzElFileName_fp)
|
||||
AzElFileName = AzElFileName_fp
|
||||
AzElFileName_fp => null()
|
||||
call c_f_pointer(cptr=jpleph_cp, fptr=jpleph_fp)
|
||||
jpleph_file_name = jpleph_fp
|
||||
jpleph_fp => null()
|
||||
end block
|
||||
mygrid = mygrid_cp
|
||||
hisgrid = hisgrid_cp
|
||||
AzElFileName = C_string_value (AzElFileName_cp)
|
||||
jpleph_file_name = jpleph_file_name_cp
|
||||
|
||||
call astro0(nyear,month,nday,uth8,freq8,mygrid,hisgrid, &
|
||||
AzSun8,ElSun8,AzMoon8,ElMoon8,AzMoonB8,ElMoonB8,ntsky,ndop,ndop00, &
|
||||
|
||||
441
lib/c_interface_module.f90
Normal file
441
lib/c_interface_module.f90
Normal file
@ -0,0 +1,441 @@
|
||||
! FILE: c_interface_module.f90
|
||||
! PURPOSE: Supplement ISO-C-Binding to provide type aliases and interfaces
|
||||
! to common ISO-C string functions to aid working with strings.
|
||||
! AUTHOR: Joseph M. Krahn
|
||||
! STATUS: Still in development. Reasonably complete, but somewhat limited testing.
|
||||
!
|
||||
! The idea is to provide type aliases for all ISO-C types, so that the
|
||||
! Fortran interface code more explicitly defines the actual C interface.
|
||||
! This should be updated to support F2008 variable-length allocatable
|
||||
! strings.
|
||||
!
|
||||
! Entity names all have the "C_" prefix, as with ISO-C-Binding, with a
|
||||
! few exceptions.
|
||||
!
|
||||
! Sourced from: http://fortranwiki.org/fortran/show/c_interface_module
|
||||
!
|
||||
! One FORALL statement reverted to a DO loop to avoid a gfortran 4.9.2 ICE
|
||||
!
|
||||
module C_interface_module
|
||||
use, intrinsic :: ISO_C_Binding, &
|
||||
! C type aliases for pointer derived types:
|
||||
C_ptr => C_ptr , &
|
||||
C_char_ptr => C_ptr, &
|
||||
C_const_char_ptr => C_ptr, &
|
||||
C_void_ptr => C_ptr, &
|
||||
C_const_void_ptr => C_ptr
|
||||
|
||||
implicit none
|
||||
public
|
||||
|
||||
!----------------------------------------------------------------------------
|
||||
! C type aliases for intrinsic type KIND parameters:
|
||||
|
||||
! NOTE: a C enum may not always be a standard C int
|
||||
integer, parameter :: C_enum = C_int
|
||||
|
||||
! Defining off_t is difficult, because it may depend on "LARGEFILE" selection.
|
||||
! integer, parameter :: C_off_t = ??
|
||||
|
||||
! C string terminator alais using the 3-letter ASCII name.
|
||||
! The C_ prefix is not used because it is just an ASCII character.
|
||||
character(len=1,kind=C_char), parameter :: NUL = C_NULL_char
|
||||
|
||||
! NOTE: In C, "char" is distinct from "signed char", unlike integers.
|
||||
! The plain "char" type is specific for text/string values, whereas
|
||||
! "signed char" should indicate 1-byte integer data.
|
||||
!
|
||||
! Most ISO-C systems have wide chars "wchar_t", but Fortran compilers
|
||||
! have limited support for different character kinds. UTF encoding
|
||||
! adds more complexity. This should be updated as Fortran compilers
|
||||
! include support for more character types.
|
||||
!
|
||||
|
||||
! Fortran does not (yet) support unsigned types.
|
||||
integer, parameter :: &
|
||||
C_unsigned = C_int, &
|
||||
C_unsigned_short = C_short, &
|
||||
C_unsigned_long = C_long, &
|
||||
C_unsigned_long_long = C_long_long, &
|
||||
C_unsigned_char = C_signed_char, &
|
||||
C_ssize_t = C_size_t, &
|
||||
C_uint8_t = C_int8_t, &
|
||||
C_uint16_t = C_int16_t, &
|
||||
C_uint32_t = C_int32_t, &
|
||||
C_uint64_t = C_int64_t, &
|
||||
C_uint_least8_t = C_int_least8_t, &
|
||||
C_uint_least16_t = C_int_least16_t, &
|
||||
C_uint_least32_t = C_int_least32_t, &
|
||||
C_uint_least64_t = C_int_least64_t, &
|
||||
C_uint_fast8_t = C_int_fast8_t, &
|
||||
C_uint_fast16_t = C_int_fast16_t, &
|
||||
C_uint_fast32_t = C_int_fast32_t, &
|
||||
C_uint_fast64_t = C_int_fast64_t, &
|
||||
C_uintmax_t = C_intmax_t
|
||||
! Note: ptrdiff_t cannot be reliably defined from other types.
|
||||
! When practical, it is larger than a pointer because it benefits
|
||||
! from the full unsigned range in both positive and negative directions.
|
||||
|
||||
! Integer versions including 'int', where the 'int' is optional:
|
||||
integer, parameter :: &
|
||||
C_short_int = C_short, &
|
||||
C_long_int = C_long, &
|
||||
C_long_long_int = C_long_long, &
|
||||
C_unsigned_int = C_unsigned, &
|
||||
C_unsigned_short_int = C_short, &
|
||||
C_unsigned_long_int = C_long, &
|
||||
C_unsigned_long_long_int = C_long_long
|
||||
|
||||
interface C_F_string
|
||||
module procedure C_F_string_ptr
|
||||
module procedure C_F_string_chars
|
||||
end interface C_F_string
|
||||
|
||||
interface F_C_string
|
||||
module procedure F_C_string_ptr
|
||||
module procedure F_C_string_chars
|
||||
end interface F_C_string
|
||||
|
||||
!=======================================================================
|
||||
! Some useful ISO C library string functions from <string.h>
|
||||
! These are based on GCC header sections marked as NAMESPACE_STD
|
||||
interface
|
||||
|
||||
! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed.
|
||||
! extern void *memcpy (void *dest, const void *src, size_t n);
|
||||
function C_memcpy(dest, src, n) result(result) bind(C,name="memcpy")
|
||||
import C_void_ptr, C_size_t
|
||||
type(C_void_ptr) :: result
|
||||
type(C_void_ptr), value, intent(in) :: dest ! target=intent(out)
|
||||
type(C_void_ptr), value, intent(in) :: src ! target=intent(in)
|
||||
integer(C_size_t), value, intent(in) :: n
|
||||
end function C_memcpy
|
||||
|
||||
! Copy N bytes of SRC to DEST, guaranteeing correct behavior for overlapping strings.
|
||||
!extern void *memmove (void *dest, const void *src, size_t n)
|
||||
function C_memmove(dest, src, n) result(result) bind(C,name="memmove")
|
||||
import C_void_ptr, C_size_t
|
||||
type(C_void_ptr) :: result
|
||||
type(C_void_ptr), value, intent(in) :: dest ! target=intent(out)
|
||||
type(C_void_ptr), value, intent(in) :: src
|
||||
integer(C_size_t), value, intent(in) :: n
|
||||
end function C_memmove
|
||||
|
||||
! Set N bytes of S to C.
|
||||
!extern void *memset (void *s, int c, size_t n)
|
||||
function C_memset(s, c, n) result(result) bind(C,name="memset")
|
||||
import C_void_ptr, C_int, C_size_t
|
||||
type(C_void_ptr) :: result
|
||||
type(C_void_ptr), value, intent(in) :: s ! target=intent(out)
|
||||
integer(C_int), value, intent(in) :: c
|
||||
integer(C_size_t), value, intent(in) :: n
|
||||
end function C_memset
|
||||
|
||||
! Compare N bytes of S1 and S2.
|
||||
!extern int memcmp (const void *s1, const void *s2, size_t n)
|
||||
pure function C_memcmp(s1, s2, n) result(result) bind(C,name="memcmp")
|
||||
import C_int, C_void_ptr, C_size_t
|
||||
integer(C_int) :: result
|
||||
type(C_void_ptr), value, intent(in) :: s1
|
||||
type(C_void_ptr), value, intent(in) :: s2
|
||||
integer(C_size_t), value, intent(in) :: n
|
||||
end function C_memcmp
|
||||
|
||||
! Search N bytes of S for C.
|
||||
!extern void *memchr (const void *s, int c, size_t n)
|
||||
pure function C_memchr(s, c, n) result(result) bind(C,name="memchr")
|
||||
import C_void_ptr, C_int, C_size_t
|
||||
type(C_void_ptr) :: result
|
||||
type(C_void_ptr), value, intent(in) :: s
|
||||
integer(C_int), value, intent(in) :: c
|
||||
integer(C_size_t), value, intent(in) :: n
|
||||
end function C_memchr
|
||||
|
||||
! Copy SRC to DEST.
|
||||
!extern char *strcpy (char *dest, const char *src)
|
||||
function C_strcpy(dest, src) result(result) bind(C,name="strcpy")
|
||||
import C_char_ptr, C_size_t
|
||||
type(C_char_ptr) :: result
|
||||
type(C_char_ptr), value, intent(in) :: dest ! target=intent(out)
|
||||
type(C_char_ptr), value, intent(in) :: src
|
||||
end function C_strcpy
|
||||
|
||||
! Copy no more than N characters of SRC to DEST.
|
||||
!extern char *strncpy (char *dest, const char *src, size_t n)
|
||||
function C_strncpy(dest, src, n) result(result) bind(C,name="strncpy")
|
||||
import C_char_ptr, C_size_t
|
||||
type(C_char_ptr) :: result
|
||||
type(C_char_ptr), value, intent(in) :: dest ! target=intent(out)
|
||||
type(C_char_ptr), value, intent(in) :: src
|
||||
integer(C_size_t), value, intent(in) :: n
|
||||
end function C_strncpy
|
||||
|
||||
! Append SRC onto DEST.
|
||||
!extern char *strcat (char *dest, const char *src)
|
||||
function C_strcat(dest, src) result(result) bind(C,name="strcat")
|
||||
import C_char_ptr, C_size_t
|
||||
type(C_char_ptr) :: result
|
||||
type(C_char_ptr), value, intent(in) :: dest ! target=intent(out)
|
||||
type(C_char_ptr), value, intent(in) :: src
|
||||
end function C_strcat
|
||||
|
||||
! Append no more than N characters from SRC onto DEST.
|
||||
!extern char *strncat (char *dest, const char *src, size_t n)
|
||||
function C_strncat(dest, src, n) result(result) bind(C,name="strncat")
|
||||
import C_char_ptr, C_size_t
|
||||
type(C_char_ptr) :: result
|
||||
type(C_char_ptr), value, intent(in) :: dest ! target=intent(out)
|
||||
type(C_char_ptr), value, intent(in) :: src
|
||||
integer(C_size_t), value, intent(in) :: n
|
||||
end function C_strncat
|
||||
|
||||
! Compare S1 and S2.
|
||||
!extern int strcmp (const char *s1, const char *s2)
|
||||
pure function C_strcmp(s1, s2) result(result) bind(C,name="strcmp")
|
||||
import C_int, C_char_ptr, C_size_t
|
||||
integer(C_int) :: result
|
||||
type(C_char_ptr), value, intent(in) :: s1
|
||||
type(C_char_ptr), value, intent(in) :: s2
|
||||
end function C_strcmp
|
||||
|
||||
! Compare N characters of S1 and S2.
|
||||
!extern int strncmp (const char *s1, const char *s2, size_t n)
|
||||
pure function C_strncmp(s1, s2, n) result(result) bind(C,name="strncmp")
|
||||
import C_int, C_char_ptr, C_size_t
|
||||
integer(C_int) :: result
|
||||
type(C_char_ptr), value, intent(in) :: s1
|
||||
type(C_char_ptr), value, intent(in) :: s2
|
||||
integer(C_size_t), value, intent(in) :: n
|
||||
end function C_strncmp
|
||||
|
||||
! Return the length of S.
|
||||
!extern size_t strlen (const char *s)
|
||||
pure function C_strlen(s) result(result) bind(C,name="strlen")
|
||||
import C_char_ptr, C_size_t
|
||||
integer(C_size_t) :: result
|
||||
type(C_char_ptr), value, intent(in) :: s !character(len=*), intent(in)
|
||||
end function C_strlen
|
||||
|
||||
end interface
|
||||
|
||||
! End of <string.h>
|
||||
!=========================================================================
|
||||
! Standard ISO-C malloc routines:
|
||||
interface
|
||||
|
||||
! void *calloc(size_t nmemb, size_t size);
|
||||
type(C_void_ptr) function C_calloc(nmemb, size) bind(C,name="calloc")
|
||||
import C_void_ptr, C_size_t
|
||||
integer(C_size_t), value, intent(in) :: nmemb, size
|
||||
end function C_calloc
|
||||
|
||||
! void *malloc(size_t size);
|
||||
type(C_void_ptr) function C_malloc(size) bind(C,name="malloc")
|
||||
import C_void_ptr, C_size_t
|
||||
integer(C_size_t), value, intent(in) :: size
|
||||
end function C_malloc
|
||||
|
||||
! void free(void *ptr);
|
||||
subroutine C_free(ptr) bind(C,name="free")
|
||||
import C_void_ptr
|
||||
type(C_void_ptr), value, intent(in) :: ptr
|
||||
end subroutine C_free
|
||||
|
||||
! void *realloc(void *ptr, size_t size);
|
||||
type(C_void_ptr) function C_realloc(ptr,size) bind(C,name="realloc")
|
||||
import C_void_ptr, C_size_t
|
||||
type(C_void_ptr), value, intent(in) :: ptr
|
||||
integer(C_size_t), value, intent(in) :: size
|
||||
end function C_realloc
|
||||
|
||||
end interface
|
||||
|
||||
interface assignment(=)
|
||||
module procedure F_string_assign_C_string
|
||||
end interface assignment(=)
|
||||
|
||||
!==========================================================================
|
||||
|
||||
contains
|
||||
|
||||
! HACK: For some reason, C_associated was not defined as pure.
|
||||
pure logical function C_associated_pure(ptr) result(associated)
|
||||
type(C_ptr), intent(in) :: ptr
|
||||
integer(C_intptr_t) :: iptr
|
||||
iptr = transfer(ptr,iptr)
|
||||
associated = (iptr /= 0)
|
||||
end function C_associated_pure
|
||||
|
||||
! Set a fixed-length Fortran string to the value of a C string.
|
||||
subroutine F_string_assign_C_string(F_string, C_string)
|
||||
character(len=*), intent(out) :: F_string
|
||||
type(C_ptr), intent(in) :: C_string
|
||||
character(len=1,kind=C_char), pointer :: p_chars(:)
|
||||
integer :: i
|
||||
if (.not. C_associated(C_string) ) then
|
||||
F_string = ' '
|
||||
else
|
||||
call C_F_pointer(C_string,p_chars,[huge(0)])
|
||||
i=1
|
||||
do while(p_chars(i)/=NUL .and. i<=len(F_string))
|
||||
F_string(i:i) = p_chars(i)
|
||||
i=i+1
|
||||
end do
|
||||
if (i<len(F_string)) F_string(i:) = ' '
|
||||
end if
|
||||
end subroutine F_string_assign_C_string
|
||||
|
||||
! Copy a C string, passed by pointer, to a Fortran string.
|
||||
! If the C pointer is NULL, the Fortran string is blanked.
|
||||
! C_string must be NUL terminated, or at least as long as F_string.
|
||||
! If C_string is longer, it is truncated. Otherwise, F_string is
|
||||
! blank-padded at the end.
|
||||
subroutine C_F_string_ptr(C_string, F_string)
|
||||
type(C_ptr), intent(in) :: C_string
|
||||
character(len=*), intent(out) :: F_string
|
||||
character(len=1,kind=C_char), dimension(:), pointer :: p_chars
|
||||
integer :: i
|
||||
if (.not. C_associated(C_string)) then
|
||||
F_string = ' '
|
||||
else
|
||||
call C_F_pointer(C_string,p_chars,[huge(0)])
|
||||
i=1
|
||||
do while(p_chars(i)/=NUL .and. i<=len(F_string))
|
||||
F_string(i:i) = p_chars(i)
|
||||
i=i+1
|
||||
end do
|
||||
if (i<len(F_string)) F_string(i:) = ' '
|
||||
end if
|
||||
end subroutine C_F_string_ptr
|
||||
|
||||
! Copy a C string, passed as a char-array reference, to a Fortran string.
|
||||
subroutine C_F_string_chars(C_string, F_string)
|
||||
character(len=1,kind=C_char), intent(in) :: C_string(*)
|
||||
character(len=*), intent(out) :: F_string
|
||||
integer :: i
|
||||
i=1
|
||||
do while(C_string(i)/=NUL .and. i<=len(F_string))
|
||||
F_string(i:i) = C_string(i)
|
||||
i=i+1
|
||||
end do
|
||||
if (i<len(F_string)) F_string(i:) = ' '
|
||||
end subroutine C_F_string_chars
|
||||
|
||||
! Copy a Fortran string to an allocated C string pointer.
|
||||
! If the C pointer is NULL, no action is taken. (Maybe auto allocate via libc call?)
|
||||
! If the length is not passed, the C string must be at least: len(F_string)+1
|
||||
! If the length is passed and F_string is too long, it is truncated.
|
||||
subroutine F_C_string_ptr(F_string, C_string, C_string_len)
|
||||
character(len=*), intent(in) :: F_string
|
||||
type(C_ptr), intent(in) :: C_string ! target = intent(out)
|
||||
integer, intent(in), optional :: C_string_len ! Max string length,
|
||||
! INCLUDING THE TERMINAL NUL
|
||||
character(len=1,kind=C_char), dimension(:), pointer :: p_chars
|
||||
integer :: i, strlen
|
||||
strlen = len(F_string)
|
||||
if (present(C_string_len)) then
|
||||
if (C_string_len <= 0) return
|
||||
strlen = min(strlen,C_string_len)
|
||||
end if
|
||||
if (.not. C_associated(C_string)) then
|
||||
return
|
||||
end if
|
||||
call C_F_pointer(C_string,p_chars,[strlen+1])
|
||||
forall (i=1:strlen)
|
||||
p_chars(i) = F_string(i:i)
|
||||
end forall
|
||||
p_chars(strlen+1) = NUL
|
||||
end subroutine F_C_string_ptr
|
||||
|
||||
pure function C_strlen_safe(s) result(length)
|
||||
integer(C_size_t) :: length
|
||||
type(C_char_ptr), value, intent(in) :: s
|
||||
if (.not. C_associated_pure(s)) then
|
||||
length = 0
|
||||
else
|
||||
length = C_strlen(s)
|
||||
end if
|
||||
end function C_strlen_safe
|
||||
|
||||
function C_string_value(C_string) result(F_string)
|
||||
type(C_ptr), intent(in) :: C_string
|
||||
character(len=C_strlen_safe(C_string)) :: F_string
|
||||
character(len=1,kind=C_char), dimension(:), pointer :: p_chars
|
||||
integer :: i, length
|
||||
length = len(F_string)
|
||||
if (length/=0) then
|
||||
call C_F_pointer(C_string,p_chars,[length])
|
||||
forall (i=1:length)
|
||||
F_string(i:i) = p_chars(i)
|
||||
end forall
|
||||
end if
|
||||
end function C_string_value
|
||||
|
||||
! Copy a Fortran string to a C string passed by char-array reference.
|
||||
! If the length is not passed, the C string must be at least: len(F_string)+1
|
||||
! If the length is passed and F_string is too long, it is truncated.
|
||||
subroutine F_C_string_chars(F_string, C_string, C_string_len)
|
||||
character(len=*), intent(in) :: F_string
|
||||
character(len=1,kind=C_char), dimension(*), intent(out) :: C_string
|
||||
integer, intent(in), optional :: C_string_len ! Max string length,
|
||||
! INCLUDING THE TERMINAL NUL
|
||||
integer :: i, strlen
|
||||
strlen = len(F_string)
|
||||
if (present(C_string_len)) then
|
||||
if (C_string_len <= 0) return
|
||||
strlen = min(strlen,C_string_len)
|
||||
end if
|
||||
forall (i=1:strlen)
|
||||
C_string(i) = F_string(i:i)
|
||||
end forall
|
||||
C_string(strlen+1) = NUL
|
||||
end subroutine F_C_string_chars
|
||||
|
||||
! NOTE: Strings allocated here must be freed by the
|
||||
! C library, such as via C_free() or C_string_free(),
|
||||
type(C_ptr) function F_C_string_dup(F_string,length) result(C_string)
|
||||
character(len=*), intent(in) :: F_string
|
||||
integer, intent(in), optional :: length
|
||||
character(len=1,kind=C_char), pointer :: C_string_ptr(:)
|
||||
integer :: i
|
||||
integer(C_size_t) :: strlen
|
||||
if (present(length)) then
|
||||
strlen = length
|
||||
else
|
||||
strlen = len(F_string)
|
||||
end if
|
||||
if (strlen <= 0) then
|
||||
C_string = C_NULL_ptr
|
||||
else
|
||||
C_string = C_malloc(strlen+1)
|
||||
if (C_associated(C_string)) then
|
||||
call C_F_pointer(C_string,C_string_ptr,[strlen+1])
|
||||
forall (i=1:strlen)
|
||||
C_string_ptr(i) = F_string(i:i)
|
||||
end forall
|
||||
C_string_ptr(strlen+1) = NUL
|
||||
end if
|
||||
end if
|
||||
end function F_C_string_dup
|
||||
|
||||
! NOTE: Strings allocated here must be freed by the
|
||||
! C library, such as via C_free() or C_string_free(),
|
||||
type(C_ptr) function C_string_alloc(length) result(C_string)
|
||||
integer(C_size_t), intent(in) :: length
|
||||
character(len=1,kind=C_char), pointer :: C_charptr
|
||||
C_string = C_malloc(length+1)
|
||||
if (C_associated(C_string)) then
|
||||
call C_F_pointer(C_string,C_charptr)
|
||||
C_charptr = NUL
|
||||
end if
|
||||
end function C_string_alloc
|
||||
|
||||
subroutine C_string_free(string)
|
||||
type(C_ptr), intent(inout) :: string
|
||||
if (C_associated(string)) then
|
||||
call C_free(string)
|
||||
string = C_NULL_ptr
|
||||
end if
|
||||
end subroutine C_string_free
|
||||
|
||||
end module C_interface_module
|
||||
10
lib/types.f90
Normal file
10
lib/types.f90
Normal file
@ -0,0 +1,10 @@
|
||||
module types
|
||||
use, intrinsic :: iso_fortran_env
|
||||
implicit none
|
||||
|
||||
! use the Fortran 2008 intrinsic constants to define real kinds
|
||||
integer, parameter :: sp = REAL32
|
||||
integer, parameter :: dp = REAL64
|
||||
integer, parameter :: qp = REAL128
|
||||
|
||||
end module types
|
||||
@ -25,13 +25,13 @@
|
||||
|
||||
extern "C" {
|
||||
void astrosub(int nyear, int month, int nday, double uth, double freqMoon,
|
||||
const char * mygrid, size_t mygrid_len, const char * hisgrid,
|
||||
size_t hisgrid_len, double * azsun, double * elsun, double * azmoon,
|
||||
const char * mygrid, const char * hisgrid,
|
||||
double * azsun, double * elsun, double * azmoon,
|
||||
double * elmoon, double * azmoondx, double * elmoondx, int * ntsky,
|
||||
int * ndop, int * ndop00, double * ramoon, double * decmoon, double * dgrd,
|
||||
double * poloffset, double * xnr, double * techo, double * width1,
|
||||
double * width2, bool bTx, const char * AzElFileName, size_t AzElFileName_len,
|
||||
const char * jpleph, size_t jpleph_len);
|
||||
double * width2, bool bTx, const char * AzElFileName,
|
||||
const char * jpleph);
|
||||
}
|
||||
|
||||
Astro::Astro(QSettings * settings, Configuration const * configuration, QWidget * parent)
|
||||
@ -112,14 +112,14 @@ auto Astro::astroUpdate(QDateTime const& t, QString const& mygrid, QString const
|
||||
auto const& jpleph = configuration_->data_dir ().absoluteFilePath ("JPLEPH");
|
||||
|
||||
astrosub(nyear, month, nday, uth, static_cast<double> (freq_moon),
|
||||
mygrid.toLatin1 ().constData (), mygrid.size (),
|
||||
hisgrid.toLatin1().constData(), hisgrid.size (),
|
||||
mygrid.toLatin1 ().data (),
|
||||
hisgrid.toLatin1().data(),
|
||||
&azsun, &elsun, &azmoon, &elmoon,
|
||||
&azmoondx, &elmoondx, &ntsky, &m_dop, &m_dop00, &ramoon, &decmoon,
|
||||
&dgrd, &poloffset, &xnr, &techo, &width1, &width2,
|
||||
bTx,
|
||||
AzElFileName.toLatin1().constData(), AzElFileName.size (),
|
||||
jpleph.toLatin1().constData(), jpleph.size ());
|
||||
AzElFileName.toLatin1().data(),
|
||||
jpleph.toLatin1().data());
|
||||
|
||||
if(!hisgrid.size ()) {
|
||||
azmoondx=0.0;
|
||||
@ -224,14 +224,14 @@ auto Astro::astroUpdate(QDateTime const& t, QString const& mygrid, QString const
|
||||
double sec {target_date_time.time().second() + 0.001*target_date_time.time().msec()};
|
||||
double uth {nhr + nmin/60.0 + sec/3600.0};
|
||||
astrosub(nyear, month, nday, uth, static_cast<double> (freq_moon),
|
||||
mygrid.toLatin1 ().constData (), mygrid.size (),
|
||||
hisgrid.toLatin1().constData(), hisgrid.size (),
|
||||
mygrid.toLatin1 ().data (),
|
||||
hisgrid.toLatin1().data(),
|
||||
&azsun, &elsun, &azmoon, &elmoon,
|
||||
&azmoondx, &elmoondx, &ntsky, &m_dop, &m_dop00, &ramoon, &decmoon,
|
||||
&dgrd, &poloffset, &xnr, &techo, &width1, &width2,
|
||||
bTx,
|
||||
AzElFileName.toLatin1().constData(), AzElFileName.size (),
|
||||
jpleph.toLatin1().constData(), jpleph.size ());
|
||||
nullptr, // don't overwrite azel.dat
|
||||
jpleph.toLatin1().data());
|
||||
FrequencyDelta offset {0};
|
||||
switch (m_DopplerMethod)
|
||||
{
|
||||
|
||||
Loading…
Reference in New Issue
Block a user