From 96f3fa5810896d6ad0ebab59265e811ae60a1e94 Mon Sep 17 00:00:00 2001 From: Joe Taylor Date: Thu, 21 Jun 2018 10:51:19 -0400 Subject: [PATCH] Add directory 77bit and its contents. --- lib/77bit/77bit.txt | 40 ++ lib/77bit/arrl_sec.txt | 83 +++ lib/77bit/fmtmsg77.f90 | 20 + lib/77bit/msgtypes.txt | 23 + lib/77bit/msgtypes.txt.0 | 11 + lib/77bit/packjt.f90 | 1037 ++++++++++++++++++++++++++++++++++++++ lib/77bit/parse77.f90 | 178 +++++++ lib/77bit/t1.f90 | 54 ++ lib/77bit/t2.f90 | 26 + lib/77bit/t3.f90 | 25 + 10 files changed, 1497 insertions(+) create mode 100644 lib/77bit/77bit.txt create mode 100644 lib/77bit/arrl_sec.txt create mode 100644 lib/77bit/fmtmsg77.f90 create mode 100644 lib/77bit/msgtypes.txt create mode 100644 lib/77bit/msgtypes.txt.0 create mode 100644 lib/77bit/packjt.f90 create mode 100644 lib/77bit/parse77.f90 create mode 100644 lib/77bit/t1.f90 create mode 100644 lib/77bit/t2.f90 create mode 100644 lib/77bit/t3.f90 diff --git a/lib/77bit/77bit.txt b/lib/77bit/77bit.txt new file mode 100644 index 000000000..f4f38fe8d --- /dev/null +++ b/lib/77bit/77bit.txt @@ -0,0 +1,40 @@ +Proposed new message types have 77-bit payload: 74 information bits +and 3 bits for "message type". Note that Type 0 (as defined by i3) +uses only 71 information bits, so it allows another 3 bits (here +called n3) to be used for 8 sub-types. + +---------------------------------------------------------------------------------- +i3 Example message Bits n3 Total Purpose +---------------------------------------------------------------------------------- +0 FREE TEXT MSG 71 0 71 +0 K1ABC RR73; W9XYZ -11 28 28 10 5 1 71 DXpedition Mode +0 PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 2 70 EU VHF contest +0 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 3 71 ARRL Field Day +0 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 4 71 ARRL Field Day + +1 WA9XYZ/R KA1ABC/R R FN42 28 1 28 1 1 15 74 Standard msg +2 TU; W9XYZ K1ABC R 579 MA 1 28 28 1 3 13 74 ARRL RTTY contest +3 PA3XYZ/P GM4ABC/P R JO22 28 1 28 1 1 15 74 EU VHF contest +4 PJ4/KA1ABC R-11 13 53 1 1 6 74 Nonstandard calls +5 ... +6 +7 +---------------------------------------------------------------------------------- +Notes: + +0. Free text message. + +1. 74-bit standard message: two 28-bit callsigns, each with an extra +bit to indicate "/R" Rover status; one bit for "R" preceding the grid +or report; 15 bits for grid or report. + +2. Type 2 is for the annual ARRL RTTY Roundup. Optional "TU;" uses +1 bit; then two 28-bit callsigns, optional "R" (1 bit), a 3-bit +report, and finally 13 bits for US state, Canadian province, or DX +serial number. + +3. For European VHF+ contests. Like Type 1, but /P instead of /R. + +4. For European VHF+ contests. Transfers serial QSO number (12 bits) +and 6-digit grid locator (25 bits). + diff --git a/lib/77bit/arrl_sec.txt b/lib/77bit/arrl_sec.txt new file mode 100644 index 000000000..b97b64f46 --- /dev/null +++ b/lib/77bit/arrl_sec.txt @@ -0,0 +1,83 @@ +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 diff --git a/lib/77bit/fmtmsg77.f90 b/lib/77bit/fmtmsg77.f90 new file mode 100644 index 000000000..75378ad1f --- /dev/null +++ b/lib/77bit/fmtmsg77.f90 @@ -0,0 +1,20 @@ +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/msgtypes.txt b/lib/77bit/msgtypes.txt new file mode 100644 index 000000000..a1ab61f61 --- /dev/null +++ b/lib/77bit/msgtypes.txt @@ -0,0 +1,23 @@ +i3 n3 +-------------------------------------------------------------------------------------- +0 0 FREE TEXT MSG 71 0 71 +0 1 K1ABC RR73; W9XYZ -11 28 28 10 5 1 71 DXpedition Mode +0 2 PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 2 70 EU VHF contest (2) +0 3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 3 71 ARRL Field Day +0 4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 4 71 ARRL Field Day +1 WA9XYZ/R KA1ABC/R R FN42 28 1 28 1 1 15 74 Standard msg +2 TU; W9XYZ K1ABC R 579 MA 1 28 28 1 3 13 74 ARRL RTTY contest +3 PJ4/KA1ABC R-11 13 53 1 1 6 74 Nonstandard calls +4 PA3XYZ/P GM4ABC/P R IO91 28 1 28 1 1 15 74 EU VHF contest + +0 0 HELLO WORLD 1 +0 0 hello world 2 + +0 1 K1ABC RR73; W9XYZ -11 +0 2 PA3XYZ 590003 IO91NP +0 3 WA9XYZ KA1ABC 16A EMA +0 4 WA9XYZ KA1ABC 32A EMA +1 WA9XYZ/R KA1ABC/R R FN42 +2 W9XYZ K1ABC 579 MA +3 PJ4/KA1ABC -11 +4 PA3XYZ/P GM4ABC/P R IO91 diff --git a/lib/77bit/msgtypes.txt.0 b/lib/77bit/msgtypes.txt.0 new file mode 100644 index 000000000..cabf618bc --- /dev/null +++ b/lib/77bit/msgtypes.txt.0 @@ -0,0 +1,11 @@ +i3 n3 +-------------------------------------------------------------------------------------- +0 0 FREE TEXT MSG 71 0 71 +0 1 K1ABC RR73; W9XYZ -11 28 28 10 5 1 71 DXpedition Mode +0 2 PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 2 70 EU VHF contest +0 3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 3 71 ARRL Field Day +0 4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 4 71 ARRL Field Day +1 WA9XYZ/R KA1ABC/R R FN42 28 1 28 1 1 15 74 Standard msg +2 TU; W9XYZ K1ABC R 579 MA 1 28 28 1 3 13 74 ARRL RTTY contest +3 PJ4/KA1ABC R-11 13 53 1 1 6 74 Nonstandard calls +4 PA3XYZ/P GM4ABC/P R IO91 28 1 28 1 1 15 74 EU VHF contest diff --git a/lib/77bit/packjt.f90 b/lib/77bit/packjt.f90 new file mode 100644 index 000000000..ad05b573b --- /dev/null +++ b/lib/77bit/packjt.f90 @@ -0,0 +1,1037 @@ +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) + + ! 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) + 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:) + if(word(1:1).eq.'Q' .and. word(2:2).ge.'A' .and. & + word(2:2).le.'Z') word='3X'//word(2:) + + 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) + + 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) + + 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. + + 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 diff --git a/lib/77bit/parse77.f90 b/lib/77bit/parse77.f90 new file mode 100644 index 000000000..5ba8cd4c7 --- /dev/null +++ b/lib/77bit/parse77.f90 @@ -0,0 +1,178 @@ +subroutine parse77(msg,i3,n3) + + parameter (NSEC=83) !Number of ARRL Sections + parameter (NUSCAN=65) !Number of US states and Canadian provinces/territories + character msg*37 + character*13 w(19),c13 + character*13 call_1,call_2 + character*6 bcall_1,bcall_2,grid6 + character*4 grid4 + character crpt*3,crrpt*4 + character*1 c,c0 + character*3 csec(NSEC),cmult(NUSCAN),section,mult + logical ok1,ok2 + logical is_grid4,is_grid6 + + 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 "/ + + 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 "/ + + 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' + + 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' + + iz=len(trim(msg)) +! Convert to upper case; parse into words. + 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 over leading or 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 + w(k)(n:n)=c !Copy character c into word + c0=c + enddo + iz=j !Message length + nw=k !Number of words in msg + msg(iz+1:)=' ' + +! Check 0.1 (DXpedition mode) + i3=0 + n3=0 + i0=index(msg," RR73; ") + call chkcall(w(1)(1:12),bcall_1,ok1) + call chkcall(w(3)(1:12),bcall_2,ok2) + if(i0.ge.4 .and. i0.le.7 .and. nw.eq.5 .and. ok1 .and. ok2) then + i0=0 + n3=1 !Type 0.1: DXpedition mode + go to 900 + endif + +! Check 0.2 (EU VHF contest exchange) + if(nw.eq.3 .or. nw.eq.4) then + n=-1 + if(nw.ge.2) read(w(nw-1),*,err=2) n +2 if(ok1 .and. n.ge.520001 .and. n.le.594095 .and. is_grid6(w(nw)(1:6))) then + i3=0 + n3=2 !Type 0.2: EU VHF+ Contest + go to 900 + endif + endif + + call chkcall(w(2)(1:12),bcall_2,ok2) + +! Check 0.3 and 0.4 (ARRL Field Day exchange) + if(nw.eq.4 .or. nw.eq.5) then + n=-1 + j=len(trim(w(nw-1)))-1 + if(j.ge.2) read(w(nw-1)(1:j),*,err=4) n !Number of transmitters +4 m=len(trim(w(nw))) !Length of section abbreviation + if(ok1 .and. ok2 .and. n.ge.1 .and. n.le.32 .and. (m.eq.2 .or. m.eq.3)) then + section=' ' + do i=1,NSEC + if(csec(i).eq.w(nw)) then + section=csec(i) + exit + endif + enddo + if(section.ne.' ') then + i3=0 + if(n.ge.1 .and. n.le.16) n3=3 !Type 0.3 ARRL Field Day + if(n.ge.17 .and. n.le.32) n3=4 !Type 0.4 ARRL Field Day + go to 900 + endif + endif + endif + + n3=0 +! Check Type 1 (Standard 77-bit message) and Type 4 (ditto, with a "/P" call) + if(nw.eq.3 .or. nw.eq.4) then + if(ok1 .and. ok2 .and. is_grid4(w(nw)(1:4))) then + if(nw.eq.3 .or. (nw.eq.4 .and. w(3)(1:2).eq.'R ')) then + i3=1 !Type 1: Standard message + if(index(w(1),'/P').ge.4 .or. index(w(2),'/P').ge.4) i3=4 + go to 900 + endif + endif + endif + +! Check Type 2 (ARRL RTTY contest exchange) + if(nw.eq.4 .or. nw.eq.5 .or. nw.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(nw-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 + i3=2 + n3=0 + go to 900 + endif + endif + +! Check Type 3 (One nonstandard call and one hashed call) + if(nw.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) + crrpt=w(nw)(1:4) + i1=1 + if(crrpt(1:1).eq.'R') i1=2 + n=-99 + read(crrpt(i1:),*,err=6) n +6 if(ok1 .and. ok2 .and. n.ne.-99) then + i3=3 + n3=0 + go to 900 + endif + endif + +! It's free text + i3=0 + n3=0 + msg(iz+1:)=' ' + +900 continue + + return +end subroutine parse77 diff --git a/lib/77bit/t1.f90 b/lib/77bit/t1.f90 new file mode 100644 index 000000000..28c99292e --- /dev/null +++ b/lib/77bit/t1.f90 @@ -0,0 +1,54 @@ +program t1 + + real x(13) + real(KIND=16) :: dlong,dlong0 + character wd*13,w*13,error*5 + character c*44 !NB: 44^13 = 2^(70.973) + data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?@$'/ + + nargs=iargc() + if(nargs.ne.1) then + print*,'Usage: t1 "FreeText13"' + print*,' t1 ' + go to 999 + endif + call getarg(1,w) + iters=1 + read(w,*,err=10) iters +10 continue + + do iter=1,iters + if(iters.gt.1) then +! Create a random free-text word + call random_number(x) + do i=1,13 + j=44*x(i) + 1 + w(i:i)=c(j:j) + enddo + endif +! Encode a 13-character free-text message into a 71-bit integer. + dlong=0.d0 + do i=1,13 + n=index(c,w(i:i))-1 + dlong=44.d0*dlong + n + enddo + dlong0=dlong + + ! Decode a a 71-bit integer into a 13-character free-text message. + do i=13,1,-1 + j=mod(dlong,44.d0)+1.d0 + wd(i:i)=c(j:j) + dlong=dlong/44.d0 + enddo + + + error=' ' + if(wd.ne.w) then + error='ERROR' + write(*,1010) w,dlong0,wd,error +1010 format('"',a13,'"',f25.1,2x,'"',a13'"',2x,a5) + endif + if(mod(iter,1000).eq.0) print*,iter + enddo + +999 end program t1 diff --git a/lib/77bit/t2.f90 b/lib/77bit/t2.f90 new file mode 100644 index 000000000..7d42e57e9 --- /dev/null +++ b/lib/77bit/t2.f90 @@ -0,0 +1,26 @@ +program t2 + + character msg*37,msg0*37,cerr*1 + + open(10,file='msgtypes.txt',status='old') + +! Skip over first two lines + read(10,1001) cerr + read(10,1001) cerr +1001 format(a1) + + do iline=1,999 + read(10,1002,end=999) i3,n3,msg +1002 format(i1,i4,1x,a37) + msg0=msg + call parse77(msg,i3a,n3a) + cerr=' ' + if(i3a.ne.i3 .or. n3a.ne.n3 .or. msg.ne.msg0) cerr='*' + write(*,1004) i3,n3,i3a,n3a,cerr,msg +1004 format(i1,3i3,2x,a1,2x,a37) + enddo + +999 end program t2 + +include 'parse77.f90' +include '../chkcall.f90' diff --git a/lib/77bit/t3.f90 b/lib/77bit/t3.f90 new file mode 100644 index 000000000..0b074c5a1 --- /dev/null +++ b/lib/77bit/t3.f90 @@ -0,0 +1,25 @@ +program t3 + character*3 csec + character*70 line + logical eof + + eof=.false. + j=1 + do i=1,83 + read(*,1001,end=1) csec +1001 format(a3) + go to 2 +1 eof=.true. +2 line(j:j+5)='"'//csec//'",' + j=j+6 + if(j.gt.60 .or. i.eq.83 .or.eof) then + line(j:j+2)=' &' + line(j+3:)=' ' + write(*,1010) line +1010 format(a70) + j=1 + endif + if(eof) go to 999 + enddo + +999 end program t3