comicsansg
/
ft8d
mirror of https://github.com/pavel-demin/ft8d.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

port changes from WSJT-X 2.1.2

This commit is contained in:
Pavel Demin 2020-06-25 10:00:22 +00:00
parent d9e0de9a58
commit e7eaa44adf
13 changed files with 212 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Makefile
View File

@ -1,11 +1,11 @@
TARGET = ft8d
OBJECTS = \
crc14.o crc.o ft8_downsample.o sync8d.o sync8.o grid2deg.o four2a.o \
deg2grid.o determ.o fftw3mod.o baseline.o bpdecode174_91.o fmtmsg.o \
packjt.o chkcrc14a.o indexx.o shell.o pctile.o polyfit.o twkfreq1.o \
osd174_91.o encode174_91.o chkcall.o packjt77.o genft8.o genft8refsig.o \
subtractft8.o ft8b.o ft8d.o
crc14.o crc.o ft8_downsample.o sync8d.o sync8.o grid2deg.o fftw3mod.o \
four2a.o deg2grid.o determ.o baseline.o platanh.o bpdecode174_91.o \
fmtmsg.o packjt.o chkcrc14a.o indexx.o shell.o pctile.o polyfit.o \
twkfreq1.o osd174_91.o encode174_91.o chkcall.o packjt77.o genft8.o \
gfsk_pulse.o gen_ft8wave.o subtractft8.o ft8b.o ft8d.o
CC = gcc
FC = gfortran

25
bpdecode174_91.f90
View File

@ -1,28 +1,3 @@
subroutine platanh(x,y)
isign=+1
z=x
if( x.lt.0 ) then
isign=-1
z=abs(x)
endif
if( z.le. 0.664 ) then
y=x/0.83
return
elseif( z.le. 0.9217 ) then
y=isign*(z-0.4064)/0.322
return
elseif( z.le. 0.9951 ) then
y=isign*(z-0.8378)/0.0524
return
elseif( z.le. 0.9998 ) then
y=isign*(z-0.9914)/0.0012
return
else
y=isign*7.0
return
endif
end subroutine platanh
subroutine bpdecode174_91(llr,apmask,maxiterations,message77,cw,nharderror,iter)
!
! A log-domain belief propagation decoder for the (174,91) code.

4
four2a.f90
View File

@ -19,6 +19,7 @@ subroutine four2a(a,nfft,ndim,isign,iform)
! This version of four2a makes calls to the FFTW library to do the
! actual computations.
use fftw3
parameter (NPMAX=2100) !Max numberf of stored plans
parameter (NSMALL=16384) !Max size of "small" FFTs
complex a(nfft) !Array to be transformed
@ -29,7 +30,6 @@ subroutine four2a(a,nfft,ndim,isign,iform)
logical found_plan
data nplan/0/ !Number of stored plans
common/patience/npatience,nthreads !Patience and threads for FFTW plans
include 'fftw3.f90' !FFTW definitions
save plan,nplan,nn,ns,nf,nl
if(nfft.lt.0) go to 999
@ -107,7 +107,7 @@ subroutine four2a(a,nfft,ndim,isign,iform)
!$omp end critical(fftw)
end if
enddo
call fftwf_cleanup()
nplan=0
!$omp end critical(four2a)

2
ft8b.f90
View File

@ -387,7 +387,7 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
cycle
endif
nbadcrc=0 ! If we get this far: valid codeword, valid (i3,n3), nonquirky message.
call get_tones_from_77bits(message77,itone)
call get_ft8_tones_from_77bits(message77,itone)
if(lsubtract) call subtractft8(dd0,itone,f1,xdt)
xsig=0.0
xnoi=0.0

6
ft8d.f90
View File

@ -13,7 +13,11 @@ program ft8d
complex dd(NMAX,4)
logical newdat,lft8apon,lsubtract,ldupe
integer allsnrs(100)
integer apsym(KK)
integer apsym(58)
apsym=0
apsym(1)=99
apsym(30)=99
nargs=iargc()
if(nargs.ne.1) then

74
gen_ft8wave.f90 Normal file
View File

@ -0,0 +1,74 @@
subroutine gen_ft8wave(itone,nsym,nsps,bt,fsample,f0,cwave,wave,icmplx,nwave)
!
! generate ft8 waveform using Gaussian-filtered frequency pulses.
!
parameter(MAX_SECONDS=20)
real wave(nwave)
complex cwave(nwave)
real pulse(23040)
real dphi(0:(nsym+2)*nsps-1)
integer itone(nsym)
data ibt0/0/
save pulse,twopi,dt,hmod,ibt0
ibt=nint(10*bt)
if(ibt0.ne.ibt) then
twopi=8.0*atan(1.0)
dt=1.0/fsample
hmod=1.0
! Compute the frequency-smoothing pulse
do i=1,3*nsps
tt=(i-1.5*nsps)/real(nsps)
pulse(i)=gfsk_pulse(bt,tt)
enddo
ibt0=nint(10*bt)
endif
! Compute the smoothed frequency waveform.
! Length = (nsym+2)*nsps samples, first and last symbols extended
dphi_peak=twopi*hmod/real(nsps)
dphi=0.0
do j=1,nsym
ib=(j-1)*nsps
ie=ib+3*nsps-1
dphi(ib:ie) = dphi(ib:ie) + dphi_peak*pulse(1:3*nsps)*itone(j)
enddo
! Add dummy symbols at beginning and end with tone values equal to 1st and last symbol, respectively
dphi(0:2*nsps-1)=dphi(0:2*nsps-1)+dphi_peak*itone(1)*pulse(nsps+1:3*nsps)
dphi(nsym*nsps:(nsym+2)*nsps-1)=dphi(nsym*nsps:(nsym+2)*nsps-1)+dphi_peak*itone(nsym)*pulse(1:2*nsps)
! Calculate and insert the audio waveform
phi=0.0
dphi = dphi + twopi*f0*dt !Shift frequency up by f0
wave=0.
if (icmplx .ne. 0) cwave=0. ! avoid writing to memory we may not have access to
k=0
do j=nsps,nsps+nwave-1 !Don't include dummy symbols
k=k+1
if(icmplx.eq.0) then
wave(k)=sin(phi)
else
cwave(k)=cmplx(cos(phi),sin(phi))
endif
phi=mod(phi+dphi(j),twopi)
enddo
! Apply envelope shaping to the first and last symbols
nramp=nint(nsps/8.0)
if(icmplx.eq.0) then
wave(1:nramp)=wave(1:nramp) * &
(1.0-cos(twopi*(/(i,i=0,nramp-1)/)/(2.0*nramp)))/2.0
k1=nsym*nsps-nramp+1
wave(k1:k1+nramp-1)=wave(k1:k1+nramp-1) * &
(1.0+cos(twopi*(/(i,i=0,nramp-1)/)/(2.0*nramp)))/2.0
else
cwave(1:nramp)=cwave(1:nramp) * &
(1.0-cos(twopi*(/(i,i=0,nramp-1)/)/(2.0*nramp)))/2.0
k1=nsym*nsps-nramp+1
cwave(k1:k1+nramp-1)=cwave(k1:k1+nramp-1) * &
(1.0+cos(twopi*(/(i,i=0,nramp-1)/)/(2.0*nramp)))/2.0
endif
return
end subroutine gen_ft8wave

2
genft8.f90
View File

@ -25,7 +25,7 @@ subroutine genft8(msg,i3,n3,msgsent,msgbits,itone)
msgsent='*** bad message *** '
go to 900
entry get_tones_from_77bits(msgbits,itone)
entry get_ft8_tones_from_77bits(msgbits,itone)
2 call encode174_91(msgbits,codeword) !Encode the test message

23
genft8refsig.f90
View File

@ -1,23 +0,0 @@
subroutine genft8refsig(itone,cref,f0)
complex cref(79*640)
integer itone(79)
! real*8 twopi,phi,dphi,dt,xnsps
real twopi,phi,dphi,dt,xnsps
data twopi/0.d0/
save twopi
if( twopi .lt. 0.1 ) twopi=8.d0*atan(1.d0)
xnsps=640.d0
dt=1.d0/4000.d0
phi=0.d0
k=1
do i=1,79
dphi=twopi*(f0*dt+itone(i)/xnsps)
do is=1,640
cref(k)=cmplx(cos(phi),sin(phi))
phi=mod(phi+dphi,twopi)
k=k+1
enddo
enddo
return
end subroutine genft8refsig

6
gfsk_pulse.f90 Normal file
View File

@ -0,0 +1,6 @@
real function gfsk_pulse(b,t)
pi=4.*atan(1.0)
c=pi*sqrt(2.0/log(2.0))
gfsk_pulse=0.5*(erf(c*b*(t+0.5))-erf(c*b*(t-0.5)))
return
end function gfsk_pulse

89
packjt77.f90
View File

@ -172,6 +172,10 @@ subroutine pack77(msg0,i3,n3,c77)
call pack77_4(nwords,w,i3,n3,c77)
if(i3.ge.0) go to 900
! Check Type 5 (WWROF contest exchange)
call pack77_5(nwords,w,i3,n3,c77)
if(i3.ge.0) go to 900
! It defaults to free text
800 i3=0
n3=0
@ -204,6 +208,7 @@ subroutine unpack77(c77,nrx,msg,msgcall,msggrid,unpk77_success)
character*6 cexch,grid6
character*4 grid4,cserial,msggrid
character*3 csec(NSEC)
character*2 cfield
character*38 c
integer hashmy10,hashmy12,hashmy22,hashdx10,hashdx12,hashdx22
logical unpk28_success,unpk77_success
@ -496,8 +501,31 @@ subroutine unpack77(c77,nrx,msg,msgcall,msggrid,unpk77_success)
msg='CQ '//trim(call_2)
endif
msgcall=trim(call_2)
else if(i3.eq.5) then
! 5 TU; W9XYZ K1ABC R-09 FN 1 28 28 1 7 9 74 WWROF contest
read(c77,1041) itu,n28a,n28b,ir,irpt,nexch,i3
1041 format(b1,2b28.28,b1,b7.7,b9.9,b3.3)
call unpack28(n28a,call_1,unpk28_success)
if(.not.unpk28_success) unpk77_success=.false.
call unpack28(n28b,call_2,unpk28_success)
if(.not.unpk28_success) unpk77_success=.false.
write(crpt,'(i3.2)') irpt-35
if(crpt(1:1).eq.' ') crpt(1:1)='+'
n1=nexch/18
n2=nexch - 18*n1
cfield(1:1)=char(ichar('A')+n1)
cfield(2:2)=char(ichar('A')+n2)
if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// &
' '//crpt//' '//cfield
if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// &
' '//crpt//' '//cfield
if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// &
' R'//crpt//' '//cfield
if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// &
' R'//crpt//' '//cfield
endif
if(msg(1:4).eq.'CQ <') unpk77_success=.false.
! if(msg(1:4).eq.'CQ <') unpk77_success=.false.
return
end subroutine unpack77
@ -1020,7 +1048,7 @@ end subroutine pack77_1
subroutine pack77_3(nwords,w,i3,n3,c77)
! Check Type 2 (ARRL RTTY contest exchange)
!ARRL RTTY - US/Can: rpt state/prov R 579 MA
! - DX: rpt serial R 559 0013
! - DX: rpt serial R 559 0013
parameter (NUSCAN=65) !Number of US states and Canadian provinces/territories
character*13 w(19)
@ -1045,12 +1073,11 @@ subroutine pack77_3(nwords,w,i3,n3,c77)
call chkcall(w(i1+1),bcall_2,ok2)
if(.not.ok1 .or. .not.ok2) go to 900
crpt=w(nwords-1)(1:3)
if(index(crpt,'-').ge.1 .or. index(crpt,'+').ge.1) go to 900
if(crpt(1:1).eq.'5' .and. crpt(2:2).ge.'2' .and. crpt(2:2).le.'9' .and. &
crpt(3:3).eq.'9') then
nserial=0
read(w(nwords),*,err=1) nserial
!1 i3=3
! n3=0
endif
1 mult=' '
imult=-1
@ -1155,6 +1182,60 @@ subroutine pack77_4(nwords,w,i3,n3,c77)
900 return
end subroutine pack77_4
subroutine pack77_5(nwords,w,i3,n3,c77)
! Check Type 5 (WWROF contest exchange)
character*13 w(19)
character*77 c77
character*6 bcall_1,bcall_2
character*3 mult
character crpt*4
character c1*1,c2*2
logical ok1,ok2
if(nwords.eq.4 .or. nwords.eq.5 .or. nwords.eq.6) then
i1=1
if(trim(w(1)).eq.'TU;') i1=2
call chkcall(w(i1),bcall_1,ok1)
call chkcall(w(i1+1),bcall_2,ok2)
if(.not.ok1 .or. .not.ok2) go to 900
crpt=w(nwords-1)(1:4)
if(index(crpt,'-').lt.1 .and. index(crpt,'+').lt.1) go to 900
c1=crpt(1:1)
c2=crpt(1:2)
irpt=-1
if(c1.eq.'+' .or. c1.eq.'-') then
ir=0
read(w(nwords-1),*,err=900) irpt
irpt=irpt+35
else if(c2.eq.'R+' .or. c2.eq.'R-') then
ir=1
read(w(nwords-1)(2:),*) irpt
irpt=irpt+35
endif
if(irpt.eq.-1 .or. len(trim(w(nwords))).ne.2) go to 900
c2=w(nwords)(1:2)
n1=ichar(c2(1:1)) - ichar('A')
n2=ichar(c2(2:2)) - ichar('A')
if(n1.lt.0 .or. n1.gt.17) go to 900
if(n2.lt.0 .or. n2.gt.17) go to 900
nexch=18*n1 + n2
i3=5
n3=0
itu=0
if(trim(w(1)).eq.'TU;') itu=1
call pack28(w(1+itu),n28a)
call pack28(w(2+itu),n28b)
! 5 TU; W9XYZ K1ABC R-09 FN 1 28 28 1 7 9 74 WWROF contest
write(c77,1010) itu,n28a,n28b,ir,irpt,nexch,i3
1010 format(b1,2b28.28,b1,b7.7,b9.9,b3.3)
end if
900 return
end subroutine pack77_5
subroutine packtext77(c13,c71)
character*13 c13,w

24
platanh.f90 Normal file
View File

@ -0,0 +1,24 @@
subroutine platanh(x,y)
isign=+1
z=x
if( x.lt.0 ) then
isign=-1
z=abs(x)
endif
if( z.le. 0.664 ) then
y=x/0.83
return
elseif( z.le. 0.9217 ) then
y=isign*(z-0.4064)/0.322
return
elseif( z.le. 0.9951 ) then
y=isign*(z-0.8378)/0.0524
return
elseif( z.le. 0.9998 ) then
y=isign*(z-0.9914)/0.0012
return
else
y=isign*7.0
return
endif
end subroutine platanh

6
subtractft8.f90
View File

@ -9,13 +9,13 @@ subroutine subtractft8(dd,itone,f0,dt)
parameter (NMAX=15*4000,NFRAME=640*79)
parameter (NFFT=NMAX,NFILT=1400)
real*4 window(-NFILT/2:NFILT/2)
real*4 window(-NFILT/2:NFILT/2),xjunk
complex dd(NMAX)
complex cref,camp,cfilt,cw
integer itone(79)
logical first
data first/.true./
common/heap8/cref(NFRAME),camp(NMAX),cfilt(NMAX),cw(NMAX)
common/heap8/cref(NFRAME),camp(NMAX),cfilt(NMAX),cw(NMAX),xjunk(NFRAME)
save first
if(f0.lt.2000.0) then
@ -24,7 +24,7 @@ subroutine subtractft8(dd,itone,f0,dt)
f=f0-2000.0
endif
nstart=dt*4000+1
call genft8refsig(itone,cref,f)
call gen_ft8wave(itone,79,640,2.0,4000.0,f,cref,xjunk,1,NFRAME)
camp=0.
do i=1,nframe
id=nstart-1+i

7
sync8.f90
View File

@ -89,7 +89,12 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase)
enddo
iz=ib-ia+1
call indexx(red(ia:ib),iz,indx)
ibase=indx(nint(0.40*iz)) - 1 + ia
npctile=nint(0.40*iz)
if(npctile.lt.1) then ! something is wrong; bail out
ncand=0
return;
endif
ibase=indx(npctile) - 1 + ia
if(ibase.lt.1) ibase=1
if(ibase.gt.NFFT1) ibase=NFFT1
base=red(ibase)