WSJT-X/lib/qra64a.f90

175 lines
4.8 KiB
Fortran

subroutine qra64a(dd,npts,nf1,nf2,nfqso,ntol,mode64,minsync,ndepth, &
emedelay,mycall_12,hiscall_12,hisgrid_6,sync,nsnr,dtx,nfreq,decoded,nft)
use packjt
use timer_module, only: timer
parameter (NMAX=60*12000,LN=1152*63)
character decoded*22
character*12 mycall_12,hiscall_12
character*6 mycall,hiscall,hisgrid_6
character*4 hisgrid
logical ltext
complex c00(0:720000) !Complex spectrum of dd()
complex c0(0:720000) !Complex data for dd()
real a(3) !twkfreq params f,f1,f2
real dd(NMAX) !Raw data sampled at 12000 Hz
real s3(LN) !Symbol spectra
real s3a(LN) !Symbol spectra
integer dat4(12) !Decoded message (as 12 integers)
integer dat4x(12)
integer nap(0:11)
data nap/0,2,3,2,3,4,2,3,6,4,6,6/
data nc1z/-1/,nc2z/-1/,ng2z/-1/,maxaptypez/-1/
save
call timer('qra64a ',0)
irc=-1
decoded=' '
nft=99
if(nfqso.lt.nf1 .or. nfqso.gt.nf2) go to 900
mycall=mycall_12(1:6) !### May need fixing ###
hiscall=hiscall_12(1:6)
hisgrid=hisgrid_6(1:4)
call packcall(mycall,nc1,ltext)
call packcall(hiscall,nc2,ltext)
call packgrid(hisgrid,ng2,ltext)
nSubmode=0
if(mode64.eq.2) nSubmode=1
if(mode64.eq.4) nSubmode=2
if(mode64.eq.8) nSubmode=3
if(mode64.eq.16) nSubmode=4
b90=1.0
nFadingModel=1
maxaptype=4
if(iand(ndepth,64).ne.0) maxaptype=5
if(nc1.ne.nc1z .or. nc2.ne.nc2z .or. ng2.ne.ng2z .or. &
maxaptype.ne.maxaptypez) then
do naptype=0,maxaptype
if(naptype.eq.2 .and. maxaptype.eq.4) cycle
call qra64_dec(s3,nc1,nc2,ng2,naptype,1,nSubmode,b90, &
nFadingModel,dat4,snr2,irc)
enddo
nc1z=nc1
nc2z=nc2
ng2z=ng2
maxaptypez=maxaptype
endif
naptype=maxaptype
call ana64(dd,npts,c00)
npts2=npts/2
call timer('sync64 ',0)
call sync64(c00,nf1,nf2,nfqso,ntol,minsync,mode64,emedelay,dtx,f0, &
jpk0,sync,sync2,width)
call timer('sync64 ',1)
nfreq=nint(f0)
if(mode64.eq.1 .and. minsync.ne.-1 .and. (sync-7.0).lt.minsync) go to 900
irc=-99
s3lim=20.
ibwmax=11
if(mode64.le.4) ibwmax=9
ibwmin=0
idtmax=5
if(minsync.eq.-2) then
ibwmin=ibwmax
idtmax=3
endif
LL=64*(mode64+2)
NN=63
napmin=99
ncall=0
do idf0=1,11
idf=idf0/2
if(mod(idf0,2).eq.0) idf=-idf
a=0.
a(1)=-(f0+0.868*idf)
call twkfreq(c00,c0,npts2,6000.0,a)
do idt0=1,idtmax
idt=idt0/2
if(mod(idt0,2).eq.0) idt=-idt
jpk=jpk0 + 750*idt
call spec64(c0,jpk,s3a,LL,NN)
call pctile(s3a,LL*NN,40,base)
s3a=s3a/base
where(s3a(1:LL*NN)>s3lim) s3a(1:LL*NN)=s3lim
do ibw=ibwmax,ibwmin,-2
b90=1.728**ibw
if(b90.gt.230.0) cycle
if(b90.lt.0.15*width) exit
s3(1:LL*NN)=s3a(1:LL*NN)
ncall=ncall+1
call timer('qra64_de',0)
call qra64_dec(s3,nc1,nc2,ng2,naptype,0,nSubmode,b90, &
nFadingModel,dat4,snr2,irc)
call timer('qra64_de',1)
if(irc.eq.0) go to 10
if(irc.gt.0) call badmsg(irc,dat4,nc1,nc2,ng2)
iirc=max(0,min(irc,11))
if(irc.gt.0 .and. nap(iirc).lt.napmin) then
dat4x=dat4
b90x=b90
snr2x=snr2
napmin=nap(iirc)
irckeep=irc
dtxkeep=jpk/6000.0 - 1.0
f0keep=-a(1)
idfkeep=idf
idtkeep=idt
ibwkeep=ibw
endif
enddo ! ibw (b90 loop)
if(iand(ndepth,3).lt.3 .and. irc.ge.0) go to 100
if(irc.eq.0) go to 100
enddo ! idt (DT loop)
enddo ! idf (f0 loop)
100 if(napmin.ne.99) then
dat4=dat4x
b90=b90x
snr2=snr2x
irc=irckeep
dtx=dtxkeep
f0=f0keep
idt=idtkeep
idf=idfkeep
ibw=ibwkeep
endif
10 decoded=' '
if(irc.ge.0) then
call unpackmsg(dat4,decoded) !Unpack the user message
call fmtmsg(decoded,iz)
if(index(decoded,"000AAA ").ge.1) then
! Suppress a certain type of garbage decode.
decoded=' '
irc=-1
endif
nft=100 + irc
nsnr=nint(snr2)
else
snr2=0.
endif
nfreq=nint(f0)
write(71,3071) idf,idt,ncall,irc,nsnr,dtx,nfreq,decoded
3071 format(5i5,f7.2,i6,2x,a22)
900 if(irc.lt.0) then
sy=max(1.0,sync)
if(nSubmode.eq.0) nsnr=nint(10.0*log10(sy)-35.0) !A
if(nSubmode.eq.1) nsnr=nint(10.0*log10(sy)-34.0) !B
if(nSubmode.eq.2) nsnr=nint(10.0*log10(sy)-29.0) !C
if(nSubmode.eq.3) nsnr=nint(10.0*log10(sy)-29.0) !D
if(nSubmode.eq.4) nsnr=nint(10.0*log10(sy)-24.0) !E
endif
call timer('qra64a ',1)
return
end subroutine qra64a