diff --git a/lib/77bit/encode77.f90 b/lib/77bit/encode77.f90 index 212ec67e2..d52078c12 100644 --- a/lib/77bit/encode77.f90 +++ b/lib/77bit/encode77.f90 @@ -1,5 +1,7 @@ program encode77 + use packjt77 + character*80 msg0 character msg*37,cerr*1 character*77 c77 @@ -36,16 +38,3 @@ program encode77 999 end program encode77 include '../chkcall.f90' -include 'pack77.f90' -include 'unpack77.f90' -include 'pack28.f90' -include 'unpack28.f90' -include 'split77.f90' -include 'pack77_01.f90' -include 'pack77_02.f90' -include 'pack77_03.f90' -include 'pack77_1.f90' -include 'pack77_3.f90' -include 'pack77_4.f90' -include 'packtext77.f90' -include 'unpacktext77.f90' diff --git a/lib/77bit/fmtmsg77.f90 b/lib/77bit/fmtmsg77.f90 deleted file mode 100644 index 75378ad1f..000000000 --- a/lib/77bit/fmtmsg77.f90 +++ /dev/null @@ -1,20 +0,0 @@ -subroutine fmtmsg77(msg) - - character*37 msg - -! Convert all letters to upper case - iz=len(trim(msg)) - do i=1,iz - if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') & - msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a')) - enddo - - do iter=1,10 !Collapse multiple blanks into one - ib2=index(msg(1:iz),' ') - if(ib2.lt.1) go to 900 - msg=msg(1:ib2)//msg(ib2+2:) - iz=iz-1 - enddo - -900 return -end subroutine fmtmsg77 diff --git a/lib/77bit/g2 b/lib/77bit/g2 index 1e2a4334f..645717496 100644 --- a/lib/77bit/g2 +++ b/lib/77bit/g2 @@ -1,6 +1,6 @@ gfortran -c ../packjt.f90 +gfortran -c packjt77.f90 gfortran -o encode77 -fbounds-check -Wall -Wno-conversion -Wno-real-q-constant \ encode77.f90 ../deg2grid.f90 ../grid2deg.f90 ../fix_contest_msg.f90 \ ../to_contest_msg.f90 ../fmtmsg.f90 ../azdist.f90 ../geodist.f90 \ - ihashcall.f90 hash10.f90 hash12.f90 hash22.f90 save_hash_call.f90 \ - packjt.o + packjt.o packjt77.o diff --git a/lib/77bit/hash10.f90 b/lib/77bit/hash10.f90 deleted file mode 100644 index 1b6f03930..000000000 --- a/lib/77bit/hash10.f90 +++ /dev/null @@ -1,18 +0,0 @@ -subroutine hash10(n10,c13) - - parameter (MAXHASH=20) - character*13 c13,callsign(MAXHASH) - integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) - common/hashcom/ihash10,ihash12,ihash22,callsign - save /hashcom/ - - c13='<...>' - do i=1,MAXHASH - if(ihash10(i).eq.n10) then - c13=callsign(i) - go to 900 - endif - enddo - -900 return -end subroutine hash10 diff --git a/lib/77bit/hash12.f90 b/lib/77bit/hash12.f90 deleted file mode 100644 index 1c474424a..000000000 --- a/lib/77bit/hash12.f90 +++ /dev/null @@ -1,19 +0,0 @@ -subroutine hash12(n12,c13) - - parameter (MAXHASH=20) - character*13 c13,callsign(MAXHASH) - integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) - common/hashcom/ihash10,ihash12,ihash22,callsign - save /hashcom/ - - c13='<...>' - do i=1,MAXHASH - if(ihash12(i).eq.n12) then - c13=callsign(i) - go to 900 - endif - enddo - - -900 return -end subroutine hash12 diff --git a/lib/77bit/hash22.f90 b/lib/77bit/hash22.f90 deleted file mode 100644 index b1fdbc5c4..000000000 --- a/lib/77bit/hash22.f90 +++ /dev/null @@ -1,18 +0,0 @@ -subroutine hash22(n22,c13) - - parameter (MAXHASH=20) - character*13 c13,callsign(MAXHASH) - integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) - common/hashcom/ihash10,ihash12,ihash22,callsign - save /hashcom/ - - c13='<...>' - do i=1,MAXHASH - if(ihash22(i).eq.n22) then - c13=callsign(i) - go to 900 - endif - enddo - -900 return -end subroutine hash22 diff --git a/lib/77bit/ihashcall.f90 b/lib/77bit/ihashcall.f90 deleted file mode 100644 index 26d7e6721..000000000 --- a/lib/77bit/ihashcall.f90 +++ /dev/null @@ -1,20 +0,0 @@ -integer function ihashcall(c0,m) - - integer*8 n8 - character*13 c0,c1 - character*38 c - data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ - - c1=c0 - if(c1(1:1).eq.'<') c1=c1(2:) - i=index(c1,'>') - if(i.gt.0) c1(i:)=' ' - n8=0 - do i=1,11 - j=index(c,c1(i:i)) - 1 - n8=38*n8 + j - enddo - ihashcall=ishft(47055833459_8*n8,m-64) - - return -end function ihashcall diff --git a/lib/77bit/pack28.f90 b/lib/77bit/pack28.f90 deleted file mode 100644 index 2184ba5f4..000000000 --- a/lib/77bit/pack28.f90 +++ /dev/null @@ -1,127 +0,0 @@ -subroutine pack28(c13,n28) - -! Pack a special token, a 22-bit hash code, or a valid base call into a 28-bit -! integer. - - parameter (NTOKENS=2063592,MAX22=4194304) - integer nc(6) - logical is_digit,is_letter - character*13 c13 - character*6 callsign - character*1 c - character*4 c4 - character*37 a1 - character*36 a2 - character*10 a3 - character*27 a4 - data a1/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - data a2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - data a3/'0123456789'/ - data a4/' ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - data nc/37,36,19,27,27,27/ - - is_digit(c)=c.ge.'0' .and. c.le.'9' - is_letter(c)=c.ge.'A' .and. c.le.'Z' - - n28=-1 -! Work-around for Swaziland prefix: - if(c13(1:4).eq.'3DA0') callsign='3D0'//c13(5:7) -! Work-around for Guinea prefixes: - if(c13(1:2).eq.'3X' .and. c13(3:3).ge.'A' .and. & - c13(3:3).le.'Z') callsign='Q'//c13(3:6) - -! Check for special tokens first - if(c13(1:3).eq.'DE ') then - n28=0 - go to 900 - endif - - if(c13(1:4).eq.'QRZ ') then - n28=1 - go to 900 - endif - - if(c13(1:3).eq.'CQ ') then - n28=2 - go to 900 - endif - - if(c13(1:3).eq.'CQ_') then - n=len(trim(c13)) - if(n.ge.4 .and. n.le.7) then - nlet=0 - nnum=0 - do i=4,n - c=c13(i:i) - if(c.ge.'A' .and. c.le.'Z') nlet=nlet+1 - if(c.ge.'0' .and. c.le.'9') nnum=nnum+1 - enddo - if(nnum.eq.3 .and. nlet.eq.0) then - read(c13(4:3+nnum),*) nqsy - n28=3+nqsy - go to 900 - endif - if(nlet.ge.1 .and. nlet.le.4 .and. nnum.eq.0) then - c4=c13(4:n)//' ' - c4=adjustr(c4) - m=0 - do i=1,4 - j=0 - c=c4(i:i) - if(c.ge.'A' .and. c.le.'Z') j=ichar(c)-ichar('A')+1 - m=27*m + j - enddo - n28=3+1000+m - go to 900 - endif - endif - endif -! Check for <...> callsign - if(c13(1:1).eq.'<')then - call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table - n28=NTOKENS + n22 - go to 900 - endif - -! Check for standard callsign - iarea=-1 - n=len(trim(c13)) - do i=n,2,-1 - if(is_digit(c13(i:i))) exit - enddo - iarea=i !Call-area digit - npdig=0 !Digits before call area - nplet=0 !Letters before call area - do i=1,iarea-1 - if(is_digit(c13(i:i))) npdig=npdig+1 - if(is_letter(c13(i:i))) nplet=nplet+1 - enddo - nslet=0 - do i=iarea+1,n - if(is_letter(c13(i:i))) nslet=nslet+1 - enddo - if(iarea.lt.2 .or. iarea.gt.3 .or. nplet.eq.0 .or. & - npdig.ge.iarea-1 .or. nslet.gt.3) then -! Treat this as a nonstandard callsign: compute its 22-bit hash - call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table - n28=NTOKENS + n22 - go to 900 - endif - - n=len(trim(c13)) -! This is a standard callsign - if(iarea.eq.2) callsign=' '//c13(1:5) - if(iarea.eq.3) callsign=c13(1:6) - i1=index(a1,callsign(1:1))-1 - i2=index(a2,callsign(2:2))-1 - i3=index(a3,callsign(3:3))-1 - i4=index(a4,callsign(4:4))-1 - i5=index(a4,callsign(5:5))-1 - i6=index(a4,callsign(6:6))-1 - n28=36*10*27*27*27*i1 + 10*27*27*27*i2 + 27*27*27*i3 + 27*27*i4 + & - 27*i5 + i6 - n28=n28 + NTOKENS + MAX22 - -900 n28=iand(n28,2**28-1) - return -end subroutine pack28 diff --git a/lib/77bit/pack77.f90 b/lib/77bit/pack77.f90 deleted file mode 100644 index f7e674e54..000000000 --- a/lib/77bit/pack77.f90 +++ /dev/null @@ -1,67 +0,0 @@ -subroutine pack77(msg0,i3,n3,c77) - - use packjt - character*37 msg,msg0 - character*18 c18 - character*13 w(19) - character*77 c77 - integer nw(19) - integer ntel(3) - - msg=msg0 - if(i3.eq.0 .and. n3.eq.5) go to 5 - -! Convert msg to upper case; collapse multiple blanks; parse into words. - call split77(msg,nwords,nw,w) - i3=-1 - n3=-1 - if(msg(1:3).eq.'CQ ' .or. msg(1:3).eq.'DE ' .or. msg(1:4).eq.'QRZ ') go to 100 - -! Check 0.1 (DXpedition mode) - call pack77_01(nwords,w,i3,n3,c77) - if(i3.ge.0 .or. n3.ge.1) go to 900 -! Check 0.2 (EU VHF contest exchange) - call pack77_02(nwords,w,i3,n3,c77) - if(i3.ge.0) go to 900 - -! Check 0.3 and 0.4 (ARRL Field Day exchange) - call pack77_03(nwords,w,i3,n3,c77) - if(i3.ge.0) go to 900 - -! Check 0.5 (telemetry) -5 i0=index(msg,' ') - c18=msg(1:i0-1)//' ' - c18=adjustr(c18) - ntel=-99 - read(c18,1005,err=6) ntel -1005 format(3z6) - if(ntel(1).ge.2**23) go to 800 -6 if(ntel(1).ge.0 .and. ntel(2).ge.0 .and. ntel(3).ge.0) then - i3=0 - n3=5 - write(c77,1006) ntel,n3 -1006 format(b23.23,2b24.24,b3.3) - go to 900 - endif - -! Check Type 1 (Standard 77-bit message) or Type 2, with optional "/P" -100 call pack77_1(nwords,w,i3,n3,c77) - if(i3.ge.0) go to 900 - -! Check Type 3 (ARRL RTTY contest exchange) - call pack77_3(nwords,w,i3,n3,c77) - if(i3.ge.0) go to 900 - -! Check Type 4 (One nonstandard call and one hashed call) - call pack77_4(nwords,w,i3,n3,c77) - if(i3.ge.0) go to 900 - -! It defaults to free text -800 i3=0 - n3=0 - msg(14:)=' ' - call packtext77(msg(1:13),c77(1:71)) - write(c77(72:77),'(2b3.3)') n3,i3 - -900 return -end subroutine pack77 diff --git a/lib/77bit/pack77_01.f90 b/lib/77bit/pack77_01.f90 deleted file mode 100644 index 0a90d5c73..000000000 --- a/lib/77bit/pack77_01.f90 +++ /dev/null @@ -1,36 +0,0 @@ -subroutine pack77_01(nwords,w,i3,n3,c77) - -! Pack a Type 0.1 message: DXpedition mode -! Example message: "K1ABC RR73; W9XYZ -11" 28 28 10 5 - - character*13 w(19) - character*77 c77 - character*6 bcall_1,bcall_2 - logical ok1,ok2 - - if(nwords.ne.5) go to 900 !Must have 5 words - if(trim(w(2)).ne.'RR73;') go to 900 !2nd word must be "RR73;" - if(w(4)(1:1).ne.'<') go to 900 !4th word must have <...> - if(index(w(4),'>').lt.1) go to 900 - n=-99 - read(w(5),*,err=1) n -1 if(n.eq.-99) go to 900 !5th word must be a valid report - n5=(n+30)/2 - if(n5.lt.0) n5=0 - if(n5.gt.31) n5=31 - call chkcall(w(1),bcall_1,ok1) - if(.not.ok1) go to 900 !1st word must be a valid basecall - call chkcall(w(3),bcall_2,ok2) - if(.not.ok2) go to 900 !3rd word must be a valid basecall - -! Type 0.1: K1ABC RR73; W9XYZ -11 28 28 10 5 71 DXpedition Mode - i3=0 - n3=1 - call pack28(w(1),n28a) - call pack28(w(3),n28b) - call save_hash_call(w(4),n10,n12,n22) - write(c77,1010) n28a,n28b,n10,n5,n3,i3 -1010 format(2b28.28,b10.10,b5.5,2b3.3) - -900 return -end subroutine pack77_01 diff --git a/lib/77bit/pack77_02.f90 b/lib/77bit/pack77_02.f90 deleted file mode 100644 index dd8af8c78..000000000 --- a/lib/77bit/pack77_02.f90 +++ /dev/null @@ -1,51 +0,0 @@ -subroutine pack77_02(nwords,w,i3,n3,c77) - - character*13 w(19),c13 - character*77 c77 - character*6 bcall_1,grid6 - logical ok1,is_grid6 - - is_grid6(grid6)=len(trim(grid6)).eq.6 .and. & - grid6(1:1).ge.'A' .and. grid6(1:1).le.'R' .and. & - grid6(2:2).ge.'A' .and. grid6(2:2).le.'R' .and. & - grid6(3:3).ge.'0' .and. grid6(3:3).le.'9' .and. & - grid6(4:4).ge.'0' .and. grid6(4:4).le.'9' .and. & - grid6(5:5).ge.'A' .and. grid6(5:5).le.'X' .and. & - grid6(6:6).ge.'A' .and. grid6(6:6).le.'X' - - call chkcall(w(1),bcall_1,ok1) - if(.not.ok1) return !bcall_1 must be a valid basecall - if(nwords.lt.3 .or. nwords.gt.4) return !nwords must be 3 or 4 - nx=-1 - if(nwords.ge.2) read(w(nwords-1),*,err=2) nx -2 if(nx.lt.520001 .or. nx.gt.594095) return !Exchange between 520001 - 594095 - if(.not.is_grid6(w(nwords)(1:6))) return !Last word must be a valid grid6 - -! Type 0.2: PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 70 EU VHF contest - i3=0 - n3=2 - ip=0 - c13=w(1) - i=index(w(1),'/P') - if(i.ge.4) then - ip=1 - c13=w(1)(1:i-1)//' ' - endif - call pack28(c13,n28a) - ir=0 - if(w(2)(1:2).eq.'R ') ir=1 - irpt=nx/10000 - 52 - iserial=mod(nx,10000) - grid6=w(nwords)(1:6) - j1=(ichar(grid6(1:1))-ichar('A'))*18*10*10*24*24 - j2=(ichar(grid6(2:2))-ichar('A'))*10*10*24*24 - j3=(ichar(grid6(3:3))-ichar('0'))*10*24*24 - j4=(ichar(grid6(4:4))-ichar('0'))*24*24 - j5=(ichar(grid6(5:5))-ichar('A'))*24 - j6=(ichar(grid6(6:6))-ichar('A')) - igrid6=j1+j2+j3+j4+j5+j6 - write(c77,1010) n28a,ip,ir,irpt,iserial,igrid6,n3,i3 -1010 format(b28.28,2b1,b3.3,b12.12,b25.25,b4.4,b3.3) - - return -end subroutine pack77_02 diff --git a/lib/77bit/pack77_03.f90 b/lib/77bit/pack77_03.f90 deleted file mode 100644 index 8d12633b0..000000000 --- a/lib/77bit/pack77_03.f90 +++ /dev/null @@ -1,62 +0,0 @@ -subroutine pack77_03(nwords,w,i3,n3,c77) -! Check 0.3 and 0.4 (ARRL Field Day exchange) - - parameter (NSEC=84) !Number of ARRL Sections - character*13 w(19) - character*77 c77 - character*6 bcall_1,bcall_2 - character*3 csec(NSEC) - logical ok1,ok2 - data csec/ & - "AB ","AK ","AL ","AR ","AZ ","BC ","CO ","CT ","DE ","EB ", & - "EMA","ENY","EPA","EWA","GA ","GTA","IA ","ID ","IL ","IN ", & - "KS ","KY ","LA ","LAX","MAR","MB ","MDC","ME ","MI ","MN ", & - "MO ","MS ","MT ","NC ","ND ","NE ","NFL","NH ","NL ","NLI", & - "NM ","NNJ","NNY","NT ","NTX","NV ","OH ","OK ","ONE","ONN", & - "ONS","OR ","ORG","PAC","PR ","QC ","RI ","SB ","SC ","SCV", & - "SD ","SDG","SF ","SFL","SJV","SK ","SNJ","STX","SV ","TN ", & - "UT ","VA ","VI ","VT ","WCF","WI ","WMA","WNY","WPA","WTX", & - "WV ","WWA","WY ","DX "/ - - if(nwords.lt.4 .or. nwords.gt.5) return - call chkcall(w(1),bcall_1,ok1) - call chkcall(w(2),bcall_2,ok2) - if(.not.ok1 .or. .not.ok2) return - isec=-1 - do i=1,NSEC - if(csec(i).eq.w(nwords)) then - isec=i - exit - endif - enddo - if(isec.eq.-1) return - if(nwords.eq.5 .and. trim(w(3)).ne.'R') return - - ntx=-1 - j=len(trim(w(nwords-1)))-1 - read(w(nwords-1)(1:j),*,err=1) ntx !Number of transmitters -1 if(ntx.lt.1 .or. ntx.gt.32) return - nclass=ichar(w(nwords-1)(j+1:j+1))-ichar('A') - - m=len(trim(w(nwords))) !Length of section abbreviation - if(m.lt.2 .or. m.gt.3) return - -! 0.3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 ARRL Field Day -! 0.4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 71 ARRL Field Day - - i3=0 - n3=3 !Type 0.3 ARRL Field Day - intx=ntx-1 - if(intx.ge.16) then - n3=4 !Type 0.4 ARRL Field Day - intx=ntx-17 - endif - call pack28(w(1),n28a) - call pack28(w(2),n28b) - ir=0 - if(w(3)(1:2).eq.'R ') ir=1 - write(c77,1010) n28a,n28b,ir,intx,nclass,isec,n3,i3 -1010 format(2b28.28,b1,b4.4,b3.3,b7.7,2b3.3) - - return -end subroutine pack77_03 diff --git a/lib/77bit/pack77_1.f90 b/lib/77bit/pack77_1.f90 deleted file mode 100644 index a3d9be89b..000000000 --- a/lib/77bit/pack77_1.f90 +++ /dev/null @@ -1,94 +0,0 @@ -subroutine pack77_1(nwords,w,i3,n3,c77) -! Check Type 1 (Standard 77-bit message) and Type 2 (ditto, with a "/P" call) - - parameter (MAXGRID4=32400) - character*13 w(19),c13 - character*77 c77 - character*6 bcall_1,bcall_2 - character*4 grid4 - character c1*1,c2*2 - logical is_grid4 - logical ok1,ok2 - is_grid4(grid4)=len(trim(grid4)).eq.4 .and. & - grid4(1:1).ge.'A' .and. grid4(1:1).le.'R' .and. & - grid4(2:2).ge.'A' .and. grid4(2:2).le.'R' .and. & - grid4(3:3).ge.'0' .and. grid4(3:3).le.'9' .and. & - grid4(4:4).ge.'0' .and. grid4(4:4).le.'9' - - if(nwords.lt.2 .or. nwords.gt.4) return - call chkcall(w(1),bcall_1,ok1) - call chkcall(w(2),bcall_2,ok2) - if(w(1)(1:3).eq.'DE ' .or. w(1)(1:3).eq.'CQ_' .or. w(1)(1:3).eq.'CQ ' .or. & - w(1)(1:4).eq.'QRZ ') ok1=.true. - if(w(1)(1:1).eq.'<' .and. index(w(1),'>').ge.5) ok1=.true. - if(w(2)(1:1).eq.'<' .and. index(w(2),'>').ge.5) ok2=.true. - if(.not.ok1 .or. .not.ok2) return - if(nwords.eq.2 .and. (.not.ok2 .or. index(w(2),'/').ge.2)) return - if(nwords.eq.2) go to 10 - - c1=w(nwords)(1:1) - c2=w(nwords)(1:2) - if(.not.is_grid4(w(nwords)(1:4)) .and. c1.ne.'+' .and. c1.ne.'-' & - .and. c2.ne.'R+' .and. c2.ne.'R-' .and. trim(w(nwords)).ne.'RRR' .and. & - trim(w(nwords)).ne.'RR73' .and. trim(w(nwords)).ne.'73') return - if(c1.eq.'+' .or. c1.eq.'-') then - ir=0 - read(w(nwords),*) irpt - irpt=irpt+35 - else if(c2.eq.'R+' .or. c2.eq.'R-') then - ir=1 - read(w(nwords)(2:),*) irpt - irpt=irpt+35 - else if(trim(w(nwords)).eq.'RRR') then - ir=0 - irpt=2 - else if(trim(w(nwords)).eq.'RR73') then - ir=0 - irpt=3 - else if(trim(w(nwords)).eq.'73') then - ir=0 - irpt=4 - endif - -! 1 WA9XYZ/R KA1ABC/R R FN42 28 1 28 1 1 15 74 Standard msg -! 2 PA3XYZ/P GM4ABC/P R JO22 28 1 28 1 1 15 74 EU VHF contest - -10 if(nwords.eq.2 .or. nwords.eq.3 .or. (nwords.eq.4 .and. & - w(3)(1:2).eq.'R ')) then - n3=0 - i3=1 !Type 1: Standard message, possibly with "/R" - if(index(w(1),'/P').ge.4 .or. index(w(2),'/P').ge.4) i3=2 !Type 2, with "/P" - endif - c13=bcall_1//' ' - if(c13(1:3).eq.'CQ_' .or. w(1)(1:1).eq.'<') c13=w(1) - call pack28(c13,n28a) - c13=bcall_2//' ' - if(w(2)(1:1).eq.'<') c13=w(2) - call pack28(c13,n28b) - ipa=0 - ipb=0 - if(index(w(1),'/P').ge.4 .or. index(w(1),'/R').ge.4) ipa=1 - if(index(w(2),'/P').ge.4 .or. index(w(2),'/R').ge.4) ipb=1 - - grid4=w(nwords)(1:4) - if(is_grid4(grid4)) then - ir=0 - if(w(3).eq.'R ') ir=1 - j1=(ichar(grid4(1:1))-ichar('A'))*18*10*10 - j2=(ichar(grid4(2:2))-ichar('A'))*10*10 - j3=(ichar(grid4(3:3))-ichar('0'))*10 - j4=(ichar(grid4(4:4))-ichar('0')) - igrid4=j1+j2+j3+j4 - else - igrid4=MAXGRID4 + irpt - endif - if(nwords.eq.2) then - ir=0 - irpt=1 - igrid4=MAXGRID4+irpt - endif - write(c77,1000) n28a,ipa,n28b,ipb,ir,igrid4,i3 -1000 format(2(b28.28,b1),b1,b15.15,b3.3) - - return -end subroutine pack77_1 diff --git a/lib/77bit/pack77_3.f90 b/lib/77bit/pack77_3.f90 deleted file mode 100644 index 084c1037b..000000000 --- a/lib/77bit/pack77_3.f90 +++ /dev/null @@ -1,68 +0,0 @@ -subroutine pack77_3(nwords,w,i3,n3,c77) -! Check Type 2 (ARRL RTTY contest exchange) -!ARRL RTTY - US/Can: rpt state/prov R 579 MA -! - DX: rpt serial R 559 0013 - - parameter (NUSCAN=65) !Number of US states and Canadian provinces/territories - character*13 w(19) - character*77 c77 - character*6 bcall_1,bcall_2 - character*3 cmult(NUSCAN),mult - character crpt*3 - logical ok1,ok2 - data cmult/ & - "AL ","AK ","AZ ","AR ","CA ","CO ","CT ","DE ","FL ","GA ", & - "HI ","ID ","IL ","IN ","IA ","KS ","KY ","LA ","ME ","MD ", & - "MA ","MI ","MN ","MS ","MO ","MT ","NE ","NV ","NH ","NJ ", & - "NM ","NY ","NC ","ND ","OH ","OK ","OR ","PA ","RI ","SC ", & - "SD ","TN ","TX ","UT ","VT ","VA ","WA ","WV ","WI ","WY ", & - "NB ","NS ","QC ","ON ","MB ","SK ","AB ","BC ","NWT","NF ", & - "LB ","NU ","VT ","PEI","DC "/ - - if(nwords.eq.4 .or. nwords.eq.5 .or. nwords.eq.6) then - i1=1 - if(trim(w(1)).eq.'TU;') i1=2 - call chkcall(w(i1),bcall_1,ok1) - call chkcall(w(i1+1),bcall_2,ok2) - crpt=w(nwords-1)(1:3) - if(crpt(1:1).eq.'5' .and. crpt(2:2).ge.'2' .and. crpt(2:2).le.'9' .and. & - crpt(3:3).eq.'9') then - nserial=0 - read(w(nwords),*,err=1) nserial -!1 i3=3 -! n3=0 - endif -1 mult=' ' - imult=-1 - do i=1,NUSCAN - if(cmult(i).eq.w(nwords)) then - imult=i - mult=cmult(i) - exit - endif - enddo - nexch=0 - if(nserial.gt.0) nexch=nserial - if(imult.gt.0) nexch=8000+imult - if(mult.ne.' ' .or. nserial.gt.0) then - i3=3 - n3=0 - itu=0 - if(trim(w(1)).eq.'TU;') itu=1 - call pack28(w(1+itu),n28a) - call pack28(w(2+itu),n28b) - ir=0 - if(w(3+itu)(1:2).eq.'R ') ir=1 - read(w(3+itu+ir),*) irpt - irpt=(irpt-509)/10 - 2 - if(irpt.lt.0) irpt=0 - if(irpt.gt.7) irpt=7 -! 3 TU; W9XYZ K1ABC R 579 MA 1 28 28 1 3 13 74 ARRL RTTY contest -! 3 TU; W9XYZ G8ABC R 559 0013 1 28 28 1 3 13 74 ARRL RTTY (DX) - write(c77,1010) itu,n28a,n28b,ir,irpt,nexch,i3 -1010 format(b1,2b28.28,b1,b3.3,b13.13,b3.3) - endif - endif - - return -end subroutine pack77_3 diff --git a/lib/77bit/pack77_4.f90 b/lib/77bit/pack77_4.f90 deleted file mode 100644 index 62d3d1d2b..000000000 --- a/lib/77bit/pack77_4.f90 +++ /dev/null @@ -1,60 +0,0 @@ -subroutine pack77_4(nwords,w,i3,n3,c77) -! Check Type 3 (One nonstandard call and one hashed call) - - integer*8 n58 - logical ok1,ok2 - character*13 w(19) - character*77 c77 - character*13 call_1,call_2 - character*11 c11 - character*6 bcall_1,bcall_2 - character*38 c - data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ - - if(nwords.eq.2 .or. nwords.eq.3) then - call_1=w(1) - if(call_1(1:1).eq.'<') call_1=w(1)(2:len(trim(w(1)))-1) - call_2=w(2) - if(call_2(1:1).eq.'<') call_2=w(2)(2:len(trim(w(2)))-1) - call chkcall(call_1,bcall_1,ok1) - call chkcall(call_2,bcall_2,ok2) - if(trim(w(1)).eq.'CQ' .or. (ok1.and.ok2)) then - if(trim(w(1)).eq.'CQ' .and. len(trim(w(2))).le.4) go to 900 - i3=4 - n3=0 - icq=0 - if(trim(w(1)).eq.'CQ') icq=1 - endif - - if(icq.eq.1) then - iflip=0 - n12=0 - c11=adjustr(call_2(1:11)) - call save_hash_call(w(2),n10,n12,n22) - else if(w(1)(1:1).eq.'<') then - iflip=0 - call save_hash_call(w(1),n10,n12,n22) - c11=adjustr(call_2(1:11)) - else if(w(2)(1:1).eq.'<') then - iflip=1 - call save_hash_call(w(2),n10,n12,n22) - c11=adjustr(call_1(1:11)) - endif - n58=0 - do i=1,11 - n58=n58*38 + index(c,c11(i:i)) - 1 - enddo - nrpt=0 - if(trim(w(3)).eq.'RRR') nrpt=1 - if(trim(w(3)).eq.'RR73') nrpt=2 - if(trim(w(3)).eq.'73') nrpt=3 - if(icq.eq.1) then - iflip=0 - nrpt=0 - endif - write(c77,1010) n12,n58,iflip,nrpt,icq,i3 -1010 format(b12.12,b58.58,b1,b2.2,b1,b3.3) - endif - -900 return -end subroutine pack77_4 diff --git a/lib/77bit/packjt77.f90 b/lib/77bit/packjt77.f90 index 9f1f7c84a..4aab5c495 100644 --- a/lib/77bit/packjt77.f90 +++ b/lib/77bit/packjt77.f90 @@ -1,19 +1,1122 @@ -include 'hash10.f90' -include 'hash12.f90' -include 'hash22.f90' -include 'ihashcall.f90' -include 'save_hash_call.f90' -include 'pack77.f90' -include 'unpack77.f90' -include 'pack28.f90' -include 'unpack28.f90' -include 'split77.f90' -include 'pack77_01.f90' -include 'pack77_02.f90' -include 'pack77_03.f90' -include 'pack77_1.f90' -include 'pack77_3.f90' -include 'pack77_4.f90' -include 'packtext77.f90' -include 'unpacktext77.f90' +module packjt77 + contains + +subroutine hash10(n10,c13) + + parameter (MAXHASH=20) + character*13 c13,callsign(MAXHASH) + integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) + common/hashcom/ihash10,ihash12,ihash22,callsign + save /hashcom/ + + c13='<...>' + do i=1,MAXHASH + if(ihash10(i).eq.n10) then + c13=callsign(i) + go to 900 + endif + enddo + +900 return +end subroutine hash10 + + +subroutine hash12(n12,c13) + + parameter (MAXHASH=20) + character*13 c13,callsign(MAXHASH) + integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) + common/hashcom/ihash10,ihash12,ihash22,callsign + save /hashcom/ + + c13='<...>' + do i=1,MAXHASH + if(ihash12(i).eq.n12) then + c13=callsign(i) + go to 900 + endif + enddo + + +900 return +end subroutine hash12 + + +subroutine hash22(n22,c13) + + parameter (MAXHASH=20) + character*13 c13,callsign(MAXHASH) + integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) + common/hashcom/ihash10,ihash12,ihash22,callsign + save /hashcom/ + + c13='<...>' + do i=1,MAXHASH + if(ihash22(i).eq.n22) then + c13=callsign(i) + go to 900 + endif + enddo + +900 return +end subroutine hash22 + + +integer function ihashcall(c0,m) + + integer*8 n8 + character*13 c0,c1 + character*38 c + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ + + c1=c0 + if(c1(1:1).eq.'<') c1=c1(2:) + i=index(c1,'>') + if(i.gt.0) c1(i:)=' ' + n8=0 + do i=1,11 + j=index(c,c1(i:i)) - 1 + n8=38*n8 + j + enddo + ihashcall=ishft(47055833459_8*n8,m-64) + + return +end function ihashcall + + +subroutine save_hash_call(c13,n10,n12,n22) + + parameter (MAXHASH=20) + character*13 c13,callsign(MAXHASH) + integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) + logical first + common/hashcom/ihash10,ihash12,ihash22,callsign + save first,/hashcom/ + + + if(first) then + ihash10=-1 + ihash12=-1 + ihash22=-1 + callsign=' ' + first=.false. + endif + + n10=ihashcall(c13,10) + n12=ihashcall(c13,12) + n22=ihashcall(c13,22) + do i=1,MAXHASH + if(ihash22(i).eq.n22) go to 900 !This one is already in the table + enddo + +! New entry: move table down, making room for new one at the top + ihash10(MAXHASH:2:-1)=ihash10(MAXHASH-1:1:-1) + ihash12(MAXHASH:2:-1)=ihash12(MAXHASH-1:1:-1) + ihash22(MAXHASH:2:-1)=ihash22(MAXHASH-1:1:-1) + +! Add the new entry + callsign(MAXHASH:2:-1)=callsign(MAXHASH-1:1:-1) + ihash10(1)=n10 + ihash12(1)=n12 + ihash22(1)=n22 + callsign(1)=c13 + +900 return +end subroutine save_hash_call + + +subroutine pack77(msg0,i3,n3,c77) + + use packjt + character*37 msg,msg0 + character*18 c18 + character*13 w(19) + character*77 c77 + integer nw(19) + integer ntel(3) + + msg=msg0 + if(i3.eq.0 .and. n3.eq.5) go to 5 + +! Convert msg to upper case; collapse multiple blanks; parse into words. + call split77(msg,nwords,nw,w) + i3=-1 + n3=-1 + if(msg(1:3).eq.'CQ ' .or. msg(1:3).eq.'DE ' .or. msg(1:4).eq.'QRZ ') go to 100 + +! Check 0.1 (DXpedition mode) + call pack77_01(nwords,w,i3,n3,c77) + if(i3.ge.0 .or. n3.ge.1) go to 900 +! Check 0.2 (EU VHF contest exchange) + call pack77_02(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! Check 0.3 and 0.4 (ARRL Field Day exchange) + call pack77_03(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! Check 0.5 (telemetry) +5 i0=index(msg,' ') + c18=msg(1:i0-1)//' ' + c18=adjustr(c18) + ntel=-99 + read(c18,1005,err=6) ntel +1005 format(3z6) + if(ntel(1).ge.2**23) go to 800 +6 if(ntel(1).ge.0 .and. ntel(2).ge.0 .and. ntel(3).ge.0) then + i3=0 + n3=5 + write(c77,1006) ntel,n3 +1006 format(b23.23,2b24.24,b3.3) + go to 900 + endif + +! Check Type 1 (Standard 77-bit message) or Type 2, with optional "/P" +100 call pack77_1(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! Check Type 3 (ARRL RTTY contest exchange) + call pack77_3(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! Check Type 4 (One nonstandard call and one hashed call) + call pack77_4(nwords,w,i3,n3,c77) + if(i3.ge.0) go to 900 + +! It defaults to free text +800 i3=0 + n3=0 + msg(14:)=' ' + call packtext77(msg(1:13),c77(1:71)) + write(c77(72:77),'(2b3.3)') n3,i3 + +900 return +end subroutine pack77 + + +subroutine unpack77(c77,msg) + + parameter (NSEC=84) !Number of ARRL Sections + parameter (NUSCAN=65) !Number of US states and Canadian provinces + parameter (MAXGRID4=32400) + integer*8 n58 + integer ntel(3) + character*77 c77 + character*37 msg + character*13 call_1,call_2,call_3 + character*11 c11 + character*3 crpt,cntx + character*3 cmult(NUSCAN) + character*6 cexch,grid6 + character*4 grid4,cserial + character*3 csec(NSEC) + character*38 c + + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ + data csec/ & + "AB ","AK ","AL ","AR ","AZ ","BC ","CO ","CT ","DE ","EB ", & + "EMA","ENY","EPA","EWA","GA ","GTA","IA ","ID ","IL ","IN ", & + "KS ","KY ","LA ","LAX","MAR","MB ","MDC","ME ","MI ","MN ", & + "MO ","MS ","MT ","NC ","ND ","NE ","NFL","NH ","NL ","NLI", & + "NM ","NNJ","NNY","NT ","NTX","NV ","OH ","OK ","ONE","ONN", & + "ONS","OR ","ORG","PAC","PR ","QC ","RI ","SB ","SC ","SCV", & + "SD ","SDG","SF ","SFL","SJV","SK ","SNJ","STX","SV ","TN ", & + "UT ","VA ","VI ","VT ","WCF","WI ","WMA","WNY","WPA","WTX", & + "WV ","WWA","WY ","DX "/ + data cmult/ & + "AL ","AK ","AZ ","AR ","CA ","CO ","CT ","DE ","FL ","GA ", & + "HI ","ID ","IL ","IN ","IA ","KS ","KY ","LA ","ME ","MD ", & + "MA ","MI ","MN ","MS ","MO ","MT ","NE ","NV ","NH ","NJ ", & + "NM ","NY ","NC ","ND ","OH ","OK ","OR ","PA ","RI ","SC ", & + "SD ","TN ","TX ","UT ","VT ","VA ","WA ","WV ","WI ","WY ", & + "NB ","NS ","QC ","ON ","MB ","SK ","AB ","BC ","NWT","NF ", & + "LB ","NU ","VT ","PEI","DC "/ + + read(c77(72:77),'(2b3)') n3,i3 + msg=repeat(' ',37) + if(i3.eq.0 .and. n3.eq.0) then +! 0.0 Free text + call unpacktext77(c77(1:71),msg(1:13)) + msg(14:)=' ' + msg=adjustl(msg) + + else if(i3.eq.0 .and. n3.eq.1) then +! 0.1 K1ABC RR73; W9XYZ -11 28 28 10 5 71 DXpedition Mode + read(c77,1010) n28a,n28b,n10,n5 +1010 format(2b28,b10,b5) + irpt=2*n5 - 30 + write(crpt,1012) irpt +1012 format(i3.2) + if(irpt.ge.0) crpt(1:1)='+' + call unpack28(n28a,call_1) + call unpack28(n28b,call_2) + call hash10(n10,call_3) + if(call_3(1:1).eq.'<') then + msg=trim(call_1)//' RR73; '//trim(call_2)//' '//trim(call_3)// & + ' '//crpt + else + msg=trim(call_1)//' RR73; '//trim(call_2)//' <'//trim(call_3)// & + '> '//crpt + endif + else if(i3.eq.0 .and. n3.eq.2) then +! 0.2 PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 70 EU VHF contest + read(c77,1020) n28a,ip,ir,irpt,iserial,igrid6 +1020 format(b28,2b1,b3,b12,b25) + call unpack28(n28a,call_1) + nrs=52+irpt + if(ip.eq.1) call_1=trim(call_1)//'/P'//' ' + write(cexch,1022) nrs,iserial +1022 format(i2,i4.4) + n=igrid6 + j1=n/(18*10*10*24*24) + n=n-j1*18*10*10*24*24 + j2=n/(10*10*24*24) + n=n-j2*10*10*24*24 + j3=n/(10*24*24) + n=n-j3*10*24*24 + j4=n/(24*24) + n=n-j4*24*24 + j5=n/24 + j6=n-j5*24 + grid6(1:1)=char(j1+ichar('A')) + grid6(2:2)=char(j2+ichar('A')) + grid6(3:3)=char(j3+ichar('0')) + grid6(4:4)=char(j4+ichar('0')) + grid6(5:5)=char(j5+ichar('A')) + grid6(6:6)=char(j6+ichar('A')) + msg=trim(call_1)//' '//cexch//' '//grid6 + if(ir.eq.1) msg=trim(call_1)//' R '//cexch//' '//grid6 + + else if(i3.eq.0 .and. (n3.eq.3 .or. n3.eq.4)) then +! 0.3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 ARRL Field Day + ! 0.4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 71 ARRL Field Day + read(c77,1030) n28a,n28b,ir,intx,nclass,isec +1030 format(2b28,b1,b4,b3,b7) + call unpack28(n28a,call_1) + call unpack28(n28b,call_2) + ntx=intx+1 + if(n3.eq.4) ntx=ntx+16 + write(cntx(1:2),1032) ntx +1032 format(i2) + cntx(3:3)=char(ichar('A')+nclass) + if(ir.eq.0 .and. ntx.lt.10) msg=trim(call_1)//' '//trim(call_2)// & + cntx//' '//csec(isec) + if(ir.eq.1 .and. ntx.lt.10) msg=trim(call_1)//' '//trim(call_2)// & + ' R'//cntx//' '//csec(isec) + if(ir.eq.0 .and. ntx.ge.10) msg=trim(call_1)//' '//trim(call_2)// & + ' '//cntx//' '//csec(isec) + if(ir.eq.1 .and. ntx.ge.10) msg=trim(call_1)//' '//trim(call_2)// & + ' R '//cntx//' '//csec(isec) + + else if(i3.eq.0 .and. n3.eq.5) then +! 0.5 0123456789abcdef01 71 71 Telemetry (18 hex) + read(c77,1006) ntel +1006 format(b23,2b24) + write(msg,1007) ntel +1007 format(3z6.6) + do i=1,18 + if(msg(i:i).ne.'0') exit + msg(i:i)=' ' + enddo + msg=adjustl(msg) + + else if(i3.eq.1 .or. i3.eq.2) then +! Type 1 (standard message) or Type 2 ("/P" form for EU VHF contest) + read(c77,1000) n28a,ipa,n28b,ipb,ir,igrid4,i3 +1000 format(2(b28,b1),b1,b15,b3) + call unpack28(n28a,call_1) + call unpack28(n28b,call_2) + if(call_1(1:3).eq.'CQ_') call_1(3:3)=' ' + i=index(call_1,' ') + if(i.ge.4 .and. ipa.eq.1 .and. i3.eq.1) call_1(i:i+1)='/R' + if(i.ge.4 .and. ipa.eq.1 .and. i3.eq.2) call_1(i:i+1)='/P' + i=index(call_2,' ') + if(i.ge.4 .and. ipb.eq.1 .and. i3.eq.1) call_2(i:i+1)='/R' + if(i.ge.4 .and. ipb.eq.1 .and. i3.eq.2) call_2(i:i+1)='/P' + + if(igrid4.le.MAXGRID4) then + n=igrid4 + j1=n/(18*10*10) + n=n-j1*18*10*10 + j2=n/(10*10) + n=n-j2*10*10 + j3=n/10 + j4=n-j3*10 + grid4(1:1)=char(j1+ichar('A')) + grid4(2:2)=char(j2+ichar('A')) + grid4(3:3)=char(j3+ichar('0')) + grid4(4:4)=char(j4+ichar('0')) + if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//grid4 + if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R '//grid4 + else + irpt=igrid4-MAXGRID4 + if(irpt.eq.1) msg=trim(call_1)//' '//trim(call_2) + if(irpt.eq.2) msg=trim(call_1)//' '//trim(call_2)//' RRR' + if(irpt.eq.3) msg=trim(call_1)//' '//trim(call_2)//' RR73' + if(irpt.eq.4) msg=trim(call_1)//' '//trim(call_2)//' 73' + if(irpt.ge.5) then + write(crpt,'(i3.2)') irpt-35 + if(crpt(1:1).eq.' ') crpt(1:1)='+' + if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//crpt + if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R'//crpt + endif + endif + + else if(i3.eq.3) then +! Type 3: ARRL RTTY Contest + read(c77,1040) itu,n28a,n28b,ir,irpt,nexch,i3 +1040 format(b1,2b28.28,b1,b3.3,b13.13,b3.3) + write(crpt,1042) irpt+2 +1042 format('5',i1,'9') + nserial=nexch + imult=-1 + if(nexch.gt.8000) then + imult=nexch-8000 + nserial=-1 + endif + call unpack28(n28a,call_1) + call unpack28(n28b,call_2) + imult=0 + nserial=0 + if(nexch.gt.8000) imult=nexch-8000 + if(nexch.lt.8000) nserial=nexch + + if(imult.ge.1 .and.imult.le.NUSCAN) then + if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// & + ' '//crpt//' '//cmult(imult) + if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// & + ' '//crpt//' '//cmult(imult) + if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// & + ' R '//crpt//' '//cmult(imult) + if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// & + ' R '//crpt//' '//cmult(imult) + else if(nserial.ge.1 .and. nserial.le.7999) then + write(cserial,'(i4.4)') nserial + if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// & + ' '//crpt//' '//cserial + if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// & + ' '//crpt//' '//cserial + if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// & + ' R '//crpt//' '//cserial + if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// & + ' R '//crpt//' '//cserial + endif + else if(i3.eq.4) then + read(c77,1050) n12,n58,iflip,nrpt,icq +1050 format(b12,b58,b1,b2,b1) + do i=11,1,-1 + j=mod(n58,38)+1 + c11(i:i)=c(j:j) + n58=n58/38 + enddo + call hash12(n12,call_3) + if(iflip.eq.0) then + call_1=call_3 + call_2=adjustl(c11)//' ' + else + call_1=adjustl(c11)//' ' + call_2=call_3 + endif + if(icq.eq.0) then + if(nrpt.eq.0) msg=trim(call_1)//' '//trim(call_2) + if(nrpt.eq.1) msg=trim(call_1)//' '//trim(call_2)//' RRR' + if(nrpt.eq.2) msg=trim(call_1)//' '//trim(call_2)//' RR73' + if(nrpt.eq.3) msg=trim(call_1)//' '//trim(call_2)//' 73' + else + msg='CQ '//trim(call_2) + endif + endif + + return +end subroutine unpack77 + + +subroutine pack28(c13,n28) + +! Pack a special token, a 22-bit hash code, or a valid base call into a 28-bit +! integer. + + parameter (NTOKENS=2063592,MAX22=4194304) + integer nc(6) + logical is_digit,is_letter + character*13 c13 + character*6 callsign + character*1 c + character*4 c4 + character*37 a1 + character*36 a2 + character*10 a3 + character*27 a4 + data a1/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data a2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data a3/'0123456789'/ + data a4/' ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data nc/37,36,19,27,27,27/ + + is_digit(c)=c.ge.'0' .and. c.le.'9' + is_letter(c)=c.ge.'A' .and. c.le.'Z' + + n28=-1 +! Work-around for Swaziland prefix: + if(c13(1:4).eq.'3DA0') callsign='3D0'//c13(5:7) +! Work-around for Guinea prefixes: + if(c13(1:2).eq.'3X' .and. c13(3:3).ge.'A' .and. & + c13(3:3).le.'Z') callsign='Q'//c13(3:6) + +! Check for special tokens first + if(c13(1:3).eq.'DE ') then + n28=0 + go to 900 + endif + + if(c13(1:4).eq.'QRZ ') then + n28=1 + go to 900 + endif + + if(c13(1:3).eq.'CQ ') then + n28=2 + go to 900 + endif + + if(c13(1:3).eq.'CQ_') then + n=len(trim(c13)) + if(n.ge.4 .and. n.le.7) then + nlet=0 + nnum=0 + do i=4,n + c=c13(i:i) + if(c.ge.'A' .and. c.le.'Z') nlet=nlet+1 + if(c.ge.'0' .and. c.le.'9') nnum=nnum+1 + enddo + if(nnum.eq.3 .and. nlet.eq.0) then + read(c13(4:3+nnum),*) nqsy + n28=3+nqsy + go to 900 + endif + if(nlet.ge.1 .and. nlet.le.4 .and. nnum.eq.0) then + c4=c13(4:n)//' ' + c4=adjustr(c4) + m=0 + do i=1,4 + j=0 + c=c4(i:i) + if(c.ge.'A' .and. c.le.'Z') j=ichar(c)-ichar('A')+1 + m=27*m + j + enddo + n28=3+1000+m + go to 900 + endif + endif + endif +! Check for <...> callsign + if(c13(1:1).eq.'<')then + call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table + n28=NTOKENS + n22 + go to 900 + endif + +! Check for standard callsign + iarea=-1 + n=len(trim(c13)) + do i=n,2,-1 + if(is_digit(c13(i:i))) exit + enddo + iarea=i !Call-area digit + npdig=0 !Digits before call area + nplet=0 !Letters before call area + do i=1,iarea-1 + if(is_digit(c13(i:i))) npdig=npdig+1 + if(is_letter(c13(i:i))) nplet=nplet+1 + enddo + nslet=0 + do i=iarea+1,n + if(is_letter(c13(i:i))) nslet=nslet+1 + enddo + if(iarea.lt.2 .or. iarea.gt.3 .or. nplet.eq.0 .or. & + npdig.ge.iarea-1 .or. nslet.gt.3) then +! Treat this as a nonstandard callsign: compute its 22-bit hash + call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table + n28=NTOKENS + n22 + go to 900 + endif + + n=len(trim(c13)) +! This is a standard callsign + if(iarea.eq.2) callsign=' '//c13(1:5) + if(iarea.eq.3) callsign=c13(1:6) + i1=index(a1,callsign(1:1))-1 + i2=index(a2,callsign(2:2))-1 + i3=index(a3,callsign(3:3))-1 + i4=index(a4,callsign(4:4))-1 + i5=index(a4,callsign(5:5))-1 + i6=index(a4,callsign(6:6))-1 + n28=36*10*27*27*27*i1 + 10*27*27*27*i2 + 27*27*27*i3 + 27*27*i4 + & + 27*i5 + i6 + n28=n28 + NTOKENS + MAX22 + +900 n28=iand(n28,2**28-1) + return +end subroutine pack28 + + +subroutine unpack28(n28_0,c13) + + parameter (NTOKENS=2063592,MAX22=4194304) + integer nc(6) + character*13 c13 + character*37 c1 + character*36 c2 + character*10 c3 + character*27 c4 + data c1/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data c2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data c3/'0123456789'/ + data c4/' ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data nc/37,36,19,27,27,27/ + + n28=n28_0 + if(n28.lt.NTOKENS) then +! Special tokens DE, QRZ, CQ, CQ_nnn, CQ_aaaa + if(n28.eq.0) c13='DE ' + if(n28.eq.1) c13='QRZ ' + if(n28.eq.2) c13='CQ ' + if(n28.le.2) go to 900 + if(n28.le.1002) then + write(c13,1002) n28-3 +1002 format('CQ_',i3.3) + go to 900 + endif + if(n28.le.532443) then + n=n28-1003 + n0=n + i1=n/(27*27*27) + n=n-27*27*27*i1 + i2=n/(27*27) + n=n-27*27*i2 + i3=n/27 + i4=n-27*i3 + c13=c4(i1+1:i1+1)//c4(i2+1:i2+1)//c4(i3+1:i3+1)//c4(i4+1:i4+1) + c13=adjustl(c13) + c13='CQ_'//c13(1:10) + go to 900 + endif + endif + n28=n28-NTOKENS + if(n28.lt.MAX22) then +! This is a 22-bit hash of a callsign + n22=n28 + call hash22(n22,c13) !Retrieve callsign from hash table + if(c13(1:1).ne.'<') then + n=len(trim(c13)) + c13='<'//c13(1:n)//'>'//' ' + endif + go to 900 + endif + +! Standard callsign + n=n28 - MAX22 + i1=n/(36*10*27*27*27) + n=n-36*10*27*27*27*i1 + i2=n/(10*27*27*27) + n=n-10*27*27*27*i2 + i3=n/(27*27*27) + n=n-27*27*27*i3 + i4=n/(27*27) + n=n-27*27*i4 + i5=n/27 + i6=n-27*i5 + c13=c1(i1+1:i1+1)//c2(i2+1:i2+1)//c3(i3+1:i3+1)//c4(i4+1:i4+1)// & + c4(i5+1:i5+1)//c4(i6+1:i6+1)//' ' + c13=adjustl(c13) + +900 return +end subroutine unpack28 + + +subroutine split77(msg,nwords,nw,w) + +! Convert msg to upper case; collapse multiple blanks; parse into words. + + character*37 msg + character*13 w(19) + character*1 c,c0 + character*6 bcall_1 + logical ok1 + integer nw(19) + + iz=len(trim(msg)) + j=0 + k=0 + n=0 + c0=' ' + w=' ' + do i=1,iz + c=msg(i:i) !Single character + if(c.eq.' ' .and. c0.eq.' ') cycle !Skip leading/repeated blanks + if(c.ne.' ' .and. c0.eq.' ') then + k=k+1 !New word + n=0 + endif + j=j+1 !Index in msg + n=n+1 !Index in word + msg(j:j)=c + if(c.ge.'a' .and. c.le.'z') msg(j:j)=char(ichar(c)-32) !Force upper case + if(n.le.13) w(k)(n:n)=c !Copy character c into word + c0=c + enddo + iz=j !Message length + nwords=k !Number of words in msg + nw(k)=len(trim(w(k))) + msg(iz+1:)=' ' + + call chkcall(w(3),bcall_1,ok1) + if(ok1 .and. w(1)(1:3).eq.'CQ ') then + w(1)='CQ_'//w(2)(1:10) + w(2:12)=w(3:13) + nwords=nwords-1 + endif + + return +end subroutine split77 + + +subroutine pack77_01(nwords,w,i3,n3,c77) + +! Pack a Type 0.1 message: DXpedition mode +! Example message: "K1ABC RR73; W9XYZ -11" 28 28 10 5 + + character*13 w(19) + character*77 c77 + character*6 bcall_1,bcall_2 + logical ok1,ok2 + + if(nwords.ne.5) go to 900 !Must have 5 words + if(trim(w(2)).ne.'RR73;') go to 900 !2nd word must be "RR73;" + if(w(4)(1:1).ne.'<') go to 900 !4th word must have <...> + if(index(w(4),'>').lt.1) go to 900 + n=-99 + read(w(5),*,err=1) n +1 if(n.eq.-99) go to 900 !5th word must be a valid report + n5=(n+30)/2 + if(n5.lt.0) n5=0 + if(n5.gt.31) n5=31 + call chkcall(w(1),bcall_1,ok1) + if(.not.ok1) go to 900 !1st word must be a valid basecall + call chkcall(w(3),bcall_2,ok2) + if(.not.ok2) go to 900 !3rd word must be a valid basecall + +! Type 0.1: K1ABC RR73; W9XYZ -11 28 28 10 5 71 DXpedition Mode + i3=0 + n3=1 + call pack28(w(1),n28a) + call pack28(w(3),n28b) + call save_hash_call(w(4),n10,n12,n22) + write(c77,1010) n28a,n28b,n10,n5,n3,i3 +1010 format(2b28.28,b10.10,b5.5,2b3.3) + +900 return +end subroutine pack77_01 + + +subroutine pack77_02(nwords,w,i3,n3,c77) + + character*13 w(19),c13 + character*77 c77 + character*6 bcall_1,grid6 + logical ok1,is_grid6 + + is_grid6(grid6)=len(trim(grid6)).eq.6 .and. & + grid6(1:1).ge.'A' .and. grid6(1:1).le.'R' .and. & + grid6(2:2).ge.'A' .and. grid6(2:2).le.'R' .and. & + grid6(3:3).ge.'0' .and. grid6(3:3).le.'9' .and. & + grid6(4:4).ge.'0' .and. grid6(4:4).le.'9' .and. & + grid6(5:5).ge.'A' .and. grid6(5:5).le.'X' .and. & + grid6(6:6).ge.'A' .and. grid6(6:6).le.'X' + + call chkcall(w(1),bcall_1,ok1) + if(.not.ok1) return !bcall_1 must be a valid basecall + if(nwords.lt.3 .or. nwords.gt.4) return !nwords must be 3 or 4 + nx=-1 + if(nwords.ge.2) read(w(nwords-1),*,err=2) nx +2 if(nx.lt.520001 .or. nx.gt.594095) return !Exchange between 520001 - 594095 + if(.not.is_grid6(w(nwords)(1:6))) return !Last word must be a valid grid6 + +! Type 0.2: PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 70 EU VHF contest + i3=0 + n3=2 + ip=0 + c13=w(1) + i=index(w(1),'/P') + if(i.ge.4) then + ip=1 + c13=w(1)(1:i-1)//' ' + endif + call pack28(c13,n28a) + ir=0 + if(w(2)(1:2).eq.'R ') ir=1 + irpt=nx/10000 - 52 + iserial=mod(nx,10000) + grid6=w(nwords)(1:6) + j1=(ichar(grid6(1:1))-ichar('A'))*18*10*10*24*24 + j2=(ichar(grid6(2:2))-ichar('A'))*10*10*24*24 + j3=(ichar(grid6(3:3))-ichar('0'))*10*24*24 + j4=(ichar(grid6(4:4))-ichar('0'))*24*24 + j5=(ichar(grid6(5:5))-ichar('A'))*24 + j6=(ichar(grid6(6:6))-ichar('A')) + igrid6=j1+j2+j3+j4+j5+j6 + write(c77,1010) n28a,ip,ir,irpt,iserial,igrid6,n3,i3 +1010 format(b28.28,2b1,b3.3,b12.12,b25.25,b4.4,b3.3) + + return +end subroutine pack77_02 + + +subroutine pack77_03(nwords,w,i3,n3,c77) +! Check 0.3 and 0.4 (ARRL Field Day exchange) + + parameter (NSEC=84) !Number of ARRL Sections + character*13 w(19) + character*77 c77 + character*6 bcall_1,bcall_2 + character*3 csec(NSEC) + logical ok1,ok2 + data csec/ & + "AB ","AK ","AL ","AR ","AZ ","BC ","CO ","CT ","DE ","EB ", & + "EMA","ENY","EPA","EWA","GA ","GTA","IA ","ID ","IL ","IN ", & + "KS ","KY ","LA ","LAX","MAR","MB ","MDC","ME ","MI ","MN ", & + "MO ","MS ","MT ","NC ","ND ","NE ","NFL","NH ","NL ","NLI", & + "NM ","NNJ","NNY","NT ","NTX","NV ","OH ","OK ","ONE","ONN", & + "ONS","OR ","ORG","PAC","PR ","QC ","RI ","SB ","SC ","SCV", & + "SD ","SDG","SF ","SFL","SJV","SK ","SNJ","STX","SV ","TN ", & + "UT ","VA ","VI ","VT ","WCF","WI ","WMA","WNY","WPA","WTX", & + "WV ","WWA","WY ","DX "/ + + if(nwords.lt.4 .or. nwords.gt.5) return + call chkcall(w(1),bcall_1,ok1) + call chkcall(w(2),bcall_2,ok2) + if(.not.ok1 .or. .not.ok2) return + isec=-1 + do i=1,NSEC + if(csec(i).eq.w(nwords)) then + isec=i + exit + endif + enddo + if(isec.eq.-1) return + if(nwords.eq.5 .and. trim(w(3)).ne.'R') return + + ntx=-1 + j=len(trim(w(nwords-1)))-1 + read(w(nwords-1)(1:j),*,err=1) ntx !Number of transmitters +1 if(ntx.lt.1 .or. ntx.gt.32) return + nclass=ichar(w(nwords-1)(j+1:j+1))-ichar('A') + + m=len(trim(w(nwords))) !Length of section abbreviation + if(m.lt.2 .or. m.gt.3) return + +! 0.3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 ARRL Field Day +! 0.4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 71 ARRL Field Day + + i3=0 + n3=3 !Type 0.3 ARRL Field Day + intx=ntx-1 + if(intx.ge.16) then + n3=4 !Type 0.4 ARRL Field Day + intx=ntx-17 + endif + call pack28(w(1),n28a) + call pack28(w(2),n28b) + ir=0 + if(w(3)(1:2).eq.'R ') ir=1 + write(c77,1010) n28a,n28b,ir,intx,nclass,isec,n3,i3 +1010 format(2b28.28,b1,b4.4,b3.3,b7.7,2b3.3) + + return +end subroutine pack77_03 + + +subroutine pack77_1(nwords,w,i3,n3,c77) +! Check Type 1 (Standard 77-bit message) and Type 2 (ditto, with a "/P" call) + + parameter (MAXGRID4=32400) + character*13 w(19),c13 + character*77 c77 + character*6 bcall_1,bcall_2 + character*4 grid4 + character c1*1,c2*2 + logical is_grid4 + logical ok1,ok2 + is_grid4(grid4)=len(trim(grid4)).eq.4 .and. & + grid4(1:1).ge.'A' .and. grid4(1:1).le.'R' .and. & + grid4(2:2).ge.'A' .and. grid4(2:2).le.'R' .and. & + grid4(3:3).ge.'0' .and. grid4(3:3).le.'9' .and. & + grid4(4:4).ge.'0' .and. grid4(4:4).le.'9' + + if(nwords.lt.2 .or. nwords.gt.4) return + call chkcall(w(1),bcall_1,ok1) + call chkcall(w(2),bcall_2,ok2) + if(w(1)(1:3).eq.'DE ' .or. w(1)(1:3).eq.'CQ_' .or. w(1)(1:3).eq.'CQ ' .or. & + w(1)(1:4).eq.'QRZ ') ok1=.true. + if(w(1)(1:1).eq.'<' .and. index(w(1),'>').ge.5) ok1=.true. + if(w(2)(1:1).eq.'<' .and. index(w(2),'>').ge.5) ok2=.true. + if(.not.ok1 .or. .not.ok2) return + if(nwords.eq.2 .and. (.not.ok2 .or. index(w(2),'/').ge.2)) return + if(nwords.eq.2) go to 10 + + c1=w(nwords)(1:1) + c2=w(nwords)(1:2) + if(.not.is_grid4(w(nwords)(1:4)) .and. c1.ne.'+' .and. c1.ne.'-' & + .and. c2.ne.'R+' .and. c2.ne.'R-' .and. trim(w(nwords)).ne.'RRR' .and. & + trim(w(nwords)).ne.'RR73' .and. trim(w(nwords)).ne.'73') return + if(c1.eq.'+' .or. c1.eq.'-') then + ir=0 + read(w(nwords),*) irpt + irpt=irpt+35 + else if(c2.eq.'R+' .or. c2.eq.'R-') then + ir=1 + read(w(nwords)(2:),*) irpt + irpt=irpt+35 + else if(trim(w(nwords)).eq.'RRR') then + ir=0 + irpt=2 + else if(trim(w(nwords)).eq.'RR73') then + ir=0 + irpt=3 + else if(trim(w(nwords)).eq.'73') then + ir=0 + irpt=4 + endif + +! 1 WA9XYZ/R KA1ABC/R R FN42 28 1 28 1 1 15 74 Standard msg +! 2 PA3XYZ/P GM4ABC/P R JO22 28 1 28 1 1 15 74 EU VHF contest + +10 if(nwords.eq.2 .or. nwords.eq.3 .or. (nwords.eq.4 .and. & + w(3)(1:2).eq.'R ')) then + n3=0 + i3=1 !Type 1: Standard message, possibly with "/R" + if(index(w(1),'/P').ge.4 .or. index(w(2),'/P').ge.4) i3=2 !Type 2, with "/P" + endif + c13=bcall_1//' ' + if(c13(1:3).eq.'CQ_' .or. w(1)(1:1).eq.'<') c13=w(1) + call pack28(c13,n28a) + c13=bcall_2//' ' + if(w(2)(1:1).eq.'<') c13=w(2) + call pack28(c13,n28b) + ipa=0 + ipb=0 + if(index(w(1),'/P').ge.4 .or. index(w(1),'/R').ge.4) ipa=1 + if(index(w(2),'/P').ge.4 .or. index(w(2),'/R').ge.4) ipb=1 + + grid4=w(nwords)(1:4) + if(is_grid4(grid4)) then + ir=0 + if(w(3).eq.'R ') ir=1 + j1=(ichar(grid4(1:1))-ichar('A'))*18*10*10 + j2=(ichar(grid4(2:2))-ichar('A'))*10*10 + j3=(ichar(grid4(3:3))-ichar('0'))*10 + j4=(ichar(grid4(4:4))-ichar('0')) + igrid4=j1+j2+j3+j4 + else + igrid4=MAXGRID4 + irpt + endif + if(nwords.eq.2) then + ir=0 + irpt=1 + igrid4=MAXGRID4+irpt + endif + write(c77,1000) n28a,ipa,n28b,ipb,ir,igrid4,i3 +1000 format(2(b28.28,b1),b1,b15.15,b3.3) + + return +end subroutine pack77_1 + + +subroutine pack77_3(nwords,w,i3,n3,c77) +! Check Type 2 (ARRL RTTY contest exchange) +!ARRL RTTY - US/Can: rpt state/prov R 579 MA +! - DX: rpt serial R 559 0013 + + parameter (NUSCAN=65) !Number of US states and Canadian provinces/territories + character*13 w(19) + character*77 c77 + character*6 bcall_1,bcall_2 + character*3 cmult(NUSCAN),mult + character crpt*3 + logical ok1,ok2 + data cmult/ & + "AL ","AK ","AZ ","AR ","CA ","CO ","CT ","DE ","FL ","GA ", & + "HI ","ID ","IL ","IN ","IA ","KS ","KY ","LA ","ME ","MD ", & + "MA ","MI ","MN ","MS ","MO ","MT ","NE ","NV ","NH ","NJ ", & + "NM ","NY ","NC ","ND ","OH ","OK ","OR ","PA ","RI ","SC ", & + "SD ","TN ","TX ","UT ","VT ","VA ","WA ","WV ","WI ","WY ", & + "NB ","NS ","QC ","ON ","MB ","SK ","AB ","BC ","NWT","NF ", & + "LB ","NU ","VT ","PEI","DC "/ + + if(nwords.eq.4 .or. nwords.eq.5 .or. nwords.eq.6) then + i1=1 + if(trim(w(1)).eq.'TU;') i1=2 + call chkcall(w(i1),bcall_1,ok1) + call chkcall(w(i1+1),bcall_2,ok2) + crpt=w(nwords-1)(1:3) + if(crpt(1:1).eq.'5' .and. crpt(2:2).ge.'2' .and. crpt(2:2).le.'9' .and. & + crpt(3:3).eq.'9') then + nserial=0 + read(w(nwords),*,err=1) nserial +!1 i3=3 +! n3=0 + endif +1 mult=' ' + imult=-1 + do i=1,NUSCAN + if(cmult(i).eq.w(nwords)) then + imult=i + mult=cmult(i) + exit + endif + enddo + nexch=0 + if(nserial.gt.0) nexch=nserial + if(imult.gt.0) nexch=8000+imult + if(mult.ne.' ' .or. nserial.gt.0) then + i3=3 + n3=0 + itu=0 + if(trim(w(1)).eq.'TU;') itu=1 + call pack28(w(1+itu),n28a) + call pack28(w(2+itu),n28b) + ir=0 + if(w(3+itu)(1:2).eq.'R ') ir=1 + read(w(3+itu+ir),*) irpt + irpt=(irpt-509)/10 - 2 + if(irpt.lt.0) irpt=0 + if(irpt.gt.7) irpt=7 +! 3 TU; W9XYZ K1ABC R 579 MA 1 28 28 1 3 13 74 ARRL RTTY contest +! 3 TU; W9XYZ G8ABC R 559 0013 1 28 28 1 3 13 74 ARRL RTTY (DX) + write(c77,1010) itu,n28a,n28b,ir,irpt,nexch,i3 +1010 format(b1,2b28.28,b1,b3.3,b13.13,b3.3) + endif + endif + + return +end subroutine pack77_3 + + +subroutine pack77_4(nwords,w,i3,n3,c77) +! Check Type 3 (One nonstandard call and one hashed call) + + integer*8 n58 + logical ok1,ok2 + character*13 w(19) + character*77 c77 + character*13 call_1,call_2 + character*11 c11 + character*6 bcall_1,bcall_2 + character*38 c + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ + + if(nwords.eq.2 .or. nwords.eq.3) then + call_1=w(1) + if(call_1(1:1).eq.'<') call_1=w(1)(2:len(trim(w(1)))-1) + call_2=w(2) + if(call_2(1:1).eq.'<') call_2=w(2)(2:len(trim(w(2)))-1) + call chkcall(call_1,bcall_1,ok1) + call chkcall(call_2,bcall_2,ok2) + if(trim(w(1)).eq.'CQ' .or. (ok1.and.ok2)) then + if(trim(w(1)).eq.'CQ' .and. len(trim(w(2))).le.4) go to 900 + i3=4 + n3=0 + icq=0 + if(trim(w(1)).eq.'CQ') icq=1 + endif + + if(icq.eq.1) then + iflip=0 + n12=0 + c11=adjustr(call_2(1:11)) + call save_hash_call(w(2),n10,n12,n22) + else if(w(1)(1:1).eq.'<') then + iflip=0 + call save_hash_call(w(1),n10,n12,n22) + c11=adjustr(call_2(1:11)) + else if(w(2)(1:1).eq.'<') then + iflip=1 + call save_hash_call(w(2),n10,n12,n22) + c11=adjustr(call_1(1:11)) + endif + n58=0 + do i=1,11 + n58=n58*38 + index(c,c11(i:i)) - 1 + enddo + nrpt=0 + if(trim(w(3)).eq.'RRR') nrpt=1 + if(trim(w(3)).eq.'RR73') nrpt=2 + if(trim(w(3)).eq.'73') nrpt=3 + if(icq.eq.1) then + iflip=0 + nrpt=0 + endif + write(c77,1010) n12,n58,iflip,nrpt,icq,i3 +1010 format(b12.12,b58.58,b1,b2.2,b1,b3.3) + endif + +900 return +end subroutine pack77_4 + + +subroutine packtext77(c13,c71) + + real*16 q + character*13 c13,w + character*71 c71 + character*42 c + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/ + + q=0.q0 + w=adjustr(c13) + do i=1,13 + j=index(c,w(i:i))-1 + if(j.lt.0) j=0 + q=42.q0*q + j + enddo + + do i=71,1,-1 + c71(i:i)='0' + n=mod(q,2.q0) + q=q/2.q0 + if(n.eq.1) then + c71(i:i)='1' + q=q-0.q5 + endif + enddo + + return +end subroutine packtext77 + + +subroutine unpacktext77(c71,c13) + + real*16 q,q1 + integer*8 n1,n2 + character*13 c13 + character*71 c71 + character*42 c + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/ + + read(c71,1001) n1,n2 +1001 format(b63,b8) + q=n1*256.q0 + n2 + + do i=13,1,-1 + q1=mod(q,42.q0) + j=q1+1.q0 + c13(i:i)=c(j:j) + q=(q-q1)/42.q0 + enddo + + return +end subroutine unpacktext77 + + +end module packjt77 diff --git a/lib/77bit/packtext77.f90 b/lib/77bit/packtext77.f90 deleted file mode 100644 index 5d876f8d1..000000000 --- a/lib/77bit/packtext77.f90 +++ /dev/null @@ -1,28 +0,0 @@ -subroutine packtext77(c13,c71) - - real*16 q - character*13 c13,w - character*71 c71 - character*42 c - data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/ - - q=0.q0 - w=adjustr(c13) - do i=1,13 - j=index(c,w(i:i))-1 - if(j.lt.0) j=0 - q=42.q0*q + j - enddo - - do i=71,1,-1 - c71(i:i)='0' - n=mod(q,2.q0) - q=q/2.q0 - if(n.eq.1) then - c71(i:i)='1' - q=q-0.q5 - endif - enddo - - return -end subroutine packtext77 diff --git a/lib/77bit/save_hash_call.f90 b/lib/77bit/save_hash_call.f90 deleted file mode 100644 index c8250faf6..000000000 --- a/lib/77bit/save_hash_call.f90 +++ /dev/null @@ -1,39 +0,0 @@ -subroutine save_hash_call(c13,n10,n12,n22) - - parameter (MAXHASH=20) - character*13 c13,callsign(MAXHASH) - integer ihash10(MAXHASH),ihash12(MAXHASH),ihash22(MAXHASH) - logical first - common/hashcom/ihash10,ihash12,ihash22,callsign - save first,/hashcom/ - - - if(first) then - ihash10=-1 - ihash12=-1 - ihash22=-1 - callsign=' ' - first=.false. - endif - - n10=ihashcall(c13,10) - n12=ihashcall(c13,12) - n22=ihashcall(c13,22) - do i=1,MAXHASH - if(ihash22(i).eq.n22) go to 900 !This one is already in the table - enddo - -! New entry: move table down, making room for new one at the top - ihash10(MAXHASH:2:-1)=ihash10(MAXHASH-1:1:-1) - ihash12(MAXHASH:2:-1)=ihash12(MAXHASH-1:1:-1) - ihash22(MAXHASH:2:-1)=ihash22(MAXHASH-1:1:-1) - -! Add the new entry - callsign(MAXHASH:2:-1)=callsign(MAXHASH-1:1:-1) - ihash10(1)=n10 - ihash12(1)=n12 - ihash22(1)=n22 - callsign(1)=c13 - -900 return -end subroutine save_hash_call diff --git a/lib/77bit/split77.f90 b/lib/77bit/split77.f90 deleted file mode 100644 index 045e4da40..000000000 --- a/lib/77bit/split77.f90 +++ /dev/null @@ -1,45 +0,0 @@ -subroutine split77(msg,nwords,nw,w) - -! Convert msg to upper case; collapse multiple blanks; parse into words. - - character*37 msg - character*13 w(19) - character*1 c,c0 - character*6 bcall_1 - logical ok1 - integer nw(19) - - iz=len(trim(msg)) - j=0 - k=0 - n=0 - c0=' ' - w=' ' - do i=1,iz - c=msg(i:i) !Single character - if(c.eq.' ' .and. c0.eq.' ') cycle !Skip leading/repeated blanks - if(c.ne.' ' .and. c0.eq.' ') then - k=k+1 !New word - n=0 - endif - j=j+1 !Index in msg - n=n+1 !Index in word - msg(j:j)=c - if(c.ge.'a' .and. c.le.'z') msg(j:j)=char(ichar(c)-32) !Force upper case - if(n.le.13) w(k)(n:n)=c !Copy character c into word - c0=c - enddo - iz=j !Message length - nwords=k !Number of words in msg - nw(k)=len(trim(w(k))) - msg(iz+1:)=' ' - - call chkcall(w(3),bcall_1,ok1) - if(ok1 .and. w(1)(1:3).eq.'CQ ') then - w(1)='CQ_'//w(2)(1:10) - w(2:12)=w(3:13) - nwords=nwords-1 - endif - - return -end subroutine split77 diff --git a/lib/77bit/unpack28.f90 b/lib/77bit/unpack28.f90 deleted file mode 100644 index aef0a85af..000000000 --- a/lib/77bit/unpack28.f90 +++ /dev/null @@ -1,72 +0,0 @@ -subroutine unpack28(n28_0,c13) - - parameter (NTOKENS=2063592,MAX22=4194304) - integer nc(6) - character*13 c13 - character*37 c1 - character*36 c2 - character*10 c3 - character*27 c4 - data c1/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - data c2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - data c3/'0123456789'/ - data c4/' ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - data nc/37,36,19,27,27,27/ - - n28=n28_0 - if(n28.lt.NTOKENS) then -! Special tokens DE, QRZ, CQ, CQ_nnn, CQ_aaaa - if(n28.eq.0) c13='DE ' - if(n28.eq.1) c13='QRZ ' - if(n28.eq.2) c13='CQ ' - if(n28.le.2) go to 900 - if(n28.le.1002) then - write(c13,1002) n28-3 -1002 format('CQ_',i3.3) - go to 900 - endif - if(n28.le.532443) then - n=n28-1003 - n0=n - i1=n/(27*27*27) - n=n-27*27*27*i1 - i2=n/(27*27) - n=n-27*27*i2 - i3=n/27 - i4=n-27*i3 - c13=c4(i1+1:i1+1)//c4(i2+1:i2+1)//c4(i3+1:i3+1)//c4(i4+1:i4+1) - c13=adjustl(c13) - c13='CQ_'//c13(1:10) - go to 900 - endif - endif - n28=n28-NTOKENS - if(n28.lt.MAX22) then -! This is a 22-bit hash of a callsign - n22=n28 - call hash22(n22,c13,-1) !Retrieve callsign from hash table - if(c13(1:1).ne.'<') then - n=len(trim(c13)) - c13='<'//c13(1:n)//'>'//' ' - endif - go to 900 - endif - -! Standard callsign - n=n28 - MAX22 - i1=n/(36*10*27*27*27) - n=n-36*10*27*27*27*i1 - i2=n/(10*27*27*27) - n=n-10*27*27*27*i2 - i3=n/(27*27*27) - n=n-27*27*27*i3 - i4=n/(27*27) - n=n-27*27*i4 - i5=n/27 - i6=n-27*i5 - c13=c1(i1+1:i1+1)//c2(i2+1:i2+1)//c3(i3+1:i3+1)//c4(i4+1:i4+1)// & - c4(i5+1:i5+1)//c4(i6+1:i6+1)//' ' - c13=adjustl(c13) - -900 return -end subroutine unpack28 diff --git a/lib/77bit/unpack77.f90 b/lib/77bit/unpack77.f90 deleted file mode 100644 index cd905ba8c..000000000 --- a/lib/77bit/unpack77.f90 +++ /dev/null @@ -1,235 +0,0 @@ -subroutine unpack77(c77,msg) - - parameter (NSEC=84) !Number of ARRL Sections - parameter (NUSCAN=65) !Number of US states and Canadian provinces - parameter (MAXGRID4=32400) - integer*8 n58 - integer ntel(3) - character*77 c77 - character*37 msg - character*13 call_1,call_2,call_3 - character*11 c11 - character*3 crpt,cntx - character*3 cmult(NUSCAN) - character*6 cexch,grid6 - character*4 grid4,cserial - character*3 csec(NSEC) - character*38 c - - data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ - data csec/ & - "AB ","AK ","AL ","AR ","AZ ","BC ","CO ","CT ","DE ","EB ", & - "EMA","ENY","EPA","EWA","GA ","GTA","IA ","ID ","IL ","IN ", & - "KS ","KY ","LA ","LAX","MAR","MB ","MDC","ME ","MI ","MN ", & - "MO ","MS ","MT ","NC ","ND ","NE ","NFL","NH ","NL ","NLI", & - "NM ","NNJ","NNY","NT ","NTX","NV ","OH ","OK ","ONE","ONN", & - "ONS","OR ","ORG","PAC","PR ","QC ","RI ","SB ","SC ","SCV", & - "SD ","SDG","SF ","SFL","SJV","SK ","SNJ","STX","SV ","TN ", & - "UT ","VA ","VI ","VT ","WCF","WI ","WMA","WNY","WPA","WTX", & - "WV ","WWA","WY ","DX "/ - data cmult/ & - "AL ","AK ","AZ ","AR ","CA ","CO ","CT ","DE ","FL ","GA ", & - "HI ","ID ","IL ","IN ","IA ","KS ","KY ","LA ","ME ","MD ", & - "MA ","MI ","MN ","MS ","MO ","MT ","NE ","NV ","NH ","NJ ", & - "NM ","NY ","NC ","ND ","OH ","OK ","OR ","PA ","RI ","SC ", & - "SD ","TN ","TX ","UT ","VT ","VA ","WA ","WV ","WI ","WY ", & - "NB ","NS ","QC ","ON ","MB ","SK ","AB ","BC ","NWT","NF ", & - "LB ","NU ","VT ","PEI","DC "/ - - read(c77(72:77),'(2b3)') n3,i3 - msg=repeat(' ',37) - if(i3.eq.0 .and. n3.eq.0) then -! 0.0 Free text - call unpacktext77(c77(1:71),msg(1:13)) - msg(14:)=' ' - msg=adjustl(msg) - - else if(i3.eq.0 .and. n3.eq.1) then -! 0.1 K1ABC RR73; W9XYZ -11 28 28 10 5 71 DXpedition Mode - read(c77,1010) n28a,n28b,n10,n5 -1010 format(2b28,b10,b5) - irpt=2*n5 - 30 - write(crpt,1012) irpt -1012 format(i3.2) - if(irpt.ge.0) crpt(1:1)='+' - call unpack28(n28a,call_1) - call unpack28(n28b,call_2) - call hash10(n10,call_3) - if(call_3(1:1).eq.'<') then - msg=trim(call_1)//' RR73; '//trim(call_2)//' '//trim(call_3)// & - ' '//crpt - else - msg=trim(call_1)//' RR73; '//trim(call_2)//' <'//trim(call_3)// & - '> '//crpt - endif - else if(i3.eq.0 .and. n3.eq.2) then -! 0.2 PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 70 EU VHF contest - read(c77,1020) n28a,ip,ir,irpt,iserial,igrid6 -1020 format(b28,2b1,b3,b12,b25) - call unpack28(n28a,call_1) - nrs=52+irpt - if(ip.eq.1) call_1=trim(call_1)//'/P'//' ' - write(cexch,1022) nrs,iserial -1022 format(i2,i4.4) - n=igrid6 - j1=n/(18*10*10*24*24) - n=n-j1*18*10*10*24*24 - j2=n/(10*10*24*24) - n=n-j2*10*10*24*24 - j3=n/(10*24*24) - n=n-j3*10*24*24 - j4=n/(24*24) - n=n-j4*24*24 - j5=n/24 - j6=n-j5*24 - grid6(1:1)=char(j1+ichar('A')) - grid6(2:2)=char(j2+ichar('A')) - grid6(3:3)=char(j3+ichar('0')) - grid6(4:4)=char(j4+ichar('0')) - grid6(5:5)=char(j5+ichar('A')) - grid6(6:6)=char(j6+ichar('A')) - msg=trim(call_1)//' '//cexch//' '//grid6 - if(ir.eq.1) msg=trim(call_1)//' R '//cexch//' '//grid6 - - else if(i3.eq.0 .and. (n3.eq.3 .or. n3.eq.4)) then -! 0.3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 ARRL Field Day - ! 0.4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 71 ARRL Field Day - read(c77,1030) n28a,n28b,ir,intx,nclass,isec -1030 format(2b28,b1,b4,b3,b7) - call unpack28(n28a,call_1) - call unpack28(n28b,call_2) - ntx=intx+1 - if(n3.eq.4) ntx=ntx+16 - write(cntx(1:2),1032) ntx -1032 format(i2) - cntx(3:3)=char(ichar('A')+nclass) - if(ir.eq.0 .and. ntx.lt.10) msg=trim(call_1)//' '//trim(call_2)// & - cntx//' '//csec(isec) - if(ir.eq.1 .and. ntx.lt.10) msg=trim(call_1)//' '//trim(call_2)// & - ' R'//cntx//' '//csec(isec) - if(ir.eq.0 .and. ntx.ge.10) msg=trim(call_1)//' '//trim(call_2)// & - ' '//cntx//' '//csec(isec) - if(ir.eq.1 .and. ntx.ge.10) msg=trim(call_1)//' '//trim(call_2)// & - ' R '//cntx//' '//csec(isec) - - else if(i3.eq.0 .and. n3.eq.5) then -! 0.5 0123456789abcdef01 71 71 Telemetry (18 hex) - read(c77,1006) ntel -1006 format(b23,2b24) - write(msg,1007) ntel -1007 format(3z6.6) - do i=1,18 - if(msg(i:i).ne.'0') exit - msg(i:i)=' ' - enddo - msg=adjustl(msg) - - else if(i3.eq.1 .or. i3.eq.2) then -! Type 1 (standard message) or Type 2 ("/P" form for EU VHF contest) - read(c77,1000) n28a,ipa,n28b,ipb,ir,igrid4,i3 -1000 format(2(b28,b1),b1,b15,b3) - call unpack28(n28a,call_1) - call unpack28(n28b,call_2) - if(call_1(1:3).eq.'CQ_') call_1(3:3)=' ' - i=index(call_1,' ') - if(i.ge.4 .and. ipa.eq.1 .and. i3.eq.1) call_1(i:i+1)='/R' - if(i.ge.4 .and. ipa.eq.1 .and. i3.eq.2) call_1(i:i+1)='/P' - i=index(call_2,' ') - if(i.ge.4 .and. ipb.eq.1 .and. i3.eq.1) call_2(i:i+1)='/R' - if(i.ge.4 .and. ipb.eq.1 .and. i3.eq.2) call_2(i:i+1)='/P' - - if(igrid4.le.MAXGRID4) then - n=igrid4 - j1=n/(18*10*10) - n=n-j1*18*10*10 - j2=n/(10*10) - n=n-j2*10*10 - j3=n/10 - j4=n-j3*10 - grid4(1:1)=char(j1+ichar('A')) - grid4(2:2)=char(j2+ichar('A')) - grid4(3:3)=char(j3+ichar('0')) - grid4(4:4)=char(j4+ichar('0')) - if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//grid4 - if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R '//grid4 - else - irpt=igrid4-MAXGRID4 - if(irpt.eq.1) msg=trim(call_1)//' '//trim(call_2) - if(irpt.eq.2) msg=trim(call_1)//' '//trim(call_2)//' RRR' - if(irpt.eq.3) msg=trim(call_1)//' '//trim(call_2)//' RR73' - if(irpt.eq.4) msg=trim(call_1)//' '//trim(call_2)//' 73' - if(irpt.ge.5) then - write(crpt,'(i3.2)') irpt-35 - if(crpt(1:1).eq.' ') crpt(1:1)='+' - if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//crpt - if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R'//crpt - endif - endif - - else if(i3.eq.3) then -! Type 3: ARRL RTTY Contest - read(c77,1040) itu,n28a,n28b,ir,irpt,nexch,i3 -1040 format(b1,2b28.28,b1,b3.3,b13.13,b3.3) - write(crpt,1042) irpt+2 -1042 format('5',i1,'9') - nserial=nexch - imult=-1 - if(nexch.gt.8000) then - imult=nexch-8000 - nserial=-1 - endif - call unpack28(n28a,call_1) - call unpack28(n28b,call_2) - imult=0 - nserial=0 - if(nexch.gt.8000) imult=nexch-8000 - if(nexch.lt.8000) nserial=nexch - - if(imult.ge.1 .and.imult.le.NUSCAN) then - if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// & - ' '//crpt//' '//cmult(imult) - if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// & - ' '//crpt//' '//cmult(imult) - if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// & - ' R '//crpt//' '//cmult(imult) - if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// & - ' R '//crpt//' '//cmult(imult) - else if(nserial.ge.1 .and. nserial.le.7999) then - write(cserial,'(i4.4)') nserial - if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// & - ' '//crpt//' '//cserial - if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// & - ' '//crpt//' '//cserial - if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// & - ' R '//crpt//' '//cserial - if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// & - ' R '//crpt//' '//cserial - endif - else if(i3.eq.4) then - read(c77,1050) n12,n58,iflip,nrpt,icq -1050 format(b12,b58,b1,b2,b1) - do i=11,1,-1 - j=mod(n58,38)+1 - c11(i:i)=c(j:j) - n58=n58/38 - enddo - call hash12(n12,call_3) - if(iflip.eq.0) then - call_1=call_3 - call_2=adjustl(c11)//' ' - else - call_1=adjustl(c11)//' ' - call_2=call_3 - endif - if(icq.eq.0) then - if(nrpt.eq.0) msg=trim(call_1)//' '//trim(call_2) - if(nrpt.eq.1) msg=trim(call_1)//' '//trim(call_2)//' RRR' - if(nrpt.eq.2) msg=trim(call_1)//' '//trim(call_2)//' RR73' - if(nrpt.eq.3) msg=trim(call_1)//' '//trim(call_2)//' 73' - else - msg='CQ '//trim(call_2) - endif - endif - - return -end subroutine unpack77 diff --git a/lib/77bit/unpacktext77.f90 b/lib/77bit/unpacktext77.f90 deleted file mode 100644 index 35633fe83..000000000 --- a/lib/77bit/unpacktext77.f90 +++ /dev/null @@ -1,22 +0,0 @@ -subroutine unpacktext77(c71,c13) - - real*16 q,q1 - integer*8 n1,n2 - character*13 c13 - character*71 c71 - character*42 c - data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/ - - read(c71,1001) n1,n2 -1001 format(b63,b8) - q=n1*256.q0 + n2 - - do i=13,1,-1 - q1=mod(q,42.q0) - j=q1+1.q0 - c13(i:i)=c(j:j) - q=(q-q1)/42.q0 - enddo - - return -end subroutine unpacktext77 diff --git a/lib/ft8/ft8b_2.f90 b/lib/ft8/ft8b_2.f90 index f0cba2ef4..5788dd67d 100644 --- a/lib/ft8/ft8b_2.f90 +++ b/lib/ft8/ft8b_2.f90 @@ -4,6 +4,7 @@ subroutine ft8b_2(dd0,newdat,nQSOProgress,nfqso,nftx,ndepth,lapon,lapcqonly, & use crc use timer_module, only: timer + use packjt77 include 'ft8_params.f90' parameter(NP2=2812) character*37 msg37,msgsent37 diff --git a/lib/ft8/ft8sim2.f90 b/lib/ft8/ft8sim2.f90 index e3a2c9cd2..7e9acbcaf 100644 --- a/lib/ft8/ft8sim2.f90 +++ b/lib/ft8/ft8sim2.f90 @@ -4,6 +4,7 @@ program ft8sim2 ! Output is saved to a *.wav file. use wavhdr + use packjt77 include 'ft8_params.f90' !Set various constants parameter (NWAVE=NN*NSPS) type(hdr) h !Header for .wav file diff --git a/lib/ft8/genft8_174_91.f90 b/lib/ft8/genft8_174_91.f90 index a58883656..690cff1ef 100644 --- a/lib/ft8/genft8_174_91.f90 +++ b/lib/ft8/genft8_174_91.f90 @@ -3,6 +3,7 @@ subroutine genft8_174_91(msg,mygrid,bcontest,i3,n3,msgsent,msgbits,itone) ! Encode an FT8 message, producing array itone(). use packjt + use packjt77 include 'ft8_params.f90' character msg*37,msgsent*37 character*6 mygrid