comicsansg
/
ft8d
mirror of https://github.com/pavel-demin/ft8d.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

switch to 77-bit message protocol

This commit is contained in:
Pavel Demin 2018-12-15 13:25:41 +01:00
parent 69ca3729ae
commit f8f733d450
29 changed files with 2692 additions and 1150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
Makefile
View File

@ -1,10 +1,11 @@
TARGET = ft8d TARGET = ft8d
OBJECTS = \ OBJECTS = \
crc12.o crc.o ft8_downsample.o sync8d.o sync8.o grid2deg.o four2a.o \ crc14.o crc.o ft8_downsample.o sync8d.o sync8.o grid2deg.o four2a.o \
deg2grid.o chkcrc12a.o determ.o fftw3mod.o baseline.o bpdecode174.o \ deg2grid.o determ.o fftw3mod.o baseline.o bpdecode174_91.o fmtmsg.o \
fmtmsg.o packjt.o extractmessage174.o indexx.o shell.o pctile.o polyfit.o \ packjt.o chkcrc14a.o extractmessage174_91.o indexx.o shell.o pctile.o \
twkfreq1.o osd174.o encode174.o genft8.o db.o ft8b.o ft8d.o polyfit.o twkfreq1.o osd174_91.o encode174_91.o chkcall.o packjt77.o \
genft8.o genft8refsig.o subtractft8.o ft8b.o ft8d.o
CC = gcc CC = gcc
FC = gfortran FC = gfortran

426
bpdecode174.f90
View File

@ -1,426 +0,0 @@
subroutine platanh(x,y)
isign=+1
z=x
if( x.lt.0 ) then
isign=-1
z=abs(x)
endif
if( z.le. 0.664 ) then
y=x/0.83
return
elseif( z.le. 0.9217 ) then
y=isign*(z-0.4064)/0.322
return
elseif( z.le. 0.9951 ) then
y=isign*(z-0.8378)/0.0524
return
elseif( z.le. 0.9998 ) then
y=isign*(z-0.9914)/0.0012
return
else
y=isign*7.0
return
endif
end subroutine platanh
subroutine bpdecode174(llr,apmask,maxiterations,decoded,cw,nharderror,iter)
!
! A log-domain belief propagation decoder for the (174,87) code.
!
integer, parameter:: N=174, K=87, M=N-K
integer*1 codeword(N),cw(N),apmask(N)
integer colorder(N)
integer*1 decoded(K)
integer Nm(7,M) ! 5, 6, or 7 bits per check
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, 30, 4, 5, 6, 7, 8, 9, 10, 11, 32, 12, 40, 13, 14, 15, 16,&
17, 18, 37, 45, 29, 19, 20, 21, 41, 22, 42, 31, 33, 34, 44, 35, 47, 51, 50, 43,&
36, 52, 63, 46, 25, 55, 27, 24, 23, 53, 39, 49, 59, 38, 48, 61, 60, 57, 28, 62,&
56, 58, 65, 66, 26, 70, 64, 69, 68, 67, 74, 71, 54, 76, 72, 75, 78, 77, 80, 79,&
73, 83, 84, 81, 82, 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, 25, 69, &
2, 5, 73, &
3, 32, 68, &
4, 51, 61, &
6, 63, 70, &
7, 33, 79, &
8, 50, 86, &
9, 37, 43, &
10, 41, 65, &
11, 14, 64, &
12, 75, 77, &
13, 23, 81, &
15, 16, 82, &
17, 56, 66, &
18, 53, 60, &
19, 31, 52, &
20, 67, 84, &
21, 29, 72, &
22, 24, 44, &
26, 35, 76, &
27, 36, 38, &
28, 40, 42, &
30, 54, 55, &
34, 49, 87, &
39, 57, 58, &
45, 74, 83, &
46, 62, 80, &
47, 48, 85, &
59, 71, 78, &
1, 50, 53, &
2, 47, 84, &
3, 25, 79, &
4, 6, 14, &
5, 7, 80, &
8, 34, 55, &
9, 36, 69, &
10, 43, 83, &
11, 23, 74, &
12, 17, 44, &
13, 57, 76, &
15, 27, 56, &
16, 28, 29, &
18, 19, 59, &
20, 40, 63, &
21, 35, 52, &
22, 54, 64, &
24, 62, 78, &
26, 32, 77, &
30, 72, 85, &
31, 65, 87, &
33, 39, 51, &
37, 48, 75, &
38, 70, 71, &
41, 42, 68, &
45, 67, 86, &
46, 81, 82, &
49, 66, 73, &
58, 60, 66, &
61, 65, 85, &
1, 14, 21, &
2, 13, 59, &
3, 67, 82, &
4, 32, 73, &
5, 36, 54, &
6, 43, 46, &
7, 28, 75, &
8, 33, 71, &
9, 49, 76, &
10, 58, 64, &
11, 48, 68, &
12, 19, 45, &
15, 50, 61, &
16, 22, 26, &
17, 72, 80, &
18, 40, 55, &
20, 35, 51, &
23, 25, 34, &
24, 63, 87, &
27, 39, 74, &
29, 78, 83, &
30, 70, 77, &
31, 69, 84, &
22, 37, 86, &
38, 41, 81, &
42, 44, 57, &
47, 53, 62, &
52, 56, 79, &
60, 75, 81, &
1, 39, 77, &
2, 16, 41, &
3, 31, 54, &
4, 36, 78, &
5, 45, 65, &
6, 57, 85, &
7, 14, 49, &
8, 21, 46, &
9, 15, 72, &
10, 20, 62, &
11, 17, 71, &
12, 34, 47, &
13, 68, 86, &
18, 23, 43, &
19, 64, 73, &
24, 48, 79, &
25, 70, 83, &
26, 80, 87, &
27, 32, 40, &
28, 56, 69, &
29, 63, 66, &
30, 42, 50, &
33, 37, 82, &
35, 60, 74, &
38, 55, 84, &
44, 52, 61, &
51, 53, 72, &
58, 59, 67, &
47, 56, 76, &
1, 19, 37, &
2, 61, 75, &
3, 8, 66, &
4, 60, 84, &
5, 34, 39, &
6, 26, 53, &
7, 32, 57, &
9, 52, 67, &
10, 12, 15, &
11, 51, 69, &
13, 14, 65, &
16, 31, 43, &
17, 20, 36, &
18, 80, 86, &
21, 48, 59, &
22, 40, 46, &
23, 33, 62, &
24, 30, 74, &
25, 42, 64, &
27, 49, 85, &
28, 38, 73, &
29, 44, 81, &
35, 68, 70, &
41, 63, 76, &
45, 49, 71, &
50, 58, 87, &
48, 54, 83, &
13, 55, 79, &
77, 78, 82, &
1, 2, 24, &
3, 6, 75, &
4, 56, 87, &
5, 44, 53, &
7, 50, 83, &
8, 10, 28, &
9, 55, 62, &
11, 29, 67, &
12, 33, 40, &
14, 16, 20, &
15, 35, 73, &
17, 31, 39, &
18, 36, 57, &
19, 46, 76, &
21, 42, 84, &
22, 34, 59, &
23, 26, 61, &
25, 60, 65, &
27, 64, 80, &
30, 37, 66, &
32, 45, 72, &
38, 51, 86, &
41, 77, 79, &
43, 56, 68, &
47, 74, 82, &
40, 52, 78, &
54, 61, 71, &
46, 58, 69/
data Nm/ &
1, 30, 60, 89, 118, 147, 0, &
2, 31, 61, 90, 119, 147, 0, &
3, 32, 62, 91, 120, 148, 0, &
4, 33, 63, 92, 121, 149, 0, &
2, 34, 64, 93, 122, 150, 0, &
5, 33, 65, 94, 123, 148, 0, &
6, 34, 66, 95, 124, 151, 0, &
7, 35, 67, 96, 120, 152, 0, &
8, 36, 68, 97, 125, 153, 0, &
9, 37, 69, 98, 126, 152, 0, &
10, 38, 70, 99, 127, 154, 0, &
11, 39, 71, 100, 126, 155, 0, &
12, 40, 61, 101, 128, 145, 0, &
10, 33, 60, 95, 128, 156, 0, &
13, 41, 72, 97, 126, 157, 0, &
13, 42, 73, 90, 129, 156, 0, &
14, 39, 74, 99, 130, 158, 0, &
15, 43, 75, 102, 131, 159, 0, &
16, 43, 71, 103, 118, 160, 0, &
17, 44, 76, 98, 130, 156, 0, &
18, 45, 60, 96, 132, 161, 0, &
19, 46, 73, 83, 133, 162, 0, &
12, 38, 77, 102, 134, 163, 0, &
19, 47, 78, 104, 135, 147, 0, &
1, 32, 77, 105, 136, 164, 0, &
20, 48, 73, 106, 123, 163, 0, &
21, 41, 79, 107, 137, 165, 0, &
22, 42, 66, 108, 138, 152, 0, &
18, 42, 80, 109, 139, 154, 0, &
23, 49, 81, 110, 135, 166, 0, &
16, 50, 82, 91, 129, 158, 0, &
3, 48, 63, 107, 124, 167, 0, &
6, 51, 67, 111, 134, 155, 0, &
24, 35, 77, 100, 122, 162, 0, &
20, 45, 76, 112, 140, 157, 0, &
21, 36, 64, 92, 130, 159, 0, &
8, 52, 83, 111, 118, 166, 0, &
21, 53, 84, 113, 138, 168, 0, &
25, 51, 79, 89, 122, 158, 0, &
22, 44, 75, 107, 133, 155, 172, &
9, 54, 84, 90, 141, 169, 0, &
22, 54, 85, 110, 136, 161, 0, &
8, 37, 65, 102, 129, 170, 0, &
19, 39, 85, 114, 139, 150, 0, &
26, 55, 71, 93, 142, 167, 0, &
27, 56, 65, 96, 133, 160, 174, &
28, 31, 86, 100, 117, 171, 0, &
28, 52, 70, 104, 132, 144, 0, &
24, 57, 68, 95, 137, 142, 0, &
7, 30, 72, 110, 143, 151, 0, &
4, 51, 76, 115, 127, 168, 0, &
16, 45, 87, 114, 125, 172, 0, &
15, 30, 86, 115, 123, 150, 0, &
23, 46, 64, 91, 144, 173, 0, &
23, 35, 75, 113, 145, 153, 0, &
14, 41, 87, 108, 117, 149, 170, &
25, 40, 85, 94, 124, 159, 0, &
25, 58, 69, 116, 143, 174, 0, &
29, 43, 61, 116, 132, 162, 0, &
15, 58, 88, 112, 121, 164, 0, &
4, 59, 72, 114, 119, 163, 173, &
27, 47, 86, 98, 134, 153, 0, &
5, 44, 78, 109, 141, 0, 0, &
10, 46, 69, 103, 136, 165, 0, &
9, 50, 59, 93, 128, 164, 0, &
14, 57, 58, 109, 120, 166, 0, &
17, 55, 62, 116, 125, 154, 0, &
3, 54, 70, 101, 140, 170, 0, &
1, 36, 82, 108, 127, 174, 0, &
5, 53, 81, 105, 140, 0, 0, &
29, 53, 67, 99, 142, 173, 0, &
18, 49, 74, 97, 115, 167, 0, &
2, 57, 63, 103, 138, 157, 0, &
26, 38, 79, 112, 135, 171, 0, &
11, 52, 66, 88, 119, 148, 0, &
20, 40, 68, 117, 141, 160, 0, &
11, 48, 81, 89, 146, 169, 0, &
29, 47, 80, 92, 146, 172, 0, &
6, 32, 87, 104, 145, 169, 0, &
27, 34, 74, 106, 131, 165, 0, &
12, 56, 84, 88, 139, 0, 0, &
13, 56, 62, 111, 146, 171, 0, &
26, 37, 80, 105, 144, 151, 0, &
17, 31, 82, 113, 121, 161, 0, &
28, 49, 59, 94, 137, 0, 0, &
7, 55, 83, 101, 131, 168, 0, &
24, 50, 78, 106, 143, 149, 0/
data nrw/ &
6,6,6,6,6,6,6,6,6,6, &
6,6,6,6,6,6,6,6,6,6, &
6,6,6,6,6,6,6,6,6,6, &
6,6,6,6,6,6,6,6,6,7, &
6,6,6,6,6,7,6,6,6,6, &
6,6,6,6,6,7,6,6,6,6, &
7,6,5,6,6,6,6,6,6,5, &
6,6,6,6,6,6,6,6,6,6, &
5,6,6,6,5,6,6/
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:7,i)=tanh(-toc(1:7,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

140
bpdecode174_91.f90 Normal file
View File

@ -0,0 +1,140 @@
subroutine platanh(x,y)
isign=+1
z=x
if( x.lt.0 ) then
isign=-1
z=abs(x)
endif
if( z.le. 0.664 ) then
y=x/0.83
return
elseif( z.le. 0.9217 ) then
y=isign*(z-0.4064)/0.322
return
elseif( z.le. 0.9951 ) then
y=isign*(z-0.8378)/0.0524
return
elseif( z.le. 0.9998 ) then
y=isign*(z-0.9914)/0.0012
return
else
y=isign*7.0
return
endif
end subroutine platanh
subroutine bpdecode174_91(llr,apmask,maxiterations,message77,cw,nharderror,iter)
!
! A log-domain belief propagation decoder for the (174,91) code.
!
use iso_c_binding, only: c_loc,c_size_t
use crc
integer, parameter:: N=174, K=91, M=N-K
integer*1 cw(N),apmask(N)
integer*1 decoded(K)
integer*1 message77(77)
integer nrw(M),ncw
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
include "ldpc_174_91_c_reordered_parity.f90"
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 - if crc is good, return it
decoded=cw(1:K)
call chkcrc14a(decoded,nbadcrc)
nharderror=count( (2*cw-1)*llr .lt. 0.0 )
if(nbadcrc.eq.0) then
message77=decoded(1:77)
return
endif
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:7,i)=tanh(-toc(1:7,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

58
chkcall.f90 Normal file
View File

@ -0,0 +1,58 @@
subroutine chkcall(w,bc,cok)
! Check "w" to see if it could be a valid standard callsign or a valid
! compound callsign.
! Return base call "bc" and a logical "cok" indicator.
character w*13 !A putative callsign
character bc*6 !Base call (tentative)
character c*1
logical cok,isdigit,isletter
isdigit(c)=(ichar(c).ge.ichar('0')) .and. (ichar(c).le.ichar('9'))
isletter(c)=(ichar(c).ge.ichar('A')) .and. (ichar(c).le.ichar('Z'))
cok=.true.
bc=w(1:6)
n1=len_trim(w)
if(n1.gt.11) go to 100
if(index(w,'.').ge.1) go to 100
if(index(w,'+').ge.1) go to 100
if(index(w,'-').ge.1) go to 100
if(index(w,'?').ge.1) go to 100
if(n1.gt.6 .and. index(w,'/').le.0) go to 100
i0=index(w,'/')
if(max(i0-1,n1-i0).gt.6) go to 100 !Base call must be < 7 characters
if(i0.ge.2 .and. i0.le.n1-1) then !Extract base call from compound call
if(i0-1.le.n1-i0) bc=w(i0+1:n1)//' '
if(i0-1.gt.n1-i0) bc=w(1:i0-1)//' '
endif
nbc=len_trim(bc)
if(nbc.gt.6) go to 100 !Base call should have no more than 6 characters
! One of first two characters (c1 or c2) must be a letter
if((.not.isletter(bc(1:1))) .and. (.not.isletter(bc(2:2)))) go to 100
if(bc(1:1).eq.'Q') go to 100 !Calls don't start with Q
! Must have a digit in 2nd or 3rd position
i1=0
if(isdigit(bc(2:2))) i1=2
if(isdigit(bc(3:3))) i1=3
if(i1.eq.0) go to 100
! Callsign must have a suffix of 1-3 letters
if(i1.eq.nbc) go to 100
n=0
do i=i1+1,nbc
j=ichar(bc(i:i))
if(j.lt.ichar('A') .or. j.gt.ichar('Z')) go to 100
n=n+1
enddo
if(n.ge.1 .and. n.le.3) go to 200
100 cok=.false.
200 return
end subroutine chkcall

24
chkcrc12a.f90
View File

@ -1,24 +0,0 @@
subroutine chkcrc12a(decoded,nbadcrc)
use crc
integer*1 decoded(87)
integer*1, target:: i1Dec8BitBytes(11)
character*87 cbits
! Write decoded bits into cbits: 75-bit message plus 12-bit CRC
write(cbits,1000) decoded
1000 format(87i1)
read(cbits,1001) i1Dec8BitBytes
1001 format(11b8)
read(cbits,1002) ncrc12 !Received CRC12
1002 format(75x,b12)
i1Dec8BitBytes(10)=iand(i1Dec8BitBytes(10),128+64+32)
i1Dec8BitBytes(11)=0
icrc12=crc12(c_loc(i1Dec8BitBytes),11) !CRC12 computed from 75 msg bits
nbadcrc=1
if(ncrc12.eq.icrc12) nbadcrc=0
return
end subroutine chkcrc12a

24
chkcrc14a.f90 Normal file
View File

@ -0,0 +1,24 @@
subroutine chkcrc14a(decoded,nbadcrc)
use crc
integer*1 decoded(91)
integer*1, target:: i1Dec8BitBytes(12)
character*91 cbits
! Write decoded bits into cbits: 77-bit message plus 14-bit CRC
write(cbits,1000) decoded
1000 format(91i1)
read(cbits,1001) i1Dec8BitBytes
1001 format(12b8)
read(cbits,1002) ncrc14 !Received CRC14
1002 format(77x,b14)
i1Dec8BitBytes(10)=iand(i1Dec8BitBytes(10),128+64+32+16+8)
i1Dec8BitBytes(11:12)=0
icrc14=crc14(c_loc(i1Dec8BitBytes),12) !CRC14 computed from 77 msg bits
nbadcrc=1
if(ncrc14.eq.icrc14) nbadcrc=0
return
end subroutine chkcrc14a

34
crc.f90
View File

@ -10,7 +10,7 @@ module crc
integer (c_int), value :: length integer (c_int), value :: length
end function crc14 end function crc14
function crc14_check (data, length) bind (C, name="crc16_check") function crc14_check (data, length) bind (C, name="crc14_check")
use, intrinsic :: iso_c_binding, only: c_bool, c_ptr, c_int use, intrinsic :: iso_c_binding, only: c_bool, c_ptr, c_int
implicit none implicit none
logical (c_bool) :: crc14_check logical (c_bool) :: crc14_check
@ -18,37 +18,5 @@ module crc
integer (c_int), value :: length integer (c_int), value :: length
end function crc14_check end function crc14_check
function crc12 (data, length) bind (C, name="crc12")
use, intrinsic :: iso_c_binding, only: c_short, c_ptr, c_int
implicit none
integer (c_short) :: crc12
type (c_ptr), value :: data
integer (c_int), value :: length
end function crc12
function crc12_check (data, length) bind (C, name="crc12_check")
use, intrinsic :: iso_c_binding, only: c_bool, c_ptr, c_int
implicit none
logical (c_bool) :: crc12_check
type (c_ptr), value :: data
integer (c_int), value :: length
end function crc12_check
function crc10 (data, length) bind (C, name="crc10")
use, intrinsic :: iso_c_binding, only: c_short, c_ptr, c_int
implicit none
integer (c_short) :: crc10
type (c_ptr), value :: data
integer (c_int), value :: length
end function crc10
function crc10_check (data, length) bind (C, name="crc10_check")
use, intrinsic :: iso_c_binding, only: c_bool, c_ptr, c_int
implicit none
logical (c_bool) :: crc10_check
type (c_ptr), value :: data
integer (c_int), value :: length
end function crc10_check
end interface end interface
end module crc end module crc

59
crc12.c
View File

@ -1,59 +0,0 @@
#include <stdbool.h>
static unsigned short table[256] =
{
0x0000, 0x1c06, 0x340a, 0x280c, 0x6814, 0x7412, 0x5c1e, 0x4018,
0xdc2e, 0xc028, 0xe824, 0xf422, 0xb43a, 0xa83c, 0x8030, 0x9c36,
0xb45a, 0xa85c, 0x8050, 0x9c56, 0xdc4e, 0xc048, 0xe844, 0xf442,
0x6874, 0x7472, 0x5c7e, 0x4078, 0x0060, 0x1c66, 0x346a, 0x286c,
0x68b4, 0x74b2, 0x5cbe, 0x40b8, 0x00a0, 0x1ca6, 0x34aa, 0x28ac,
0xb49a, 0xa89c, 0x8090, 0x9c96, 0xdc8e, 0xc088, 0xe884, 0xf482,
0xdcee, 0xc0e8, 0xe8e4, 0xf4e2, 0xb4fa, 0xa8fc, 0x80f0, 0x9cf6,
0x00c0, 0x1cc6, 0x34ca, 0x28cc, 0x68d4, 0x74d2, 0x5cde, 0x40d8,
0xdd6e, 0xc168, 0xe964, 0xf562, 0xb57a, 0xa97c, 0x8170, 0x9d76,
0x0140, 0x1d46, 0x354a, 0x294c, 0x6954, 0x7552, 0x5d5e, 0x4158,
0x6934, 0x7532, 0x5d3e, 0x4138, 0x0120, 0x1d26, 0x352a, 0x292c,
0xb51a, 0xa91c, 0x8110, 0x9d16, 0xdd0e, 0xc108, 0xe904, 0xf502,
0xb5da, 0xa9dc, 0x81d0, 0x9dd6, 0xddce, 0xc1c8, 0xe9c4, 0xf5c2,
0x69f4, 0x75f2, 0x5dfe, 0x41f8, 0x01e0, 0x1de6, 0x35ea, 0x29ec,
0x0180, 0x1d86, 0x358a, 0x298c, 0x6994, 0x7592, 0x5d9e, 0x4198,
0xddae, 0xc1a8, 0xe9a4, 0xf5a2, 0xb5ba, 0xa9bc, 0x81b0, 0x9db6,
0xb6da, 0xaadc, 0x82d0, 0x9ed6, 0xdece, 0xc2c8, 0xeac4, 0xf6c2,
0x6af4, 0x76f2, 0x5efe, 0x42f8, 0x02e0, 0x1ee6, 0x36ea, 0x2aec,
0x0280, 0x1e86, 0x368a, 0x2a8c, 0x6a94, 0x7692, 0x5e9e, 0x4298,
0xdeae, 0xc2a8, 0xeaa4, 0xf6a2, 0xb6ba, 0xaabc, 0x82b0, 0x9eb6,
0xde6e, 0xc268, 0xea64, 0xf662, 0xb67a, 0xaa7c, 0x8270, 0x9e76,
0x0240, 0x1e46, 0x364a, 0x2a4c, 0x6a54, 0x7652, 0x5e5e, 0x4258,
0x6a34, 0x7632, 0x5e3e, 0x4238, 0x0220, 0x1e26, 0x362a, 0x2a2c,
0xb61a, 0xaa1c, 0x8210, 0x9e16, 0xde0e, 0xc208, 0xea04, 0xf602,
0x6bb4, 0x77b2, 0x5fbe, 0x43b8, 0x03a0, 0x1fa6, 0x37aa, 0x2bac,
0xb79a, 0xab9c, 0x8390, 0x9f96, 0xdf8e, 0xc388, 0xeb84, 0xf782,
0xdfee, 0xc3e8, 0xebe4, 0xf7e2, 0xb7fa, 0xabfc, 0x83f0, 0x9ff6,
0x03c0, 0x1fc6, 0x37ca, 0x2bcc, 0x6bd4, 0x77d2, 0x5fde, 0x43d8,
0x0300, 0x1f06, 0x370a, 0x2b0c, 0x6b14, 0x7712, 0x5f1e, 0x4318,
0xdf2e, 0xc328, 0xeb24, 0xf722, 0xb73a, 0xab3c, 0x8330, 0x9f36,
0xb75a, 0xab5c, 0x8350, 0x9f56, 0xdf4e, 0xc348, 0xeb44, 0xf742,
0x6b74, 0x7772, 0x5f7e, 0x4378, 0x0360, 0x1f66, 0x376a, 0x2b6c
};
short crc12(unsigned char const *data, int length)
{
unsigned short remainder = 0;
unsigned char index;
int i;
for(i = 0; i < length; ++i)
{
index = remainder >> 4;
remainder <<= 8;
remainder |= data[i];
remainder ^= table[index];
}
return remainder & 0x0fff;
}
bool crc12_check(unsigned char const *data, int length)
{
return !crc12(data, length);
}

59
crc14.c Normal file
View File

@ -0,0 +1,59 @@
#include <stdbool.h>
static unsigned short table[256] =
{
0x0000, 0x6757, 0xe9f9, 0x8eae, 0xf4a5, 0x93f2, 0x1d5c, 0x7a0b,
0xce1d, 0xa94a, 0x27e4, 0x40b3, 0x3ab8, 0x5def, 0xd341, 0xb416,
0x9c3a, 0xfb6d, 0x75c3, 0x1294, 0x689f, 0x0fc8, 0x8166, 0xe631,
0x5227, 0x3570, 0xbbde, 0xdc89, 0xa682, 0xc1d5, 0x4f7b, 0x282c,
0x3874, 0x5f23, 0xd18d, 0xb6da, 0xccd1, 0xab86, 0x2528, 0x427f,
0xf669, 0x913e, 0x1f90, 0x78c7, 0x02cc, 0x659b, 0xeb35, 0x8c62,
0xa44e, 0xc319, 0x4db7, 0x2ae0, 0x50eb, 0x37bc, 0xb912, 0xde45,
0x6a53, 0x0d04, 0x83aa, 0xe4fd, 0x9ef6, 0xf9a1, 0x770f, 0x1058,
0x57bf, 0x30e8, 0xbe46, 0xd911, 0xa31a, 0xc44d, 0x4ae3, 0x2db4,
0x99a2, 0xfef5, 0x705b, 0x170c, 0x6d07, 0x0a50, 0x84fe, 0xe3a9,
0xcb85, 0xacd2, 0x227c, 0x452b, 0x3f20, 0x5877, 0xd6d9, 0xb18e,
0x0598, 0x62cf, 0xec61, 0x8b36, 0xf13d, 0x966a, 0x18c4, 0x7f93,
0x6fcb, 0x089c, 0x8632, 0xe165, 0x9b6e, 0xfc39, 0x7297, 0x15c0,
0xa1d6, 0xc681, 0x482f, 0x2f78, 0x5573, 0x3224, 0xbc8a, 0xdbdd,
0xf3f1, 0x94a6, 0x1a08, 0x7d5f, 0x0754, 0x6003, 0xeead, 0x89fa,
0x3dec, 0x5abb, 0xd415, 0xb342, 0xc949, 0xae1e, 0x20b0, 0x47e7,
0xaf7e, 0xc829, 0x4687, 0x21d0, 0x5bdb, 0x3c8c, 0xb222, 0xd575,
0x6163, 0x0634, 0x889a, 0xefcd, 0x95c6, 0xf291, 0x7c3f, 0x1b68,
0x3344, 0x5413, 0xdabd, 0xbdea, 0xc7e1, 0xa0b6, 0x2e18, 0x494f,
0xfd59, 0x9a0e, 0x14a0, 0x73f7, 0x09fc, 0x6eab, 0xe005, 0x8752,
0x970a, 0xf05d, 0x7ef3, 0x19a4, 0x63af, 0x04f8, 0x8a56, 0xed01,
0x5917, 0x3e40, 0xb0ee, 0xd7b9, 0xadb2, 0xcae5, 0x444b, 0x231c,
0x0b30, 0x6c67, 0xe2c9, 0x859e, 0xff95, 0x98c2, 0x166c, 0x713b,
0xc52d, 0xa27a, 0x2cd4, 0x4b83, 0x3188, 0x56df, 0xd871, 0xbf26,
0xf8c1, 0x9f96, 0x1138, 0x766f, 0x0c64, 0x6b33, 0xe59d, 0x82ca,
0x36dc, 0x518b, 0xdf25, 0xb872, 0xc279, 0xa52e, 0x2b80, 0x4cd7,
0x64fb, 0x03ac, 0x8d02, 0xea55, 0x905e, 0xf709, 0x79a7, 0x1ef0,
0xaae6, 0xcdb1, 0x431f, 0x2448, 0x5e43, 0x3914, 0xb7ba, 0xd0ed,
0xc0b5, 0xa7e2, 0x294c, 0x4e1b, 0x3410, 0x5347, 0xdde9, 0xbabe,
0x0ea8, 0x69ff, 0xe751, 0x8006, 0xfa0d, 0x9d5a, 0x13f4, 0x74a3,
0x5c8f, 0x3bd8, 0xb576, 0xd221, 0xa82a, 0xcf7d, 0x41d3, 0x2684,
0x9292, 0xf5c5, 0x7b6b, 0x1c3c, 0x6637, 0x0160, 0x8fce, 0xe899
};
short crc14(unsigned char const *data, int length)
{
unsigned short remainder = 0;
unsigned char index;
int i;
for(i = 0; i < length; ++i)
{
index = remainder >> 6;
remainder <<= 8;
remainder |= data[i];
remainder ^= table[index];
}
return remainder & 0x3fff;
}
bool crc14_check(unsigned char const *data, int length)
{
return !crc14(data, length);
}

5
db.f90
View File

@ -1,5 +0,0 @@
real function db(x)
db=-99.0
if(x.gt.1.259e-10) db=10.0*log10(x)
return
end function db

50
encode174.f90
View File

@ -1,50 +0,0 @@
subroutine encode174(message,codeword)
! Encode an 87-bit message and return a 174-bit codeword.
! The generator matrix has dimensions (87,87).
! The code is a (174,87) regular ldpc code with column weight 3.
! The code was generated using the PEG algorithm.
! After creating the codeword, the columns are re-ordered according to
! "colorder" to make the codeword compatible with the parity-check matrix
!
include "ldpc_174_87_params.f90"
integer*1 codeword(N)
integer*1 gen(M,K)
integer*1 itmp(N)
integer*1 message(K)
integer*1 pchecks(M)
logical first
data first/.true./
save first,gen
if( first ) then ! fill the generator matrix
gen=0
do i=1,M
do j=1,11
read(g(i)( (j-1)*2+1:(j-1)*2+2 ),"(Z2)") istr
do jj=1, 8
icol=(j-1)*8+jj
if( icol .le. 87 ) then
if( btest(istr,8-jj) ) gen(i,icol)=1
endif
enddo
enddo
enddo
first=.false.
endif
do i=1,M
nsum=0
do j=1,K
nsum=nsum+message(j)*gen(i,j)
enddo
pchecks(i)=mod(nsum,2)
enddo
itmp(1:M)=pchecks
itmp(M+1:N)=message(1:K)
codeword(colorder+1)=itmp(1:N)
return
end subroutine encode174

58
encode174_91.f90 Normal file
View File

@ -0,0 +1,58 @@
subroutine encode174_91(message77,codeword)
!
! Add a 14-bit CRC to a 77-bit message and return a 174-bit codeword
!
use, intrinsic :: iso_c_binding
use iso_c_binding, only: c_loc,c_size_t
use crc
integer, parameter:: N=174, K=91, M=N-K
character*91 tmpchar
integer*1 codeword(N)
integer*1 gen(M,K)
integer*1 message77(77),message(K)
integer*1 pchecks(M)
integer*1, target :: i1MsgBytes(12)
include "ldpc_174_91_c_generator.f90"
logical first
data first/.true./
save first,gen
if( first ) then ! fill the generator matrix
gen=0
do i=1,M
do j=1,23
read(g(i)(j:j),"(Z1)") istr
ibmax=4
if(j.eq.23) ibmax=3
do jj=1, ibmax
icol=(j-1)*4+jj
if( btest(istr,4-jj) ) gen(i,icol)=1
enddo
enddo
enddo
first=.false.
endif
! Add 14-bit CRC to form 91-bit message+CRC14
write(tmpchar,'(77i1)') message77
tmpchar(78:80)='000'
i1MsgBytes=0
read(tmpchar,'(10b8)') i1MsgBytes(1:10)
ncrc14 = crc14 (c_loc (i1MsgBytes), 12)
write(tmpchar(78:91),'(b14)') ncrc14
read(tmpchar,'(91i1)') message
do i=1,M
nsum=0
do j=1,K
nsum=nsum+message(j)*gen(i,j)
enddo
pchecks(i)=mod(nsum,2)
enddo
codeword(1:K)=message
codeword(K+1:N)=pchecks
return
end subroutine encode174_91

42
extractmessage174.f90
View File

@ -1,42 +0,0 @@
subroutine extractmessage174(decoded,msgreceived,msgcall,msggrid,ncrcflag)
use iso_c_binding, only: c_loc,c_size_t
use crc
use packjt
character msgreceived*22, msgcall*6, msggrid*4
character*87 cbits
integer*1 decoded(87)
integer*1, target:: i1Dec8BitBytes(11)
integer*4 i4Dec6BitWords(12)
! Write decoded bits into cbits: 75-bit message plus 12-bit CRC
write(cbits,1000) decoded
1000 format(87i1)
read(cbits,1001) i1Dec8BitBytes
1001 format(11b8)
read(cbits,1002) ncrc12 !Received CRC12
1002 format(75x,b12)
i1Dec8BitBytes(10)=iand(i1Dec8BitBytes(10),128+64+32)
i1Dec8BitBytes(11)=0
icrc12=crc12(c_loc(i1Dec8BitBytes),11) !CRC12 computed from 75 msg bits
if(ncrc12.eq.icrc12 .or. sum(decoded(57:87)).eq.0) then !### Kludge ###
! CRC12 checks out --- unpack 72-bit message
do ibyte=1,12
itmp=0
do ibit=1,6
itmp=ishft(itmp,1)+iand(1,decoded((ibyte-1)*6+ibit))
enddo
i4Dec6BitWords(ibyte)=itmp
enddo
call unpackmsg(i4Dec6BitWords,msgreceived,msgcall,msggrid)
ncrcflag=1
else
msgreceived=' '
msgcall=' '
msggrid=' '
ncrcflag=-1
endif
return
end subroutine extractmessage174

40
extractmessage174_91.f90 Normal file
View File

@ -0,0 +1,40 @@
subroutine extractmessage174_91(decoded,msgreceived,ncrcflag)
use iso_c_binding, only: c_loc,c_size_t
use crc
use packjt
character*22 msgreceived
character*91 cbits
integer*1 decoded(91)
integer*1, target:: i1Dec8BitBytes(12)
integer*4 i4Dec6BitWords(12)
! Write decoded bits into cbits: 77-bit message plus 14-bit CRC
write(cbits,1000) decoded
1000 format(91i1)
read(cbits,1001) i1Dec8BitBytes
1001 format(12b8)
read(cbits,1002) ncrc14 !Received CRC12
1002 format(77x,b14)
i1Dec8BitBytes(10)=iand(i1Dec8BitBytes(10),128+64+32+16+8)
i1Dec8BitBytes(11:12)=0
icrc14=crc14(c_loc(i1Dec8BitBytes),12) !CRC12 computed from 75 msg bits
if(ncrc14.eq.icrc14 .or. sum(decoded(57:87)).eq.0) then !### Kludge ###
! CRC14 checks out --- unpack 72-bit message
do ibyte=1,12
itmp=0
do ibit=1,6
itmp=ishft(itmp,1)+iand(1,decoded((ibyte-1)*6+ibit))
enddo
i4Dec6BitWords(ibyte)=itmp
enddo
call unpackmsg(i4Dec6BitWords,msgreceived)
ncrcflag=1
else
msgreceived=' '
ncrcflag=-1
endif
return
end subroutine extractmessage174_91

8
fmtmsg.f90
View File

@ -1,16 +1,16 @@
subroutine fmtmsg(msg,iz) subroutine fmtmsg(msg,iz)
character*22 msg character*(*) msg
! Convert all letters to upper case ! Convert all letters to upper case
iz=22 iz=len(msg)
do i=1,22 do i=1,iz
if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') & if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') &
msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a')) msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a'))
if(msg(i:i).ne.' ') iz=i if(msg(i:i).ne.' ') iz=i
enddo enddo
do iter=1,5 !Collapse multiple blanks into one do iter=1,37 !Collapse multiple blanks into one
ib2=index(msg(1:iz),' ') ib2=index(msg(1:iz),' ')
if(ib2.lt.1) go to 100 if(ib2.lt.1) go to 100
msg=msg(1:ib2)//msg(ib2+2:) msg=msg(1:ib2)//msg(ib2+2:)

6
ft8_params.f90
View File

@ -1,5 +1,5 @@
! LDPC (174,87) code ! LDPC (174,91) code
parameter (KK=87) !Information bits (75 + CRC12) parameter (KK=91) !Information bits (77 + CRC14)
parameter (ND=58) !Data symbols parameter (ND=58) !Data symbols
parameter (NS=21) !Sync symbols (3 @ Costas 7x7) parameter (NS=21) !Sync symbols (3 @ Costas 7x7)
parameter (NN=NS+ND) !Total channel symbols (79) parameter (NN=NS+ND) !Total channel symbols (79)
@ -10,4 +10,4 @@ parameter (NFFT1=2*NSPS) !Length of FFTs for symbol spectra
parameter (NSTEP=NSPS/4) !Rough time-sync step size parameter (NSTEP=NSPS/4) !Rough time-sync step size
parameter (NHSYM=NMAX/NSTEP-3) !Number of symbol spectra (1/4-sym steps) parameter (NHSYM=NMAX/NSTEP-3) !Number of symbol spectra (1/4-sym steps)
parameter (NDOWN=20) !Downsample factor parameter (NDOWN=20) !Downsample factor
parameter (MAXCAND=200) parameter (MAXCAND=300)

556
ft8b.f90
View File

@ -1,42 +1,55 @@
subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
napwid,nagain,iaptype,f1,xdt,xbase,apsym,nharderrors,dmin, & napwid,lsubtract,nagain,ncontest,iaptype,f1,xdt,xbase,apsym,nharderrors, &
nbadcrc,ipass,msgcall,msggrid,xsnr) dmin,nbadcrc,ipass,msg37,msgcall,msggrid,xsnr)
use crc use crc
use packjt77
include 'ft8_params.f90' include 'ft8_params.f90'
parameter(NP2=2812) parameter(NP2=2812)
character msgcall*6,msggrid*4,message*22 character*37 msg37
character*13 msgcall
character*4 msggrid
character*77 c77
real a(5) real a(5)
real s1(0:7,ND),s2(0:7,NN),s1sort(8*ND) real s8(0:7,NN)
real ps(0:7),psl(0:7) real s2(0:511),s2l(0:511)
real bmeta(3*ND),bmetb(3*ND),bmetap(3*ND) real bmeta(174),bmetb(174),bmetc(174)
real llr(3*ND),llra(3*ND),llr0(3*ND),llr1(3*ND),llrap(3*ND) !Soft symbols real llra(174),llrb(174),llrc(174),llrd(174) !Soft symbols
complex dd0(NMAX) complex dd0(NMAX)
integer*1 decoded(KK),apmask(3*ND),cw(3*ND) integer*1 message77(77),apmask(174),cw(174)
integer apsym(KK) integer apsym(58)
integer mcq(28),mde(28),mrrr(16),m73(16),mrr73(16) integer mcq(29),mcqru(29),mcqfd(29),mcqtest(29)
integer mrrr(19),m73(19),mrr73(19)
integer itone(NN) integer itone(NN)
integer indxs1(8*ND)
integer icos7(0:6),ip(1) integer icos7(0:6),ip(1)
integer nappasses(0:5) !Number of decoding passes to use for each QSO state integer nappasses(0:5) !Number of decoding passes to use for each QSO state
integer naptypes(0:5,4) ! (nQSOProgress, decoding pass) maximum of 4 passes for now integer naptypes(0:5,4) ! (nQSOProgress, decoding pass) maximum of 4 passes for now
complex cd0(3200) integer ncontest,ncontest0
logical one(0:511,0:8)
integer graymap(0:7)
complex cd0(0:3199)
complex ctwk(32) complex ctwk(32)
complex csymb(32) complex csymb(32)
logical first,newdat,lapon,lapcqonly,nagain complex cs(0:7,NN)
equivalence (s1,s1sort) logical first,newdat,lsubtract,lapon,lapcqonly,nagain,unpk77_success
data icos7/2,5,6,0,4,1,3/ data icos7/3,1,4,0,6,5,2/ ! Flipped w.r.t. original FT8 sync array
data mcq/1,1,1,1,1,0,1,0,0,0,0,0,1,0,0,0,0,0,1,1,0,0,0,1,1,0,0,1/ 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 mrrr/0,1,1,1,1,1,1,0,1,1,0,0,1,1,1,1/ 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 m73/0,1,1,1,1,1,1,0,1,1,0,1,0,0,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 mde/1,1,1,1,1,1,1,1,0,1,1,0,0,1,0,0,0,0,0,1,1,1,0,1,0,0,0,1/ 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 mrr73/0,0,0,0,0,0,1,0,0,0,0,1,0,1,0,1/ 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 first/.true./ data first/.true./
save nappasses,naptypes data graymap/0,1,3,2,5,6,4,7/
save nappasses,naptypes,ncontest0,one
if(first) then
if(first.or.(ncontest.ne.ncontest0)) then
mcq=2*mcq-1 mcq=2*mcq-1
mde=2*mde-1 mcqfd=2*mcqfd-1
mcqru=2*mcqru-1
mcqtest=2*mcqtest-1
mrrr=2*mrrr-1 mrrr=2*mrrr-1
m73=2*m73-1 m73=2*m73-1
mrr73=2*mrr73-1 mrr73=2*mrr73-1
@ -49,25 +62,33 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
! iaptype ! iaptype
!------------------------ !------------------------
! 1 CQ ??? ??? ! 1 CQ ??? ??? (29+3=32 ap bits)
! 2 MyCall ??? ??? ! 2 MyCall ??? ??? (29+3=32 ap bits)
! 3 MyCall DxCall ??? ! 3 MyCall DxCall ??? (58+3=61 ap bits)
! 4 MyCall DxCall RRR ! 4 MyCall DxCall RRR (77 ap bits)
! 5 MyCall DxCall 73 ! 5 MyCall DxCall 73 (77 ap bits)
! 6 MyCall DxCall RR73 ! 6 MyCall DxCall RR73 (77 ap bits)
! 7 ??? DxCall ???
naptypes(0,1:4)=(/1,2,0,0/) naptypes(0,1:4)=(/1,2,0,0/) ! Tx6 selected (CQ)
naptypes(1,1:4)=(/2,3,0,0/) naptypes(1,1:4)=(/2,3,0,0/) ! Tx1
naptypes(2,1:4)=(/2,3,0,0/) naptypes(2,1:4)=(/2,3,0,0/) ! Tx2
naptypes(3,1:4)=(/3,4,5,6/) naptypes(3,1:4)=(/3,4,5,6/) ! Tx3
naptypes(4,1:4)=(/3,4,5,6/) naptypes(4,1:4)=(/3,4,5,6/) ! Tx4
naptypes(5,1:4)=(/3,1,2,0/) naptypes(5,1:4)=(/3,1,2,0/) ! Tx5
one=.false.
do i=0,511
do j=0,8
if(iand(i,2**j).ne.0) one(i,j)=.true.
enddo
enddo
first=.false. first=.false.
ncontest0=ncontest
endif endif
max_iterations=30 max_iterations=30
nharderrors=-1 nharderrors=-1
nbadcrc=1 ! this is used upstream to flag good decodes.
fs2=4000.0/NDOWN fs2=4000.0/NDOWN
dt2=1.0/fs2 dt2=1.0/fs2
twopi=8.0*atan(1.0) twopi=8.0*atan(1.0)
@ -98,7 +119,7 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
ctwk(i)=cmplx(cos(phi),sin(phi)) ctwk(i)=cmplx(cos(phi),sin(phi))
phi=mod(phi+dphi,twopi) phi=mod(phi+dphi,twopi)
enddo enddo
call sync8d(cd0,i0,ctwk,1,sync) call sync8d(cd0,i0,ctwk,1,sync)
if( sync .gt. smax ) then if( sync .gt. smax ) then
smax=sync smax=sync
delfbest=delf delfbest=delf
@ -109,16 +130,15 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
call twkfreq1(cd0,NP2,fs2,a,cd0) call twkfreq1(cd0,NP2,fs2,a,cd0)
xdt=xdt2 xdt=xdt2
f1=f1+delfbest !Improved estimate of DF f1=f1+delfbest !Improved estimate of DF
call sync8d(cd0,i0,ctwk,0,sync)
call sync8d(cd0,i0,ctwk,2,sync)
j=0
do k=1,NN do k=1,NN
i1=ibest+(k-1)*32 i1=ibest+(k-1)*32
csymb=cmplx(0.0,0.0) csymb=cmplx(0.0,0.0)
if( i1.ge.1 .and. i1+31 .le. NP2 ) csymb=cd0(i1:i1+31) if( i1.ge.0 .and. i1+31 .le. NP2-1 ) csymb=cd0(i1:i1+31)
call four2a(csymb,32,1,-1,1) call four2a(csymb,32,1,-1,1)
s2(0:7,k)=abs(csymb(1:8))/1e3 cs(0:7,k)=csymb(1:8)/1e3
s8(0:7,k)=abs(csymb(1:8))
enddo enddo
! sync quality check ! sync quality check
@ -126,11 +146,11 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
is2=0 is2=0
is3=0 is3=0
do k=1,7 do k=1,7
ip=maxloc(s2(:,k)) ip=maxloc(s8(:,k))
if(icos7(k-1).eq.(ip(1)-1)) is1=is1+1 if(icos7(k-1).eq.(ip(1)-1)) is1=is1+1
ip=maxloc(s2(:,k+36)) ip=maxloc(s8(:,k+36))
if(icos7(k-1).eq.(ip(1)-1)) is2=is2+1 if(icos7(k-1).eq.(ip(1)-1)) is2=is2+1
ip=maxloc(s2(:,k+72)) ip=maxloc(s8(:,k+72))
if(icos7(k-1).eq.(ip(1)-1)) is3=is3+1 if(icos7(k-1).eq.(ip(1)-1)) is3=is3+1
enddo enddo
! hard sync sum - max is 21 ! hard sync sum - max is 21
@ -140,245 +160,258 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
return return
endif endif
j=0 do nsym=1,3
do k=1,NN nt=2**(3*nsym)
if(k.le.7) cycle do ihalf=1,2
if(k.ge.37 .and. k.le.43) cycle do k=1,29,nsym
if(k.gt.72) cycle if(ihalf.eq.1) ks=k+7
j=j+1 if(ihalf.eq.2) ks=k+43
s1(0:7,j)=s2(0:7,k) amax=-1.0
do i=0,nt-1
i1=i/64
i2=iand(i,63)/8
i3=iand(i,7)
if(nsym.eq.1) then
s2(i)=abs(cs(graymap(i3),ks))
elseif(nsym.eq.2) then
s2(i)=abs(cs(graymap(i2),ks)+cs(graymap(i3),ks+1))
elseif(nsym.eq.3) then
s2(i)=abs(cs(graymap(i1),ks)+cs(graymap(i2),ks+1)+cs(graymap(i3),ks+2))
else
print*,"Error - nsym must be 1, 2, or 3."
endif
enddo
s2l(0:nt-1)=log(s2(0:nt-1)+1e-32)
i32=1+(k-1)*3+(ihalf-1)*87
if(nsym.eq.1) ibmax=2
if(nsym.eq.2) ibmax=5
if(nsym.eq.3) ibmax=8
do ib=0,ibmax
bm=maxval(s2(0:nt-1),one(0:nt-1,ibmax-ib)) - &
maxval(s2(0:nt-1),.not.one(0:nt-1,ibmax-ib))
if(i32+ib .gt.174) cycle
if(nsym.eq.1) then
bmeta(i32+ib)=bm
elseif(nsym.eq.2) then
bmetb(i32+ib)=bm
elseif(nsym.eq.3) then
bmetc(i32+ib)=bm
endif
enddo
enddo
enddo
enddo enddo
call normalizebmet(bmeta,174)
call normalizebmet(bmetb,174)
call normalizebmet(bmetc,174)
call indexx(s1sort,8*ND,indxs1) scalefac=2.83
xmeds1=s1sort(indxs1(nint(0.5*8*ND))) llra=scalefac*bmeta
s1=s1/xmeds1 llrb=scalefac*bmetb
llrc=scalefac*bmetc
do j=1,ND apmag=maxval(abs(llra))*1.01
i4=3*j-2
i2=3*j-1
i1=3*j
! Max amplitude
ps=s1(0:7,j)
r1=max(ps(1),ps(3),ps(5),ps(7))-max(ps(0),ps(2),ps(4),ps(6))
r2=max(ps(2),ps(3),ps(6),ps(7))-max(ps(0),ps(1),ps(4),ps(5))
r4=max(ps(4),ps(5),ps(6),ps(7))-max(ps(0),ps(1),ps(2),ps(3))
bmeta(i4)=r4
bmeta(i2)=r2
bmeta(i1)=r1
bmetap(i4)=r4
bmetap(i2)=r2
bmetap(i1)=r1
! Max log metric
psl=log(ps+1e-32)
r1=max(psl(1),psl(3),psl(5),psl(7))-max(psl(0),psl(2),psl(4),psl(6))
r2=max(psl(2),psl(3),psl(6),psl(7))-max(psl(0),psl(1),psl(4),psl(5))
r4=max(psl(4),psl(5),psl(6),psl(7))-max(psl(0),psl(1),psl(2),psl(3))
bmetb(i4)=r4
bmetb(i2)=r2
bmetb(i1)=r1
! Metric for Cauchy noise ! pass #
! r1=log(ps(1)**3+ps(3)**3+ps(5)**3+ps(7)**3)- & !------------------------------
! log(ps(0)**3+ps(2)**3+ps(4)**3+ps(6)**3) ! 1 regular decoding, nsym=1
! r2=log(ps(2)**3+ps(3)**3+ps(6)**3+ps(7)**3)- & ! 2 regular decoding, nsym=2
! log(ps(0)**3+ps(1)**3+ps(4)**3+ps(5)**3) ! 3 regular decoding, nsym=3
! r4=log(ps(4)**3+ps(5)**3+ps(6)**3+ps(7)**3)- & ! 4 ap pass 1, nsym=1 (for now?)
! log(ps(0)**3+ps(1)**3+ps(2)**3+ps(3)**3) ! 5 ap pass 2
! Metric for AWGN, no fading ! 6 ap pass 3
! bscale=2.5 ! 7 ap pass 4
! b0=bessi0(bscale*ps(0))
! b1=bessi0(bscale*ps(1))
! b2=bessi0(bscale*ps(2))
! b3=bessi0(bscale*ps(3))
! b4=bessi0(bscale*ps(4))
! b5=bessi0(bscale*ps(5))
! b6=bessi0(bscale*ps(6))
! b7=bessi0(bscale*ps(7))
! r1=log(b1+b3+b5+b7)-log(b0+b2+b4+b6)
! r2=log(b2+b3+b6+b7)-log(b0+b1+b4+b5)
! r4=log(b4+b5+b6+b7)-log(b0+b1+b2+b3)
if(nQSOProgress .eq. 0 .or. nQSOProgress .eq. 5) then if(lapon.or.ncontest.eq.6) then !Hounds always use AP
! When bits 88:115 are set as ap bits, bit 115 lives in symbol 39 along if(.not.lapcqonly) then
! with no-ap bits 116 and 117. Take care of metrics for bits 116 and 117. npasses=3+nappasses(nQSOProgress)
if(j.eq.39) then ! take care of bits that live in symbol 39 else
if(apsym(28).lt.0) then npasses=4
bmetap(i2)=max(ps(2),ps(3))-max(ps(0),ps(1)) endif
bmetap(i1)=max(ps(1),ps(3))-max(ps(0),ps(2)) else
else npasses=3
bmetap(i2)=max(ps(6),ps(7))-max(ps(4),ps(5)) endif
bmetap(i1)=max(ps(5),ps(7))-max(ps(4),ps(6))
do ipass=1,npasses
llrd=llra
if(ipass.eq.2) llrd=llrb
if(ipass.eq.3) llrd=llrc
if(ipass.le.3) then
apmask=0
iaptype=0
endif
if(ipass .gt. 3) then
llrd=llra
if(.not.lapcqonly) then
iaptype=naptypes(nQSOProgress,ipass-3)
else
iaptype=1
endif
! ncontest=0 : NONE
! 1 : NA_VHF
! 2 : EU_VHF
! 3 : FIELD DAY
! 4 : RTTY
! 5 : FOX
! 6 : HOUND
!
! Conditions that cause us to bail out of AP decoding
if(ncontest.le.4 .and. iaptype.ge.3 .and. (abs(f1-nfqso).gt.napwid .and. abs(f1-nftx).gt.napwid) ) cycle
if(ncontest.eq.5) cycle ! No AP for Foxes
if(ncontest.eq.6.and.f1.gt.950.0) cycle ! Hounds use AP only for signals below 950 Hz
if(iaptype.ge.2 .and. apsym(1).gt.1) cycle ! No, or nonstandard, mycall
if(iaptype.ge.3 .and. apsym(30).gt.1) cycle ! No, or nonstandard, dxcall
if(iaptype.eq.1) then ! CQ or CQ RU or CQ TEST or CQ FD
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.6) llrd(1:29)=apmag*mcq(1:29)
apmask(75:77)=1
llrd(75:76)=apmag*(-1)
llrd(77)=apmag*(+1)
endif
if(iaptype.eq.2) then ! MyCall,???,???
apmask=0
if(ncontest.eq.0.or.ncontest.eq.1) then
apmask(1:29)=1
llrd(1:29)=apmag*apsym(1:29)
apmask(75:77)=1
llrd(75:76)=apmag*(-1)
llrd(77)=apmag*(+1)
else if(ncontest.eq.2) then
apmask(1:28)=1
llrd(1:28)=apmag*apsym(1:28)
apmask(72:74)=1
llrd(72)=apmag*(-1)
llrd(73)=apmag*(+1)
llrd(74)=apmag*(-1)
apmask(75:77)=1
llrd(75:77)=apmag*(-1)
else if(ncontest.eq.3) then
apmask(1:28)=1
llrd(1:28)=apmag*apsym(1:28)
apmask(75:77)=1
llrd(75:77)=apmag*(-1)
else if(ncontest.eq.4) then
apmask(2:29)=1
llrd(2:29)=apmag*apsym(1:28)
apmask(75:77)=1
llrd(75)=apmag*(-1)
llrd(76:77)=apmag*(+1)
else if(ncontest.eq.6) then ! ??? RR73; MyCall <???> ???
apmask(29:56)=1
llrd(29:56)=apmag*apsym(1:28)
apmask(72:77)=1
llrd(72:73)=apmag*(-1)
llrd(74)=apmag*(+1)
llrd(75:77)=apmag*(-1)
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.6) then
apmask(1:58)=1
llrd(1:58)=apmag*apsym
apmask(75:77)=1
llrd(75:76)=apmag*(-1)
llrd(77)=apmag*(+1)
else if(ncontest.eq.3) then ! Field Day
apmask(1:56)=1
llrd(1:28)=apmag*apsym(1:28)
llrd(29:56)=apmag*apsym(30:57)
apmask(72:74)=1
apmask(75:77)=1
llrd(75:77)=apmag*(-1)
else if(ncontest.eq.4) then ! RTTY RU
apmask(2:57)=1
llrd(2:29)=apmag*apsym(1:28)
llrd(30:57)=apmag*apsym(30:57)
apmask(75:77)=1
llrd(75)=apmag*(-1)
llrd(76:77)=apmag*(+1)
endif
endif
if(iaptype.eq.5.and.ncontest.eq.6) cycle !Hound
if(iaptype.eq.4 .or. iaptype.eq.5 .or. iaptype.eq.6) then
apmask=0
if(ncontest.le.4 .or. (ncontest.eq.6.and.iaptype.eq.6)) then
apmask(1:77)=1 ! mycall, hiscall, RRR|73|RR73
llrd(1:58)=apmag*apsym
if(iaptype.eq.4) llrd(59:77)=apmag*mrrr
if(iaptype.eq.5) llrd(59:77)=apmag*m73
if(iaptype.eq.6) llrd(59:77)=apmag*mrr73
else if(ncontest.eq.6.and.iaptype.eq.4) then ! Hound listens for MyCall RR73;...
apmask(1:28)=1
llrd(1:28)=apmag*apsym(1:28)
apmask(72:77)=1
llrd(72:73)=apmag*(-1)
llrd(74)=apmag*(1)
llrd(75:77)=apmag*(-1)
endif endif
endif endif
endif endif
! When bits 116:143 are set as ap bits, bit 115 lives in symbol 39 along
! with ap bits 116 and 117. Take care of metric for bit 115.
! if(j.eq.39) then ! take care of bit 115
! iii=2*(apsym(29)+1)/2 + (apsym(30)+1)/2 ! known values of bits 116 & 117
! if(iii.eq.0) bmetap(i4)=ps(4)-ps(0)
! if(iii.eq.1) bmetap(i4)=ps(5)-ps(1)
! if(iii.eq.2) bmetap(i4)=ps(6)-ps(2)
! if(iii.eq.3) bmetap(i4)=ps(7)-ps(3)
! endif
! bit 144 lives in symbol 48 and will be 1 if it is set as an ap bit.
! take care of metrics for bits 142 and 143
if(j.eq.48) then ! bit 144 is always 1
bmetap(i4)=max(ps(5),ps(7))-max(ps(1),ps(3))
bmetap(i2)=max(ps(3),ps(7))-max(ps(1),ps(5))
endif
! bit 154 lives in symbol 52 and will be 0 if it is set as an ap bit
! take care of metrics for bits 155 and 156
if(j.eq.52) then ! bit 154 will be 0 if it is set as an ap bit.
bmetap(i2)=max(ps(2),ps(3))-max(ps(0),ps(1))
bmetap(i1)=max(ps(1),ps(3))-max(ps(0),ps(2))
endif
enddo
call normalizebmet(bmeta,3*ND)
call normalizebmet(bmetb,3*ND)
call normalizebmet(bmetap,3*ND)
scalefac=2.83
llr0=scalefac*bmeta
llr1=scalefac*bmetb
llra=scalefac*bmetap ! llr's for use with ap
apmag=scalefac*(maxval(abs(bmetap))*1.01)
! pass #
!------------------------------
! 1 regular decoding
! 2 erase 24
! 3 erase 48
! 4 ap pass 1
! 5 ap pass 2
! 6 ap pass 3
! 7 ap pass 4, etc.
if(lapon) then
if(.not.lapcqonly) then
npasses=4+nappasses(nQSOProgress)
else
npasses=5
endif
else
npasses=4
endif
do ipass=1,npasses
llr=llr0
if(ipass.eq.2) llr=llr1
if(ipass.eq.3) llr(1:24)=0.
if(ipass.eq.4) llr(1:48)=0.
if(ipass.le.4) then
apmask=0
llrap=llr
iaptype=0
endif
if(ipass .gt. 4) then
if(.not.lapcqonly) then
iaptype=naptypes(nQSOProgress,ipass-4)
else
iaptype=1
endif
if(iaptype.ge.3 .and. (abs(f1-nfqso).gt.napwid .and. abs(f1-nftx).gt.napwid) ) cycle
if(iaptype.eq.1 .or. iaptype.eq.2 ) then ! AP,???,???
apmask=0
apmask(88:115)=1 ! first 28 bits are AP
apmask(144)=1 ! not free text
llrap=llr
if(iaptype.eq.1) llrap(88:115)=apmag*mcq
if(iaptype.eq.2) llrap(88:115)=apmag*apsym(1:28)
llrap(116:117)=llra(116:117)
llrap(142:143)=llra(142:143)
llrap(144)=-apmag
endif
if(iaptype.eq.3) then ! mycall, dxcall, ???
apmask=0
apmask(88:115)=1 ! mycall
apmask(116:143)=1 ! hiscall
apmask(144)=1 ! not free text
llrap=llr
llrap(88:143)=apmag*apsym(1:56)
llrap(144)=-apmag
endif
if(iaptype.eq.4 .or. iaptype.eq.5 .or. iaptype.eq.6) then
apmask=0
apmask(88:115)=1 ! mycall
apmask(116:143)=1 ! hiscall
apmask(144:159)=1 ! RRR or 73 or RR73
llrap=llr
llrap(88:143)=apmag*apsym(1:56)
if(iaptype.eq.4) llrap(144:159)=apmag*mrrr
if(iaptype.eq.5) llrap(144:159)=apmag*m73
if(iaptype.eq.6) llrap(144:159)=apmag*mrr73
endif
if(iaptype.eq.7) then ! ???, dxcall, ???
apmask=0
apmask(116:143)=1 ! hiscall
apmask(144)=1 ! not free text
llrap=llr
llrap(115)=llra(115)
llrap(116:143)=apmag*apsym(29:56)
llrap(144)=-apmag
endif
endif
cw=0 cw=0
call bpdecode174(llrap,apmask,max_iterations,decoded,cw,nharderrors, & call bpdecode174_91(llrd,apmask,max_iterations,message77,cw,nharderrors, &
niterations) niterations)
dmin=0.0 dmin=0.0
if(ndepth.eq.3 .and. nharderrors.lt.0) then if(ndepth.eq.3 .and. nharderrors.lt.0) then
ndeep=3 ndeep=3
if(abs(nfqso-f1).le.napwid .or. abs(nftx-f1).le.napwid) then if(abs(nfqso-f1).le.napwid .or. abs(nftx-f1).le.napwid) then
if((ipass.eq.3 .or. ipass.eq.4) .and. .not.nagain) then ndeep=4
ndeep=3
else
ndeep=4
endif
endif endif
if(nagain) ndeep=5 if(nagain) ndeep=5
call osd174(llrap,apmask,ndeep,decoded,cw,nharderrors,dmin) call osd174_91(llrd,apmask,ndeep,message77,cw,nharderrors,dmin)
endif endif
nbadcrc=1
message=' ' msg37=' '
xsnr=-99.0 if(nharderrors.lt.0 .or. nharderrors.gt.36) cycle
if(count(cw.eq.0).eq.174) cycle !Reject the all-zero codeword if(count(cw.eq.0).eq.174) cycle !Reject the all-zero codeword
if(nharderrors.ge.0 .and. nharderrors+dmin.lt.60.0 .and. & write(c77,'(77i1)') message77
.not.(sync.lt.2.0 .and. nharderrors.gt.35) .and. & read(c77(72:74),'(b3)') n3
.not.(ipass.gt.2 .and. nharderrors.gt.39) .and. & read(c77(75:77),'(b3)') i3
.not.(ipass.eq.4 .and. nharderrors.gt.30) & if(i3.gt.4 .or. (i3.eq.0.and.n3.gt.5)) then
) then
call chkcrc12a(decoded,nbadcrc)
else
nharderrors=-1
cycle cycle
endif endif
if(nbadcrc.eq.0) then call unpack77(c77,msg37,msgcall,msggrid,unpk77_success)
call extractmessage174(decoded,message,msgcall,msggrid,ncrcflag) if(.not.unpk77_success) then
call genft8(message,0,itone) cycle
xsig=0.0
xnoi=0.0
do i=1,79
xsig=xsig+s2(itone(i),i)**2
ios=mod(itone(i)+4,7)
xnoi=xnoi+s2(ios,i)**2
enddo
xsnr=0.001
if(xnoi.gt.0 .and. xnoi.lt.xsig) xsnr=xsig/xnoi-1.0
xsnr=10.0*log10(xsnr)-27.0
xsnr2=db(xsig/xbase - 1.0) - 32.0
if(.not.nagain) xsnr=xsnr2
if(xsnr .lt. -24.0) xsnr=-24.0
return
endif endif
enddo nbadcrc=0 ! If we get this far: valid codeword, valid (i3,n3), nonquirky message.
call get_tones_from_77bits(message77,itone)
if(lsubtract) call subtractft8(dd0,itone,f1,xdt)
xsig=0.0
xnoi=0.0
do i=1,79
xsig=xsig+s8(itone(i),i)**2
ios=mod(itone(i)+4,7)
xnoi=xnoi+s8(ios,i)**2
enddo
xsnr=0.001
xsnr2=0.001
arg=xsig/xnoi-1.0
if(arg.gt.0.1) xsnr=arg
arg=xsig/xbase/2.6e6-1.0
if(arg.gt.0.1) xsnr2=arg
xsnr=10.0*log10(xsnr)-27.0
xsnr2=10.0*log10(xsnr2)-27.0
if(.not.nagain) then
xsnr=xsnr2
endif
if(xsnr .lt. -24.0) xsnr=-24.0
return
enddo
return return
end subroutine ft8b end subroutine ft8b
@ -420,4 +453,3 @@ function bessi0(x)
endif endif
return return
end function bessi0 end function bessi0

85
ft8d.f90
View File

@ -3,14 +3,16 @@ program ft8d
! Decode FT8 data read from *.c2 files. ! Decode FT8 data read from *.c2 files.
include 'ft8_params.f90' include 'ft8_params.f90'
character infile*80,date*6,time*4 character infile*80,msg37*37,date*6,time*4
character msgcall*6,msggrid*4 character msgcall*13,msggrid*4
character*37 allmessages(100)
real s(NFFT1,NHSYM) real s(NFFT1,NHSYM)
real sbase(NFFT1) real sbase(NFFT1)
real candidate(3,MAXCAND) real candidate(3,MAXCAND)
real*8 dialfreq real*8 dialfreq
complex dd(NMAX,4) complex dd(NMAX,4)
logical newdat logical newdat,lft8apon,lsubtract,ldupe
integer allsnrs(100)
integer apsym(KK) integer apsym(KK)
nargs=iargc() nargs=iargc()
@ -19,13 +21,6 @@ program ft8d
go to 999 go to 999
endif endif
twopi=8.0*atan(1.0)
fs=4000.0 !Sample rate
dt=1.0/fs !Sample interval (s)
tt=NSPS*dt !Duration of "itone" symbols (s)
ts=2*NSPS*dt !Duration of OQPSK symbols (s)
baud=1.0/tt !Keying rate (baud)
txt=NZ*dt !Transmission length (s)
nfa=-1600 nfa=-1600
nfb=+1600 nfb=+1600
nfqso=0 nfqso=0
@ -38,29 +33,59 @@ program ft8d
date=infile(j2-11:j2-6) date=infile(j2-11:j2-6)
time=infile(j2-4:j2-1) time=infile(j2-4:j2-1)
do ipart=1,4 do ipart=1,4
nQSOProgress=0
ndecodes=0 ndecodes=0
n2=0
allmessages=' '
allsnrs=0
ncontest=0
lft8apon=.false.
ndepth=1 ndepth=1
newdat=.true. if(ndepth.eq.1) npass=1
syncmin=1.5 if(ndepth.ge.2) npass=3
call sync8(dd(1:NMAX,ipart),nfa+2000,nfb+2000,syncmin, & do ipass=1,npass
nfqso+2000,s,candidate,ncand,sbase) newdat=.true.
do icand=1,ncand syncmin=1.5
sync=candidate(3,icand) if(ipass.eq.1) then
f1=candidate(1,icand) lsubtract=.true.
xdt=candidate(2,icand) if(ndepth.eq.1) lsubtract=.false.
xbase=10.0**(0.1*(sbase(nint(f1/3.125))-40.0)) elseif(ipass.eq.2) then
call ft8b(dd(1:NMAX,ipart),newdat,nQSOProgress,nfqso+2000, & n2=ndecodes
nftx,ndepth,lft8apon,lapcqonly,napwid,nagain,iaptype, & if(ndecodes.eq.0) cycle
f1,xdt,xbase,apsym,nharderrors,dmin,nbadcrc,iappass, & lsubtract=.true.
msgcall,msggrid,xsnr) elseif(ipass.eq.3) then
nsnr=nint(xsnr) if((ndecodes-n2).eq.0) cycle
xdt=xdt-0.5 lsubtract=.false.
hd=nharderrors+dmin
if(nbadcrc.eq.0) then
write(*,1004) date,time,15*(ipart-1),min(sync,999.0),nint(xsnr), &
xdt,nint(f1-2000+dialfreq),msgcall,msggrid
1004 format(a6,1x,a4,i2.2,f6.1,i4,f6.2,i9,1x,a6,1x,a4)
endif endif
call sync8(dd(1:NMAX,ipart),nfa+2000,nfb+2000,syncmin, &
nfqso+2000,s,candidate,ncand,sbase)
do icand=1,ncand
sync=candidate(3,icand)
f1=candidate(1,icand)
xdt=candidate(2,icand)
xbase=10.0**(0.1*(sbase(nint(f1/3.125))-40.0))
call ft8b(dd(1:NMAX,ipart),newdat,nQSOProgress,nfqso+2000, &
nftx,ndepth,lft8apon,lapcqonly,napwid,lsubtract,nagain, &
ncontest,iaptype,f1,xdt,xbase,apsym,nharderrors,dmin, &
nbadcrc,iappass,msg37,msgcall,msggrid,xsnr)
nsnr=nint(xsnr)
xdt=xdt-0.5
hd=nharderrors+dmin
if(nbadcrc.eq.0) then
ldupe=.false.
do id=1,ndecodes
if(msg37.eq.allmessages(id).and.nsnr.le.allsnrs(id)) ldupe=.true.
enddo
if(.not.ldupe) then
ndecodes=ndecodes+1
allmessages(ndecodes)=msg37
allsnrs(ndecodes)=nsnr
endif
write(*,1004) date,time,15*(ipart-1),min(sync,999.0),nint(xsnr), &
xdt,nint(f1-2000+dialfreq),msgcall,msggrid
1004 format(a6,1x,a4,i2.2,f6.1,i4,f6.2,i9,1x,a13,1x,a4)
endif
enddo
enddo enddo
enddo ! ipart loop enddo ! ipart loop

51
genft8.f90
View File

@ -1,35 +1,33 @@
subroutine genft8(msg,i3bit,itone) subroutine genft8(msg,i3,n3,msgsent,msgbits,itone)
! Encode an FT8 message, producing array itone(). ! Encode an FT8 message, producing array itone().
use crc use packjt77
use packjt
include 'ft8_params.f90' include 'ft8_params.f90'
character*22 msg character msg*37,msgsent*37,msgcall*13,msggrid*4
character*87 cbits character*77 c77
integer*4 i4Msg6BitWords(12) !72-bit message as 6-bit words integer*1 msgbits(77),codeword(174)
integer*1 msgbits(KK),codeword(3*ND) integer itone(79)
integer*1, target:: i1Msg8BitBytes(11)
integer itone(NN)
integer icos7(0:6) integer icos7(0:6)
data icos7/2,5,6,0,4,1,3/ !Costas 7x7 tone pattern integer graymap(0:7)
logical unpk77_success
data icos7/3,1,4,0,6,5,2/ !Costas 7x7 tone pattern
data graymap/0,1,3,2,5,6,4,7/
call packmsg(msg,i4Msg6BitWords,itype) !Pack into 12 6-bit bytes i3=-1
n3=-1
call pack77(msg,i3,n3,c77)
call unpack77(c77,msgsent,msgcall,msggrid,unpk77_success)
read(c77,'(77i1)',err=1) msgbits
if(unpk77_success) go to 2
1 msgbits=0
itone=0
msgsent='*** bad message *** '
go to 900
write(cbits,1000) i4Msg6BitWords,32*i3bit entry get_tones_from_77bits(msgbits,itone)
1000 format(12b6.6,b8.8)
read(cbits,1001) i1Msg8BitBytes(1:10)
1001 format(10b8)
i1Msg8BitBytes(10)=iand(i1Msg8BitBytes(10),128+64+32)
i1Msg8BitBytes(11)=0
icrc12=crc12(c_loc(i1Msg8BitBytes),11)
write(cbits,1003) i4Msg6BitWords,i3bit,icrc12 2 call encode174_91(msgbits,codeword) !Encode the test message
1003 format(12b6.6,b3.3,b12.12)
read(cbits,1004) msgbits
1004 format(87i1)
call encode174(msgbits,codeword) !Encode the test message
! Message structure: S7 D29 S7 D29 S7 ! Message structure: S7 D29 S7 D29 S7
itone(1:7)=icos7 itone(1:7)=icos7
@ -40,8 +38,9 @@ subroutine genft8(msg,i3bit,itone)
i=3*j -2 i=3*j -2
k=k+1 k=k+1
if(j.eq.30) k=k+7 if(j.eq.30) k=k+7
itone(k)=codeword(i)*4 + codeword(i+1)*2 + codeword(i+2) indx=codeword(i)*4 + codeword(i+1)*2 + codeword(i+2)
itone(k)=graymap(indx)
enddo enddo
return 900 return
end subroutine genft8 end subroutine genft8

23
genft8refsig.f90 Normal file
View File

@ -0,0 +1,23 @@
subroutine genft8refsig(itone,cref,f0)
complex cref(79*640)
integer itone(79)
! real*8 twopi,phi,dphi,dt,xnsps
real twopi,phi,dphi,dt,xnsps
data twopi/0.d0/
save twopi
if( twopi .lt. 0.1 ) twopi=8.d0*atan(1.d0)
xnsps=640.d0
dt=1.d0/4000.d0
phi=0.d0
k=1
do i=1,79
dphi=twopi*(f0*dt+itone(i)/xnsps)
do is=1,640
cref(k)=cmplx(cos(phi),sin(phi))
phi=mod(phi+dphi,twopi)
k=k+1
enddo
enddo
return
end subroutine genft8refsig

102
ldpc_174_87_params.f90
View File

@ -1,102 +0,0 @@
integer, parameter:: N=174, K=87, M=N-K
character*22 g(87)
integer colorder(N)
data g/ & !parity generator matrix for (174,87) code
"23bba830e23b6b6f50982e", &
"1f8e55da218c5df3309052", &
"ca7b3217cd92bd59a5ae20", &
"56f78313537d0f4382964e", &
"29c29dba9c545e267762fe", &
"6be396b5e2e819e373340c", &
"293548a138858328af4210", &
"cb6c6afcdc28bb3f7c6e86", &
"3f2a86f5c5bd225c961150", &
"849dd2d63673481860f62c", &
"56cdaec6e7ae14b43feeee", &
"04ef5cfa3766ba778f45a4", &
"c525ae4bd4f627320a3974", &
"fe37802941d66dde02b99c", &
"41fd9520b2e4abeb2f989c", &
"40907b01280f03c0323946", &
"7fb36c24085a34d8c1dbc4", &
"40fc3e44bb7d2bb2756e44", &
"d38ab0a1d2e52a8ec3bc76", &
"3d0f929ef3949bd84d4734", &
"45d3814f504064f80549ae", &
"f14dbf263825d0bd04b05e", &
"f08a91fb2e1f78290619a8", &
"7a8dec79a51e8ac5388022", &
"ca4186dd44c3121565cf5c", &
"db714f8f64e8ac7af1a76e", &
"8d0274de71e7c1a8055eb0", &
"51f81573dd4049b082de14", &
"d037db825175d851f3af00", &
"d8f937f31822e57c562370", &
"1bf1490607c54032660ede", &
"1616d78018d0b4745ca0f2", &
"a9fa8e50bcb032c85e3304", &
"83f640f1a48a8ebc0443ea", &
"eca9afa0f6b01d92305edc", &
"3776af54ccfbae916afde6", &
"6abb212d9739dfc02580f2", &
"05209a0abb530b9e7e34b0", &
"612f63acc025b6ab476f7c", &
"0af7723161ec223080be86", &
"a8fc906976c35669e79ce0", &
"45b7ab6242b77474d9f11a", &
"b274db8abd3c6f396ea356", &
"9059dfa2bb20ef7ef73ad4", &
"3d188ea477f6fa41317a4e", &
"8d9071b7e7a6a2eed6965e", &
"a377253773ea678367c3f6", &
"ecbd7c73b9cd34c3720c8a", &
"b6537f417e61d1a7085336", &
"6c280d2a0523d9c4bc5946", &
"d36d662a69ae24b74dcbd8", &
"d747bfc5fd65ef70fbd9bc", &
"a9fa2eefa6f8796a355772", &
"cc9da55fe046d0cb3a770c", &
"f6ad4824b87c80ebfce466", &
"cc6de59755420925f90ed2", &
"164cc861bdd803c547f2ac", &
"c0fc3ec4fb7d2bb2756644", &
"0dbd816fba1543f721dc72", &
"a0c0033a52ab6299802fd2", &
"bf4f56e073271f6ab4bf80", &
"57da6d13cb96a7689b2790", &
"81cfc6f18c35b1e1f17114", &
"481a2a0df8a23583f82d6c", &
"1ac4672b549cd6dba79bcc", &
"c87af9a5d5206abca532a8", &
"97d4169cb33e7435718d90", &
"a6573f3dc8b16c9d19f746", &
"2c4142bf42b01e71076acc", &
"081c29a10d468ccdbcecb6", &
"5b0f7742bca86b8012609a", &
"012dee2198eba82b19a1da", &
"f1627701a2d692fd9449e6", &
"35ad3fb0faeb5f1b0c30dc", &
"b1ca4ea2e3d173bad4379c", &
"37d8e0af9258b9e8c5f9b2", &
"cd921fdf59e882683763f6", &
"6114e08483043fd3f38a8a", &
"2e547dd7a05f6597aac516", &
"95e45ecd0135aca9d6e6ae", &
"b33ec97be83ce413f9acc8", &
"c8b5dffc335095dcdcaf2a", &
"3dd01a59d86310743ec752", &
"14cd0f642fc0c5fe3a65ca", &
"3a0a1dfd7eee29c2e827e0", &
"8abdb889efbe39a510a118", &
"3f231f212055371cf3e2a2"/
data colorder/ &
0, 1, 2, 3, 30, 4, 5, 6, 7, 8, 9, 10, 11, 32, 12, 40, 13, 14, 15, 16,&
17, 18, 37, 45, 29, 19, 20, 21, 41, 22, 42, 31, 33, 34, 44, 35, 47, 51, 50, 43,&
36, 52, 63, 46, 25, 55, 27, 24, 23, 53, 39, 49, 59, 38, 48, 61, 60, 57, 28, 62,&
56, 58, 65, 66, 26, 70, 64, 69, 68, 67, 74, 71, 54, 76, 72, 75, 78, 77, 80, 79,&
73, 83, 84, 81, 82, 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/

86
ldpc_174_91_c_generator.f90 Normal file
View File

@ -0,0 +1,86 @@
character*23 g(83)
data g/ &
"8329ce11bf31eaf509f27fc", &
"761c264e25c259335493132", &
"dc265902fb277c6410a1bdc", &
"1b3f417858cd2dd33ec7f62", &
"09fda4fee04195fd034783a", &
"077cccc11b8873ed5c3d48a", &
"29b62afe3ca036f4fe1a9da", &
"6054faf5f35d96d3b0c8c3e", &
"e20798e4310eed27884ae90", &
"775c9c08e80e26ddae56318", &
"b0b811028c2bf997213487c", &
"18a0c9231fc60adf5c5ea32", &
"76471e8302a0721e01b12b8", &
"ffbccb80ca8341fafb47b2e", &
"66a72a158f9325a2bf67170", &
"c4243689fe85b1c51363a18", &
"0dff739414d1a1b34b1c270", &
"15b48830636c8b99894972e", &
"29a89c0d3de81d665489b0e", &
"4f126f37fa51cbe61bd6b94", &
"99c47239d0d97d3c84e0940", &
"1919b75119765621bb4f1e8", &
"09db12d731faee0b86df6b8", &
"488fc33df43fbdeea4eafb4", &
"827423ee40b675f756eb5fe", &
"abe197c484cb74757144a9a", &
"2b500e4bc0ec5a6d2bdbdd0", &
"c474aa53d70218761669360", &
"8eba1a13db3390bd6718cec", &
"753844673a27782cc42012e", &
"06ff83a145c37035a5c1268", &
"3b37417858cc2dd33ec3f62", &
"9a4a5a28ee17ca9c324842c", &
"bc29f465309c977e89610a4", &
"2663ae6ddf8b5ce2bb29488", &
"46f231efe457034c1814418", &
"3fb2ce85abe9b0c72e06fbe", &
"de87481f282c153971a0a2e", &
"fcd7ccf23c69fa99bba1412", &
"f0261447e9490ca8e474cec", &
"4410115818196f95cdd7012", &
"088fc31df4bfbde2a4eafb4", &
"b8fef1b6307729fb0a078c0", &
"5afea7acccb77bbc9d99a90", &
"49a7016ac653f65ecdc9076", &
"1944d085be4e7da8d6cc7d0", &
"251f62adc4032f0ee714002", &
"56471f8702a0721e00b12b8", &
"2b8e4923f2dd51e2d537fa0", &
"6b550a40a66f4755de95c26", &
"a18ad28d4e27fe92a4f6c84", &
"10c2e586388cb82a3d80758", &
"ef34a41817ee02133db2eb0", &
"7e9c0c54325a9c15836e000", &
"3693e572d1fde4cdf079e86", &
"bfb2cec5abe1b0c72e07fbe", &
"7ee18230c583cccc57d4b08", &
"a066cb2fedafc9f52664126", &
"bb23725abc47cc5f4cc4cd2", &
"ded9dba3bee40c59b5609b4", &
"d9a7016ac653e6decdc9036", &
"9ad46aed5f707f280ab5fc4", &
"e5921c77822587316d7d3c2", &
"4f14da8242a8b86dca73352", &
"8b8b507ad467d4441df770e", &
"22831c9cf1169467ad04b68", &
"213b838fe2ae54c38ee7180", &
"5d926b6dd71f085181a4e12", &
"66ab79d4b29ee6e69509e56", &
"958148682d748a38dd68baa", &
"b8ce020cf069c32a723ab14", &
"f4331d6d461607e95752746", &
"6da23ba424b9596133cf9c8", &
"a636bcbc7b30c5fbeae67fe", &
"5cb0d86a07df654a9089a20", &
"f11f106848780fc9ecdd80a", &
"1fbb5364fb8d2c9d730d5ba", &
"fcb86bc70a50c9d02a5d034", &
"a534433029eac15f322e34c", &
"c989d9c7c3d3b8c55d75130", &
"7bb38b2f0186d46643ae962", &
"2644ebadeb44b9467d1f42c", &
"608cc857594bfbb55d69600"/

270
ldpc_174_91_c_reordered_parity.f90 Normal file
View File

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

81
osd174.f90 → osd174_91.f90
View File

@ -1,9 +1,8 @@
subroutine osd174(llr,apmask,ndeep,decoded,cw,nhardmin,dmin) subroutine osd174_91(llr,apmask,ndeep,message77,cw,nhardmin,dmin)
! !
! An ordered-statistics decoder for the (174,87) code. ! An ordered-statistics decoder for the (174,91) code.
! !
include "ldpc_174_87_params.f90" integer, parameter:: N=174, K=91, M=N-K
integer*1 apmask(N),apmaskr(N) integer*1 apmask(N),apmaskr(N)
integer*1 gen(K,N) integer*1 gen(K,N)
integer*1 genmrb(K,N),g2(N,K) integer*1 genmrb(K,N),g2(N,K)
@ -12,8 +11,12 @@ integer*1 r2pat(N-K)
integer indices(N),nxor(N) integer indices(N),nxor(N)
integer*1 cw(N),ce(N),c0(N),hdec(N) integer*1 cw(N),ce(N),c0(N),hdec(N)
integer*1 decoded(K) integer*1 decoded(K)
integer*1 message77(77)
integer indx(N) integer indx(N)
real llr(N),rx(N),absrx(N) real llr(N),rx(N),absrx(N)
include "ldpc_174_91_c_generator.f90"
logical first,reset logical first,reset
data first/.true./ data first/.true./
save first,gen save first,gen
@ -21,23 +24,24 @@ save first,gen
if( first ) then ! fill the generator matrix if( first ) then ! fill the generator matrix
gen=0 gen=0
do i=1,M do i=1,M
do j=1,22 do j=1,23
read(g(i)(j:j),"(Z1)") istr read(g(i)(j:j),"(Z1)") istr
do jj=1, 4 ibmax=4
irow=(j-1)*4+jj if(j.eq.23) ibmax=3
if( btest(istr,4-jj) ) gen(irow,i)=1 do jj=1, ibmax
enddo irow=(j-1)*4+jj
if( btest(istr,4-jj) ) gen(irow,K+i)=1
enddo
enddo enddo
enddo enddo
do irow=1,K do irow=1,K
gen(irow,M+irow)=1 gen(irow,irow)=1
enddo enddo
first=.false. first=.false.
endif endif
! Re-order received vector to place systematic msg bits at the end. rx=llr
rx=llr(colorder+1) apmaskr=apmask
apmaskr=apmask(colorder+1)
! Hard decisions on the received word. ! Hard decisions on the received word.
hdec=0 hdec=0
@ -92,7 +96,7 @@ absrx=absrx(indices)
rx=rx(indices) rx=rx(indices)
apmaskr=apmaskr(indices) apmaskr=apmaskr(indices)
call mrbencode(m0,c0,g2,N,K) call mrbencode91(m0,c0,g2,N,K)
nxor=ieor(c0,hdec) nxor=ieor(c0,hdec)
nhardmin=sum(nxor) nhardmin=sum(nxor)
dmin=sum(nxor*absrx) dmin=sum(nxor*absrx)
@ -155,7 +159,7 @@ do iorder=1,nord
ntotal=ntotal+1 ntotal=ntotal+1
me=ieor(m0,mi) me=ieor(m0,mi)
if(n1.eq.iflag) then if(n1.eq.iflag) then
call mrbencode(me,ce,g2,N,K) call mrbencode91(me,ce,g2,N,K)
e2sub=ieor(ce(K+1:N),hdec(K+1:N)) e2sub=ieor(ce(K+1:N),hdec(K+1:N))
e2=e2sub e2=e2sub
nd1Kpt=sum(e2sub(1:nt))+1 nd1Kpt=sum(e2sub(1:nt))+1
@ -165,7 +169,7 @@ do iorder=1,nord
nd1Kpt=sum(e2(1:nt))+2 nd1Kpt=sum(e2(1:nt))+2
endif endif
if(nd1Kpt .le. ntheta) then if(nd1Kpt .le. ntheta) then
call mrbencode(me,ce,g2,N,K) call mrbencode91(me,ce,g2,N,K)
nxor=ieor(ce,hdec) nxor=ieor(ce,hdec)
if(n1.eq.iflag) then if(n1.eq.iflag) then
dd=d1+sum(e2sub*absrx(K+1:N)) dd=d1+sum(e2sub*absrx(K+1:N))
@ -184,7 +188,7 @@ do iorder=1,nord
enddo enddo
! Get the next test error pattern, iflag will go negative ! Get the next test error pattern, iflag will go negative
! when the last pattern with weight iorder has been generated. ! when the last pattern with weight iorder has been generated.
call nextpat(misub,k,iorder,iflag) call nextpat91(misub,k,iorder,iflag)
enddo enddo
enddo enddo
@ -195,7 +199,7 @@ if(npre2.eq.1) then
do i2=i1-1,1,-1 do i2=i1-1,1,-1
ntotal=ntotal+1 ntotal=ntotal+1
mi(1:ntau)=ieor(g2(K+1:K+ntau,i1),g2(K+1:K+ntau,i2)) mi(1:ntau)=ieor(g2(K+1:K+ntau,i1),g2(K+1:K+ntau,i2))
call boxit(reset,mi(1:ntau),ntau,ntotal,i1,i2) call boxit91(reset,mi(1:ntau),ntau,ntotal,i1,i2)
enddo enddo
enddo enddo
@ -208,7 +212,7 @@ if(npre2.eq.1) then
iflag=K-nord+1 iflag=K-nord+1
do while(iflag .ge.0) do while(iflag .ge.0)
me=ieor(m0,misub) me=ieor(m0,misub)
call mrbencode(me,ce,g2,N,K) call mrbencode91(me,ce,g2,N,K)
e2sub=ieor(ce(K+1:N),hdec(K+1:N)) e2sub=ieor(ce(K+1:N),hdec(K+1:N))
do i2=0,ntau do i2=0,ntau
ntotal2=ntotal2+1 ntotal2=ntotal2+1
@ -216,7 +220,7 @@ if(npre2.eq.1) then
if(i2.gt.0) ui(i2)=1 if(i2.gt.0) ui(i2)=1
r2pat=ieor(e2sub,ui) r2pat=ieor(e2sub,ui)
778 continue 778 continue
call fetchit(reset,r2pat(1:ntau),ntau,in1,in2) call fetchit91(reset,r2pat(1:ntau),ntau,in1,in2)
if(in1.gt.0.and.in2.gt.0) then if(in1.gt.0.and.in2.gt.0) then
ncount2=ncount2+1 ncount2=ncount2+1
mi=misub mi=misub
@ -224,7 +228,7 @@ if(npre2.eq.1) then
mi(in2)=1 mi(in2)=1
if(sum(mi).lt.nord+npre1+npre2.or.any(iand(apmaskr(1:K),mi).eq.1)) cycle if(sum(mi).lt.nord+npre1+npre2.or.any(iand(apmaskr(1:K),mi).eq.1)) cycle
me=ieor(m0,mi) me=ieor(m0,mi)
call mrbencode(me,ce,g2,N,K) call mrbencode91(me,ce,g2,N,K)
nxor=ieor(ce,hdec) nxor=ieor(ce,hdec)
dd=sum(nxor*absrx) dd=sum(nxor*absrx)
if( dd .lt. dmin ) then if( dd .lt. dmin ) then
@ -235,20 +239,23 @@ if(npre2.eq.1) then
goto 778 goto 778
endif endif
enddo enddo
call nextpat(misub,K,nord,iflag) call nextpat91(misub,K,nord,iflag)
enddo enddo
endif endif
998 continue 998 continue
! Re-order the codeword to place message bits at the end. ! Re-order the codeword to [message bits][parity bits] format.
cw(indices)=cw cw(indices)=cw
hdec(indices)=hdec hdec(indices)=hdec
decoded=cw(M+1:N) decoded=cw(1:K)
cw(colorder+1)=cw ! put the codeword back into received-word order call chkcrc14a(decoded,nbadcrc)
return message77=decoded(1:77)
end subroutine osd174 if(nbadcrc.eq.1) nhardmin=-nhardmin
subroutine mrbencode(me,codeword,g2,N,K) return
end subroutine osd174_91
subroutine mrbencode91(me,codeword,g2,N,K)
integer*1 me(K),codeword(N),g2(N,K) integer*1 me(K),codeword(N),g2(N,K)
! fast encoding for low-weight test patterns ! fast encoding for low-weight test patterns
codeword=0 codeword=0
@ -258,9 +265,9 @@ integer*1 me(K),codeword(N),g2(N,K)
endif endif
enddo enddo
return return
end subroutine mrbencode end subroutine mrbencode91
subroutine nextpat(mi,k,iorder,iflag) subroutine nextpat91(mi,k,iorder,iflag)
integer*1 mi(k),ms(k) integer*1 mi(k),ms(k)
! generate the next test error pattern ! generate the next test error pattern
ind=-1 ind=-1
@ -287,11 +294,11 @@ subroutine nextpat(mi,k,iorder,iflag)
endif endif
enddo enddo
return return
end subroutine nextpat end subroutine nextpat91
subroutine boxit(reset,e2,ntau,npindex,i1,i2) subroutine boxit91(reset,e2,ntau,npindex,i1,i2)
integer*1 e2(1:ntau) integer*1 e2(1:ntau)
integer indexes(4000,2),fp(0:525000),np(4000) integer indexes(5000,2),fp(0:525000),np(5000)
logical reset logical reset
common/boxes/indexes,fp,np common/boxes/indexes,fp,np
@ -323,10 +330,10 @@ subroutine boxit(reset,e2,ntau,npindex,i1,i2)
np(ip)=npindex np(ip)=npindex
endif endif
return return
end subroutine boxit end subroutine boxit91
subroutine fetchit(reset,e2,ntau,i1,i2) subroutine fetchit91(reset,e2,ntau,i1,i2)
integer indexes(4000,2),fp(0:525000),np(4000) integer indexes(5000,2),fp(0:525000),np(5000)
integer lastpat integer lastpat
integer*1 e2(ntau) integer*1 e2(ntau)
logical reset logical reset
@ -361,5 +368,5 @@ subroutine fetchit(reset,e2,ntau,i1,i2)
endif endif
lastpat=ipat lastpat=ipat
return return
end subroutine fetchit end subroutine fetchit91

204
packjt.f90
View File

@ -6,7 +6,52 @@ module packjt
contains contains
subroutine packcall(callsign,ncall,text) subroutine packbits(dbits,nsymd,m0,sym)
! Pack 0s and 1s from dbits() into sym() with m0 bits per word.
! NB: nsymd is the number of packed output words.
integer sym(:)
integer*1 dbits(:)
k=0
do i=1,nsymd
n=0
do j=1,m0
k=k+1
m=dbits(k)
n=ior(ishft(n,1),m)
enddo
sym(i)=n
enddo
return
end subroutine packbits
subroutine unpackbits(sym,nsymd,m0,dbits)
! Unpack bits from sym() into dbits(), one bit per byte.
! NB: nsymd is the number of input words, and m0 their length.
! there will be m0*nsymd output bytes, each 0 or 1.
integer sym(:)
integer*1 dbits(:)
k=0
do i=1,nsymd
mask=ishft(1,m0-1)
do j=1,m0
k=k+1
dbits(k)=0
if(iand(mask,sym(i)).ne.0) dbits(k)=1
mask=ishft(mask,-1)
enddo
enddo
return
end subroutine unpackbits
subroutine packcall(callsign,ncall,text)
! Pack a valid callsign into a 28-bit integer. ! Pack a valid callsign into a 28-bit integer.
@ -489,12 +534,12 @@ subroutine packcall(callsign,ncall,text)
return return
end subroutine packmsg end subroutine packmsg
subroutine unpackmsg(dat,msg,msgcall,msggrid) subroutine unpackmsg(dat,msg)
parameter (NBASE=37*36*10*27*27*27) parameter (NBASE=37*36*10*27*27*27)
parameter (NGBASE=180*180) parameter (NGBASE=180*180)
integer dat(:) integer dat(:)
character c1*12,c2*12,grid*4,msg*22,msgcall*6,msggrid*4,grid6*6,psfx*4,junk2*4 character c1*12,c2*12,grid*4,msg*22,grid6*6,psfx*4,junk2*4
logical cqnnn logical cqnnn
cqnnn=.false. cqnnn=.false.
@ -526,16 +571,39 @@ subroutine packcall(callsign,ncall,text)
endif endif
call unpackcall(nc2,c2,junk1,junk2) call unpackcall(nc2,c2,junk1,junk2)
msgcall=c2(:6)
msggrid=' '
if(ng.lt.32400 .and. ng.ne.533) then
dlat=mod(ng,180)-90
dlong=(ng/180)*2 - 180 + 2
call deg2grid(dlong,dlat,grid6)
if(grid6(1:2).ne.'KA' .and. grid6(1:2).ne.'LA') msggrid=grid6(:4)
endif
call unpackgrid(ng,grid) call unpackgrid(ng,grid)
if(iv2.gt.0) then
! This is a JT65v2 message
do i=1,4
if(ichar(psfx(i:i)).eq.0) psfx(i:i)=' '
enddo
n1=len_trim(psfx)
n2=len_trim(c2)
if(iv2.eq.1) msg='CQ '//psfx(:n1)//'/'//c2(:n2)//' '//grid
if(iv2.eq.2) msg='QRZ '//psfx(:n1)//'/'//c2(:n2)//' '//grid
if(iv2.eq.3) msg='DE '//psfx(:n1)//'/'//c2(:n2)//' '//grid
if(iv2.eq.4) msg='CQ '//c2(:n2)//'/'//psfx(:n1)//' '//grid
if(iv2.eq.5) msg='QRZ '//c2(:n2)//'/'//psfx(:n1)//' '//grid
if(iv2.eq.6) msg='DE '//c2(:n2)//'/'//psfx(:n1)//' '//grid
if(iv2.eq.7) then
grid6=grid//'ma'
call grid2k(grid6,k)
if(k.ge.451 .and. k.le.900) then
call getpfx2(k,c2)
n2=len_trim(c2)
msg='DE '//c2(:n2)
else
msg='DE '//c2(:n2)//' '//grid
endif
endif
if(iv2.eq.8) msg=' '
go to 100
else
endif
grid6=grid//'ma' grid6=grid//'ma'
call grid2k(grid6,k) call grid2k(grid6,k)
if(k.ge.1 .and. k.le.450) call getpfx2(k,c1) if(k.ge.1 .and. k.le.450) call getpfx2(k,c1)
@ -648,7 +716,7 @@ subroutine packcall(callsign,ncall,text)
nc1=nc1a nc1=nc1a
nc2=nc2a nc2=nc2a
nc3=iand(nc3a,32767) !Remove the "plain text" bit nc3=iand(nc3a,32767) !Remove the "plain text" bit
if(iand(nc1,1).ne.0) nc3=nc3+32768 if(iand(nc1,1).ne.0) nc3=nc3+32768
nc1=nc1/2 nc1=nc1/2
if(iand(nc2,1).ne.0) nc3=nc3+65536 if(iand(nc2,1).ne.0) nc3=nc3+65536
@ -826,6 +894,32 @@ subroutine packcall(callsign,ncall,text)
return return
end subroutine k2grid end subroutine k2grid
subroutine grid2n(grid,n)
character*4 grid
i1=ichar(grid(1:1))-ichar('A')
i2=ichar(grid(3:3))-ichar('0')
i=10*i1 + i2
n=-i - 31
return
end subroutine grid2n
subroutine n2grid(n,grid)
character*4 grid
if(n.gt.-31 .or. n.lt.-70) stop 'Error in n2grid'
i=-(n+31) !NB: 0 <= i <= 39
i1=i/10
i2=mod(i,10)
grid(1:1)=char(ichar('A')+i1)
grid(2:2)='A'
grid(3:3)=char(ichar('0')+i2)
grid(4:4)='0'
return
end subroutine n2grid
function nchar(c) function nchar(c)
! Convert ascii number, letter, or space to 0-36 for callsign packing. ! Convert ascii number, letter, or space to 0-36 for callsign packing.
@ -850,4 +944,90 @@ subroutine packcall(callsign,ncall,text)
return return
end function nchar end function nchar
subroutine pack50(n1,n2,dat)
integer*1 dat(:),i1
i1=iand(ishft(n1,-20),255) !8 bits
dat(1)=i1
i1=iand(ishft(n1,-12),255) !8 bits
dat(2)=i1
i1=iand(ishft(n1, -4),255) !8 bits
dat(3)=i1
i1=16*iand(n1,15)+iand(ishft(n2,-18),15) !4+4 bits
dat(4)=i1
i1=iand(ishft(n2,-10),255) !8 bits
dat(5)=i1
i1=iand(ishft(n2, -2),255) !8 bits
dat(6)=i1
i1=64*iand(n2,3) !2 bits
dat(7)=i1
dat(8)=0
dat(9)=0
dat(10)=0
dat(11)=0
return
end subroutine pack50
subroutine packpfx(call1,n1,ng,nadd)
character*12 call1,call0
character*3 pfx
logical text
i1=index(call1,'/')
if(call1(i1+2:i1+2).eq.' ') then
! Single-character add-on suffix (maybe also fourth suffix letter?)
call0=call1(:i1-1)
call packcall(call0,n1,text)
nadd=1
nc=ichar(call1(i1+1:i1+1))
if(nc.ge.48 .and. nc.le.57) then
n=nc-48
else if(nc.ge.65 .and. nc.le.90) then
n=nc-65+10
else
n=38
endif
nadd=1
ng=60000-32768+n
else if(call1(i1+3:i1+3).eq.' ') then
! Two-character numerical suffix, /10 to /99
call0=call1(:i1-1)
call packcall(call0,n1,text)
nadd=1
n=10*(ichar(call1(i1+1:i1+1))-48) + ichar(call1(i1+2:i1+2)) - 48
nadd=1
ng=60000 + 26 + n
else
! Prefix of 1 to 3 characters
pfx=call1(:i1-1)
if(pfx(3:3).eq.' ') pfx=' '//pfx(1:2)
if(pfx(3:3).eq.' ') pfx=' '//pfx(1:2)
call0=call1(i1+1:)
call packcall(call0,n1,text)
ng=0
do i=1,3
nc=ichar(pfx(i:i))
if(nc.ge.48 .and. nc.le.57) then
n=nc-48
else if(nc.ge.65 .and. nc.le.90) then
n=nc-65+10
else
n=36
endif
ng=37*ng + n
enddo
nadd=0
if(ng.ge.32768) then
ng=ng-32768
nadd=1
endif
endif
return
end subroutine packpfx
end module packjt end module packjt

1227
packjt77.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

65
subtractft8.f90 Normal file
View File

@ -0,0 +1,65 @@
subroutine subtractft8(dd,itone,f0,dt)
! Subtract an ft8 signal
!
! Measured signal : dd(t) = a(t)cos(2*pi*f0*t+theta(t))
! Reference signal : cref(t) = exp( j*(2*pi*f0*t+phi(t)) )
! Complex amp : cfilt(t) = LPF[ dd(t)*CONJG(cref(t)) ]
! Subtract : dd(t) = dd(t) - 2*REAL{cref*cfilt}
parameter (NMAX=15*4000,NFRAME=640*79)
parameter (NFFT=NMAX,NFILT=1400)
real*4 window(-NFILT/2:NFILT/2)
complex dd(NMAX)
complex cref,camp,cfilt,cw
integer itone(79)
logical first
data first/.true./
common/heap8/cref(NFRAME),camp(NMAX),cfilt(NMAX),cw(NMAX)
save first
if(f0.lt.2000.0) then
f=f0+2000.0
else
f=f0-2000.0
endif
nstart=dt*4000+1
call genft8refsig(itone,cref,f)
camp=0.
do i=1,nframe
id=nstart-1+i
if(id.ge.1.and.id.le.NMAX) camp(i)=dd(id)*conjg(cref(i))
enddo
if(first) then
! Create and normalize the filter
pi=4.0*atan(1.0)
fac=1.0/float(nfft)
sum=0.0
do j=-NFILT/2,NFILT/2
window(j)=cos(pi*j/NFILT)**2
sum=sum+window(j)
enddo
cw=0.
cw(1:NFILT+1)=window/sum
cw=cshift(cw,NFILT/2+1)
call four2a(cw,nfft,1,-1,1)
cw=cw*fac
first=.false.
endif
cfilt=0.0
cfilt(1:nframe)=camp(1:nframe)
call four2a(cfilt,nfft,1,-1,1)
cfilt(1:nfft)=cfilt(1:nfft)*cw(1:nfft)
call four2a(cfilt,nfft,1,1,1)
! Subtract the reconstructed signal
do i=1,nframe
j=nstart+i-1
if(j.ge.1 .and. j.le.NMAX) dd(j)=dd(j)-cfilt(i)*cref(i)
enddo
return
end subroutine subtractft8

40
sync8.f90
View File

@ -17,7 +17,7 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase)
integer indx(NFFT1) integer indx(NFFT1)
integer ii(1) integer ii(1)
integer icos7(0:6) integer icos7(0:6)
data icos7/2,5,6,0,4,1,3/ !Costas 7x7 tone pattern data icos7/3,1,4,0,6,5,2/ !Costas 7x7 tone pattern
equivalence (x,cx) equivalence (x,cx)
! Compute symbol spectra, stepping by NSTEP steps. ! Compute symbol spectra, stepping by NSTEP steps.
@ -38,17 +38,14 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase)
savg=savg + s(1:NFFT1,j) !Average spectrum savg=savg + s(1:NFFT1,j) !Average spectrum
enddo enddo
call baseline(savg,nfa,nfb,sbase) call baseline(savg,nfa,nfb,sbase)
! savg=savg/NHSYM
! do i=1,NFFT1
! write(51,3051) i*df,savg(i),db(savg(i))
!3051 format(f10.3,e12.3,f12.3)
! enddo
ia=max(1,nint(nfa/df)) ia=max(1,nint(nfa/df))
ib=nint(nfb/df) ib=nint(nfb/df)
nssy=NSPS/NSTEP ! # steps per symbol nssy=NSPS/NSTEP ! # steps per symbol
nfos=NFFT1/NSPS ! # frequency bin oversampling factor nfos=NFFT1/NSPS ! # frequency bin oversampling factor
jstrt=0.5/tstep jstrt=0.5/tstep
candidate0=0.
k=0
do i=ia,ib do i=ia,ib
do j=-JZ,+JZ do j=-JZ,+JZ
@ -59,23 +56,22 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase)
t0b=0. t0b=0.
t0c=0. t0c=0.
do n=0,6 do n=0,6
k=j+jstrt+nssy*n m=j+jstrt+nssy*n
if(k.ge.1.and.k.le.NHSYM) then if(m.ge.1.and.m.le.NHSYM) then
ta=ta + s(i+nfos*icos7(n),k) ta=ta + s(i+nfos*icos7(n),m)
t0a=t0a + sum(s(i:i+nfos*6:nfos,k)) t0a=t0a + sum(s(i:i+nfos*6:nfos,m))
endif endif
tb=tb + s(i+nfos*icos7(n),k+nssy*36) tb=tb + s(i+nfos*icos7(n),m+nssy*36)
t0b=t0b + sum(s(i:i+nfos*6:nfos,k+nssy*36)) t0b=t0b + sum(s(i:i+nfos*6:nfos,m+nssy*36))
if(k+nssy*72.le.NHSYM) then if(m+nssy*72.le.NHSYM) then
tc=tc + s(i+nfos*icos7(n),k+nssy*72) tc=tc + s(i+nfos*icos7(n),m+nssy*72)
t0c=t0c + sum(s(i:i+nfos*6:nfos,k+nssy*72)) t0c=t0c + sum(s(i:i+nfos*6:nfos,m+nssy*72))
endif endif
enddo enddo
t=ta+tb+tc t=ta+tb+tc
t0=t0a+t0b+t0c t0=t0a+t0b+t0c
t0=(t0-t)/6.0 t0=(t0-t)/6.0
sync_abc=t/t0 sync_abc=t/t0
t=tb+tc t=tb+tc
t0=t0b+t0c t0=t0b+t0c
t0=(t0-t)/6.0 t0=(t0-t)/6.0
@ -90,8 +86,6 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase)
j0=ii(1) j0=ii(1)
jpeak(i)=j0 jpeak(i)=j0
red(i)=sync2d(i,j0) red(i)=sync2d(i,j0)
! write(52,3052) i*df,red(i),db(red(i))
!3052 format(3f12.3)
enddo enddo
iz=ib-ia+1 iz=ib-ia+1
call indexx(red(ia:ib),iz,indx) call indexx(red(ia:ib),iz,indx)
@ -101,9 +95,7 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase)
base=red(ibase) base=red(ibase)
red=red/base red=red/base
candidate0=0. do i=1,min(MAXCAND,iz)
k=0
do i=1,MAXCAND
n=ia + indx(iz+1-i) - 1 n=ia + indx(iz+1-i) - 1
if(red(n).lt.syncmin.or.isnan(red(n)).or.k.eq.MAXCAND) exit if(red(n).lt.syncmin.or.isnan(red(n)).or.k.eq.MAXCAND) exit
k=k+1 k=k+1
@ -124,9 +116,6 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase)
if(candidate0(3,i).lt.candidate0(3,j)) candidate0(3,i)=0. if(candidate0(3,i).lt.candidate0(3,j)) candidate0(3,i)=0.
endif endif
enddo enddo
! write(*,3001) i,candidate0(1,i-1),candidate0(1,i),candidate0(3,i-1), &
! candidate0(3,i)
!3001 format(i2,4f8.1)
endif endif
enddo enddo
@ -143,9 +132,8 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase)
j=indx(i) j=indx(i)
! if( candidate0(3,j) .ge. syncmin .and. candidate0(2,j).ge.-1.5 ) then ! if( candidate0(3,j) .ge. syncmin .and. candidate0(2,j).ge.-1.5 ) then
if( candidate0(3,j) .ge. syncmin ) then if( candidate0(3,j) .ge. syncmin ) then
candidate(2:3,k)=candidate0(2:3,j)
candidate(1,k)=abs(candidate0(1,j)) candidate(1,k)=abs(candidate0(1,j))
candidate(2,k)=candidate0(2,j)
candidate(3,k)=candidate0(3,j)
k=k+1 k=k+1
endif endif
enddo enddo

10
sync8d.f90
View File

@ -3,14 +3,14 @@ subroutine sync8d(cd0,i0,ctwk,itwk,sync)
! Compute sync power for a complex, downsampled FT8 signal. ! Compute sync power for a complex, downsampled FT8 signal.
parameter(NP2=2812,NDOWN=20) parameter(NP2=2812,NDOWN=20)
complex cd0(3125) complex cd0(0:3199)
complex csync(0:6,32) complex csync(0:6,32)
complex csync2(32) complex csync2(32)
complex ctwk(32) complex ctwk(32)
complex z1,z2,z3 complex z1,z2,z3
logical first logical first
integer icos7(0:6) integer icos7(0:6)
data icos7/2,5,6,0,4,1,3/ data icos7/3,1,4,0,6,5,2/
data first/.true./ data first/.true./
save first,twopi,fs2,dt2,taus,baud,csync save first,twopi,fs2,dt2,taus,baud,csync
@ -44,9 +44,9 @@ subroutine sync8d(cd0,i0,ctwk,itwk,sync)
z1=0. z1=0.
z2=0. z2=0.
z3=0. z3=0.
if(i1.ge.1 .and. i1+31.le.NP2) z1=sum(cd0(i1:i1+31)*conjg(csync2)) if(i1.ge.0 .and. i1+31.le.NP2-1) z1=sum(cd0(i1:i1+31)*conjg(csync2))
if(i2.ge.1 .and. i2+31.le.NP2) z2=sum(cd0(i2:i2+31)*conjg(csync2)) if(i2.ge.0 .and. i2+31.le.NP2-1) z2=sum(cd0(i2:i2+31)*conjg(csync2))
if(i3.ge.1 .and. i3+31.le.NP2) z3=sum(cd0(i3:i3+31)*conjg(csync2)) if(i3.ge.0 .and. i3+31.le.NP2-1) z3=sum(cd0(i3:i3+31)*conjg(csync2))
sync = sync + p(z1) + p(z2) + p(z3) sync = sync + p(z1) + p(z2) + p(z3)
enddo enddo