1module packjt 2 3 contains 4 5subroutine packbits(dbits,nsymd,m0,sym) 6 7 ! Pack 0s and 1s from dbits() into sym() with m0 bits per word. 8 ! NB: nsymd is the number of packed output words. 9 10 integer sym(:) 11 integer*1 dbits(:) 12 13 k=0 14 do i=1,nsymd 15 n=0 16 do j=1,m0 17 k=k+1 18 m=dbits(k) 19 n=ior(ishft(n,1),m) 20 enddo 21 sym(i)=n 22 enddo 23 24 return 25 end subroutine packbits 26 27 subroutine unpackbits(sym,nsymd,m0,dbits) 28 29 ! Unpack bits from sym() into dbits(), one bit per byte. 30 ! NB: nsymd is the number of input words, and m0 their length. 31 ! there will be m0*nsymd output bytes, each 0 or 1. 32 33 integer sym(:) 34 integer*1 dbits(:) 35 36 k=0 37 do i=1,nsymd 38 mask=ishft(1,m0-1) 39 do j=1,m0 40 k=k+1 41 dbits(k)=0 42 if(iand(mask,sym(i)).ne.0) dbits(k)=1 43 mask=ishft(mask,-1) 44 enddo 45 enddo 46 47 return 48 end subroutine unpackbits 49 50 subroutine packcall(callsign,ncall,text) 51 52 ! Pack a valid callsign into a 28-bit integer. 53 54 parameter (NBASE=37*36*10*27*27*27) 55 character callsign*6,c*1,tmp*6 56 logical text 57 58 text=.false. 59 60 ! Work-around for Swaziland prefix: 61 if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6) 62 63 if(callsign(1:3).eq.'CQ ') then 64 ncall=NBASE + 1 65 if(callsign(4:4).ge.'0' .and. callsign(4:4).le.'9' .and. & 66 callsign(5:5).ge.'0' .and. callsign(5:5).le.'9' .and. & 67 callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then 68 read(callsign(4:6),*) nfreq 69 ncall=NBASE + 3 + nfreq 70 endif 71 return 72 else if(callsign(1:4).eq.'QRZ ') then 73 ncall=NBASE + 2 74 return 75 else if(callsign(1:3).eq.'DE ') then 76 ncall=267796945 77 return 78 endif 79 80 tmp=' ' 81 if(callsign(3:3).ge.'0' .and. callsign(3:3).le.'9') then 82 tmp=callsign 83 else if(callsign(2:2).ge.'0' .and. callsign(2:2).le.'9') then 84 if(callsign(6:6).ne.' ') then 85 text=.true. 86 return 87 endif 88 tmp=' '//callsign(:5) 89 else 90 text=.true. 91 return 92 endif 93 94 do i=1,6 95 c=tmp(i:i) 96 if(c.ge.'a' .and. c.le.'z') & 97 tmp(i:i)=char(ichar(c)-ichar('a')+ichar('A')) 98 enddo 99 100 n1=0 101 if((tmp(1:1).ge.'A'.and.tmp(1:1).le.'Z').or.tmp(1:1).eq.' ') n1=1 102 if(tmp(1:1).ge.'0' .and. tmp(1:1).le.'9') n1=1 103 n2=0 104 if(tmp(2:2).ge.'A' .and. tmp(2:2).le.'Z') n2=1 105 if(tmp(2:2).ge.'0' .and. tmp(2:2).le.'9') n2=1 106 n3=0 107 if(tmp(3:3).ge.'0' .and. tmp(3:3).le.'9') n3=1 108 n4=0 109 if((tmp(4:4).ge.'A'.and.tmp(4:4).le.'Z').or.tmp(4:4).eq.' ') n4=1 110 n5=0 111 if((tmp(5:5).ge.'A'.and.tmp(5:5).le.'Z').or.tmp(5:5).eq.' ') n5=1 112 n6=0 113 if((tmp(6:6).ge.'A'.and.tmp(6:6).le.'Z').or.tmp(6:6).eq.' ') n6=1 114 115 if(n1+n2+n3+n4+n5+n6 .ne. 6) then 116 text=.true. 117 return 118 endif 119 120 ncall=nchar(tmp(1:1)) 121 ncall=36*ncall+nchar(tmp(2:2)) 122 ncall=10*ncall+nchar(tmp(3:3)) 123 ncall=27*ncall+nchar(tmp(4:4))-10 124 ncall=27*ncall+nchar(tmp(5:5))-10 125 ncall=27*ncall+nchar(tmp(6:6))-10 126 127 return 128 end subroutine packcall 129 130 subroutine unpackcall(ncall,word,iv2,psfx) 131 132 parameter (NBASE=37*36*10*27*27*27) 133 character word*12,c*37,psfx*4 134 135 data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/ 136 137 word='......' 138 psfx=' ' 139 n=ncall 140 iv2=0 141 if(n.ge.262177560) go to 20 142 word='......' 143 ! if(n.ge.262177560) go to 999 !Plain text message ... 144 i=mod(n,27)+11 145 word(6:6)=c(i:i) 146 n=n/27 147 i=mod(n,27)+11 148 word(5:5)=c(i:i) 149 n=n/27 150 i=mod(n,27)+11 151 word(4:4)=c(i:i) 152 n=n/27 153 i=mod(n,10)+1 154 word(3:3)=c(i:i) 155 n=n/10 156 i=mod(n,36)+1 157 word(2:2)=c(i:i) 158 n=n/36 159 i=n+1 160 word(1:1)=c(i:i) 161 do i=1,4 162 if(word(i:i).ne.' ') go to 10 163 enddo 164 go to 999 165 10 word=word(i:) 166 go to 999 167 168 20 if(n.ge.267796946) go to 999 169 170 ! We have a JT65v2 message 171 if((n.ge.262178563) .and. (n.le.264002071)) then 172 ! CQ with prefix 173 iv2=1 174 n=n-262178563 175 i=mod(n,37)+1 176 psfx(4:4)=c(i:i) 177 n=n/37 178 i=mod(n,37)+1 179 psfx(3:3)=c(i:i) 180 n=n/37 181 i=mod(n,37)+1 182 psfx(2:2)=c(i:i) 183 n=n/37 184 i=n+1 185 psfx(1:1)=c(i:i) 186 187 else if((n.ge.264002072) .and. (n.le.265825580)) then 188 ! QRZ with prefix 189 iv2=2 190 n=n-264002072 191 i=mod(n,37)+1 192 psfx(4:4)=c(i:i) 193 n=n/37 194 i=mod(n,37)+1 195 psfx(3:3)=c(i:i) 196 n=n/37 197 i=mod(n,37)+1 198 psfx(2:2)=c(i:i) 199 n=n/37 200 i=n+1 201 psfx(1:1)=c(i:i) 202 203 else if((n.ge.265825581) .and. (n.le.267649089)) then 204 ! DE with prefix 205 iv2=3 206 n=n-265825581 207 i=mod(n,37)+1 208 psfx(4:4)=c(i:i) 209 n=n/37 210 i=mod(n,37)+1 211 psfx(3:3)=c(i:i) 212 n=n/37 213 i=mod(n,37)+1 214 psfx(2:2)=c(i:i) 215 n=n/37 216 i=n+1 217 psfx(1:1)=c(i:i) 218 219 else if((n.ge.267649090) .and. (n.le.267698374)) then 220 ! CQ with suffix 221 iv2=4 222 n=n-267649090 223 i=mod(n,37)+1 224 psfx(3:3)=c(i:i) 225 n=n/37 226 i=mod(n,37)+1 227 psfx(2:2)=c(i:i) 228 n=n/37 229 i=n+1 230 psfx(1:1)=c(i:i) 231 232 else if((n.ge.267698375) .and. (n.le.267747659)) then 233 ! QRZ with suffix 234 iv2=5 235 n=n-267698375 236 i=mod(n,37)+1 237 psfx(3:3)=c(i:i) 238 n=n/37 239 i=mod(n,37)+1 240 psfx(2:2)=c(i:i) 241 n=n/37 242 i=n+1 243 psfx(1:1)=c(i:i) 244 245 else if((n.ge.267747660) .and. (n.le.267796944)) then 246 ! DE with suffix 247 iv2=6 248 n=n-267747660 249 i=mod(n,37)+1 250 psfx(3:3)=c(i:i) 251 n=n/37 252 i=mod(n,37)+1 253 psfx(2:2)=c(i:i) 254 n=n/37 255 i=n+1 256 psfx(1:1)=c(i:i) 257 258 else if(n.eq.267796945) then 259 ! DE with no prefix or suffix 260 iv2=7 261 psfx = ' ' 262 endif 263 264 999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:) 265 266 return 267 end subroutine unpackcall 268 269 subroutine packgrid(grid,ng,text) 270 271 parameter (NGBASE=180*180) 272 character*4 grid 273 character*1 c1 274 logical text 275 276 text=.false. 277 if(grid.eq.' ') go to 90 !Blank grid is OK 278 279 ! First, handle signal reports in the original range, -01 to -30 dB 280 if(grid(1:1).eq.'-') then 281 read(grid(2:3),*,err=800,end=800) n 282 if(n.ge.1 .and. n.le.30) then 283 ng=NGBASE+1+n 284 go to 900 285 endif 286 go to 10 287 else if(grid(1:2).eq.'R-') then 288 read(grid(3:4),*,err=800,end=800) n 289 if(n.ge.1 .and. n.le.30) then 290 ng=NGBASE+31+n 291 go to 900 292 endif 293 go to 10 294 ! Now check for RO, RRR, or 73 in the message field normally used for grid 295 else if(grid(1:4).eq.'RO ') then 296 ng=NGBASE+62 297 go to 900 298 else if(grid(1:4).eq.'RRR ') then 299 ng=NGBASE+63 300 go to 900 301 else if(grid(1:4).eq.'73 ') then 302 ng=NGBASE+64 303 go to 900 304 endif 305 306 ! Now check for extended-range signal reports: -50 to -31, and 0 to +49. 307 10 n=99 308 c1=grid(1:1) 309 read(grid,*,err=20,end=20) n 310 go to 30 311 20 read(grid(2:4),*,err=30,end=30) n 312 30 if(n.ge.-50 .and. n.le.49) then 313 if(c1.eq.'R') then 314 write(grid,1002) n+50 315 1002 format('LA',i2.2) 316 else 317 write(grid,1003) n+50 318 1003 format('KA',i2.2) 319 endif 320 go to 40 321 endif 322 323 ! Maybe it's free text ? 324 if(grid(1:1).lt.'A' .or. grid(1:1).gt.'R') text=.true. 325 if(grid(2:2).lt.'A' .or. grid(2:2).gt.'R') text=.true. 326 if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true. 327 if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true. 328 if(text) go to 900 329 330 ! OK, we have a properly formatted grid locator 331 40 call grid2deg(grid//'mm',dlong,dlat) 332 long=int(dlong) 333 lat=int(dlat+ 90.0) 334 ng=((long+180)/2)*180 + lat 335 go to 900 336 337 90 ng=NGBASE + 1 338 go to 900 339 340 800 text=.true. 341 900 continue 342 343 return 344 end subroutine packgrid 345 346 subroutine unpackgrid(ng,grid) 347 348 parameter (NGBASE=180*180) 349 character grid*4,grid6*6 350 351 grid=' ' 352 if(ng.ge.32400) go to 10 353 dlat=mod(ng,180)-90 354 dlong=(ng/180)*2 - 180 + 2 355 call deg2grid(dlong,dlat,grid6) 356 grid=grid6(:4) 357 if(grid(1:2).eq.'KA') then 358 read(grid(3:4),*) n 359 n=n-50 360 write(grid,1001) n 361 1001 format(i3.2) 362 if(grid(1:1).eq.' ') grid(1:1)='+' 363 else if(grid(1:2).eq.'LA') then 364 read(grid(3:4),*) n 365 n=n-50 366 write(grid,1002) n 367 1002 format('R',i3.2) 368 if(grid(2:2).eq.' ') grid(2:2)='+' 369 endif 370 go to 900 371 372 10 n=ng-NGBASE-1 373 if(n.ge.1 .and.n.le.30) then 374 write(grid,1012) -n 375 1012 format(i3.2) 376 else if(n.ge.31 .and.n.le.60) then 377 n=n-30 378 write(grid,1022) -n 379 1022 format('R',i3.2) 380 else if(n.eq.61) then 381 grid='RO' 382 else if(n.eq.62) then 383 grid='RRR' 384 else if(n.eq.63) then 385 grid='73' 386 endif 387 388 900 return 389 end subroutine unpackgrid 390 391 subroutine packmsg(msg0,dat,itype) 392 393 ! Packs a JT4/JT9/JT65 message into twelve 6-bit symbols 394 395 ! itype Message Type 396 !-------------------- 397 ! 1 Standardd message 398 ! 2 Type 1 prefix 399 ! 3 Type 1 suffix 400 ! 4 Type 2 prefix 401 ! 5 Type 2 suffix 402 ! 6 Free text 403 ! -1 Does not decode correctly 404 405 parameter (NBASE=37*36*10*27*27*27) 406 parameter (NBASE2=262178562) 407 character*22 msg0,msg 408 integer dat(:) 409 character*12 c1,c2 410 character*4 c3 411 character*6 grid6 412 logical text1,text2,text3 413 414 msg=msg0 415 itype=1 416 call fmtmsg(msg,iz) 417 418 if(msg(1:6).eq.'CQ DX ') msg(3:3)='9' 419 if(msg(1:3).eq."CQ " .and. & 420 msg(4:4).ge.'A' .and. msg(4:4).le.'Z' .and. & 421 msg(5:5).ge.'A' .and. msg(5:5).le.'Z' .and. & 422 msg(6:6).eq.' ') msg='E9'//msg(4:) 423 424 ! See if it's a CQ message 425 if(msg(1:3).eq.'CQ ') then 426 i=3 427 ! ... and if so, does it have a reply frequency? 428 if(msg(4:4).ge.'0' .and. msg(4:4).le.'9' .and. & 429 msg(5:5).ge.'0' .and. msg(5:5).le.'9' .and. & 430 msg(6:6).ge.'0' .and. msg(6:6).le.'9') i=7 431 go to 1 432 endif 433 434 do i=1,22 435 if(msg(i:i).eq.' ') go to 1 !Get 1st blank 436 enddo 437 go to 10 !Consider msg as plain text 438 439 1 ia=i 440 c1=msg(1:ia-1) 441 do i=ia+1,22 442 if(msg(i:i).eq.' ') go to 2 !Get 2nd blank 443 enddo 444 go to 10 !Consider msg as plain text 445 446 2 ib=i 447 c2=msg(ia+1:ib-1) 448 449 do i=ib+1,22 450 if(msg(i:i).eq.' ') go to 3 !Get 3rd blank 451 enddo 452 go to 10 !Consider msg as plain text 453 454 3 ic=i 455 c3=' ' 456 if(ic.ge.ib+1) c3=msg(ib+1:ic) 457 if(c3.eq.'OOO ') c3=' ' !Strip out the OOO flag 458 call getpfx1(c1,k1,nv2a) 459 if(nv2a.ge.4) go to 10 460 call packcall(c1,nc1,text1) 461 if(text1) go to 10 462 call getpfx1(c2,k2,nv2b) 463 call packcall(c2,nc2,text2) 464 if(text2) go to 10 465 if(nv2a.eq.2 .or. nv2a.eq.3 .or. nv2b.eq.2 .or. nv2b.eq.3) then 466 if(k1.lt.0 .or. k2.lt.0 .or. k1*k2.ne.0) go to 10 467 if(k2.gt.0) k2=k2+450 468 k=max(k1,k2) 469 if(k.gt.0) then 470 call k2grid(k,grid6) 471 c3=grid6(:4) 472 endif 473 endif 474 call packgrid(c3,ng,text3) 475 476 if(nv2a.lt.4 .and. nv2b.lt.4 .and. (.not.text1) .and. (.not.text2) .and. & 477 (.not.text3)) go to 20 478 479 nc1=0 480 if(nv2b.eq.4) then 481 if(c1(1:3).eq.'CQ ') nc1=262178563 + k2 482 if(c1(1:4).eq.'QRZ ') nc1=264002072 + k2 483 if(c1(1:3).eq.'DE ') nc1=265825581 + k2 484 else if(nv2b.eq.5) then 485 if(c1(1:3).eq.'CQ ') nc1=267649090 + k2 486 if(c1(1:4).eq.'QRZ ') nc1=267698375 + k2 487 if(c1(1:3).eq.'DE ') nc1=267747660 + k2 488 endif 489 if(nc1.ne.0) go to 20 490 491 ! The message will be treated as plain text. 492 10 itype=6 493 call packtext(msg,nc1,nc2,ng) 494 ng=ng+32768 495 496 ! Encode data into 6-bit words 497 20 continue 498 if(itype.ne.6) itype=max(nv2a,nv2b) 499 dat(1)=iand(ishft(nc1,-22),63) !6 bits 500 dat(2)=iand(ishft(nc1,-16),63) !6 bits 501 dat(3)=iand(ishft(nc1,-10),63) !6 bits 502 dat(4)=iand(ishft(nc1, -4),63) !6 bits 503 dat(5)=4*iand(nc1,15)+iand(ishft(nc2,-26),3) !4+2 bits 504 dat(6)=iand(ishft(nc2,-20),63) !6 bits 505 dat(7)=iand(ishft(nc2,-14),63) !6 bits 506 dat(8)=iand(ishft(nc2, -8),63) !6 bits 507 dat(9)=iand(ishft(nc2, -2),63) !6 bits 508 dat(10)=16*iand(nc2,3)+iand(ishft(ng,-12),15) !2+4 bits 509 dat(11)=iand(ishft(ng,-6),63) 510 dat(12)=iand(ng,63) 511 512 return 513 end subroutine packmsg 514 515 subroutine unpackmsg(dat,msg) 516 517 parameter (NBASE=37*36*10*27*27*27) 518 parameter (NGBASE=180*180) 519 integer dat(:) 520 character c1*12,c2*12,grid*4,msg*22,grid6*6,psfx*4,junk2*4 521 logical cqnnn 522 523 cqnnn=.false. 524 nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+ & 525 ishft(dat(4),4) + iand(ishft(dat(5),-2),15) 526 527 nc2=ishft(iand(dat(5),3),26) + ishft(dat(6),20) + & 528 ishft(dat(7),14) + ishft(dat(8),8) + ishft(dat(9),2) + & 529 iand(ishft(dat(10),-4),3) 530 531 ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12) 532 533 if(ng.ge.32768) then 534 call unpacktext(nc1,nc2,ng,msg) 535 go to 100 536 endif 537 538 call unpackcall(nc1,c1,iv2,psfx) 539 if(iv2.eq.0) then 540 ! This is an "original JT65" message 541 if(nc1.eq.NBASE+1) c1='CQ ' 542 if(nc1.eq.NBASE+2) c1='QRZ ' 543 nfreq=nc1-NBASE-3 544 if(nfreq.ge.0 .and. nfreq.le.999) then 545 write(c1,1002) nfreq 546 1002 format('CQ ',i3.3) 547 cqnnn=.true. 548 endif 549 endif 550 551 call unpackcall(nc2,c2,junk1,junk2) 552 call unpackgrid(ng,grid) 553 554 if(iv2.gt.0) then 555 ! This is a JT65v2 message 556 do i=1,4 557 if(ichar(psfx(i:i)).eq.0) psfx(i:i)=' ' 558 enddo 559 560 n1=len_trim(psfx) 561 n2=len_trim(c2) 562 if(iv2.eq.1) msg='CQ '//psfx(:n1)//'/'//c2(:n2)//' '//grid 563 if(iv2.eq.2) msg='QRZ '//psfx(:n1)//'/'//c2(:n2)//' '//grid 564 if(iv2.eq.3) msg='DE '//psfx(:n1)//'/'//c2(:n2)//' '//grid 565 if(iv2.eq.4) msg='CQ '//c2(:n2)//'/'//psfx(:n1)//' '//grid 566 if(iv2.eq.5) msg='QRZ '//c2(:n2)//'/'//psfx(:n1)//' '//grid 567 if(iv2.eq.6) msg='DE '//c2(:n2)//'/'//psfx(:n1)//' '//grid 568 if(iv2.eq.7) msg='DE '//c2(:n2)//' '//grid 569 if(iv2.eq.8) msg=' ' 570 go to 100 571 else 572 573 endif 574 575 grid6=grid//'ma' 576 call grid2k(grid6,k) 577 if(k.ge.1 .and. k.le.450) call getpfx2(k,c1) 578 if(k.ge.451 .and. k.le.900) call getpfx2(k,c2) 579 580 i=index(c1,char(0)) 581 if(i.ge.3) c1=c1(1:i-1)//' ' 582 i=index(c2,char(0)) 583 if(i.ge.3) c2=c2(1:i-1)//' ' 584 585 msg=' ' 586 j=0 587 if(cqnnn) then 588 msg=c1//' ' 589 j=7 !### ??? ### 590 go to 10 591 endif 592 593 do i=1,12 594 j=j+1 595 msg(j:j)=c1(i:i) 596 if(c1(i:i).eq.' ') go to 10 597 enddo 598 j=j+1 599 msg(j:j)=' ' 600 601 10 do i=1,12 602 if(j.le.21) j=j+1 603 msg(j:j)=c2(i:i) 604 if(c2(i:i).eq.' ') go to 20 605 enddo 606 if(j.le.21) j=j+1 607 msg(j:j)=' ' 608 609 20 if(k.eq.0) then 610 do i=1,4 611 if(j.le.21) j=j+1 612 msg(j:j)=grid(i:i) 613 enddo 614 if(j.le.21) j=j+1 615 msg(j:j)=' ' 616 endif 617 618 100 continue 619 if(msg(1:6).eq.'CQ9DX ') msg(3:3)=' ' 620 if(msg(1:2).eq.'E9' .and. & 621 msg(3:3).ge.'A' .and. msg(3:3).le.'Z' .and. & 622 msg(4:4).ge.'A' .and. msg(4:4).le.'Z' .and. & 623 msg(5:5).eq.' ') msg='CQ '//msg(3:) 624 625 return 626 end subroutine unpackmsg 627 628 subroutine packtext(msg,nc1,nc2,nc3) 629 630 parameter (MASK28=2**28 - 1) 631 character*13 msg 632 character*42 c 633 data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ 634 635 nc1=0 636 nc2=0 637 nc3=0 638 639 do i=1,5 !First 5 characters in nc1 640 do j=1,42 !Get character code 641 if(msg(i:i).eq.c(j:j)) go to 10 642 enddo 643 j=37 644 10 j=j-1 !Codes should start at zero 645 nc1=42*nc1 + j 646 enddo 647 648 do i=6,10 !Characters 6-10 in nc2 649 do j=1,42 !Get character code 650 if(msg(i:i).eq.c(j:j)) go to 20 651 enddo 652 j=37 653 20 j=j-1 !Codes should start at zero 654 nc2=42*nc2 + j 655 enddo 656 657 do i=11,13 !Characters 11-13 in nc3 658 do j=1,42 !Get character code 659 if(msg(i:i).eq.c(j:j)) go to 30 660 enddo 661 j=37 662 30 j=j-1 !Codes should start at zero 663 nc3=42*nc3 + j 664 enddo 665 666 ! We now have used 17 bits in nc3. Must move one each to nc1 and nc2. 667 nc1=nc1+nc1 668 if(iand(nc3,32768).ne.0) nc1=nc1+1 669 nc2=nc2+nc2 670 if(iand(nc3,65536).ne.0) nc2=nc2+1 671 nc3=iand(nc3,32767) 672 673 return 674 end subroutine packtext 675 676 subroutine unpacktext(nc1,nc2,nc3,msg) 677 678 character*22 msg 679 character*44 c 680 data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ 681 682 nc3=iand(nc3,32767) !Remove the "plain text" bit 683 if(iand(nc1,1).ne.0) nc3=nc3+32768 684 nc1=nc1/2 685 if(iand(nc2,1).ne.0) nc3=nc3+65536 686 nc2=nc2/2 687 688 do i=5,1,-1 689 j=mod(nc1,42)+1 690 msg(i:i)=c(j:j) 691 nc1=nc1/42 692 enddo 693 694 do i=10,6,-1 695 j=mod(nc2,42)+1 696 msg(i:i)=c(j:j) 697 nc2=nc2/42 698 enddo 699 700 do i=13,11,-1 701 j=mod(nc3,42)+1 702 msg(i:i)=c(j:j) 703 nc3=nc3/42 704 enddo 705 msg(14:22) = ' ' 706 707 return 708 end subroutine unpacktext 709 710 subroutine getpfx1(callsign,k,nv2) 711 712 character*12 callsign0,callsign,lof,rof 713 character*8 c 714 character addpfx*8,tpfx*4,tsfx*3 715 logical ispfx,issfx,invalid 716 common/pfxcom/addpfx 717 include 'pfx.f90' 718 719 callsign0=callsign 720 nv2=1 721 iz=index(callsign,' ') - 1 722 if(iz.lt.0) iz=12 723 islash=index(callsign(1:iz),'/') 724 k=0 725 ! if(k.eq.0) go to 10 !Tnx to DL9RDZ for reminder:this was for tests only! 726 c=' ' 727 if(islash.gt.0 .and. islash.le.(iz-4)) then 728 ! Add-on prefix 729 c=callsign(1:islash-1) 730 callsign=callsign(islash+1:iz) 731 do i=1,NZ 732 if(pfx(i)(1:4).eq.c) then 733 k=i 734 nv2=2 735 go to 10 736 endif 737 enddo 738 if(addpfx.eq.c) then 739 k=449 740 nv2=2 741 go to 10 742 endif 743 744 else if(islash.eq.(iz-1)) then 745 ! Add-on suffix 746 c=callsign(islash+1:iz) 747 callsign=callsign(1:islash-1) 748 do i=1,NZ2 749 if(sfx(i).eq.c(1:1)) then 750 k=400+i 751 nv2=3 752 go to 10 753 endif 754 enddo 755 endif 756 757 10 if(islash.ne.0 .and.k.eq.0) then 758 ! Original JT65 would force this compound callsign to be treated as 759 ! plain text. In JT65v2, we will encode the prefix or suffix into nc1. 760 ! The task here is to compute the proper value of k. 761 lof=callsign0(:islash-1) 762 rof=callsign0(islash+1:) 763 llof=len_trim(lof) 764 lrof=len_trim(rof) 765 ispfx=(llof.gt.0 .and. llof.le.4) 766 issfx=(lrof.gt.0 .and. lrof.le.3) 767 invalid=.not.(ispfx.or.issfx) 768 if(ispfx.and.issfx) then 769 if(llof.lt.3) issfx=.false. 770 if(lrof.lt.3) ispfx=.false. 771 if(ispfx.and.issfx) then 772 i=ichar(callsign0(islash-1:islash-1)) 773 if(i.ge.ichar('0') .and. i.le.ichar('9')) then 774 issfx=.false. 775 else 776 ispfx=.false. 777 endif 778 endif 779 endif 780 781 if(invalid) then 782 k=-1 783 else 784 if(ispfx) then 785 tpfx=lof(1:4) 786 k=nchar(tpfx(1:1)) 787 k=37*k + nchar(tpfx(2:2)) 788 k=37*k + nchar(tpfx(3:3)) 789 k=37*k + nchar(tpfx(4:4)) 790 nv2=4 791 i=index(callsign0,'/') 792 callsign=callsign0(:i-1) 793 callsign=callsign0(i+1:) 794 endif 795 if(issfx) then 796 tsfx=rof(1:3) 797 k=nchar(tsfx(1:1)) 798 k=37*k + nchar(tsfx(2:2)) 799 k=37*k + nchar(tsfx(3:3)) 800 nv2=5 801 i=index(callsign0,'/') 802 callsign=callsign0(:i-1) 803 endif 804 endif 805 endif 806 807 return 808 end subroutine getpfx1 809 810 subroutine getpfx2(k0,callsign) 811 812 character callsign*12 813 include 'pfx.f90' 814 character addpfx*8 815 common/pfxcom/addpfx 816 817 k=k0 818 if(k.gt.450) k=k-450 819 if(k.ge.1 .and. k.le.NZ) then 820 iz=index(pfx(k),' ') - 1 821 callsign=pfx(k)(1:iz)//'/'//callsign 822 else if(k.ge.401 .and. k.le.400+NZ2) then 823 iz=index(callsign,' ') - 1 824 callsign=callsign(1:iz)//'/'//sfx(k-400) 825 else if(k.eq.449) then 826 iz=index(addpfx,' ') - 1 827 if(iz.lt.1) iz=8 828 callsign=addpfx(1:iz)//'/'//callsign 829 endif 830 831 return 832 end subroutine getpfx2 833 834 subroutine grid2k(grid,k) 835 836 character*6 grid 837 838 call grid2deg(grid,xlong,xlat) 839 nlong=nint(xlong) 840 nlat=nint(xlat) 841 k=0 842 if(nlat.ge.85) k=5*(nlong+179)/2 + nlat-84 843 844 return 845 end subroutine grid2k 846 847 subroutine k2grid(k,grid) 848 character grid*6 849 850 nlong=2*mod((k-1)/5,90)-179 851 if(k.gt.450) nlong=nlong+180 852 nlat=mod(k-1,5)+ 85 853 dlat=nlat 854 dlong=nlong 855 call deg2grid(dlong,dlat,grid) 856 857 return 858 end subroutine k2grid 859 860 subroutine grid2n(grid,n) 861 character*4 grid 862 863 i1=ichar(grid(1:1))-ichar('A') 864 i2=ichar(grid(3:3))-ichar('0') 865 i=10*i1 + i2 866 n=-i - 31 867 868 return 869 end subroutine grid2n 870 871 subroutine n2grid(n,grid) 872 character*4 grid 873 874 if(n.gt.-31 .or. n.lt.-70) stop 'Error in n2grid' 875 i=-(n+31) !NB: 0 <= i <= 39 876 i1=i/10 877 i2=mod(i,10) 878 grid(1:1)=char(ichar('A')+i1) 879 grid(2:2)='A' 880 grid(3:3)=char(ichar('0')+i2) 881 grid(4:4)='0' 882 883 return 884 end subroutine n2grid 885 886 function nchar(c) 887 888 ! Convert ascii number, letter, or space to 0-36 for callsign packing. 889 890 character c*1 891 892 n=0 !Silence compiler warning 893 if(c.ge.'0' .and. c.le.'9') then 894 n=ichar(c)-ichar('0') 895 else if(c.ge.'A' .and. c.le.'Z') then 896 n=ichar(c)-ichar('A') + 10 897 else if(c.ge.'a' .and. c.le.'z') then 898 n=ichar(c)-ichar('a') + 10 899 else if(c.ge.' ') then 900 n=36 901 else 902 Print*,'Invalid character in callsign ',c,' ',ichar(c) 903 stop 904 endif 905 nchar=n 906 907 return 908 end function nchar 909 910 subroutine pack50(n1,n2,dat) 911 912 integer*1 dat(:),i1 913 914 i1=iand(ishft(n1,-20),255) !8 bits 915 dat(1)=i1 916 i1=iand(ishft(n1,-12),255) !8 bits 917 dat(2)=i1 918 i1=iand(ishft(n1, -4),255) !8 bits 919 dat(3)=i1 920 i1=16*iand(n1,15)+iand(ishft(n2,-18),15) !4+4 bits 921 dat(4)=i1 922 i1=iand(ishft(n2,-10),255) !8 bits 923 dat(5)=i1 924 i1=iand(ishft(n2, -2),255) !8 bits 925 dat(6)=i1 926 i1=64*iand(n2,3) !2 bits 927 dat(7)=i1 928 dat(8)=0 929 dat(9)=0 930 dat(10)=0 931 dat(11)=0 932 933 return 934 end subroutine pack50 935 936subroutine packpfx(call1,n1,ng,nadd) 937 938 character*12 call1,call0 939 character*3 pfx 940 logical text 941 942 i1=index(call1,'/') 943 if(call1(i1+2:i1+2).eq.' ') then 944! Single-character add-on suffix (maybe also fourth suffix letter?) 945 call0=call1(:i1-1) 946 call packcall(call0,n1,text) 947 nadd=1 948 nc=ichar(call1(i1+1:i1+1)) 949 if(nc.ge.48 .and. nc.le.57) then 950 n=nc-48 951 else if(nc.ge.65 .and. nc.le.90) then 952 n=nc-65+10 953 else 954 n=38 955 endif 956 nadd=1 957 ng=60000-32768+n 958 else if(call1(i1+3:i1+3).eq.' ') then 959! Two-character numerical suffix, /10 to /99 960 call0=call1(:i1-1) 961 call packcall(call0,n1,text) 962 nadd=1 963 n=10*(ichar(call1(i1+1:i1+1))-48) + ichar(call1(i1+2:i1+2)) - 48 964 nadd=1 965 ng=60000 + 26 + n 966 else 967! Prefix of 1 to 3 characters 968 pfx=call1(:i1-1) 969 if(pfx(3:3).eq.' ') pfx=' '//pfx(1:2) 970 if(pfx(3:3).eq.' ') pfx=' '//pfx(1:2) 971 call0=call1(i1+1:) 972 call packcall(call0,n1,text) 973 974 ng=0 975 do i=1,3 976 nc=ichar(pfx(i:i)) 977 if(nc.ge.48 .and. nc.le.57) then 978 n=nc-48 979 else if(nc.ge.65 .and. nc.le.90) then 980 n=nc-65+10 981 else 982 n=36 983 endif 984 ng=37*ng + n 985 enddo 986 nadd=0 987 if(ng.ge.32768) then 988 ng=ng-32768 989 nadd=1 990 endif 991 endif 992 993 return 994end subroutine packpfx 995 996end module packjt 997