From 61ae08bf0c9037d7d983f822dc8bdc843e47eab6 Mon Sep 17 00:00:00 2001 From: Pavel Demin Date: Thu, 19 Apr 2018 16:49:30 +0200 Subject: [PATCH] remove signal subtraction and simplify output format --- Makefile | 10 +- azdist.f90 | 129 ------- bpdecode144.f90 | 348 ------------------ bpdecode174.f90 | 25 ++ crc10.c | 59 --- encode174.f90 | 50 --- extractmessage174.f90 | 10 +- fix_contest_msg.f90 | 32 -- fmtmsg.f90 | 21 -- ft8b.f90 | 72 +--- ft8d.f90 | 79 ++-- genft8.f90 | 56 --- genft8refsig.f90 | 22 -- geodist.f90 | 105 ------ grid2deg.f90 | 38 -- packjt.f90 | 833 +----------------------------------------- pfx.f90 | 50 --- subtractft8.f90 | 67 ---- timer_module.f90 | 24 -- to_contest_msg.f90 | 27 -- 20 files changed, 77 insertions(+), 1980 deletions(-) delete mode 100644 azdist.f90 delete mode 100644 bpdecode144.f90 delete mode 100644 crc10.c delete mode 100644 encode174.f90 delete mode 100644 fix_contest_msg.f90 delete mode 100644 fmtmsg.f90 delete mode 100644 genft8.f90 delete mode 100644 genft8refsig.f90 delete mode 100644 geodist.f90 delete mode 100644 grid2deg.f90 delete mode 100644 pfx.f90 delete mode 100644 subtractft8.f90 delete mode 100644 timer_module.f90 delete mode 100644 to_contest_msg.f90 diff --git a/Makefile b/Makefile index f0237bd..2549c07 100644 --- a/Makefile +++ b/Makefile @@ -1,12 +1,10 @@ TARGET = ft8d OBJECTS = \ - timer_module.o crc10.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 bpdecode144.o geodist.o azdist.o fix_contest_msg.o \ - to_contest_msg.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 genft8refsig.o subtractft8.o db.o ft8b.o ft8d.o + 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 CC = gcc FC = gfortran diff --git a/azdist.f90 b/azdist.f90 deleted file mode 100644 index 0375a19..0000000 --- a/azdist.f90 +++ /dev/null @@ -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 diff --git a/bpdecode144.f90 b/bpdecode144.f90 deleted file mode 100644 index 0b530f5..0000000 --- a/bpdecode144.f90 +++ /dev/null @@ -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 diff --git a/bpdecode174.f90 b/bpdecode174.f90 index ada4354..df0eb67 100644 --- a/bpdecode174.f90 +++ b/bpdecode174.f90 @@ -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) ! ! A log-domain belief propagation decoder for the (174,87) code. diff --git a/crc10.c b/crc10.c deleted file mode 100644 index 025018d..0000000 --- a/crc10.c +++ /dev/null @@ -1,59 +0,0 @@ -#include - -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); -} diff --git a/encode174.f90 b/encode174.f90 deleted file mode 100644 index 61bce37..0000000 --- a/encode174.f90 +++ /dev/null @@ -1,50 +0,0 @@ -subroutine encode174(message,codeword) -! Encode an 87-bit message and return a 174-bit codeword. -! The generator matrix has dimensions (87,87). -! The code is a (174,87) regular ldpc code with column weight 3. -! The code was generated using the PEG algorithm. -! After creating the codeword, the columns are re-ordered according to -! "colorder" to make the codeword compatible with the parity-check matrix -! - -include "ldpc_174_87_params.f90" - -integer*1 codeword(N) -integer*1 gen(M,K) -integer*1 itmp(N) -integer*1 message(K) -integer*1 pchecks(M) -logical first -data first/.true./ - -save first,gen - -if( first ) then ! fill the generator matrix - gen=0 - do i=1,M - do j=1,11 - read(g(i)( (j-1)*2+1:(j-1)*2+2 ),"(Z2)") istr - do jj=1, 8 - icol=(j-1)*8+jj - if( icol .le. 87 ) then - if( btest(istr,8-jj) ) gen(i,icol)=1 - endif - enddo - enddo - enddo -first=.false. -endif - -do i=1,M - nsum=0 - do j=1,K - nsum=nsum+message(j)*gen(i,j) - enddo - pchecks(i)=mod(nsum,2) -enddo -itmp(1:M)=pchecks -itmp(M+1:N)=message(1:K) -codeword(colorder+1)=itmp(1:N) - -return -end subroutine encode174 diff --git a/extractmessage174.f90 b/extractmessage174.f90 index 20e23e3..d988735 100644 --- a/extractmessage174.f90 +++ b/extractmessage174.f90 @@ -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 crc use packjt - character*22 msgreceived + character msgcall*12, msggrid*4 character*87 cbits integer*1 decoded(87) integer*1, target:: i1Dec8BitBytes(11) integer*4 i4Dec6BitWords(12) + logical lhasgrid ! Write decoded bits into cbits: 75-bit message plus 12-bit CRC write(cbits,1000) decoded @@ -30,10 +31,11 @@ subroutine extractmessage174(decoded,msgreceived,ncrcflag) enddo i4Dec6BitWords(ibyte)=itmp enddo - call unpackmsg(i4Dec6BitWords,msgreceived,.false.,' ') + call unpackmsg(i4Dec6BitWords,lhasgrid,msgcall,msggrid) ncrcflag=1 else - msgreceived=' ' + msgcall=' ' + msggrid=' ' ncrcflag=-1 endif return diff --git a/fix_contest_msg.f90 b/fix_contest_msg.f90 deleted file mode 100644 index 8c0345e..0000000 --- a/fix_contest_msg.f90 +++ /dev/null @@ -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 diff --git a/fmtmsg.f90 b/fmtmsg.f90 deleted file mode 100644 index 2ceb815..0000000 --- a/fmtmsg.f90 +++ /dev/null @@ -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 diff --git a/ft8b.f90 b/ft8b.f90 index bdfecab..c949da1 100644 --- a/ft8b.f90 +++ b/ft8b.f90 @@ -1,25 +1,18 @@ -subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & - napwid,lsubtract,nagain,iaptype,mycall12,mygrid6,hiscall12,bcontest, & - sync0,f1,xdt,xbase,apsym,nharderrors,dmin,nbadcrc,ipass,iera,msg37,xsnr) +subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & + napwid,nagain,iaptype,f1,xdt,xbase,apsym,nharderrors,dmin, & + nbadcrc,ipass,lhasgrid,msgcall,msggrid,xsnr) use crc - use timer_module, only: timer include 'ft8_params.f90' parameter(NP2=2812) - character*37 msg37 - character message*22,msgsent*22 - character*12 mycall12,hiscall12 - character*6 mycall6,mygrid6,hiscall6,c1,c2 - character*87 cbits - logical bcontest + character msgcall*12,msggrid*4,message*22 real a(5) real s1(0:7,ND),s2(0:7,NN),s1sort(8*ND) real ps(0:7),psl(0:7) real bmeta(3*ND),bmetb(3*ND),bmetap(3*ND) real llr(3*ND),llra(3*ND),llr0(3*ND),llr1(3*ND),llrap(3*ND) !Soft symbols complex dd0(NMAX) - integer*1 decoded(KK),decoded0(KK),apmask(3*ND),cw(3*ND) - integer*1 msgbits(KK) + integer*1 decoded(KK),apmask(3*ND),cw(3*ND) integer apsym(KK) integer mcq(28),mde(28),mrrr(16),m73(16),mrr73(16) integer itone(NN) @@ -27,11 +20,10 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & integer icos7(0:6),ip(1) integer nappasses(0:5) !Number of decoding passes to use for each QSO state integer naptypes(0:5,4) ! (nQSOProgress, decoding pass) maximum of 4 passes for now - integer*1, target:: i1hiscall(12) complex cd0(3200) complex ctwk(32) complex csymb(32) - logical first,newdat,lsubtract,lapon,lapcqonly,nagain + logical first,newdat,lapon,lapcqonly,nagain,lhasgrid equivalence (s1,s1sort) data icos7/2,5,6,0,4,1,3/ data mcq/1,1,1,1,1,0,1,0,0,0,0,0,1,0,0,0,0,0,1,1,0,0,0,1,1,0,0,1/ @@ -82,9 +74,7 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & delfbest=0. ibest=0 - call timer('ft8_down',0) 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 smax=0.0 @@ -340,10 +330,8 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & endif cw=0 - call timer('bpd174 ',0) call bpdecode174(llrap,apmask,max_iterations,decoded,cw,nharderrors, & niterations) - call timer('bpd174 ',1) dmin=0.0 if(ndepth.eq.3 .and. nharderrors.lt.0) then ndeep=3 @@ -355,9 +343,7 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & endif endif if(nagain) ndeep=5 - call timer('osd174 ',0) call osd174(llrap,apmask,ndeep,decoded,cw,nharderrors,dmin) - call timer('osd174 ',1) endif nbadcrc=1 message=' ' @@ -373,16 +359,8 @@ subroutine ft8b(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & nharderrors=-1 cycle endif - i3bit=4*decoded(73) + 2*decoded(74) + decoded(75) - iFreeText=decoded(57) if(nbadcrc.eq.0) then - decoded0=decoded - 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) + call extractmessage174(decoded,lhasgrid,msgcall,msggrid,ncrcflag) xsig=0.0 xnoi=0.0 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 if(.not.nagain) xsnr=xsnr2 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 endif enddo diff --git a/ft8d.f90 b/ft8d.f90 index 5529f93..9b6f704 100644 --- a/ft8d.f90 +++ b/ft8d.f90 @@ -4,17 +4,14 @@ program ft8d include 'ft8_params.f90' character infile*80,datetime*13,message*22,msg37*37 - character*22 allmessages(100) - character*12 mycall12,hiscall12 - character*6 mygrid6,hisgrid6 + character msgcall*12, msggrid*4 real s(NFFT1,NHSYM) real sbase(NFFT1) real candidate(3,200) real*8 dialfreq complex dd(NMAX,4) - logical newdat,lsubtract,ldupe,bcontest + logical newdat,lhasgrid integer apsym(KK) - integer allsnrs(100) nargs=iargc() if(nargs.ne.1) then @@ -42,59 +39,29 @@ program ft8d datetime=infile(j2-13:j2-1) do ipart=1,4 ndecodes=0 - allmessages=' ' - allsnrs=0 ndepth=1 - npass=1 - do ipass=1,npass - newdat=.true. - syncmin=1.5 - if(ipass.eq.1) then - lsubtract=.true. - if(ndepth.eq.1) lsubtract=.false. - elseif(ipass.eq.2) then - n2=ndecodes - if(ndecodes.eq.0) cycle - lsubtract=.true. - elseif(ipass.eq.3) then - if((ndecodes-n2).eq.0) cycle - lsubtract=.false. + newdat=.true. + syncmin=1.5 + call sync8(dd(1:NMAX,ipart),nfa+2000,nfb+2000,syncmin, & + nfqso+2000,s,candidate,ncand,sbase) + do icand=1,ncand + sync=candidate(3,icand) + f1=candidate(1,icand) + xdt=candidate(2,icand) + xbase=10.0**(0.1*(sbase(nint(f1/3.125))-40.0)) + call ft8b(dd(1:NMAX,ipart),newdat,nQSOProgress,nfqso+2000, & + nftx,ndepth,lft8apon,lapcqonly,napwid,nagain,iaptype, & + f1,xdt,xbase,apsym,nharderrors,dmin,nbadcrc,iappass, & + lhasgrid,msgcall,msggrid,xsnr) + 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 - 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 ! ipart loop diff --git a/genft8.f90 b/genft8.f90 deleted file mode 100644 index 4e33c9d..0000000 --- a/genft8.f90 +++ /dev/null @@ -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 diff --git a/genft8refsig.f90 b/genft8refsig.f90 deleted file mode 100644 index 6893825..0000000 --- a/genft8refsig.f90 +++ /dev/null @@ -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 diff --git a/geodist.f90 b/geodist.f90 deleted file mode 100644 index 5fa9502..0000000 --- a/geodist.f90 +++ /dev/null @@ -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 diff --git a/grid2deg.f90 b/grid2deg.f90 deleted file mode 100644 index 843fc84..0000000 --- a/grid2deg.f90 +++ /dev/null @@ -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 diff --git a/packjt.f90 b/packjt.f90 index 0b4e3c1..e12a554 100644 --- a/packjt.f90 +++ b/packjt.f90 @@ -6,28 +6,6 @@ module packjt 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) ! Unpack bits from sym() into dbits(), one bit per byte. @@ -51,90 +29,6 @@ subroutine packbits(dbits,nsymd,m0,sym) return 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) parameter (NBASE=37*36*10*27*27*27) @@ -276,277 +170,14 @@ subroutine packbits(dbits,nsymd,m0,sym) return end subroutine unpackcall - 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,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) + subroutine unpackmsg(dat,lhasgrid,msgcall,msggrid) parameter (NBASE=37*36*10*27*27*27) parameter (NGBASE=180*180) integer dat(:) - character c1*12,c2*12,grid*4,msg*22,grid6*6,psfx*4,junk2*4,mygrid*6 - logical cqnnn,bcontest + character msgcall*12,msggrid*4,grid6*6,junk2*4 + logical lhasgrid - 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) @@ -556,374 +187,20 @@ subroutine packbits(dbits,nsymd,m0,sym) ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12) - if(ng.ge.32768) then - call unpacktext(nc1,nc2,ng,msg) - go to 100 + lhasgrid=.false. + msggrid=' ' + 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 - 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 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) ! Convert ascii number, letter, or space to 0-36 for callsign packing. @@ -948,90 +225,4 @@ subroutine packbits(dbits,nsymd,m0,sym) return end function nchar - subroutine pack50(n1,n2,dat) - - integer*1 dat(:),i1 - - i1=iand(ishft(n1,-20),255) !8 bits - dat(1)=i1 - i1=iand(ishft(n1,-12),255) !8 bits - dat(2)=i1 - i1=iand(ishft(n1, -4),255) !8 bits - dat(3)=i1 - i1=16*iand(n1,15)+iand(ishft(n2,-18),15) !4+4 bits - dat(4)=i1 - i1=iand(ishft(n2,-10),255) !8 bits - dat(5)=i1 - i1=iand(ishft(n2, -2),255) !8 bits - dat(6)=i1 - i1=64*iand(n2,3) !2 bits - dat(7)=i1 - dat(8)=0 - dat(9)=0 - dat(10)=0 - dat(11)=0 - - return - end subroutine pack50 - -subroutine packpfx(call1,n1,ng,nadd) - - character*12 call1,call0 - character*3 pfx - logical text - - i1=index(call1,'/') - if(call1(i1+2:i1+2).eq.' ') then -! Single-character add-on suffix (maybe also fourth suffix letter?) - call0=call1(:i1-1) - call packcall(call0,n1,text) - nadd=1 - nc=ichar(call1(i1+1:i1+1)) - if(nc.ge.48 .and. nc.le.57) then - n=nc-48 - else if(nc.ge.65 .and. nc.le.90) then - n=nc-65+10 - else - n=38 - endif - nadd=1 - ng=60000-32768+n - else if(call1(i1+3:i1+3).eq.' ') then -! Two-character numerical suffix, /10 to /99 - call0=call1(:i1-1) - call packcall(call0,n1,text) - nadd=1 - n=10*(ichar(call1(i1+1:i1+1))-48) + ichar(call1(i1+2:i1+2)) - 48 - nadd=1 - ng=60000 + 26 + n - else -! Prefix of 1 to 3 characters - pfx=call1(:i1-1) - if(pfx(3:3).eq.' ') pfx=' '//pfx(1:2) - if(pfx(3:3).eq.' ') pfx=' '//pfx(1:2) - call0=call1(i1+1:) - call packcall(call0,n1,text) - - ng=0 - do i=1,3 - nc=ichar(pfx(i:i)) - if(nc.ge.48 .and. nc.le.57) then - n=nc-48 - else if(nc.ge.65 .and. nc.le.90) then - n=nc-65+10 - else - n=36 - endif - ng=37*ng + n - enddo - nadd=0 - if(ng.ge.32768) then - ng=ng-32768 - nadd=1 - endif - endif - - return -end subroutine packpfx - end module packjt diff --git a/pfx.f90 b/pfx.f90 deleted file mode 100644 index eb81fef..0000000 --- a/pfx.f90 +++ /dev/null @@ -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 '/ diff --git a/subtractft8.f90 b/subtractft8.f90 deleted file mode 100644 index 67aed84..0000000 --- a/subtractft8.f90 +++ /dev/null @@ -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 - diff --git a/timer_module.f90 b/timer_module.f90 deleted file mode 100644 index 59675c1..0000000 --- a/timer_module.f90 +++ /dev/null @@ -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 diff --git a/to_contest_msg.f90 b/to_contest_msg.f90 deleted file mode 100644 index adc841d..0000000 --- a/to_contest_msg.f90 +++ /dev/null @@ -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