From 9f611385f08dced9e315fa9b401bdfce8c6268aa Mon Sep 17 00:00:00 2001 From: Pavel Demin Date: Mon, 15 Oct 2018 23:43:39 +0200 Subject: [PATCH] fix snr calculations --- Makefile | 10 +- encode174.f90 | 50 ++++ extractmessage174.f90 | 7 +- fmtmsg.f90 | 21 ++ ft8b.f90 | 3 +- genft8.f90 | 55 ++++ grid2deg.f90 | 38 +++ packjt.f90 | 658 +++++++++++++++++++++++++++++++++++++++++- pfx.f90 | 50 ++++ 9 files changed, 880 insertions(+), 12 deletions(-) create mode 100644 encode174.f90 create mode 100644 fmtmsg.f90 create mode 100644 genft8.f90 create mode 100644 grid2deg.f90 create mode 100644 pfx.f90 diff --git a/Makefile b/Makefile index 2549c07..d2eb261 100644 --- a/Makefile +++ b/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 diff --git a/encode174.f90 b/encode174.f90 new file mode 100644 index 0000000..61bce37 --- /dev/null +++ b/encode174.f90 @@ -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 diff --git a/extractmessage174.f90 b/extractmessage174.f90 index 588880f..f6e263c 100644 --- a/extractmessage174.f90 +++ b/extractmessage174.f90 @@ -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 diff --git a/fmtmsg.f90 b/fmtmsg.f90 new file mode 100644 index 0000000..2ceb815 --- /dev/null +++ b/fmtmsg.f90 @@ -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 diff --git a/ft8b.f90 b/ft8b.f90 index 72bc98b..5c024d9 100644 --- a/ft8b.f90 +++ b/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 diff --git a/genft8.f90 b/genft8.f90 new file mode 100644 index 0000000..78c2369 --- /dev/null +++ b/genft8.f90 @@ -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 diff --git a/grid2deg.f90 b/grid2deg.f90 new file mode 100644 index 0000000..843fc84 --- /dev/null +++ b/grid2deg.f90 @@ -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 diff --git a/packjt.f90 b/packjt.f90 index e33b955..5009ec8 100644 --- a/packjt.f90 +++ b/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. diff --git a/pfx.f90 b/pfx.f90 new file mode 100644 index 0000000..eb81fef --- /dev/null +++ b/pfx.f90 @@ -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 '/