WSJT-X/lib/wsprcode/wspr_old_subs.f90

!-------------------------------------------------------------------------------
!
! This file is part of the WSPR application, Weak Signal Propagation Reporter
!
! File Name:    wspr_old_subs.f90
! Description:  Utility subroutines from WSPR 2.0
!
! Copyright (C) 2001-2014 Joseph Taylor, K1JT
! License: GPL-3
!
! This program is free software; you can redistribute it and/or modify it under
! the terms of the GNU General Public License as published by the Free Software
! Foundation; either version 3 of the License, or (at your option) any later
! version.
!
! This program is distributed in the hope that it will be useful, but WITHOUT
! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
! FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
! details.
!
! You should have received a copy of the GNU General Public License along with
! this program; if not, write to the Free Software Foundation, Inc., 51 Franklin
! Street, Fifth Floor, Boston, MA 02110-1301, USA.
!
!-------------------------------------------------------------------------------

subroutine deg2grid(dlong0,dlat,grid)

  real dlong                        !West longitude (deg)
  real dlat                         !Latitude (deg)
  character grid*6

  dlong=dlong0
  if(dlong.lt.-180.0) dlong=dlong+360.0
  if(dlong.gt.180.0) dlong=dlong-360.0

! Convert to units of 5 min of longitude, working east from 180 deg.
  nlong=60.0*(180.0-dlong)/5.0
  n1=nlong/240                      !20-degree field
  n2=(nlong-240*n1)/24              !2 degree square
  n3=nlong-240*n1-24*n2             !5 minute subsquare
  grid(1:1)=char(ichar('A')+n1)
  grid(3:3)=char(ichar('0')+n2)
  grid(5:5)=char(ichar('a')+n3)

! Convert to units of 2.5 min of latitude, working north from -90 deg.
  nlat=60.0*(dlat+90)/2.5
  n1=nlat/240                       !10-degree field
  n2=(nlat-240*n1)/24               !1 degree square
  n3=nlat-240*n1-24*n2              !2.5 minuts subsquare
  grid(2:2)=char(ichar('A')+n1)
  grid(4:4)=char(ichar('0')+n2)
  grid(6:6)=char(ichar('a')+n3)

  return
end subroutine deg2grid

subroutine encode232(dat,nbytes,symbol,maxsym)

! Convolutional encoder for a K=32, r=1/2 code.

  integer*1 dat(nbytes)             !User data, packed 8 bits per byte
  integer*1 symbol(maxsym)          !Channel symbols, one bit per byte
  integer*1 i1

! Layland-Lushbaugh polynomials for a K=32, r=1/2 convolutional code,
! and 8-bit parity lookup table.

  data npoly1/-221228207/,npoly2/-463389625/
  integer*1 partab(0:255)
  data partab/                 &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0/

  nstate=0
  k=0
  do j=1,nbytes
     do i=7,0,-1
        i1=dat(j)
        i4=i1
        if (i4.lt.0) i4=i4+256
        nstate=ior(ishft(nstate,1),iand(ishft(i4,-i),1))
        n=iand(nstate,npoly1)
        n=ieor(n,ishft(n,-16))
        k=k+1
        symbol(k)=partab(iand(ieor(n,ishft(n,-8)),255))
        n=iand(nstate,npoly2)
        n=ieor(n,ishft(n,-16))
        k=k+1
        symbol(k)=partab(iand(ieor(n,ishft(n,-8)),255))
     enddo
  enddo

  return
end subroutine encode232

subroutine fano232(symbol,nbits,mettab,ndelta,maxcycles,dat,ncycles,metric,ierr)

! Sequential decoder for K=32, r=1/2 convolutional code using 
! the Fano algorithm.  Translated from C routine for same purpose
! written by Phil Karn, KA9Q.

  parameter (MAXBITS=103)
  parameter (MAXDAT=(MAXBITS+7)/8)
  integer*1 symbol(0:2*MAXBITS-1)
  integer*1 dat(MAXDAT)               !Decoded user data, 8 bits per byte
  integer mettab(0:255,0:1)           !Metric table

! These were the "node" structure in Karn's C code:
  integer nstate(0:MAXBITS-1)      !Encoder state of next node
  integer gamma(0:MAXBITS-1)       !Cumulative metric to this node
  integer metrics(0:3,0:MAXBITS-1) !Metrics indexed by all possible Tx syms
  integer tm(0:1,0:MAXBITS-1)      !Sorted metrics for current hypotheses
  integer ii(0:MAXBITS-1)          !Current branch being tested

  logical noback

! Layland-Lushbaugh polynomials for a K=32, r=1/2 convolutional code,
! and 8-bit parity lookup table.

  data npoly1/-221228207/,npoly2/-463389625/
  integer*1 partab(0:255)
  data partab/                 &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       0, 1, 1, 0, 1, 0, 0, 1, &
       1, 0, 0, 1, 0, 1, 1, 0/

  ntail=nbits-31

! Compute all possible branch metrics for each symbol pair.
! This is the only place we actually look at the raw input symbols
  i4a=0
  i4b=0
  do np=0,nbits-1
     j=2*np
     i4a=symbol(j)
     i4b=symbol(j+1)
     if (i4a.lt.0) i4a=i4a+256
     if (i4b.lt.0) i4b=i4b+256
     metrics(0,np) = mettab(i4a,0) + mettab(i4b,0)
     metrics(1,np) = mettab(i4a,0) + mettab(i4b,1)
     metrics(2,np) = mettab(i4a,1) + mettab(i4b,0)
     metrics(3,np) = mettab(i4a,1) + mettab(i4b,1)
  enddo

  np=0
  nstate(np)=0

! Compute and sort branch metrics from the root node
  n=iand(nstate(np),npoly1)
  n=ieor(n,ishft(n,-16))
  lsym=partab(iand(ieor(n,ishft(n,-8)),255))
  n=iand(nstate(np),npoly2)
  n=ieor(n,ishft(n,-16))
  lsym=lsym+lsym+partab(iand(ieor(n,ishft(n,-8)),255))
  m0=metrics(lsym,np)
  m1=metrics(ieor(3,lsym),np)
  if(m0.gt.m1) then
     tm(0,np)=m0                      !0-branch has better metric
     tm(1,np)=m1
  else
     tm(0,np)=m1                      !1-branch is better
     tm(1,np)=m0
     nstate(np)=nstate(np) + 1        !Set low bit
  endif

! Start with best branch
  ii(np)=0
  gamma(np)=0
  nt=0

! Start the Fano decoder
  do i=1,nbits*maxcycles
! Look forward
     ngamma=gamma(np) + tm(ii(np),np)
     if(ngamma.ge.nt) then

! Node is acceptable.  If first time visiting this node, tighten threshold:
        if(gamma(np).lt.(nt+ndelta)) nt=nt +                     &
             ndelta * ((ngamma-nt)/ndelta)

! Move forward
        gamma(np+1)=ngamma
        nstate(np+1)=ishft(nstate(np),1)
        np=np+1
        if(np.eq.nbits-1) go to 100     !We're done!

        n=iand(nstate(np),npoly1)
        n=ieor(n,ishft(n,-16))
        lsym=partab(iand(ieor(n,ishft(n,-8)),255))
        n=iand(nstate(np),npoly2)
        n=ieor(n,ishft(n,-16))
        lsym=lsym+lsym+partab(iand(ieor(n,ishft(n,-8)),255))
            
        if(np.ge.ntail) then
           tm(0,np)=metrics(lsym,np)      !We're in the tail, all zeros
        else
           m0=metrics(lsym,np)
           m1=metrics(ieor(3,lsym),np)
           if(m0.gt.m1) then
              tm(0,np)=m0                 !0-branch has better metric
              tm(1,np)=m1
           else
              tm(0,np)=m1                 !1-branch is better
              tm(1,np)=m0
              nstate(np)=nstate(np) + 1   !Set low bit
           endif
        endif

        ii(np)=0                          !Start with best branch
        go to 99
     endif

! Threshold violated, can't go forward
10   noback=.false.
     if(np.eq.0) noback=.true.
     if(np.gt.0) then
        if(gamma(np-1).lt.nt) noback=.true.
     endif

     if(noback) then
! Can't back up, either.  Relax threshold and look forward again 
! to a better branch.
        nt=nt-ndelta
        if(ii(np).ne.0) then
           ii(np)=0
           nstate(np)=ieor(nstate(np),1)
        endif
        go to 99
     endif

! Back up
     np=np-1
     if(np.lt.ntail .and. ii(np).ne.1) then
! Search the next best branch
        ii(np)=ii(np)+1
        nstate(np)=ieor(nstate(np),1)
        go to 99
     endif
     go to 10
99   continue
  enddo
  i=nbits*maxcycles

100 metric=gamma(np)                       !Final path metric

! Copy decoded data to user's buffer
  nbytes=(nbits+7)/8
  np=7
  do j=1,nbytes-1
     i4a=nstate(np)
     dat(j)=i4a
     np=np+8
  enddo
  dat(nbytes)=0

  ncycles=i+1
  ierr=0
  if(i.ge.maxcycles*nbits) ierr=-1

  return
end subroutine fano232

subroutine grid2deg(grid0,dlong,dlat)

! Converts Maidenhead grid locator to degrees of West longitude
! and North latitude.

  character*6 grid0,grid
  character*1 g1,g2,g3,g4,g5,g6

  grid=grid0
  i=ichar(grid(5:5))
  if(grid(5:5).eq.' ' .or. i.le.64 .or. i.ge.128) grid(5:6)='mm'

  if(grid(1:1).ge.'a' .and. grid(1:1).le.'z') grid(1:1)=            &
       char(ichar(grid(1:1))+ichar('A')-ichar('a'))
  if(grid(2:2).ge.'a' .and. grid(2:2).le.'z') grid(2:2)=            &
       char(ichar(grid(2:2))+ichar('A')-ichar('a'))
  if(grid(5:5).ge.'A' .and. grid(5:5).le.'Z') grid(5:5)=            &
       char(ichar(grid(5:5))-ichar('A')+ichar('a'))
  if(grid(6:6).ge.'A' .and. grid(6:6).le.'Z') grid(6:6)=            &
       char(ichar(grid(6:6))-ichar('A')+ichar('a'))

  g1=grid(1:1)
  g2=grid(2:2)
  g3=grid(3:3)
  g4=grid(4:4)
  g5=grid(5:5)
  g6=grid(6:6)

  nlong = 180 - 20*(ichar(g1)-ichar('A'))
  n20d = 2*(ichar(g3)-ichar('0'))
  xminlong = 5*(ichar(g5)-ichar('a')+0.5)
  dlong = nlong - n20d - xminlong/60.0
  nlat = -90+10*(ichar(g2)-ichar('A')) + ichar(g4)-ichar('0')
  xminlat = 2.5*(ichar(g6)-ichar('a')+0.5)
  dlat = nlat + xminlat/60.0

  return
end subroutine grid2deg

subroutine hash(string,len,ihash)

  parameter (MASK15=32767)
  character*(*) string
  integer*1 ic(12)

     do i=1,len
        ic(i)=ichar(string(i:i))
     enddo
     i=nhash(ic,len,146)
     ihash=iand(i,MASK15)

!     print*,'C',ihash,len,string
  return
end subroutine hash

subroutine inter_mept(id,ndir)

! Interleave (ndir=1) or de-interleave (ndir=-1) the array id.

  integer*1 id(0:161),itmp(0:161)
  integer j0(0:161)
  logical first
  data first/.true./
  save

  if(first) then
! Compute the interleave table using bit reversal.
     k=-1
     do i=0,255
        n=0
        ii=i
        do j=0,7
           n=n+n
           if(iand(ii,1).ne.0) n=n+1
           ii=ii/2
        enddo
        if(n.le.161) then
           k=k+1
           j0(k)=n
        endif
     enddo
     first=.false.
  endif

  if(ndir.eq.1) then
     do i=0,161
        itmp(j0(i))=id(i)
     enddo
  else
     do i=0,161
        itmp(i)=id(j0(i))
     enddo
  endif

  do i=0,161
     id(i)=itmp(i)
  enddo

  return
end subroutine inter_mept

function nchar(c)

! Convert ASCII number, letter, or space to 0-36 for callsign packing.

  character c*1
  data 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(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

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,digit*10
  logical text
  data digit/'0123456789'/

  text=.false.

! Work-around for Swaziland prefix:
  if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6)

  if(callsign(1:3).eq.'CQ ') then
     ncall=NBASE + 1
     if(callsign(4:4).ge.'0' .and. callsign(4:4).le.'9' .and.       &
          callsign(5:5).ge.'0' .and. callsign(5:5).le.'9' .and.     &
          callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then
        nfreq=100*(ichar(callsign(4:4))-48) +                       &
             10*(ichar(callsign(5:5))-48) +                         &
             ichar(callsign(6:6))-48
        ncall=NBASE + 3 + nfreq
     endif
     return
  else if(callsign(1:4).eq.'QRZ ') then
     ncall=NBASE + 2
     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
  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 packgrid(grid,ng,text)

  parameter (NGBASE=180*180)
  character*4 grid
  logical text

  text=.false.
  if(grid.eq.'    ') go to 90                 !Blank grid is OK

! Test for numerical signal report, etc.
  if(grid(1:1).eq.'-') then
     n=10*(ichar(grid(2:2))-48) + ichar(grid(3:3)) - 48
     ng=NGBASE+1+n
     go to 100
  else if(grid(1:2).eq.'R-') then
     n=10*(ichar(grid(3:3))-48) + ichar(grid(4:4)) - 48
     if(n.eq.0) go to 90
     ng=NGBASE+31+n
     go to 100
  else if(grid(1:2).eq.'RO') then
     ng=NGBASE+62
     go to 100
  else if(grid(1:3).eq.'RRR') then
     ng=NGBASE+63
     go to 100
  else if(grid(1:2).eq.'73') then
     ng=NGBASE+64
     go to 100
  endif

  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 100

  call grid2deg(grid//'mm',dlong,dlat)
  long=dlong
  lat=dlat+ 90.0
  ng=((long+180)/2)*180 + lat
  go to 100

90 ng=NGBASE + 1

100 return
end subroutine packgrid

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
     if(pfx(3:3).eq.' ') pfx=' '//pfx
     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

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

subroutine unpackcall(ncall,word)

  character word*12,c*37

  data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/

  n=ncall
  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:)

999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:)
  return
end subroutine unpackcall

subroutine unpackgrid(ng,grid)

  parameter (NGBASE=180*180)
  character grid*4,grid6*6,digit*10
  data digit/'0123456789'/

  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(1:4) !XXX explicitly truncate this -db
  go to 100

10 n=ng-NGBASE-1
  if(n.ge.1 .and.n.le.30) then
     grid(1:1)='-'
     grid(2:2)=char(48+n/10)
     grid(3:3)=char(48+mod(n,10))
  else if(n.ge.31 .and.n.le.60) then
     n=n-30
     grid(1:2)='R-'
     grid(3:3)=char(48+n/10)
     grid(4:4)=char(48+mod(n,10))
  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

100 return
end subroutine unpackgrid

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 or teo characters
     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)
     else if(nc.ge.36 .and. nc.le.125) then
        nc1=(nc-26)/10
        nc2=mod(nc-26,10)
        call1=call1(:i1-1)//'/'//char(nc1+48)//char(nc2+48)
     endif
  endif

  return
end subroutine unpackpfx

subroutine wqdecode(data0,message,ntype)

  parameter (N15=32768)
  integer*1 data0(11)
  character*22 message
  character*12 callsign
  character*3 cdbm
  character grid4*4,grid6*6
  logical first
  character*12 dcall(0:N15-1)
  data first/.true./
  save first,dcall

! May want to have a timeout (say, one hour?) on calls fetched 
! from the hash table.

  if(first) then
     dcall='            '
     first=.false.
  endif

  message='                      '
  call unpack50(data0,n1,n2)
  call unpackcall(n1,callsign)
  i1=index(callsign,' ')
  call unpackgrid(n2/128,grid4)
  ntype=iand(n2,127) -64

! Standard WSPR message (types 0 3 7 10 13 17 ... 60)
  if(ntype.ge.0 .and. ntype.le.62) then
     nu=mod(ntype,10)
     if(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)//grid4//' '//cdbm
        call hash(callsign,i1-1,ih)
        dcall(ih)=callsign(:i1)
     else
        nadd=nu
        if(nu.gt.3) nadd=nu-3
        if(nu.gt.7) nadd=nu-7
        ng=n2/128 + 32768*(nadd-1)
        call unpackpfx(ng,callsign)
        ndbm=ntype-nadd
        write(cdbm,'(i3)'),ndbm
        if(cdbm(1:1).eq.' ') cdbm=cdbm(2:)
        if(cdbm(1:1).eq.' ') cdbm=cdbm(2:)
        i2=index(callsign,' ')
        message=callsign(:i2)//cdbm
        call hash(callsign,i2-1,ih)
        dcall(ih)=callsign(:i2)
     endif
  else if(ntype.lt.0) then
     ndbm=-(ntype+1)
     grid6=callsign(6:6)//callsign(1:5)
     ih=(n2-ntype-64)/128
     callsign=dcall(ih)
     write(cdbm,'(i3)'),ndbm
     if(cdbm(1:1).eq.' ') cdbm=cdbm(2:)
     if(cdbm(1:1).eq.' ') cdbm=cdbm(2:)
     i2=index(callsign,' ')
     if(dcall(ih)(1:1).ne.' ') then
        message='<'//callsign(:i2-1)//'> '//grid6//' '//cdbm
     else
        message='<...> '//grid6//' '//cdbm
     endif
  endif

  return
end subroutine wqdecode

subroutine wqencode(msg,ntype,data0)

!  Parse and encode a WSPR message.

  parameter (MASK15=32767)
  character*22 msg
  character*12 call1,call2
  character grid4*4,grid6*6
  logical lbad1,lbad2
  integer*1 data0(11)
  integer nu(0:9)
  data nu/0,-1,1,0,-1,2,1,0,-1,1/

! Standard WSPR message (types 0 3 7 10 13 17 ... 60)
  i1=index(msg,' ')
  i2=index(msg,'/')
  i3=index(msg,'<')
  call1=msg(:i1-1)
  if(i1.lt.3 .or. i1.gt.7 .or. i2.gt.0 .or. i3.gt.0) go to 10
  grid4=msg(i1+1:i1+4)
  call packcall(call1,n1,lbad1)
  call packgrid(grid4,ng,lbad2)
  if(lbad1 .or. lbad2) go to 10
  ndbm=0
  read(msg(i1+5:),*) ndbm
  if(ndbm.lt.0) ndbm=0
  if(ndbm.gt.60) ndbm=60
  ndbm=ndbm+nu(mod(ndbm,10))
  n2=128*ng + (ndbm+64)
  call pack50(n1,n2,data0)
  ntype=ndbm
  go to 900

10 if(i2.ge.2 .and. i3.lt.1) then
     call packpfx(call1,n1,ng,nadd)
     ndbm=0
     read(msg(i1+1:),*) ndbm
     if(ndbm.lt.0) ndbm=0
     if(ndbm.gt.60) ndbm=60
     ndbm=ndbm+nu(mod(ndbm,10))
     ntype=ndbm + 1 + nadd
     n2=128*ng + ntype + 64
     call pack50(n1,n2,data0)
  else if(i3.eq.1) then
     i4=index(msg,'>')
     call1=msg(2:i4-1)
     call hash(call1,i4-2,ih)
     grid6=msg(i1+1:i1+6)
     call2=grid6(2:6)//grid6(1:1)//'      '
     call packcall(call2,n1,lbad1)
     ndbm=0
     read(msg(i1+8:),*) ndbm
     if(ndbm.lt.0) ndbm=0
     if(ndbm.gt.60) ndbm=60
     ndbm=ndbm+nu(mod(ndbm,10))
     ntype=-(ndbm+1)
     n2=128*ih + ntype + 64
     call pack50(n1,n2,data0)
  endif
  go to 900

900 continue
  return
end subroutine wqencode