mirror of
https://github.com/saitohirga/WSJT-X.git
synced 2024-11-25 13:48:42 -05:00
Merge branch 'feat-fst280' of bitbucket.org:k1jt/wsjtx into feat-fst280
This commit is contained in:
commit
d1012c9afb
@ -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
|
@ -539,11 +539,11 @@ contains
|
||||
endif
|
||||
if(iqorw.eq.1) then
|
||||
write(c77,'(77i1)') mod(message101(1:77)+rvec,2)
|
||||
call unpack77(c77,0,msg,unpk77_success)
|
||||
call unpack77(c77,1,msg,unpk77_success)
|
||||
else
|
||||
write(c77,'(50i1)') message74(1:50)
|
||||
c77(51:77)='000000000000000000000110000'
|
||||
call unpack77(c77,0,msg,unpk77_success)
|
||||
call unpack77(c77,1,msg,unpk77_success)
|
||||
endif
|
||||
if(unpk77_success) then
|
||||
idupe=0
|
||||
|
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)
|
||||
{
|
||||
|
@ -387,7 +387,8 @@ QString DisplayText::appendWorkedB4 (QString message, QString call, QString cons
|
||||
void DisplayText::displayDecodedText(DecodedText const& decodedText, QString const& myCall,
|
||||
QString const& mode,
|
||||
bool displayDXCCEntity, LogBook const& logBook,
|
||||
QString const& currentBand, bool ppfx, bool bCQonly)
|
||||
QString const& currentBand, bool ppfx, bool bCQonly,
|
||||
bool haveFSpread, float fSpread)
|
||||
{
|
||||
m_bPrincipalPrefix=ppfx;
|
||||
QColor bg;
|
||||
@ -421,6 +422,11 @@ void DisplayText::displayDecodedText(DecodedText const& decodedText, QString con
|
||||
QRegularExpression grid_regexp {"\\A(?![Rr]{2}73)[A-Ra-r]{2}[0-9]{2}([A-Xa-x]{2}){0,1}\\z"};
|
||||
if(!dxGrid.contains(grid_regexp)) dxGrid="";
|
||||
message = message.left (message.indexOf (QChar::Nbsp)); // strip appended info
|
||||
if (haveFSpread)
|
||||
{
|
||||
message += QString {37 - message.size (), QChar {' '}};
|
||||
message += QChar::Nbsp + QString {"%1"}.arg (fSpread, 5, 'f', fSpread < 0.95 ? 3 : 2);
|
||||
}
|
||||
m_CQPriority="";
|
||||
if (CQcall)
|
||||
{
|
||||
|
@ -30,7 +30,8 @@ public:
|
||||
void insertLineSpacer(QString const&);
|
||||
void displayDecodedText(DecodedText const& decodedText, QString const& myCall, QString const& mode,
|
||||
bool displayDXCCEntity, LogBook const& logBook,
|
||||
QString const& currentBand=QString {}, bool ppfx=false, bool bCQonly=false);
|
||||
QString const& currentBand=QString {}, bool ppfx=false, bool bCQonly=false,
|
||||
bool haveFSpread = false, float fSpread = 0.);
|
||||
void displayTransmittedText(QString text, QString modeTx, qint32 txFreq, bool bFastMode, double TRperiod);
|
||||
void displayQSY(QString text);
|
||||
void displayFoxToBeCalled(QString t, QColor bg = QColor {}, QColor fg = QColor {});
|
||||
|
@ -1796,7 +1796,7 @@ void MainWindow::on_actionSettings_triggered() //Setup Dialog
|
||||
|
||||
m_config.transceiver_online ();
|
||||
if(!m_bFastMode) setXIT (ui->TxFreqSpinBox->value ());
|
||||
if(m_config.single_decode() or m_mode=="JT4") {
|
||||
if ((m_config.single_decode () && !m_mode.startsWith ("FST240")) || m_mode=="JT4") {
|
||||
ui->label_6->setText(tr ("Single-Period Decodes"));
|
||||
ui->label_7->setText(tr ("Average Decodes"));
|
||||
}
|
||||
@ -3145,12 +3145,21 @@ void MainWindow::readFromStdout() //readFromStdout
|
||||
{
|
||||
while(proc_jt9.canReadLine()) {
|
||||
auto line_read = proc_jt9.readLine ();
|
||||
m_fSpread=line_read.mid(64,6).toFloat();
|
||||
line_read=line_read.left(64);
|
||||
if (auto p = std::strpbrk (line_read.constData (), "\n\r")) {
|
||||
// truncate before line ending chars
|
||||
line_read = line_read.left (p - line_read.constData ());
|
||||
}
|
||||
bool haveFSpread {false};
|
||||
float fSpread {0.};
|
||||
if (m_mode.startsWith ("FST240"))
|
||||
{
|
||||
auto text = line_read.mid (64, 6).trimmed ();
|
||||
if (text.size ())
|
||||
{
|
||||
fSpread = text.toFloat (&haveFSpread);
|
||||
line_read = line_read.left (64);
|
||||
}
|
||||
}
|
||||
if(m_mode!="FT8" and m_mode!="FT4") {
|
||||
//Pad 22-char msg to at least 37 chars
|
||||
line_read = line_read.left(44) + " " + line_read.mid(44);
|
||||
@ -3232,14 +3241,10 @@ void MainWindow::readFromStdout() //readFromStdout
|
||||
}
|
||||
} else {
|
||||
DecodedText decodedtext1=decodedtext0;
|
||||
if(m_mode.startsWith("FST240") and m_fSpread>0.0) {
|
||||
QString t=decodedtext0.string();
|
||||
DecodedText dt2 {QString {"%1%2%3"}.arg (t.left (46)).arg (m_fSpread, 5, 'f', m_fSpread < 0.95 ? 2 : 3).arg (t.mid(50)).trimmed ()};
|
||||
decodedtext1=dt2;
|
||||
}
|
||||
ui->decodedTextBrowser->displayDecodedText(decodedtext1,m_baseCall,m_mode,m_config.DXCC(),
|
||||
m_logBook,m_currentBand,m_config.ppfx(),
|
||||
(ui->cbCQonly->isVisible() and ui->cbCQonly->isChecked()));
|
||||
ui->cbCQonly->isVisible() && ui->cbCQonly->isChecked(),
|
||||
haveFSpread, fSpread);
|
||||
|
||||
if(m_bBestSPArmed and m_mode=="FT4") {
|
||||
QString messagePriority=ui->decodedTextBrowser->CQPriority();
|
||||
@ -4514,7 +4519,9 @@ void MainWindow::doubleClickOnCall(Qt::KeyboardModifiers modifiers)
|
||||
}
|
||||
return;
|
||||
}
|
||||
DecodedText message {cursor.block().text().trimmed().left(61).remove("TU; ")};
|
||||
QString t{cursor.block().text().trimmed().left(61).remove("TU; ")};
|
||||
t=t.left(46)+" "+t.mid(51);
|
||||
DecodedText message{t.trimmed()};
|
||||
m_bDoubleClicked = true;
|
||||
processMessage (message, modifiers);
|
||||
}
|
||||
|
@ -419,7 +419,6 @@ private:
|
||||
float m_t0Pick;
|
||||
float m_t1Pick;
|
||||
float m_fCPUmskrtd;
|
||||
float m_fSpread;
|
||||
|
||||
qint32 m_waterfallAvg;
|
||||
qint32 m_ntx;
|
||||
|
Loading…
Reference in New Issue
Block a user