From f8f733d450e3abae6543ad8fb6aa5425995fbb12 Mon Sep 17 00:00:00 2001 From: Pavel Demin Date: Sat, 15 Dec 2018 13:25:41 +0100 Subject: [PATCH] switch to 77-bit message protocol --- Makefile | 9 +- bpdecode174.f90 | 426 ---------- bpdecode174_91.f90 | 140 ++++ chkcall.f90 | 58 ++ chkcrc12a.f90 | 24 - chkcrc14a.f90 | 24 + crc.f90 | 34 +- crc12.c | 59 -- crc14.c | 59 ++ db.f90 | 5 - encode174.f90 | 50 -- encode174_91.f90 | 58 ++ extractmessage174.f90 | 42 - extractmessage174_91.f90 | 40 + fmtmsg.f90 | 8 +- ft8_params.f90 | 6 +- ft8b.f90 | 556 +++++++------ ft8d.f90 | 85 +- genft8.f90 | 51 +- genft8refsig.f90 | 23 + ldpc_174_87_params.f90 | 102 --- ldpc_174_91_c_generator.f90 | 86 ++ ldpc_174_91_c_reordered_parity.f90 | 270 ++++++ osd174.f90 => osd174_91.f90 | 81 +- packjt.f90 | 204 ++++- packjt77.f90 | 1227 ++++++++++++++++++++++++++++ subtractft8.f90 | 65 ++ sync8.f90 | 40 +- sync8d.f90 | 10 +- 29 files changed, 2692 insertions(+), 1150 deletions(-) delete mode 100644 bpdecode174.f90 create mode 100644 bpdecode174_91.f90 create mode 100644 chkcall.f90 delete mode 100644 chkcrc12a.f90 create mode 100644 chkcrc14a.f90 delete mode 100644 crc12.c create mode 100644 crc14.c delete mode 100644 db.f90 delete mode 100644 encode174.f90 create mode 100644 encode174_91.f90 delete mode 100644 extractmessage174.f90 create mode 100644 extractmessage174_91.f90 create mode 100644 genft8refsig.f90 delete mode 100644 ldpc_174_87_params.f90 create mode 100644 ldpc_174_91_c_generator.f90 create mode 100644 ldpc_174_91_c_reordered_parity.f90 rename osd174.f90 => osd174_91.f90 (83%) create mode 100644 packjt77.f90 create mode 100644 subtractft8.f90 diff --git a/Makefile b/Makefile index d2eb261..434111c 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,11 @@ TARGET = ft8d OBJECTS = \ - crc12.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 \ - fmtmsg.o packjt.o extractmessage174.o indexx.o shell.o pctile.o polyfit.o \ - twkfreq1.o osd174.o encode174.o genft8.o db.o ft8b.o ft8d.o + crc14.o crc.o ft8_downsample.o sync8d.o sync8.o grid2deg.o four2a.o \ + deg2grid.o determ.o fftw3mod.o baseline.o bpdecode174_91.o fmtmsg.o \ + packjt.o chkcrc14a.o extractmessage174_91.o indexx.o shell.o pctile.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 FC = gfortran diff --git a/bpdecode174.f90 b/bpdecode174.f90 deleted file mode 100644 index df0eb67..0000000 --- a/bpdecode174.f90 +++ /dev/null @@ -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 diff --git a/bpdecode174_91.f90 b/bpdecode174_91.f90 new file mode 100644 index 0000000..91bea04 --- /dev/null +++ b/bpdecode174_91.f90 @@ -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 diff --git a/chkcall.f90 b/chkcall.f90 new file mode 100644 index 0000000..3d86114 --- /dev/null +++ b/chkcall.f90 @@ -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 diff --git a/chkcrc12a.f90 b/chkcrc12a.f90 deleted file mode 100644 index 4377801..0000000 --- a/chkcrc12a.f90 +++ /dev/null @@ -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 diff --git a/chkcrc14a.f90 b/chkcrc14a.f90 new file mode 100644 index 0000000..409ba9e --- /dev/null +++ b/chkcrc14a.f90 @@ -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 diff --git a/crc.f90 b/crc.f90 index 3f60048..2cb7c4a 100644 --- a/crc.f90 +++ b/crc.f90 @@ -10,7 +10,7 @@ module crc integer (c_int), value :: length 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 implicit none logical (c_bool) :: crc14_check @@ -18,37 +18,5 @@ module crc integer (c_int), value :: length 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 module crc diff --git a/crc12.c b/crc12.c deleted file mode 100644 index a4dc144..0000000 --- a/crc12.c +++ /dev/null @@ -1,59 +0,0 @@ -#include - -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); -} diff --git a/crc14.c b/crc14.c new file mode 100644 index 0000000..8fdce54 --- /dev/null +++ b/crc14.c @@ -0,0 +1,59 @@ +#include + +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); +} diff --git a/db.f90 b/db.f90 deleted file mode 100644 index aa58f43..0000000 --- a/db.f90 +++ /dev/null @@ -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 diff --git a/encode174.f90 b/encode174.f90 deleted file mode 100644 index 61bce37..0000000 --- a/encode174.f90 +++ /dev/null @@ -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 diff --git a/encode174_91.f90 b/encode174_91.f90 new file mode 100644 index 0000000..df99698 --- /dev/null +++ b/encode174_91.f90 @@ -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 diff --git a/extractmessage174.f90 b/extractmessage174.f90 deleted file mode 100644 index fd8fafb..0000000 --- a/extractmessage174.f90 +++ /dev/null @@ -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 diff --git a/extractmessage174_91.f90 b/extractmessage174_91.f90 new file mode 100644 index 0000000..bf52de2 --- /dev/null +++ b/extractmessage174_91.f90 @@ -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 diff --git a/fmtmsg.f90 b/fmtmsg.f90 index 2ceb815..81789e2 100644 --- a/fmtmsg.f90 +++ b/fmtmsg.f90 @@ -1,16 +1,16 @@ subroutine fmtmsg(msg,iz) - character*22 msg + character*(*) msg ! Convert all letters to upper case - iz=22 - do i=1,22 + iz=len(msg) + do i=1,iz if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') & msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a')) if(msg(i:i).ne.' ') iz=i enddo - do iter=1,5 !Collapse multiple blanks into one + do iter=1,37 !Collapse multiple blanks into one ib2=index(msg(1:iz),' ') if(ib2.lt.1) go to 100 msg=msg(1:ib2)//msg(ib2+2:) diff --git a/ft8_params.f90 b/ft8_params.f90 index c9c8e38..531edcd 100644 --- a/ft8_params.f90 +++ b/ft8_params.f90 @@ -1,5 +1,5 @@ -! LDPC (174,87) code -parameter (KK=87) !Information bits (75 + CRC12) +! LDPC (174,91) code +parameter (KK=91) !Information bits (77 + CRC14) parameter (ND=58) !Data symbols parameter (NS=21) !Sync symbols (3 @ Costas 7x7) 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 (NHSYM=NMAX/NSTEP-3) !Number of symbol spectra (1/4-sym steps) parameter (NDOWN=20) !Downsample factor -parameter (MAXCAND=200) +parameter (MAXCAND=300) diff --git a/ft8b.f90 b/ft8b.f90 index a131fe5..07ed591 100644 --- a/ft8b.f90 +++ b/ft8b.f90 @@ -1,42 +1,55 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & - napwid,nagain,iaptype,f1,xdt,xbase,apsym,nharderrors,dmin, & - nbadcrc,ipass,msgcall,msggrid,xsnr) + napwid,lsubtract,nagain,ncontest,iaptype,f1,xdt,xbase,apsym,nharderrors, & + dmin,nbadcrc,ipass,msg37,msgcall,msggrid,xsnr) use crc + use packjt77 include 'ft8_params.f90' 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 s1(0:7,ND),s2(0:7,NN),s1sort(8*ND) - real ps(0:7),psl(0:7) - real bmeta(3*ND),bmetb(3*ND),bmetap(3*ND) - real llr(3*ND),llra(3*ND),llr0(3*ND),llr1(3*ND),llrap(3*ND) !Soft symbols + real s8(0:7,NN) + real s2(0:511),s2l(0:511) + real bmeta(174),bmetb(174),bmetc(174) + real llra(174),llrb(174),llrc(174),llrd(174) !Soft symbols complex dd0(NMAX) - integer*1 decoded(KK),apmask(3*ND),cw(3*ND) - integer apsym(KK) - integer mcq(28),mde(28),mrrr(16),m73(16),mrr73(16) + integer*1 message77(77),apmask(174),cw(174) + integer apsym(58) + integer mcq(29),mcqru(29),mcqfd(29),mcqtest(29) + integer mrrr(19),m73(19),mrr73(19) integer itone(NN) - integer indxs1(8*ND) integer icos7(0:6),ip(1) 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 - complex cd0(3200) + integer ncontest,ncontest0 + logical one(0:511,0:8) + integer graymap(0:7) + complex cd0(0:3199) complex ctwk(32) complex csymb(32) - logical first,newdat,lapon,lapcqonly,nagain - equivalence (s1,s1sort) - data icos7/2,5,6,0,4,1,3/ - 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 mrrr/0,1,1,1,1,1,1,0,1,1,0,0,1,1,1,1/ - data m73/0,1,1,1,1,1,1,0,1,1,0,1,0,0,0,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 mrr73/0,0,0,0,0,0,1,0,0,0,0,1,0,1,0,1/ + complex cs(0:7,NN) + logical first,newdat,lsubtract,lapon,lapcqonly,nagain,unpk77_success + data icos7/3,1,4,0,6,5,2/ ! Flipped w.r.t. original FT8 sync array + 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 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 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 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 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./ - 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 - mde=2*mde-1 + mcqfd=2*mcqfd-1 + mcqru=2*mcqru-1 + mcqtest=2*mcqtest-1 mrrr=2*mrrr-1 m73=2*m73-1 mrr73=2*mrr73-1 @@ -49,25 +62,33 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & ! iaptype !------------------------ -! 1 CQ ??? ??? -! 2 MyCall ??? ??? -! 3 MyCall DxCall ??? -! 4 MyCall DxCall RRR -! 5 MyCall DxCall 73 -! 6 MyCall DxCall RR73 -! 7 ??? DxCall ??? +! 1 CQ ??? ??? (29+3=32 ap bits) +! 2 MyCall ??? ??? (29+3=32 ap bits) +! 3 MyCall DxCall ??? (58+3=61 ap bits) +! 4 MyCall DxCall RRR (77 ap bits) +! 5 MyCall DxCall 73 (77 ap bits) +! 6 MyCall DxCall RR73 (77 ap bits) - naptypes(0,1:4)=(/1,2,0,0/) - naptypes(1,1:4)=(/2,3,0,0/) - naptypes(2,1:4)=(/2,3,0,0/) - naptypes(3,1:4)=(/3,4,5,6/) - naptypes(4,1:4)=(/3,4,5,6/) - naptypes(5,1:4)=(/3,1,2,0/) + naptypes(0,1:4)=(/1,2,0,0/) ! Tx6 selected (CQ) + naptypes(1,1:4)=(/2,3,0,0/) ! Tx1 + naptypes(2,1:4)=(/2,3,0,0/) ! Tx2 + naptypes(3,1:4)=(/3,4,5,6/) ! Tx3 + naptypes(4,1:4)=(/3,4,5,6/) ! Tx4 + 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. + ncontest0=ncontest endif max_iterations=30 nharderrors=-1 + nbadcrc=1 ! this is used upstream to flag good decodes. fs2=4000.0/NDOWN dt2=1.0/fs2 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)) phi=mod(phi+dphi,twopi) enddo - call sync8d(cd0,i0,ctwk,1,sync) + call sync8d(cd0,i0,ctwk,1,sync) if( sync .gt. smax ) then smax=sync delfbest=delf @@ -109,16 +130,15 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & call twkfreq1(cd0,NP2,fs2,a,cd0) xdt=xdt2 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 i1=ibest+(k-1)*32 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) - 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 ! sync quality check @@ -126,11 +146,11 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & is2=0 is3=0 do k=1,7 - ip=maxloc(s2(:,k)) + ip=maxloc(s8(:,k)) 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 - ip=maxloc(s2(:,k+72)) + ip=maxloc(s8(:,k+72)) if(icos7(k-1).eq.(ip(1)-1)) is3=is3+1 enddo ! hard sync sum - max is 21 @@ -140,245 +160,258 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & return endif - j=0 - do k=1,NN - if(k.le.7) cycle - if(k.ge.37 .and. k.le.43) cycle - if(k.gt.72) cycle - j=j+1 - s1(0:7,j)=s2(0:7,k) + do nsym=1,3 + nt=2**(3*nsym) + do ihalf=1,2 + do k=1,29,nsym + if(ihalf.eq.1) ks=k+7 + if(ihalf.eq.2) ks=k+43 + 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 + call normalizebmet(bmeta,174) + call normalizebmet(bmetb,174) + call normalizebmet(bmetc,174) - call indexx(s1sort,8*ND,indxs1) - xmeds1=s1sort(indxs1(nint(0.5*8*ND))) - s1=s1/xmeds1 + scalefac=2.83 + llra=scalefac*bmeta + llrb=scalefac*bmetb + llrc=scalefac*bmetc - do j=1,ND - 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 + apmag=maxval(abs(llra))*1.01 -! Metric for Cauchy noise -! 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) -! r2=log(ps(2)**3+ps(3)**3+ps(6)**3+ps(7)**3)- & -! log(ps(0)**3+ps(1)**3+ps(4)**3+ps(5)**3) -! r4=log(ps(4)**3+ps(5)**3+ps(6)**3+ps(7)**3)- & -! log(ps(0)**3+ps(1)**3+ps(2)**3+ps(3)**3) -! Metric for AWGN, no fading -! bscale=2.5 -! 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) +! pass # +!------------------------------ +! 1 regular decoding, nsym=1 +! 2 regular decoding, nsym=2 +! 3 regular decoding, nsym=3 +! 4 ap pass 1, nsym=1 (for now?) +! 5 ap pass 2 +! 6 ap pass 3 +! 7 ap pass 4 - if(nQSOProgress .eq. 0 .or. nQSOProgress .eq. 5) then -! When bits 88:115 are set as ap bits, bit 115 lives in symbol 39 along -! with no-ap bits 116 and 117. Take care of metrics for bits 116 and 117. - if(j.eq.39) then ! take care of bits that live in symbol 39 - if(apsym(28).lt.0) then - bmetap(i2)=max(ps(2),ps(3))-max(ps(0),ps(1)) - bmetap(i1)=max(ps(1),ps(3))-max(ps(0),ps(2)) - else - bmetap(i2)=max(ps(6),ps(7))-max(ps(4),ps(5)) - bmetap(i1)=max(ps(5),ps(7))-max(ps(4),ps(6)) + if(lapon.or.ncontest.eq.6) then !Hounds always use AP + if(.not.lapcqonly) then + npasses=3+nappasses(nQSOProgress) + else + npasses=4 + endif + else + npasses=3 + endif + + 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 -! 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 - call bpdecode174(llrap,apmask,max_iterations,decoded,cw,nharderrors, & + call bpdecode174_91(llrd,apmask,max_iterations,message77,cw,nharderrors, & niterations) dmin=0.0 if(ndepth.eq.3 .and. nharderrors.lt.0) then ndeep=3 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=3 - else - ndeep=4 - endif + ndeep=4 endif if(nagain) ndeep=5 - call osd174(llrap,apmask,ndeep,decoded,cw,nharderrors,dmin) + call osd174_91(llrd,apmask,ndeep,message77,cw,nharderrors,dmin) endif - nbadcrc=1 - message=' ' - xsnr=-99.0 + + msg37=' ' + if(nharderrors.lt.0 .or. nharderrors.gt.36) cycle if(count(cw.eq.0).eq.174) cycle !Reject the all-zero codeword - if(nharderrors.ge.0 .and. nharderrors+dmin.lt.60.0 .and. & - .not.(sync.lt.2.0 .and. nharderrors.gt.35) .and. & - .not.(ipass.gt.2 .and. nharderrors.gt.39) .and. & - .not.(ipass.eq.4 .and. nharderrors.gt.30) & - ) then - call chkcrc12a(decoded,nbadcrc) - else - nharderrors=-1 + write(c77,'(77i1)') message77 + read(c77(72:74),'(b3)') n3 + read(c77(75:77),'(b3)') i3 + if(i3.gt.4 .or. (i3.eq.0.and.n3.gt.5)) then cycle endif - if(nbadcrc.eq.0) then - call extractmessage174(decoded,message,msgcall,msggrid,ncrcflag) - call genft8(message,0,itone) - 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 + call unpack77(c77,msg37,msgcall,msggrid,unpk77_success) + if(.not.unpk77_success) then + cycle 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 end subroutine ft8b @@ -420,4 +453,3 @@ function bessi0(x) endif return end function bessi0 - diff --git a/ft8d.f90 b/ft8d.f90 index 13235ec..28df6be 100644 --- a/ft8d.f90 +++ b/ft8d.f90 @@ -3,14 +3,16 @@ program ft8d ! Decode FT8 data read from *.c2 files. include 'ft8_params.f90' - character infile*80,date*6,time*4 - character msgcall*6,msggrid*4 + character infile*80,msg37*37,date*6,time*4 + character msgcall*13,msggrid*4 + character*37 allmessages(100) real s(NFFT1,NHSYM) real sbase(NFFT1) real candidate(3,MAXCAND) real*8 dialfreq complex dd(NMAX,4) - logical newdat + logical newdat,lft8apon,lsubtract,ldupe + integer allsnrs(100) integer apsym(KK) nargs=iargc() @@ -19,13 +21,6 @@ program ft8d go to 999 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 nfb=+1600 nfqso=0 @@ -38,29 +33,59 @@ program ft8d date=infile(j2-11:j2-6) time=infile(j2-4:j2-1) do ipart=1,4 + nQSOProgress=0 ndecodes=0 + n2=0 + allmessages=' ' + allsnrs=0 + ncontest=0 + lft8apon=.false. ndepth=1 - newdat=.true. - syncmin=1.5 - 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,nagain,iaptype, & - f1,xdt,xbase,apsym,nharderrors,dmin,nbadcrc,iappass, & - msgcall,msggrid,xsnr) - nsnr=nint(xsnr) - xdt=xdt-0.5 - 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) + if(ndepth.eq.1) npass=1 + if(ndepth.ge.2) npass=3 + do ipass=1,npass + newdat=.true. + syncmin=1.5 + if(ipass.eq.1) then + lsubtract=.true. + if(ndepth.eq.1) lsubtract=.false. + elseif(ipass.eq.2) then + n2=ndecodes + if(ndecodes.eq.0) cycle + lsubtract=.true. + elseif(ipass.eq.3) then + if((ndecodes-n2).eq.0) cycle + lsubtract=.false. 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 ! ipart loop diff --git a/genft8.f90 b/genft8.f90 index dd948a7..2bfb9cc 100644 --- a/genft8.f90 +++ b/genft8.f90 @@ -1,35 +1,33 @@ -subroutine genft8(msg,i3bit,itone) +subroutine genft8(msg,i3,n3,msgsent,msgbits,itone) ! Encode an FT8 message, producing array itone(). - use crc - use packjt + use packjt77 include 'ft8_params.f90' - character*22 msg - character*87 cbits - integer*4 i4Msg6BitWords(12) !72-bit message as 6-bit words - integer*1 msgbits(KK),codeword(3*ND) - integer*1, target:: i1Msg8BitBytes(11) - integer itone(NN) + character msg*37,msgsent*37,msgcall*13,msggrid*4 + character*77 c77 + integer*1 msgbits(77),codeword(174) + integer itone(79) 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 -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) +entry get_tones_from_77bits(msgbits,itone) - write(cbits,1003) i4Msg6BitWords,i3bit,icrc12 -1003 format(12b6.6,b3.3,b12.12) - read(cbits,1004) msgbits -1004 format(87i1) - - call encode174(msgbits,codeword) !Encode the test message +2 call encode174_91(msgbits,codeword) !Encode the test message ! Message structure: S7 D29 S7 D29 S7 itone(1:7)=icos7 @@ -40,8 +38,9 @@ subroutine genft8(msg,i3bit,itone) i=3*j -2 k=k+1 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 - return +900 return end subroutine genft8 diff --git a/genft8refsig.f90 b/genft8refsig.f90 new file mode 100644 index 0000000..ca3062e --- /dev/null +++ b/genft8refsig.f90 @@ -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 diff --git a/ldpc_174_87_params.f90 b/ldpc_174_87_params.f90 deleted file mode 100644 index 35af9b8..0000000 --- a/ldpc_174_87_params.f90 +++ /dev/null @@ -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/ - diff --git a/ldpc_174_91_c_generator.f90 b/ldpc_174_91_c_generator.f90 new file mode 100644 index 0000000..675bae5 --- /dev/null +++ b/ldpc_174_91_c_generator.f90 @@ -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"/ diff --git a/ldpc_174_91_c_reordered_parity.f90 b/ldpc_174_91_c_reordered_parity.f90 new file mode 100644 index 0000000..2309ad8 --- /dev/null +++ b/ldpc_174_91_c_reordered_parity.f90 @@ -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 diff --git a/osd174.f90 b/osd174_91.f90 similarity index 83% rename from osd174.f90 rename to osd174_91.f90 index 78eb472..1989c71 100644 --- a/osd174.f90 +++ b/osd174_91.f90 @@ -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 gen(K,N) integer*1 genmrb(K,N),g2(N,K) @@ -12,8 +11,12 @@ integer*1 r2pat(N-K) integer indices(N),nxor(N) integer*1 cw(N),ce(N),c0(N),hdec(N) integer*1 decoded(K) +integer*1 message77(77) integer indx(N) real llr(N),rx(N),absrx(N) + +include "ldpc_174_91_c_generator.f90" + logical first,reset data first/.true./ save first,gen @@ -21,23 +24,24 @@ save first,gen if( first ) then ! fill the generator matrix gen=0 do i=1,M - do j=1,22 + do j=1,23 read(g(i)(j:j),"(Z1)") istr - do jj=1, 4 - irow=(j-1)*4+jj - if( btest(istr,4-jj) ) gen(irow,i)=1 - enddo + ibmax=4 + if(j.eq.23) ibmax=3 + do jj=1, ibmax + irow=(j-1)*4+jj + if( btest(istr,4-jj) ) gen(irow,K+i)=1 + enddo enddo enddo do irow=1,K - gen(irow,M+irow)=1 + gen(irow,irow)=1 enddo first=.false. endif -! Re-order received vector to place systematic msg bits at the end. -rx=llr(colorder+1) -apmaskr=apmask(colorder+1) +rx=llr +apmaskr=apmask ! Hard decisions on the received word. hdec=0 @@ -92,7 +96,7 @@ absrx=absrx(indices) rx=rx(indices) apmaskr=apmaskr(indices) -call mrbencode(m0,c0,g2,N,K) +call mrbencode91(m0,c0,g2,N,K) nxor=ieor(c0,hdec) nhardmin=sum(nxor) dmin=sum(nxor*absrx) @@ -155,7 +159,7 @@ do iorder=1,nord ntotal=ntotal+1 me=ieor(m0,mi) 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)) e2=e2sub nd1Kpt=sum(e2sub(1:nt))+1 @@ -165,7 +169,7 @@ do iorder=1,nord nd1Kpt=sum(e2(1:nt))+2 endif if(nd1Kpt .le. ntheta) then - call mrbencode(me,ce,g2,N,K) + call mrbencode91(me,ce,g2,N,K) nxor=ieor(ce,hdec) if(n1.eq.iflag) then dd=d1+sum(e2sub*absrx(K+1:N)) @@ -184,7 +188,7 @@ do iorder=1,nord enddo ! Get the next test error pattern, iflag will go negative ! when the last pattern with weight iorder has been generated. - call nextpat(misub,k,iorder,iflag) + call nextpat91(misub,k,iorder,iflag) enddo enddo @@ -195,7 +199,7 @@ if(npre2.eq.1) then do i2=i1-1,1,-1 ntotal=ntotal+1 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 @@ -208,7 +212,7 @@ if(npre2.eq.1) then iflag=K-nord+1 do while(iflag .ge.0) 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)) do i2=0,ntau ntotal2=ntotal2+1 @@ -216,7 +220,7 @@ if(npre2.eq.1) then if(i2.gt.0) ui(i2)=1 r2pat=ieor(e2sub,ui) 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 ncount2=ncount2+1 mi=misub @@ -224,7 +228,7 @@ if(npre2.eq.1) then mi(in2)=1 if(sum(mi).lt.nord+npre1+npre2.or.any(iand(apmaskr(1:K),mi).eq.1)) cycle me=ieor(m0,mi) - call mrbencode(me,ce,g2,N,K) + call mrbencode91(me,ce,g2,N,K) nxor=ieor(ce,hdec) dd=sum(nxor*absrx) if( dd .lt. dmin ) then @@ -235,20 +239,23 @@ if(npre2.eq.1) then goto 778 endif enddo - call nextpat(misub,K,nord,iflag) + call nextpat91(misub,K,nord,iflag) enddo endif 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 hdec(indices)=hdec -decoded=cw(M+1:N) -cw(colorder+1)=cw ! put the codeword back into received-word order -return -end subroutine osd174 +decoded=cw(1:K) +call chkcrc14a(decoded,nbadcrc) +message77=decoded(1:77) +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) ! fast encoding for low-weight test patterns codeword=0 @@ -258,9 +265,9 @@ integer*1 me(K),codeword(N),g2(N,K) endif enddo 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) ! generate the next test error pattern ind=-1 @@ -287,11 +294,11 @@ subroutine nextpat(mi,k,iorder,iflag) endif enddo 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 indexes(4000,2),fp(0:525000),np(4000) + integer indexes(5000,2),fp(0:525000),np(5000) logical reset common/boxes/indexes,fp,np @@ -323,10 +330,10 @@ subroutine boxit(reset,e2,ntau,npindex,i1,i2) np(ip)=npindex endif return -end subroutine boxit +end subroutine boxit91 -subroutine fetchit(reset,e2,ntau,i1,i2) - integer indexes(4000,2),fp(0:525000),np(4000) +subroutine fetchit91(reset,e2,ntau,i1,i2) + integer indexes(5000,2),fp(0:525000),np(5000) integer lastpat integer*1 e2(ntau) logical reset @@ -361,5 +368,5 @@ subroutine fetchit(reset,e2,ntau,i1,i2) endif lastpat=ipat return -end subroutine fetchit +end subroutine fetchit91 diff --git a/packjt.f90 b/packjt.f90 index c9b4001..934ccaf 100644 --- a/packjt.f90 +++ b/packjt.f90 @@ -6,7 +6,52 @@ module packjt 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. @@ -489,12 +534,12 @@ subroutine packcall(callsign,ncall,text) return end subroutine packmsg - subroutine unpackmsg(dat,msg,msgcall,msggrid) + subroutine unpackmsg(dat,msg) parameter (NBASE=37*36*10*27*27*27) parameter (NGBASE=180*180) 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 cqnnn=.false. @@ -526,16 +571,39 @@ subroutine packcall(callsign,ncall,text) endif 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) + 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' call grid2k(grid6,k) if(k.ge.1 .and. k.le.450) call getpfx2(k,c1) @@ -648,7 +716,7 @@ subroutine packcall(callsign,ncall,text) nc1=nc1a 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 nc1=nc1/2 if(iand(nc2,1).ne.0) nc3=nc3+65536 @@ -826,6 +894,32 @@ subroutine packcall(callsign,ncall,text) return 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) ! Convert ascii number, letter, or space to 0-36 for callsign packing. @@ -850,4 +944,90 @@ subroutine packcall(callsign,ncall,text) return 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 diff --git a/packjt77.f90 b/packjt77.f90 new file mode 100644 index 0000000..2a8a811 --- /dev/null +++ b/packjt77.f90 @@ -0,0 +1,1227 @@ +module packjt77 + +! These variables are accessible from outside via "use packjt77": + parameter (MAXHASH=1000,MAXRECENT=10) + character*13 callsign(MAXHASH) + integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) + integer n28a,n28b,nzhash + character*13 recent_calls(MAXRECENT) + + contains + +subroutine hash10(n10,c13) + + character*13 c13 + + c13='<...>' + do i=1,nzhash + if(ihash10(i).eq.n10) then + c13=callsign(i) + c13='<'//trim(c13)//'>'//' ' + go to 900 + endif + enddo + +900 return +end subroutine hash10 + +subroutine hash12(n12,c13) + + character*13 c13 + + c13='<...>' + do i=1,nzhash + if(ihash12(i).eq.n12) then + c13=callsign(i) + c13='<'//trim(c13)//'>'//' ' + go to 900 + endif + enddo + +900 return +end subroutine hash12 + + +subroutine hash22(n22,c13) + + character*13 c13 + + c13='<...>' + do i=1,nzhash + if(ihash22(i).eq.n22) then + c13=callsign(i) + c13='<'//trim(c13)//'>'//' ' + go to 900 + endif + enddo + +900 return +end subroutine hash22 + + +integer function ihashcall(c0,m) + + integer*8 n8 + character*13 c0 + character*38 c + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ + + n8=0 + do i=1,11 + j=index(c,c0(i:i)) - 1 + n8=38*n8 + j + enddo + ihashcall=ishft(47055833459_8*n8,m-64) + + return +end function ihashcall + +subroutine save_hash_call(c13,n10,n12,n22) + + character*13 c13,cw + logical first + data first/.true./ + save first + + if(first) then + ihash10=-1 + ihash12=-1 + ihash22=-1 + callsign=' ' + nzhash=0 + first=.false. + endif + + cw=c13 + if(cw(1:1).eq.' ' .or. cw(1:5).eq.'<...>') return + if(cw(1:1).eq.'<') cw=cw(2:) + i=index(cw,'>') + if(i.gt.0) cw(i:)=' ' + + n10=ihashcall(cw,10) + n12=ihashcall(cw,12) + n22=ihashcall(cw,22) + do i=1,nzhash + if(ihash22(i).eq.n22) go to 900 !This one is already in the table + enddo + +! New entry: move table down, making room for new one at the top + ihash10(MAXHASH:2:-1)=ihash10(MAXHASH-1:1:-1) + ihash12(MAXHASH:2:-1)=ihash12(MAXHASH-1:1:-1) + ihash22(MAXHASH:2:-1)=ihash22(MAXHASH-1:1:-1) + +! Add the new entry + callsign(MAXHASH:2:-1)=callsign(MAXHASH-1:1:-1) + ihash10(1)=n10 + ihash12(1)=n12 + ihash22(1)=n22 + callsign(1)=cw + if(nzhash.lt.MAXHASH) nzhash=nzhash+1 + +900 return +end subroutine save_hash_call + +subroutine pack77(msg0,i3,n3,c77) + + use packjt + character*37 msg,msg0 + character*18 c18 + character*13 w(19) + character*77 c77 + integer nw(19) + integer ntel(3) + + msg=msg0 + if(i3.eq.0 .and. n3.eq.5) go to 5 + +! Convert msg to upper case; collapse multiple blanks; parse into words. + call split77(msg,nwords,nw,w) + i3=-1 + n3=-1 + if(msg(1:3).eq.'CQ ' .or. msg(1:3).eq.'DE ' .or. msg(1:4).eq.'QRZ ') go to 100 + +! Check 0.1 (DXpedition mode) + call pack77_01(nwords,w,i3,n3,c77) + if(i3.ge.0 .or. n3.ge.1) go to 900 +! Check 0.2 (EU VHF contest exchange) + call pack77_02(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! Check 0.3 and 0.4 (ARRL Field Day exchange) + call pack77_03(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + if(nwords.ge.2) go to 100 + + ! Check 0.5 (telemetry) +5 i0=index(msg,' ') + c18=msg(1:i0-1)//' ' + c18=adjustr(c18) + ntel=-99 + read(c18,1005,err=6) ntel +1005 format(3z6) + if(ntel(1).ge.2**23) go to 800 +6 if(ntel(1).ge.0 .and. ntel(2).ge.0 .and. ntel(3).ge.0) then + i3=0 + n3=5 + write(c77,1006) ntel,n3,i3 +1006 format(b23.23,2b24.24,2b3.3) + go to 900 + endif + +! Check Type 1 (Standard 77-bit message) or Type 2, with optional "/P" +100 call pack77_1(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! Check Type 3 (ARRL RTTY contest exchange) + call pack77_3(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! Check Type 4 (One nonstandard call and one hashed call) + call pack77_4(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! It defaults to free text +800 i3=0 + n3=0 + msg(14:)=' ' + call packtext77(msg(1:13),c77(1:71)) + write(c77(72:77),'(2b3.3)') n3,i3 + +900 return +end subroutine pack77 + +subroutine unpack77(c77,msg,msgcall,msggrid,unpk77_success) + + parameter (NSEC=84) !Number of ARRL Sections + parameter (NUSCAN=65) !Number of US states and Canadian provinces + parameter (MAXGRID4=32400) + integer*8 n58 + integer ntel(3) + character*77 c77 + character*37 msg + character*13 call_1,call_2,call_3,msgcall + character*11 c11 + character*3 crpt,cntx + character*3 cmult(NUSCAN) + character*6 cexch,grid6 + character*4 grid4,cserial,msggrid + character*3 csec(NSEC) + character*38 c + logical unpk28_success,unpk77_success + + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ + data csec/ & + "AB ","AK ","AL ","AR ","AZ ","BC ","CO ","CT ","DE ","EB ", & + "EMA","ENY","EPA","EWA","GA ","GTA","IA ","ID ","IL ","IN ", & + "KS ","KY ","LA ","LAX","MAR","MB ","MDC","ME ","MI ","MN ", & + "MO ","MS ","MT ","NC ","ND ","NE ","NFL","NH ","NL ","NLI", & + "NM ","NNJ","NNY","NT ","NTX","NV ","OH ","OK ","ONE","ONN", & + "ONS","OR ","ORG","PAC","PR ","QC ","RI ","SB ","SC ","SCV", & + "SD ","SDG","SF ","SFL","SJV","SK ","SNJ","STX","SV ","TN ", & + "UT ","VA ","VI ","VT ","WCF","WI ","WMA","WNY","WPA","WTX", & + "WV ","WWA","WY ","DX "/ + data cmult/ & + "AL ","AK ","AZ ","AR ","CA ","CO ","CT ","DE ","FL ","GA ", & + "HI ","ID ","IL ","IN ","IA ","KS ","KY ","LA ","ME ","MD ", & + "MA ","MI ","MN ","MS ","MO ","MT ","NE ","NV ","NH ","NJ ", & + "NM ","NY ","NC ","ND ","OH ","OK ","OR ","PA ","RI ","SC ", & + "SD ","TN ","TX ","UT ","VT ","VA ","WA ","WV ","WI ","WY ", & + "NB ","NS ","QC ","ON ","MB ","SK ","AB ","BC ","NWT","NF ", & + "LB ","NU ","YT ","PEI","DC "/ + + unpk77_success=.true. + +! Check for bad data + do i=1,77 + if(c77(i:i).ne.'0' .and. c77(i:i).ne.'1') then + msg='failed unpack' + unpk77_success=.false. + return + endif + enddo + + read(c77(72:77),'(2b3)') n3,i3 + msg=repeat(' ',37) + msgcall=repeat(' ',13) + msggrid=repeat(' ',4) + if(i3.eq.0 .and. n3.eq.0) then +! 0.0 Free text + call unpacktext77(c77(1:71),msg(1:13)) + msg(14:)=' ' + msg=adjustl(msg) + + else if(i3.eq.0 .and. n3.eq.1) then +! 0.1 K1ABC RR73; W9XYZ -11 28 28 10 5 71 DXpedition Mode + read(c77,1010) n28a,n28b,n10,n5 +1010 format(2b28,b10,b5) + irpt=2*n5 - 30 + write(crpt,1012) irpt +1012 format(i3.2) + if(irpt.ge.0) crpt(1:1)='+' + call unpack28(n28a,call_1,unpk28_success) + if(.not.unpk28_success .or. n28a.le.2) unpk77_success=.false. + call unpack28(n28b,call_2,unpk28_success) + if(.not.unpk28_success .or. n28b.le.2) unpk77_success=.false. + call hash10(n10,call_3) + if(call_3(1:1).eq.'<') then + msg=trim(call_1)//' RR73; '//trim(call_2)//' '//trim(call_3)// & + ' '//crpt + else + msg=trim(call_1)//' RR73; '//trim(call_2)//' <'//trim(call_3)// & + '> '//crpt + endif + else if(i3.eq.0 .and. n3.eq.2) then +! 0.2 PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 70 EU VHF contest + read(c77,1020) n28a,ip,ir,irpt,iserial,igrid6 +1020 format(b28,2b1,b3,b12,b25) + call unpack28(n28a,call_1,unpk28_success) + if(.not.unpk28_success .or. n28a.le.2) unpk77_success=.false. + nrs=52+irpt + if(ip.eq.1) call_1=trim(call_1)//'/P'//' ' + write(cexch,1022) nrs,iserial +1022 format(i2,i4.4) + n=igrid6 + j1=n/(18*10*10*24*24) + n=n-j1*18*10*10*24*24 + j2=n/(10*10*24*24) + n=n-j2*10*10*24*24 + j3=n/(10*24*24) + n=n-j3*10*24*24 + j4=n/(24*24) + n=n-j4*24*24 + j5=n/24 + j6=n-j5*24 + grid6(1:1)=char(j1+ichar('A')) + grid6(2:2)=char(j2+ichar('A')) + grid6(3:3)=char(j3+ichar('0')) + grid6(4:4)=char(j4+ichar('0')) + grid6(5:5)=char(j5+ichar('A')) + grid6(6:6)=char(j6+ichar('A')) + msg=trim(call_1)//' '//cexch//' '//grid6 + if(ir.eq.1) msg=trim(call_1)//' R '//cexch//' '//grid6 + + else if(i3.eq.0 .and. (n3.eq.3 .or. n3.eq.4)) then +! 0.3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 ARRL Field Day +! 0.4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 71 ARRL Field Day + read(c77,1030) n28a,n28b,ir,intx,nclass,isec +1030 format(2b28,b1,b4,b3,b7) + if(isec.gt.NSEC .or. isec.lt.1) then + unpk77_success=.false. + isec=1 + endif + call unpack28(n28a,call_1,unpk28_success) + if(.not.unpk28_success .or. n28a.le.2) unpk77_success=.false. + call unpack28(n28b,call_2,unpk28_success) + if(.not.unpk28_success .or. n28b.le.2) unpk77_success=.false. + ntx=intx+1 + if(n3.eq.4) ntx=ntx+16 + write(cntx(1:2),1032) ntx +1032 format(i2) + cntx(3:3)=char(ichar('A')+nclass) + if(ir.eq.0 .and. ntx.lt.10) msg=trim(call_1)//' '//trim(call_2)// & + cntx//' '//csec(isec) + if(ir.eq.1 .and. ntx.lt.10) msg=trim(call_1)//' '//trim(call_2)// & + ' R'//cntx//' '//csec(isec) + if(ir.eq.0 .and. ntx.ge.10) msg=trim(call_1)//' '//trim(call_2)// & + ' '//cntx//' '//csec(isec) + if(ir.eq.1 .and. ntx.ge.10) msg=trim(call_1)//' '//trim(call_2)// & + ' R '//cntx//' '//csec(isec) + + else if(i3.eq.0 .and. n3.eq.5) then +! 0.5 0123456789abcdef01 71 71 Telemetry (18 hex) + read(c77,1006) ntel +1006 format(b23,2b24) + write(msg,1007) ntel +1007 format(3z6.6) + do i=1,18 + if(msg(i:i).ne.'0') exit + msg(i:i)=' ' + enddo + msg=adjustl(msg) + + else if(i3.eq.1 .or. i3.eq.2) then +! Type 1 (standard message) or Type 2 ("/P" form for EU VHF contest) + read(c77,1000) n28a,ipa,n28b,ipb,ir,igrid4,i3 +1000 format(2(b28,b1),b1,b15,b3) + call unpack28(n28a,call_1,unpk28_success) + if(.not.unpk28_success) unpk77_success=.false. + call unpack28(n28b,call_2,unpk28_success) + if(.not.unpk28_success) unpk77_success=.false. + if(call_1(1:3).eq.'CQ_') call_1(3:3)=' ' + if(index(call_1,'<').le.0) then + i=index(call_1,' ') + if(i.ge.4 .and. ipa.eq.1 .and. i3.eq.1) call_1(i:i+1)='/R' + if(i.ge.4 .and. ipa.eq.1 .and. i3.eq.2) call_1(i:i+1)='/P' + if(i.ge.4) call add_call_to_recent_calls(call_1) + endif + if(index(call_2,'<').le.0) then + i=index(call_2,' ') + if(i.ge.4 .and. ipb.eq.1 .and. i3.eq.1) call_2(i:i+1)='/R' + if(i.ge.4 .and. ipb.eq.1 .and. i3.eq.2) call_2(i:i+1)='/P' + if(i.ge.4) call add_call_to_recent_calls(call_2) + endif + if(igrid4.le.MAXGRID4) then + n=igrid4 + j1=n/(18*10*10) + n=n-j1*18*10*10 + j2=n/(10*10) + n=n-j2*10*10 + j3=n/10 + j4=n-j3*10 + grid4(1:1)=char(j1+ichar('A')) + grid4(2:2)=char(j2+ichar('A')) + grid4(3:3)=char(j3+ichar('0')) + grid4(4:4)=char(j4+ichar('0')) + if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//grid4 + if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R '//grid4 + if(msg(1:3).eq.'CQ ' .and. ir.eq.1) unpk77_success=.false. + if(igrid4.ne.32373) msggrid=grid4 + else + irpt=igrid4-MAXGRID4 + if(irpt.eq.1) msg=trim(call_1)//' '//trim(call_2) + if(irpt.eq.2) msg=trim(call_1)//' '//trim(call_2)//' RRR' + if(irpt.eq.3) msg=trim(call_1)//' '//trim(call_2)//' RR73' + if(irpt.eq.4) msg=trim(call_1)//' '//trim(call_2)//' 73' + if(irpt.ge.5) then + write(crpt,'(i3.2)') irpt-35 + if(crpt(1:1).eq.' ') crpt(1:1)='+' + if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//crpt + if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R'//crpt + endif + if(msg(1:3).eq.'CQ ' .and. irpt.ge.2) unpk77_success=.false. + endif + msgcall=trim(call_2) + + else if(i3.eq.3) then +! Type 3: ARRL RTTY Contest + read(c77,1040) itu,n28a,n28b,ir,irpt,nexch,i3 +1040 format(b1,2b28.28,b1,b3.3,b13.13,b3.3) + write(crpt,1042) irpt+2 +1042 format('5',i1,'9') + nserial=nexch + imult=-1 + if(nexch.gt.8000) then + imult=nexch-8000 + nserial=-1 + endif + call unpack28(n28a,call_1,unpk28_success) + if(.not.unpk28_success) unpk77_success=.false. + call unpack28(n28b,call_2,unpk28_success) + if(.not.unpk28_success) unpk77_success=.false. + imult=0 + nserial=0 + if(nexch.gt.8000) imult=nexch-8000 + if(nexch.lt.8000) nserial=nexch + + if(imult.ge.1 .and.imult.le.NUSCAN) then + if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// & + ' '//crpt//' '//cmult(imult) + if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// & + ' '//crpt//' '//cmult(imult) + if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// & + ' R '//crpt//' '//cmult(imult) + if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// & + ' R '//crpt//' '//cmult(imult) + else if(nserial.ge.1 .and. nserial.le.7999) then + write(cserial,'(i4.4)') nserial + if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// & + ' '//crpt//' '//cserial + if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// & + ' '//crpt//' '//cserial + if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// & + ' R '//crpt//' '//cserial + if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// & + ' R '//crpt//' '//cserial + endif + else if(i3.eq.4) then + read(c77,1050) n12,n58,iflip,nrpt,icq +1050 format(b12,b58,b1,b2,b1) + do i=11,1,-1 + j=mod(n58,38)+1 + c11(i:i)=c(j:j) + n58=n58/38 + enddo + call hash12(n12,call_3) + if(iflip.eq.0) then + call_1=call_3 + call_2=adjustl(c11)//' ' + call add_call_to_recent_calls(call_2) + else + call_1=adjustl(c11)//' ' + call_2=call_3 + call add_call_to_recent_calls(call_1) + endif + if(icq.eq.0) then + if(nrpt.eq.0) msg=trim(call_1)//' '//trim(call_2) + if(nrpt.eq.1) msg=trim(call_1)//' '//trim(call_2)//' RRR' + if(nrpt.eq.2) msg=trim(call_1)//' '//trim(call_2)//' RR73' + if(nrpt.eq.3) msg=trim(call_1)//' '//trim(call_2)//' 73' + else + msg='CQ '//trim(call_2) + endif + msgcall=trim(call_2) + endif + if(msg(1:4).eq.'CQ <') unpk77_success=.false. + + return +end subroutine unpack77 + +subroutine pack28(c13,n28) + +! Pack a special token, a 22-bit hash code, or a valid base call into a 28-bit +! integer. + + parameter (NTOKENS=2063592,MAX22=4194304) + logical is_digit,is_letter + character*13 c13 + character*6 callsign + character*1 c + character*4 c4 + character*37 a1 + character*36 a2 + character*10 a3 + character*27 a4 + data a1/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data a2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data a3/'0123456789'/ + data a4/' ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + + is_digit(c)=c.ge.'0' .and. c.le.'9' + is_letter(c)=c.ge.'A' .and. c.le.'Z' + + n28=-1 +! Work-around for Swaziland prefix: + if(c13(1:4).eq.'3DA0') callsign='3D0'//c13(5:7) +! Work-around for Guinea prefixes: + if(c13(1:2).eq.'3X' .and. c13(3:3).ge.'A' .and. & + c13(3:3).le.'Z') callsign='Q'//c13(3:6) + +! Check for special tokens first + if(c13(1:3).eq.'DE ') then + n28=0 + go to 900 + endif + + if(c13(1:4).eq.'QRZ ') then + n28=1 + go to 900 + endif + + if(c13(1:3).eq.'CQ ') then + n28=2 + go to 900 + endif + + if(c13(1:3).eq.'CQ_') then + n=len(trim(c13)) + if(n.ge.4 .and. n.le.7) then + nlet=0 + nnum=0 + do i=4,n + c=c13(i:i) + if(c.ge.'A' .and. c.le.'Z') nlet=nlet+1 + if(c.ge.'0' .and. c.le.'9') nnum=nnum+1 + enddo + if(nnum.eq.3 .and. nlet.eq.0) then + read(c13(4:3+nnum),*) nqsy + n28=3+nqsy + go to 900 + endif + if(nlet.ge.1 .and. nlet.le.4 .and. nnum.eq.0) then + c4=c13(4:n)//' ' + c4=adjustr(c4) + m=0 + do i=1,4 + j=0 + c=c4(i:i) + if(c.ge.'A' .and. c.le.'Z') j=ichar(c)-ichar('A')+1 + m=27*m + j + enddo + n28=3+1000+m + go to 900 + endif + endif + endif + +! Check for <...> callsign + if(c13(1:1).eq.'<')then + call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table + n28=NTOKENS + n22 + go to 900 + endif + +! Check for standard callsign + iarea=-1 + n=len(trim(c13)) + do i=n,2,-1 + if(is_digit(c13(i:i))) exit + enddo + iarea=i !Call-area digit + npdig=0 !Digits before call area + nplet=0 !Letters before call area + do i=1,iarea-1 + if(is_digit(c13(i:i))) npdig=npdig+1 + if(is_letter(c13(i:i))) nplet=nplet+1 + enddo + nslet=0 + do i=iarea+1,n + if(is_letter(c13(i:i))) nslet=nslet+1 + enddo + if(iarea.lt.2 .or. iarea.gt.3 .or. nplet.eq.0 .or. & + npdig.ge.iarea-1 .or. nslet.gt.3) then +! Treat this as a nonstandard callsign: compute its 22-bit hash + call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table + n28=NTOKENS + n22 + go to 900 + endif + + n=len(trim(c13)) +! This is a standard callsign + call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table + if(iarea.eq.2) callsign=' '//c13(1:5) + if(iarea.eq.3) callsign=c13(1:6) + i1=index(a1,callsign(1:1))-1 + i2=index(a2,callsign(2:2))-1 + i3=index(a3,callsign(3:3))-1 + i4=index(a4,callsign(4:4))-1 + i5=index(a4,callsign(5:5))-1 + i6=index(a4,callsign(6:6))-1 + n28=36*10*27*27*27*i1 + 10*27*27*27*i2 + 27*27*27*i3 + 27*27*i4 + & + 27*i5 + i6 + n28=n28 + NTOKENS + MAX22 + +900 n28=iand(n28,ishft(1,28)-1) + return +end subroutine pack28 + + +subroutine unpack28(n28_0,c13,success) + + parameter (NTOKENS=2063592,MAX22=4194304) + logical success + character*13 c13 + character*37 c1 + character*36 c2 + character*10 c3 + character*27 c4 + data c1/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data c2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data c3/'0123456789'/ + data c4/' ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + + success=.true. + n28=n28_0 + if(n28.lt.NTOKENS) then +! Special tokens DE, QRZ, CQ, CQ_nnn, CQ_aaaa + if(n28.eq.0) c13='DE ' + if(n28.eq.1) c13='QRZ ' + if(n28.eq.2) c13='CQ ' + if(n28.le.2) go to 900 + if(n28.le.1002) then + write(c13,1002) n28-3 +1002 format('CQ_',i3.3) + go to 900 + endif + if(n28.le.532443) then + n=n28-1003 + n0=n + i1=n/(27*27*27) + n=n-27*27*27*i1 + i2=n/(27*27) + n=n-27*27*i2 + i3=n/27 + i4=n-27*i3 + c13=c4(i1+1:i1+1)//c4(i2+1:i2+1)//c4(i3+1:i3+1)//c4(i4+1:i4+1) + c13=adjustl(c13) + c13='CQ_'//c13(1:10) + go to 900 + endif + endif + n28=n28-NTOKENS + if(n28.lt.MAX22) then +! This is a 22-bit hash of a callsign + n22=n28 + call hash22(n22,c13) !Retrieve callsign from hash table + go to 900 + endif + +! Standard callsign + n=n28 - MAX22 + i1=n/(36*10*27*27*27) + n=n-36*10*27*27*27*i1 + i2=n/(10*27*27*27) + n=n-10*27*27*27*i2 + i3=n/(27*27*27) + n=n-27*27*27*i3 + i4=n/(27*27) + n=n-27*27*i4 + i5=n/27 + i6=n-27*i5 + c13=c1(i1+1:i1+1)//c2(i2+1:i2+1)//c3(i3+1:i3+1)//c4(i4+1:i4+1)// & + c4(i5+1:i5+1)//c4(i6+1:i6+1)//' ' + c13=adjustl(c13) + +900 i0=index(c13,' ') + if(i0.ne.0 .and. i0.lt.len(trim(c13))) then + c13='QU1RK' + success=.false. + endif + return +end subroutine unpack28 + +subroutine split77(msg,nwords,nw,w) + +! Convert msg to upper case; collapse multiple blanks; parse into words. + + character*37 msg + character*13 w(19) + character*1 c,c0 + character*6 bcall_1 + logical ok1 + integer nw(19) + + iz=len(trim(msg)) + j=0 + k=0 + n=0 + c0=' ' + w=' ' + do i=1,iz + if(ichar(msg(i:i)).eq.0) msg(i:i)=' ' + c=msg(i:i) !Single character + if(c.eq.' ' .and. c0.eq.' ') cycle !Skip leading/repeated blanks + if(c.ne.' ' .and. c0.eq.' ') then + k=k+1 !New word + n=0 + endif + j=j+1 !Index in msg + n=n+1 !Index in word + msg(j:j)=c + if(c.ge.'a' .and. c.le.'z') msg(j:j)=char(ichar(c)-32) !Force upper case + if(n.le.13) w(k)(n:n)=c !Copy character c into word + c0=c + enddo + iz=j !Message length + nwords=k !Number of words in msg + if(nwords.le.0) go to 900 + nw(k)=len(trim(w(k))) + msg(iz+1:)=' ' + if(nwords.lt.3) go to 900 + call chkcall(w(3),bcall_1,ok1) + if(ok1 .and. w(1)(1:3).eq.'CQ ') then + w(1)='CQ_'//w(2)(1:10) !Make "CQ " into "CQ_" + w(2:12)=w(3:13) !Move all remeining words down by one + nwords=nwords-1 + endif + +900 return +end subroutine split77 + + +subroutine pack77_01(nwords,w,i3,n3,c77) + +! Pack a Type 0.1 message: DXpedition mode +! Example message: "K1ABC RR73; W9XYZ -11" 28 28 10 5 + + character*13 w(19) + character*77 c77 + character*6 bcall_1,bcall_2 + logical ok1,ok2 + + if(nwords.ne.5) go to 900 !Must have 5 words + if(trim(w(2)).ne.'RR73;') go to 900 !2nd word must be "RR73;" + if(w(4)(1:1).ne.'<') go to 900 !4th word must have <...> + if(index(w(4),'>').lt.1) go to 900 + n=-99 + read(w(5),*,err=1) n +1 if(n.eq.-99) go to 900 !5th word must be a valid report + n5=(n+30)/2 + if(n5.lt.0) n5=0 + if(n5.gt.31) n5=31 + call chkcall(w(1),bcall_1,ok1) + if(.not.ok1) go to 900 !1st word must be a valid basecall + call chkcall(w(3),bcall_2,ok2) + if(.not.ok2) go to 900 !3rd word must be a valid basecall + +! Type 0.1: K1ABC RR73; W9XYZ -11 28 28 10 5 71 DXpedition Mode + i3=0 + n3=1 + call pack28(w(1),n28a) + call pack28(w(3),n28b) + call save_hash_call(w(4),n10,n12,n22) + write(c77,1010) n28a,n28b,n10,n5,n3,i3 +1010 format(2b28.28,b10.10,b5.5,2b3.3) + +900 return +end subroutine pack77_01 + + +subroutine pack77_02(nwords,w,i3,n3,c77) + + character*13 w(19),c13 + character*77 c77 + character*6 bcall_1,grid6 + logical ok1,is_grid6 + + is_grid6(grid6)=len(trim(grid6)).eq.6 .and. & + grid6(1:1).ge.'A' .and. grid6(1:1).le.'R' .and. & + grid6(2:2).ge.'A' .and. grid6(2:2).le.'R' .and. & + grid6(3:3).ge.'0' .and. grid6(3:3).le.'9' .and. & + grid6(4:4).ge.'0' .and. grid6(4:4).le.'9' .and. & + grid6(5:5).ge.'A' .and. grid6(5:5).le.'X' .and. & + grid6(6:6).ge.'A' .and. grid6(6:6).le.'X' + + call chkcall(w(1),bcall_1,ok1) + if(.not.ok1) return !bcall_1 must be a valid basecall + if(nwords.lt.3 .or. nwords.gt.4) return !nwords must be 3 or 4 + nx=-1 + if(nwords.ge.2) read(w(nwords-1),*,err=2) nx +2 if(nx.lt.520001 .or. nx.gt.594095) return !Exchange between 520001 - 594095 + if(.not.is_grid6(w(nwords)(1:6))) return !Last word must be a valid grid6 + +! Type 0.2: PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 70 EU VHF contest + i3=0 + n3=2 + ip=0 + c13=w(1) + i=index(w(1),'/P') + if(i.ge.4) then + ip=1 + c13=w(1)(1:i-1)//' ' + endif + call pack28(c13,n28a) + ir=0 + if(w(2)(1:2).eq.'R ') ir=1 + irpt=nx/10000 - 52 + iserial=mod(nx,10000) + grid6=w(nwords)(1:6) + j1=(ichar(grid6(1:1))-ichar('A'))*18*10*10*24*24 + j2=(ichar(grid6(2:2))-ichar('A'))*10*10*24*24 + j3=(ichar(grid6(3:3))-ichar('0'))*10*24*24 + j4=(ichar(grid6(4:4))-ichar('0'))*24*24 + j5=(ichar(grid6(5:5))-ichar('A'))*24 + j6=(ichar(grid6(6:6))-ichar('A')) + igrid6=j1+j2+j3+j4+j5+j6 + write(c77,1010) n28a,ip,ir,irpt,iserial,igrid6,n3,i3 +1010 format(b28.28,2b1,b3.3,b12.12,b25.25,b4.4,b3.3) + + return +end subroutine pack77_02 + + +subroutine pack77_03(nwords,w,i3,n3,c77) +! Check 0.3 and 0.4 (ARRL Field Day exchange) + + parameter (NSEC=84) !Number of ARRL Sections + character*13 w(19) + character*77 c77 + character*6 bcall_1,bcall_2 + character*3 csec(NSEC) + logical ok1,ok2 + data csec/ & + "AB ","AK ","AL ","AR ","AZ ","BC ","CO ","CT ","DE ","EB ", & + "EMA","ENY","EPA","EWA","GA ","GTA","IA ","ID ","IL ","IN ", & + "KS ","KY ","LA ","LAX","MAR","MB ","MDC","ME ","MI ","MN ", & + "MO ","MS ","MT ","NC ","ND ","NE ","NFL","NH ","NL ","NLI", & + "NM ","NNJ","NNY","NT ","NTX","NV ","OH ","OK ","ONE","ONN", & + "ONS","OR ","ORG","PAC","PR ","QC ","RI ","SB ","SC ","SCV", & + "SD ","SDG","SF ","SFL","SJV","SK ","SNJ","STX","SV ","TN ", & + "UT ","VA ","VI ","VT ","WCF","WI ","WMA","WNY","WPA","WTX", & + "WV ","WWA","WY ","DX "/ + + if(nwords.lt.4 .or. nwords.gt.5) return + call chkcall(w(1),bcall_1,ok1) + call chkcall(w(2),bcall_2,ok2) + if(.not.ok1 .or. .not.ok2) return + isec=-1 + do i=1,NSEC + if(csec(i).eq.w(nwords)(1:3)) then + isec=i + exit + endif + enddo + if(isec.eq.-1) return + if(nwords.eq.5 .and. trim(w(3)).ne.'R') return + + ntx=-1 + j=len(trim(w(nwords-1)))-1 + read(w(nwords-1)(1:j),*,err=1) ntx !Number of transmitters +1 if(ntx.lt.1 .or. ntx.gt.32) return + nclass=ichar(w(nwords-1)(j+1:j+1))-ichar('A') + + m=len(trim(w(nwords))) !Length of section abbreviation + if(m.lt.2 .or. m.gt.3) return + +! 0.3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 ARRL Field Day +! 0.4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 71 ARRL Field Day + + i3=0 + n3=3 !Type 0.3 ARRL Field Day + intx=ntx-1 + if(intx.ge.16) then + n3=4 !Type 0.4 ARRL Field Day + intx=ntx-17 + endif + call pack28(w(1),n28a) + call pack28(w(2),n28b) + ir=0 + if(w(3)(1:2).eq.'R ') ir=1 + write(c77,1010) n28a,n28b,ir,intx,nclass,isec,n3,i3 +1010 format(2b28.28,b1,b4.4,b3.3,b7.7,2b3.3) + + return +end subroutine pack77_03 + +subroutine pack77_1(nwords,w,i3,n3,c77) +! Check Type 1 (Standard 77-bit message) and Type 2 (ditto, with a "/P" call) + + parameter (MAXGRID4=32400) + character*13 w(19),c13 + character*77 c77 + character*6 bcall_1,bcall_2 + character*4 grid4 + character c1*1,c2*2 + logical is_grid4 + logical ok1,ok2 + is_grid4(grid4)=len(trim(grid4)).eq.4 .and. & + grid4(1:1).ge.'A' .and. grid4(1:1).le.'R' .and. & + grid4(2:2).ge.'A' .and. grid4(2:2).le.'R' .and. & + grid4(3:3).ge.'0' .and. grid4(3:3).le.'9' .and. & + grid4(4:4).ge.'0' .and. grid4(4:4).le.'9' + + if(nwords.lt.2 .or. nwords.gt.4) return + call chkcall(w(1),bcall_1,ok1) + call chkcall(w(2),bcall_2,ok2) + if(w(1)(1:3).eq.'DE ' .or. w(1)(1:3).eq.'CQ_' .or. w(1)(1:3).eq.'CQ ' .or. & + w(1)(1:4).eq.'QRZ ') ok1=.true. + if(w(1)(1:1).eq.'<' .and. index(w(1),'>').ge.5) ok1=.true. + if(w(2)(1:1).eq.'<' .and. index(w(2),'>').ge.5) ok2=.true. + if(.not.ok1 .or. .not.ok2) return + if(w(1)(1:1).eq.'<' .and. index(w(2),'/').gt.0) return + if(w(2)(1:1).eq.'<' .and. index(w(1),'/').gt.0) return + if(nwords.eq.2 .and. (.not.ok2 .or. index(w(2),'/').ge.2)) return + if(nwords.eq.2) go to 10 + + c1=w(nwords)(1:1) + c2=w(nwords)(1:2) + if(.not.is_grid4(w(nwords)(1:4)) .and. c1.ne.'+' .and. c1.ne.'-' & + .and. c2.ne.'R+' .and. c2.ne.'R-' .and. trim(w(nwords)).ne.'RRR' .and. & + trim(w(nwords)).ne.'RR73' .and. trim(w(nwords)).ne.'73') return + if(c1.eq.'+' .or. c1.eq.'-') then + ir=0 + read(w(nwords),*,err=900) irpt + irpt=irpt+35 + else if(c2.eq.'R+' .or. c2.eq.'R-') then + ir=1 + read(w(nwords)(2:),*) irpt + irpt=irpt+35 + else if(trim(w(nwords)).eq.'RRR') then + ir=0 + irpt=2 + else if(trim(w(nwords)).eq.'RR73') then + ir=0 + irpt=3 + else if(trim(w(nwords)).eq.'73') then + ir=0 + irpt=4 + endif + +! 1 WA9XYZ/R KA1ABC/R R FN42 28 1 28 1 1 15 74 Standard msg +! 2 PA3XYZ/P GM4ABC/P R JO22 28 1 28 1 1 15 74 EU VHF contest + +10 if(nwords.eq.2 .or. nwords.eq.3 .or. (nwords.eq.4 .and. & + w(3)(1:2).eq.'R ')) then + n3=0 + i3=1 !Type 1: Standard message, possibly with "/R" + if(index(w(1),'/P').ge.4 .or. index(w(2),'/P').ge.4) i3=2 !Type 2, with "/P" + endif + c13=bcall_1//' ' + if(c13(1:3).eq.'CQ_' .or. w(1)(1:1).eq.'<') c13=w(1) + call pack28(c13,n28a) + c13=bcall_2//' ' + if(w(2)(1:1).eq.'<') c13=w(2) + call pack28(c13,n28b) + ipa=0 + ipb=0 + if(index(w(1),'/P').ge.4 .or. index(w(1),'/R').ge.4) ipa=1 + if(index(w(2),'/P').ge.4 .or. index(w(2),'/R').ge.4) ipb=1 + + grid4=w(nwords)(1:4) + if(is_grid4(grid4)) then + ir=0 + if(w(3).eq.'R ') ir=1 + j1=(ichar(grid4(1:1))-ichar('A'))*18*10*10 + j2=(ichar(grid4(2:2))-ichar('A'))*10*10 + j3=(ichar(grid4(3:3))-ichar('0'))*10 + j4=(ichar(grid4(4:4))-ichar('0')) + igrid4=j1+j2+j3+j4 + else + igrid4=MAXGRID4 + irpt + endif + if(nwords.eq.2) then + ir=0 + irpt=1 + igrid4=MAXGRID4+irpt + endif + write(c77,1000) n28a,ipa,n28b,ipb,ir,igrid4,i3 +1000 format(2(b28.28,b1),b1,b15.15,b3.3) + return + +900 return +end subroutine pack77_1 + + +subroutine pack77_3(nwords,w,i3,n3,c77) +! Check Type 2 (ARRL RTTY contest exchange) +!ARRL RTTY - US/Can: rpt state/prov R 579 MA +! - DX: rpt serial R 559 0013 + + parameter (NUSCAN=65) !Number of US states and Canadian provinces/territories + character*13 w(19) + character*77 c77 + character*6 bcall_1,bcall_2 + character*3 cmult(NUSCAN),mult + character crpt*3 + logical ok1,ok2 + data cmult/ & + "AL ","AK ","AZ ","AR ","CA ","CO ","CT ","DE ","FL ","GA ", & + "HI ","ID ","IL ","IN ","IA ","KS ","KY ","LA ","ME ","MD ", & + "MA ","MI ","MN ","MS ","MO ","MT ","NE ","NV ","NH ","NJ ", & + "NM ","NY ","NC ","ND ","OH ","OK ","OR ","PA ","RI ","SC ", & + "SD ","TN ","TX ","UT ","VT ","VA ","WA ","WV ","WI ","WY ", & + "NB ","NS ","QC ","ON ","MB ","SK ","AB ","BC ","NWT","NF ", & + "LB ","NU ","YT ","PEI","DC "/ + + if(nwords.eq.4 .or. nwords.eq.5 .or. nwords.eq.6) then + i1=1 + if(trim(w(1)).eq.'TU;') i1=2 + call chkcall(w(i1),bcall_1,ok1) + call chkcall(w(i1+1),bcall_2,ok2) + if(.not.ok1 .or. .not.ok2) go to 900 + crpt=w(nwords-1)(1:3) + if(crpt(1:1).eq.'5' .and. crpt(2:2).ge.'2' .and. crpt(2:2).le.'9' .and. & + crpt(3:3).eq.'9') then + nserial=0 + read(w(nwords),*,err=1) nserial +!1 i3=3 +! n3=0 + endif +1 mult=' ' + imult=-1 + do i=1,NUSCAN + if(cmult(i).eq.w(nwords)) then + imult=i + mult=cmult(i) + exit + endif + enddo + nexch=0 + if(nserial.gt.0) nexch=nserial + if(imult.gt.0) nexch=8000+imult + if(mult.ne.' ' .or. nserial.gt.0) then + i3=3 + n3=0 + itu=0 + if(trim(w(1)).eq.'TU;') itu=1 + call pack28(w(1+itu),n28a) + call pack28(w(2+itu),n28b) + ir=0 + if(w(3+itu)(1:2).eq.'R ') ir=1 + read(w(3+itu+ir),*,err=900) irpt + irpt=(irpt-509)/10 - 2 + if(irpt.lt.0) irpt=0 + if(irpt.gt.7) irpt=7 +! 3 TU; W9XYZ K1ABC R 579 MA 1 28 28 1 3 13 74 ARRL RTTY contest +! 3 TU; W9XYZ G8ABC R 559 0013 1 28 28 1 3 13 74 ARRL RTTY (DX) + write(c77,1010) itu,n28a,n28b,ir,irpt,nexch,i3 +1010 format(b1,2b28.28,b1,b3.3,b13.13,b3.3) + endif + endif + +900 return +end subroutine pack77_3 + +subroutine pack77_4(nwords,w,i3,n3,c77) +! Check Type 3 (One nonstandard call and one hashed call) + + integer*8 n58 + logical ok1,ok2 + character*13 w(19) + character*77 c77 + character*13 call_1,call_2 + character*11 c11 + character*6 bcall_1,bcall_2 + character*38 c + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ + + iflip=0 + i3=-1 + if(nwords.eq.2 .or. nwords.eq.3) then + call_1=w(1) + if(call_1(1:1).eq.'<') call_1=w(1)(2:len(trim(w(1)))-1) + call_2=w(2) + if(call_2(1:1).eq.'<') call_2=w(2)(2:len(trim(w(2)))-1) + call chkcall(call_1,bcall_1,ok1) + call chkcall(call_2,bcall_2,ok2) + icq=0 + if(trim(w(1)).eq.'CQ' .or. (ok1.and.ok2)) then + if(trim(w(1)).eq.'CQ' .and. len(trim(w(2))).le.4) go to 900 + i3=4 + n3=0 + if(trim(w(1)).eq.'CQ') icq=1 + endif + + if(icq.eq.1) then + iflip=0 + n12=0 + c11=adjustr(call_2(1:11)) + call save_hash_call(w(2),n10,n12,n22) + else if(w(1)(1:1).eq.'<') then + iflip=0 + i3=4 + call save_hash_call(w(1),n10,n12,n22) + c11=adjustr(call_2(1:11)) + else if(w(2)(1:1).eq.'<') then + iflip=1 + i3=4 + call save_hash_call(w(2),n10,n12,n22) + c11=adjustr(call_1(1:11)) + endif + n58=0 + do i=1,11 + n58=n58*38 + index(c,c11(i:i)) - 1 + enddo + nrpt=0 + if(trim(w(3)).eq.'RRR') nrpt=1 + if(trim(w(3)).eq.'RR73') nrpt=2 + if(trim(w(3)).eq.'73') nrpt=3 + if(icq.eq.1) then + iflip=0 + nrpt=0 + endif + write(c77,1010) n12,n58,iflip,nrpt,icq,i3 +1010 format(b12.12,b58.58,b1,b2.2,b1,b3.3) + do i=1,77 + if(c77(i:i).eq.'*') c77(i:i)='0' !### Clean up any illegal chars ### + enddo + endif + +900 return +end subroutine pack77_4 + +subroutine packtext77(c13,c71) + + character*13 c13,w + character*71 c71 + character*42 c + character*1 qa(10),qb(10) + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/ + + call mp_short_init + qa=char(0) + w=adjustr(c13) + do i=1,13 + j=index(c,w(i:i))-1 + if(j.lt.0) j=0 + call mp_short_mult(qb,qa(2:10),9,42) !qb(1:9)=42*qa(2:9) + call mp_short_add(qa,qb(2:10),9,j) !qa(1:9)=qb(2:9)+j + enddo + + write(c71,1010) qa(2:10) +1010 format(b7.7,8b8.8) + + return +end subroutine packtext77 + +subroutine unpacktext77(c71,c13) + + integer*1 ia(10) + character*1 qa(10),qb(10) + character*13 c13 + character*71 c71 + character*42 c + equivalence (qa,ia),(qb,ib) + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/ + + qa(1)=char(0) + read(c71,1010) qa(2:10) +1010 format(b7.7,8b8.8) + + do i=13,1,-1 + call mp_short_div(qb,qa(2:10),9,42,ir) + c13(i:i)=c(ir+1:ir+1) + qa(2:10)=qb(1:9) + enddo + + return +end subroutine unpacktext77 + +subroutine mp_short_ops(w,u) + character*1 w(*),u(*) + integer i,ireg,j,n,ir,iv,ii1,ii2 + character*1 creg(4) + save ii1,ii2 + equivalence (ireg,creg) + + entry mp_short_init + ireg=256*ichar('2')+ichar('1') + do j=1,4 + if (creg(j).eq.'1') ii1=j + if (creg(j).eq.'2') ii2=j + enddo + return + + entry mp_short_add(w,u,n,iv) + ireg=256*iv + do j=n,1,-1 + ireg=ichar(u(j))+ichar(creg(ii2)) + w(j+1)=creg(ii1) + enddo + w(1)=creg(ii2) + return + + entry mp_short_mult(w,u,n,iv) + ireg=0 + do j=n,1,-1 + ireg=ichar(u(j))*iv+ichar(creg(ii2)) + w(j+1)=creg(ii1) + enddo + w(1)=creg(ii2) + return + + entry mp_short_div(w,u,n,iv,ir) + ir=0 + do j=1,n + i=256*ir+ichar(u(j)) + w(j)=char(i/iv) + ir=mod(i,iv) + enddo + return + + return +end subroutine mp_short_ops + +subroutine add_call_to_recent_calls(callsign) + + character*13 callsign + logical ladd +! only add if the callsign is not already on the list + ladd=.true. + do i=1,MAXRECENT-1 ! if callsign is at the end of the list add it again + if(recent_calls(i).eq.callsign) ladd=.false. + enddo + + if(ladd) then + do i=MAXRECENT,2,-1 + recent_calls(i)=recent_calls(i-1) + enddo + recent_calls(1)=callsign + endif + +! Make sure that callsign is hashed + call save_hash_call(callsign,n10,n12,n22) + + return +end subroutine add_call_to_recent_calls + +end module packjt77 diff --git a/subtractft8.f90 b/subtractft8.f90 new file mode 100644 index 0000000..b68ff23 --- /dev/null +++ b/subtractft8.f90 @@ -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 + diff --git a/sync8.f90 b/sync8.f90 index 98efa31..7ad2322 100644 --- a/sync8.f90 +++ b/sync8.f90 @@ -17,7 +17,7 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase) integer indx(NFFT1) integer ii(1) 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) ! 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 enddo 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)) ib=nint(nfb/df) nssy=NSPS/NSTEP ! # steps per symbol nfos=NFFT1/NSPS ! # frequency bin oversampling factor jstrt=0.5/tstep + candidate0=0. + k=0 do i=ia,ib do j=-JZ,+JZ @@ -59,23 +56,22 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase) t0b=0. t0c=0. do n=0,6 - k=j+jstrt+nssy*n - if(k.ge.1.and.k.le.NHSYM) then - ta=ta + s(i+nfos*icos7(n),k) - t0a=t0a + sum(s(i:i+nfos*6:nfos,k)) + m=j+jstrt+nssy*n + if(m.ge.1.and.m.le.NHSYM) then + ta=ta + s(i+nfos*icos7(n),m) + t0a=t0a + sum(s(i:i+nfos*6:nfos,m)) endif - tb=tb + s(i+nfos*icos7(n),k+nssy*36) - t0b=t0b + sum(s(i:i+nfos*6:nfos,k+nssy*36)) - if(k+nssy*72.le.NHSYM) then - tc=tc + s(i+nfos*icos7(n),k+nssy*72) - t0c=t0c + sum(s(i:i+nfos*6:nfos,k+nssy*72)) + tb=tb + s(i+nfos*icos7(n),m+nssy*36) + t0b=t0b + sum(s(i:i+nfos*6:nfos,m+nssy*36)) + if(m+nssy*72.le.NHSYM) then + tc=tc + s(i+nfos*icos7(n),m+nssy*72) + t0c=t0c + sum(s(i:i+nfos*6:nfos,m+nssy*72)) endif enddo t=ta+tb+tc t0=t0a+t0b+t0c t0=(t0-t)/6.0 sync_abc=t/t0 - t=tb+tc t0=t0b+t0c t0=(t0-t)/6.0 @@ -90,8 +86,6 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase) j0=ii(1) jpeak(i)=j0 red(i)=sync2d(i,j0) -! write(52,3052) i*df,red(i),db(red(i)) -!3052 format(3f12.3) enddo iz=ib-ia+1 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) red=red/base - candidate0=0. - k=0 - do i=1,MAXCAND + do i=1,min(MAXCAND,iz) n=ia + indx(iz+1-i) - 1 if(red(n).lt.syncmin.or.isnan(red(n)).or.k.eq.MAXCAND) exit 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. endif enddo -! write(*,3001) i,candidate0(1,i-1),candidate0(1,i),candidate0(3,i-1), & -! candidate0(3,i) -!3001 format(i2,4f8.1) endif enddo @@ -143,9 +132,8 @@ subroutine sync8(dd,nfa,nfb,syncmin,nfqso,s,candidate,ncand,sbase) j=indx(i) ! if( candidate0(3,j) .ge. syncmin .and. candidate0(2,j).ge.-1.5 ) then if( candidate0(3,j) .ge. syncmin ) then + candidate(2:3,k)=candidate0(2:3,j) candidate(1,k)=abs(candidate0(1,j)) - candidate(2,k)=candidate0(2,j) - candidate(3,k)=candidate0(3,j) k=k+1 endif enddo diff --git a/sync8d.f90 b/sync8d.f90 index dc7bd20..42f661e 100644 --- a/sync8d.f90 +++ b/sync8d.f90 @@ -3,14 +3,14 @@ subroutine sync8d(cd0,i0,ctwk,itwk,sync) ! Compute sync power for a complex, downsampled FT8 signal. parameter(NP2=2812,NDOWN=20) - complex cd0(3125) + complex cd0(0:3199) complex csync(0:6,32) complex csync2(32) complex ctwk(32) complex z1,z2,z3 logical first 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./ save first,twopi,fs2,dt2,taus,baud,csync @@ -44,9 +44,9 @@ subroutine sync8d(cd0,i0,ctwk,itwk,sync) z1=0. z2=0. z3=0. - if(i1.ge.1 .and. i1+31.le.NP2) 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(i3.ge.1 .and. i3+31.le.NP2) z3=sum(cd0(i3:i3+31)*conjg(csync2)) + if(i1.ge.0 .and. i1+31.le.NP2-1) z1=sum(cd0(i1:i1+31)*conjg(csync2)) + if(i2.ge.0 .and. i2+31.le.NP2-1) z2=sum(cd0(i2:i2+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) enddo