w4kek/WSJT-X
1
0
Fork 0
mirror of https://github.com/saitohirga/WSJT-X.git synced 2025-08-15 04:02:27 -04:00
Code Issues Packages Projects Releases Wiki Activity
WSJT-X/lib/packjt.f90
Bill Somerville b048669c02 Merged from trunk: 
------------------------------------------------------------------------
r8060 | k1jt | 2017-09-01 13:51:42 +0100 (Fri, 01 Sep 2017) | 2 lines

Add a link to G3WDG doc on using QRA64 for microwave EME.

------------------------------------------------------------------------
r8061 | k1jt | 2017-09-01 17:22:19 +0100 (Fri, 01 Sep 2017) | 1 line

Fix a misspelled word.
------------------------------------------------------------------------
r8062 | bsomervi | 2017-09-01 21:10:35 +0100 (Fri, 01 Sep 2017) | 7 lines

Rationalize NA contest mode

Generic message packing and unpacking routines now understand antipode
grid contest messages.  These messages  are now recognized as standard
messages in  message response processing and  dealt with appropriately
when contest mode is selected and applicable (currently FT8 and MSK144
only).
------------------------------------------------------------------------
r8063 | bsomervi | 2017-09-01 21:43:45 +0100 (Fri, 01 Sep 2017) | 1 line

Fix issue compiling with Qt older than v5.7
------------------------------------------------------------------------
r8064 | bsomervi | 2017-09-01 22:29:02 +0100 (Fri, 01 Sep 2017) | 7 lines

Fix issues with type 2 compound calls in contest mode

Message generation in  contest mode now generates the  correct Tx3 for
type 2 calls.

"<type-2> 73"  is a free  text so  needed special handling  in message
processing.
------------------------------------------------------------------------
r8065 | bsomervi | 2017-09-01 23:22:20 +0100 (Fri, 01 Sep 2017) | 11 lines

Improved message generation for type 2 calls in contest mode

These attempt  to ensure that  a prefix is  logged by the  QSO partner
even if the compound call holder user Tx3 to tail-end a QSO.

The  type  2 message  generation  options  are largely  overridden  in
contest mode as only a few options make sense. Key is that Tx1 may use
only the base call when calling split is necessary, this requires that
both Tx3 and Tx4 have the full compound call otherwise the QSO partner
will never see the  full call until it is possibly  too late i.e. post
logging.
------------------------------------------------------------------------
r8066 | bsomervi | 2017-09-02 00:28:44 +0100 (Sat, 02 Sep 2017) | 5 lines

Fix erroneous auto stop critera for auto reply in FT8

We cannot assume that a "DE <dx-call>  <anything>" is or is not for us
so  we must  continue calling  and  risk possible  QRM. Calling  split
avoids this issue.
------------------------------------------------------------------------



git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/wsjtx-1.8@8067 ab8295b8-cf94-4d9e-aec4-7959e3be5d79
2017-09-01 23:55:56 +00:00

1027 lines
24 KiB
Fortran
Raw Blame History

module packjt
! These variables are accessible from outside via "use packjt":
integer jt_itype,jt_nc1,jt_nc2,jt_ng,jt_k1,jt_k2
character*6 jt_c1,jt_c2,jt_c3
contains
subroutine 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.
! NB: nsymd is the number of input words, and m0 their length.
! there will be m0*nsymd output bytes, each 0 or 1.
integer sym(:)
integer*1 dbits(:)
k=0
do i=1,nsymd
mask=ishft(1,m0-1)
do j=1,m0
k=k+1
dbits(k)=0
if(iand(mask,sym(i)).ne.0) dbits(k)=1
mask=ishft(mask,-1)
enddo
enddo
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)
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)
character word*12,c*37,psfx*4
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/
word='......'
psfx=' '
n=ncall
iv2=0
if(n.ge.262177560) go to 20
word='......'
! if(n.ge.262177560) go to 999 !Plain text message ...
i=mod(n,27)+11
word(6:6)=c(i:i)
n=n/27
i=mod(n,27)+11
word(5:5)=c(i:i)
n=n/27
i=mod(n,27)+11
word(4:4)=c(i:i)
n=n/27
i=mod(n,10)+1
word(3:3)=c(i:i)
n=n/10
i=mod(n,36)+1
word(2:2)=c(i:i)
n=n/36
i=n+1
word(1:1)=c(i:i)
do i=1,4
if(word(i:i).ne.' ') go to 10
enddo
go to 999
10 word=word(i:)
go to 999
20 if(n.ge.267796946) go to 999
! We have a JT65v2 message
if((n.ge.262178563) .and. (n.le.264002071)) then
! CQ with prefix
iv2=1
n=n-262178563
i=mod(n,37)+1
psfx(4:4)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(3:3)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(2:2)=c(i:i)
n=n/37
i=n+1
psfx(1:1)=c(i:i)
else if((n.ge.264002072) .and. (n.le.265825580)) then
! QRZ with prefix
iv2=2
n=n-264002072
i=mod(n,37)+1
psfx(4:4)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(3:3)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(2:2)=c(i:i)
n=n/37
i=n+1
psfx(1:1)=c(i:i)
else if((n.ge.265825581) .and. (n.le.267649089)) then
! DE with prefix
iv2=3
n=n-265825581
i=mod(n,37)+1
psfx(4:4)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(3:3)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(2:2)=c(i:i)
n=n/37
i=n+1
psfx(1:1)=c(i:i)
else if((n.ge.267649090) .and. (n.le.267698374)) then
! CQ with suffix
iv2=4
n=n-267649090
i=mod(n,37)+1
psfx(3:3)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(2:2)=c(i:i)
n=n/37
i=n+1
psfx(1:1)=c(i:i)
else if((n.ge.267698375) .and. (n.le.267747659)) then
! QRZ with suffix
iv2=5
n=n-267698375
i=mod(n,37)+1
psfx(3:3)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(2:2)=c(i:i)
n=n/37
i=n+1
psfx(1:1)=c(i:i)
else if((n.ge.267747660) .and. (n.le.267796944)) then
! DE with suffix
iv2=6
n=n-267747660
i=mod(n,37)+1
psfx(3:3)=c(i:i)
n=n/37
i=mod(n,37)+1
psfx(2:2)=c(i:i)
n=n/37
i=n+1
psfx(1:1)=c(i:i)
else if(n.eq.267796945) then
! DE with no prefix or suffix
iv2=7
psfx = ' '
endif
999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:)
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: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
jt_c2=c2
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)
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
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)
nc2=ishft(iand(dat(5),3),26) + ishft(dat(6),20) + &
ishft(dat(7),14) + ishft(dat(8),8) + ishft(dat(9),2) + &
iand(ishft(dat(10),-4),3)
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
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)
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.
character c*1
n=0 !Silence compiler warning
if(c.ge.'0' .and. c.le.'9') then
n=ichar(c)-ichar('0')
else if(c.ge.'A' .and. c.le.'Z') then
n=ichar(c)-ichar('A') + 10
else if(c.ge.'a' .and. c.le.'z') then
n=ichar(c)-ichar('a') + 10
else if(c.ge.' ') then
n=36
else
Print*,'Invalid character in callsign ',c,' ',ichar(c)
stop
endif
nchar=n
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
Reference in New Issue View Git Blame Copy Permalink