WSJT-X/lib/packjt.f90

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)

   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:)

   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: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)

   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