mirror of
https://github.com/pavel-demin/ft8d.git
synced 2024-11-23 12:58:37 -05:00
fix snr calculations
This commit is contained in:
Pavel Demin
parent
cd8ec61296
commit
9f611385f0
10
Makefile
10
Makefile
@ -1,17 +1,17 @@
|
||||
TARGET = ft8d
|
||||
|
||||
OBJECTS = \
|
||||
crc12.o crc.o ft8_downsample.o sync8d.o sync8.o four2a.o deg2grid.o \
|
||||
chkcrc12a.o determ.o fftw3mod.o baseline.o bpdecode174.o packjt.o \
|
||||
extractmessage174.o indexx.o shell.o pctile.o polyfit.o twkfreq1.o \
|
||||
osd174.o db.o ft8b.o ft8d.o
|
||||
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
|
||||
|
||||
CC = gcc
|
||||
FC = gfortran
|
||||
LD = gfortran
|
||||
RM = rm -f
|
||||
|
||||
CFLAGS = -O3 -Wall -fbounds-check
|
||||
CFLAGS = -O3 -Wall
|
||||
FFLAGS = -O3 -Wall -funroll-loops -fno-second-underscore
|
||||
LDFLAGS = -lfftw3f
|
||||
|
||||
|
||||
50
encode174.f90
Normal file
50
encode174.f90
Normal file
@ -0,0 +1,50 @@
|
||||
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
|
||||
@ -1,9 +1,9 @@
|
||||
subroutine extractmessage174(decoded,msgcall,msggrid,ncrcflag)
|
||||
subroutine extractmessage174(decoded,msgreceived,msgcall,msggrid,ncrcflag)
|
||||
use iso_c_binding, only: c_loc,c_size_t
|
||||
use crc
|
||||
use packjt
|
||||
|
||||
character msgcall*12, msggrid*4
|
||||
character msgreceived*22, msgcall*12, msggrid*4
|
||||
character*87 cbits
|
||||
integer*1 decoded(87)
|
||||
integer*1, target:: i1Dec8BitBytes(11)
|
||||
@ -30,9 +30,10 @@ subroutine extractmessage174(decoded,msgcall,msggrid,ncrcflag)
|
||||
enddo
|
||||
i4Dec6BitWords(ibyte)=itmp
|
||||
enddo
|
||||
call unpackmsg(i4Dec6BitWords,msgcall,msggrid)
|
||||
call unpackmsg(i4Dec6BitWords,msgreceived,msgcall,msggrid)
|
||||
ncrcflag=1
|
||||
else
|
||||
msgreceived=' '
|
||||
msgcall=' '
|
||||
msggrid=' '
|
||||
ncrcflag=-1
|
||||
|
||||
21
fmtmsg.f90
Normal file
21
fmtmsg.f90
Normal file
@ -0,0 +1,21 @@
|
||||
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
|
||||
3
ft8b.f90
3
ft8b.f90
@ -360,7 +360,8 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, &
|
||||
cycle
|
||||
endif
|
||||
if(nbadcrc.eq.0) then
|
||||
call extractmessage174(decoded,msgcall,msggrid,ncrcflag)
|
||||
call extractmessage174(decoded,message,msgcall,msggrid,ncrcflag)
|
||||
call genft8(message,0,itone)
|
||||
xsig=0.0
|
||||
xnoi=0.0
|
||||
do i=1,79
|
||||
|
||||
55
genft8.f90
Normal file
55
genft8.f90
Normal file
@ -0,0 +1,55 @@
|
||||
subroutine genft8(msg,i3bit,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) !Pack into 12 6-bit bytes
|
||||
|
||||
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
|
||||
38
grid2deg.f90
Normal file
38
grid2deg.f90
Normal file
@ -0,0 +1,38 @@
|
||||
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
|
||||
658
packjt.f90
658
packjt.f90
@ -1,7 +1,95 @@
|
||||
module packjt
|
||||
|
||||
! These variables are accessible from outside via "use packjt":
|
||||
integer jt_itype,jt_nc1,jt_nc2,jt_ng,jt_k1,jt_k2
|
||||
character*6 jt_c1,jt_c2,jt_c3
|
||||
|
||||
contains
|
||||
|
||||
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)
|
||||
|
||||
parameter (NBASE=37*36*10*27*27*27)
|
||||
@ -143,13 +231,273 @@ module packjt
|
||||
return
|
||||
end subroutine unpackcall
|
||||
|
||||
subroutine unpackmsg(dat,msgcall,msggrid)
|
||||
subroutine packgrid(grid,ng,text)
|
||||
|
||||
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)
|
||||
|
||||
! 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
|
||||
|
||||
itype=1
|
||||
msg=msg0
|
||||
|
||||
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,msgcall,msggrid)
|
||||
|
||||
parameter (NBASE=37*36*10*27*27*27)
|
||||
parameter (NGBASE=180*180)
|
||||
integer dat(:)
|
||||
character msgcall*12,msggrid*4,grid6*6,junk2*4
|
||||
character c1*12,c2*12,grid*4,msg*22,msgcall*12,msggrid*4,grid6*6,psfx*4,junk2*4
|
||||
logical cqnnn
|
||||
|
||||
cqnnn=.false.
|
||||
nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+ &
|
||||
ishft(dat(4),4) + iand(ishft(dat(5),-2),15)
|
||||
|
||||
@ -159,7 +507,25 @@ module packjt
|
||||
|
||||
ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12)
|
||||
|
||||
call unpackcall(nc2,msgcall,junk1,junk2)
|
||||
if(ng.ge.32768) then
|
||||
call unpacktext(nc1,nc2,ng,msg)
|
||||
go to 100
|
||||
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)
|
||||
msggrid=' '
|
||||
if(ng.lt.32400 .and. ng.ne.533) then
|
||||
dlat=mod(ng,180)-90
|
||||
@ -167,10 +533,296 @@ module packjt
|
||||
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)
|
||||
|
||||
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(msg(1:5).eq.'CQ 00' .and. msg(6:6).ge.'0' .and. &
|
||||
msg(6:6).le.'9') msg='CQ '//msg(6:)
|
||||
|
||||
return
|
||||
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
|
||||
|
||||
function nchar(c)
|
||||
|
||||
! Convert ascii number, letter, or space to 0-36 for callsign packing.
|
||||
|
||||
50
pfx.f90
Normal file
50
pfx.f90
Normal file
@ -0,0 +1,50 @@
|
||||
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 '/
|
||||
Loading…
Reference in New Issue
Block a user