fix snr calculations

This commit is contained in:
Pavel Demin 2018-10-15 23:43:39 +02:00
parent cd8ec61296
commit 9f611385f0
9 changed files with 880 additions and 12 deletions

View File

@ -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
View 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

View File

@ -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
View 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

View File

@ -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
View 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
View 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

View File

@ -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
View 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 '/