mirror of
				https://github.com/saitohirga/WSJT-X.git
				synced 2025-10-30 20:40:28 -04: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())); | ||||
|                                                      m_logBook,m_currentBand,m_config.ppfx(), | ||||
|                                                      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…
	
	
			
			x
			
			
		
	
		Reference in New Issue
	
	Block a user