1module packjt77 2 3! These variables are accessible from outside via "use packjt77": 4 parameter (MAXHASH=1000,MAXRECENT=10) 5 character (len=13), dimension(0:1023) :: calls10='' 6 character (len=13), dimension(0:4095) :: calls12='' 7 character (len=13), dimension(1:MAXHASH) :: calls22='' 8 character (len=13), dimension(1:MAXRECENT) :: recent_calls='' 9 character (len=13) :: mycall13='' 10 character (len=13) :: dxcall13='' 11 integer, dimension(1:MAXHASH) :: ihash22=-1 12 integer :: nzhash=0 13 integer n28a,n28b 14 15 contains 16 17subroutine hash10(n10,c13) 18 19 character*13 c13 20 21 c13='<...>' 22 if(n10.lt.0 .or. n10.gt.1023) return 23 if(len(trim(calls10(n10))).gt.0) then 24 c13=calls10(n10) 25 c13='<'//trim(c13)//'>' 26 endif 27 return 28 29end subroutine hash10 30 31subroutine hash12(n12,c13) 32 33 character*13 c13 34 35 c13='<...>' 36 if(n12.lt.0 .or. n12.gt.4095) return 37 if(len(trim(calls12(n12))).gt.0) then 38 c13=calls12(n12) 39 c13='<'//trim(c13)//'>' 40 endif 41 return 42 43end subroutine hash12 44 45 46subroutine hash22(n22,c13) 47 48 character*13 c13 49 50 c13='<...>' 51 do i=1,nzhash 52 if(ihash22(i).eq.n22) then 53 c13=calls22(i) 54 c13='<'//trim(c13)//'>' 55 go to 900 56 endif 57 enddo 58 59900 return 60end subroutine hash22 61 62 63integer function ihashcall(c0,m) 64 65 integer*8 n8 66 character*13 c0 67 character*38 c 68 data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ 69 70 n8=0 71 do i=1,11 72 j=index(c,c0(i:i)) - 1 73 n8=38*n8 + j 74 enddo 75 ihashcall=ishft(47055833459_8*n8,m-64) 76 77 return 78end function ihashcall 79 80subroutine save_hash_call(c13,n10,n12,n22) 81 82 character*13 c13,cw 83 84 cw=c13 85 if(cw(1:1).eq.' ' .or. cw(1:5).eq.'<...>') return 86 if(cw(1:1).eq.'<') cw=cw(2:) 87 i=index(cw,'>') 88 if(i.gt.0) cw(i:)=' ' 89 90 if(len(trim(cw)) .lt. 3) return 91 92 n10=ihashcall(cw,10) 93 if(n10.ge.0 .and. n10 .le. 1023 .and. cw.ne.mycall13) calls10(n10)=cw 94 95 n12=ihashcall(cw,12) 96 if(n12.ge.0 .and. n12 .le. 4095 .and. cw.ne.mycall13) calls12(n12)=cw 97 98 n22=ihashcall(cw,22) 99 if(any(ihash22.eq.n22)) then ! If entry exists, make sure callsign is the most recently received one 100 where(ihash22.eq.n22) calls22=cw 101 go to 900 102 endif 103 104! New entry: move table down, making room for new one at the top 105 ihash22(MAXHASH:2:-1)=ihash22(MAXHASH-1:1:-1) 106 107! Add the new entry 108 calls22(MAXHASH:2:-1)=calls22(MAXHASH-1:1:-1) 109 ihash22(1)=n22 110 calls22(1)=cw 111 if(nzhash.lt.MAXHASH) nzhash=nzhash+1 112900 continue 113 return 114end subroutine save_hash_call 115 116subroutine pack77(msg0,i3,n3,c77) 117 118 use packjt 119 character*37 msg,msg0 120 character*18 c18 121 character*13 w(19) 122 character*77 c77 123 integer nw(19) 124 integer ntel(3) 125 126 msg=msg0 127 i3_hint=i3 128 n3_hint=n3 129 i3=-1 130 n3=-1 131 if(i3_hint.eq.0 .and. n3_hint.eq.5) go to 5 132 133! Convert msg to upper case; collapse multiple blanks; parse into words. 134 call split77(msg,nwords,nw,w) 135 if(msg(1:3).eq.'CQ ' .or. msg(1:3).eq.'DE ' .or. msg(1:4).eq.'QRZ ') go to 100 136 137! Check 0.1 (DXpedition mode) 138 call pack77_01(nwords,w,i3,n3,c77) 139 if(i3.ge.0 .or. n3.ge.1) go to 900 140! Check 0.2 (EU VHF contest exchange) 141! call pack77_02(nwords,w,i3,n3,c77) 142! if(i3.ge.0) go to 900 143 144! Check 0.3 and 0.4 (ARRL Field Day exchange) 145 call pack77_03(nwords,w,i3,n3,c77) 146 if(i3.ge.0) go to 900 147 if(nwords.ge.2) go to 100 148 149 ! Check 0.5 (telemetry) 1505 i0=index(msg,' ') 151 c18=msg(1:i0-1) 152 c18=adjustr(c18) 153 ntel=-99 154 read(c18,1005,err=6) ntel 1551005 format(3z6) 156 if(ntel(1).ge.2**23) go to 800 1576 if(ntel(1).ge.0 .and. ntel(2).ge.0 .and. ntel(3).ge.0) then 158 i3=0 159 n3=5 160 write(c77,1006) ntel,n3,i3 1611006 format(b23.23,2b24.24,2b3.3) 162 go to 900 163 endif 164 165100 call pack77_06(nwords,w,i3,n3,c77,i3_hint,n3_hint) 166 if(i3.ge.0) go to 900 167 168! Check Type 1 (Standard 77-bit message) or Type 2, with optional "/P" 169 call pack77_1(nwords,w,i3,n3,c77) 170 if(i3.ge.0) go to 900 171 172! Check Type 3 (ARRL RTTY contest exchange) 173 call pack77_3(nwords,w,i3,n3,c77) 174 if(i3.ge.0) go to 900 175 176! Check Type 4 (One nonstandard call and one hashed call) 177 call pack77_4(nwords,w,i3,n3,c77) 178 if(i3.ge.0) go to 900 179 180! Check Type 5 (EU VHF Contest with 2 hashed calls, report, serial, and grid6) 181 call pack77_5(nwords,w,i3,n3,c77) 182 if(i3.ge.0) go to 900 183 184! It defaults to free text 185800 i3=0 186 n3=0 187 msg(14:)=' ' 188 call packtext77(msg(1:13),c77(1:71)) 189 write(c77(72:77),'(2b3.3)') n3,i3 190 191900 return 192end subroutine pack77 193 194subroutine unpack77(c77,nrx,msg,unpk77_success) 195! 196! nrx=1 when unpacking a received message 197! nrx=0 when unpacking a to-be-transmitted message 198! the value of nrx is used to decide when mycall13 or dxcall13 should 199! be used in place of a callsign from the hashtable 200! 201 parameter (NSEC=85) !Number of ARRL Sections 202 parameter (NUSCAN=65) !Number of US states and Canadian provinces 203 parameter (MAXGRID4=32400) 204 integer*8 n58 205 integer ntel(3) 206 character*77 c77 207 character*37 msg 208 character*13 call_1,call_2,call_3,call_1a 209 character*13 mycall13_0,dxcall13_0 210 character*11 c11 211 character*3 crpt,cntx,cpfx 212 character*3 cmult(NUSCAN) 213 character*6 cexch,grid6 214 character*4 grid4,cserial 215 character*3 csec(NSEC) 216 character*38 c 217 character*36 a2 218 integer hashmy10,hashmy12,hashmy22,hashdx10,hashdx12,hashdx22 219 logical unpk28_success,unpk77_success,unpkg4_success 220 logical dxcall13_set,mycall13_set 221 222 data a2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/,nzzz/46656/ 223 data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ 224 data csec/ & 225 "AB ","AK ","AL ","AR ","AZ ","BC ","CO ","CT ","DE ","EB ", & 226 "EMA","ENY","EPA","EWA","GA ","GTA","IA ","ID ","IL ","IN ", & 227 "KS ","KY ","LA ","LAX","MAR","MB ","MDC","ME ","MI ","MN ", & 228 "MO ","MS ","MT ","NC ","ND ","NE ","NFL","NH ","NL ","NLI", & 229 "NM ","NNJ","NNY","NT ","NTX","NV ","OH ","OK ","ONE","ONN", & 230 "ONS","OR ","ORG","PAC","PR ","QC ","RI ","SB ","SC ","SCV", & 231 "SD ","SDG","SF ","SFL","SJV","SK ","SNJ","STX","SV ","TN ", & 232 "UT ","VA ","VI ","VT ","WCF","WI ","WMA","WNY","WPA","WTX", & 233 "WV ","WWA","WY ","DX ","PE "/ 234 data cmult/ & 235 "AL ","AK ","AZ ","AR ","CA ","CO ","CT ","DE ","FL ","GA ", & 236 "HI ","ID ","IL ","IN ","IA ","KS ","KY ","LA ","ME ","MD ", & 237 "MA ","MI ","MN ","MS ","MO ","MT ","NE ","NV ","NH ","NJ ", & 238 "NM ","NY ","NC ","ND ","OH ","OK ","OR ","PA ","RI ","SC ", & 239 "SD ","TN ","TX ","UT ","VT ","VA ","WA ","WV ","WI ","WY ", & 240 "NB ","NS ","QC ","ON ","MB ","SK ","AB ","BC ","NWT","NF ", & 241 "LB ","NU ","YT ","PEI","DC "/ 242 data dxcall13_set/.false./ 243 data mycall13_set/.false./ 244 data mycall13_0/''/ 245 data dxcall13_0/''/ 246 247 save hashmy10,hashmy12,hashmy22,hashdx10,hashdx12,hashdx22 248 249 if(mycall13.ne.mycall13_0) then 250 if(len(trim(mycall13)).gt.2) then 251 mycall13_set=.true. 252 mycall13_0=mycall13 253 call save_hash_call(mycall13,hashmy10,hashmy12,hashmy22) 254 else 255 mycall13_set=.false. 256 endif 257 endif 258 259 if(dxcall13.ne.dxcall13_0) then 260 if(len(trim(dxcall13)).gt.2) then 261 dxcall13_set=.true. 262 dxcall13_0=dxcall13 263 hashdx10=ihashcall(dxcall13,10) 264 hashdx12=ihashcall(dxcall13,12) 265 hashdx22=ihashcall(dxcall13,22) 266 endif 267 endif 268 unpk77_success=.true. 269 270! Check for bad data 271 do i=1,77 272 if(c77(i:i).ne.'0' .and. c77(i:i).ne.'1') then 273 msg='failed unpack' 274 unpk77_success=.false. 275 return 276 endif 277 enddo 278 279 read(c77(72:77),'(2b3)') n3,i3 280 msg=repeat(' ',37) 281 282 if(i3.eq.0 .and. n3.eq.0) then 283! 0.0 Free text 284 call unpacktext77(c77(1:71),msg(1:13)) 285 msg(14:)=' ' 286 msg=adjustl(msg) 287 if(msg(1:1).eq.' ') then 288 unpk77_success=.false. 289 return 290 endif 291 292 else if(i3.eq.0 .and. n3.eq.1) then 293! 0.1 K1ABC RR73; W9XYZ <KH1/KH7Z> -11 28 28 10 5 71 DXpedition Mode 294 read(c77,1010) n28a,n28b,n10,n5 2951010 format(2b28,b10,b5) 296 irpt=2*n5 - 30 297 write(crpt,1012) irpt 2981012 format(i3.2) 299 if(irpt.ge.0) crpt(1:1)='+' 300 call unpack28(n28a,call_1,unpk28_success) 301 if(.not.unpk28_success .or. n28a.le.2) unpk77_success=.false. 302 call unpack28(n28b,call_2,unpk28_success) 303 if(.not.unpk28_success .or. n28b.le.2) unpk77_success=.false. 304 call hash10(n10,call_3) 305 if(nrx.eq.1 .and. & 306 dxcall13_set .and. & 307 hashdx10.eq.n10) call_3='<'//trim(dxcall13)//'>' 308 if(nrx.eq.0 .and. & 309 mycall13_set .and. & 310 n10.eq.hashmy10) call_3='<'//trim(mycall13)//'>' 311 msg=trim(call_1)//' RR73; '//trim(call_2)//' '//trim(call_3)//' '//crpt 312 313 else if(i3.eq.0 .and. n3.eq.2) then 314 unpk77_success=.false. 315 316 else if(i3.eq.0 .and. (n3.eq.3 .or. n3.eq.4)) then 317! 0.3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 ARRL Field Day 318! 0.4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 71 ARRL Field Day 319 read(c77,1030) n28a,n28b,ir,intx,nclass,isec 3201030 format(2b28,b1,b4,b3,b7) 321 if(isec.gt.NSEC .or. isec.lt.1) then 322 unpk77_success=.false. 323 isec=1 324 endif 325 call unpack28(n28a,call_1,unpk28_success) 326 if(.not.unpk28_success .or. n28a.le.2) unpk77_success=.false. 327 call unpack28(n28b,call_2,unpk28_success) 328 if(.not.unpk28_success .or. n28b.le.2) unpk77_success=.false. 329 ntx=intx+1 330 if(n3.eq.4) ntx=ntx+16 331 write(cntx(1:2),1032) ntx 3321032 format(i2) 333 cntx(3:3)=char(ichar('A')+nclass) 334 if(ir.eq.0 .and. ntx.lt.10) msg=trim(call_1)//' '//trim(call_2)// & 335 cntx//' '//csec(isec) 336 if(ir.eq.1 .and. ntx.lt.10) msg=trim(call_1)//' '//trim(call_2)// & 337 ' R'//cntx//' '//csec(isec) 338 if(ir.eq.0 .and. ntx.ge.10) msg=trim(call_1)//' '//trim(call_2)// & 339 ' '//cntx//' '//csec(isec) 340 if(ir.eq.1 .and. ntx.ge.10) msg=trim(call_1)//' '//trim(call_2)// & 341 ' R '//cntx//' '//csec(isec) 342 343 else if(i3.eq.0 .and. n3.eq.5) then 344! 0.5 0123456789abcdef01 71 71 Telemetry (18 hex) 345 read(c77,1006) ntel 3461006 format(b23,2b24) 347 write(msg,1007) ntel 3481007 format(3z6.6) 349 do i=1,18 350 if(msg(i:i).ne.'0') exit 351 msg(i:i)=' ' 352 enddo 353 msg=adjustl(msg) 354 355 else if(i3.eq.0 .and. n3.eq.6) then 356 read(c77(49:50),'(2b1)') j2a,j2b 357 itype=2 358 if(j2b.eq.0 .and. j2a.eq.0) itype=1 359 if(j2b.eq.0 .and. j2a.eq.1) itype=3 360 if(itype.eq.1) then 361! WSPR Type 1 362 read(c77,2010) n28,igrid4,idbm 3632010 format(b28.28,b15.15,b5.5) 364 idbm=nint(idbm*10.0/3.0) 365 call unpack28(n28,call_1,unpk28_success) 366 if(.not.unpk28_success) unpk77_success=.false. 367 call to_grid4(igrid4,grid4,unpkg4_success) 368 if(.not.unpkg4_success) unpk77_success=.false. 369 write(crpt,'(i3)') idbm 370 msg=trim(call_1)//' '//grid4//' '//trim(adjustl(crpt)) 371 if (unpk77_success) call save_hash_call(call_1,n10,n12,n22) !### Is this OK here? ### 372 373 else if(itype.eq.2) then 374! WSPR Type 2 375 read(c77,2020) n28,npfx,idbm 3762020 format(b28.28,b16.16,b5.5) 377 idbm=nint(idbm*10.0/3.0) 378 call unpack28(n28,call_1,unpk28_success) 379 if(.not.unpk28_success) unpk77_success=.false. 380 write(crpt,'(i3)') idbm 381 cpfx=' ' 382 if(npfx.lt.nzzz) then 383! Prefix 384 do i=3,1,-1 385 j=mod(npfx,36)+1 386 cpfx(i:i)=a2(j:j) 387 npfx=npfx/36 388 if(npfx.eq.0) exit 389 enddo 390 msg=trim(adjustl(cpfx))//'/'//trim(call_1)//' '//trim(adjustl(crpt)) 391 call_1a=trim(adjustl(cpfx))//'/'//trim(call_1) 392 call save_hash_call(call_1a,n10,n12,n22) !### Is this OK here? ### 393 else 394! Suffix 395 npfx=npfx-nzzz 396 if(npfx.le.35) then 397 cpfx(1:1)=a2(npfx+1:npfx+1) 398 else if(npfx.gt.35 .and. npfx.le.1295) then 399 cpfx(1:1)=a2(npfx/36+1:npfx/36+1) 400 cpfx(2:2)=a2(mod(npfx,36)+1:mod(npfx,36)+1) 401 else if(npfx.gt.1295 .and. npfx.le.12959) then 402 cpfx(1:1)=a2(npfx/360+1:npfx/360+1) 403 cpfx(2:2)=a2(mod(npfx/10,36)+1:mod(npfx/10,36)+1) 404 cpfx(3:3)=a2(mod(npfx,10)+1:mod(npfx,10)+1) 405 else 406 unpk77_success=.false. 407 return 408 endif 409 msg=trim(call_1)//'/'//trim(adjustl(cpfx))//' '//trim(adjustl(crpt)) 410 call_1a=trim(call_1)//'/'//trim(adjustl(cpfx)) 411 call save_hash_call(call_1a,n10,n12,n22) !### Is this OK here? ### 412 endif 413 414 else if(itype.eq.3) then 415! WSPR Type 3 416 read(c77,2030) n22,igrid6 4172030 format(b22.22,b25.25) 418 n28=n22+2063592 419 call unpack28(n28,call_1,unpk28_success) 420 if(.not.unpk28_success) unpk77_success=.false. 421 call to_grid(igrid6,grid6,unpkg4_success) 422 if(.not.unpkg4_success) unpk77_success=.false. 423 msg=trim(call_1)//' '//grid6 424 endif 425 426 else if(i3.eq.0 .and. n3.gt.6) then 427 unpk77_success=.false. 428 429 else if(i3.eq.1 .or. i3.eq.2) then 430! Type 1 (standard message) or Type 2 ("/P" form for EU VHF contest) 431 read(c77,1000) n28a,ipa,n28b,ipb,ir,igrid4,i3 4321000 format(2(b28,b1),b1,b15,b3) 433 call unpack28(n28a,call_1,unpk28_success) 434 if(nrx.eq.1 .and. mycall13_set .and. hashmy22.eq.(n28a-2063592)) then 435 call_1='<'//trim(mycall13)//'>' 436 unpk28_success=.true. 437 endif 438 if(.not.unpk28_success) unpk77_success=.false. 439 call unpack28(n28b,call_2,unpk28_success) 440 if(.not.unpk28_success) unpk77_success=.false. 441 if(call_1(1:3).eq.'CQ_') call_1(3:3)=' ' 442 if(index(call_1,'<').le.0) then 443 i=index(call_1,' ') 444 if(i.ge.4 .and. ipa.eq.1 .and. i3.eq.1) call_1(i:i+1)='/R' 445 if(i.ge.4 .and. ipa.eq.1 .and. i3.eq.2) call_1(i:i+1)='/P' 446 if(i.ge.4) call add_call_to_recent_calls(call_1) 447 endif 448 if(index(call_2,'<').le.0) then 449 i=index(call_2,' ') 450 if(i.ge.4 .and. ipb.eq.1 .and. i3.eq.1) call_2(i:i+1)='/R' 451 if(i.ge.4 .and. ipb.eq.1 .and. i3.eq.2) call_2(i:i+1)='/P' 452 if(i.ge.4) call add_call_to_recent_calls(call_2) 453 endif 454 if(igrid4.le.MAXGRID4) then 455 call to_grid4(igrid4,grid4,unpkg4_success) 456 if(.not.unpkg4_success) unpk77_success=.false. 457 if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//grid4 458 if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R '//grid4 459 if(msg(1:3).eq.'CQ ' .and. ir.eq.1) unpk77_success=.false. 460 else 461 irpt=igrid4-MAXGRID4 462 if(irpt.eq.1) msg=trim(call_1)//' '//trim(call_2) 463 if(irpt.eq.2) msg=trim(call_1)//' '//trim(call_2)//' RRR' 464 if(irpt.eq.3) msg=trim(call_1)//' '//trim(call_2)//' RR73' 465 if(irpt.eq.4) msg=trim(call_1)//' '//trim(call_2)//' 73' 466 if(irpt.ge.5) then 467 isnr=irpt-35 468 if(isnr.gt.50) isnr=isnr-101 469 write(crpt,'(i3.2)') isnr 470 if(crpt(1:1).eq.' ') crpt(1:1)='+' 471 if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//crpt 472 if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R'//crpt 473 endif 474 if(msg(1:3).eq.'CQ ' .and. irpt.ge.2) unpk77_success=.false. 475 endif 476 477 else if(i3.eq.3) then 478! Type 3: ARRL RTTY Contest 479 read(c77,1040) itu,n28a,n28b,ir,irpt,nexch,i3 4801040 format(b1,2b28.28,b1,b3.3,b13.13,b3.3) 481 write(crpt,1042) irpt+2 4821042 format('5',i1,'9') 483 nserial=nexch 484 imult=-1 485 if(nexch.gt.8000) then 486 imult=nexch-8000 487 nserial=-1 488 endif 489 call unpack28(n28a,call_1,unpk28_success) 490 if(.not.unpk28_success) unpk77_success=.false. 491 call unpack28(n28b,call_2,unpk28_success) 492 if(.not.unpk28_success) unpk77_success=.false. 493 imult=0 494 nserial=0 495 if(nexch.gt.8000) imult=nexch-8000 496 if(nexch.lt.8000) nserial=nexch 497 498 if(imult.ge.1 .and.imult.le.NUSCAN) then 499 if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// & 500 ' '//crpt//' '//cmult(imult) 501 if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// & 502 ' '//crpt//' '//cmult(imult) 503 if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// & 504 ' R '//crpt//' '//cmult(imult) 505 if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// & 506 ' R '//crpt//' '//cmult(imult) 507 else if(nserial.ge.1 .and. nserial.le.7999) then 508 write(cserial,'(i4.4)') nserial 509 if(itu.eq.0 .and. ir.eq.0) msg=trim(call_1)//' '//trim(call_2)// & 510 ' '//crpt//' '//cserial 511 if(itu.eq.1 .and. ir.eq.0) msg='TU; '//trim(call_1)//' '//trim(call_2)// & 512 ' '//crpt//' '//cserial 513 if(itu.eq.0 .and. ir.eq.1) msg=trim(call_1)//' '//trim(call_2)// & 514 ' R '//crpt//' '//cserial 515 if(itu.eq.1 .and. ir.eq.1) msg='TU; '//trim(call_1)//' '//trim(call_2)// & 516 ' R '//crpt//' '//cserial 517 endif 518 else if(i3.eq.4) then 519! Type 4 520 read(c77,1050) n12,n58,iflip,nrpt,icq 5211050 format(b12,b58,b1,b2,b1) 522 do i=11,1,-1 523 j=mod(n58,38)+1 524 c11(i:i)=c(j:j) 525 n58=n58/38 526 enddo 527 call hash12(n12,call_3) 528 if(iflip.eq.0) then ! 12 bit hash for TO call 529 call_1=call_3 530 call_2=adjustl(c11)//' ' 531 call add_call_to_recent_calls(call_2) 532 if(nrx.eq.1 .and. & 533 dxcall13_set .and. mycall13_set .and. & 534 call_2.eq.dxcall13 .and. & 535 n12.eq.hashmy12 ) call_1='<'//trim(mycall13)//'>' 536 if(nrx.eq.1 .and. & 537 mycall13_set .and. & 538 index(call_1,'<...>').gt.0 .and. & 539 n12.eq.hashmy12 ) call_1='<'//trim(mycall13)//'>' 540 else ! 12 bit hash for DE call 541 call_1=adjustl(c11) 542 call_2=call_3 543 call add_call_to_recent_calls(call_1) 544 if(nrx.eq.0 .and. & 545 mycall13_set .and. & 546 n12.eq.hashmy12) call_2='<'//trim(mycall13)//'>' 547 endif 548 if(icq.eq.0) then 549 if(nrpt.eq.0) msg=trim(call_1)//' '//trim(call_2) 550 if(nrpt.eq.1) msg=trim(call_1)//' '//trim(call_2)//' RRR' 551 if(nrpt.eq.2) msg=trim(call_1)//' '//trim(call_2)//' RR73' 552 if(nrpt.eq.3) msg=trim(call_1)//' '//trim(call_2)//' 73' 553 else 554 msg='CQ '//trim(call_2) 555 endif 556 557 else if(i3.eq.5) then 558 559! Type 5 <PA3XYZ> <G4ABC/P> R 590003 IO91NP h12 h22 r1 s3 S11 g25 560! EU VHF contest 561 read(c77,1060) n12,n22,ir,irpt,iserial,igrid6 5621060 format(b12,b22,b1,b3,b11,b25) 563 if(igrid6.lt.0 .or. igrid6.gt.18662399) then 564 unpk77_success=.false. 565 return 566 endif 567 call hash12(n12,call_1) 568 if(n12.eq.hashmy12) call_1='<'//trim(mycall13)//'>' 569 call hash22(n22,call_2) 570 nrs=52+irpt 571 write(cexch,1022) nrs,iserial 5721022 format(i2,i4.4) 573 call to_grid6(igrid6,grid6,unpk77_success) 574 if(ir.eq.0) msg=trim(call_1)//' '//trim(call_2)//' '//cexch//' '//grid6 575 if(ir.eq.1) msg=trim(call_1)//' '//trim(call_2)//' R '//cexch//' '//grid6 576 577 else if(i3.ge.6) then ! i3 values 6 and 7 are not yet defined 578 unpk77_success=.false. 579 endif 580 if(msg(1:4).eq.'CQ <') unpk77_success=.false. 581 582 return 583end subroutine unpack77 584 585subroutine pack28(c13,n28) 586 587! Pack a special token, a 22-bit hash code, or a valid base call into a 28-bit 588! integer. 589 590 parameter (NTOKENS=2063592,MAX22=4194304) 591 logical is_digit,is_letter 592 character*13 c13 593 character*6 callsign 594 character*1 c 595 character*4 c4 596 character*37 a1 597 character*36 a2 598 character*10 a3 599 character*27 a4 600 data a1/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 601 data a2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 602 data a3/'0123456789'/ 603 data a4/' ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 604 605 is_digit(c)=c.ge.'0' .and. c.le.'9' 606 is_letter(c)=c.ge.'A' .and. c.le.'Z' 607 608 n28=-1 609! Work-around for Swaziland prefix: 610 if(c13(1:4).eq.'3DA0') callsign='3D0'//c13(5:7) 611! Work-around for Guinea prefixes: 612 if(c13(1:2).eq.'3X' .and. c13(3:3).ge.'A' .and. & 613 c13(3:3).le.'Z') callsign='Q'//c13(3:6) 614 615! Check for special tokens first 616 if(c13(1:3).eq.'DE ') then 617 n28=0 618 go to 900 619 endif 620 621 if(c13(1:4).eq.'QRZ ') then 622 n28=1 623 go to 900 624 endif 625 626 if(c13(1:3).eq.'CQ ') then 627 n28=2 628 go to 900 629 endif 630 631 if(c13(1:3).eq.'CQ_') then 632 n=len(trim(c13)) 633 if(n.ge.4 .and. n.le.7) then 634 nlet=0 635 nnum=0 636 do i=4,n 637 c=c13(i:i) 638 if(c.ge.'A' .and. c.le.'Z') nlet=nlet+1 639 if(c.ge.'0' .and. c.le.'9') nnum=nnum+1 640 enddo 641 if(nnum.eq.3 .and. nlet.eq.0) then 642 read(c13(4:3+nnum),*) nqsy 643 n28=3+nqsy 644 go to 900 645 endif 646 if(nlet.ge.1 .and. nlet.le.4 .and. nnum.eq.0) then 647 c4=c13(4:n) 648 c4=adjustr(c4) 649 m=0 650 do i=1,4 651 j=0 652 c=c4(i:i) 653 if(c.ge.'A' .and. c.le.'Z') j=ichar(c)-ichar('A')+1 654 m=27*m + j 655 enddo 656 n28=3+1000+m 657 go to 900 658 endif 659 endif 660 endif 661 662! Check for <...> callsign 663 if(c13(1:1).eq.'<')then 664 call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table 665 i2=index(c13,'>') 666 c13=c13(2:i2-1) 667 n22=ihashcall(c13,22) 668 n28=NTOKENS + n22 669 go to 900 670 endif 671 672! Check for standard callsign 673 iarea=-1 674 n=len(trim(c13)) 675 do i=n,2,-1 676 if(is_digit(c13(i:i))) exit 677 enddo 678 iarea=i !Call-area digit 679 npdig=0 !Digits before call area 680 nplet=0 !Letters before call area 681 do i=1,iarea-1 682 if(is_digit(c13(i:i))) npdig=npdig+1 683 if(is_letter(c13(i:i))) nplet=nplet+1 684 enddo 685 nslet=0 686 do i=iarea+1,n 687 if(is_letter(c13(i:i))) nslet=nslet+1 688 enddo 689 if(iarea.lt.2 .or. iarea.gt.3 .or. nplet.eq.0 .or. & 690 npdig.ge.iarea-1 .or. nslet.gt.3) then 691! Treat this as a nonstandard callsign: compute its 22-bit hash 692 call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table 693 n22=ihashcall(c13,22) 694 n28=NTOKENS + n22 695 go to 900 696 endif 697 698 n=len(trim(c13)) 699! This is a standard callsign 700 call save_hash_call(c13,n10,n12,n22) !Save callsign in hash table 701 if(iarea.eq.2) callsign=' '//c13(1:5) 702 if(iarea.eq.3) callsign=c13(1:6) 703 i1=index(a1,callsign(1:1))-1 704 i2=index(a2,callsign(2:2))-1 705 i3=index(a3,callsign(3:3))-1 706 i4=index(a4,callsign(4:4))-1 707 i5=index(a4,callsign(5:5))-1 708 i6=index(a4,callsign(6:6))-1 709 n28=36*10*27*27*27*i1 + 10*27*27*27*i2 + 27*27*27*i3 + 27*27*i4 + & 710 27*i5 + i6 711 n28=n28 + NTOKENS + MAX22 712 713900 n28=iand(n28,ishft(1,28)-1) 714 return 715end subroutine pack28 716 717 718subroutine unpack28(n28_0,c13,success) 719 720 parameter (NTOKENS=2063592,MAX22=4194304) 721 logical success 722 character*13 c13 723 character*37 c1 724 character*36 c2 725 character*10 c3 726 character*27 c4 727 data c1/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 728 data c2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 729 data c3/'0123456789'/ 730 data c4/' ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 731 732 success=.true. 733 n28=n28_0 734 if(n28.lt.NTOKENS) then 735! Special tokens DE, QRZ, CQ, CQ_nnn, CQ_aaaa 736 if(n28.eq.0) c13='DE ' 737 if(n28.eq.1) c13='QRZ ' 738 if(n28.eq.2) c13='CQ ' 739 if(n28.le.2) go to 900 740 if(n28.le.1002) then 741 write(c13,1002) n28-3 7421002 format('CQ_',i3.3) 743 go to 900 744 endif 745 if(n28.le.532443) then 746 n=n28-1003 747 n0=n 748 i1=n/(27*27*27) 749 n=n-27*27*27*i1 750 i2=n/(27*27) 751 n=n-27*27*i2 752 i3=n/27 753 i4=n-27*i3 754 c13=c4(i1+1:i1+1)//c4(i2+1:i2+1)//c4(i3+1:i3+1)//c4(i4+1:i4+1) 755 c13=adjustl(c13) 756 c13='CQ_'//c13(1:10) 757 go to 900 758 endif 759 endif 760 n28=n28-NTOKENS 761 if(n28.lt.MAX22) then 762! This is a 22-bit hash of a callsign 763 n22=n28 764 call hash22(n22,c13) !Retrieve callsign from hash table 765 go to 900 766 endif 767 768! Standard callsign 769 n=n28 - MAX22 770 i1=n/(36*10*27*27*27) 771 n=n-36*10*27*27*27*i1 772 i2=n/(10*27*27*27) 773 n=n-10*27*27*27*i2 774 i3=n/(27*27*27) 775 n=n-27*27*27*i3 776 i4=n/(27*27) 777 n=n-27*27*i4 778 i5=n/27 779 i6=n-27*i5 780 c13=c1(i1+1:i1+1)//c2(i2+1:i2+1)//c3(i3+1:i3+1)//c4(i4+1:i4+1)// & 781 c4(i5+1:i5+1)//c4(i6+1:i6+1) 782 c13=adjustl(c13) 783 784900 i0=index(c13,' ') 785 if(i0.ne.0 .and. i0.lt.len(trim(c13))) then 786 c13='QU1RK' 787 success=.false. 788 endif 789 return 790end subroutine unpack28 791 792subroutine split77(msg,nwords,nw,w) 793 794! Convert msg to upper case; collapse multiple blanks; parse into words. 795 796 character*37 msg 797 character*13 w(19) 798 character*1 c,c0 799 character*6 bcall_1 800 logical ok1 801 integer nw(19) 802 803 iz=len(trim(msg)) 804 j=0 805 k=0 806 n=0 807 c0=' ' 808 w=' ' 809 do i=1,iz 810 if(ichar(msg(i:i)).eq.0) msg(i:i)=' ' 811 c=msg(i:i) !Single character 812 if(c.eq.' ' .and. c0.eq.' ') cycle !Skip leading/repeated blanks 813 if(c.ne.' ' .and. c0.eq.' ') then 814 k=k+1 !New word 815 n=0 816 endif 817 j=j+1 !Index in msg 818 n=n+1 !Index in word 819 if(c.ge.'a' .and. c.le.'z') c=char(ichar(c)-32) !Force upper case 820 msg(j:j)=c 821 if(n.le.13) w(k)(n:n)=c !Copy character c into word 822 c0=c 823 enddo 824 iz=j !Message length 825 nwords=k !Number of words in msg 826 if(nwords.le.0) go to 900 827 nw(k)=len(trim(w(k))) 828 msg(iz+1:)=' ' 829 if(nwords.lt.3) go to 900 830 call chkcall(w(3),bcall_1,ok1) 831 if(ok1 .and. w(1)(1:3).eq.'CQ ') then 832 w(1)='CQ_'//w(2)(1:10) !Make "CQ " into "CQ_" 833 w(2:12)=w(3:13) !Move all remaining words down by one 834 nwords=nwords-1 835 endif 836 837900 return 838end subroutine split77 839 840 841subroutine pack77_01(nwords,w,i3,n3,c77) 842 843! Pack a Type 0.1 message: DXpedition mode 844! Example message: "K1ABC RR73; W9XYZ <KH1/KH7Z> -11" 28 28 10 5 845 846 character*13 w(19),c13 847 character*77 c77 848 character*6 bcall_1,bcall_2 849 logical ok1,ok2 850 851 if(nwords.ne.5) go to 900 !Must have 5 words 852 if(trim(w(2)).ne.'RR73;') go to 900 !2nd word must be "RR73;" 853 if(w(4)(1:1).ne.'<') go to 900 !4th word must have <...> 854 if(index(w(4),'>').lt.1) go to 900 855 n=-99 856 read(w(5),*,err=1) n 8571 if(n.eq.-99) go to 900 !5th word must be a valid report 858 n5=(n+30)/2 859 if(n5.lt.0) n5=0 860 if(n5.gt.31) n5=31 861 call chkcall(w(1),bcall_1,ok1) 862 if(.not.ok1) go to 900 !1st word must be a valid basecall 863 call chkcall(w(3),bcall_2,ok2) 864 if(.not.ok2) go to 900 !3rd word must be a valid basecall 865 866! Type 0.1: K1ABC RR73; W9XYZ <KH1/KH7Z> -11 28 28 10 5 71 867 i3=0 868 n3=1 869 call pack28(w(1),n28a) 870 call pack28(w(3),n28b) 871 call save_hash_call(w(4),n10,n12,n22) 872 i2=index(w(4),'>') 873 c13=w(4)(2:i2-1) 874 n10=ihashcall(c13,10) 875 write(c77,1010) n28a,n28b,n10,n5,n3,i3 8761010 format(2b28.28,b10.10,b5.5,2b3.3) 877 878900 return 879end subroutine pack77_01 880 881 882subroutine pack77_03(nwords,w,i3,n3,c77) 883 884! Check 0.3 and 0.4 (ARRL Field Day exchange) 885! Example message: WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 886 887 parameter (NSEC=85) !Number of ARRL Sections 888 character*13 w(19) 889 character*77 c77 890 character*6 bcall_1,bcall_2 891 character*3 csec(NSEC) 892 logical ok1,ok2 893 data csec/ & 894 "AB ","AK ","AL ","AR ","AZ ","BC ","CO ","CT ","DE ","EB ", & 895 "EMA","ENY","EPA","EWA","GA ","GTA","IA ","ID ","IL ","IN ", & 896 "KS ","KY ","LA ","LAX","MAR","MB ","MDC","ME ","MI ","MN ", & 897 "MO ","MS ","MT ","NC ","ND ","NE ","NFL","NH ","NL ","NLI", & 898 "NM ","NNJ","NNY","NT ","NTX","NV ","OH ","OK ","ONE","ONN", & 899 "ONS","OR ","ORG","PAC","PR ","QC ","RI ","SB ","SC ","SCV", & 900 "SD ","SDG","SF ","SFL","SJV","SK ","SNJ","STX","SV ","TN ", & 901 "UT ","VA ","VI ","VT ","WCF","WI ","WMA","WNY","WPA","WTX", & 902 "WV ","WWA","WY ","DX ","PE "/ 903 904 if(nwords.lt.4 .or. nwords.gt.5) return 905 call chkcall(w(1),bcall_1,ok1) 906 call chkcall(w(2),bcall_2,ok2) 907 if(.not.ok1 .or. .not.ok2) return 908 isec=-1 909 do i=1,NSEC 910 if(csec(i).eq.w(nwords)(1:3)) then 911 isec=i 912 exit 913 endif 914 enddo 915 if(isec.eq.-1) return 916 if(nwords.eq.5 .and. trim(w(3)).ne.'R') return 917 918 ntx=-1 919 j=len(trim(w(nwords-1)))-1 920 read(w(nwords-1)(1:j),*,err=1,end=1) ntx !Number of transmitters 9211 if(ntx.lt.1 .or. ntx.gt.32) return 922 nclass=ichar(w(nwords-1)(j+1:j+1))-ichar('A') 923 924 m=len(trim(w(nwords))) !Length of section abbreviation 925 if(m.lt.2 .or. m.gt.3) return 926 927! 0.3 WA9XYZ KA1ABC R 16A EMA 28 28 1 4 3 7 71 ARRL Field Day 928! 0.4 WA9XYZ KA1ABC R 32A EMA 28 28 1 4 3 7 71 ARRL Field Day 929 930 i3=0 931 n3=3 !Type 0.3 ARRL Field Day 932 intx=ntx-1 933 if(intx.ge.16) then 934 n3=4 !Type 0.4 ARRL Field Day 935 intx=ntx-17 936 endif 937 call pack28(w(1),n28a) 938 call pack28(w(2),n28b) 939 ir=0 940 if(w(3)(1:2).eq.'R ') ir=1 941 write(c77,1010) n28a,n28b,ir,intx,nclass,isec,n3,i3 9421010 format(2b28.28,b1,b4.4,b3.3,b7.7,2b3.3) 943 944 return 945end subroutine pack77_03 946 947 948subroutine pack77_06(nwords,w,i3,n3,c77,i3_hint,n3_hint) 949 950 character*13 w(19) 951 character*77 c77 952 character*6 bcall,grid6 953 character*4 grid4 954 character*1 c 955 character*36 a2 956 data a2/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/,nzzz/46656/ 957 958 logical is_grid4,is_grid6,is_digit,ok 959 is_grid4(grid4)=len(trim(grid4)).eq.4 .and. & 960 grid4(1:1).ge.'A' .and. grid4(1:1).le.'R' .and. & 961 grid4(2:2).ge.'A' .and. grid4(2:2).le.'R' .and. & 962 grid4(3:3).ge.'0' .and. grid4(3:3).le.'9' .and. & 963 grid4(4:4).ge.'0' .and. grid4(4:4).le.'9' 964 965 is_grid6(grid6)=(len(trim(grid6)).eq.6.or.len(trim(grid6)).eq.4).and. & 966 grid6(1:1).ge.'A' .and. grid6(1:1).le.'R' .and. & 967 grid6(2:2).ge.'A' .and. grid6(2:2).le.'R' .and. & 968 grid6(3:3).ge.'0' .and. grid6(3:3).le.'9' .and. & 969 grid6(4:4).ge.'0' .and. grid6(4:4).le.'9' .and. & 970 (len(trim(grid6)).eq.4.or. & 971 (grid6(5:5).ge.'A' .and. grid6(5:5).le.'X' .and. & 972 grid6(6:6).ge.'A' .and. grid6(6:6).le.'X')) 973 974 is_digit(c)=c.ge.'0' .and. c.le.'9' 975 976 m1=len(trim(w(1))) 977 m2=len(trim(w(2))) 978 m3=len(trim(w(3))) 979 if(nwords.eq.3 .and. m1.ge.3 .and. m1.le.6 .and. m2.eq.4 .and. m3.le.2) then 980! WSPR Type 1 981 if(.not.is_grid4(w(2)(1:4))) go to 900 982 if(.not.is_digit(w(3)(1:1))) go to 900 983 if(m3.eq.2) then 984 if(.not.is_digit(w(3)(2:2))) go to 900 985 endif 986 i3=0 987 n3=6 988 call pack28(w(1),n28) 989 grid4=w(2)(1:4) 990 k1=(ichar(grid4(1:1))-ichar('A'))*18*10*10 991 k2=(ichar(grid4(2:2))-ichar('A'))*10*10 992 k3=(ichar(grid4(3:3))-ichar('0'))*10 993 k4=(ichar(grid4(4:4))-ichar('0')) 994 igrid4=k1+k2+k3+k4 995 read(w(3),*) idbm 996 if(idbm.lt.0) idbm=0 997 if(idbm.gt.60) idbm=60 998 idbm=nint(0.3*idbm) 999 write(c77,1010) n28,igrid4,idbm,0,0,0,n3,i3 10001010 format(b28.28,b15.15,b5.5,2i1,b21.21,2b3.3) 1001 go to 900 1002 endif 1003 if(nwords.eq.2 .and. m1.ge.5 .and. m1.le.10 .and. m2.le.2) then 1004! WSPR Type 2 1005 i1=index(w(1),'/') 1006 if(i1.lt.2 .or. i1.eq.m1) go to 900 1007 if(.not.is_digit(w(2)(1:1))) go to 900 1008 if(i1.eq.(m1-3) .and. .not.is_digit(w(1)(m1:m1))) go to 900 1009 if(m2.eq.2) then 1010 if(.not.is_digit(w(2)(2:2))) go to 900 1011 endif 1012 call chkcall(w(1),bcall,ok) 1013 if(.not.ok) go to 900 1014 if(i1.le.4) then 1015! We have a prefix 1016 npfx=index(a2,w(1)(1:1))-1 1017 if(i1.ge.3) npfx=36*npfx + index(a2,w(1)(2:2))-1 1018 if(i1.eq.4) npfx=36*npfx + index(a2,w(1)(3:3))-1 1019 else 1020! We have a suffix 1021 if((m1-i1).eq.1) npfx=index(a2,w(1)(i1+1:i1+1))-1 1022 if((m1-i1).eq.2) npfx=36*(index(a2,w(1)(i1+1:i1+1))-1) + & 1023 index(a2,w(1)(i1+2:i1+2))-1 1024 if((m1-i1).eq.3) then 1025! Third character of a suffix must be a digit 1026 if(.not.is_digit(w(1)(i1+3:i1+3))) go to 900 1027 npfx=36*10*(index(a2,w(1)(i1+1:i1+1))-1) + & 1028 10*(index(a2,w(1)(i1+2:i1+2))-1) + index(a2,w(1)(i1+3:i1+3))-1 1029 endif 1030 npfx=npfx + nzzz 1031 endif 1032 i3=0 1033 n3=6 1034 call pack28(bcall//' ',n28) 1035 read(w(2),*) idbm 1036 if(idbm.lt.0) idbm=0 1037 if(idbm.gt.60) idbm=60 1038 idbm=nint(0.3*idbm) 1039 write(c77,1020) n28,npfx,idbm,1,0,n3,i3 10401020 format(b28.28,b16.16,b5.5,i1,b21.21,2b3.3) 1041 go to 900 1042 endif 1043 1044 if(i3_hint.eq.0.and.n3_hint.eq.6.and.nwords.eq.2 .and. m1.ge.5 & 1045 .and. m1.le.12 .and. m2.le.6) then 1046! WSPR Type 3 1047 1048 !n3_hint=6 and i3_hint=0 is a hint that the caller wanted a 1049 !50-bit encoding rather than the possible alternative n3=4 77-bit 1050 !encoding 1051 if(index(w(1),'<').lt.1 .or. index(w(1),'>').lt.1) go to 900 1052 grid6=w(2)(1:6) 1053 if(.not.is_grid6(grid6)) go to 900 1054 i3=0 1055 n3=6 1056 call pack28(w(1),n28) 1057 n22=n28-2063592 1058 k1=(ichar(grid6(1:1))-ichar('A'))*18*10*10*25*25 1059 k2=(ichar(grid6(2:2))-ichar('A'))*10*10*25*25 1060 k3=(ichar(grid6(3:3))-ichar('0'))*10*25*25 1061 k4=(ichar(grid6(4:4))-ichar('0'))*25*25 1062 if (grid6(5:6).eq.' ') then 1063 igrid6=k1+k2+k3+k4+24*25+24 1064 else 1065 k5=(ichar(grid6(5:5))-ichar('A'))*25 1066 k6=(ichar(grid6(6:6))-ichar('A')) 1067 igrid6=k1+k2+k3+k4+k5+k6 1068 endif 1069 write(c77,1030) n22,igrid6,2,0,n3,i3 10701030 format(b22.22,b25.25,b3.3,b21.21,2b3.3) 1071 endif 1072 1073900 return 1074end subroutine pack77_06 1075 1076 1077subroutine pack77_1(nwords,w,i3,n3,c77) 1078 1079! Check Type 1 (Standard 77-bit message) and Type 2 (ditto, with a "/P" call) 1080! Example message: WA9XYZ/R KA1ABC/R R FN42 28 1 28 1 1 15 74 1081 1082 parameter (MAXGRID4=32400) 1083 character*13 w(19),c13 1084 character*77 c77 1085 character*6 bcall_1,bcall_2 1086 character*4 grid4 1087 character c1*1,c2*2 1088 logical is_grid4 1089 logical ok1,ok2 1090 is_grid4(grid4)=len(trim(grid4)).eq.4 .and. & 1091 grid4(1:1).ge.'A' .and. grid4(1:1).le.'R' .and. & 1092 grid4(2:2).ge.'A' .and. grid4(2:2).le.'R' .and. & 1093 grid4(3:3).ge.'0' .and. grid4(3:3).le.'9' .and. & 1094 grid4(4:4).ge.'0' .and. grid4(4:4).le.'9' 1095 1096 if(nwords.lt.2 .or. nwords.gt.4) return 1097 call chkcall(w(1),bcall_1,ok1) 1098 call chkcall(w(2),bcall_2,ok2) 1099 if(w(1)(1:3).eq.'DE ' .or. w(1)(1:3).eq.'CQ_' .or. w(1)(1:3).eq.'CQ ' .or. & 1100 w(1)(1:4).eq.'QRZ ') ok1=.true. 1101 if(w(1)(1:1).eq.'<' .and. index(w(1),'>').ge.5) ok1=.true. 1102 if(w(2)(1:1).eq.'<' .and. index(w(2),'>').ge.5) ok2=.true. 1103 if(.not.ok1 .or. .not.ok2) return 1104 if(w(1)(1:1).eq.'<' .and. index(w(2),'/').gt.0) return 1105 if(w(2)(1:1).eq.'<' .and. index(w(1),'/').gt.0) return 1106 if(nwords.eq.2 .and. (.not.ok2 .or. index(w(2),'/').ge.2)) return 1107 if(nwords.eq.2) go to 10 1108 1109 c1=w(nwords)(1:1) 1110 c2=w(nwords)(1:2) 1111 if(.not.is_grid4(w(nwords)(1:4)) .and. c1.ne.'+' .and. c1.ne.'-' & 1112 .and. c2.ne.'R+' .and. c2.ne.'R-' .and. trim(w(nwords)).ne.'RRR' .and. & 1113 trim(w(nwords)).ne.'RR73' .and. trim(w(nwords)).ne.'73') return 1114 if(c1.eq.'+' .or. c1.eq.'-') then 1115 ir=0 1116 read(w(nwords),*,err=900) irpt 1117 if(irpt.ge.-50 .and. irpt.le.-31) irpt=irpt+101 1118 irpt=irpt+35 1119 else if(c2.eq.'R+' .or. c2.eq.'R-') then 1120 ir=1 1121 read(w(nwords)(2:),*,err=900) irpt 1122 if(irpt.ge.-50 .and. irpt.le.-31) irpt=irpt+101 1123 irpt=irpt+35 1124 else if(trim(w(nwords)).eq.'RRR') then 1125 ir=0 1126 irpt=2 1127 else if(trim(w(nwords)).eq.'RR73') then 1128 ir=0 1129 irpt=3 1130 else if(trim(w(nwords)).eq.'73') then 1131 ir=0 1132 irpt=4 1133 endif 1134 1135! 1 WA9XYZ/R KA1ABC/R R FN42 28 1 28 1 1 15 74 Standard msg 1136! 2 PA3XYZ/P GM4ABC/P R JO22 28 1 28 1 1 15 74 EU VHF contest 1137 113810 i1psuffix=index(w(1)//' ' ,'/P ') 1139 i2psuffix=index(w(2)//' ','/P ') 1140 if(nwords.eq.2 .or. nwords.eq.3 .or. (nwords.eq.4 .and. & 1141 w(3)(1:2).eq.'R ')) then 1142 n3=0 1143 i3=1 !Type 1: Standard message, possibly with "/R" 1144 if (i1psuffix.ge.4.or.i2psuffix.ge.4) i3=2 !Type 2, with "/P" 1145 endif 1146 c13=bcall_1 1147 if(c13(1:3).eq.'CQ_' .or. w(1)(1:1).eq.'<') c13=w(1) 1148 call pack28(c13,n28a) 1149 c13=bcall_2 1150 if(w(2)(1:1).eq.'<') c13=w(2) 1151 call pack28(c13,n28b) 1152 ipa=0 1153 ipb=0 1154 if(i1psuffix.ge.4.or.index(w(1)//' ','/R ').ge.4) ipa=1 1155 if(i2psuffix.ge.4.or.index(w(2)//' ','/R ').ge.4) ipb=1 1156 1157 grid4=w(nwords)(1:4) 1158 if(is_grid4(grid4)) then 1159 ir=0 1160 if(w(3).eq.'R ') ir=1 1161 j1=(ichar(grid4(1:1))-ichar('A'))*18*10*10 1162 j2=(ichar(grid4(2:2))-ichar('A'))*10*10 1163 j3=(ichar(grid4(3:3))-ichar('0'))*10 1164 j4=(ichar(grid4(4:4))-ichar('0')) 1165 igrid4=j1+j2+j3+j4 1166 else 1167 igrid4=MAXGRID4 + irpt 1168 endif 1169 if(nwords.eq.2) then 1170 ir=0 1171 irpt=1 1172 igrid4=MAXGRID4+irpt 1173 endif 1174 write(c77,1000) n28a,ipa,n28b,ipb,ir,igrid4,i3 11751000 format(2(b28.28,b1),b1,b15.15,b3.3) 1176 return 1177 1178900 return 1179end subroutine pack77_1 1180 1181 1182subroutine pack77_3(nwords,w,i3,n3,c77) 1183 1184! Check Type 3 (ARRL RTTY contest exchange) 1185! ARRL RTTY - US/Can: rpt state/prov R 579 MA 1186! - DX: rpt serial R 559 0013 1187! Example message: TU; W9XYZ K1ABC R 579 MA 1 28 28 1 3 13 74 1188 1189 parameter (NUSCAN=65) !Number of US states and Canadian provinces/territories 1190 character*13 w(19) 1191 character*77 c77 1192 character*6 bcall_1,bcall_2 1193 character*3 cmult(NUSCAN),mult 1194 character crpt*3 1195 logical ok1,ok2 1196 data cmult/ & 1197 "AL ","AK ","AZ ","AR ","CA ","CO ","CT ","DE ","FL ","GA ", & 1198 "HI ","ID ","IL ","IN ","IA ","KS ","KY ","LA ","ME ","MD ", & 1199 "MA ","MI ","MN ","MS ","MO ","MT ","NE ","NV ","NH ","NJ ", & 1200 "NM ","NY ","NC ","ND ","OH ","OK ","OR ","PA ","RI ","SC ", & 1201 "SD ","TN ","TX ","UT ","VT ","VA ","WA ","WV ","WI ","WY ", & 1202 "NB ","NS ","QC ","ON ","MB ","SK ","AB ","BC ","NWT","NF ", & 1203 "LB ","NU ","YT ","PEI","DC "/ 1204 1205 if(w(1)(1:1).eq.'<' .and. w(2)(1:1).eq.'<') go to 900 1206 if(nwords.eq.4 .or. nwords.eq.5 .or. nwords.eq.6) then 1207 i1=1 1208 if(trim(w(1)).eq.'TU;') i1=2 1209 call chkcall(w(i1),bcall_1,ok1) 1210 call chkcall(w(i1+1),bcall_2,ok2) 1211 if(.not.ok1 .or. .not.ok2) go to 900 1212 crpt=w(nwords-1)(1:3) 1213 if(index(crpt,'-').ge.1 .or. index(crpt,'+').ge.1) go to 900 1214 if(crpt(1:1).eq.'5' .and. crpt(2:2).ge.'2' .and. crpt(2:2).le.'9' .and. & 1215 crpt(3:3).eq.'9') then 1216 nserial=0 1217 read(w(nwords),*,err=1) nserial 1218 endif 12191 mult=' ' 1220 imult=-1 1221 do i=1,NUSCAN 1222 if(cmult(i).eq.w(nwords)) then 1223 imult=i 1224 mult=cmult(i) 1225 exit 1226 endif 1227 enddo 1228 nexch=0 1229 if(nserial.gt.0) nexch=nserial 1230 if(imult.gt.0) nexch=8000+imult 1231 if(mult.ne.' ' .or. nserial.gt.0) then 1232 i3=3 1233 n3=0 1234 itu=0 1235 if(trim(w(1)).eq.'TU;') itu=1 1236 call pack28(w(1+itu),n28a) 1237 call pack28(w(2+itu),n28b) 1238 ir=0 1239 if(w(3+itu)(1:2).eq.'R ') ir=1 1240 read(w(3+itu+ir),*,err=900) irpt 1241 irpt=(irpt-509)/10 - 2 1242 if(irpt.lt.0) irpt=0 1243 if(irpt.gt.7) irpt=7 1244! 3 TU; W9XYZ K1ABC R 579 MA 1 28 28 1 3 13 74 ARRL RTTY contest 1245! 3 TU; W9XYZ G8ABC R 559 0013 1 28 28 1 3 13 74 ARRL RTTY (DX) 1246 write(c77,1010) itu,n28a,n28b,ir,irpt,nexch,i3 12471010 format(b1,2b28.28,b1,b3.3,b13.13,b3.3) 1248 endif 1249 endif 1250 1251900 return 1252end subroutine pack77_3 1253 1254 1255subroutine pack77_4(nwords,w,i3,n3,c77) 1256 1257! Check Type 4 (One nonstandard call and one hashed call) 1258! Example message: <WA9XYZ> PJ4/KA1ABC RR73 12 58 1 2 1 74 1259 1260 integer*8 n58 1261 logical ok1,ok2 1262 character*13 w(19) 1263 character*77 c77 1264 character*13 call_1,call_2 1265 character*11 c11 1266 character*6 bcall_1,bcall_2 1267 character*38 c 1268 data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ/'/ 1269 1270 iflip=0 1271 i3=-1 1272 if(nwords.eq.2 .or. nwords.eq.3) then 1273 call_1=w(1) 1274 if(call_1(1:1).eq.'<') call_1=w(1)(2:len(trim(w(1)))-1) 1275 call_2=w(2) 1276 if(call_2(1:1).eq.'<') call_2=w(2)(2:len(trim(w(2)))-1) 1277 call chkcall(call_1,bcall_1,ok1) 1278 call chkcall(call_2,bcall_2,ok2) 1279 if(call_1.eq.bcall_1 .and. call_2.eq.bcall_2 .and. ok1 .and. ok2) go to 900 1280 icq=0 1281 if(trim(w(1)).eq.'CQ' .or. (ok1.and.ok2)) then 1282 if(trim(w(1)).eq.'CQ' .and. len(trim(w(2))).le.4) go to 900 1283 i3=4 1284 n3=0 1285 if(trim(w(1)).eq.'CQ') icq=1 1286 endif 1287 1288 if(icq.eq.1) then 1289 iflip=0 1290 n12=0 1291 c11=adjustr(call_2(1:11)) 1292 call save_hash_call(w(2),n10,n12,n22) 1293 else if(w(1)(1:1).eq.'<') then 1294 iflip=0 1295 i3=4 1296 call save_hash_call(w(1),n10,n12,n22) 1297 c11=adjustr(call_2(1:11)) 1298 else if(w(2)(1:1).eq.'<') then 1299 iflip=1 1300 i3=4 1301 call save_hash_call(w(2),n10,n12,n22) 1302 c11=adjustr(call_1(1:11)) 1303 endif 1304 n58=0 1305 do i=1,11 1306 n58=n58*38 + index(c,c11(i:i)) - 1 1307 enddo 1308 nrpt=0 1309 if(trim(w(3)).eq.'RRR') nrpt=1 1310 if(trim(w(3)).eq.'RR73') nrpt=2 1311 if(trim(w(3)).eq.'73') nrpt=3 1312 if(icq.eq.1) then 1313 iflip=0 1314 nrpt=0 1315 endif 1316 write(c77,1010) n12,n58,iflip,nrpt,icq,i3 13171010 format(b12.12,b58.58,b1,b2.2,b1,b3.3) 1318 do i=1,77 1319 if(c77(i:i).eq.'*') c77(i:i)='0' !### Clean up any illegal chars ### 1320 enddo 1321 endif 1322 1323900 return 1324end subroutine pack77_4 1325 1326subroutine pack77_5(nwords,w,i3,n3,c77) 1327 1328! Pack a Type 0.2 message: EU VHF Contest mode 1329! Example message: PA3XYZ/P R 590003 IO91NP 28 1 1 3 12 25 1330! <PA3XYZ> <G4ABC/P> R 590003 IO91NP h10 h20 r1 s3 s12 g25 1331 1332 character*13 w(19),c13 1333 character*77 c77 1334 character*6 grid6 1335 logical is_grid6 1336 1337 is_grid6(grid6)=len(trim(grid6)).eq.6 .and. & 1338 grid6(1:1).ge.'A' .and. grid6(1:1).le.'R' .and. & 1339 grid6(2:2).ge.'A' .and. grid6(2:2).le.'R' .and. & 1340 grid6(3:3).ge.'0' .and. grid6(3:3).le.'9' .and. & 1341 grid6(4:4).ge.'0' .and. grid6(4:4).le.'9' .and. & 1342 grid6(5:5).ge.'A' .and. grid6(5:5).le.'X' .and. & 1343 grid6(6:6).ge.'A' .and. grid6(6:6).le.'X' 1344 1345 if(nwords.lt.4 .or. nwords.gt.5) return !nwords must be 4 or 5 1346 if(w(1)(1:1).ne.'<' .or. w(2)(1:1).ne.'<') return !Both calls must be hashed 1347 nx=-1 1348 read(w(nwords-1),*,err=2) nx 13492 if(nx.lt.520001 .or. nx.gt.594095) return !Exchange between 520001 - 594095 1350 if(.not.is_grid6(w(nwords)(1:6))) return !Last word must be a valid grid6 1351 1352! Type 0.2: <PA3XYZ> <G4ABC/P> R 590003 IO91NP h10 h20 r1 s3 s12 g25 1353 1354 i3=5 1355 n3=0 1356 1357 call save_hash_call(w(1),n10,n12,n22) 1358 i2=index(w(1),'>') 1359 c13=w(1)(2:i2-1) 1360 n12=ihashcall(c13,12) 1361 1362 call save_hash_call(w(2),n10a,n12a,n22) 1363 i2=index(w(2),'>') 1364 c13=w(2)(2:i2-1) 1365 n22=ihashcall(c13,22) 1366 1367 ir=0 1368 if(w(3)(1:2).eq.'R ') ir=1 1369 irpt=nx/10000 - 52 1370 iserial=mod(nx,10000) 1371 if(iserial.gt.2047) iserial=2047 1372 grid6=w(nwords)(1:6) 1373 j1=(ichar(grid6(1:1))-ichar('A'))*18*10*10*24*24 1374 j2=(ichar(grid6(2:2))-ichar('A'))*10*10*24*24 1375 j3=(ichar(grid6(3:3))-ichar('0'))*10*24*24 1376 j4=(ichar(grid6(4:4))-ichar('0'))*24*24 1377 j5=(ichar(grid6(5:5))-ichar('A'))*24 1378 j6=(ichar(grid6(6:6))-ichar('A')) 1379 igrid6=j1+j2+j3+j4+j5+j6 1380 1381 write(c77,1010) n12,n22,ir,irpt,iserial,igrid6,i3 13821010 format(b12.12,b22.22,b1,b3.3,b11.11,b25.25,b3.3) 1383 1384 return 1385end subroutine pack77_5 1386 1387 1388subroutine packtext77(c13,c71) 1389 1390 character*13 c13,w 1391 character*71 c71 1392 character*42 c 1393 character*1 qa(10),qb(10) 1394 data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/ 1395 1396 call mp_short_init 1397 qa=char(0) 1398 w=adjustr(c13) 1399 do i=1,13 1400 j=index(c,w(i:i))-1 1401 if(j.lt.0) j=0 1402 call mp_short_mult(qb,qa(2:10),9,42) !qb(1:9)=42*qa(2:9) 1403 call mp_short_add(qa,qb(2:10),9,j) !qa(1:9)=qb(2:9)+j 1404 enddo 1405 1406 write(c71,1010) qa(2:10) 14071010 format(b7.7,8b8.8) 1408 1409 return 1410end subroutine packtext77 1411 1412subroutine unpacktext77(c71,c13) 1413 1414 integer*1 ia(10) 1415 character*1 qa(10),qb(10) 1416 character*13 c13 1417 character*71 c71 1418 character*42 c 1419 equivalence (qa,ia),(qb,ib) 1420 data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/ 1421 1422 qa(1)=char(0) 1423 read(c71,1010) qa(2:10) 14241010 format(b7.7,8b8.8) 1425 1426 do i=13,1,-1 1427 call mp_short_div(qb,qa(2:10),9,42,ir) 1428 c13(i:i)=c(ir+1:ir+1) 1429 qa(2:10)=qb(1:9) 1430 enddo 1431 1432 return 1433end subroutine unpacktext77 1434 1435subroutine mp_short_ops(w,u) 1436 character*1 w(*),u(*) 1437 integer i,ireg,j,n,ir,iv,ii1,ii2 1438 character*1 creg(4) 1439 save ii1,ii2 1440 equivalence (ireg,creg) 1441 1442 entry mp_short_init 1443 ireg=256*ichar('2')+ichar('1') 1444 do j=1,4 1445 if (creg(j).eq.'1') ii1=j 1446 if (creg(j).eq.'2') ii2=j 1447 enddo 1448 return 1449 1450 entry mp_short_add(w,u,n,iv) 1451 ireg=256*iv 1452 do j=n,1,-1 1453 ireg=ichar(u(j))+ichar(creg(ii2)) 1454 w(j+1)=creg(ii1) 1455 enddo 1456 w(1)=creg(ii2) 1457 return 1458 1459 entry mp_short_mult(w,u,n,iv) 1460 ireg=0 1461 do j=n,1,-1 1462 ireg=ichar(u(j))*iv+ichar(creg(ii2)) 1463 w(j+1)=creg(ii1) 1464 enddo 1465 w(1)=creg(ii2) 1466 return 1467 1468 entry mp_short_div(w,u,n,iv,ir) 1469 ir=0 1470 do j=1,n 1471 i=256*ir+ichar(u(j)) 1472 w(j)=char(i/iv) 1473 ir=mod(i,iv) 1474 enddo 1475 return 1476 1477 return 1478end subroutine mp_short_ops 1479 1480subroutine add_call_to_recent_calls(callsign) 1481 1482 character*13 callsign 1483 logical ladd 1484 1485! only add if the callsign is not already on the list 1486 ladd=.true. 1487 do i=1,MAXRECENT-1 ! if callsign is at the end of the list add it again 1488 if(recent_calls(i).eq.callsign) ladd=.false. 1489 enddo 1490 1491 if(ladd) then 1492 do i=MAXRECENT,2,-1 1493 recent_calls(i)=recent_calls(i-1) 1494 enddo 1495 recent_calls(1)=callsign 1496 endif 1497 1498! Make sure that callsign is hashed 1499 call save_hash_call(callsign,n10,n12,n22) 1500 1501 return 1502end subroutine add_call_to_recent_calls 1503 1504subroutine to_grid4(n,grid4,ok) 1505 character*4 grid4 1506 logical ok 1507 1508 ok=.false. 1509 j1=n/(18*10*10) 1510 if (j1.lt.0.or.j1.gt.17) goto 900 1511 n=n-j1*18*10*10 1512 j2=n/(10*10) 1513 if (j2.lt.0.or.j2.gt.17) goto 900 1514 n=n-j2*10*10 1515 j3=n/10 1516 if (j3.lt.0.or.j3.gt.9) goto 900 1517 j4=n-j3*10 1518 if (j4.lt.0.or.j4.gt.9) goto 900 1519 grid4(1:1)=char(j1+ichar('A')) 1520 grid4(2:2)=char(j2+ichar('A')) 1521 grid4(3:3)=char(j3+ichar('0')) 1522 grid4(4:4)=char(j4+ichar('0')) 1523 ok=.true. 1524 1525900 return 1526end subroutine to_grid4 1527 1528subroutine to_grid6(n,grid6,ok) 1529 character*6 grid6 1530 logical ok 1531 1532 ok=.false. 1533 j1=n/(18*10*10*24*24) 1534 if (j1.lt.0.or.j1.gt.17) goto 900 1535 n=n-j1*18*10*10*24*24 1536 j2=n/(10*10*24*24) 1537 if (j2.lt.0.or.j2.gt.17) goto 900 1538 n=n-j2*10*10*24*24 1539 j3=n/(10*24*24) 1540 if (j3.lt.0.or.j3.gt.9) goto 900 1541 n=n-j3*10*24*24 1542 j4=n/(24*24) 1543 if (j4.lt.0.or.j4.gt.9) goto 900 1544 n=n-j4*24*24 1545 j5=n/24 1546 if (j5.lt.0.or.j5.gt.23) goto 900 1547 j6=n-j5*24 1548 if (j6.lt.0.or.j6.gt.23) goto 900 1549 grid6(1:1)=char(j1+ichar('A')) 1550 grid6(2:2)=char(j2+ichar('A')) 1551 grid6(3:3)=char(j3+ichar('0')) 1552 grid6(4:4)=char(j4+ichar('0')) 1553 grid6(5:5)=char(j5+ichar('A')) 1554 grid6(6:6)=char(j6+ichar('A')) 1555 ok=.true. 1556 1557900 return 1558end subroutine to_grid6 1559 1560subroutine to_grid(n,grid6,ok) 1561 ! 4-, or 6-character grid 1562 character*6 grid6 1563 logical ok 1564 1565 ok=.false. 1566 j1=n/(18*10*10*25*25) 1567 if (j1.lt.0.or.j1.gt.17) goto 900 1568 n=n-j1*18*10*10*25*25 1569 j2=n/(10*10*25*25) 1570 if (j2.lt.0.or.j2.gt.17) goto 900 1571 n=n-j2*10*10*25*25 1572 j3=n/(10*25*25) 1573 if (j3.lt.0.or.j3.gt.9) goto 900 1574 n=n-j3*10*25*25 1575 j4=n/(25*25) 1576 if (j4.lt.0.or.j4.gt.9) goto 900 1577 n=n-j4*25*25 1578 j5=n/25 1579 if (j5.lt.0.or.j5.gt.24) goto 900 1580 j6=n-j5*25 1581 if (j6.lt.0.or.j6.gt.24) goto 900 1582 grid6='' 1583 grid6(1:1)=char(j1+ichar('A')) 1584 grid6(2:2)=char(j2+ichar('A')) 1585 grid6(3:3)=char(j3+ichar('0')) 1586 grid6(4:4)=char(j4+ichar('0')) 1587 if (j5.ne.24.or.j6.ne.24) then 1588 grid6(5:5)=char(j5+ichar('A')) 1589 grid6(6:6)=char(j6+ichar('A')) 1590 endif 1591 ok=.true. 1592 1593900 return 1594end subroutine to_grid 1595 1596end module packjt77 1597