remove signal subtraction and simplify output format

This commit is contained in:
Pavel Demin 2018-04-19 16:49:30 +02:00
parent fa4f5a12e2
commit 61ae08bf0c
20 changed files with 77 additions and 1980 deletions

View File

@ -1,12 +1,10 @@
TARGET = ft8d TARGET = ft8d
OBJECTS = \ OBJECTS = \
timer_module.o crc10.o crc12.o crc.o ft8_downsample.o sync8d.o sync8.o \ crc12.o crc.o ft8_downsample.o sync8d.o sync8.o four2a.o deg2grid.o \
grid2deg.o four2a.o deg2grid.o chkcrc12a.o determ.o fftw3mod.o \ chkcrc12a.o determ.o fftw3mod.o baseline.o bpdecode174.o packjt.o \
baseline.o bpdecode144.o geodist.o azdist.o fix_contest_msg.o \ extractmessage174.o indexx.o shell.o pctile.o polyfit.o twkfreq1.o \
to_contest_msg.o bpdecode174.o fmtmsg.o packjt.o extractmessage174.o \ osd174.o db.o ft8b.o ft8d.o
indexx.o shell.o pctile.o polyfit.o twkfreq1.o osd174.o encode174.o \
genft8.o genft8refsig.o subtractft8.o db.o ft8b.o ft8d.o
CC = gcc CC = gcc
FC = gfortran FC = gfortran

View File

@ -1,129 +0,0 @@
subroutine azdist(grid1,grid2,utch,nAz,nEl,nDmiles,nDkm,nHotAz,nHotABetter)
character*(*) grid1,grid2
character*6 MyGrid,HisGrid,mygrid0,hisgrid0
real*8 utch,utch0
logical HotABetter,IamEast
real eltab(22),daztab(22)
data eltab/18.,15.,13.,11.,9.,8.,7.,6.,5.3,4.7,4.,3.3,2.7, &
2.,1.5,1.,0.8,0.6,0.4,0.2,0.0,0.0/
data daztab/21.,18.,16.,15.,14.,13.,12.,11.,10.7,10.3,10., &
10.,10.,10.,10.,10.,10.,9.,9.,9.,8.,8./
data mygrid0/" "/,hisgrid0/" "/,utch0/-999.d0/
save
MyGrid=grid1//' '
HisGrid=grid2//' '
if(ichar(MyGrid(5:5)).eq.0) MyGrid(5:6)=' '
if(ichar(HisGrid(5:5)).eq.0) HisGrid(5:6)=' '
if(MyGrid.eq.HisGrid) then
naz=0
nel=0
ndmiles=0
ndkm=0
nhotaz=0
nhotabetter=1
go to 999
endif
if(mygrid.eq.mygrid0 .and. hisgrid.eq.hisgrid0 .and. &
abs(utch-utch0).lt.0.1666667d0) go to 900
utch0=utch
mygrid0=mygrid
hisgrid0=hisgrid
utchours=utch
if(MyGrid(5:5).eq.' ') MyGrid(5:5)='m'
if(MyGrid(6:6).eq.' ') MyGrid(6:6)='m'
if(HisGrid(5:5).eq.' ') HisGrid(5:5)='m'
if(HisGrid(6:6).eq.' ') HisGrid(6:6)='m'
if(MyGrid.eq.HisGrid) then
Az=0.
Dmiles=0.
Dkm=0.0
El=0.
HotA=0.
HotB=0.
HotABetter=.true.
go to 900
endif
call grid2deg(MyGrid,dlong1,dlat1)
call grid2deg(HisGrid,dlong2,dlat2)
eps=1.e-6
Az=0.
Dmiles=0.
Dkm=0.0
El=0.
HotA=0.
HotB=0.
HotABetter=.true.
if(abs(dlat1-dlat2).lt.eps .and. abs(dlong1-dlong2).lt.eps) go to 900
difflong=mod(dlong1-dlong2+720.0,360.0)
if(abs(dlat1+dlat2).lt.eps .and. abs(difflong-180.0).lt.eps) then
! Antipodes
Dkm=20400
go to 900
endif
call geodist(dlat1,dlong1,dlat2,dlong2,Az,Baz,Dkm)
ndkm=Dkm/100
j=ndkm-4
if(j.lt.1) j=1
if(j.gt.21)j=21
if(Dkm.lt.500.0) then
El=18.0
else
u=(Dkm-100.0*ndkm)/100.0
El=(1.0-u)*eltab(j) + u*eltab(j+1)
endif
daz=daztab(j) + u * (daztab(j+1)-daztab(j))
Dmiles=Dkm/1.609344
tmid=mod(UTChours-0.5*(dlong1+dlong2)/15.0+48.0,24.0)
IamEast=.false.
if(dlong1.lt.dlong2) IamEast=.true.
if(dlong1.eq.dlong2 .and. dlat1.gt.dlat2) IamEast=.false.
azEast=baz
if(IamEast) azEast=az
if((azEast.ge.45.0 .and. azEast.lt.135.0) .or. &
(azEast.ge.225.0 .and. azEast.lt.315.0)) then
! The path will be taken as "east-west".
HotABetter=.true.
if(abs(tmid-6.0).lt.6.0) HotABetter=.false.
if((dlat1+dlat2)/2.0 .lt. 0.0) HotABetter=.not.HotABetter
else
! The path will be taken as "north-south".
HotABetter=.false.
if(abs(tmid-12.0).lt.6.0) HotABetter=.true.
endif
if(IamEast) then
HotA = Az - daz
HotB = Az + daz
else
HotA = Az + daz
HotB = Az - daz
endif
if(HotA.lt.0.0) HotA=HotA+360.0
if(HotA.gt.360.0) HotA=HotA-360.0
if(HotB.lt.0.0) HotB=HotB+360.0
if(HotB.gt.360.0) HotB=HotB-360.0
900 continue
naz=nint(Az)
nel=nint(el)
nDmiles=nint(Dmiles)
nDkm=nint(Dkm)
nHotAz=nint(HotB)
nHotABetter=0
if(HotABetter) then
nHotAz=nint(HotA)
nHotABetter=1
endif
999 return
end subroutine azdist

View File

@ -1,348 +0,0 @@
subroutine pltanh(x,y)
isign=+1
z=x
if( x.lt.0 ) then
isign=-1
z=abs(x)
endif
if( z.le. 0.8 ) then
y=0.83*x
return
elseif( z.le. 1.6 ) then
y=isign*(0.322*z+0.4064)
return
elseif( z.le. 3.0 ) then
y=isign*(0.0524*z+0.8378)
return
elseif( z.lt. 7.0 ) then
y=isign*(0.0012*z+0.9914)
return
else
y=isign*0.9998
return
endif
end subroutine pltanh
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 bpdecode144(llr,maxiterations,decoded,niterations)
!
! A log-domain belief propagation decoder for the msk144 code.
! The code is a regular (128,80) code with column weight 3 and row weight 8.
! k9an August, 2016
!
integer, parameter:: N=128, K=80, M=N-K
integer*1 codeword(N),cw(N)
integer*1 colorder(N)
integer*1 decoded(K)
integer Nm(8,M) ! 8 bits per check
integer Mn(3,N) ! 3 checks per bit
integer synd(M)
real tov(3,N) ! single precision seems to be adequate in log-domain
real toc(8,M)
real tanhtoc(8,M)
real zn(N)
real llr(N)
real Tmn
data colorder/0,1,2,3,4,5,6,7,8,9, &
10,11,12,13,14,15,24,26,29,30, &
32,43,44,47,60,77,79,97,101,111, &
96,38,64,53,93,34,59,94,74,90, &
108,123,85,57,70,25,69,62,48,49, &
50,51,52,33,54,55,56,21,58,36, &
16,61,23,63,20,65,66,67,68,46, &
22,71,72,73,31,75,76,45,78,17, &
80,81,82,83,84,42,86,87,88,89, &
39,91,92,35,37,95,19,27,98,99, &
100,28,102,103,104,105,106,107,40,109, &
110,18,112,113,114,115,116,117,118,119, &
120,121,122,41,124,125,126,127/
data Mn/ &
1, 14, 38, &
2, 4, 41, &
3, 19, 39, &
5, 29, 34, &
6, 35, 40, &
7, 20, 45, &
8, 28, 48, &
9, 22, 25, &
10, 24, 36, &
11, 12, 37, &
13, 43, 44, &
15, 18, 46, &
16, 17, 47, &
21, 32, 33, &
23, 30, 31, &
26, 27, 42, &
1, 12, 46, &
2, 36, 38, &
3, 5, 10, &
4, 9, 23, &
6, 13, 39, &
7, 15, 17, &
8, 18, 27, &
11, 33, 40, &
14, 28, 44, &
16, 29, 31, &
19, 20, 22, &
21, 30, 42, &
24, 26, 47, &
25, 37, 48, &
32, 34, 45, &
8, 35, 41, &
12, 31, 43, &
1, 19, 21, &
2, 43, 45, &
3, 4, 11, &
5, 18, 33, &
6, 25, 47, &
7, 28, 30, &
9, 14, 34, &
10, 35, 42, &
13, 15, 22, &
16, 37, 38, &
17, 41, 44, &
20, 24, 29, &
18, 23, 39, &
12, 26, 32, &
27, 38, 40, &
15, 36, 48, &
2, 30, 46, &
1, 4, 13, &
3, 28, 32, &
5, 43, 47, &
6, 34, 46, &
7, 9, 40, &
8, 11, 45, &
10, 17, 23, &
14, 31, 35, &
16, 22, 42, &
19, 37, 44, &
20, 33, 48, &
21, 24, 41, &
25, 27, 29, &
26, 39, 48, &
19, 31, 36, &
1, 5, 7, &
2, 29, 39, &
3, 16, 46, &
4, 26, 37, &
6, 28, 45, &
8, 22, 33, &
9, 21, 43, &
10, 25, 38, &
11, 14, 24, &
12, 17, 40, &
13, 27, 30, &
15, 32, 35, &
18, 44, 47, &
20, 23, 36, &
34, 41, 42, &
1, 32, 48, &
2, 3, 33, &
4, 29, 42, &
5, 14, 37, &
6, 7, 36, &
8, 9, 39, &
10, 13, 19, &
11, 18, 30, &
12, 16, 20, &
15, 29, 44, &
17, 34, 38, &
6, 21, 22, &
23, 32, 40, &
24, 27, 46, &
25, 41, 45, &
7, 26, 43, &
28, 31, 47, &
20, 35, 38, &
1, 33, 41, &
2, 42, 44, &
3, 23, 48, &
4, 31, 45, &
5, 8, 30, &
9, 16, 36, &
10, 40, 47, &
11, 17, 46, &
12, 21, 34, &
13, 24, 28, &
14, 18, 43, &
15, 25, 26, &
19, 27, 35, &
22, 37, 39, &
1, 16, 18, &
2, 6, 20, &
3, 30, 43, &
4, 28, 33, &
5, 22, 23, &
7, 39, 42, &
8, 12, 38, &
9, 35, 46, &
10, 27, 32, &
11, 15, 34, &
13, 36, 37, &
14, 41, 47, &
17, 21, 25, &
19, 29, 45, &
24, 31, 48, &
26, 40, 44/
data Nm/ &
1, 17, 34, 51, 66, 81, 99, 113, &
2, 18, 35, 50, 67, 82, 100, 114, &
3, 19, 36, 52, 68, 82, 101, 115, &
2, 20, 36, 51, 69, 83, 102, 116, &
4, 19, 37, 53, 66, 84, 103, 117, &
5, 21, 38, 54, 70, 85, 92, 114, &
6, 22, 39, 55, 66, 85, 96, 118, &
7, 23, 32, 56, 71, 86, 103, 119, &
8, 20, 40, 55, 72, 86, 104, 120, &
9, 19, 41, 57, 73, 87, 105, 121, &
10, 24, 36, 56, 74, 88, 106, 122, &
10, 17, 33, 47, 75, 89, 107, 119, &
11, 21, 42, 51, 76, 87, 108, 123, &
1, 25, 40, 58, 74, 84, 109, 124, &
12, 22, 42, 49, 77, 90, 110, 122, &
13, 26, 43, 59, 68, 89, 104, 113, &
13, 22, 44, 57, 75, 91, 106, 125, &
12, 23, 37, 46, 78, 88, 109, 113, &
3, 27, 34, 60, 65, 87, 111, 126, &
6, 27, 45, 61, 79, 89, 98, 114, &
14, 28, 34, 62, 72, 92, 107, 125, &
8, 27, 42, 59, 71, 92, 112, 117, &
15, 20, 46, 57, 79, 93, 101, 117, &
9, 29, 45, 62, 74, 94, 108, 127, &
8, 30, 38, 63, 73, 95, 110, 125, &
16, 29, 47, 64, 69, 96, 110, 128, &
16, 23, 48, 63, 76, 94, 111, 121, &
7, 25, 39, 52, 70, 97, 108, 116, &
4, 26, 45, 63, 67, 83, 90, 126, &
15, 28, 39, 50, 76, 88, 103, 115, &
15, 26, 33, 58, 65, 97, 102, 127, &
14, 31, 47, 52, 77, 81, 93, 121, &
14, 24, 37, 61, 71, 82, 99, 116, &
4, 31, 40, 54, 80, 91, 107, 122, &
5, 32, 41, 58, 77, 98, 111, 120, &
9, 18, 49, 65, 79, 85, 104, 123, &
10, 30, 43, 60, 69, 84, 112, 123, &
1, 18, 43, 48, 73, 91, 98, 119, &
3, 21, 46, 64, 67, 86, 112, 118, &
5, 24, 48, 55, 75, 93, 105, 128, &
2, 32, 44, 62, 80, 95, 99, 124, &
16, 28, 41, 59, 80, 83, 100, 118, &
11, 33, 35, 53, 72, 96, 109, 115, &
11, 25, 44, 60, 78, 90, 100, 128, &
6, 31, 35, 56, 70, 95, 102, 126, &
12, 17, 50, 54, 68, 94, 106, 120, &
13, 29, 38, 53, 78, 97, 105, 124, &
7, 30, 49, 61, 64, 81, 101, 127/
nrw=8
ncw=3
toc=0
tov=0
tanhtoc=0
! initial messages to checks
do j=1,M
do i=1,nrw
toc(i,j)=llr((Nm(i,j)))
enddo
enddo
ncnt=0
do iter=0,maxiterations
! Update bit log likelihood ratios
do i=1,N
zn(i)=llr(i)+sum(tov(1:ncw,i))
enddo
! Check to see if we have a codeword
cw=0
where( zn .gt. 0. ) cw=1
ncheck=0
do i=1,M
synd(i)=sum(cw(Nm(:,i)))
if( mod(synd(i),2) .ne. 0 ) ncheck=ncheck+1
enddo
if( ncheck .eq. 0 ) then ! we have a codeword
niterations=iter
codeword=cw(colorder+1)
decoded=codeword(M+1:N)
return
endif
if( iter.gt.0 ) 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. 3 .and. iter .ge. 5 .and. ncheck .gt. 10) then
niterations=-1
return
endif
endif
nclast=ncheck
! Send messages from bits to check nodes
do j=1,M
do i=1,nrw
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 ! Mn(3,128)
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:nrw,i)=tanh(-toc(1:nrw,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(:,ichk),mask=Nm(:,ichk).ne.j)
call platanh(-Tmn,y)
tov(i,j)=2*y
enddo
enddo
enddo
niterations=-1
end subroutine bpdecode144

View File

@ -1,3 +1,28 @@
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) subroutine bpdecode174(llr,apmask,maxiterations,decoded,cw,nharderror,iter)
! !
! A log-domain belief propagation decoder for the (174,87) code. ! A log-domain belief propagation decoder for the (174,87) code.

59
crc10.c
View File

@ -1,59 +0,0 @@
#include <stdbool.h>
static unsigned short table[256] =
{
0x0000, 0x048f, 0x091e, 0x0d91, 0x123c, 0x16b3, 0x1b22, 0x1fad,
0x24f7, 0x2078, 0x2de9, 0x2966, 0x36cb, 0x3244, 0x3fd5, 0x3b5a,
0x49ee, 0x4d61, 0x40f0, 0x447f, 0x5bd2, 0x5f5d, 0x52cc, 0x5643,
0x6d19, 0x6996, 0x6407, 0x6088, 0x7f25, 0x7baa, 0x763b, 0x72b4,
0x93dc, 0x9753, 0x9ac2, 0x9e4d, 0x81e0, 0x856f, 0x88fe, 0x8c71,
0xb72b, 0xb3a4, 0xbe35, 0xbaba, 0xa517, 0xa198, 0xac09, 0xa886,
0xda32, 0xdebd, 0xd32c, 0xd7a3, 0xc80e, 0xcc81, 0xc110, 0xc59f,
0xfec5, 0xfa4a, 0xf7db, 0xf354, 0xecf9, 0xe876, 0xe5e7, 0xe168,
0x2737, 0x23b8, 0x2e29, 0x2aa6, 0x350b, 0x3184, 0x3c15, 0x389a,
0x03c0, 0x074f, 0x0ade, 0x0e51, 0x11fc, 0x1573, 0x18e2, 0x1c6d,
0x6ed9, 0x6a56, 0x67c7, 0x6348, 0x7ce5, 0x786a, 0x75fb, 0x7174,
0x4a2e, 0x4ea1, 0x4330, 0x47bf, 0x5812, 0x5c9d, 0x510c, 0x5583,
0xb4eb, 0xb064, 0xbdf5, 0xb97a, 0xa6d7, 0xa258, 0xafc9, 0xab46,
0x901c, 0x9493, 0x9902, 0x9d8d, 0x8220, 0x86af, 0x8b3e, 0x8fb1,
0xfd05, 0xf98a, 0xf41b, 0xf094, 0xef39, 0xebb6, 0xe627, 0xe2a8,
0xd9f2, 0xdd7d, 0xd0ec, 0xd463, 0xcbce, 0xcf41, 0xc2d0, 0xc65f,
0x4ee1, 0x4a6e, 0x47ff, 0x4370, 0x5cdd, 0x5852, 0x55c3, 0x514c,
0x6a16, 0x6e99, 0x6308, 0x6787, 0x782a, 0x7ca5, 0x7134, 0x75bb,
0x070f, 0x0380, 0x0e11, 0x0a9e, 0x1533, 0x11bc, 0x1c2d, 0x18a2,
0x23f8, 0x2777, 0x2ae6, 0x2e69, 0x31c4, 0x354b, 0x38da, 0x3c55,
0xdd3d, 0xd9b2, 0xd423, 0xd0ac, 0xcf01, 0xcb8e, 0xc61f, 0xc290,
0xf9ca, 0xfd45, 0xf0d4, 0xf45b, 0xebf6, 0xef79, 0xe2e8, 0xe667,
0x94d3, 0x905c, 0x9dcd, 0x9942, 0x86ef, 0x8260, 0x8ff1, 0x8b7e,
0xb024, 0xb4ab, 0xb93a, 0xbdb5, 0xa218, 0xa697, 0xab06, 0xaf89,
0x69d6, 0x6d59, 0x60c8, 0x6447, 0x7bea, 0x7f65, 0x72f4, 0x767b,
0x4d21, 0x49ae, 0x443f, 0x40b0, 0x5f1d, 0x5b92, 0x5603, 0x528c,
0x2038, 0x24b7, 0x2926, 0x2da9, 0x3204, 0x368b, 0x3b1a, 0x3f95,
0x04cf, 0x0040, 0x0dd1, 0x095e, 0x16f3, 0x127c, 0x1fed, 0x1b62,
0xfa0a, 0xfe85, 0xf314, 0xf79b, 0xe836, 0xecb9, 0xe128, 0xe5a7,
0xdefd, 0xda72, 0xd7e3, 0xd36c, 0xccc1, 0xc84e, 0xc5df, 0xc150,
0xb3e4, 0xb76b, 0xbafa, 0xbe75, 0xa1d8, 0xa557, 0xa8c6, 0xac49,
0x9713, 0x939c, 0x9e0d, 0x9a82, 0x852f, 0x81a0, 0x8c31, 0x88be
};
short crc10(unsigned char const *data, int length)
{
unsigned short remainder = 0;
unsigned char index;
int i;
for(i = 0; i < length; ++i)
{
index = remainder >> 2;
remainder <<= 8;
remainder |= data[i];
remainder ^= table[index];
}
return remainder & 0x03ff;
}
bool crc10_check(unsigned char const *data, int length)
{
return !crc10(data, length);
}

View File

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

View File

@ -1,13 +1,14 @@
subroutine extractmessage174(decoded,msgreceived,ncrcflag) subroutine extractmessage174(decoded,lhasgrid,msgcall,msggrid,ncrcflag)
use iso_c_binding, only: c_loc,c_size_t use iso_c_binding, only: c_loc,c_size_t
use crc use crc
use packjt use packjt
character*22 msgreceived character msgcall*12, msggrid*4
character*87 cbits character*87 cbits
integer*1 decoded(87) integer*1 decoded(87)
integer*1, target:: i1Dec8BitBytes(11) integer*1, target:: i1Dec8BitBytes(11)
integer*4 i4Dec6BitWords(12) integer*4 i4Dec6BitWords(12)
logical lhasgrid
! Write decoded bits into cbits: 75-bit message plus 12-bit CRC ! Write decoded bits into cbits: 75-bit message plus 12-bit CRC
write(cbits,1000) decoded write(cbits,1000) decoded
@ -30,10 +31,11 @@ subroutine extractmessage174(decoded,msgreceived,ncrcflag)
enddo enddo
i4Dec6BitWords(ibyte)=itmp i4Dec6BitWords(ibyte)=itmp
enddo enddo
call unpackmsg(i4Dec6BitWords,msgreceived,.false.,' ') call unpackmsg(i4Dec6BitWords,lhasgrid,msgcall,msggrid)
ncrcflag=1 ncrcflag=1
else else
msgreceived=' ' msgcall=' '
msggrid=' '
ncrcflag=-1 ncrcflag=-1
endif endif
return return

View File

@ -1,32 +0,0 @@
subroutine fix_contest_msg(mygrid,msg)
! If distance from mygrid to grid1 is more thsn 10000 km, change "grid1"
! to "R grid2" where grid2 is the antipodes of grid1.
character*6 mygrid
character*22 msg
character*6 g1,g2
logical isgrid
isgrid(g1)=g1(1:1).ge.'A' .and. g1(1:1).le.'R' .and. g1(2:2).ge.'A' .and. &
g1(2:2).le.'R' .and. g1(3:3).ge.'0' .and. g1(3:3).le.'9' .and. &
g1(4:4).ge.'0' .and. g1(4:4).le.'9' .and. g1(1:4).ne.'RR73'
n=len(trim(msg))
if(n.lt.4) return
g1=msg(n-3:n)//' '
if(isgrid(g1)) then
call azdist(mygrid,g1,0.d0,nAz,nEl,nDmiles,nDkm,nHotAz,nHotABetter)
if(ndkm.gt.10000) then
call grid2deg(g1,dlong,dlat)
dlong=dlong+180.0
if(dlong.gt.180.0) dlong=dlong-360.0
dlat=-dlat
call deg2grid(dlong,dlat,g2)
msg=msg(1:n-4)//'R '//g2(1:4)
endif
endif
return
end subroutine fix_contest_msg

View File

@ -1,21 +0,0 @@
subroutine fmtmsg(msg,iz)
character*22 msg
! Convert all letters to upper case
iz=22
do i=1,22
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
ib2=index(msg(1:iz),' ')
if(ib2.lt.1) go to 100
msg=msg(1:ib2)//msg(ib2+2:)
iz=iz-1
enddo
100 return
end subroutine fmtmsg

View File

@ -1,25 +1,18 @@
subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
napwid,lsubtract,nagain,iaptype,mycall12,mygrid6,hiscall12,bcontest, & napwid,nagain,iaptype,f1,xdt,xbase,apsym,nharderrors,dmin, &
sync0,f1,xdt,xbase,apsym,nharderrors,dmin,nbadcrc,ipass,iera,msg37,xsnr) nbadcrc,ipass,lhasgrid,msgcall,msggrid,xsnr)
use crc use crc
use timer_module, only: timer
include 'ft8_params.f90' include 'ft8_params.f90'
parameter(NP2=2812) parameter(NP2=2812)
character*37 msg37 character msgcall*12,msggrid*4,message*22
character message*22,msgsent*22
character*12 mycall12,hiscall12
character*6 mycall6,mygrid6,hiscall6,c1,c2
character*87 cbits
logical bcontest
real a(5) real a(5)
real s1(0:7,ND),s2(0:7,NN),s1sort(8*ND) real s1(0:7,ND),s2(0:7,NN),s1sort(8*ND)
real ps(0:7),psl(0:7) real ps(0:7),psl(0:7)
real bmeta(3*ND),bmetb(3*ND),bmetap(3*ND) 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 llr(3*ND),llra(3*ND),llr0(3*ND),llr1(3*ND),llrap(3*ND) !Soft symbols
complex dd0(NMAX) complex dd0(NMAX)
integer*1 decoded(KK),decoded0(KK),apmask(3*ND),cw(3*ND) integer*1 decoded(KK),apmask(3*ND),cw(3*ND)
integer*1 msgbits(KK)
integer apsym(KK) integer apsym(KK)
integer mcq(28),mde(28),mrrr(16),m73(16),mrr73(16) integer mcq(28),mde(28),mrrr(16),m73(16),mrr73(16)
integer itone(NN) integer itone(NN)
@ -27,11 +20,10 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
integer icos7(0:6),ip(1) integer icos7(0:6),ip(1)
integer nappasses(0:5) !Number of decoding passes to use for each QSO state integer nappasses(0:5) !Number of decoding passes to use for each QSO state
integer naptypes(0:5,4) ! (nQSOProgress, decoding pass) maximum of 4 passes for now integer naptypes(0:5,4) ! (nQSOProgress, decoding pass) maximum of 4 passes for now
integer*1, target:: i1hiscall(12)
complex cd0(3200) complex cd0(3200)
complex ctwk(32) complex ctwk(32)
complex csymb(32) complex csymb(32)
logical first,newdat,lsubtract,lapon,lapcqonly,nagain logical first,newdat,lapon,lapcqonly,nagain,lhasgrid
equivalence (s1,s1sort) equivalence (s1,s1sort)
data icos7/2,5,6,0,4,1,3/ 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 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/
@ -82,9 +74,7 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
delfbest=0. delfbest=0.
ibest=0 ibest=0
call timer('ft8_down',0)
call ft8_downsample(dd0,newdat,f1,cd0) !Mix f1 to baseband and downsample call ft8_downsample(dd0,newdat,f1,cd0) !Mix f1 to baseband and downsample
call timer('ft8_down',1)
i0=nint((xdt+0.5)*fs2) !Initial guess for start of signal i0=nint((xdt+0.5)*fs2) !Initial guess for start of signal
smax=0.0 smax=0.0
@ -340,10 +330,8 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
endif endif
cw=0 cw=0
call timer('bpd174 ',0)
call bpdecode174(llrap,apmask,max_iterations,decoded,cw,nharderrors, & call bpdecode174(llrap,apmask,max_iterations,decoded,cw,nharderrors, &
niterations) niterations)
call timer('bpd174 ',1)
dmin=0.0 dmin=0.0
if(ndepth.eq.3 .and. nharderrors.lt.0) then if(ndepth.eq.3 .and. nharderrors.lt.0) then
ndeep=3 ndeep=3
@ -355,9 +343,7 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
endif endif
endif endif
if(nagain) ndeep=5 if(nagain) ndeep=5
call timer('osd174 ',0)
call osd174(llrap,apmask,ndeep,decoded,cw,nharderrors,dmin) call osd174(llrap,apmask,ndeep,decoded,cw,nharderrors,dmin)
call timer('osd174 ',1)
endif endif
nbadcrc=1 nbadcrc=1
message=' ' message=' '
@ -373,16 +359,8 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
nharderrors=-1 nharderrors=-1
cycle cycle
endif endif
i3bit=4*decoded(73) + 2*decoded(74) + decoded(75)
iFreeText=decoded(57)
if(nbadcrc.eq.0) then if(nbadcrc.eq.0) then
decoded0=decoded call extractmessage174(decoded,lhasgrid,msgcall,msggrid,ncrcflag)
if(i3bit.eq.1) decoded(57:)=0
call extractmessage174(decoded,message,ncrcflag)
decoded=decoded0
! This needs fixing for messages with i3bit=1:
call genft8(message,mygrid6,bcontest,i3bit,msgsent,msgbits,itone)
if(lsubtract) call subtractft8(dd0,itone,f1,xdt2)
xsig=0.0 xsig=0.0
xnoi=0.0 xnoi=0.0
do i=1,79 do i=1,79
@ -396,42 +374,6 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
xsnr2=db(xsig/xbase - 1.0) - 32.0 xsnr2=db(xsig/xbase - 1.0) - 32.0
if(.not.nagain) xsnr=xsnr2 if(.not.nagain) xsnr=xsnr2
if(xsnr .lt. -24.0) xsnr=-24.0 if(xsnr .lt. -24.0) xsnr=-24.0
if(i3bit.eq.1) then
do i=1,12
i1hiscall(i)=ichar(hiscall12(i:i))
enddo
icrc10=crc10(c_loc(i1hiscall),12)
write(cbits,1001) decoded
1001 format(87i1)
read(cbits,1002) ncrc10,nrpt
1002 format(56x,b10,b6)
irpt=nrpt-30
i1=index(message,' ')
i2=index(message(i1+1:),' ') + i1
c1=message(1:i1)//' '
c2=message(i1+1:i2)//' '
if(ncrc10.eq.icrc10) msg37=c1//' RR73; '//c2//' <'// &
trim(hiscall12)//'> '
if(ncrc10.ne.icrc10) msg37=c1//' RR73; '//c2//' <...> '
! msg37=c1//' RR73; '//c2//' <...> '
write(msg37(35:37),1010) irpt
1010 format(i3.2)
if(msg37(35:35).ne.'-') msg37(35:35)='+'
iz=len(trim(msg37))
do iter=1,10 !Collapse multiple blanks
ib2=index(msg37(1:iz),' ')
if(ib2.lt.1) exit
msg37=msg37(1:ib2)//msg37(ib2+2:)
iz=iz-1
enddo
else
msg37=message//' '
endif
return return
endif endif
enddo enddo

View File

@ -4,17 +4,14 @@ program ft8d
include 'ft8_params.f90' include 'ft8_params.f90'
character infile*80,datetime*13,message*22,msg37*37 character infile*80,datetime*13,message*22,msg37*37
character*22 allmessages(100) character msgcall*12, msggrid*4
character*12 mycall12,hiscall12
character*6 mygrid6,hisgrid6
real s(NFFT1,NHSYM) real s(NFFT1,NHSYM)
real sbase(NFFT1) real sbase(NFFT1)
real candidate(3,200) real candidate(3,200)
real*8 dialfreq real*8 dialfreq
complex dd(NMAX,4) complex dd(NMAX,4)
logical newdat,lsubtract,ldupe,bcontest logical newdat,lhasgrid
integer apsym(KK) integer apsym(KK)
integer allsnrs(100)
nargs=iargc() nargs=iargc()
if(nargs.ne.1) then if(nargs.ne.1) then
@ -42,59 +39,29 @@ program ft8d
datetime=infile(j2-13:j2-1) datetime=infile(j2-13:j2-1)
do ipart=1,4 do ipart=1,4
ndecodes=0 ndecodes=0
allmessages=' '
allsnrs=0
ndepth=1 ndepth=1
npass=1 newdat=.true.
do ipass=1,npass syncmin=1.5
newdat=.true. call sync8(dd(1:NMAX,ipart),nfa+2000,nfb+2000,syncmin, &
syncmin=1.5 nfqso+2000,s,candidate,ncand,sbase)
if(ipass.eq.1) then do icand=1,ncand
lsubtract=.true. sync=candidate(3,icand)
if(ndepth.eq.1) lsubtract=.false. f1=candidate(1,icand)
elseif(ipass.eq.2) then xdt=candidate(2,icand)
n2=ndecodes xbase=10.0**(0.1*(sbase(nint(f1/3.125))-40.0))
if(ndecodes.eq.0) cycle call ft8b(dd(1:NMAX,ipart),newdat,nQSOProgress,nfqso+2000, &
lsubtract=.true. nftx,ndepth,lft8apon,lapcqonly,napwid,nagain,iaptype, &
elseif(ipass.eq.3) then f1,xdt,xbase,apsym,nharderrors,dmin,nbadcrc,iappass, &
if((ndecodes-n2).eq.0) cycle lhasgrid,msgcall,msggrid,xsnr)
lsubtract=.false. message=msg37(1:22)
nsnr=nint(xsnr)
xdt=xdt-0.5
hd=nharderrors+dmin
if(nbadcrc.eq.0 .and. lhasgrid) then
write(*,1004) nutc+15*(ipart-1),min(sync,999.0),nint(xsnr), &
xdt,nint(f1-2000+dialfreq),msggrid,msgcall
1004 format(i6.6,f6.1,i4,f6.2,i9,1x,a4,1x,a12)
endif endif
call sync8(dd(1:NMAX,ipart),nfa+2000,nfb+2000,syncmin, &
nfqso+2000,s,candidate,ncand,sbase)
do icand=1,ncand
sync=candidate(3,icand)
f1=candidate(1,icand)
xdt=candidate(2,icand)
xbase=10.0**(0.1*(sbase(nint(f1/3.125))-40.0))
call ft8b(dd(1:NMAX,ipart),newdat,nQSOProgress,nfqso+2000, &
nftx,ndepth,lft8apon, lapcqonly,napwid,lsubtract,nagain, &
iaptype,mycall12,mygrid6,hiscall12,bcontest,sync,f1,xdt, &
xbase,apsym,nharderrors,dmin,nbadcrc,iappass,iera,msg37,xsnr)
message=msg37(1:22)
nsnr=nint(xsnr)
xdt=xdt-0.5
hd=nharderrors+dmin
if(nbadcrc.eq.0) then
if(bcontest) then
call fix_contest_msg(mygrid6,message)
msg37(1:22)=message
endif
ldupe=.false.
do id=1,ndecodes
if(message.eq.allmessages(id).and.nsnr.le.allsnrs(id)) ldupe=.true.
enddo
if(.not.ldupe) then
ndecodes=ndecodes+1
allmessages(ndecodes)=message
allsnrs(ndecodes)=nsnr
endif
write(*,1004) nutc+15*(ipart-1),ipass,iaptype,iappass, &
nharderrors,dmin,hd,min(sync,999.0),nint(xsnr), &
xdt,nint(f1-2000+dialfreq),message
1004 format(i6.6,3i2,i3,3f6.1,i4,f6.2,i9,1x,a22)
endif
enddo
enddo enddo
enddo ! ipart loop enddo ! ipart loop

View File

@ -1,56 +0,0 @@
subroutine genft8(msg,mygrid,bcontest,i3bit,msgsent,msgbits,itone)
! Encode an FT8 message, producing array itone().
use crc
use packjt
include 'ft8_params.f90'
character*22 msg,msgsent
character*6 mygrid
character*87 cbits
logical bcontest,checksumok
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)
integer icos7(0:6)
data icos7/2,5,6,0,4,1,3/ !Costas 7x7 tone pattern
call packmsg(msg,i4Msg6BitWords,itype,bcontest) !Pack into 12 6-bit bytes
call unpackmsg(i4Msg6BitWords,msgsent,bcontest,mygrid) !Unpack to get msgsent
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)
! For reference, here's how to check the CRC
! i1Msg8BitBytes(10)=icrc12/256
! i1Msg8BitBytes(11)=iand (icrc12,255)
! checksumok = crc12_check(c_loc (i1Msg8BitBytes), 11)
! if( checksumok ) write(*,*) 'Good checksum'
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
! Message structure: S7 D29 S7 D29 S7
itone(1:7)=icos7
itone(36+1:36+7)=icos7
itone(NN-6:NN)=icos7
k=7
do j=1,ND
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)
enddo
return
end subroutine genft8

View File

@ -1,22 +0,0 @@
subroutine genft8refsig(itone,cref,f0)
complex cref(79*640)
integer itone(79)
real*8 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

View File

@ -1,105 +0,0 @@
subroutine geodist(Eplat,Eplon,Stlat,Stlon,Az,Baz,Dist)
implicit none
real eplat, eplon, stlat, stlon, az, baz, dist
! JHT: In actual fact, I use the first two arguments for "My Location",
! the second two for "His location"; West longitude is positive.
! Taken directly from:
! Thomas, P.D., 1970, Spheroidal geodesics, reference systems,
! & local geometry, U.S. Naval Oceanographi!Office SP-138,
! 165 pp.
! assumes North Latitude and East Longitude are positive
! EpLat, EpLon = End point Lat/Long
! Stlat, Stlon = Start point lat/long
! Az, BAz = direct & reverse azimuith
! Dist = Dist (km); Deg = central angle, discarded
real BOA, F, P1R, P2R, L1R, L2R, DLR, T1R, T2R, TM, &
DTM, STM, CTM, SDTM,CDTM, KL, KK, SDLMR, L, &
CD, DL, SD, T, U, V, D, X, E, Y, A, FF64, TDLPM, &
HAPBR, HAMBR, A1M2, A2M1
real AL,BL,D2R,Pi2
data AL/6378206.4/ ! Clarke 1866 ellipsoid
data BL/6356583.8/
! real pi /3.14159265359/
data D2R/0.01745329251994/ ! degrees to radians conversion factor
data Pi2/6.28318530718/
if(abs(Eplat-Stlat).lt.0.02 .and. abs(Eplon-Stlon).lt.0.02) then
Az=0.
Baz=180.0
Dist=0
go to 999
endif
BOA = BL/AL
F = 1.0 - BOA
! Convert st/end pts to radians
P1R = Eplat * D2R
P2R = Stlat * D2R
L1R = Eplon * D2R
L2R = StLon * D2R
DLR = L2R - L1R ! DLR = Delta Long in Rads
T1R = ATan(BOA * Tan(P1R))
T2R = ATan(BOA * Tan(P2R))
TM = (T1R + T2R) / 2.0
DTM = (T2R - T1R) / 2.0
STM = Sin(TM)
CTM = Cos(TM)
SDTM = Sin(DTM)
CDTM = Cos(DTM)
KL = STM * CDTM
KK = SDTM * CTM
SDLMR = Sin(DLR/2.0)
L = SDTM * SDTM + SDLMR * SDLMR * (CDTM * CDTM - STM * STM)
CD = 1.0 - 2.0 * L
DL = ACos(CD)
SD = Sin(DL)
T = DL/SD
U = 2.0 * KL * KL / (1.0 - L)
V = 2.0 * KK * KK / L
D = 4.0 * T * T
X = U + V
E = -2.0 * CD
Y = U - V
A = -D * E
FF64 = F * F / 64.0
Dist = AL*SD*(T -(F/4.0)*(T*X-Y)+FF64*(X*(A+(T-(A+E) &
/2.0)*X)+Y*(-2.0*D+E*Y)+D*X*Y))/1000.0
TDLPM = Tan((DLR+(-((E*(4.0-X)+2.0*Y)*((F/2.0)*T+FF64* &
(32.0*T+(A-20.0*T)*X-2.0*(D+2.0)*Y))/4.0)*Tan(DLR)))/2.0)
HAPBR = ATan2(SDTM,(CTM*TDLPM))
HAMBR = Atan2(CDTM,(STM*TDLPM))
A1M2 = Pi2 + HAMBR - HAPBR
A2M1 = Pi2 - HAMBR - HAPBR
1 If ((A1M2 .ge. 0.0) .AND. (A1M2 .lt. Pi2)) GOTO 5
If (A1M2 .lt. Pi2) GOTO 4
A1M2 = A1M2 - Pi2
GOTO 1
4 A1M2 = A1M2 + Pi2
GOTO 1
! All of this gens the proper az, baz (forward and back azimuth)
5 If ((A2M1 .ge. 0.0) .AND. (A2M1 .lt. Pi2)) GOTO 9
If (A2M1 .lt. Pi2) GOTO 8
A2M1 = A2M1 - Pi2
GOTO 5
8 A2M1 = A2M1 + Pi2
GOTO 5
9 Az = A1M2 / D2R
BAZ = A2M1 / D2R
!Fix the mirrored coords here.
az = 360.0 - az
baz = 360.0 - baz
999 return
end subroutine geodist

View File

@ -1,38 +0,0 @@
subroutine grid2deg(grid0,dlong,dlat)
! Converts Maidenhead grid locator to degrees of West longitude
! and North latitude.
character*6 grid0,grid
character*1 g1,g2,g3,g4,g5,g6
grid=grid0
i=ichar(grid(5:5))
if(grid(5:5).eq.' ' .or. i.le.64 .or. i.ge.128) grid(5:6)='mm'
if(grid(1:1).ge.'a' .and. grid(1:1).le.'z') grid(1:1)= &
char(ichar(grid(1:1))+ichar('A')-ichar('a'))
if(grid(2:2).ge.'a' .and. grid(2:2).le.'z') grid(2:2)= &
char(ichar(grid(2:2))+ichar('A')-ichar('a'))
if(grid(5:5).ge.'A' .and. grid(5:5).le.'Z') grid(5:5)= &
char(ichar(grid(5:5))-ichar('A')+ichar('a'))
if(grid(6:6).ge.'A' .and. grid(6:6).le.'Z') grid(6:6)= &
char(ichar(grid(6:6))-ichar('A')+ichar('a'))
g1=grid(1:1)
g2=grid(2:2)
g3=grid(3:3)
g4=grid(4:4)
g5=grid(5:5)
g6=grid(6:6)
nlong = 180 - 20*(ichar(g1)-ichar('A'))
n20d = 2*(ichar(g3)-ichar('0'))
xminlong = 5*(ichar(g5)-ichar('a')+0.5)
dlong = nlong - n20d - xminlong/60.0
nlat = -90+10*(ichar(g2)-ichar('A')) + ichar(g4)-ichar('0')
xminlat = 2.5*(ichar(g6)-ichar('a')+0.5)
dlat = nlat + xminlat/60.0
return
end subroutine grid2deg

View File

@ -6,28 +6,6 @@ module packjt
contains contains
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) subroutine unpackbits(sym,nsymd,m0,dbits)
! Unpack bits from sym() into dbits(), one bit per byte. ! Unpack bits from sym() into dbits(), one bit per byte.
@ -51,90 +29,6 @@ subroutine packbits(dbits,nsymd,m0,sym)
return return
end subroutine unpackbits end subroutine unpackbits
subroutine packcall(callsign,ncall,text)
! Pack a valid callsign into a 28-bit integer.
parameter (NBASE=37*36*10*27*27*27)
character callsign*6,c*1,tmp*6
logical text
text=.false.
! Work-around for Swaziland prefix:
if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6)
! Work-around for Guinea prefixes:
if(callsign(1:2).eq.'3X' .and. callsign(3:3).ge.'A' .and. &
callsign(3:3).le.'Z') callsign='Q'//callsign(3:6)
if(callsign(1:3).eq.'CQ ') then
ncall=NBASE + 1
if(callsign(4:4).ge.'0' .and. callsign(4:4).le.'9' .and. &
callsign(5:5).ge.'0' .and. callsign(5:5).le.'9' .and. &
callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then
read(callsign(4:6),*) nfreq
ncall=NBASE + 3 + nfreq
endif
return
else if(callsign(1:4).eq.'QRZ ') then
ncall=NBASE + 2
return
else if(callsign(1:3).eq.'DE ') then
ncall=267796945
return
endif
tmp=' '
if(callsign(3:3).ge.'0' .and. callsign(3:3).le.'9') then
tmp=callsign
else if(callsign(2:2).ge.'0' .and. callsign(2:2).le.'9') then
if(callsign(6:6).ne.' ') then
text=.true.
return
endif
tmp=' '//callsign(:5)
else
text=.true.
return
endif
do i=1,6
c=tmp(i:i)
if(c.ge.'a' .and. c.le.'z') &
tmp(i:i)=char(ichar(c)-ichar('a')+ichar('A'))
enddo
n1=0
if((tmp(1:1).ge.'A'.and.tmp(1:1).le.'Z').or.tmp(1:1).eq.' ') n1=1
if(tmp(1:1).ge.'0' .and. tmp(1:1).le.'9') n1=1
n2=0
if(tmp(2:2).ge.'A' .and. tmp(2:2).le.'Z') n2=1
if(tmp(2:2).ge.'0' .and. tmp(2:2).le.'9') n2=1
n3=0
if(tmp(3:3).ge.'0' .and. tmp(3:3).le.'9') n3=1
n4=0
if((tmp(4:4).ge.'A'.and.tmp(4:4).le.'Z').or.tmp(4:4).eq.' ') n4=1
n5=0
if((tmp(5:5).ge.'A'.and.tmp(5:5).le.'Z').or.tmp(5:5).eq.' ') n5=1
n6=0
if((tmp(6:6).ge.'A'.and.tmp(6:6).le.'Z').or.tmp(6:6).eq.' ') n6=1
if(n1+n2+n3+n4+n5+n6 .ne. 6) then
text=.true.
return
endif
ncall=nchar(tmp(1:1))
ncall=36*ncall+nchar(tmp(2:2))
ncall=10*ncall+nchar(tmp(3:3))
ncall=27*ncall+nchar(tmp(4:4))-10
ncall=27*ncall+nchar(tmp(5:5))-10
ncall=27*ncall+nchar(tmp(6:6))-10
return
end subroutine packcall
subroutine unpackcall(ncall,word,iv2,psfx) subroutine unpackcall(ncall,word,iv2,psfx)
parameter (NBASE=37*36*10*27*27*27) parameter (NBASE=37*36*10*27*27*27)
@ -276,277 +170,14 @@ subroutine packbits(dbits,nsymd,m0,sym)
return return
end subroutine unpackcall end subroutine unpackcall
subroutine packgrid(grid,ng,text) subroutine unpackmsg(dat,lhasgrid,msgcall,msggrid)
parameter (NGBASE=180*180)
character*4 grid
character*1 c1
logical text
text=.false.
if(grid.eq.' ') go to 90 !Blank grid is OK
! First, handle signal reports in the original range, -01 to -30 dB
if(grid(1:1).eq.'-') then
read(grid(2:3),*,err=800,end=800) n
if(n.ge.1 .and. n.le.30) then
ng=NGBASE+1+n
go to 900
endif
go to 10
else if(grid(1:2).eq.'R-') then
read(grid(3:4),*,err=800,end=800) n
if(n.ge.1 .and. n.le.30) then
ng=NGBASE+31+n
go to 900
endif
go to 10
! Now check for RO, RRR, or 73 in the message field normally used for grid
else if(grid(1:4).eq.'RO ') then
ng=NGBASE+62
go to 900
else if(grid(1:4).eq.'RRR ') then
ng=NGBASE+63
go to 900
else if(grid(1:4).eq.'73 ') then
ng=NGBASE+64
go to 900
endif
! Now check for extended-range signal reports: -50 to -31, and 0 to +49.
10 n=99
c1=grid(1:1)
read(grid,*,err=20,end=20) n
go to 30
20 read(grid(2:4),*,err=30,end=30) n
30 if(n.ge.-50 .and. n.le.49) then
if(c1.eq.'R') then
write(grid,1002) n+50
1002 format('LA',i2.2)
else
write(grid,1003) n+50
1003 format('KA',i2.2)
endif
go to 40
endif
! Maybe it's free text ?
if(grid(1:1).lt.'A' .or. grid(1:1).gt.'R') text=.true.
if(grid(2:2).lt.'A' .or. grid(2:2).gt.'R') text=.true.
if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true.
if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true.
if(text) go to 900
! OK, we have a properly formatted grid locator
40 call grid2deg(grid//'mm',dlong,dlat)
long=int(dlong)
lat=int(dlat+ 90.0)
ng=((long+180)/2)*180 + lat
go to 900
90 ng=NGBASE + 1
go to 900
800 text=.true.
900 continue
return
end subroutine packgrid
subroutine unpackgrid(ng,grid)
parameter (NGBASE=180*180)
character grid*4,grid6*6
grid=' '
if(ng.ge.32400) go to 10
dlat=mod(ng,180)-90
dlong=(ng/180)*2 - 180 + 2
call deg2grid(dlong,dlat,grid6)
grid=grid6(:4)
if(grid(1:2).eq.'KA') then
read(grid(3:4),*) n
n=n-50
write(grid,1001) n
1001 format(i3.2)
if(grid(1:1).eq.' ') grid(1:1)='+'
else if(grid(1:2).eq.'LA') then
read(grid(3:4),*) n
n=n-50
write(grid,1002) n
1002 format('R',i3.2)
if(grid(2:2).eq.' ') grid(2:2)='+'
endif
go to 900
10 n=ng-NGBASE-1
if(n.ge.1 .and.n.le.30) then
write(grid,1012) -n
1012 format(i3.2)
else if(n.ge.31 .and.n.le.60) then
n=n-30
write(grid,1022) -n
1022 format('R',i3.2)
else if(n.eq.61) then
grid='RO'
else if(n.eq.62) then
grid='RRR'
else if(n.eq.63) then
grid='73'
endif
900 return
end subroutine unpackgrid
subroutine packmsg(msg0,dat,itype,bcontest)
! Packs a JT4/JT9/JT65 message into twelve 6-bit symbols
! itype Message Type
!--------------------
! 1 Standardd message
! 2 Type 1 prefix
! 3 Type 1 suffix
! 4 Type 2 prefix
! 5 Type 2 suffix
! 6 Free text
! -1 Does not decode correctly
parameter (NBASE=37*36*10*27*27*27)
parameter (NBASE2=262178562)
character*22 msg0,msg
integer dat(:)
character*12 c1,c2
character*4 c3
character*6 grid6
logical text1,text2,text3,bcontest
itype=1
if(bcontest) then
call to_contest_msg(msg0,msg)
else
msg=msg0
end if
call fmtmsg(msg,iz)
if(msg(1:3).eq.'CQ ' .and. msg(4:4).ge.'0' .and. msg(4:4).le.'9' &
.and. msg(5:5).eq.' ') msg='CQ 00'//msg(4:)
if(msg(1:6).eq.'CQ DX ') msg(3:3)='9'
if(msg(1:3).eq.'CQ ' .and. &
msg(4:4).ge.'A' .and. msg(4:4).le.'Z' .and. &
msg(5:5).ge.'A' .and. msg(5:5).le.'Z' .and. &
msg(6:6).eq.' ') msg='E9'//msg(4:)
! See if it's a CQ message
if(msg(1:3).eq.'CQ ') then
i=3
! ... and if so, does it have a reply frequency?
if(msg(4:4).ge.'0' .and. msg(4:4).le.'9' .and. &
msg(5:5).ge.'0' .and. msg(5:5).le.'9' .and. &
msg(6:6).ge.'0' .and. msg(6:6).le.'9') i=7
go to 1
endif
do i=1,22
if(msg(i:i).eq.' ') go to 1 !Get 1st blank
enddo
go to 10 !Consider msg as plain text
1 ia=i
c1=msg(1:ia-1)
do i=ia+1,22
if(msg(i:i).eq.' ') go to 2 !Get 2nd blank
enddo
go to 10 !Consider msg as plain text
2 ib=i
c2=msg(ia+1:ib-1)
do i=ib+1,22
if(msg(i:i).eq.' ') go to 3 !Get 3rd blank
enddo
go to 10 !Consider msg as plain text
3 ic=i
c3=' '
if(ic.ge.ib+1) c3=msg(ib+1:ic)
if(c3.eq.'OOO ') c3=' ' !Strip out the OOO flag
call getpfx1(c1,k1,nv2a)
if(nv2a.ge.4) go to 10
call packcall(c1,nc1,text1)
if(text1) go to 10
call getpfx1(c2,k2,nv2b)
call packcall(c2,nc2,text2)
if(text2) go to 10
if(nv2a.eq.2 .or. nv2a.eq.3 .or. nv2b.eq.2 .or. nv2b.eq.3) then
if(k1.lt.0 .or. k2.lt.0 .or. k1*k2.ne.0) go to 10
if(k2.gt.0) k2=k2+450
k=max(k1,k2)
if(k.gt.0) then
call k2grid(k,grid6)
c3=grid6(:4)
endif
endif
call packgrid(c3,ng,text3)
if(nv2a.lt.4 .and. nv2b.lt.4 .and. (.not.text1) .and. (.not.text2) .and. &
(.not.text3)) go to 20
nc1=0
if(nv2b.eq.4) then
if(c1(1:3).eq.'CQ ' .and. (.not.text3)) nc1=262178563 + k2
if(c1(1:4).eq.'QRZ ' .and. (.not.text3)) nc1=264002072 + k2
if(c1(1:3).eq.'DE ' .and. (.not.text3)) nc1=265825581 + k2
else if(nv2b.eq.5) then
if(c1(1:3).eq.'CQ ' .and. (.not.text3)) nc1=267649090 + k2
if(c1(1:4).eq.'QRZ ' .and. (.not.text3)) nc1=267698375 + k2
if(c1(1:3).eq.'DE ' .and. (.not.text3)) nc1=267747660 + k2
endif
if(nc1.ne.0) go to 20
! The message will be treated as plain text.
10 itype=6
call packtext(msg,nc1,nc2,ng)
ng=ng+32768
! Encode data into 6-bit words
20 continue
if(itype.ne.6) itype=max(nv2a,nv2b)
jt_itype=itype
jt_c1=c1(1:6)
jt_c2=c2(1:6)
jt_c3=c3
jt_k1=k1
jt_k2=k2
jt_nc1=nc1
jt_nc2=nc2
jt_ng=ng
dat(1)=iand(ishft(nc1,-22),63) !6 bits
dat(2)=iand(ishft(nc1,-16),63) !6 bits
dat(3)=iand(ishft(nc1,-10),63) !6 bits
dat(4)=iand(ishft(nc1, -4),63) !6 bits
dat(5)=4*iand(nc1,15)+iand(ishft(nc2,-26),3) !4+2 bits
dat(6)=iand(ishft(nc2,-20),63) !6 bits
dat(7)=iand(ishft(nc2,-14),63) !6 bits
dat(8)=iand(ishft(nc2, -8),63) !6 bits
dat(9)=iand(ishft(nc2, -2),63) !6 bits
dat(10)=16*iand(nc2,3)+iand(ishft(ng,-12),15) !2+4 bits
dat(11)=iand(ishft(ng,-6),63)
dat(12)=iand(ng,63)
return
end subroutine packmsg
subroutine unpackmsg(dat,msg,bcontest,mygrid)
parameter (NBASE=37*36*10*27*27*27) parameter (NBASE=37*36*10*27*27*27)
parameter (NGBASE=180*180) parameter (NGBASE=180*180)
integer dat(:) integer dat(:)
character c1*12,c2*12,grid*4,msg*22,grid6*6,psfx*4,junk2*4,mygrid*6 character msgcall*12,msggrid*4,grid6*6,junk2*4
logical cqnnn,bcontest logical lhasgrid
cqnnn=.false.
nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+ & nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+ &
ishft(dat(4),4) + iand(ishft(dat(5),-2),15) ishft(dat(4),4) + iand(ishft(dat(5),-2),15)
@ -556,374 +187,20 @@ subroutine packbits(dbits,nsymd,m0,sym)
ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12) ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12)
if(ng.ge.32768) then lhasgrid=.false.
call unpacktext(nc1,nc2,ng,msg) msggrid=' '
go to 100 if(ng.lt.32400 .and. ng.ne.533) then
call unpackcall(nc2,msgcall,junk1,junk2)
dlat=mod(ng,180)-90
dlong=(ng/180)*2 - 180 + 2
call deg2grid(dlong,dlat,grid6)
msggrid=grid6(:4)
lhasgrid=msggrid(1:2).ne.'KA' .and. msggrid(1:2).ne.'KA'
endif endif
call unpackcall(nc1,c1,iv2,psfx)
if(iv2.eq.0) then
! This is an "original JT65" message
if(nc1.eq.NBASE+1) c1='CQ '
if(nc1.eq.NBASE+2) c1='QRZ '
nfreq=nc1-NBASE-3
if(nfreq.ge.0 .and. nfreq.le.999) then
write(c1,1002) nfreq
1002 format('CQ ',i3.3)
cqnnn=.true.
endif
endif
call unpackcall(nc2,c2,junk1,junk2)
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)
if(k.ge.451 .and. k.le.900) call getpfx2(k,c2)
i=index(c1,char(0))
if(i.ge.3) c1=c1(1:i-1)//' '
i=index(c2,char(0))
if(i.ge.3) c2=c2(1:i-1)//' '
msg=' '
j=0
if(cqnnn) then
msg=c1//' '
j=7 !### ??? ###
go to 10
endif
do i=1,12
j=j+1
msg(j:j)=c1(i:i)
if(c1(i:i).eq.' ') go to 10
enddo
j=j+1
msg(j:j)=' '
10 do i=1,12
if(j.le.21) j=j+1
msg(j:j)=c2(i:i)
if(c2(i:i).eq.' ') go to 20
enddo
if(j.le.21) j=j+1
msg(j:j)=' '
20 if(k.eq.0) then
do i=1,4
if(j.le.21) j=j+1
msg(j:j)=grid(i:i)
enddo
if(j.le.21) j=j+1
msg(j:j)=' '
endif
100 continue
if(msg(1:6).eq.'CQ9DX ') msg(3:3)=' '
if(msg(1:2).eq.'E9' .and. &
msg(3:3).ge.'A' .and. msg(3:3).le.'Z' .and. &
msg(4:4).ge.'A' .and. msg(4:4).le.'Z' .and. &
msg(5:5).eq.' ') msg='CQ '//msg(3:)
if(bcontest) call fix_contest_msg(mygrid,msg)
if(msg(1:5).eq.'CQ 00' .and. msg(6:6).ge.'0' .and. &
msg(6:6).le.'9') msg='CQ '//msg(6:)
return return
end subroutine unpackmsg end subroutine unpackmsg
subroutine packtext(msg,nc1,nc2,nc3)
parameter (MASK28=2**28 - 1)
character*22 msg
character*42 c
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/
nc1=0
nc2=0
nc3=0
do i=1,5 !First 5 characters in nc1
do j=1,42 !Get character code
if(msg(i:i).eq.c(j:j)) go to 10
enddo
j=37
10 j=j-1 !Codes should start at zero
nc1=42*nc1 + j
enddo
do i=6,10 !Characters 6-10 in nc2
do j=1,42 !Get character code
if(msg(i:i).eq.c(j:j)) go to 20
enddo
j=37
20 j=j-1 !Codes should start at zero
nc2=42*nc2 + j
enddo
do i=11,13 !Characters 11-13 in nc3
do j=1,42 !Get character code
if(msg(i:i).eq.c(j:j)) go to 30
enddo
j=37
30 j=j-1 !Codes should start at zero
nc3=42*nc3 + j
enddo
! We now have used 17 bits in nc3. Must move one each to nc1 and nc2.
nc1=nc1+nc1
if(iand(nc3,32768).ne.0) nc1=nc1+1
nc2=nc2+nc2
if(iand(nc3,65536).ne.0) nc2=nc2+1
nc3=iand(nc3,32767)
return
end subroutine packtext
subroutine unpacktext(nc1,nc2,nc3,msg)
character*22 msg
character*44 c
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/
nc3=iand(nc3,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
nc2=nc2/2
do i=5,1,-1
j=mod(nc1,42)+1
msg(i:i)=c(j:j)
nc1=nc1/42
enddo
do i=10,6,-1
j=mod(nc2,42)+1
msg(i:i)=c(j:j)
nc2=nc2/42
enddo
do i=13,11,-1
j=mod(nc3,42)+1
msg(i:i)=c(j:j)
nc3=nc3/42
enddo
msg(14:22) = ' '
return
end subroutine unpacktext
subroutine getpfx1(callsign,k,nv2)
character*12 callsign0,callsign,lof,rof
character*8 c
character addpfx*8,tpfx*4,tsfx*3
logical ispfx,issfx,invalid
common/pfxcom/addpfx
include 'pfx.f90'
callsign0=callsign
nv2=1
iz=index(callsign,' ') - 1
if(iz.lt.0) iz=12
islash=index(callsign(1:iz),'/')
k=0
! if(k.eq.0) go to 10 !Tnx to DL9RDZ for reminder:this was for tests only!
c=' '
if(islash.gt.0 .and. islash.le.(iz-4)) then
! Add-on prefix
c=callsign(1:islash-1)
callsign=callsign(islash+1:iz)
do i=1,NZ
if(pfx(i)(1:4).eq.c) then
k=i
nv2=2
go to 10
endif
enddo
if(addpfx.eq.c) then
k=449
nv2=2
go to 10
endif
else if(islash.eq.(iz-1)) then
! Add-on suffix
c=callsign(islash+1:iz)
callsign=callsign(1:islash-1)
do i=1,NZ2
if(sfx(i).eq.c(1:1)) then
k=400+i
nv2=3
go to 10
endif
enddo
endif
10 if(islash.ne.0 .and.k.eq.0) then
! Original JT65 would force this compound callsign to be treated as
! plain text. In JT65v2, we will encode the prefix or suffix into nc1.
! The task here is to compute the proper value of k.
lof=callsign0(:islash-1)
rof=callsign0(islash+1:)
llof=len_trim(lof)
lrof=len_trim(rof)
ispfx=(llof.gt.0 .and. llof.le.4)
issfx=(lrof.gt.0 .and. lrof.le.3)
invalid=.not.(ispfx.or.issfx)
if(ispfx.and.issfx) then
if(llof.lt.3) issfx=.false.
if(lrof.lt.3) ispfx=.false.
if(ispfx.and.issfx) then
i=ichar(callsign0(islash-1:islash-1))
if(i.ge.ichar('0') .and. i.le.ichar('9')) then
issfx=.false.
else
ispfx=.false.
endif
endif
endif
if(invalid) then
k=-1
else
if(ispfx) then
tpfx=lof(1:4)
k=nchar(tpfx(1:1))
k=37*k + nchar(tpfx(2:2))
k=37*k + nchar(tpfx(3:3))
k=37*k + nchar(tpfx(4:4))
nv2=4
i=index(callsign0,'/')
callsign=callsign0(:i-1)
callsign=callsign0(i+1:)
endif
if(issfx) then
tsfx=rof(1:3)
k=nchar(tsfx(1:1))
k=37*k + nchar(tsfx(2:2))
k=37*k + nchar(tsfx(3:3))
nv2=5
i=index(callsign0,'/')
callsign=callsign0(:i-1)
endif
endif
endif
return
end subroutine getpfx1
subroutine getpfx2(k0,callsign)
character callsign*12
include 'pfx.f90'
character addpfx*8
common/pfxcom/addpfx
k=k0
if(k.gt.450) k=k-450
if(k.ge.1 .and. k.le.NZ) then
iz=index(pfx(k),' ') - 1
callsign=pfx(k)(1:iz)//'/'//callsign
else if(k.ge.401 .and. k.le.400+NZ2) then
iz=index(callsign,' ') - 1
callsign=callsign(1:iz)//'/'//sfx(k-400)
else if(k.eq.449) then
iz=index(addpfx,' ') - 1
if(iz.lt.1) iz=8
callsign=addpfx(1:iz)//'/'//callsign
endif
return
end subroutine getpfx2
subroutine grid2k(grid,k)
character*6 grid
call grid2deg(grid,xlong,xlat)
nlong=nint(xlong)
nlat=nint(xlat)
k=0
if(nlat.ge.85) k=5*(nlong+179)/2 + nlat-84
return
end subroutine grid2k
subroutine k2grid(k,grid)
character grid*6
nlong=2*mod((k-1)/5,90)-179
if(k.gt.450) nlong=nlong+180
nlat=mod(k-1,5)+ 85
dlat=nlat
dlong=nlong
call deg2grid(dlong,dlat,grid)
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) function nchar(c)
! Convert ascii number, letter, or space to 0-36 for callsign packing. ! Convert ascii number, letter, or space to 0-36 for callsign packing.
@ -948,90 +225,4 @@ subroutine packbits(dbits,nsymd,m0,sym)
return return
end function nchar end function nchar
subroutine pack50(n1,n2,dat)
integer*1 dat(:),i1
i1=iand(ishft(n1,-20),255) !8 bits
dat(1)=i1
i1=iand(ishft(n1,-12),255) !8 bits
dat(2)=i1
i1=iand(ishft(n1, -4),255) !8 bits
dat(3)=i1
i1=16*iand(n1,15)+iand(ishft(n2,-18),15) !4+4 bits
dat(4)=i1
i1=iand(ishft(n2,-10),255) !8 bits
dat(5)=i1
i1=iand(ishft(n2, -2),255) !8 bits
dat(6)=i1
i1=64*iand(n2,3) !2 bits
dat(7)=i1
dat(8)=0
dat(9)=0
dat(10)=0
dat(11)=0
return
end subroutine pack50
subroutine packpfx(call1,n1,ng,nadd)
character*12 call1,call0
character*3 pfx
logical text
i1=index(call1,'/')
if(call1(i1+2:i1+2).eq.' ') then
! Single-character add-on suffix (maybe also fourth suffix letter?)
call0=call1(:i1-1)
call packcall(call0,n1,text)
nadd=1
nc=ichar(call1(i1+1:i1+1))
if(nc.ge.48 .and. nc.le.57) then
n=nc-48
else if(nc.ge.65 .and. nc.le.90) then
n=nc-65+10
else
n=38
endif
nadd=1
ng=60000-32768+n
else if(call1(i1+3:i1+3).eq.' ') then
! Two-character numerical suffix, /10 to /99
call0=call1(:i1-1)
call packcall(call0,n1,text)
nadd=1
n=10*(ichar(call1(i1+1:i1+1))-48) + ichar(call1(i1+2:i1+2)) - 48
nadd=1
ng=60000 + 26 + n
else
! Prefix of 1 to 3 characters
pfx=call1(:i1-1)
if(pfx(3:3).eq.' ') pfx=' '//pfx(1:2)
if(pfx(3:3).eq.' ') pfx=' '//pfx(1:2)
call0=call1(i1+1:)
call packcall(call0,n1,text)
ng=0
do i=1,3
nc=ichar(pfx(i:i))
if(nc.ge.48 .and. nc.le.57) then
n=nc-48
else if(nc.ge.65 .and. nc.le.90) then
n=nc-65+10
else
n=36
endif
ng=37*ng + n
enddo
nadd=0
if(ng.ge.32768) then
ng=ng-32768
nadd=1
endif
endif
return
end subroutine packpfx
end module packjt end module packjt

50
pfx.f90
View File

@ -1,50 +0,0 @@
parameter (NZ=339) !Total number of prefixes
parameter (NZ2=12) !Total number of suffixes
character*1 sfx(NZ2)
character*5 pfx(NZ)
data sfx/'P','0','1','2','3','4','5','6','7','8','9','A'/
data pfx/ &
'1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', &
'3D2 ','3D2C ','3D2R ','3DA ','3V ','3W ','3X ','3Y ', &
'3YB ','3YP ','4J ','4L ','4S ','4U1I ','4U1U ','4W ', &
'4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', &
'5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', &
'7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', &
'9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', &
'9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', &
'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', &
'C3 ','C5 ','C6 ','C9 ','CE ','CE0X ','CE0Y ','CE0Z ', &
'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', &
'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', &
'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', &
'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', &
'F ','FG ','FH ','FJ ','FK ','FKC ','FM ','FO ', &
'FOA ','FOC ','FOM ','FP ','FR ','FRG ','FRJ ','FRT ', &
'FT5W ','FT5X ','FT5Z ','FW ','FY ','M ','MD ','MI ', &
'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', &
'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ', &
'HK0M ','HL ','HM ','HP ','HR ','HS ','HV ','HZ ', &
'I ','IS ','IS0 ', 'J2 ','J3 ','J5 ','J6 ', &
'J7 ','J8 ','JA ','JDM ','JDO ','JT ','JW ', &
'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', &
'KH4 ','KH5 ','KH5K ','KH6 ','KH7 ','KH8 ','KH9 ','KL ', &
'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', &
'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', &
'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', &
'PJ2 ','PJ7 ','PY ','PY0F ','PT0S ','PY0T ','PZ ','R1F ', &
'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', &
'ST ','SU ','SV ','SVA ','SV5 ','SV9 ','T2 ','T30 ', &
'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', &
'TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', &
'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', &
'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', &
'V6 ','V7 ','V8 ','VE ','VK ','VK0H ','VK0M ','VK9C ', &
'VK9L ','VK9M ','VK9N ','VK9W ','VK9X ','VP2E ','VP2M ','VP2V ', &
'VP5 ','VP6 ','VP6D ','VP8 ','VP8G ','VP8H ','VP8O ','VP8S ', &
'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', &
'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', &
'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', &
'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', &
'ZD9 ','ZF ','ZK1N ','ZK1S ','ZK2 ','ZK3 ','ZL ','ZL7 ', &
'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 ','KC4 ','E5 '/

View File

@ -1,67 +0,0 @@
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}
use timer_module, only: timer
parameter (NMAX=15*4000,NFRAME=640*79)
parameter (NFFT=NMAX,NFILT=700)
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

View File

@ -1,24 +0,0 @@
module timer_module
implicit none
abstract interface
subroutine timer_callback (dname, k)
character(len=8), intent(in) :: dname
integer, intent(in) :: k
end subroutine timer_callback
end interface
public :: null_timer
procedure(timer_callback), pointer :: timer => null_timer
contains
!
! default Fortran implementation which does nothing
!
subroutine null_timer (dname, k)
implicit none
character(len=8), intent(in) :: dname
integer, intent(in) :: k
if(dname.eq.'99999999' .and. k.eq.9999) stop !Silence compiler warnings
end subroutine null_timer
end module timer_module

View File

@ -1,27 +0,0 @@
subroutine to_contest_msg(msg0,msg)
! If the message has "R grid4" istead of "grid4", remove the "R "
! and substitute the diametrically opposite grid.
character*6 g1,g2
character*22 msg0,msg
logical isgrid
isgrid(g1)=g1(1:1).ge.'A' .and. g1(1:1).le.'R' .and. g1(2:2).ge.'A' .and. &
g1(2:2).le.'R' .and. g1(3:3).ge.'0' .and. g1(3:3).le.'9' .and. &
g1(4:4).ge.'0' .and. g1(4:4).le.'9' .and. g1(1:4).ne.'RR73'
i0=index(msg0,' R ') + 3 !Check for ' R ' in message
g1=msg0(i0:i0+3)//' '
if(isgrid(g1)) then !Check for ' R grid'
call grid2deg(g1,dlong,dlat)
dlong=dlong+180.0
if(dlong.gt.180.0) dlong=dlong-360.0
dlat=-dlat
call deg2grid(dlong,dlat,g2) !g2=antipodes grid
msg=msg0(1:i0-3)//g2(1:4) !Send message with g2
else
msg=msg0
endif
return
end subroutine to_contest_msg