From c3102ea4853ec331d08ce7e9bb35833c52e78690 Mon Sep 17 00:00:00 2001 From: Joe Taylor Date: Tue, 10 Jan 2017 16:48:12 +0000 Subject: [PATCH] More conversions from .f to .f90. git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/map65@7475 ab8295b8-cf94-4d9e-aec4-7959e3be5d79 --- libm65/CMakeLists.txt | 23 +++++----- libm65/nchar.f | 23 ---------- libm65/nchar.f90 | 23 ++++++++++ libm65/packcall.f | 79 -------------------------------- libm65/packcall.f90 | 78 +++++++++++++++++++++++++++++++ libm65/packdxcc.f | 64 -------------------------- libm65/packdxcc.f90 | 64 ++++++++++++++++++++++++++ libm65/packgrid.f | 47 ------------------- libm65/packgrid.f90 | 47 +++++++++++++++++++ libm65/packmsg.f | 104 ------------------------------------------ libm65/packmsg.f90 | 104 ++++++++++++++++++++++++++++++++++++++++++ libm65/packtext.f | 47 ------------------- libm65/packtext.f90 | 47 +++++++++++++++++++ libm65/pctile.f | 13 ------ libm65/pctile.f90 | 13 ++++++ libm65/set.f | 31 ------------- libm65/set.f90 | 31 +++++++++++++ libm65/setup65.f | 96 -------------------------------------- libm65/setup65.f90 | 96 ++++++++++++++++++++++++++++++++++++++ libm65/sort.f | 4 -- libm65/sort.f90 | 6 +++ 21 files changed, 521 insertions(+), 519 deletions(-) delete mode 100644 libm65/nchar.f create mode 100644 libm65/nchar.f90 delete mode 100644 libm65/packcall.f create mode 100644 libm65/packcall.f90 delete mode 100644 libm65/packdxcc.f create mode 100644 libm65/packdxcc.f90 delete mode 100644 libm65/packgrid.f create mode 100644 libm65/packgrid.f90 delete mode 100644 libm65/packmsg.f create mode 100644 libm65/packmsg.f90 delete mode 100644 libm65/packtext.f create mode 100644 libm65/packtext.f90 delete mode 100644 libm65/pctile.f create mode 100644 libm65/pctile.f90 delete mode 100644 libm65/set.f create mode 100644 libm65/set.f90 delete mode 100644 libm65/setup65.f create mode 100644 libm65/setup65.f90 delete mode 100644 libm65/sort.f create mode 100644 libm65/sort.f90 diff --git a/libm65/CMakeLists.txt b/libm65/CMakeLists.txt index c424af52e..d5f9cca70 100644 --- a/libm65/CMakeLists.txt +++ b/libm65/CMakeLists.txt @@ -101,30 +101,31 @@ set (FSRCS map65a.f90 moon2.f90 moondop.f90 + nchar.f90 noisegen.f90 + packcall.f90 + packdxcc.f90 + packgrid.f90 + packmsg.f90 + packtext.f90 + pctile.f90 pfxdump.f90 recvpkt.f90 rfile3a.f90 s3avg.f90 sec_midn.f90 + set.f90 + setup65.f90 sleep_msec.f90 - symspec.f90 + sort.f90 + +symspec.f90 timer.f90 timf2.f90 tm2.f90 zplot.f90 f77_wisdom.f - nchar.f - packcall.f - packdxcc.f - packgrid.f - packmsg.f - packtext.f - pctile.f - set.f - setup65.f - sort.f ssort.f sun.f toxyz.f diff --git a/libm65/nchar.f b/libm65/nchar.f deleted file mode 100644 index a13148668..000000000 --- a/libm65/nchar.f +++ /dev/null @@ -1,23 +0,0 @@ - function nchar(c) - -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) - call exit(1) - endif - nchar=n - - return - end diff --git a/libm65/nchar.f90 b/libm65/nchar.f90 new file mode 100644 index 000000000..21593bd13 --- /dev/null +++ b/libm65/nchar.f90 @@ -0,0 +1,23 @@ +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) + call exit(1) + endif + nchar=n + + return +end function nchar diff --git a/libm65/packcall.f b/libm65/packcall.f deleted file mode 100644 index 9e91a0be8..000000000 --- a/libm65/packcall.f +++ /dev/null @@ -1,79 +0,0 @@ - subroutine packcall(callsign,ncall,text) - -C 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. - -C 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 diff --git a/libm65/packcall.f90 b/libm65/packcall.f90 new file mode 100644 index 000000000..bf31c611d --- /dev/null +++ b/libm65/packcall.f90 @@ -0,0 +1,78 @@ +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 diff --git a/libm65/packdxcc.f b/libm65/packdxcc.f deleted file mode 100644 index ac370ef3f..000000000 --- a/libm65/packdxcc.f +++ /dev/null @@ -1,64 +0,0 @@ - subroutine packdxcc(c,ng,ldxcc) - - character*3 c - logical ldxcc - - parameter (NZ=303) - character*5 pfx(NZ) - data pfx/ - + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', - + '3D2 ', '3DA ','3V ','3W ','3X ','3Y ', - + '4J ','4L ','4S ','4U1 ', '4W ', - + '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', - + '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', - + '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', - + '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', - + '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', - + 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', - + 'C3 ','C5 ','C6 ','C9 ','CE ','CE0 ', - + 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', - + 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', - + 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', - + 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', - + 'F ','FG ','FH ','FJ ','FK ', 'FM ','FO ', - + 'FP ','FR ', - + 'FT5 ', 'FW ','FY ','M ','MD ','MI ', - + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', - + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ', - + 'HL ','HM ','HP ','HR ','HS ','HV ','HZ ', - + 'I ','IG9 ','IS ','IT9 ','J2 ','J3 ','J5 ','J6 ', - + 'J7 ','J8 ','JA ','JD ', 'JT ','JW ', - + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', - + 'KH4 ','KH5 ', 'KH6 ','KH7 ','KH8 ','KH9 ','KL ', - + 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', - + 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', - + 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', - + 'PJ2 ','PJ7 ','PY ','PY0 ', 'PZ ','R1F ', - + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', - + 'ST ','SU ','SV ', 'SV5 ','SV9 ','T2 ','T30 ', - + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', - + 'TA1 ','TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', - + 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', - + 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', - + 'V6 ','V7 ','V8 ','VE ','VK ','VK0 ', 'VK9 ', - + 'VP2 ', - + 'VP5 ','VP6 ', 'VP8 ', - + 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', - + 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', - + 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', - + 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', - + 'ZD9 ','ZF ','ZK1 ', 'ZK2 ','ZK3 ','ZL ','ZL7 ', - + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 '/ - - ldxcc=.false. - ng=0 - do i=1,NZ - if(pfx(i)(1:3).eq.c) go to 10 - enddo - go to 20 - - 10 ng=180*180+61+i - ldxcc=.true. - - 20 return - end diff --git a/libm65/packdxcc.f90 b/libm65/packdxcc.f90 new file mode 100644 index 000000000..2fdec9208 --- /dev/null +++ b/libm65/packdxcc.f90 @@ -0,0 +1,64 @@ +subroutine packdxcc(c,ng,ldxcc) + + character*3 c + logical ldxcc + + parameter (NZ=303) + character*5 pfx(NZ) + data pfx/ & + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', & + '3D2 ', '3DA ','3V ','3W ','3X ','3Y ', & + '4J ','4L ','4S ','4U1 ', '4W ', & + '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', & + '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', & + '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', & + '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', & + '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', & + 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', & + 'C3 ','C5 ','C6 ','C9 ','CE ','CE0 ', & + 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', & + 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', & + 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', & + 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', & + 'F ','FG ','FH ','FJ ','FK ', 'FM ','FO ', & + 'FP ','FR ', & + 'FT5 ', 'FW ','FY ','M ','MD ','MI ', & + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', & + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ', & + 'HL ','HM ','HP ','HR ','HS ','HV ','HZ ', & + 'I ','IG9 ','IS ','IT9 ','J2 ','J3 ','J5 ','J6 ', & + 'J7 ','J8 ','JA ','JD ', 'JT ','JW ', & + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', & + 'KH4 ','KH5 ', 'KH6 ','KH7 ','KH8 ','KH9 ','KL ', & + 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', & + 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', & + 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', & + 'PJ2 ','PJ7 ','PY ','PY0 ', 'PZ ','R1F ', & + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', & + 'ST ','SU ','SV ', 'SV5 ','SV9 ','T2 ','T30 ', & + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', & + 'TA1 ','TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', & + 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', & + 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', & + 'V6 ','V7 ','V8 ','VE ','VK ','VK0 ', 'VK9 ', & + 'VP2 ', & + 'VP5 ','VP6 ', 'VP8 ', & + 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', & + 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', & + 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', & + 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', & + 'ZD9 ','ZF ','ZK1 ', 'ZK2 ','ZK3 ','ZL ','ZL7 ', & + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 '/ + + ldxcc=.false. + ng=0 + do i=1,NZ + if(pfx(i)(1:3).eq.c) go to 10 + enddo + go to 20 + +10 ng=180*180+61+i + ldxcc=.true. + +20 return +end subroutine packdxcc diff --git a/libm65/packgrid.f b/libm65/packgrid.f deleted file mode 100644 index 8f1d00330..000000000 --- a/libm65/packgrid.f +++ /dev/null @@ -1,47 +0,0 @@ - subroutine packgrid(grid,ng,text) - - parameter (NGBASE=180*180) - character*4 grid - logical text - - text=.false. - if(grid.eq.' ') go to 90 !Blank grid is OK - -C Test for numerical signal report, etc. - if(grid(1:1).eq.'-') then - read(grid(2:3),*,err=1,end=1) n - 1 ng=NGBASE+1+n - go to 100 - else if(grid(1:2).eq.'R-') then - read(grid(3:4),*,err=2,end=2) n - 2 if(n.eq.0) go to 90 - ng=NGBASE+31+n - go to 100 - else if(grid(1:2).eq.'RO') then - ng=NGBASE+62 - go to 100 - else if(grid(1:3).eq.'RRR') then - ng=NGBASE+63 - go to 100 - else if(grid(1:2).eq.'73') then - ng=NGBASE+64 - go to 100 - endif - - if(grid(1:1).lt.'A' .or. grid(1:1).gt.'R') text=.true. - if(grid(2:2).lt.'A' .or. grid(2:2).gt.'R') text=.true. - if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true. - if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true. - if(text) go to 100 - - call grid2deg(grid//'mm',dlong,dlat) - long=dlong - lat=dlat+ 90.0 - ng=((long+180)/2)*180 + lat - go to 100 - - 90 ng=NGBASE + 1 - - 100 return - end - diff --git a/libm65/packgrid.f90 b/libm65/packgrid.f90 new file mode 100644 index 000000000..1fb97e3fa --- /dev/null +++ b/libm65/packgrid.f90 @@ -0,0 +1,47 @@ +subroutine packgrid(grid,ng,text) + + parameter (NGBASE=180*180) + character*4 grid + logical text + + text=.false. + if(grid.eq.' ') go to 90 !Blank grid is OK + +! Test for numerical signal report, etc. + if(grid(1:1).eq.'-') then + read(grid(2:3),*,err=1,end=1) n +1 ng=NGBASE+1+n + go to 100 + else if(grid(1:2).eq.'R-') then + read(grid(3:4),*,err=2,end=2) n +2 if(n.eq.0) go to 90 + ng=NGBASE+31+n + go to 100 + else if(grid(1:2).eq.'RO') then + ng=NGBASE+62 + go to 100 + else if(grid(1:3).eq.'RRR') then + ng=NGBASE+63 + go to 100 + else if(grid(1:2).eq.'73') then + ng=NGBASE+64 + go to 100 + endif + + if(grid(1:1).lt.'A' .or. grid(1:1).gt.'R') text=.true. + if(grid(2:2).lt.'A' .or. grid(2:2).gt.'R') text=.true. + if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true. + if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true. + if(text) go to 100 + + call grid2deg(grid//'mm',dlong,dlat) + long=dlong + lat=dlat+ 90.0 + ng=((long+180)/2)*180 + lat + go to 100 + +90 ng=NGBASE + 1 + +100 return +end subroutine packgrid + diff --git a/libm65/packmsg.f b/libm65/packmsg.f deleted file mode 100644 index 65e67eca5..000000000 --- a/libm65/packmsg.f +++ /dev/null @@ -1,104 +0,0 @@ - subroutine packmsg(msg,dat) - - parameter (NBASE=37*36*10*27*27*27) - parameter (NBASE2=262178562) - character*22 msg - integer dat(12) - character*12 c1,c2,c2z - character*4 c3 - character*6 grid6 -c character*3 dxcc !Where is DXCC implemented? - logical text1,text2,text3 - -C Convert all letters to upper case - do i=1,22 - if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') - + msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a')) - enddo - -C See if it's a CQ message - if(msg(1:3).eq.'CQ ') then - i=3 -C ... 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,nv2) - if(nv2.ne.0) go to 10 - call packcall(c1,nc1,text1) - c2z=c2 - call getpfx1(c2,k2,nv2) - call packcall(c2,nc2,text2) - if(nv2.eq.0) 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(nv2.eq.0 .and. (.not.text1) .and. (.not.text2) .and. - + (.not.text3)) go to 20 - if(nv2.gt.0) then - if(nv2.eq.1) then - if(c1(1:3).eq.'CQ ') nc1=262178563 + k2 - if(c1(1:4).eq.'QRZ ') nc1=264002072 + k2 - if(c1(1:3).eq.'DE ') nc1=265825581 + k2 - endif - if(nv2.eq.2) then - if(c1(1:3).eq.'CQ ') nc1=267649090 + k2 - if(c1(1:4).eq.'QRZ ') nc1=267698375 + k2 - if(c1(1:3).eq.'DE ') nc1=267747660 + k2 - endif - go to 20 - endif - -C The message will be treated as plain text. - 10 call packtext(msg,nc1,nc2,ng) - ng=ng+32768 - -C Encode data into 6-bit words - 20 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 diff --git a/libm65/packmsg.f90 b/libm65/packmsg.f90 new file mode 100644 index 000000000..5bb0cc057 --- /dev/null +++ b/libm65/packmsg.f90 @@ -0,0 +1,104 @@ +subroutine packmsg(msg,dat) + + parameter (NBASE=37*36*10*27*27*27) + parameter (NBASE2=262178562) + character*22 msg + integer dat(12) + character*12 c1,c2,c2z + character*4 c3 + character*6 grid6 +! character*3 dxcc !Where is DXCC implemented? + logical text1,text2,text3 + +! Convert all letters to upper case + do i=1,22 + if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') msg(i:i)= & + char(ichar(msg(i:i))+ichar('A')-ichar('a')) + enddo + +! 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,nv2) + if(nv2.ne.0) go to 10 + call packcall(c1,nc1,text1) + c2z=c2 + call getpfx1(c2,k2,nv2) + call packcall(c2,nc2,text2) + if(nv2.eq.0) 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(nv2.eq.0 .and. (.not.text1) .and. (.not.text2) .and. & + (.not.text3)) go to 20 + if(nv2.gt.0) then + if(nv2.eq.1) then + if(c1(1:3).eq.'CQ ') nc1=262178563 + k2 + if(c1(1:4).eq.'QRZ ') nc1=264002072 + k2 + if(c1(1:3).eq.'DE ') nc1=265825581 + k2 + endif + if(nv2.eq.2) then + if(c1(1:3).eq.'CQ ') nc1=267649090 + k2 + if(c1(1:4).eq.'QRZ ') nc1=267698375 + k2 + if(c1(1:3).eq.'DE ') nc1=267747660 + k2 + endif + go to 20 + endif + +! The message will be treated as plain text. +10 call packtext(msg,nc1,nc2,ng) + ng=ng+32768 + +! Encode data into 6-bit words +20 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 diff --git a/libm65/packtext.f b/libm65/packtext.f deleted file mode 100644 index c4029766f..000000000 --- a/libm65/packtext.f +++ /dev/null @@ -1,47 +0,0 @@ - subroutine packtext(msg,nc1,nc2,nc3) - - parameter (MASK28=2**28 - 1) - character*13 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 - -C 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 diff --git a/libm65/packtext.f90 b/libm65/packtext.f90 new file mode 100644 index 000000000..10f348878 --- /dev/null +++ b/libm65/packtext.f90 @@ -0,0 +1,47 @@ +subroutine packtext(msg,nc1,nc2,nc3) + + parameter (MASK28=2**28 - 1) + character*13 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 diff --git a/libm65/pctile.f b/libm65/pctile.f deleted file mode 100644 index 8cfedc154..000000000 --- a/libm65/pctile.f +++ /dev/null @@ -1,13 +0,0 @@ - subroutine pctile(x,tmp,nmax,npct,xpct) - real x(nmax),tmp(nmax) - - do i=1,nmax - tmp(i)=x(i) - enddo - call sort(nmax,tmp) - j=nint(nmax*0.01*npct) - if(j.lt.1) j=1 - xpct=tmp(j) - - return - end diff --git a/libm65/pctile.f90 b/libm65/pctile.f90 new file mode 100644 index 000000000..6afdd59af --- /dev/null +++ b/libm65/pctile.f90 @@ -0,0 +1,13 @@ +subroutine pctile(x,tmp,nmax,npct,xpct) + real x(nmax),tmp(nmax) + + do i=1,nmax + tmp(i)=x(i) + enddo + call sort(nmax,tmp) + j=nint(nmax*0.01*npct) + if(j.lt.1) j=1 + xpct=tmp(j) + + return +end subroutine pctile diff --git a/libm65/set.f b/libm65/set.f deleted file mode 100644 index e93740a8a..000000000 --- a/libm65/set.f +++ /dev/null @@ -1,31 +0,0 @@ - subroutine set(a,y,n) - real y(n) - do i=1,n - y(i)=a - enddo - return - end - - subroutine move(x,y,n) - real x(n),y(n) - do i=1,n - y(i)=x(i) - enddo - return - end - - subroutine zero(x,n) - real x(n) - do i=1,n - x(i)=0.0 - enddo - return - end - - subroutine add(a,b,c,n) - real a(n),b(n),c(n) - do i=1,n - c(i)=a(i)+b(i) - enddo - return - end diff --git a/libm65/set.f90 b/libm65/set.f90 new file mode 100644 index 000000000..ff7679889 --- /dev/null +++ b/libm65/set.f90 @@ -0,0 +1,31 @@ +subroutine set(a,y,n) + real y(n) + do i=1,n + y(i)=a + enddo + return +end subroutine set + +subroutine move(x,y,n) + real x(n),y(n) + do i=1,n + y(i)=x(i) + enddo + return +end subroutine move + +subroutine zero(x,n) + real x(n) + do i=1,n + x(i)=0.0 + enddo + return +end subroutine zero + +subroutine add(a,b,c,n) + real a(n),b(n),c(n) + do i=1,n + c(i)=a(i)+b(i) + enddo + return +end subroutine add diff --git a/libm65/setup65.f b/libm65/setup65.f deleted file mode 100644 index 25b821e5a..000000000 --- a/libm65/setup65.f +++ /dev/null @@ -1,96 +0,0 @@ - subroutine setup65 - -C Defines arrays related to the JT65 pseudo-random synchronizing pattern. -C Executed at program start. - - integer nprc(126) - common/prcom/pr(126),mdat(126),mref(126,2),mdat2(126),mref2(126,2) - -C JT65 - data nprc/ - + 1,0,0,1,1,0,0,0,1,1,1,1,1,1,0,1,0,1,0,0, - + 0,1,0,1,1,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1, - + 0,1,1,0,1,1,1,1,0,0,0,1,1,0,1,0,1,0,1,1, - + 0,0,1,1,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,1, - + 1,0,0,0,0,0,0,0,1,1,0,1,0,0,1,0,1,1,0,1, - + 0,1,0,1,0,0,1,1,0,0,1,0,0,1,0,0,0,0,1,1, - + 1,1,1,1,1,1/ - data mr2/0/ !Silence compiler warning - -C Put the appropriate pseudo-random sequence into pr - nsym=126 - do i=1,nsym - pr(i)=2*nprc(i)-1 - enddo - -C Determine locations of data and reference symbols - k=0 - mr1=0 - do i=1,nsym - if(pr(i).lt.0.0) then - k=k+1 - mdat(k)=i - else - mr2=i - if(mr1.eq.0) mr1=i - endif - enddo - nsig=k - -C Determine the reference symbols for each data symbol. - do k=1,nsig - m=mdat(k) - mref(k,1)=mr1 - do n=1,10 !Get ref symbol before data - if((m-n).gt.0) then - if (pr(m-n).gt.0.0) go to 10 - endif - enddo - go to 12 - 10 mref(k,1)=m-n - 12 mref(k,2)=mr2 - do n=1,10 !Get ref symbol after data - if((m+n).le.nsym) then - if (pr(m+n).gt.0.0) go to 20 - endif - enddo - go to 22 - 20 mref(k,2)=m+n - 22 enddo - -C Now do it all again, using opposite logic on pr(i) - k=0 - mr1=0 - do i=1,nsym - if(pr(i).gt.0.0) then - k=k+1 - mdat2(k)=i - else - mr2=i - if(mr1.eq.0) mr1=i - endif - enddo - nsig=k - - do k=1,nsig - m=mdat2(k) - mref2(k,1)=mr1 - do n=1,10 - if((m-n).gt.0) then - if (pr(m-n).lt.0.0) go to 110 - endif - enddo - go to 112 - 110 mref2(k,1)=m-n - 112 mref2(k,2)=mr2 - do n=1,10 - if((m+n).le.nsym) then - if (pr(m+n).lt.0.0) go to 120 - endif - enddo - go to 122 - 120 mref2(k,2)=m+n - 122 enddo - - return - end diff --git a/libm65/setup65.f90 b/libm65/setup65.f90 new file mode 100644 index 000000000..b1a867d18 --- /dev/null +++ b/libm65/setup65.f90 @@ -0,0 +1,96 @@ +subroutine setup65 + +! Defines arrays related to the JT65 pseudo-random synchronizing pattern. +! Executed at program start. + + integer nprc(126) + common/prcom/pr(126),mdat(126),mref(126,2),mdat2(126),mref2(126,2) + +! JT65 + data nprc/ & + 1,0,0,1,1,0,0,0,1,1,1,1,1,1,0,1,0,1,0,0, & + 0,1,0,1,1,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1, & + 0,1,1,0,1,1,1,1,0,0,0,1,1,0,1,0,1,0,1,1, & + 0,0,1,1,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,1, & + 1,0,0,0,0,0,0,0,1,1,0,1,0,0,1,0,1,1,0,1, & + 0,1,0,1,0,0,1,1,0,0,1,0,0,1,0,0,0,0,1,1, & + 1,1,1,1,1,1/ + data mr2/0/ !Silence compiler warning + +! Put the appropriate pseudo-random sequence into pr + nsym=126 + do i=1,nsym + pr(i)=2*nprc(i)-1 + enddo + +! Determine locations of data and reference symbols + k=0 + mr1=0 + do i=1,nsym + if(pr(i).lt.0.0) then + k=k+1 + mdat(k)=i + else + mr2=i + if(mr1.eq.0) mr1=i + endif + enddo + nsig=k + +! Determine the reference symbols for each data symbol. + do k=1,nsig + m=mdat(k) + mref(k,1)=mr1 + do n=1,10 !Get ref symbol before data + if((m-n).gt.0) then + if (pr(m-n).gt.0.0) go to 10 + endif + enddo + go to 12 +10 mref(k,1)=m-n +12 mref(k,2)=mr2 + do n=1,10 !Get ref symbol after data + if((m+n).le.nsym) then + if (pr(m+n).gt.0.0) go to 20 + endif + enddo + go to 22 +20 mref(k,2)=m+n +22 enddo + +! Now do it all again, using opposite logic on pr(i) + k=0 + mr1=0 + do i=1,nsym + if(pr(i).gt.0.0) then + k=k+1 + mdat2(k)=i + else + mr2=i + if(mr1.eq.0) mr1=i + endif + enddo + nsig=k + + do k=1,nsig + m=mdat2(k) + mref2(k,1)=mr1 + do n=1,10 + if((m-n).gt.0) then + if (pr(m-n).lt.0.0) go to 110 + endif + enddo + go to 112 +110 mref2(k,1)=m-n +112 mref2(k,2)=mr2 + do n=1,10 + if((m+n).le.nsym) then + if (pr(m+n).lt.0.0) go to 120 + endif + enddo + go to 122 +120 mref2(k,2)=m+n +122 enddo + + return +end subroutine setup65 diff --git a/libm65/sort.f b/libm65/sort.f deleted file mode 100644 index 7888b0cfd..000000000 --- a/libm65/sort.f +++ /dev/null @@ -1,4 +0,0 @@ - subroutine sort(n,arr) - call ssort(arr,tmp,n,1) - return - end diff --git a/libm65/sort.f90 b/libm65/sort.f90 new file mode 100644 index 000000000..8a05da288 --- /dev/null +++ b/libm65/sort.f90 @@ -0,0 +1,6 @@ +subroutine sort(n,arr) + + call ssort(arr,tmp,n,1) + + return +end subroutine sort