module ft4_decode type :: ft4_decoder procedure(ft4_decode_callback), pointer :: callback contains procedure :: decode end type ft4_decoder abstract interface subroutine ft4_decode_callback (this,sync,snr,dt,freq,decoded,nap,qual) import ft4_decoder implicit none class(ft4_decoder), intent(inout) :: this real, intent(in) :: sync integer, intent(in) :: snr real, intent(in) :: dt real, intent(in) :: freq character(len=37), intent(in) :: decoded integer, intent(in) :: nap real, intent(in) :: qual end subroutine ft4_decode_callback end interface contains subroutine decode(this,callback,iwave,nQSOProgress,nfqso, & nfa,nfb,ndepth,lapcqonly,ncontest,mycall,hiscall) use timer_module, only: timer use packjt77 include 'ft4/ft4_params.f90' parameter (MAXCAND=100) class(ft4_decoder), intent(inout) :: this procedure(ft4_decode_callback) :: callback parameter (NSS=NSPS/NDOWN,NDMAX=NMAX/NDOWN) character message*37,msgsent*37 character c77*77 character*37 decodes(100) character*17 cdatetime0 character*12 mycall,hiscall character*12 mycall0,hiscall0 character*6 hhmmss complex cd2(0:NDMAX-1) !Complex waveform complex cb(0:NDMAX-1) complex cd(0:NN*NSS-1) !Complex waveform complex ctwk(2*NSS),ctwk2(2*NSS,-16:16) real a(5) real bitmetrics(2*NN,3) real dd(NMAX) real llr(2*ND),llra(2*ND),llrb(2*ND),llrc(2*ND),llrd(2*ND) real candidate(2,MAXCAND) real savg(NH1),sbase(NH1) integer apbits(2*ND) integer apmy_ru(28),aphis_fd(28) integer*2 iwave(NMAX) !Raw received data integer*1 message77(77),rvec(77),apmask(2*ND),cw(2*ND) integer*1 hbits(2*NN) integer i4tone(103) integer nappasses(0:5) ! # of decoding passes for QSO States 0-5 integer naptypes(0:5,4) ! nQSOProgress, decoding pass integer mcq(29),mcqru(29),mcqfd(29),mcqtest(29),mcqww(29) integer mrrr(19),m73(19),mrr73(19) logical nohiscall,unpk77_success logical first, dobigfft logical dosubtract,doosd logical badsync logical, intent(in) :: lapcqonly data first/.true./ data mcq/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0/ data mcqru/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,1,1,1,0,0,1,1,0,0/ data mcqfd/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,1,0,0,1,0,0,0,1,0/ data mcqtest/0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,1,0,1,0,1,1,1,1,1,1,0,0,1,0/ data mcqww/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,1,1,0,1,1,1,1,0/ data mrrr/0,1,1,1,1,1,1,0,1,0,0,1,0,0,1,0,0,0,1/ data m73/0,1,1,1,1,1,1,0,1,0,0,1,0,1,0,0,0,0,1/ data mrr73/0,1,1,1,1,1,1,0,0,1,1,1,0,1,0,1,0,0,1/ data rvec/0,1,0,0,1,0,1,0,0,1,0,1,1,1,1,0,1,0,0,0,1,0,0,1,1,0,1,1,0, & 1,0,0,1,0,1,1,0,0,0,0,1,0,0,0,1,0,1,0,0,1,1,1,1,0,0,1,0,1, & 0,1,0,1,0,1,1,0,1,1,1,1,1,0,0,0,1,0,1/ save fs,dt,tt,txt,twopi,h,first,apbits,nappasses,naptypes, & mycall0,hiscall0,ctwk2 this%callback => callback hhmmss=cdatetime0(8:13) smax1=0. nd1=0 if(first) then fs=12000.0/NDOWN !Sample rate after downsampling dt=1/fs !Sample interval after downsample (s) tt=NSPS*dt !Duration of "itone" symbols (s) txt=NZ*dt !Transmission length (s) without ramp up/down twopi=8.0*atan(1.0) h=1.0 do idf=-16,16 a=0. a(1)=real(idf) ctwk=1. call twkfreq1(ctwk,2*NSS,fs/2.0,a,ctwk2(:,idf)) enddo mcq=2*mod(mcq+rvec(1:29),2)-1 mcqru=2*mod(mcqru+rvec(1:29),2)-1 mcqfd=2*mod(mcqfd+rvec(1:29),2)-1 mcqtest=2*mod(mcqtest+rvec(1:29),2)-1 mcqww=2*mod(mcqww+rvec(1:29),2)-1 mrrr=2*mod(mrrr+rvec(59:77),2)-1 m73=2*mod(m73+rvec(59:77),2)-1 mrr73=2*mod(mrr73+rvec(59:77),2)-1 nappasses(0)=2 nappasses(1)=2 nappasses(2)=2 nappasses(3)=2 nappasses(4)=2 nappasses(5)=3 ! iaptype !------------------------ ! 1 CQ ??? ??? (29 ap bits) ! 2 MyCall ??? ??? (29 ap bits) ! 3 MyCall DxCall ??? (58 ap bits) ! 4 MyCall DxCall RRR (77 ap bits) ! 5 MyCall DxCall 73 (77 ap bits) ! 6 MyCall DxCall RR73 (77 ap bits) !******** naptypes(0,1:4)=(/1,2,0,0/) ! Tx6 selected (CQ) naptypes(1,1:4)=(/2,3,0,0/) ! Tx1 naptypes(2,1:4)=(/2,3,0,0/) ! Tx2 naptypes(3,1:4)=(/3,6,0,0/) ! Tx3 naptypes(4,1:4)=(/3,6,0,0/) ! Tx4 naptypes(5,1:4)=(/3,1,2,0/) ! Tx5 mycall0='' hiscall0='' first=.false. endif l1=index(mycall,char(0)) if(l1.ne.0) mycall(l1:)=" " l1=index(hiscall,char(0)) if(l1.ne.0) hiscall(l1:)=" " if(mycall.ne.mycall0 .or. hiscall.ne.hiscall0) then apbits=0 apbits(1)=99 apbits(30)=99 apmy_ru=0 aphis_fd=0 if(len(trim(mycall)) .lt. 3) go to 10 nohiscall=.false. hiscall0=hiscall if(len(trim(hiscall0)).lt.3) then hiscall0=mycall ! use mycall for dummy hiscall - mycall won't be hashed. nohiscall=.true. endif message=trim(mycall)//' '//trim(hiscall0)//' RR73' i3=-1 n3=-1 call pack77(message,i3,n3,c77) call unpack77(c77,1,msgsent,unpk77_success) if(i3.ne.1 .or. (message.ne.msgsent) .or. .not.unpk77_success) go to 10 read(c77,'(77i1)') message77 apmy_ru=2*mod(message77(1:28)+rvec(2:29),2)-1 aphis_fd=2*mod(message77(30:57)+rvec(29:56),2)-1 message77=mod(message77+rvec,2) call encode174_91(message77,cw) apbits=2*cw-1 if(nohiscall) apbits(30)=99 10 continue mycall0=mycall hiscall0=hiscall endif ndecodes=0 decodes=' ' fa=nfa fb=nfb dd=iwave ! ndepth=3: 3 passes, bp+osd ! ndepth=2: 3 passes, bp only ! ndepth=1: 1 pass, no subtraction max_iterations=40 syncmin=1.2 dosubtract=.true. doosd=.true. nsp=3 if(ndepth.eq.2) then doosd=.false. endif if(ndepth.eq.1) then nsp=1 dosubtract=.false. doosd=.false. endif do isp = 1,nsp if(isp.eq.2) then if(ndecodes.eq.0) exit nd1=ndecodes elseif(isp.eq.3) then nd2=ndecodes-nd1 if(nd2.eq.0) exit endif candidate=0.0 ncand=0 call timer('getcand4',0) call getcandidates4(dd,fa,fb,syncmin,nfqso,MAXCAND,savg,candidate, & ncand,sbase) call timer('getcand4',1) dobigfft=.true. do icand=1,ncand f0=candidate(1,icand) snr=candidate(2,icand)-1.0 call timer('ft4_down',0) call ft4_downsample(dd,dobigfft,f0,cd2) !Downsample to 32 Sam/Sym call timer('ft4_down',1) if(dobigfft) dobigfft=.false. sum2=sum(cd2*conjg(cd2))/(real(NMAX)/real(NDOWN)) if(sum2.gt.0.0) cd2=cd2/sqrt(sum2) ! Sample rate is now 12000/18 = 666.67 samples/second do iseg=1,3 ! DT search is done over 3 segments do isync=1,2 if(isync.eq.1) then idfmin=-12 idfmax=12 idfstp=3 ibmin=-344 ibmax=1012 if(iseg.eq.1) then ibmin=108 ibmax=560 elseif(iseg.eq.2) then smax1=smax ibmin=560 ibmax=1012 elseif(iseg.eq.3) then ibmin=-344 ibmax=108 endif ibstp=4 else idfmin=idfbest-4 idfmax=idfbest+4 idfstp=1 ibmin=ibest-5 ibmax=ibest+5 ibstp=1 endif ibest=-1 idfbest=0 smax=-99. call timer('sync4d ',0) do idf=idfmin,idfmax,idfstp do istart=ibmin,ibmax,ibstp call sync4d(cd2,istart,ctwk2(:,idf),1,sync) !Find sync power if(sync.gt.smax) then smax=sync ibest=istart idfbest=idf endif enddo enddo call timer('sync4d ',1) enddo if(iseg.eq.1) smax1=smax if(smax.lt.1.2) cycle if(iseg.gt.1 .and. smax.lt.smax1) cycle f1=f0+real(idfbest) if( f1.le.10.0 .or. f1.ge.4990.0 ) cycle call timer('ft4down ',0) call ft4_downsample(dd,dobigfft,f1,cb) !Final downsample, corrected f0 call timer('ft4down ',1) sum2=sum(abs(cb)**2)/(real(NSS)*NN) if(sum2.gt.0.0) cb=cb/sqrt(sum2) cd=0. if(ibest.ge.0) then it=min(NDMAX-1,ibest+NN*NSS-1) np=it-ibest+1 cd(0:np-1)=cb(ibest:it) else cd(-ibest:ibest+NN*NSS-1)=cb(0:NN*NSS+2*ibest-1) endif call timer('bitmet ',0) call get_ft4_bitmetrics(cd,bitmetrics,badsync) call timer('bitmet ',1) if(badsync) cycle hbits=0 where(bitmetrics(:,1).ge.0) hbits=1 ns1=count(hbits( 1: 8).eq.(/0,0,0,1,1,0,1,1/)) ns2=count(hbits( 67: 74).eq.(/0,1,0,0,1,1,1,0/)) ns3=count(hbits(133:140).eq.(/1,1,1,0,0,1,0,0/)) ns4=count(hbits(199:206).eq.(/1,0,1,1,0,0,0,1/)) nsync_qual=ns1+ns2+ns3+ns4 if(nsync_qual.lt. 20) cycle scalefac=2.83 llra( 1: 58)=bitmetrics( 9: 66, 1) llra( 59:116)=bitmetrics( 75:132, 1) llra(117:174)=bitmetrics(141:198, 1) llra=scalefac*llra llrb( 1: 58)=bitmetrics( 9: 66, 2) llrb( 59:116)=bitmetrics( 75:132, 2) llrb(117:174)=bitmetrics(141:198, 2) llrb=scalefac*llrb llrc( 1: 58)=bitmetrics( 9: 66, 3) llrc( 59:116)=bitmetrics( 75:132, 3) llrc(117:174)=bitmetrics(141:198, 3) llrc=scalefac*llrc apmag=maxval(abs(llra))*1.1 npasses=3+nappasses(nQSOProgress) if(lapcqonly) npasses=4 if(ndepth.eq.1) npasses=3 if(ncontest.ge.6) npasses=3 ! Don't support Fox and Hound do ipass=1,npasses if(ipass.eq.1) llr=llra if(ipass.eq.2) llr=llrb if(ipass.eq.3) llr=llrc if(ipass.le.3) then apmask=0 iaptype=0 endif if(ipass .gt. 3) then llrd=llrc iaptype=naptypes(nQSOProgress,ipass-3) if(lapcqonly) iaptype=1 ! ncontest=0 : NONE ! 1 : NA_VHF ! 2 : EU_VHF ! 3 : FIELD DAY ! 4 : RTTY ! 5 : WW_DIGI ! 6 : FOX ! 7 : HOUND ! ! Conditions that cause us to bail out of AP decoding napwid=80 if(ncontest.le.5 .and. iaptype.ge.3 .and. (abs(f1-nfqso).gt.napwid) ) cycle if(iaptype.ge.2 .and. apbits(1).gt.1) cycle ! No, or nonstandard, mycall if(iaptype.ge.3 .and. apbits(30).gt.1) cycle ! No, or nonstandard, dxcall if(iaptype.eq.1) then ! CQ or CQ TEST or CQ FD or CQ RU or CQ WW apmask=0 apmask(1:29)=1 if( ncontest.eq.0 ) llrd(1:29)=apmag*mcq(1:29) if( ncontest.eq.1 ) llrd(1:29)=apmag*mcqtest(1:29) if( ncontest.eq.2 ) llrd(1:29)=apmag*mcqtest(1:29) if( ncontest.eq.3 ) llrd(1:29)=apmag*mcqfd(1:29) if( ncontest.eq.4 ) llrd(1:29)=apmag*mcqru(1:29) if( ncontest.eq.5 ) llrd(1:29)=apmag*mcqww(1:29) endif if(iaptype.eq.2) then ! MyCall,???,??? apmask=0 if(ncontest.eq.0.or.ncontest.eq.1.or.ncontest.eq.5) then apmask(1:29)=1 llrd(1:29)=apmag*apbits(1:29) else if(ncontest.eq.2) then apmask(1:28)=1 llrd(1:28)=apmag*apbits(1:28) else if(ncontest.eq.3) then apmask(1:28)=1 llrd(1:28)=apmag*apbits(1:28) else if(ncontest.eq.4) then apmask(2:29)=1 llrd(2:29)=apmag*apmy_ru(1:28) endif endif if(iaptype.eq.3) then ! MyCall,DxCall,??? apmask=0 if(ncontest.eq.0.or.ncontest.eq.1.or.ncontest.eq.2.or.ncontest.eq.5) then apmask(1:58)=1 llrd(1:58)=apmag*apbits(1:58) else if(ncontest.eq.3) then ! Field Day apmask(1:56)=1 llrd(1:28)=apmag*apbits(1:28) llrd(29:56)=apmag*aphis_fd(1:28) else if(ncontest.eq.4) then apmask(2:57)=1 llrd(2:29)=apmag*apmy_ru(1:28) llrd(30:57)=apmag*apbits(30:57) endif endif if(iaptype.eq.4 .or. iaptype.eq.5 .or. iaptype.eq.6) then apmask=0 if(ncontest.le.5) then apmask(1:77)=1 ! mycall, hiscall, RRR|73|RR73 if(iaptype.eq.6) llrd(1:77)=apmag*apbits(1:77) endif endif llr=llrd endif message77=0 dmin=0.0 call timer('bpdec174',0) call bpdecode174_91(llr,apmask,max_iterations,message77, & cw,nharderror,niterations,ncheck) call timer('bpdec174',1) if(doosd .and. nharderror.lt.0) then ndeep=3 if(abs(nfqso-f1).le.napwid) then ndeep=4 endif call timer('osd174_91 ',0) call osd174_91(llr,apmask,ndeep,message77,cw,nharderror,dmin) call timer('osd174_91 ',1) endif if(sum(message77).eq.0) cycle if( nharderror.ge.0 ) then message77=mod(message77+rvec,2) ! remove rvec scrambling write(c77,'(77i1)') message77(1:77) call unpack77(c77,1,message,unpk77_success) if(.not.unpk77_success) exit if(dosubtract) then call get_ft4_tones_from_77bits(message77,i4tone) dt=real(ibest)/666.67 call timer('subtract',0) call subtractft4(dd,i4tone,f1,dt) call timer('subtract',1) endif idupe=0 do i=1,ndecodes if(decodes(i).eq.message) idupe=1 enddo if(idupe.eq.1) exit ndecodes=ndecodes+1 decodes(ndecodes)=message if(snr.gt.0.0) then xsnr=10*log10(snr)-14.8 else xsnr=-21.0 endif nsnr=nint(max(-21.0,xsnr)) xdt=ibest/666.67 - 0.5 qual=1.0-(nharderror+dmin)/60.0 call this%callback(smax,nsnr,xdt,f1,message,iaptype,qual) exit endif enddo !Sequence estimation if(nharderror.ge.0) exit enddo !3 DT segments enddo !Candidate list enddo !Subtraction loop return end subroutine decode end module ft4_decode