port changes from WSJT-X 2.1.2

Makefile

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

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.

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)
 

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

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

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

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
 

genft8refsig.f90

@@ -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

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

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

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

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

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)