WSJT-X/lib/fsk4hf/bpdecode174_91.f90

subroutine bpdecode174_91(llr,apmask,maxiterations,decoded,cw,nharderror,iter)
!
! A log-domain belief propagation decoder for the (174,91) code.
!
integer, parameter:: N=174, K=91, M=N-K
integer*1 codeword(N),cw(N),apmask(N)
integer  colorder(N)
integer*1 decoded(K)
integer Nm(7,M)   
integer Mn(3,N)  ! 3 checks per bit
integer synd(M)
real tov(3,N)
real toc(7,M)
real tanhtoc(7,M)
real zn(N)
real llr(N)
real Tmn
integer nrw(M)

data colorder/            &
   0,  1,  2,  3, 28,  4,  5,  6,  7,  8,  9, 10, 11, 34, 12, 32, 13, 14, 15, 16,&
  17, 18, 36, 29, 40, 19, 20, 38, 21, 41, 30, 42, 22, 44, 37, 47, 48, 23, 33, 43,&
  49, 45, 56, 39, 25, 26, 46, 50, 51, 52, 24, 57, 58, 61, 31, 54, 64, 35, 27, 62,&
  59, 53, 60, 63, 55, 70, 66, 67, 68, 65, 71, 74, 72, 73, 77, 75, 69, 76, 79, 82,&
  83, 78, 81, 80, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99,&
 100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,&
 120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,&
 140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,&
 160,161,162,163,164,165,166,167,168,169,170,171,172,173/

data Mn/        &
   1,  24,  66, &
   2,   5,  70, &
   3,  31,  65, &
   4,  49,  58, &
   6,  60,  67, &
   7,  32,  75, &
   8,  48,  82, &
   9,  35,  41, &
  10,  39,  62, &
  11,  14,  61, &
  12,  71,  74, &
  13,  23,  78, &
  15,  16,  79, &
  17,  54,  63, &
  18,  50,  57, &
  19,  30,  47, &
  20,  64,  80, &
  21,  28,  69, &
  22,  25,  43, &
  26,  34,  72, &
  27,  36,  37, &
  29,  40,  44, &
  33,  52,  53, &
  38,  55,  83, &
  42,  51,  59, &
  45,  76,  81, &
  46,  68,  77, &
  56,  67,  73, &
   1,   4,   5, &
   2,  47,  51, &
   3,  46,  82, &
   6,  24,  76, &
   7,   9,  16, &
   8,  10,  78, &
  11,  35,  55, &
  12,  38,  64, &
  13,  42,  83, &
  14,  27,  54, &
  15,  21,  34, &
  17,  44,  53, &
  18,  25,  28, &
  19,  33,  57, &
  20,  22,  73, &
  23,  40,  81, &
  26,  49,  68, &
  29,  71,  75, &
  30,  65,  79, &
  31,  36,  60, &
  32,  43,  77, &
  37,  62,  70, &
  39,  69,  74, &
  41,  52,  66, &
  45,  50,  61, &
  48,  63,  80, &
  56,  59,  72, &
  58,  64,  65, &
   1,  13,  28, &
   2,  48,  75, &
   3,  53,  69, &
   4,  11,  44, &
   5,  73,  79, &
   6,  12,  17, &
   7,  57,  60, &
   8,  15,  61, &
   9,  39,  59, &
  10,  19,  49, &
  14,  43,  52, &
  16,  54,  68, &
  18,  41,  63, &
  20,  36,  45, &
  21,  67,  77, &
  10,  22,  55, &
  23,  65,  72, &
  24,  27,  82, &
  25,  26,  29, &
  30,  35,  37, &
  31,  51,  66, &
  17,  32,  78, &
  33,  42,  76, &
  34,  70,  83, &
  38,  46,  81, &
  40,  62,  80, &
  45,  47,  74, &
  50,  56,  71, &
   7,  37,  58, &
   1,  16,  71, &
   2,   6,  61, &
   3,  22,  50, &
   4,  59,  77, &
   5,  41,  81, &
   8,  58,  74, &
   9,  20,  26, &
  11,  21,  31, &
  12,  66,  79, &
  13,  14,  57, &
  15,  33,  40, &
  18,  44,  82, &
  19,  69,  83, &
  23,  49,  63, &
  24,  29,  39, &
  25,  47,  56, &
  27,  55,  72, &
  28,  64,  70, &
  30,  48,  77, &
  32,  34,  45, &
  35,  68,  80, &
  36,  38,  52, &
  42,  43,  62, &
  46,  60,  78, &
  51,  54,  67, &
  53,  73,  75, &
  14,  73,  76, &
   1,  22,  30, &
   2,  35,  43, &
   3,  47,  63, &
   4,  25,  76, &
   5,  33,  78, &
   6,  20,  83, &
   7,  12,  72, &
   8,  54,  70, &
   9,  61,  65, &
  10,  34,  51, &
  11,  46,  75, &
  13,  39,  68, &
  15,  17,  56, &
  16,  23,  36, &
  18,  32,  55, &
  19,  31,  81, &
  21,  37,  71, &
  24,  57,  64, &
  26,  38,  48, &
  27,  49,  50, &
  28,  52,  59, &
  29,  41,  58, &
  40,  60,  74, &
  42,  44,  79, &
  51,  53,  80, &
  62,  67,  82, &
  23,  66,  69, &
   1,  53,  61, &
   2,  18,  39, &
   3,   4,  12, &
   5,  26,  74, &
   6,  30,  52, &
   7,  82,  83, &
   8,  35,  73, &
   9,  19,  67, &
  10,  64,  75, &
  11,  20,  33, &
  13,  45,  48, &
   3,  14,  40, &
  15,  43,  49, &
  16,  55,  76, &
  17,  62,  65, &
  21,  47,  78, &
  22,  59,  81, &
  24,  34,  63, &
  25,  37,  66, &
  27,  79,  80, &
  28,  60,  79, &
  29,  31,  70, &
  32,  58,  69, &
  10,  36,  77, &
  38,  50,  51, &
  13,  41,  56, &
  42,  63,  71, &
  44,  47,  68, &
   1,  46,  72, &
  54,  57,  75, &
   2,  33,  58, &
   4,  17,  83, &
   5,  14,  55, &
   6,  23,  48, &
   7,  52,  56/

data Nm/               &
   1,  29,  57,  86, 113, 140, 168, &
   2,  30,  58,  87, 114, 141, 170, &
   3,  31,  59,  88, 115, 142, 151, &
   4,  29,  60,  89, 116, 142, 171, &
   2,  29,  61,  90, 117, 143, 172, &
   5,  32,  62,  87, 118, 144, 173, &
   6,  33,  63,  85, 119, 145, 174, &
   7,  34,  64,  91, 120, 146,   0, &
   8,  33,  65,  92, 121, 147,   0, &
   9,  34,  66,  72, 122, 148, 163, &
  10,  35,  60,  93, 123, 149,   0, &
  11,  36,  62,  94, 119, 142,   0, &
  12,  37,  57,  95, 124, 150, 165, &
  10,  38,  67,  95, 112, 151, 172, &
  13,  39,  64,  96, 125, 152,   0, &
  13,  33,  68,  86, 126, 153,   0, &
  14,  40,  62,  78, 125, 154, 171, &
  15,  41,  69,  97, 127, 141,   0, &
  16,  42,  66,  98, 128, 147,   0, &
  17,  43,  70,  92, 118, 149,   0, &
  18,  39,  71,  93, 129, 155,   0, &
  19,  43,  72,  88, 113, 156,   0, &
  12,  44,  73,  99, 126, 139, 173, &
   1,  32,  74, 100, 130, 157,   0, &
  19,  41,  75, 101, 116, 158,   0, &
  20,  45,  75,  92, 131, 143,   0, &
  21,  38,  74, 102, 132, 159,   0, &
  18,  41,  57, 103, 133, 160,   0, &
  22,  46,  75, 100, 134, 161,   0, &
  16,  47,  76, 104, 113, 144,   0, &
   3,  48,  77,  93, 128, 161,   0, &
   6,  49,  78, 105, 127, 162,   0, &
  23,  42,  79,  96, 117, 149, 170, &
  20,  39,  80, 105, 122, 157,   0, &
   8,  35,  76, 106, 114, 146,   0, &
  21,  48,  70, 107, 126, 163,   0, &
  21,  50,  76,  85, 129, 158,   0, &
  24,  36,  81, 107, 131, 164,   0, &
   9,  51,  65, 100, 124, 141,   0, &
  22,  44,  82,  96, 135, 151,   0, &
   8,  52,  69,  90, 134, 165,   0, &
  25,  37,  79, 108, 136, 166,   0, &
  19,  49,  67, 108, 114, 152,   0, &
  22,  40,  60,  97, 136, 167,   0, &
  26,  53,  70,  83, 105, 150,   0, &
  27,  31,  81, 109, 123, 168,   0, &
  16,  30,  83, 101, 115, 155, 167, &
   7,  54,  58, 104, 131, 150, 173, &
   4,  45,  66,  99, 132, 152,   0, &
  15,  53,  84,  88, 132, 164,   0, &
  25,  30,  77, 110, 122, 137, 164, &
  23,  52,  67, 107, 133, 144, 174, &
  23,  40,  59, 111, 137, 140,   0, &
  14,  38,  68, 110, 120, 169,   0, &
  24,  35,  72, 102, 127, 153, 172, &
  28,  55,  84, 101, 125, 165, 174, &
  15,  42,  63,  95, 130, 169,   0, &
   4,  56,  85,  91, 134, 162, 170, &
  25,  55,  65,  89, 133, 156,   0, &
   5,  48,  63, 109, 135, 160,   0, &
  10,  53,  64,  87, 121, 140,   0, &
   9,  50,  82, 108, 138, 154,   0, &
  14,  54,  69,  99, 115, 157, 166, &
  17,  36,  56, 103, 130, 148,   0, &
   3,  47,  56,  73, 121, 154,   0, &
   1,  52,  77,  94, 139, 158,   0, &
   5,  28,  71, 110, 138, 147,   0, &
  27,  45,  68, 106, 124, 167,   0, &
  18,  51,  59,  98, 139, 162,   0, &
   2,  50,  80, 103, 120, 161,   0, &
  11,  46,  84,  86, 129, 166,   0, &
  20,  55,  73, 102, 119, 168,   0, &
  28,  43,  61, 111, 112, 146,   0, &
  11,  51,  83,  91, 135, 143,   0, &
   6,  46,  58, 111, 123, 148, 169, &
  26,  32,  79, 112, 116, 153,   0, &
  27,  49,  71,  89, 104, 163,   0, &
  12,  34,  78, 109, 117, 155,   0, &
  13,  47,  61,  94, 136, 159, 160, &
  17,  54,  82, 106, 137, 159,   0, &
  26,  44,  81,  90, 128, 156,   0, &
   7,  31,  74,  97, 138, 145,   0, &
  24,  37,  80,  98, 118, 145, 171/

data nrw/    &
  7,7,7,7,7,7,7,6,6,7,6,6,7,7,6,6,7,6, &
  6,6,6,6,7,6,6,6,6,6,6,6,6,6,7,6,6,6, &
  6,6,6,6,6,6,6,6,6,6,7,7,6,6,7,7,6,6, &
  7,7,6,7,6,6,6,6,7,6,6,6,6,6,6,6,6,6, &
  6,6,7,6,6,6,7,6,6,6,7/

ncw=3

decoded=0
toc=0
tov=0
tanhtoc=0
! initialize messages to checks
do j=1,M
  do i=1,nrw(j)
    toc(i,j)=llr((Nm(i,j)))
  enddo
enddo

ncnt=0

do iter=0,maxiterations

! Update bit log likelihood ratios (tov=0 in iteration 0).
  do i=1,N
    if( apmask(i) .ne. 1 ) then
      zn(i)=llr(i)+sum(tov(1:ncw,i))
    else
      zn(i)=llr(i)
    endif
  enddo

! Check to see if we have a codeword (check before we do any iteration).
  cw=0
  where( zn .gt. 0. ) cw=1
  ncheck=0
  do i=1,M
    synd(i)=sum(cw(Nm(1:nrw(i),i)))
    if( mod(synd(i),2) .ne. 0 ) ncheck=ncheck+1
!   if( mod(synd(i),2) .ne. 0 ) write(*,*) 'check ',i,' unsatisfied'
  enddo
! write(*,*) 'number of unsatisfied parity checks ',ncheck
  if( ncheck .eq. 0 ) then ! we have a codeword - reorder the columns and return it
    codeword=cw(colorder+1)
    decoded=codeword(M+1:N)
    nerr=0
    do i=1,N
      if( (2*cw(i)-1)*llr(i) .lt. 0.0 ) nerr=nerr+1
    enddo
    nharderror=nerr
    return
  endif

  if( iter.gt.0 ) then  ! this code block implements an early stopping criterion
!  if( iter.gt.10000 ) then  ! this code block implements an early stopping criterion
    nd=ncheck-nclast
    if( nd .lt. 0 ) then ! # of unsatisfied parity checks decreased
      ncnt=0  ! reset counter
    else
      ncnt=ncnt+1
    endif
!    write(*,*) iter,ncheck,nd,ncnt
    if( ncnt .ge. 5 .and. iter .ge. 10 .and. ncheck .gt. 15) then
      nharderror=-1
      return
    endif
  endif
  nclast=ncheck

! Send messages from bits to check nodes 
  do j=1,M
    do i=1,nrw(j)
      ibj=Nm(i,j)
      toc(i,j)=zn(ibj)  
      do kk=1,ncw ! subtract off what the bit had received from the check
        if( Mn(kk,ibj) .eq. j ) then  
          toc(i,j)=toc(i,j)-tov(kk,ibj)
        endif
      enddo
    enddo
  enddo

! send messages from check nodes to variable nodes
  do i=1,M
    tanhtoc(1:6,i)=tanh(-toc(1:6,i)/2)
  enddo

  do j=1,N
    do i=1,ncw
      ichk=Mn(i,j)  ! Mn(:,j) are the checks that include bit j
      Tmn=product(tanhtoc(1:nrw(ichk),ichk),mask=Nm(1:nrw(ichk),ichk).ne.j)
      call platanh(-Tmn,y)
!      y=atanh(-Tmn)
      tov(i,j)=2*y
    enddo
  enddo

enddo
nharderror=-1
return
end subroutine bpdecode174_91