module fst240_decode type :: fst240_decoder procedure(fst240_decode_callback), pointer :: callback contains procedure :: decode end type fst240_decoder abstract interface subroutine fst240_decode_callback (this,nutc,sync,nsnr,dt,freq, & decoded,nap,qual,ntrperiod) import fst240_decoder implicit none class(fst240_decoder), intent(inout) :: this integer, intent(in) :: nutc real, intent(in) :: sync integer, intent(in) :: nsnr real, intent(in) :: dt real, intent(in) :: freq character(len=37), intent(in) :: decoded integer, intent(in) :: nap real, intent(in) :: qual integer, intent(in) :: ntrperiod end subroutine fst240_decode_callback end interface contains subroutine decode(this,callback,iwave,nutc,nQSOProgress,nfqso, & nfa,nfb,nsubmode,ndeep,ntrperiod,nexp_decode,ntol,nzhsym, & emedelay,lapcqonly,napwid,mycall,hiscall) use timer_module, only: timer use packjt77 include 'fst240/fst240_params.f90' parameter (MAXCAND=100) class(fst240_decoder), intent(inout) :: this procedure(fst240_decode_callback) :: callback character*37 decodes(100) character*37 msg character*77 c77 character*12 mycall,hiscall complex, allocatable :: c2(:) complex, allocatable :: cframe(:) complex, allocatable :: c_bigfft(:) !Complex waveform real, allocatable :: r_data(:) real llr(240),llra(240),llrb(240),llrc(240),llrd(240) real candidates(100,4) real bitmetrics(320,4) real s4(0:3,NN) logical lapcqonly integer itone(NN) integer hmod integer*1 apmask(240),cw(240) integer*1 hbits(320) integer*1 message101(101),message74(74) integer*1 rvec(77) logical badsync,unpk77_success,single_decode integer*2 iwave(300*12000) 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/ this%callback => callback hmod=2**nsubmode if(nfqso+nqsoprogress.eq.-999) return Keff=91 iwspr=0 nmax=15*12000 single_decode=iand(nexp_decode,32).eq.32 if(ntrperiod.eq.15) then nsps=720 nmax=15*12000 ndown=18/hmod !nss=40,80,160,400 if(hmod.eq.4) ndown=4 if(hmod.eq.8) ndown=2 nfft1=int(nmax/ndown)*ndown else if(ntrperiod.eq.30) then nsps=1680 nmax=30*12000 ndown=42/hmod !nss=40,80,168,336 nfft1=359856 if(hmod.eq.4) then ndown=10 nfft1=nmax endif if(hmod.eq.8) then ndown=5 nfft1=nmax endif else if(ntrperiod.eq.60) then nsps=3888 nmax=60*12000 ndown=96/hmod !nss=36,81,162,324 if(hmod.eq.1) ndown=108 nfft1=int(719808/ndown)*ndown else if(ntrperiod.eq.120) then nsps=8200 nmax=120*12000 ndown=200/hmod !nss=40,82,164,328 if(hmod.eq.1) ndown=205 nfft1=int(nmax/ndown)*ndown else if(ntrperiod.eq.300) then nsps=21504 nmax=300*12000 ndown=512/hmod !nss=42,84,168,336 nfft1=int((nmax-200)/ndown)*ndown end if nss=nsps/ndown fs=12000.0 !Sample rate fs2=fs/ndown nspsec=nint(fs2) dt=1.0/fs !Sample interval (s) dt2=1.0/fs2 tt=nsps*dt !Duration of "itone" symbols (s) baud=1.0/tt sigbw=4.0*hmod*baud nfft2=nfft1/ndown !make sure that nfft1 is exactly nfft2*ndown nfft1=nfft2*ndown nh1=nfft1/2 allocate( r_data(1:nfft1+2) ) allocate( c_bigfft(0:nfft1/2) ) allocate( c2(0:nfft2-1) ) allocate( cframe(0:160*nss-1) ) if(single_decode) then fa=max(100,nint(nfqso+1.5*hmod*baud-ntol)) fb=min(4800,nint(nfqso+1.5*hmod*baud+ntol)) else fa=max(100,nfa) fb=min(4800,nfb) endif if(ndeep.eq.3) then ntmax=4 ! number of block sizes to try jittermax=2 norder=3 elseif(ndeep.eq.2) then ntmax=3 jittermax=2 norder=3 elseif(ndeep.eq.1) then ntmax=1 jittermax=2 norder=2 endif ! The big fft is done once and is used for calculating the smoothed spectrum ! and also for downconverting/downsampling each candidate. r_data(1:nfft1)=iwave(1:nfft1) r_data(nfft1+1:nfft1+2)=0.0 call four2a(r_data,nfft1,1,-1,0) c_bigfft=cmplx(r_data(1:nfft1+2:2),r_data(2:nfft1+2:2)) ! Get first approximation of candidate frequencies call get_candidates_fst240(c_bigfft,nfft1,nsps,hmod,fs,fa,fb, & ncand,candidates,base) ndecodes=0 decodes=' ' isbest1=0 isbest8=0 fc21=0. fc28=0. do icand=1,ncand fc0=candidates(icand,1) detmet=candidates(icand,2) ! Downconvert and downsample a slice of the spectrum centered on the ! rough estimate of the candidates frequency. ! Output array c2 is complex baseband sampled at 12000/ndown Sa/sec. ! The size of the downsampled c2 array is nfft2=nfft1/ndown call fst240_downsample(c_bigfft,nfft1,ndown,fc0,sigbw,c2) call timer('sync240 ',0) do isync=0,1 if(isync.eq.0) then fc1=0.0 is0=1.5*nint(fs2) ishw=is0 isst=4*hmod ifhw=12 df=.1*baud else if(isync.eq.1) then fc1=fc21 if(hmod.eq.1) fc1=fc28 is0=isbest1 if(hmod.eq.1) is0=isbest8 ishw=4*hmod isst=1*hmod ifhw=7 df=.02*baud endif smax1=0.0 smax8=0.0 do if=-ifhw,ifhw fc=fc1+df*if do istart=max(1,is0-ishw),is0+ishw,isst call sync_fst240(c2,istart,fc,hmod,1,nfft2,nss,fs2,sync1) call sync_fst240(c2,istart,fc,hmod,8,nfft2,nss,fs2,sync8) if(sync8.gt.smax8) then fc28=fc isbest8=istart smax8=sync8 endif if(sync1.gt.smax1) then fc21=fc isbest1=istart smax1=sync1 endif enddo enddo enddo call timer('sync240 ',1) if(smax8/smax1 .lt. 0.65 ) then fc2=fc21 isbest=isbest1 if(hmod.gt.1) ntmax=1 njitter=2 else fc2=fc28 isbest=isbest8 if(hmod.gt.1) ntmax=1 njitter=2 endif fc_synced = fc0 + fc2 dt_synced = (isbest-fs2)*dt2 !nominal dt is 1 second so frame starts at sample fs2 candidates(icand,3)=fc_synced candidates(icand,4)=isbest enddo ! remove duplicate candidates do icand=1,ncand fc=candidates(icand,3) isbest=nint(candidates(icand,4)) do ic2=1,ncand fc2=candidates(ic2,3) isbest2=nint(candidates(ic2,4)) if(ic2.ne.icand .and. fc2.gt.0.0) then if(abs(fc2-fc).lt.0.10*baud) then ! same frequency if(abs(isbest2-isbest).le.2) then candidates(ic2,3)=-1 endif endif endif enddo enddo ic=0 do icand=1,ncand if(candidates(icand,3).gt.0) then ic=ic+1 candidates(ic,:)=candidates(icand,:) endif enddo ncand=ic xsnr=0. do icand=1,ncand sync=candidates(icand,2) fc_synced=candidates(icand,3) isbest=nint(candidates(icand,4)) xdt=(isbest-nspsec)/fs2 if(ntrperiod.eq.15) xdt=(isbest-real(nspsec)/2.0)/fs2 call fst240_downsample(c_bigfft,nfft1,ndown,fc_synced,sigbw,c2) do ijitter=0,jittermax if(ijitter.eq.0) ioffset=0 if(ijitter.eq.1) ioffset=1 if(ijitter.eq.2) ioffset=-1 is0=isbest+ioffset if(is0.lt.0) cycle cframe=c2(is0:is0+160*nss-1) bitmetrics=0 call get_fst240_bitmetrics(cframe,nss,hmod,ntmax,bitmetrics,s4,badsync) if(badsync) cycle hbits=0 where(bitmetrics(:,1).ge.0) hbits=1 ns1=count(hbits( 1: 16).eq.(/0,0,0,1,1,0,1,1,0,1,0,0,1,1,1,0/)) ns2=count(hbits( 77: 92).eq.(/1,1,1,0,0,1,0,0,1,0,1,1,0,0,0,1/)) ns3=count(hbits(153:168).eq.(/0,0,0,1,1,0,1,1,0,1,0,0,1,1,1,0/)) ns4=count(hbits(229:244).eq.(/1,1,1,0,0,1,0,0,1,0,1,1,0,0,0,1/)) ns5=count(hbits(305:320).eq.(/0,0,0,1,1,0,1,1,0,1,0,0,1,1,1,0/)) nsync_qual=ns1+ns2+ns3+ns4+ns5 if(nsync_qual.lt. 44) cycle !### Value ?? ### scalefac=2.83 llra( 1: 60)=bitmetrics( 17: 76, 1) llra( 61:120)=bitmetrics( 93:152, 1) llra(121:180)=bitmetrics(169:228, 1) llra(181:240)=bitmetrics(245:304, 1) llra=scalefac*llra llrb( 1: 60)=bitmetrics( 17: 76, 2) llrb( 61:120)=bitmetrics( 93:152, 2) llrb(121:180)=bitmetrics(169:228, 2) llrb(181:240)=bitmetrics(245:304, 2) llrb=scalefac*llrb llrc( 1: 60)=bitmetrics( 17: 76, 3) llrc( 61:120)=bitmetrics( 93:152, 3) llrc(121:180)=bitmetrics(169:228, 3) llrc(181:240)=bitmetrics(245:304, 3) llrc=scalefac*llrc llrd( 1: 60)=bitmetrics( 17: 76, 4) llrd( 61:120)=bitmetrics( 93:152, 4) llrd(121:180)=bitmetrics(169:228, 4) llrd(181:240)=bitmetrics(245:304, 4) llrd=scalefac*llrd apmask=0 do itry=1,ntmax if(itry.eq.1) llr=llra if(itry.eq.2) llr=llrb if(itry.eq.3) llr=llrc if(itry.eq.4) llr=llrd dmin=0.0 nharderrors=-1 unpk77_success=.false. if(iwspr.eq.0) then maxosd=2 call timer('d240_101',0) call decode240_101(llr,Keff,maxosd,norder,apmask,message101, & cw,ntype,nharderrors,dmin) call timer('d240_101',1) else maxosd=2 call timer('d240_74 ',0) ! call decode240_74(llr,Keff,maxosd,norder,apmask,message74,cw, & ! ntype,nharderrors,dmin) call timer('d240_74 ',1) endif if(nharderrors .ge.0) then if(iwspr.eq.0) then write(c77,'(77i1)') mod(message101(1:77)+rvec,2) call unpack77(c77,0,msg,unpk77_success) else write(c77,'(50i1)') message74(1:50) c77(51:77)='000000000000000000000110000' call unpack77(c77,0,msg,unpk77_success) endif if(unpk77_success) then idupe=0 do i=1,ndecodes if(decodes(i).eq.msg) idupe=1 enddo if(idupe.eq.1) exit ndecodes=ndecodes+1 decodes(ndecodes)=msg if(iwspr.eq.0) then call get_fst240_tones_from_bits(message101,itone,iwspr) xsig=0 do i=1,NN xsig=xsig+s4(itone(i),i)**2 enddo arg=400.0*(xsig/base)-1.0 if(arg.gt.0.0) then xsnr=10*log10(arg)-21.0-11.7*log10(nsps/800.0) else xsnr=-99.9 endif endif nsnr=nint(xsnr) iaptype=0 qual=0. fsig=fc_synced - 1.5*hmod*baud !write(21,'(i6,7i6,f7.1,f9.2,3f7.1,1x,a37)') & ! nutc,icand,itry,iaptype,ijitter,ntype,nsync_qual,nharderrors,dmin,sync,xsnr,xdt,fsig,msg call this%callback(nutc,smax1,nsnr,xdt,fsig,msg, & iaptype,qual,ntrperiod) goto 2002 else cycle endif endif enddo ! metrics enddo ! istart jitter 2002 continue enddo !candidate list!ws return end subroutine decode subroutine sync_fst240(cd0,i0,f0,hmod,ncoh,np,nss,fs,sync) ! Compute sync power for a complex, downsampled FST240 signal. include 'fst240/fst240_params.f90' complex cd0(0:np-1) complex, allocatable, save :: csync1(:),csync2(:) complex, allocatable, save :: csynct1(:),csynct2(:) complex ctwk(8*nss) complex z1,z2,z3,z4,z5 logical first integer hmod,isyncword1(0:7),isyncword2(0:7) real f0save data isyncword1/0,1,3,2,1,0,2,3/ data isyncword2/2,3,1,0,3,2,0,1/ data first/.true./,f0save/-99.9/,nss0/-1/ save first,twopi,dt,fac,f0save,nss0 p(z1)=(real(z1*fac)**2 + aimag(z1*fac)**2)**0.5 !Compute power if(nss.ne.nss0 .and. allocated(csync1)) deallocate(csync1,csync2,csynct1,csynct2) if(first .or. nss.ne.nss0) then allocate( csync1(8*nss), csync2(8*nss) ) allocate( csynct1(8*nss), csynct2(8*nss) ) twopi=8.0*atan(1.0) dt=1/fs k=1 phi1=0.0 phi2=0.0 do i=0,7 dphi1=twopi*hmod*(isyncword1(i)-1.5)/real(nss) dphi2=twopi*hmod*(isyncword2(i)-1.5)/real(nss) do j=1,nss csync1(k)=cmplx(cos(phi1),sin(phi1)) csync2(k)=cmplx(cos(phi2),sin(phi2)) phi1=mod(phi1+dphi1,twopi) phi2=mod(phi2+dphi2,twopi) k=k+1 enddo enddo first=.false. nss0=nss fac=1.0/(8.0*nss) endif if(f0.ne.f0save) then dphi=twopi*f0*dt phi=0.0 do i=1,8*nss ctwk(i)=cmplx(cos(phi),sin(phi)) phi=mod(phi+dphi,twopi) enddo csynct1=ctwk*csync1 csynct2=ctwk*csync2 f0save=f0 endif i1=i0 !Costas arrays i2=i0+38*nss i3=i0+76*nss i4=i0+114*nss i5=i0+152*nss s1=0.0 s2=0.0 s3=0.0 s4=0.0 s5=0.0 nsec=8/ncoh do i=1,nsec is=(i-1)*ncoh*nss z1=0 if(i1+is.ge.1) then z1=sum(cd0(i1+is:i1+is+ncoh*nss-1)*conjg(csynct1(is+1:is+ncoh*nss))) endif z2=sum(cd0(i2+is:i2+is+ncoh*nss-1)*conjg(csynct2(is+1:is+ncoh*nss))) z3=sum(cd0(i3+is:i3+is+ncoh*nss-1)*conjg(csynct1(is+1:is+ncoh*nss))) z4=sum(cd0(i4+is:i4+is+ncoh*nss-1)*conjg(csynct2(is+1:is+ncoh*nss))) z5=0 if(i5+is+ncoh*nss-1.le.np) then z5=sum(cd0(i5+is:i5+is+ncoh*nss-1)*conjg(csynct1(is+1:is+ncoh*nss))) endif s1=s1+abs(z1)/(8*nss) s2=s2+abs(z2)/(8*nss) s3=s3+abs(z3)/(8*nss) s4=s4+abs(z4)/(8*nss) s5=s5+abs(z5)/(8*nss) enddo sync = s1+s2+s3+s4+s5 return end subroutine sync_fst240 subroutine fst240_downsample(c_bigfft,nfft1,ndown,f0,sigbw,c1) ! Output: Complex data in c(), sampled at 12000/ndown Hz complex c_bigfft(0:nfft1/2) complex c1(0:nfft1/ndown-1) df=12000.0/nfft1 i0=nint(f0/df) ih=nint( ( f0 + 1.3*sigbw/2.0 )/df) nbw=ih-i0+1 c1=0. c1(0)=c_bigfft(i0) nfft2=nfft1/ndown do i=1,nbw if(i0+i.le.nfft1/2) c1(i)=c_bigfft(i0+i) if(i0-i.ge.0) c1(nfft2-i)=c_bigfft(i0-i) enddo c1=c1/nfft2 call four2a(c1,nfft2,1,1,1) !c2c FFT back to time domain return end subroutine fst240_downsample subroutine get_candidates_fst240(c_bigfft,nfft1,nsps,hmod,fs,fa,fb, & ncand,candidates,base) complex c_bigfft(0:nfft1/2) !Full length FFT of raw data integer hmod !Modulation index (submode) integer im(1) !For maxloc real candidates(100,4) !Candidate list real s(18000) !Low resolution power spectrum real s2(18000) !CCF of s() with 4 tones real xdb(-3:3) !Model 4-tone CCF peaks data xdb/0.25,0.50,0.75,1.0,0.75,0.50,0.25/ data nfft1z/-1/ save nfft1z nh1=nfft1/2 df1=fs/nfft1 baud=fs/nsps !Keying rate df2=baud/2.0 nd=df2/df1 !s() sums this many bins of big FFT ndh=nd/2 ia=nint(max(100.0,fa)/df2) !Low frequency search limit ib=nint(min(4800.0,fb)/df2) !High frequency limit signal_bw=4*(12000.0/nsps)*hmod analysis_bw=min(4800.0,fb)-max(100.0,fa) noise_bw=10.0*signal_bw !Is this a good compromise? if(analysis_bw.gt.noise_bw) then ina=ia inb=ib else fcenter=(fa+fb)/2.0 !If noise_bw > analysis_bw, fl = max(100.0,fcenter-noise_bw/2.)/df2 !we'll search over noise_bw fh = min(4800.0,fcenter+noise_bw/2.)/df2 ina=nint(fl) inb=nint(fh) endif s=0. !Compute low-resloution power spectrum do i=ina,inb ! noise analysis window includes signal analysis window j0=nint(i*df2/df1) do j=j0-ndh,j0+ndh s(i)=s(i) + real(c_bigfft(j))**2 + aimag(c_bigfft(j))**2 enddo enddo ina=max(ina,1+3*hmod) !Don't run off the ends inb=min(inb,18000-3*hmod) s2=0. do i=ina,inb !Compute CCF of s() and 4 tones s2(i)=s(i-hmod*3) + s(i-hmod) +s(i+hmod) +s(i+hmod*3) enddo call pctile(s2(ina+hmod*3:inb-hmod*3),inb-ina+1-hmod*6,30,base) s2=s2/base !Normalize wrt noise level thresh=1.25 !First candidate threshold ncand=0 candidates=0 if(ia.lt.3) ia=3 if(ib.gt.18000-2) ib=18000-2 ! Find candidates, using the CLEAN algorithm to remove a model of each one ! from s2() after it has been found. pval=99.99 do while(ncand.lt.100 .and. pval.gt.thresh) im=maxloc(s2(ia:ib)) iploc=ia+im(1)-1 !Index of CCF peak pval=s2(iploc) !Peak value if(s2(iploc).gt.thresh) then !Is this a possible candidate? do i=-3,+3 !Remove 0.9 of a model CCF at k=iploc+2*hmod*i !this frequency from s2() if(k.ge.ia .and. k.le.ib) then s2(k)=max(0.,s2(k)-0.9*pval*xdb(i)) endif enddo ncand=ncand+1 candidates(ncand,1)=df2*iploc !Candidate frequency candidates(ncand,2)=pval !Rough estimate of SNR endif enddo return end subroutine get_candidates_fst240 end module fst240_decode