From c470611cc98fd656f9be8cc27512baa6c74a6276 Mon Sep 17 00:00:00 2001 From: Joe Taylor Date: Wed, 31 Jan 2018 15:45:06 +0000 Subject: [PATCH] Test program to exercise features of the "WSPR QSO mode" that was tested briefly in 2008. git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/wsjtx@8446 ab8295b8-cf94-4d9e-aec4-7959e3be5d79 --- lib/qso50/g0 | 8 + lib/qso50/pack50.f90 | 26 +++ lib/qso50/packname.f90 | 23 +++ lib/qso50/packprop.f90 | 36 ++++ lib/qso50/packtext2.f90 | 22 +++ lib/qso50/twq.f90 | 18 ++ lib/qso50/unpack50.f90 | 30 ++++ lib/qso50/unpackname.f90 | 20 +++ lib/qso50/unpackpfx.f90 | 35 ++++ lib/qso50/unpackprop.f90 | 28 +++ lib/qso50/unpacktext2.f90 | 17 ++ lib/qso50/wqdec.f90 | 316 ++++++++++++++++++++++++++++++++++ lib/qso50/wqenc.f90 | 346 ++++++++++++++++++++++++++++++++++++++ lib/qso50/wqmsg.txt | 31 ++++ 14 files changed, 956 insertions(+) create mode 100644 lib/qso50/g0 create mode 100644 lib/qso50/pack50.f90 create mode 100644 lib/qso50/packname.f90 create mode 100644 lib/qso50/packprop.f90 create mode 100644 lib/qso50/packtext2.f90 create mode 100644 lib/qso50/twq.f90 create mode 100644 lib/qso50/unpack50.f90 create mode 100644 lib/qso50/unpackname.f90 create mode 100644 lib/qso50/unpackpfx.f90 create mode 100644 lib/qso50/unpackprop.f90 create mode 100644 lib/qso50/unpacktext2.f90 create mode 100644 lib/qso50/wqdec.f90 create mode 100644 lib/qso50/wqenc.f90 create mode 100644 lib/qso50/wqmsg.txt diff --git a/lib/qso50/g0 b/lib/qso50/g0 new file mode 100644 index 000000000..02e2aeb43 --- /dev/null +++ b/lib/qso50/g0 @@ -0,0 +1,8 @@ +gfortran -o twq -Wall -Wno-conversion -fbounds-check twq.f90 \ + ../packjt.f90 wqenc.f90 wqdec.f90 packprop.f90 \ + packname.f90 packtext2.f90 unpackprop.f90 unpackname.f90 \ + unpacktext2.f90 unpackpfx.f90 pack50.f90 unpack50.f90 \ + ../hash.f90 ../deg2grid.f90 ../grid2deg.f90 \ + ../fix_contest_msg.f90 ../to_contest_msg.f90 \ + ../fmtmsg.f90 ../azdist.f90 ../geodist.f90 ../wsprd/nhash.c + \ No newline at end of file diff --git a/lib/qso50/pack50.f90 b/lib/qso50/pack50.f90 new file mode 100644 index 000000000..12c230cd8 --- /dev/null +++ b/lib/qso50/pack50.f90 @@ -0,0 +1,26 @@ +subroutine pack50(n1,n2,dat) + + integer*1 dat(11),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 + diff --git a/lib/qso50/packname.f90 b/lib/qso50/packname.f90 new file mode 100644 index 000000000..5b3936e9c --- /dev/null +++ b/lib/qso50/packname.f90 @@ -0,0 +1,23 @@ +subroutine packname(name,len,n1,n2) + + character*9 name + real*8 dn + + dn=0 + do i=1,len + n=ichar(name(i:i)) + if(n.ge.97 .and. n.le.122) n=n-32 + dn=27*dn + n-64 + enddo + if(len.lt.9) then + do i=len+1,9 + dn=27*dn + enddo + endif + + n2=mod(dn,32768.d0) + dn=dn/32768.d0 + n1=dn + + return +end subroutine packname diff --git a/lib/qso50/packprop.f90 b/lib/qso50/packprop.f90 new file mode 100644 index 000000000..5d22a3780 --- /dev/null +++ b/lib/qso50/packprop.f90 @@ -0,0 +1,36 @@ +subroutine packprop(k,muf,ccur,cxp,n1) + +! Pack propagation indicators into a 21-bit number. + +! k k-index, 0-9; 10="N/A" +! muf muf, 2-60 MHz; 0=N/A, 1="none", 61=">60 MHz" +! ccur up to two current events, each indicated by single +! or double letter. +! cxp zero or one expected event, indicated by single or +! double letter + + character ccur*4,cxp*2 + + j=ichar(ccur(1:1))-64 + if(j.lt.0) j=0 + n1=j + do i=2,4 + if(ccur(i:i).eq.' ') go to 10 + if(ccur(i:i).eq.ccur(i-1:i-1)) then + n1=n1+26 + else + j=ichar(ccur(i:i))-64 + if(j.lt.0) j=0 + n1=53*n1 + j + endif + enddo + +10 j=ichar(cxp(1:1))-64 + if(j.lt.0) j=0 + if(cxp(2:2).eq.cxp(1:1)) j=j+26 + n1=53*n1 + j + n1=11*n1 + k + n1=62*n1 + muf + + return +end subroutine packprop diff --git a/lib/qso50/packtext2.f90 b/lib/qso50/packtext2.f90 new file mode 100644 index 000000000..d54b52fbe --- /dev/null +++ b/lib/qso50/packtext2.f90 @@ -0,0 +1,22 @@ +subroutine packtext2(msg,n1,ng) + + character*8 msg + real*8 dn + character*41 c + data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +./?'/ + + dn=0. + do i=1,8 + do j=1,41 + if(msg(i:i).eq.c(j:j)) go to 10 + enddo + j=37 +10 j=j-1 !Codes should start at zero + dn=41.d0*dn + j + enddo + + ng=mod(dn,32768.d0) + n1=(dn-ng)/32768.d0 + + return +end subroutine packtext2 diff --git a/lib/qso50/twq.f90 b/lib/qso50/twq.f90 new file mode 100644 index 000000000..9fdb2638c --- /dev/null +++ b/lib/qso50/twq.f90 @@ -0,0 +1,18 @@ +program twq + + character*22 msg0,msg + integer*1 data0(11) + + open(10,file='wqmsg.txt',status='old') + write(*,1000) +1000 format(4x,'Encoded message',9x,'Decoded as',12x,'itype'/55('-')) + + do line=1,9999 + read(10,*,end=999) msg0 + call wqenc(msg0,itype,data0) + call wqdec(data0,msg,ntype) + write(*,1100) line,msg0,msg,ntype +1100 format(i2,'.',1x,a22,2x,a22,i3) + enddo + +999 end program twq diff --git a/lib/qso50/unpack50.f90 b/lib/qso50/unpack50.f90 new file mode 100644 index 000000000..101f1abd2 --- /dev/null +++ b/lib/qso50/unpack50.f90 @@ -0,0 +1,30 @@ +subroutine unpack50(dat,n1,n2) + + integer*1 dat(11) + + i=dat(1) + i4=iand(i,255) + n1=ishft(i4,20) + i=dat(2) + i4=iand(i,255) + n1=n1 + ishft(i4,12) + i=dat(3) + i4=iand(i,255) + n1=n1 + ishft(i4,4) + i=dat(4) + i4=iand(i,255) + n1=n1 + iand(ishft(i4,-4),15) + n2=ishft(iand(i4,15),18) + i=dat(5) + i4=iand(i,255) + n2=n2 + ishft(i4,10) + i=dat(6) + i4=iand(i,255) + n2=n2 + ishft(i4,2) + i=dat(7) + i4=iand(i,255) + n2=n2 + iand(ishft(i4,-6),3) + + return +end subroutine unpack50 + diff --git a/lib/qso50/unpackname.f90 b/lib/qso50/unpackname.f90 new file mode 100644 index 000000000..3ae7c5cfd --- /dev/null +++ b/lib/qso50/unpackname.f90 @@ -0,0 +1,20 @@ +subroutine unpackname(n1,n2,name,len) + + character*9 name + real*8 dn + + dn=32768.d0*n1 + n2 + len=0 + do i=9,1,-1 + j=mod(dn,27.d0) + if(j.ge.1) then + name(i:i)=char(64+j) + len=len+1 + else + name(i:i)=' ' + endif + dn=dn/27.d0 + enddo + + return +end subroutine unpackname diff --git a/lib/qso50/unpackpfx.f90 b/lib/qso50/unpackpfx.f90 new file mode 100644 index 000000000..4234e9e93 --- /dev/null +++ b/lib/qso50/unpackpfx.f90 @@ -0,0 +1,35 @@ +subroutine unpackpfx(ng,call1) + + character*12 call1 + character*3 pfx + + if(ng.lt.60000) then +! Add-on prefix of 1 to 3 characters + n=ng + do i=3,1,-1 + nc=mod(n,37) + if(nc.ge.0 .and. nc.le.9) then + pfx(i:i)=char(nc+48) + else if(nc.ge.10 .and. nc.le.35) then + pfx(i:i)=char(nc+55) + else + pfx(i:i)=' ' + endif + n=n/37 + enddo + call1=pfx//'/'//call1 + if(call1(1:1).eq.' ') call1=call1(2:) + if(call1(1:1).eq.' ') call1=call1(2:) + else +! Add-on suffix, one character + i1=index(call1,' ') + nc=ng-60000 + if(nc.ge.0 .and. nc.le.9) then + call1=call1(:i1-1)//'/'//char(nc+48) + else if(nc.ge.10 .and. nc.le.35) then + call1=call1(:i1-1)//'/'//char(nc+55) + endif + endif + + return +end subroutine unpackpfx diff --git a/lib/qso50/unpackprop.f90 b/lib/qso50/unpackprop.f90 new file mode 100644 index 000000000..18cc1f568 --- /dev/null +++ b/lib/qso50/unpackprop.f90 @@ -0,0 +1,28 @@ +subroutine unpackprop(n1,k,muf,ccur,cxp) + + character ccur*4,cxp*2 + + muf=mod(n1,62) + n1=n1/62 + + k=mod(n1,11) + n1=n1/11 + + j=mod(n1,53) + n1=n1/53 + if(j.eq.0) cxp='*' + if(j.ge.1 .and. j.le.26) cxp=char(64+j) + if(j.gt.26) cxp=char(64+j-26)//char(64+j-26) + + j=mod(n1,53) + n1=n1/53 + if(j.eq.0) ccur(2:2)='*' + if(j.ge.1 .and. j.le.26) ccur(2:2)=char(64+j) + if(j.gt.26) ccur(2:3)=char(64+j-26)//char(64+j-26) + j=n1 + if(j.eq.0) ccur(1:1)='*' + if(j.ge.1 .and. j.le.26) ccur(1:1)=char(64+j) + if(j.gt.26) ccur=char(64+j-26)//char(64+j-26)//ccur(2:3) + + return +end subroutine unpackprop diff --git a/lib/qso50/unpacktext2.f90 b/lib/qso50/unpacktext2.f90 new file mode 100644 index 000000000..92dccce50 --- /dev/null +++ b/lib/qso50/unpacktext2.f90 @@ -0,0 +1,17 @@ +subroutine unpacktext2(n1,ng,msg) + + character*22 msg + real*8 dn + character*41 c + data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +./?'/ + + msg=' ' + dn=32768.d0*n1 + ng + do i=8,1,-1 + j=mod(dn,41.d0) + msg(i:i)=c(j+1:j+1) + dn=dn/41.d0 + enddo + + return +end subroutine unpacktext2 diff --git a/lib/qso50/wqdec.f90 b/lib/qso50/wqdec.f90 new file mode 100644 index 000000000..791c78ca2 --- /dev/null +++ b/lib/qso50/wqdec.f90 @@ -0,0 +1,316 @@ +subroutine wqdec(data0,message,ntype) + + use packjt + parameter (N15=32758) + integer*1 data0(11) + character*22 message + character*12 callsign + character*3 cdbm,cf + character*2 crpt + character*4 grid,psfx + character*9 name + character*36 fmt + character*6 cwx(4) + character*7 cwind(5) + character ccur*4,cxp*2 + logical first + character*12 dcall(0:N15-1) + data first/.true./ + data cwx/'CLEAR','CLOUDY','RAIN','SNOW'/ + data cwind/'CALM','BREEZES','WINDY','DRY','HUMID'/ + save first,dcall + + if(first) then + dcall=' ' + first=.false. + endif + + message=' ' + call unpack50(data0,n1,n2) + call unpackcall(n1,callsign,iv2,psfx) + i1=index(callsign,' ') + call unpackgrid(n2/128,grid) + ntype=iand(n2,127) -64 + +! Standard WSPR message (types 0 3 7 10 13 17 ... 60) + nu=mod(ntype,10) + if(ntype.ge.0 .and. ntype.le.60 .and. (nu.eq.0 .or. nu.eq.3 .or. & + nu.eq.7)) then + write(cdbm,'(i3)'),ntype + if(cdbm(1:1).eq.' ') cdbm=cdbm(2:) + if(cdbm(1:1).eq.' ') cdbm=cdbm(2:) + message=callsign(1:i1)//grid//' '//cdbm + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1) + +! "Best DX" WSPR response (type 1) + else if(ntype.eq.1) then + message=grid//' DE '//callsign + +! CQ (msg 3; types 2,4,5) + else if(ntype.eq.2) then + message='CQ '//callsign(:i1)//grid + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1) + else if(ntype.eq.4 .or. ntype.eq.5) then + ng=n2/128 + 32768*(ntype-4) + call unpackpfx(ng,callsign) + message='CQ '//callsign + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1) + +! Reply to CQ (msg #2; type 6) + else if(ntype.eq.6) then + ih=(n2-64-ntype)/128 + if(dcall(ih)(1:1).ne.' ') then + i2=index(dcall(ih),' ') + message='<'//dcall(ih)(:i2-1)//'> '//callsign(:i1-1) + else + message='<...> '//callsign + endif + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! Reply to CQ (msg #2; type 8) + else if(ntype.eq.8) then + message='DE '//callsign(:i1)//grid + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! Reply to CQ, DE pfx/call (msg #2; types 9, 11) + else if(ntype.eq.9 .or. ntype.eq.11) then + ng=n2/128 + 32768*(ntype-9)/2 + call unpackpfx(ng,callsign) + message='DE '//callsign + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! Calls and report (msg #3; types -1 to -9) + else if(ntype.le.-1 .and. ntype.ge.-9) then + write(crpt,1010) -ntype +1010 format('S',i1) + ih=(n2-62-ntype)/128 + if(dcall(ih)(1:1).ne.' ') then + i2=index(dcall(ih),' ') + message=callsign(:i1)//'<'//dcall(ih)(:i2-1)//'> '//crpt + else + message=callsign(:i1)//'<...> '//crpt + endif + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! pfx/call and report (msg #3; types -10 to -27) + else if(ntype.le.-10 .and. ntype.ge.-27) then + ng=n2/128 + nrpt=-ntype-9 + if(ntype.le.-19) then + ng=ng + 32768 + nrpt=-ntype-18 + endif + write(crpt,1010) nrpt + call unpackpfx(ng,callsign) + message=callsign//' '//crpt + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! Calls and R and report (msg #4; types -28 to -36) + else if(ntype.le.-28 .and. ntype.ge.-36) then + write(crpt,1010) -(ntype+27) + ih=(n2-64+28-ntype)/128 + if(dcall(ih)(1:1).ne.' ') then + i2=index(dcall(ih),' ') + message=callsign(:i1)//'<'//dcall(ih)(:i2-1)//'> '//'R '//crpt + else + message=callsign(:i1)//'<...> '//'R '//crpt + endif + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! pfx/call R and report (msg #4; types -37 to -54) + else if(ntype.le.-37 .and. ntype.ge.-54) then + ng=n2/128 + nrpt=-ntype-36 + if(ntype.le.-46) then + ng=ng + 32768 + nrpt=-ntype-45 + endif + write(crpt,1010) nrpt + call unpackpfx(ng,callsign) + message=callsign//' R '//crpt + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! Calls and RRR (msg#5; type 12) + else if(ntype.eq.12) then + ih=(n2-64+28-ntype)/128 + if(dcall(ih)(1:1).ne.' ') then + i2=index(dcall(ih),' ') + message=callsign(:i1)//'<'//dcall(ih)(:i2-1)//'> RRR' + else + message=callsign(:i1)//'<...> RRR' + endif + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! Calls and RRR (msg#5; type 14) + else if(ntype.eq.14) then + ih=(n2-64+28-ntype)/128 + if(dcall(ih)(1:1).ne.' ') then + i2=index(dcall(ih),' ') + message='<'//dcall(ih)(:i2-1)//'> '//callsign(:i1)//'RRR' + else + message='<...> '//callsign(:i1)//' RRR' + endif + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! DE pfx/call and RRR (msg#5; types 15, 16) + else if(ntype.eq.15 .or. ntype.eq.16) then + ng=n2/128 + 32768*(ntype-15) + call unpackpfx(ng,callsign) + message='DE '//callsign//' RRR' + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! TNX [name] 73 GL (msg #6; type 18) + else if(ntype.eq.18) then + ng=(n2-18-64)/128 + call unpackname(n1,ng,name,len) + message='TNX '//name(:len)//' 73 GL' + +! OP [name] 73 GL (msg #6; type 18) + else if(ntype.eq.-56) then + ng=(n2+56-64)/128 + call unpackname(n1,ng,name,len) + message='OP '//name(:len)//' 73 GL' + +! 73 DE [call] [grid] (msg #6; type 19) + else if(ntype.eq.19) then + ng=(n2-19-64)/128 + message='73 DE '//callsign(:i1)//grid + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! 73 DE pfx/call (msg #6; type 21, 22) + else if(ntype.eq.21 .or. ntype.eq.22) then + ng=n2/128 + (ntype-21)*32768 + call unpackpfx(ng,callsign) + i1=index(callsign,' ') + message='73 DE '//callsign + call hash(callsign,i1-1,ih) + dcall(ih)=callsign(:i1-1) + +! [power] W [gain] DBD 73 GL (msg#6; type 24, 25) + else if(ntype.eq.24 .or. ntype.eq.25) then + ng=(n2-24-64)/128 - 32 + i1=1 + if(n1.gt.0) i1=log10(float(n1)) + 1 + i2=1 + if(ng.ge.10) i2=2 + if(ng.lt.0) i2=i2+1 + if(n1.le.3000) then + if(ntype.eq.24) fmt="(i4,' W ',i2,' DBD 73 GL')" + if(ntype.eq.25) fmt="(i4,' W ',i2,' DBD ')" + fmt(3:3)=char(48+i1) + fmt(12:12)=char(48+i2) + if(ng.le.100) then + write(message,fmt) n1,ng + else + if(ng.eq.30000) fmt=fmt(1:8)//"DIPOLE')" + if(ng.eq.30001) fmt=fmt(1:8)//"VERTICAL')" + write(message,fmt) n1 + endif + else + mw=n1-3000 + if(ntype.eq.24) fmt="('0.',i3.3,' W ',i2,' DBD 73 GL')" + if(ntype.eq.25) fmt="('0.',i3.3,' W ',i2,' DBD ')" + fmt(19:19)=char(48+i2) + if(ng.le.100) then + write(message,fmt) mw,ng + else + if(ng.eq.30000) fmt=fmt(1:15)//"DIPOLE')" + if(ng.eq.30001) fmt=fmt(1:15)//"VERTICAL')" + write(message,fmt) n1 + endif + if(index(message,'***').gt.0) go to 700 + endif + +! QRZ call (msg #3; type 26) + else if(ntype.eq.26) then + ng=(n2-24-64)/128 - 32 + message='QRZ '//callsign + +! PSE QSY [nnn] KHZ (msg #6; type 28) + else if(ntype.eq.28) then + if(n1.gt.0) i1=log10(float(n1)) + 1 + fmt="('PSE QSY ',i2,' KHZ')" + fmt(14:14)=char(48+i1) + write(message,fmt) n1 + +! WX wx temp C/F wind (msg #6; type 29) + else if(ntype.eq.29) then + nwx=n1/10000 + ntemp=mod(n1,10000) - 100 + cf=' F ' + if(ntemp.gt.800) then + ntemp=ntemp-1000 + cf=' C ' + endif + n2a=n2/128 + if(nwx.ge.1 .and. nwx.le.4 .and. n2a.ge.1 .and. n2a.le.5) then + write(message,1020) cwx(nwx),ntemp,cf,cwind(n2/128) +1020 format('WX ',a6,i3,a3,a7) + else + message='WX'//' (BadMsg)' + endif + +! Hexadecimal data (type 62) + else if(ntype.eq.62) then + ng=n2/128 + write(message,'(z4.4,z7.7)') ng,n1 + +! Solar/geomagnetic/ionospheric data (type 63) + else if(ntype.eq.63) then + ih=(n2-64-ntype)/128 + if(dcall(ih)(1:1).ne.' ') then + i2=index(dcall(ih),' ') + message='<'//dcall(ih)(:i2-1)//'> ' + else + message='<...> ' + endif + call unpackprop(n1,k,muf,ccur,cxp) + i2=index(message,'>') + write(message(i2+1:),'(i3,i3)') k,muf + message=message(:i2+7)//ccur//' '//cxp + +! [plain text] (msg #6; type -57) + else if(ntype.eq.-57) then + ng=n2/128 + call unpacktext2(n1,ng,message) + else + go to 700 + endif + go to 750 + +! message='' +700 i1=index(callsign,' ') + if(i1.lt.1) i1=12 + message=callsign(:i1)//' (BadMsg)' + +750 do i=1,22 + if(ichar(message(i:i)).eq.0) message(i:i)=' ' + enddo + + do i=22,1,-1 + if(message(i:i).ne.' ') go to 800 + enddo +800 i2=i + do n=1,20 + i1=index(message(:i2),' ') + if(i1.le.0) go to 900 + message=message(1:i1)//message(i1+2:) + i2=i2-1 + enddo + +900 return +end subroutine wqdec diff --git a/lib/qso50/wqenc.f90 b/lib/qso50/wqenc.f90 new file mode 100644 index 000000000..0f6129249 --- /dev/null +++ b/lib/qso50/wqenc.f90 @@ -0,0 +1,346 @@ +subroutine wqenc(msg,ntype,data0) + +! Parse and encode a WSPR message. + + use packjt + parameter (MASK15=32767) + character*22 msg + character*12 call1,call2 + character*4 grid + character*9 name + character ccur*4,cxp*2 + logical lbad1,lbad2 + integer*1 data0(11) + integer nu(0:9) + data nu/0,-1,1,0,-1,2,1,0,-1,1/ + + read(msg,1001,end=1,err=1) ng,n1 +1001 format(z4,z7) + ntype=62 + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) !Pack 8 bits per byte, add tail + go to 900 + +1 if(msg(1:6).eq.'73 DE ') go to 80 + if(index(msg,' W ').gt.0 .and. index(msg,' DBD ').gt.0) go to 90 + if(msg(1:4).eq.'QRZ ') go to 100 + if(msg(1:8).eq.'PSE QSY ') go to 110 + if(msg(1:3).eq.'WX ') go to 120 + +! Standard WSPR message (types 0 3 7 10 13 17 ... 60) + i1=index(msg,' ') + if(i1.lt.4 .or. i1.gt.7) go to 10 + call1=msg(:i1-1) + grid=msg(i1+1:i1+4) + call packcall(call1,n1,lbad1) + call packgrid(grid,ng,lbad2) + if(lbad1 .or. lbad2) go to 10 + ndbm=0 + read(msg(i1+5:),*,err=10,end=800) ndbm + if(ndbm.lt.0 .or. ndbm.gt.60) go to 800 + ndbm=ndbm+nu(mod(ndbm,10)) + n2=128*ng + (ndbm+64) + call pack50(n1,n2,data0) + ntype=ndbm + go to 900 + +! "BestDX" automated WSPR reply (type 1) +10 if(i1.ne.5 .or. msg(5:8).ne.' DE ') go to 20 + grid=msg(1:4) + call packgrid(grid,ng,lbad2) + if(lbad2) go to 800 + call1=msg(9:) + call packcall(call1,n1,lbad1) + if(lbad1) go to 800 + ntype=1 + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) !Pack 8 bits per byte, add tail + go to 900 + +! CQ (msg #1; types 2, 4, 5) +20 if(msg(1:3).ne.'CQ ') go to 30 + if(index(msg,'/').le.0) then + i2=index(msg(4:),' ') + call1=msg(4:i2+3) + grid=msg(i2+4:) + call packcall(call1,n1,lbad1) + if(lbad1) go to 30 + call packgrid(grid,ng,lbad2) + if(lbad2) go to 30 + ntype=2 + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) + else + ntype=4 ! or 5 + call1=msg(4:) + call packpfx(call1,n1,ng,nadd) + ntype=ntype+nadd + n2=128*ng + ntype + 64 + call pack50(n1,n2,data0) + endif + go to 900 + +! Reply to CQ (msg #2; types 6,8,9,11) +30 if(msg(1:1).ne.'<' .and. msg(1:3).ne.'DE ') go to 40 + if(index(msg,' RRR ').gt.0) go to 50 + if(msg(1:1).eq.'<') then + ntype=6 + i1=index(msg,'>') + call1=msg(2:i1-1) + read(msg(i1+1:),*,err=31,end=31) k,muf,ccur,cxp + go to 130 +31 call2=msg(i1+2:) + call hash(call1,i1-2,ih) + call packcall(call2,n1,lbad1) + n2=128*ih + (ntype+64) + call pack50(n1,n2,data0) + else + i1=index(msg(4:),' ') + call1=msg(4:i1+2) + if(index(msg,'/').le.0) then + ntype=8 + ih=0 + call packcall(call1,n1,lbad1) + grid=msg(i1+4:i1+7) + call packgrid(grid,ng,lbad2) + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) + else + ntype=9 ! or 11 + call1=msg(4:) + call packpfx(call1,n1,ng,nadd) + ntype=ntype + 2*nadd + n2=128*ng + ntype + 64 + call pack50(n1,n2,data0) + endif + endif + go to 900 + +! Call(s) + report (msg #3; types -1 to -27) +! Call(s) + R + report (msg #4; types -28 to -54) +40 if(index(msg,' RRR').gt.0) go to 50 + i1=index(msg,'<') + if(i1.gt.0 .and. (i1.lt.5 .or. i1.gt.8)) go to 50 + i2=index(msg,'/') + if(i2.gt.0 .and.i2.le.4) then + ntype=-10 ! -10 to -27 + i0=index(msg,' ') + call1=msg(:i0-1) + call packpfx(call1,n1,ng,nadd) + ntype=ntype - 9*nadd + i2=index(msg,' ') + i3=index(msg,' R ') + if(i3.gt.0) i2=i2+2 !-28 to -36 + read(msg(i2+2:i2+2),*,end=800,err=800) nrpt + ntype=ntype - (nrpt-1) + if(i3.gt.0) ntype=ntype-27 + n2=128*ng + ntype + 64 + call pack50(n1,n2,data0) + go to 900 + else if(i1.eq.0) then + go to 50 + endif + call1=msg(:i1-2) !-1 to -9 + i2=index(msg,'>') + call2=msg(i1+1:i2-1) + call hash(call2,i2-i1-1,ih) + i3=index(msg,' R ') + if(i3.gt.0) i2=i2+2 !-28 to -36 + read(msg(i2+3:i2+3),*,end=42,err=42) nrpt + go to 43 +42 nrpt=1 +43 ntype=-nrpt + if(i3.gt.0) ntype=-(nrpt+27) + call packcall(call1,n1,lbad1) + n2=128*ih + (ntype+64) + call pack50(n1,n2,data0) + go to 900 + +50 i0=index(msg,'<') + if(i0.le.0 .and. msg(1:3).ne.'DE ') go to 60 + i3=index(msg,' RRR') + if(i3.le.0) go to 60 +! Call or calls and RRR (msg#5; type2 12,14,15,16) + i0=index(msg,'<') + if(i0.eq.1) then + if(index(msg,'/').le.0) then + ntype=14 + i1=index(msg,'>') + call1=msg(2:i1-1) + call2=msg(i1+2:) + i2=index(call2,' ') + call2=call2(:i2-1) + call packcall(call2,n1,lbad1) + call hash(call1,i1-2,ih) + n2=128*ih + (ntype+64) + call pack50(n1,n2,data0) + else + stop '0002' + endif + else if(i0.ge.5 .and. i0.le.8) then + if(index(msg,'/').le.0) then + ntype=12 + i1=index(msg,'>') + call1=msg(:i0-2) + call2=msg(i0+1:i1-1) + call packcall(call1,n1,lbad1) + call hash(call2,i1-i0-1,ih) + n2=128*ih + (ntype+64) + call pack50(n1,n2,data0) + else + stop '0002' + endif + else + i1=index(msg(4:),' ') + call1=msg(4:i1+2) + if(index(msg,'/').le.0) then + ntype=9 + grid=msg(i1+4:i1+7) + else + ntype=15 ! or 16 + call1=msg(4:) + i0=index(call1,' ') + call1=call1(:i0-1) + call packpfx(call1,n1,ng,nadd) + ntype=ntype+nadd + n2=128*ng + ntype + 64 + call pack50(n1,n2,data0) + endif + endif + go to 900 + +! TNX 73 GL (msg #6; type 18 ...) +60 if(msg(1:4).ne.'TNX ') go to 70 + ntype=18 + n1=0 + i2=index(msg(5:),' ') + name=msg(5:i2+4) + call packname(name,i2-1,n1,ng) + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) + go to 900 + +! TNX name 73 GL (msg #6; type -56 ...) +70 if(msg(1:3).ne.'OP ') go to 80 + ntype=-56 + n1=0 + i2=index(msg(4:),' ') + name=msg(4:i2+3) + call packname(name,i2-1,n1,ng) + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) + go to 900 + +! 73 DE call grid (msg #6; type 19) +80 if(msg(1:6).ne.'73 DE ') go to 90 + ntype=19 + i1=index(msg(7:),' ') + call1=msg(7:) + if(index(call1,'/').le.0) then + i1=index(call1,' ') + grid=call1(i1+1:) + call1=call1(:i1-1) + call packcall(call1,n1,lbad1) + call packgrid(grid,ng,lbad2) + if(lbad1 .or. lbad2) go to 800 + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) + go to 900 + else + ntype=21 ! or 22 + call packpfx(call1,n1,ng,nadd) + ntype=ntype + nadd + n2=128*ng + ntype + 64 + call pack50(n1,n2,data0) + go to 900 + endif + +! [pwr] W [gain] DBD [73 GL] (msg #6; types 24, 25) +90 if(index(msg,' W ').le.0) go to 140 + ntype=25 + if(index(msg,' DBD 73 GL').gt.0) ntype=24 + i1=index(msg,' ') + read(msg(:i1-1),*,end=800,err=800) watts + if(watts.ge.1.0) nwatts=watts + if(watts.lt.1.0) nwatts=3000 + nint(1000.*watts) + if(index(msg,'DIPOLE').gt.0) then + ndbd=30000 + else if(index(msg,'VERTICAL').gt.0) then + ndbd=30001 + else + i2=index(msg(i1+3:),' ') + read(msg(i1+3:i1+i2+1),*,end=800,err=800) ndbd + endif + n1=nwatts + ng=ndbd + 32 + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) + go to 900 + +! QRZ call (msg #3; type 26) +100 call1=msg(5:) + call packcall(call1,n1,lbad1) + if(lbad1) go to 800 + ntype=26 + n2=ntype+64 + call pack50(n1,n2,data0) + go to 900 + +! PSE QSY [nnn] KHZ (msg #6; type 28) +110 ntype=28 + read(msg(9:),*,end=800,err=800) n1 + n2=ntype+64 + call pack50(n1,n2,data0) + go to 900 + +! WX wx temp C|F wind (msg #6; type 29) +120 ntype=29 + if(index(msg,' CLEAR ').gt.0) then + i1=10 + n1=10000 + else if(index(msg,' CLOUDY ').gt.0) then + i1=11 + n1=20000 + else if(index(msg,' RAIN ').gt.0) then + i1=9 + n1=30000 + else if(index(msg,' SNOW ').gt.0) then + i1=9 + n1=40000 + endif + read(msg(i1:),*,err=800,end=800) ntemp + ntemp=ntemp+100 + i1=index(msg,' C ') + if(i1.gt.0) ntemp=ntemp+1000 + n1=n1+ntemp + if(index(msg,' CALM').gt.0) ng=1 + if(index(msg,' BREEZES').gt.0) ng=2 + if(index(msg,' WINDY').gt.0) ng=3 + if(index(msg,' DRY').gt.0) ng=4 + if(index(msg,' HUMID').gt.0) ng=5 + + n2=128*ng + (ntype+64) + call pack50(n1,n2,data0) + + go to 900 + +! Solar/geomagnetic/ionospheric data +130 ntype=63 + call packprop(k,muf,ccur,cxp,n1) + call hash(call1,i1-2,ih) + n2=128*ih + ntype + 64 + call pack50(n1,n2,data0) + go to 900 + +140 continue + +! Plain text +800 ntype=-57 + call packtext2(msg(:8),n1,ng) + n2=128*ng + ntype + 64 + call pack50(n1,n2,data0) + go to 900 + +900 continue + return +end subroutine wqenc diff --git a/lib/qso50/wqmsg.txt b/lib/qso50/wqmsg.txt new file mode 100644 index 000000000..9f509b3eb --- /dev/null +++ b/lib/qso50/wqmsg.txt @@ -0,0 +1,31 @@ +"CQ K1JT FN20" +"CQ PJ4/K1JT" +" W6CQZ" +"DE W6CQZ CM87" +"DE PJ4/K1JT" +"W6CQZ S4" +"QRZ K1JT" +"PJ4/W6CQZ S4" +"K1JT R S3" +"PJ4/K1JT R S3" +" K1JT RRR" +"W6CQZ RRR" +"DE PJ4/K1JT RRR" +"73 DE W6CQZ CM87" +"73 DE PJ4/K1JT" +"TNX VICTORIA 73 GL" +"OP HARRY 73 GL" +"5 W DIPOLE" +"10 W VERTICAL" +"1 W 0 DBD" +"1500 W 21 DBD 73 GL" +"PSE QSY 1811 KHZ" +"WX SNOW -5 C CALM" +"CUL JACK" +"." +"CQ K1JT FN20" +" W6CQZ" +"W6CQZ S4" +"K1JT R S3" +" K1JT RRR" +"TNX JOE 73 GL"