From bfcbce34a7113bbffb64dbb1303a1d382d98ffed Mon Sep 17 00:00:00 2001 From: Joe Taylor Date: Wed, 22 May 2013 15:39:28 +0000 Subject: [PATCH] Convert all *.f files to *.f90. git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/wsjtx@3296 ab8295b8-cf94-4d9e-aec4-7959e3be5d79 --- lib/deg2grid.f | 30 ----- lib/deg2grid.f90 | 30 +++++ lib/f77_wisdom.f | 45 ------- lib/f77_wisdom.f90 | 45 +++++++ lib/fftw3.f | 64 ---------- lib/fftw3.f90 | 64 ++++++++++ lib/four2a.f90 | 2 +- lib/getpfx1.f | 97 --------------- lib/getpfx1.f90 | 97 +++++++++++++++ lib/getpfx2.f | 24 ---- lib/getpfx2.f90 | 24 ++++ lib/grid2deg.f | 38 ------ lib/grid2deg.f90 | 38 ++++++ lib/grid2k.f | 12 -- lib/grid2k.f90 | 12 ++ lib/indexx.f | 19 --- lib/indexx.f90 | 19 +++ lib/k2grid.f | 12 -- lib/k2grid.f90 | 12 ++ lib/nchar.f | 23 ---- lib/nchar.f90 | 23 ++++ lib/packcall.f | 79 ------------- lib/packcall.f90 | 79 +++++++++++++ lib/packdxcc.f | 64 ---------- lib/packdxcc.f90 | 64 ++++++++++ lib/packtext.f | 47 -------- lib/packtext.f90 | 47 ++++++++ lib/pfx.f | 50 -------- lib/pfx.f90 | 50 ++++++++ lib/pfxdump.f | 13 -- lib/pfxdump.f90 | 13 ++ lib/sort.f | 4 - lib/sort.f90 | 4 + lib/ssort.f | 288 --------------------------------------------- lib/ssort.f90 | 264 +++++++++++++++++++++++++++++++++++++++++ lib/unpackcall.f | 142 ---------------------- lib/unpackcall.f90 | 142 ++++++++++++++++++++++ lib/unpacktext.f | 35 ------ lib/unpacktext.f90 | 35 ++++++ mainwindow.cpp | 2 +- 40 files changed, 1064 insertions(+), 1088 deletions(-) delete mode 100644 lib/deg2grid.f create mode 100644 lib/deg2grid.f90 delete mode 100644 lib/f77_wisdom.f create mode 100644 lib/f77_wisdom.f90 delete mode 100644 lib/fftw3.f create mode 100644 lib/fftw3.f90 delete mode 100644 lib/getpfx1.f create mode 100644 lib/getpfx1.f90 delete mode 100644 lib/getpfx2.f create mode 100644 lib/getpfx2.f90 delete mode 100644 lib/grid2deg.f create mode 100644 lib/grid2deg.f90 delete mode 100644 lib/grid2k.f create mode 100644 lib/grid2k.f90 delete mode 100644 lib/indexx.f create mode 100644 lib/indexx.f90 delete mode 100644 lib/k2grid.f create mode 100644 lib/k2grid.f90 delete mode 100644 lib/nchar.f create mode 100644 lib/nchar.f90 delete mode 100644 lib/packcall.f create mode 100644 lib/packcall.f90 delete mode 100644 lib/packdxcc.f create mode 100644 lib/packdxcc.f90 delete mode 100644 lib/packtext.f create mode 100644 lib/packtext.f90 delete mode 100644 lib/pfx.f create mode 100644 lib/pfx.f90 delete mode 100644 lib/pfxdump.f create mode 100644 lib/pfxdump.f90 delete mode 100644 lib/sort.f create mode 100644 lib/sort.f90 delete mode 100644 lib/ssort.f create mode 100644 lib/ssort.f90 delete mode 100644 lib/unpackcall.f create mode 100644 lib/unpackcall.f90 delete mode 100644 lib/unpacktext.f create mode 100644 lib/unpacktext.f90 diff --git a/lib/deg2grid.f b/lib/deg2grid.f deleted file mode 100644 index 8c64028a8..000000000 --- a/lib/deg2grid.f +++ /dev/null @@ -1,30 +0,0 @@ - subroutine deg2grid(dlong0,dlat,grid) - - real dlong !West longitude (deg) - real dlat !Latitude (deg) - character grid*6 - - dlong=dlong0 - if(dlong.lt.-180.0) dlong=dlong+360.0 - if(dlong.gt.180.0) dlong=dlong-360.0 - -C Convert to units of 5 min of longitude, working east from 180 deg. - nlong=60.0*(180.0-dlong)/5.0 - n1=nlong/240 !20-degree field - n2=(nlong-240*n1)/24 !2 degree square - n3=nlong-240*n1-24*n2 !5 minute subsquare - grid(1:1)=char(ichar('A')+n1) - grid(3:3)=char(ichar('0')+n2) - grid(5:5)=char(ichar('a')+n3) - -C Convert to units of 2.5 min of latitude, working north from -90 deg. - nlat=60.0*(dlat+90)/2.5 - n1=nlat/240 !10-degree field - n2=(nlat-240*n1)/24 !1 degree square - n3=nlat-240*n1-24*n2 !2.5 minuts subsquare - grid(2:2)=char(ichar('A')+n1) - grid(4:4)=char(ichar('0')+n2) - grid(6:6)=char(ichar('a')+n3) - - return - end diff --git a/lib/deg2grid.f90 b/lib/deg2grid.f90 new file mode 100644 index 000000000..9ca3602f8 --- /dev/null +++ b/lib/deg2grid.f90 @@ -0,0 +1,30 @@ +subroutine deg2grid(dlong0,dlat,grid) + + real dlong !West longitude (deg) + real dlat !Latitude (deg) + character grid*6 + + dlong=dlong0 + if(dlong.lt.-180.0) dlong=dlong+360.0 + if(dlong.gt.180.0) dlong=dlong-360.0 + +! Convert to units of 5 min of longitude, working east from 180 deg. + nlong=60.0*(180.0-dlong)/5.0 + n1=nlong/240 !20-degree field + n2=(nlong-240*n1)/24 !2 degree square + n3=nlong-240*n1-24*n2 !5 minute subsquare + grid(1:1)=char(ichar('A')+n1) + grid(3:3)=char(ichar('0')+n2) + grid(5:5)=char(ichar('a')+n3) + +! Convert to units of 2.5 min of latitude, working north from -90 deg. + nlat=60.0*(dlat+90)/2.5 + n1=nlat/240 !10-degree field + n2=(nlat-240*n1)/24 !1 degree square + n3=nlat-240*n1-24*n2 !2.5 minuts subsquare + grid(2:2)=char(ichar('A')+n1) + grid(4:4)=char(ichar('0')+n2) + grid(6:6)=char(ichar('a')+n3) + + return +end subroutine deg2grid diff --git a/lib/f77_wisdom.f b/lib/f77_wisdom.f deleted file mode 100644 index b0a72585e..000000000 --- a/lib/f77_wisdom.f +++ /dev/null @@ -1,45 +0,0 @@ - subroutine write_char(c, iunit) - character c - integer iunit - write(iunit,1000) c - 1000 format(a,$) - end - - subroutine export_wisdom_to_file(iunit) - integer iunit - external write_char -c call dfftw_export_wisdom(write_char, iunit) - call sfftw_export_wisdom(write_char, iunit) - end - - subroutine read_char(ic, iunit) - integer ic - integer iunit - character*256 buf - save buf - integer ibuf - data ibuf/257/ - save ibuf - if (ibuf .lt. 257) then - ic = ichar(buf(ibuf:ibuf)) - ibuf = ibuf + 1 - return - endif - read(iunit,1000,end=10) buf - 1000 format(a256) - ic = ichar(buf(1:1)) - ibuf = 2 - return - 10 ic = -1 - ibuf = 257 - rewind iunit - return - end - - subroutine import_wisdom_from_file(isuccess, iunit) - integer isuccess - integer iunit - external read_char -c call dfftw_import_wisdom(isuccess, read_char, iunit) - call sfftw_import_wisdom(isuccess, read_char, iunit) - end diff --git a/lib/f77_wisdom.f90 b/lib/f77_wisdom.f90 new file mode 100644 index 000000000..39bdff8e5 --- /dev/null +++ b/lib/f77_wisdom.f90 @@ -0,0 +1,45 @@ +subroutine write_char(c, iunit) + character c + integer iunit + write(iunit,1000) c +1000 format(a,$) +end subroutine write_char + +subroutine export_wisdom_to_file(iunit) + integer iunit + external write_char +! call dfftw_export_wisdom(write_char, iunit) + call sfftw_export_wisdom(write_char, iunit) +end subroutine export_wisdom_to_file + +subroutine read_char(ic, iunit) + integer ic + integer iunit + character*256 buf + save buf + integer ibuf + data ibuf/257/ + save ibuf + if (ibuf .lt. 257) then + ic = ichar(buf(ibuf:ibuf)) + ibuf = ibuf + 1 + return + endif + read(iunit,1000,end=10) buf +1000 format(a256) + ic = ichar(buf(1:1)) + ibuf = 2 + return +10 ic = -1 + ibuf = 257 + rewind iunit + return +end subroutine read_char + +subroutine import_wisdom_from_file(isuccess, iunit) + integer isuccess + integer iunit + external read_char +! call dfftw_import_wisdom(isuccess, read_char, iunit) + call sfftw_import_wisdom(isuccess, read_char, iunit) +end subroutine import_wisdom_from_file diff --git a/lib/fftw3.f b/lib/fftw3.f deleted file mode 100644 index 3410184ca..000000000 --- a/lib/fftw3.f +++ /dev/null @@ -1,64 +0,0 @@ - INTEGER FFTW_R2HC - PARAMETER (FFTW_R2HC=0) - INTEGER FFTW_HC2R - PARAMETER (FFTW_HC2R=1) - INTEGER FFTW_DHT - PARAMETER (FFTW_DHT=2) - INTEGER FFTW_REDFT00 - PARAMETER (FFTW_REDFT00=3) - INTEGER FFTW_REDFT01 - PARAMETER (FFTW_REDFT01=4) - INTEGER FFTW_REDFT10 - PARAMETER (FFTW_REDFT10=5) - INTEGER FFTW_REDFT11 - PARAMETER (FFTW_REDFT11=6) - INTEGER FFTW_RODFT00 - PARAMETER (FFTW_RODFT00=7) - INTEGER FFTW_RODFT01 - PARAMETER (FFTW_RODFT01=8) - INTEGER FFTW_RODFT10 - PARAMETER (FFTW_RODFT10=9) - INTEGER FFTW_RODFT11 - PARAMETER (FFTW_RODFT11=10) - INTEGER FFTW_FORWARD - PARAMETER (FFTW_FORWARD=-1) - INTEGER FFTW_BACKWARD - PARAMETER (FFTW_BACKWARD=+1) - INTEGER FFTW_MEASURE - PARAMETER (FFTW_MEASURE=0) - INTEGER FFTW_DESTROY_INPUT - PARAMETER (FFTW_DESTROY_INPUT=1) - INTEGER FFTW_UNALIGNED - PARAMETER (FFTW_UNALIGNED=2) - INTEGER FFTW_CONSERVE_MEMORY - PARAMETER (FFTW_CONSERVE_MEMORY=4) - INTEGER FFTW_EXHAUSTIVE - PARAMETER (FFTW_EXHAUSTIVE=8) - INTEGER FFTW_PRESERVE_INPUT - PARAMETER (FFTW_PRESERVE_INPUT=16) - INTEGER FFTW_PATIENT - PARAMETER (FFTW_PATIENT=32) - INTEGER FFTW_ESTIMATE - PARAMETER (FFTW_ESTIMATE=64) - INTEGER FFTW_ESTIMATE_PATIENT - PARAMETER (FFTW_ESTIMATE_PATIENT=128) - INTEGER FFTW_BELIEVE_PCOST - PARAMETER (FFTW_BELIEVE_PCOST=256) - INTEGER FFTW_DFT_R2HC_ICKY - PARAMETER (FFTW_DFT_R2HC_ICKY=512) - INTEGER FFTW_NONTHREADED_ICKY - PARAMETER (FFTW_NONTHREADED_ICKY=1024) - INTEGER FFTW_NO_BUFFERING - PARAMETER (FFTW_NO_BUFFERING=2048) - INTEGER FFTW_NO_INDIRECT_OP - PARAMETER (FFTW_NO_INDIRECT_OP=4096) - INTEGER FFTW_ALLOW_LARGE_GENERIC - PARAMETER (FFTW_ALLOW_LARGE_GENERIC=8192) - INTEGER FFTW_NO_RANK_SPLITS - PARAMETER (FFTW_NO_RANK_SPLITS=16384) - INTEGER FFTW_NO_VRANK_SPLITS - PARAMETER (FFTW_NO_VRANK_SPLITS=32768) - INTEGER FFTW_NO_VRECURSE - PARAMETER (FFTW_NO_VRECURSE=65536) - INTEGER FFTW_NO_SIMD - PARAMETER (FFTW_NO_SIMD=131072) diff --git a/lib/fftw3.f90 b/lib/fftw3.f90 new file mode 100644 index 000000000..440ccc28c --- /dev/null +++ b/lib/fftw3.f90 @@ -0,0 +1,64 @@ + INTEGER FFTW_R2HC + PARAMETER (FFTW_R2HC=0) + INTEGER FFTW_HC2R + PARAMETER (FFTW_HC2R=1) + INTEGER FFTW_DHT + PARAMETER (FFTW_DHT=2) + INTEGER FFTW_REDFT00 + PARAMETER (FFTW_REDFT00=3) + INTEGER FFTW_REDFT01 + PARAMETER (FFTW_REDFT01=4) + INTEGER FFTW_REDFT10 + PARAMETER (FFTW_REDFT10=5) + INTEGER FFTW_REDFT11 + PARAMETER (FFTW_REDFT11=6) + INTEGER FFTW_RODFT00 + PARAMETER (FFTW_RODFT00=7) + INTEGER FFTW_RODFT01 + PARAMETER (FFTW_RODFT01=8) + INTEGER FFTW_RODFT10 + PARAMETER (FFTW_RODFT10=9) + INTEGER FFTW_RODFT11 + PARAMETER (FFTW_RODFT11=10) + INTEGER FFTW_FORWARD + PARAMETER (FFTW_FORWARD=-1) + INTEGER FFTW_BACKWARD + PARAMETER (FFTW_BACKWARD=+1) + INTEGER FFTW_MEASURE + PARAMETER (FFTW_MEASURE=0) + INTEGER FFTW_DESTROY_INPUT + PARAMETER (FFTW_DESTROY_INPUT=1) + INTEGER FFTW_UNALIGNED + PARAMETER (FFTW_UNALIGNED=2) + INTEGER FFTW_CONSERVE_MEMORY + PARAMETER (FFTW_CONSERVE_MEMORY=4) + INTEGER FFTW_EXHAUSTIVE + PARAMETER (FFTW_EXHAUSTIVE=8) + INTEGER FFTW_PRESERVE_INPUT + PARAMETER (FFTW_PRESERVE_INPUT=16) + INTEGER FFTW_PATIENT + PARAMETER (FFTW_PATIENT=32) + INTEGER FFTW_ESTIMATE + PARAMETER (FFTW_ESTIMATE=64) + INTEGER FFTW_ESTIMATE_PATIENT + PARAMETER (FFTW_ESTIMATE_PATIENT=128) + INTEGER FFTW_BELIEVE_PCOST + PARAMETER (FFTW_BELIEVE_PCOST=256) + INTEGER FFTW_DFT_R2HC_ICKY + PARAMETER (FFTW_DFT_R2HC_ICKY=512) + INTEGER FFTW_NONTHREADED_ICKY + PARAMETER (FFTW_NONTHREADED_ICKY=1024) + INTEGER FFTW_NO_BUFFERING + PARAMETER (FFTW_NO_BUFFERING=2048) + INTEGER FFTW_NO_INDIRECT_OP + PARAMETER (FFTW_NO_INDIRECT_OP=4096) + INTEGER FFTW_ALLOW_LARGE_GENERIC + PARAMETER (FFTW_ALLOW_LARGE_GENERIC=8192) + INTEGER FFTW_NO_RANK_SPLITS + PARAMETER (FFTW_NO_RANK_SPLITS=16384) + INTEGER FFTW_NO_VRANK_SPLITS + PARAMETER (FFTW_NO_VRANK_SPLITS=32768) + INTEGER FFTW_NO_VRECURSE + PARAMETER (FFTW_NO_VRECURSE=65536) + INTEGER FFTW_NO_SIMD + PARAMETER (FFTW_NO_SIMD=131072) diff --git a/lib/four2a.f90 b/lib/four2a.f90 index 73cacf846..c095629be 100644 --- a/lib/four2a.f90 +++ b/lib/four2a.f90 @@ -24,7 +24,7 @@ subroutine four2a(a,nfft,ndim,isign,iform) integer*8 plan(NPMAX),nl(NPMAX),nloc data nplan/0/,npatience/1/ ! data nplan/0/,npatience/0/ - include 'fftw3.f' + include 'fftw3.f90' save plan,nplan,nn,ns,nf,nl if(nfft.lt.0) go to 999 diff --git a/lib/getpfx1.f b/lib/getpfx1.f deleted file mode 100644 index 88636a62a..000000000 --- a/lib/getpfx1.f +++ /dev/null @@ -1,97 +0,0 @@ - subroutine getpfx1(callsign,k,nv2) - - character*12 callsign0,callsign,lof,rof - character*8 c - character addpfx*8,tpfx*4,tsfx*3 - logical ispfx,issfx,invalid - common/pfxcom/addpfx - include 'pfx.f' - - callsign0=callsign - nv2=0 - iz=index(callsign,' ') - 1 - if(iz.lt.0) iz=12 - islash=index(callsign(1:iz),'/') - k=0 - if(k.eq.0) go to 10 !### Always use JT65v2 ### - c=' ' - if(islash.gt.0 .and. islash.le.(iz-4)) then -! Add-on prefix - c=callsign(1:islash-1) - callsign=callsign(islash+1:iz) - do i=1,NZ - if(pfx(i)(1:4).eq.c) then - k=i - go to 10 - endif - enddo - if(addpfx.eq.c) then - k=449 - go to 10 - endif - - else if(islash.eq.(iz-1)) then -! Add-on suffix - c=callsign(islash+1:iz) - callsign=callsign(1:islash-1) - do i=1,NZ2 - if(sfx(i).eq.c(1:1)) then - k=400+i - go to 10 - endif - enddo - endif - - 10 if(islash.ne.0 .and.k.eq.0) then -! Original JT65 would force this compound callsign to be treated as -! plain text. In JT65v2, we will encode the prefix or suffix into nc1. -! The task here is to compute the proper value of k. - lof=callsign0(:islash-1) - rof=callsign0(islash+1:) - llof=len_trim(lof) - lrof=len_trim(rof) - ispfx=(llof.gt.0 .and. llof.le.4) - issfx=(lrof.gt.0 .and. lrof.le.3) - invalid=.not.(ispfx.or.issfx) - if(ispfx.and.issfx) then - if(llof.lt.3) issfx=.false. - if(lrof.lt.3) ispfx=.false. - if(ispfx.and.issfx) then - i=ichar(callsign0(islash-1:islash-1)) - if(i.ge.ichar('0') .and. i.le.ichar('9')) then - issfx=.false. - else - ispfx=.false. - endif - endif - endif - - if(invalid) then - k=-1 - else - if(ispfx) then - tpfx=lof(1:4) - k=nchar(tpfx(1:1)) - k=37*k + nchar(tpfx(2:2)) - k=37*k + nchar(tpfx(3:3)) - k=37*k + nchar(tpfx(4:4)) - nv2=1 - i=index(callsign0,'/') - callsign=callsign0(:i-1) - callsign=callsign0(i+1:) - endif - if(issfx) then - tsfx=rof(1:3) - k=nchar(tsfx(1:1)) - k=37*k + nchar(tsfx(2:2)) - k=37*k + nchar(tsfx(3:3)) - nv2=2 - i=index(callsign0,'/') - callsign=callsign0(:i-1) - endif - endif - endif - - return - end - diff --git a/lib/getpfx1.f90 b/lib/getpfx1.f90 new file mode 100644 index 000000000..4d4e7aa06 --- /dev/null +++ b/lib/getpfx1.f90 @@ -0,0 +1,97 @@ +subroutine getpfx1(callsign,k,nv2) + + character*12 callsign0,callsign,lof,rof + character*8 c + character addpfx*8,tpfx*4,tsfx*3 + logical ispfx,issfx,invalid + common/pfxcom/addpfx + include 'pfx.f90' + + callsign0=callsign + nv2=0 + iz=index(callsign,' ') - 1 + if(iz.lt.0) iz=12 + islash=index(callsign(1:iz),'/') + k=0 + if(k.eq.0) go to 10 !### Always use JT65v2 ### + c=' ' + if(islash.gt.0 .and. islash.le.(iz-4)) then +! Add-on prefix + c=callsign(1:islash-1) + callsign=callsign(islash+1:iz) + do i=1,NZ + if(pfx(i)(1:4).eq.c) then + k=i + go to 10 + endif + enddo + if(addpfx.eq.c) then + k=449 + go to 10 + endif + + else if(islash.eq.(iz-1)) then +! Add-on suffix + c=callsign(islash+1:iz) + callsign=callsign(1:islash-1) + do i=1,NZ2 + if(sfx(i).eq.c(1:1)) then + k=400+i + go to 10 + endif + enddo + endif + +10 if(islash.ne.0 .and.k.eq.0) then +! Original JT65 would force this compound callsign to be treated as +! plain text. In JT65v2, we will encode the prefix or suffix into nc1. +! The task here is to compute the proper value of k. + lof=callsign0(:islash-1) + rof=callsign0(islash+1:) + llof=len_trim(lof) + lrof=len_trim(rof) + ispfx=(llof.gt.0 .and. llof.le.4) + issfx=(lrof.gt.0 .and. lrof.le.3) + invalid=.not.(ispfx.or.issfx) + if(ispfx.and.issfx) then + if(llof.lt.3) issfx=.false. + if(lrof.lt.3) ispfx=.false. + if(ispfx.and.issfx) then + i=ichar(callsign0(islash-1:islash-1)) + if(i.ge.ichar('0') .and. i.le.ichar('9')) then + issfx=.false. + else + ispfx=.false. + endif + endif + endif + + if(invalid) then + k=-1 + else + if(ispfx) then + tpfx=lof(1:4) + k=nchar(tpfx(1:1)) + k=37*k + nchar(tpfx(2:2)) + k=37*k + nchar(tpfx(3:3)) + k=37*k + nchar(tpfx(4:4)) + nv2=1 + i=index(callsign0,'/') + callsign=callsign0(:i-1) + callsign=callsign0(i+1:) + endif + if(issfx) then + tsfx=rof(1:3) + k=nchar(tsfx(1:1)) + k=37*k + nchar(tsfx(2:2)) + k=37*k + nchar(tsfx(3:3)) + nv2=2 + i=index(callsign0,'/') + callsign=callsign0(:i-1) + endif + endif + endif + + return +end subroutine getpfx1 + diff --git a/lib/getpfx2.f b/lib/getpfx2.f deleted file mode 100644 index 26a46cce5..000000000 --- a/lib/getpfx2.f +++ /dev/null @@ -1,24 +0,0 @@ - subroutine getpfx2(k0,callsign) - - character callsign*12 - include 'pfx.f' - character addpfx*8 - common/pfxcom/addpfx - - k=k0 - if(k.gt.450) k=k-450 - if(k.ge.1 .and. k.le.NZ) then - iz=index(pfx(k),' ') - 1 - callsign=pfx(k)(1:iz)//'/'//callsign - else if(k.ge.401 .and. k.le.400+NZ2) then - iz=index(callsign,' ') - 1 - callsign=callsign(1:iz)//'/'//sfx(k-400) - else if(k.eq.449) then - iz=index(addpfx,' ') - 1 - if(iz.lt.1) iz=8 - callsign=addpfx(1:iz)//'/'//callsign - endif - - return - end - diff --git a/lib/getpfx2.f90 b/lib/getpfx2.f90 new file mode 100644 index 000000000..d747e7f29 --- /dev/null +++ b/lib/getpfx2.f90 @@ -0,0 +1,24 @@ +subroutine getpfx2(k0,callsign) + + character callsign*12 + include 'pfx.f90' + character addpfx*8 + common/pfxcom/addpfx + + k=k0 + if(k.gt.450) k=k-450 + if(k.ge.1 .and. k.le.NZ) then + iz=index(pfx(k),' ') - 1 + callsign=pfx(k)(1:iz)//'/'//callsign + else if(k.ge.401 .and. k.le.400+NZ2) then + iz=index(callsign,' ') - 1 + callsign=callsign(1:iz)//'/'//sfx(k-400) + else if(k.eq.449) then + iz=index(addpfx,' ') - 1 + if(iz.lt.1) iz=8 + callsign=addpfx(1:iz)//'/'//callsign + endif + + return +end subroutine getpfx2 + diff --git a/lib/grid2deg.f b/lib/grid2deg.f deleted file mode 100644 index 7947073d8..000000000 --- a/lib/grid2deg.f +++ /dev/null @@ -1,38 +0,0 @@ - subroutine grid2deg(grid0,dlong,dlat) - -C Converts Maidenhead grid locator to degrees of West longitude -C and North latitude. - - character*6 grid0,grid - character*1 g1,g2,g3,g4,g5,g6 - - grid=grid0 - i=ichar(grid(5:5)) - if(grid(5:5).eq.' ' .or. i.le.64 .or. i.ge.128) grid(5:6)='mm' - - if(grid(1:1).ge.'a' .and. grid(1:1).le.'z') grid(1:1)= - + char(ichar(grid(1:1))+ichar('A')-ichar('a')) - if(grid(2:2).ge.'a' .and. grid(2:2).le.'z') grid(2:2)= - + char(ichar(grid(2:2))+ichar('A')-ichar('a')) - if(grid(5:5).ge.'A' .and. grid(5:5).le.'Z') grid(5:5)= - + char(ichar(grid(5:5))-ichar('A')+ichar('a')) - if(grid(6:6).ge.'A' .and. grid(6:6).le.'Z') grid(6:6)= - + char(ichar(grid(6:6))-ichar('A')+ichar('a')) - - g1=grid(1:1) - g2=grid(2:2) - g3=grid(3:3) - g4=grid(4:4) - g5=grid(5:5) - g6=grid(6:6) - - nlong = 180 - 20*(ichar(g1)-ichar('A')) - n20d = 2*(ichar(g3)-ichar('0')) - xminlong = 5*(ichar(g5)-ichar('a')+0.5) - dlong = nlong - n20d - xminlong/60.0 - nlat = -90+10*(ichar(g2)-ichar('A')) + ichar(g4)-ichar('0') - xminlat = 2.5*(ichar(g6)-ichar('a')+0.5) - dlat = nlat + xminlat/60.0 - - return - end diff --git a/lib/grid2deg.f90 b/lib/grid2deg.f90 new file mode 100644 index 000000000..843fc8480 --- /dev/null +++ b/lib/grid2deg.f90 @@ -0,0 +1,38 @@ +subroutine grid2deg(grid0,dlong,dlat) + +! Converts Maidenhead grid locator to degrees of West longitude +! and North latitude. + + character*6 grid0,grid + character*1 g1,g2,g3,g4,g5,g6 + + grid=grid0 + i=ichar(grid(5:5)) + if(grid(5:5).eq.' ' .or. i.le.64 .or. i.ge.128) grid(5:6)='mm' + + if(grid(1:1).ge.'a' .and. grid(1:1).le.'z') grid(1:1)= & + char(ichar(grid(1:1))+ichar('A')-ichar('a')) + if(grid(2:2).ge.'a' .and. grid(2:2).le.'z') grid(2:2)= & + char(ichar(grid(2:2))+ichar('A')-ichar('a')) + if(grid(5:5).ge.'A' .and. grid(5:5).le.'Z') grid(5:5)= & + char(ichar(grid(5:5))-ichar('A')+ichar('a')) + if(grid(6:6).ge.'A' .and. grid(6:6).le.'Z') grid(6:6)= & + char(ichar(grid(6:6))-ichar('A')+ichar('a')) + + g1=grid(1:1) + g2=grid(2:2) + g3=grid(3:3) + g4=grid(4:4) + g5=grid(5:5) + g6=grid(6:6) + + nlong = 180 - 20*(ichar(g1)-ichar('A')) + n20d = 2*(ichar(g3)-ichar('0')) + xminlong = 5*(ichar(g5)-ichar('a')+0.5) + dlong = nlong - n20d - xminlong/60.0 + nlat = -90+10*(ichar(g2)-ichar('A')) + ichar(g4)-ichar('0') + xminlat = 2.5*(ichar(g6)-ichar('a')+0.5) + dlat = nlat + xminlat/60.0 + + return +end subroutine grid2deg diff --git a/lib/grid2k.f b/lib/grid2k.f deleted file mode 100644 index 1306a95a2..000000000 --- a/lib/grid2k.f +++ /dev/null @@ -1,12 +0,0 @@ - subroutine grid2k(grid,k) - - character*6 grid - - call grid2deg(grid,xlong,xlat) - nlong=nint(xlong) - nlat=nint(xlat) - k=0 - if(nlat.ge.85) k=5*(nlong+179)/2 + nlat-84 - - return - end diff --git a/lib/grid2k.f90 b/lib/grid2k.f90 new file mode 100644 index 000000000..f68b1409e --- /dev/null +++ b/lib/grid2k.f90 @@ -0,0 +1,12 @@ +subroutine grid2k(grid,k) + + character*6 grid + + call grid2deg(grid,xlong,xlat) + nlong=nint(xlong) + nlat=nint(xlat) + k=0 + if(nlat.ge.85) k=5*(nlong+179)/2 + nlat-84 + + return +end subroutine grid2k diff --git a/lib/indexx.f b/lib/indexx.f deleted file mode 100644 index df2a5330e..000000000 --- a/lib/indexx.f +++ /dev/null @@ -1,19 +0,0 @@ - subroutine indexx(n,arr,indx) - - parameter (NMAX=3000) - integer indx(n) - real arr(n) - real brr(NMAX) - if(n.gt.NMAX) then - print*,'n=',n,' too big in indexx.' - stop - endif - do i=1,n - brr(i)=arr(i) - indx(i)=i - enddo - call ssort(brr,indx,n,2) - - return - end - diff --git a/lib/indexx.f90 b/lib/indexx.f90 new file mode 100644 index 000000000..57c1ec075 --- /dev/null +++ b/lib/indexx.f90 @@ -0,0 +1,19 @@ +subroutine indexx(n,arr,indx) + + parameter (NMAX=3000) + integer indx(n) + real arr(n) + real brr(NMAX) + if(n.gt.NMAX) then + print*,'n=',n,' too big in indexx.' + stop + endif + do i=1,n + brr(i)=arr(i) + indx(i)=i + enddo + call ssort(brr,indx,n,2) + + return +end subroutine indexx + diff --git a/lib/k2grid.f b/lib/k2grid.f deleted file mode 100644 index 6fcd7f3e4..000000000 --- a/lib/k2grid.f +++ /dev/null @@ -1,12 +0,0 @@ - subroutine k2grid(k,grid) - character grid*6 - - nlong=2*mod((k-1)/5,90)-179 - if(k.gt.450) nlong=nlong+180 - nlat=mod(k-1,5)+ 85 - dlat=nlat - dlong=nlong - call deg2grid(dlong,dlat,grid) - - return - end diff --git a/lib/k2grid.f90 b/lib/k2grid.f90 new file mode 100644 index 000000000..aa7631579 --- /dev/null +++ b/lib/k2grid.f90 @@ -0,0 +1,12 @@ +subroutine k2grid(k,grid) + character grid*6 + + nlong=2*mod((k-1)/5,90)-179 + if(k.gt.450) nlong=nlong+180 + nlat=mod(k-1,5)+ 85 + dlat=nlat + dlong=nlong + call deg2grid(dlong,dlat,grid) + + return +end subroutine k2grid diff --git a/lib/nchar.f b/lib/nchar.f deleted file mode 100644 index 1da9a9813..000000000 --- a/lib/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) - stop - endif - nchar=n - - return - end diff --git a/lib/nchar.f90 b/lib/nchar.f90 new file mode 100644 index 000000000..167992ae2 --- /dev/null +++ b/lib/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) + stop + endif + nchar=n + + return +end function nchar diff --git a/lib/packcall.f b/lib/packcall.f deleted file mode 100644 index 9e91a0be8..000000000 --- a/lib/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/lib/packcall.f90 b/lib/packcall.f90 new file mode 100644 index 000000000..c4de474ae --- /dev/null +++ b/lib/packcall.f90 @@ -0,0 +1,79 @@ +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/lib/packdxcc.f b/lib/packdxcc.f deleted file mode 100644 index ac370ef3f..000000000 --- a/lib/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/lib/packdxcc.f90 b/lib/packdxcc.f90 new file mode 100644 index 000000000..74f2789ba --- /dev/null +++ b/lib/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/lib/packtext.f b/lib/packtext.f deleted file mode 100644 index c4029766f..000000000 --- a/lib/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/lib/packtext.f90 b/lib/packtext.f90 new file mode 100644 index 000000000..10f348878 --- /dev/null +++ b/lib/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/lib/pfx.f b/lib/pfx.f deleted file mode 100644 index 685b3420e..000000000 --- a/lib/pfx.f +++ /dev/null @@ -1,50 +0,0 @@ - parameter (NZ=339) !Total number of prefixes - parameter (NZ2=12) !Total number of suffixes - character*1 sfx(NZ2) - character*5 pfx(NZ) - - data sfx/'P','0','1','2','3','4','5','6','7','8','9','A'/ - data pfx/ - + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', - + '3D2 ','3D2C ','3D2R ','3DA ','3V ','3W ','3X ','3Y ', - + '3YB ','3YP ','4J ','4L ','4S ','4U1I ','4U1U ','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 ','CE0X ','CE0Y ','CE0Z ', - + '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 ','FKC ','FM ','FO ', - + 'FOA ','FOC ','FOM ','FP ','FR ','FRG ','FRJ ','FRT ', - + 'FT5W ','FT5X ','FT5Z ','FW ','FY ','M ','MD ','MI ', - + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', - + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0A ', - + 'HK0M ','HL ','HM ','HP ','HR ','HS ','HV ','HZ ', - + 'I ','IS ','IS0 ', 'J2 ','J3 ','J5 ','J6 ', - + 'J7 ','J8 ','JA ','JDM ','JDO ','JT ','JW ', - + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', - + 'KH4 ','KH5 ','KH5K ','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 ','PY0F ','PT0S ','PY0T ','PZ ','R1F ', - + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', - + 'ST ','SU ','SV ','SVA ','SV5 ','SV9 ','T2 ','T30 ', - + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', - + '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 ','VK0H ','VK0M ','VK9C ', - + 'VK9L ','VK9M ','VK9N ','VK9W ','VK9X ','VP2E ','VP2M ','VP2V ', - + 'VP5 ','VP6 ','VP6D ','VP8 ','VP8G ','VP8H ','VP8O ','VP8S ', - + '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 ','ZK1N ','ZK1S ','ZK2 ','ZK3 ','ZL ','ZL7 ', - + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 ','KC4 ','E5 '/ diff --git a/lib/pfx.f90 b/lib/pfx.f90 new file mode 100644 index 000000000..ca4871814 --- /dev/null +++ b/lib/pfx.f90 @@ -0,0 +1,50 @@ + parameter (NZ=339) !Total number of prefixes + parameter (NZ2=12) !Total number of suffixes + character*1 sfx(NZ2) + character*5 pfx(NZ) + + data sfx/'P','0','1','2','3','4','5','6','7','8','9','A'/ + data pfx/ & + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', & + '3D2 ','3D2C ','3D2R ','3DA ','3V ','3W ','3X ','3Y ', & + '3YB ','3YP ','4J ','4L ','4S ','4U1I ','4U1U ','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 ','CE0X ','CE0Y ','CE0Z ', & + '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 ','FKC ','FM ','FO ', & + 'FOA ','FOC ','FOM ','FP ','FR ','FRG ','FRJ ','FRT ', & + 'FT5W ','FT5X ','FT5Z ','FW ','FY ','M ','MD ','MI ', & + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', & + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0A ', & + 'HK0M ','HL ','HM ','HP ','HR ','HS ','HV ','HZ ', & + 'I ','IS ','IS0 ', 'J2 ','J3 ','J5 ','J6 ', & + 'J7 ','J8 ','JA ','JDM ','JDO ','JT ','JW ', & + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', & + 'KH4 ','KH5 ','KH5K ','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 ','PY0F ','PT0S ','PY0T ','PZ ','R1F ', & + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', & + 'ST ','SU ','SV ','SVA ','SV5 ','SV9 ','T2 ','T30 ', & + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', & + '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 ','VK0H ','VK0M ','VK9C ', & + 'VK9L ','VK9M ','VK9N ','VK9W ','VK9X ','VP2E ','VP2M ','VP2V ', & + 'VP5 ','VP6 ','VP6D ','VP8 ','VP8G ','VP8H ','VP8O ','VP8S ', & + '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 ','ZK1N ','ZK1S ','ZK2 ','ZK3 ','ZL ','ZL7 ', & + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 ','KC4 ','E5 '/ diff --git a/lib/pfxdump.f b/lib/pfxdump.f deleted file mode 100644 index 1fbddc392..000000000 --- a/lib/pfxdump.f +++ /dev/null @@ -1,13 +0,0 @@ - subroutine pfxdump(fname) - character*(*) fname - include 'pfx.f' - - open(11,file=fname,status='unknown') - write(11,1001) sfx - 1001 format('Supported Suffixes:'/(11('/',a1,2x))) - write(11,1002) pfx - 1002 format(/'Supported Add-On DXCC Prefixes:'/(15(a5,1x))) - close(11) - - return - end diff --git a/lib/pfxdump.f90 b/lib/pfxdump.f90 new file mode 100644 index 000000000..7587dbf72 --- /dev/null +++ b/lib/pfxdump.f90 @@ -0,0 +1,13 @@ +subroutine pfxdump(fname) + character*(*) fname + include 'pfx.f90' + + open(11,file=fname,status='unknown') + write(11,1001) sfx +1001 format('Supported Suffixes:'/(11('/',a1,2x))) + write(11,1002) pfx +1002 format(/'Supported Add-On DXCC Prefixes:'/(15(a5,1x))) + close(11) + + return +end subroutine pfxdump diff --git a/lib/sort.f b/lib/sort.f deleted file mode 100644 index 7888b0cfd..000000000 --- a/lib/sort.f +++ /dev/null @@ -1,4 +0,0 @@ - subroutine sort(n,arr) - call ssort(arr,tmp,n,1) - return - end diff --git a/lib/sort.f90 b/lib/sort.f90 new file mode 100644 index 000000000..281ce0275 --- /dev/null +++ b/lib/sort.f90 @@ -0,0 +1,4 @@ +subroutine sort(n,arr) + call ssort(arr,tmp,n,1) + return +end subroutine sort diff --git a/lib/ssort.f b/lib/ssort.f deleted file mode 100644 index b77376732..000000000 --- a/lib/ssort.f +++ /dev/null @@ -1,288 +0,0 @@ - subroutine ssort (x,y,n,kflag) -c***purpose sort an array and optionally make the same interchanges in -c an auxiliary array. the array may be sorted in increasing -c or decreasing order. a slightly modified quicksort -c algorithm is used. -c -c ssort sorts array x and optionally makes the same interchanges in -c array y. the array x may be sorted in increasing order or -c decreasing order. a slightly modified quicksort algorithm is used. -c -c description of parameters -c x - array of values to be sorted -c y - array to be (optionally) carried along -c n - number of values in array x to be sorted -c kflag - control parameter -c = 2 means sort x in increasing order and carry y along. -c = 1 means sort x in increasing order (ignoring y) -c = -1 means sort x in decreasing order (ignoring y) -c = -2 means sort x in decreasing order and carry y along. - - integer kflag, n -! real x(n), y(n) -! real r, t, tt, tty, ty - integer x(n), y(n) - real r - integer t, tt, tty, ty - integer i, ij, j, k, kk, l, m, nn - integer il(21), iu(21) - - nn = n - if (nn .lt. 1) then -! print*,'ssort: The number of sort elements is not positive.' -! print*,'ssort: n = ',nn,' kflag = ',kflag - return - endif -c - kk = abs(kflag) - if (kk.ne.1 .and. kk.ne.2) then - print *, - + 'the sort control parameter, k, is not 2, 1, -1, or -2.' - return - endif -c -c alter array x to get decreasing order if needed -c - if (kflag .le. -1) then - do 10 i=1,nn - x(i) = -x(i) - 10 continue - endif -c - if (kk .eq. 2) go to 100 -c -c sort x only -c - m = 1 - i = 1 - j = nn - r = 0.375e0 -c - 20 if (i .eq. j) go to 60 - if (r .le. 0.5898437e0) then - r = r+3.90625e-2 - else - r = r-0.21875e0 - endif -c - 30 k = i -c -c select a central element of the array and save it in location t -c - ij = i + int((j-i)*r) - t = x(ij) -c -c if first element of array is greater than t, interchange with t -c - if (x(i) .gt. t) then - x(ij) = x(i) - x(i) = t - t = x(ij) - endif - l = j -c -c if last element of array is less than than t, interchange with t -c - if (x(j) .lt. t) then - x(ij) = x(j) - x(j) = t - t = x(ij) -c -c if first element of array is greater than t, interchange with t -c - if (x(i) .gt. t) then - x(ij) = x(i) - x(i) = t - t = x(ij) - endif - endif -c -c find an element in the second half of the array which is smaller -c than t -c - 40 l = l-1 - if (x(l) .gt. t) go to 40 -c -c find an element in the first half of the array which is greater -c than t -c - 50 k = k+1 - if (x(k) .lt. t) go to 50 -c -c interchange these elements -c - if (k .le. l) then - tt = x(l) - x(l) = x(k) - x(k) = tt - go to 40 - endif -c -c save upper and lower subscripts of the array yet to be sorted -c - if (l-i .gt. j-k) then - il(m) = i - iu(m) = l - i = k - m = m+1 - else - il(m) = k - iu(m) = j - j = l - m = m+1 - endif - go to 70 -c -c begin again on another portion of the unsorted array -c - 60 m = m-1 - if (m .eq. 0) go to 190 - i = il(m) - j = iu(m) -c - 70 if (j-i .ge. 1) go to 30 - if (i .eq. 1) go to 20 - i = i-1 -c - 80 i = i+1 - if (i .eq. j) go to 60 - t = x(i+1) - if (x(i) .le. t) go to 80 - k = i -c - 90 x(k+1) = x(k) - k = k-1 - if (t .lt. x(k)) go to 90 - x(k+1) = t - go to 80 -c -c sort x and carry y along -c - 100 m = 1 - i = 1 - j = nn - r = 0.375e0 -c - 110 if (i .eq. j) go to 150 - if (r .le. 0.5898437e0) then - r = r+3.90625e-2 - else - r = r-0.21875e0 - endif -c - 120 k = i -c -c select a central element of the array and save it in location t -c - ij = i + int((j-i)*r) - t = x(ij) - ty = y(ij) -c -c if first element of array is greater than t, interchange with t -c - if (x(i) .gt. t) then - x(ij) = x(i) - x(i) = t - t = x(ij) - y(ij) = y(i) - y(i) = ty - ty = y(ij) - endif - l = j -c -c if last element of array is less than t, interchange with t -c - if (x(j) .lt. t) then - x(ij) = x(j) - x(j) = t - t = x(ij) - y(ij) = y(j) - y(j) = ty - ty = y(ij) -c -c if first element of array is greater than t, interchange with t -c - if (x(i) .gt. t) then - x(ij) = x(i) - x(i) = t - t = x(ij) - y(ij) = y(i) - y(i) = ty - ty = y(ij) - endif - endif -c -c find an element in the second half of the array which is smaller -c than t -c - 130 l = l-1 - if (x(l) .gt. t) go to 130 -c -c find an element in the first half of the array which is greater -c than t -c - 140 k = k+1 - if (x(k) .lt. t) go to 140 -c -c interchange these elements -c - if (k .le. l) then - tt = x(l) - x(l) = x(k) - x(k) = tt - tty = y(l) - y(l) = y(k) - y(k) = tty - go to 130 - endif -c -c save upper and lower subscripts of the array yet to be sorted -c - if (l-i .gt. j-k) then - il(m) = i - iu(m) = l - i = k - m = m+1 - else - il(m) = k - iu(m) = j - j = l - m = m+1 - endif - go to 160 -c -c begin again on another portion of the unsorted array -c - 150 m = m-1 - if (m .eq. 0) go to 190 - i = il(m) - j = iu(m) -c - 160 if (j-i .ge. 1) go to 120 - if (i .eq. 1) go to 110 - i = i-1 -c - 170 i = i+1 - if (i .eq. j) go to 150 - t = x(i+1) - ty = y(i+1) - if (x(i) .le. t) go to 170 - k = i -c - 180 x(k+1) = x(k) - y(k+1) = y(k) - k = k-1 - if (t .lt. x(k)) go to 180 - x(k+1) = t - y(k+1) = ty - go to 170 -c -c clean up -c - 190 if (kflag .le. -1) then - do 200 i=1,nn - x(i) = -x(i) - 200 continue - endif - return - end diff --git a/lib/ssort.f90 b/lib/ssort.f90 new file mode 100644 index 000000000..7d712388d --- /dev/null +++ b/lib/ssort.f90 @@ -0,0 +1,264 @@ +subroutine ssort (x,y,n,kflag) +! Sort an array and optionally make the same interchanges in +! an auxiliary array. the array may be sorted in increasing +! or decreasing order. a slightly modified quicksort +! algorithm is used. + +! ssort sorts array x and optionally makes the same interchanges in +! array y. the array x may be sorted in increasing order or +! decreasing order. a slightly modified quicksort algorithm is used. + +! Description of parameters +! x - array of values to be sorted +! y - array to be (optionally) carried along +! n - number of values in array x to be sorted +! kflag - control parameter +! = 2 means sort x in increasing order and carry y along. +! = 1 means sort x in increasing order (ignoring y) +! = -1 means sort x in decreasing order (ignoring y) +! = -2 means sort x in decreasing order and carry y along. + + integer kflag, n + integer x(n), y(n) + real r + integer t, tt, tty, ty + integer i, ij, j, k, kk, l, m, nn + integer il(21), iu(21) + + nn = n + if (nn .lt. 1) then +! print*,'ssort: The number of sort elements is not positive.' +! print*,'ssort: n = ',nn,' kflag = ',kflag + return + endif + + kk = abs(kflag) + if (kk.ne.1 .and. kk.ne.2) then + print *,'the sort control parameter, k, is not 2, 1, -1, or -2.' + return + endif + +! Alter array x to get decreasing order if needed + + if (kflag .le. -1) then + do i=1,nn + x(i) = -x(i) + enddo + endif + + if (kk .eq. 2) go to 100 + +! Sort x only + + m = 1 + i = 1 + j = nn + r = 0.375e0 + +20 if (i .eq. j) go to 60 + if (r .le. 0.5898437e0) then + r = r+3.90625e-2 + else + r = r-0.21875e0 + endif + +30 k = i + +! Select a central element of the array and save it in location t + + ij = i + int((j-i)*r) + t = x(ij) + +! If first element of array is greater than t, interchange with t + + if (x(i) .gt. t) then + x(ij) = x(i) + x(i) = t + t = x(ij) + endif + l = j + +! If last element of array is less than than t, interchange with t + if (x(j) .lt. t) then + x(ij) = x(j) + x(j) = t + t = x(ij) + +! If first element of array is greater than t, interchange with t + if (x(i) .gt. t) then + x(ij) = x(i) + x(i) = t + t = x(ij) + endif + endif + +! Find an element in the second half of the array which is smaller than t +40 l = l-1 + if (x(l) .gt. t) go to 40 + +! Find an element in the first half of the array which is greater than t +50 k = k+1 + if (x(k) .lt. t) go to 50 + +! Interchange these elements + if (k .le. l) then + tt = x(l) + x(l) = x(k) + x(k) = tt + go to 40 + endif + +! Save upper and lower subscripts of the array yet to be sorted + if (l-i .gt. j-k) then + il(m) = i + iu(m) = l + i = k + m = m+1 + else + il(m) = k + iu(m) = j + j = l + m = m+1 + endif + go to 70 + +! Begin again on another portion of the unsorted array +60 m = m-1 + if (m .eq. 0) go to 190 + i = il(m) + j = iu(m) + +70 if (j-i .ge. 1) go to 30 + if (i .eq. 1) go to 20 + i = i-1 + +80 i = i+1 + if (i .eq. j) go to 60 + t = x(i+1) + if (x(i) .le. t) go to 80 + k = i + +90 x(k+1) = x(k) + k = k-1 + if (t .lt. x(k)) go to 90 + x(k+1) = t + go to 80 + +! Sort x and carry y along + +100 m = 1 + i = 1 + j = nn + r = 0.375e0 + +110 if (i .eq. j) go to 150 + if (r .le. 0.5898437e0) then + r = r+3.90625e-2 + else + r = r-0.21875e0 + endif + + 120 k = i +! Select a central element of the array and save it in location t + ij = i + int((j-i)*r) + t = x(ij) + ty = y(ij) + +! If first element of array is greater than t, interchange with t + if (x(i) .gt. t) then + x(ij) = x(i) + x(i) = t + t = x(ij) + y(ij) = y(i) + y(i) = ty + ty = y(ij) + endif + l = j + +! If last element of array is less than t, interchange with t + if (x(j) .lt. t) then + x(ij) = x(j) + x(j) = t + t = x(ij) + y(ij) = y(j) + y(j) = ty + ty = y(ij) + +! If first element of array is greater than t, interchange with t + if (x(i) .gt. t) then + x(ij) = x(i) + x(i) = t + t = x(ij) + y(ij) = y(i) + y(i) = ty + ty = y(ij) + endif + endif + +! Find an element in the second half of the array which is smaller than t +130 l = l-1 + if (x(l) .gt. t) go to 130 + +! Find an element in the first half of the array which is greater than t +140 k = k+1 + if (x(k) .lt. t) go to 140 + +! Interchange these elements + if (k .le. l) then + tt = x(l) + x(l) = x(k) + x(k) = tt + tty = y(l) + y(l) = y(k) + y(k) = tty + go to 130 + endif + +! Save upper and lower subscripts of the array yet to be sorted + if (l-i .gt. j-k) then + il(m) = i + iu(m) = l + i = k + m = m+1 + else + il(m) = k + iu(m) = j + j = l + m = m+1 + endif + go to 160 + +! Begin again on another portion of the unsorted array +150 m = m-1 + if (m .eq. 0) go to 190 + i = il(m) + j = iu(m) + +160 if (j-i .ge. 1) go to 120 + if (i .eq. 1) go to 110 + i = i-1 + +170 i = i+1 + if (i .eq. j) go to 150 + t = x(i+1) + ty = y(i+1) + if (x(i) .le. t) go to 170 + k = i + +180 x(k+1) = x(k) + y(k+1) = y(k) + k = k-1 + if (t .lt. x(k)) go to 180 + x(k+1) = t + y(k+1) = ty + go to 170 + +! Clean up +190 if (kflag .le. -1) then + do i=1,nn + x(i) = -x(i) + enddo + endif + + return +end subroutine ssort diff --git a/lib/unpackcall.f b/lib/unpackcall.f deleted file mode 100644 index 9a5a218c3..000000000 --- a/lib/unpackcall.f +++ /dev/null @@ -1,142 +0,0 @@ - subroutine unpackcall(ncall,word,iv2,psfx) - - parameter (NBASE=37*36*10*27*27*27) - character word*12,c*37,psfx*4 - - data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/ - - n=ncall - iv2=0 - if(n.ge.262177560) go to 20 - word='......' - if(n.ge.262177560) go to 999 !Plain text message ... - i=mod(n,27)+11 - word(6:6)=c(i:i) - n=n/27 - i=mod(n,27)+11 - word(5:5)=c(i:i) - n=n/27 - i=mod(n,27)+11 - word(4:4)=c(i:i) - n=n/27 - i=mod(n,10)+1 - word(3:3)=c(i:i) - n=n/10 - i=mod(n,36)+1 - word(2:2)=c(i:i) - n=n/36 - i=n+1 - word(1:1)=c(i:i) - do i=1,4 - if(word(i:i).ne.' ') go to 10 - enddo - go to 999 - 10 word=word(i:) - go to 999 - - 20 if(n.ge.267796946) go to 999 - -! We have a JT65v2 message - if((n.ge.262178563) .and. (n.le.264002071)) Then -! CQ with prefix - iv2=1 - n=n-262178563 - i=mod(n,37)+1 - psfx(4:4)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(3:3)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(2:2)=c(i:i) - n=n/37 - i=n+1 - psfx(1:1)=c(i:i) - endif - - if((n.ge.264002072) .and. (n.le.265825580)) Then -! QRZ with prefix - iv2=2 - n=n-264002072 - i=mod(n,37)+1 - psfx(4:4)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(3:3)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(2:2)=c(i:i) - n=n/37 - i=n+1 - psfx(1:1)=c(i:i) - endif - - if((n.ge.265825581) .and. (n.le.267649089)) Then -! DE with prefix - iv2=3 - n=n-265825581 - i=mod(n,37)+1 - psfx(4:4)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(3:3)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(2:2)=c(i:i) - n=n/37 - i=n+1 - psfx(1:1)=c(i:i) - endif - - if((n.ge.267649090) .and. (n.le.267698374)) Then -! CQ with suffix - iv2=4 - n=n-267649090 - i=mod(n,37)+1 - psfx(3:3)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(2:2)=c(i:i) - n=n/37 - i=n+1 - psfx(1:1)=c(i:i) - endif - - if((n.ge.267698375) .and. (n.le.267747659)) Then -! QRZ with suffix - iv2=5 - n=n-267698375 - i=mod(n,37)+1 - psfx(3:3)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(2:2)=c(i:i) - n=n/37 - i=n+1 - psfx(1:1)=c(i:i) - endif - - if((n.ge.267747660) .and. (n.le.267796944)) Then -! DE with suffix - iv2=6 - n=n-267747660 - i=mod(n,37)+1 - psfx(3:3)=c(i:i) - n=n/37 - i=mod(n,37)+1 - psfx(2:2)=c(i:i) - n=n/37 - i=n+1 - psfx(1:1)=c(i:i) - endif - - if(n.eq.267796945) Then -! DE with no prefix or suffix - iv2=7 - psfx = ' ' - endif - - 999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:) - - return - end diff --git a/lib/unpackcall.f90 b/lib/unpackcall.f90 new file mode 100644 index 000000000..f738926ca --- /dev/null +++ b/lib/unpackcall.f90 @@ -0,0 +1,142 @@ +subroutine unpackcall(ncall,word,iv2,psfx) + + parameter (NBASE=37*36*10*27*27*27) + character word*12,c*37,psfx*4 + + data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/ + + n=ncall + iv2=0 + if(n.ge.262177560) go to 20 + word='......' + if(n.ge.262177560) go to 999 !Plain text message ... + i=mod(n,27)+11 + word(6:6)=c(i:i) + n=n/27 + i=mod(n,27)+11 + word(5:5)=c(i:i) + n=n/27 + i=mod(n,27)+11 + word(4:4)=c(i:i) + n=n/27 + i=mod(n,10)+1 + word(3:3)=c(i:i) + n=n/10 + i=mod(n,36)+1 + word(2:2)=c(i:i) + n=n/36 + i=n+1 + word(1:1)=c(i:i) + do i=1,4 + if(word(i:i).ne.' ') go to 10 + enddo + go to 999 +10 word=word(i:) + go to 999 + +20 if(n.ge.267796946) go to 999 + +! We have a JT65v2 message + if((n.ge.262178563) .and. (n.le.264002071)) Then +! CQ with prefix + iv2=1 + n=n-262178563 + i=mod(n,37)+1 + psfx(4:4)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(3:3)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(2:2)=c(i:i) + n=n/37 + i=n+1 + psfx(1:1)=c(i:i) + endif + + if((n.ge.264002072) .and. (n.le.265825580)) Then +! QRZ with prefix + iv2=2 + n=n-264002072 + i=mod(n,37)+1 + psfx(4:4)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(3:3)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(2:2)=c(i:i) + n=n/37 + i=n+1 + psfx(1:1)=c(i:i) + endif + + if((n.ge.265825581) .and. (n.le.267649089)) Then +! DE with prefix + iv2=3 + n=n-265825581 + i=mod(n,37)+1 + psfx(4:4)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(3:3)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(2:2)=c(i:i) + n=n/37 + i=n+1 + psfx(1:1)=c(i:i) + endif + + if((n.ge.267649090) .and. (n.le.267698374)) Then +! CQ with suffix + iv2=4 + n=n-267649090 + i=mod(n,37)+1 + psfx(3:3)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(2:2)=c(i:i) + n=n/37 + i=n+1 + psfx(1:1)=c(i:i) + endif + + if((n.ge.267698375) .and. (n.le.267747659)) Then +! QRZ with suffix + iv2=5 + n=n-267698375 + i=mod(n,37)+1 + psfx(3:3)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(2:2)=c(i:i) + n=n/37 + i=n+1 + psfx(1:1)=c(i:i) + endif + + if((n.ge.267747660) .and. (n.le.267796944)) Then +! DE with suffix + iv2=6 + n=n-267747660 + i=mod(n,37)+1 + psfx(3:3)=c(i:i) + n=n/37 + i=mod(n,37)+1 + psfx(2:2)=c(i:i) + n=n/37 + i=n+1 + psfx(1:1)=c(i:i) + endif + + if(n.eq.267796945) Then +! DE with no prefix or suffix + iv2=7 + psfx = ' ' + endif + +999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:) + + return +end subroutine unpackcall diff --git a/lib/unpacktext.f b/lib/unpacktext.f deleted file mode 100644 index 0923e7eb1..000000000 --- a/lib/unpacktext.f +++ /dev/null @@ -1,35 +0,0 @@ - subroutine unpacktext(nc1,nc2,nc3,msg) - - character*22 msg - character*44 c - data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ - - nc3=iand(nc3,32767) !Remove the "plain text" bit - if(iand(nc1,1).ne.0) nc3=nc3+32768 - nc1=nc1/2 - if(iand(nc2,1).ne.0) nc3=nc3+65536 - nc2=nc2/2 - - do i=5,1,-1 - j=mod(nc1,42)+1 - msg(i:i)=c(j:j) - nc1=nc1/42 - enddo - - do i=10,6,-1 - j=mod(nc2,42)+1 - msg(i:i)=c(j:j) - nc2=nc2/42 - enddo - - do i=13,11,-1 - j=mod(nc3,42)+1 - msg(i:i)=c(j:j) - nc3=nc3/42 - enddo - msg(14:22) = ' ' - - return - end - - diff --git a/lib/unpacktext.f90 b/lib/unpacktext.f90 new file mode 100644 index 000000000..62451f97a --- /dev/null +++ b/lib/unpacktext.f90 @@ -0,0 +1,35 @@ +subroutine unpacktext(nc1,nc2,nc3,msg) + + character*22 msg + character*44 c + data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ + + nc3=iand(nc3,32767) !Remove the "plain text" bit + if(iand(nc1,1).ne.0) nc3=nc3+32768 + nc1=nc1/2 + if(iand(nc2,1).ne.0) nc3=nc3+65536 + nc2=nc2/2 + + do i=5,1,-1 + j=mod(nc1,42)+1 + msg(i:i)=c(j:j) + nc1=nc1/42 + enddo + + do i=10,6,-1 + j=mod(nc2,42)+1 + msg(i:i)=c(j:j) + nc2=nc2/42 + enddo + + do i=13,11,-1 + j=mod(nc3,42)+1 + msg(i:i)=c(j:j) + nc3=nc3/42 + enddo + msg(14:22) = ' ' + + return +end subroutine unpacktext + + diff --git a/mainwindow.cpp b/mainwindow.cpp index 291882563..164b49bd1 100644 --- a/mainwindow.cpp +++ b/mainwindow.cpp @@ -1,4 +1,4 @@ -//-------------------------------------------------------------- MainWindow +//--------------------------------------------------------------- MainWindow #include "mainwindow.h" #include "ui_mainwindow.h" #include "devsetup.h"