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