w4kek
/
WSJT-X
mirror of https://github.com/saitohirga/WSJT-X.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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
This commit is contained in:
Joe Taylor 2013-05-22 15:39:28 +00:00
parent e792e292cf
commit bfcbce34a7
40 changed files with 1064 additions and 1088 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
lib/deg2grid.f
View File

@ -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

30
lib/deg2grid.f90 Normal file
View File

@ -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

45
lib/f77_wisdom.f
View File

@ -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

45
lib/f77_wisdom.f90 Normal file
View File

@ -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

64
lib/fftw3.f
View File

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

64
lib/fftw3.f90 Normal file
View File

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

2
lib/four2a.f90
View File

@ -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

97
lib/getpfx1.f
View File

@ -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

97
lib/getpfx1.f90 Normal file
View File

@ -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

24
lib/getpfx2.f
View File

@ -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

24
lib/getpfx2.f90 Normal file
View File

@ -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

38
lib/grid2deg.f
View File

@ -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

38
lib/grid2deg.f90 Normal file
View File

@ -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

12
lib/grid2k.f
View File

@ -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

12
lib/grid2k.f90 Normal file
View File

@ -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

19
lib/indexx.f
View File

@ -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

19
lib/indexx.f90 Normal file
View File

@ -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

12
lib/k2grid.f
View File

@ -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

12
lib/k2grid.f90 Normal file
View File

@ -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

23
lib/nchar.f
View File

@ -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

23
lib/nchar.f90 Normal file
View File

@ -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

79
lib/packcall.f
View File

@ -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

79
lib/packcall.f90 Normal file
View File

@ -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

64
lib/packdxcc.f
View File

@ -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

64
lib/packdxcc.f90 Normal file
View File

@ -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

47
lib/packtext.f
View File

@ -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

47
lib/packtext.f90 Normal file
View File

@ -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

50
lib/pfx.f
View File

@ -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 '/

50
lib/pfx.f90 Normal file
View File

@ -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 '/

13
lib/pfxdump.f
View File

@ -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

13
lib/pfxdump.f90 Normal file
View File

@ -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

4
lib/sort.f
View File

@ -1,4 +0,0 @@
subroutine sort(n,arr)
call ssort(arr,tmp,n,1)
return
end

4
lib/sort.f90 Normal file
View File

@ -0,0 +1,4 @@
subroutine sort(n,arr)
call ssort(arr,tmp,n,1)
return
end subroutine sort

288
lib/ssort.f
View File

@ -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

264
lib/ssort.f90 Normal file
View File

@ -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

142
lib/unpackcall.f
View File

@ -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

142
lib/unpackcall.f90 Normal file
View File

@ -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

35
lib/unpacktext.f
View File

@ -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

35
lib/unpacktext.f90 Normal file
View File

@ -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

2
mainwindow.cpp
View File

@ -1,4 +1,4 @@
//-------------------------------------------------------------- MainWindow
//--------------------------------------------------------------- MainWindow
#include "mainwindow.h"
#include "ui_mainwindow.h"
#include "devsetup.h"