WSJT-X/lib/exp_decode65.f90

subroutine exp_decode65(s3,mrs,mrs2,mrsym,mr2sym,mrprob,mode65,flip,   &
     mycall,qual,decoded)

  use packjt
  use prog_args
  parameter (NMAX=10000)
  real s3(64,63)
  real pp(NMAX),bb(NMAX)
  integer*1 sym1(0:62,NMAX)
  integer*1 sym2(0:62,NMAX)
  integer mrs(63),mrs2(63)
  integer mrsym(0:62),mr2sym(0:62),mrprob(0:62)
  integer dgen(12),sym(0:62),sym_rev(0:62)
  integer test(0:62)
  character*6 mycall,hiscall(NMAX)
  character*4 hisgrid(NMAX)
  character callsign*12,grid*4
  character*180 line
  character ceme*3,msg*22
  character*22 msg0(1000),decoded
  logical*1 eme(NMAX)
  logical first
  data first/.true./,nn/0/
  save first,sym1,nused,msg0,sym2,nn

  if(first) then
     neme=1
     open(23,file=trim(data_dir)//'/CALL3.TXT',status='unknown')
     icall=0
     j=0
     do i=1,NMAX
        read(23,1002,end=10) line
1002    format(a80)
        if(line(1:4).eq.'ZZZZ') cycle
        if(line(1:2).eq.'//') cycle
        i1=index(line,',')
        if(i1.lt.4) cycle
        i2=index(line(i1+1:),',')
        if(i2.lt.5) cycle
        i2=i2+i1
        i3=index(line(i2+1:),',')
        if(i3.lt.1) i3=index(line(i2+1:),' ')
        i3=i2+i3
        callsign=line(1:i1-1)
        grid=line(i1+1:i2-1)
        ceme=line(i2+1:i3-1)
        eme(i)=ceme.eq.'EME'
        if(neme.eq.1 .and. (.not.eme(i))) cycle
        j=j+1
        hiscall(j)=callsign(1:6)               !### Fix for compound callsigns!
        hisgrid(j)=grid
     enddo
10   ncalls=j
     close(23)

     j=0
     do i=1,ncalls
        if(neme.eq.1 .and. (.not.eme(i))) cycle

!### Special for tests ###
        do isnr=-20,-30,-1
           j=j+1
           msg=mycall//' '//hiscall(i)//' '//hisgrid(i)
           if(isnr.ne.-20) write(msg(14:18),"(i3,'  ')") isnr
           call fmtmsg(msg,iz)
           call packmsg(msg,dgen,itype)            !Pack message into 72 bits
           call rs_encode(dgen,sym_rev)            !RS encode
           sym(0:62)=sym_rev(62:0:-1)
           sym1(0:62,j)=sym

           call interleave63(sym_rev,1)            !Interleave channel symbols
           call graycode(sym_rev,63,1,sym_rev)     !Apply Gray code
           sym2(0:62,j)=sym_rev(0:62)
           msg0(j)=msg
        enddo

     enddo
     nused=j
     first=.false.
  endif

  ref0=0.
  do j=1,63
     ref0=ref0 + s3(mrs(j)+1,j)
  enddo

  p1=-1.e30
  p2=-1.e30
  bb1=1.e30
  bb2=1.e30

! Find p1 and p2 (best and second-best) codeword from a list, using 
! matched filters
  ip1=1                                    !Silence compiler warning
  ip2=1
  do k=1,nused
     pp(k)=0.
     if(k.ge.2 .and. k.le.64 .and. flip.lt.0.0) cycle
! Test all messages if flip=+1; skip the CQ messages if flip=-1.
     if(flip.gt.0.0 .or. msg0(k)(1:3).ne.'CQ ') then
        psum=0.
        ref=ref0
        do j=1,63
!           i=ncode(j,k)+1
           i=sym2(j-1,k)+1
           psum=psum + s3(i,j)
           if(i.eq.mrs(j)+1) ref=ref - s3(i,j) + s3(mrs2(j)+1,j)
        enddo
        p=psum/ref
        pp(k)=p
        if(p.gt.p1) then
           p1=p
           ip1=k
        endif
     endif

! Find best and second-best codeword using the FT-defined soft distance
     test=sym1(0:62,k)
     nh=0
     ns=0
     do i=0,62
        j=62-i
        if(mrsym(j).ne.test(i)) then
           nh=nh+1
           if(mr2sym(j).ne.test(i)) ns=ns+mrprob(j)
        endif
     enddo
     ds=ns*63.0/sum(mrprob)
     bb(k)=nh+ds

     if(nh+ds.lt.bb1) then
        nhard=nh
        dsoft=ds
        bb1=nh+ds
        ncandidates=0
        ntry=0
        ip2=k
      endif
  enddo

  do i=1,nused
     if(pp(i).gt.p2 .and. pp(i).ne.p1) p2=pp(i)
     if(bb(i).lt.bb2 .and. bb(i).ne.bb1) bb2=bb(i)
  enddo

! ### DO NOT REMOVE ### 
!  call cs_lock('deep65')
!  rewind 77
!  write(77,*) p1,p2
!  call flush(77)
!  call cs_unlock
! ### Works OK without it (in both Windows and Linux) if compiled 
! ### without optimization.  However, in Windows this is a colossal 
! ### pain because of the way F2PY wants to run the compile step.

  bias=max(1.12*p2,0.335)
  if(mode65.eq.2) bias=max(1.08*p2,0.405)
  if(mode65.ge.4) bias=max(1.04*p2,0.505)

  if(p2.eq.p1 .and. p1.ne.-1.e30) stop 'Error in deep65'
  qual=100.0*(p1-bias)
  decoded='                      '
  if(bb1.le.110.0) decoded=msg0(ip2)
  nn=nn+1
  qual2=110.0-bb1 + 1.0

  return
end subroutine exp_decode65