From e7eaa44adf9dff5f83a001c140008afbb59e9fd5 Mon Sep 17 00:00:00 2001 From: Pavel Demin Date: Thu, 25 Jun 2020 10:00:22 +0000 Subject: [PATCH] port changes from WSJT-X 2.1.2 --- Makefile | 10 +++--- bpdecode174_91.f90 | 25 ------------- four2a.f90 | 4 +-- ft8b.f90 | 2 +- ft8d.f90 | 6 +++- gen_ft8wave.f90 | 74 ++++++++++++++++++++++++++++++++++++++ genft8.f90 | 2 +- genft8refsig.f90 | 23 ------------ gfsk_pulse.f90 | 6 ++++ packjt77.f90 | 89 +++++++++++++++++++++++++++++++++++++++++++--- platanh.f90 | 24 +++++++++++++ subtractft8.f90 | 6 ++-- sync8.f90 | 7 +++- 13 files changed, 212 insertions(+), 66 deletions(-) create mode 100644 gen_ft8wave.f90 delete mode 100644 genft8refsig.f90 create mode 100644 gfsk_pulse.f90 create mode 100644 platanh.f90 diff --git a/Makefile b/Makefile index afde4ac..6ff40e8 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/bpdecode174_91.f90 b/bpdecode174_91.f90 index 91bea04..cdd73f7 100644 --- a/bpdecode174_91.f90 +++ b/bpdecode174_91.f90 @@ -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. diff --git a/four2a.f90 b/four2a.f90 index 938385e..cbfd875 100644 --- a/four2a.f90 +++ b/four2a.f90 @@ -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) diff --git a/ft8b.f90 b/ft8b.f90 index 2957dd3..cb06e19 100644 --- a/ft8b.f90 +++ b/ft8b.f90 @@ -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 diff --git a/ft8d.f90 b/ft8d.f90 index b1935cb..a69fb97 100644 --- a/ft8d.f90 +++ b/ft8d.f90 @@ -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 diff --git a/gen_ft8wave.f90 b/gen_ft8wave.f90 new file mode 100644 index 0000000..f0bacc8 --- /dev/null +++ b/gen_ft8wave.f90 @@ -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 diff --git a/genft8.f90 b/genft8.f90 index c9316d6..b5c1116 100644 --- a/genft8.f90 +++ b/genft8.f90 @@ -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 diff --git a/genft8refsig.f90 b/genft8refsig.f90 deleted file mode 100644 index ca3062e..0000000 --- a/genft8refsig.f90 +++ /dev/null @@ -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 diff --git a/gfsk_pulse.f90 b/gfsk_pulse.f90 new file mode 100644 index 0000000..99ab78e --- /dev/null +++ b/gfsk_pulse.f90 @@ -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 diff --git a/packjt77.f90 b/packjt77.f90 index 3193380..3a1480b 100644 --- a/packjt77.f90 +++ b/packjt77.f90 @@ -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 diff --git a/platanh.f90 b/platanh.f90 new file mode 100644 index 0000000..e610366 --- /dev/null +++ b/platanh.f90 @@ -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 diff --git a/subtractft8.f90 b/subtractft8.f90 index b68ff23..dcd5abb 100644 --- a/subtractft8.f90 +++ b/subtractft8.f90 @@ -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 diff --git a/sync8.f90 b/sync8.f90 index 7ad2322..96326fd 100644 --- a/sync8.f90 +++ b/sync8.f90 @@ -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)