WSJT-X/lib/qso50/wqenc.f90

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 <name> 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