mirror of
https://github.com/saitohirga/WSJT-X.git
synced 2024-11-26 06:08:42 -05:00
Final conversions from .f to .f90.
git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/map65@7476 ab8295b8-cf94-4d9e-aec4-7959e3be5d79
This commit is contained in:
Joe Taylor
parent
c3102ea485
commit
94f76eb22a
@ -118,23 +118,22 @@ set (FSRCS
|
||||
setup65.f90
|
||||
sleep_msec.f90
|
||||
sort.f90
|
||||
|
||||
sun.f90
|
||||
symspec.f90
|
||||
timer.f90
|
||||
timf2.f90
|
||||
tm2.f90
|
||||
toxyz.f90
|
||||
trimlist.f90
|
||||
twkfreq.f90
|
||||
unpackcall.f90
|
||||
unpackgrid.f90
|
||||
unpackmsg.f90
|
||||
unpacktext.f90
|
||||
zplot.f90
|
||||
|
||||
f77_wisdom.f
|
||||
ssort.f
|
||||
sun.f
|
||||
toxyz.f
|
||||
trimlist.f
|
||||
twkfreq.f
|
||||
unpackcall.f
|
||||
unpackgrid.f
|
||||
unpackmsg.f
|
||||
unpacktext.f
|
||||
)
|
||||
|
||||
set (CSRCS
|
||||
|
||||
88
libm65/sun.f
88
libm65/sun.f
@ -1,88 +0,0 @@
|
||||
subroutine sun(y,m,DD,UT,lon,lat,RA,Dec,LST,Az,El,mjd,day)
|
||||
|
||||
implicit none
|
||||
|
||||
integer y !Year
|
||||
integer m !Month
|
||||
integer DD !Day
|
||||
integer mjd !Modified Julian Date
|
||||
real UT !UTC in hours
|
||||
real RA,Dec !RA and Dec of sun
|
||||
|
||||
C NB: Double caps here are single caps in the writeup.
|
||||
|
||||
C Orbital elements of the Sun (also N=0, i=0, a=1):
|
||||
real w !Argument of perihelion
|
||||
real e !Eccentricity
|
||||
real MM !Mean anomaly
|
||||
real Ls !Mean longitude
|
||||
|
||||
C Other standard variables:
|
||||
real v !True anomaly
|
||||
real EE !Eccentric anomaly
|
||||
real ecl !Obliquity of the ecliptic
|
||||
real d !Ephemeris time argument in days
|
||||
real r !Distance to sun, AU
|
||||
real xv,yv !x and y coords in ecliptic
|
||||
real lonsun !Ecliptic long and lat of sun
|
||||
C Ecliptic coords of sun (geocentric)
|
||||
real xs,ys
|
||||
C Equatorial coords of sun (geocentric)
|
||||
real xe,ye,ze
|
||||
real lon,lat
|
||||
real GMST0,LST,HA
|
||||
real xx,yy,zz
|
||||
real xhor,yhor,zhor
|
||||
real Az,El
|
||||
|
||||
real day
|
||||
real rad
|
||||
data rad/57.2957795/
|
||||
|
||||
C Time in days, with Jan 0, 2000 equal to 0.0:
|
||||
d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + DD - 730530 + UT/24.0
|
||||
mjd=d + 51543
|
||||
ecl = 23.4393 - 3.563e-7 * d
|
||||
|
||||
C Compute updated orbital elements for Sun:
|
||||
w = 282.9404 + 4.70935e-5 * d
|
||||
e = 0.016709 - 1.151e-9 * d
|
||||
MM = mod(356.0470d0 + 0.9856002585d0 * d + 360000.d0,360.d0)
|
||||
Ls = mod(w+MM+720.0,360.0)
|
||||
|
||||
EE = MM + e*rad*sin(MM/rad) * (1.0 + e*cos(M/rad))
|
||||
EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.0 - e*cos(EE/rad))
|
||||
|
||||
xv = cos(EE/rad) - e
|
||||
yv = sqrt(1.0-e*e) * sin(EE/rad)
|
||||
v = rad*atan2(yv,xv)
|
||||
r = sqrt(xv*xv + yv*yv)
|
||||
lonsun = mod(v + w + 720.0,360.0)
|
||||
C Ecliptic coordinates of sun (rectangular):
|
||||
xs = r * cos(lonsun/rad)
|
||||
ys = r * sin(lonsun/rad)
|
||||
|
||||
C Equatorial coordinates of sun (rectangular):
|
||||
xe = xs
|
||||
ye = ys * cos(ecl/rad)
|
||||
ze = ys * sin(ecl/rad)
|
||||
|
||||
C RA and Dec in degrees:
|
||||
RA = rad*atan2(ye,xe)
|
||||
Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye))
|
||||
|
||||
GMST0 = (Ls + 180.0)/15.0
|
||||
LST = mod(GMST0+UT+lon/15.0+48.0,24.0) !LST in hours
|
||||
HA = 15.0*LST - RA !HA in degrees
|
||||
xx = cos(HA/rad)*cos(Dec/rad)
|
||||
yy = sin(HA/rad)*cos(Dec/rad)
|
||||
zz = sin(Dec/rad)
|
||||
xhor = xx*sin(lat/rad) - zz*cos(lat/rad)
|
||||
yhor = yy
|
||||
zhor = xx*cos(lat/rad) + zz*sin(lat/rad)
|
||||
Az = mod(rad*atan2(yhor,xhor) + 180.0 + 360.0,360.0)
|
||||
El = rad*asin(zhor)
|
||||
day=d-1.5
|
||||
|
||||
return
|
||||
end
|
||||
88
libm65/sun.f90
Normal file
88
libm65/sun.f90
Normal file
@ -0,0 +1,88 @@
|
||||
subroutine sun(y,m,DD,UT,lon,lat,RA,Dec,LST,Az,El,mjd,day)
|
||||
|
||||
implicit none
|
||||
|
||||
integer y !Year
|
||||
integer m !Month
|
||||
integer DD !Day
|
||||
integer mjd !Modified Julian Date
|
||||
real UT !UTC in hours
|
||||
real RA,Dec !RA and Dec of sun
|
||||
|
||||
! NB: Double caps here are single caps in the writeup.
|
||||
|
||||
! Orbital elements of the Sun (also N=0, i=0, a=1):
|
||||
real w !Argument of perihelion
|
||||
real e !Eccentricity
|
||||
real MM !Mean anomaly
|
||||
real Ls !Mean longitude
|
||||
|
||||
! Other standard variables:
|
||||
real v !True anomaly
|
||||
real EE !Eccentric anomaly
|
||||
real ecl !Obliquity of the ecliptic
|
||||
real d !Ephemeris time argument in days
|
||||
real r !Distance to sun, AU
|
||||
real xv,yv !x and y coords in ecliptic
|
||||
real lonsun !Ecliptic long and lat of sun
|
||||
! Ecliptic coords of sun (geocentric)
|
||||
real xs,ys
|
||||
! Equatorial coords of sun (geocentric)
|
||||
real xe,ye,ze
|
||||
real lon,lat
|
||||
real GMST0,LST,HA
|
||||
real xx,yy,zz
|
||||
real xhor,yhor,zhor
|
||||
real Az,El
|
||||
|
||||
real day
|
||||
real rad
|
||||
data rad/57.2957795/
|
||||
|
||||
! Time in days, with Jan 0, 2000 equal to 0.0:
|
||||
d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + DD - 730530 + UT/24.0
|
||||
mjd=d + 51543
|
||||
ecl = 23.4393 - 3.563e-7 * d
|
||||
|
||||
! Compute updated orbital elements for Sun:
|
||||
w = 282.9404 + 4.70935e-5 * d
|
||||
e = 0.016709 - 1.151e-9 * d
|
||||
MM = mod(356.0470d0 + 0.9856002585d0 * d + 360000.d0,360.d0)
|
||||
Ls = mod(w+MM+720.0,360.0)
|
||||
|
||||
EE = MM + e*rad*sin(MM/rad) * (1.0 + e*cos(M/rad))
|
||||
EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.0 - e*cos(EE/rad))
|
||||
|
||||
xv = cos(EE/rad) - e
|
||||
yv = sqrt(1.0-e*e) * sin(EE/rad)
|
||||
v = rad*atan2(yv,xv)
|
||||
r = sqrt(xv*xv + yv*yv)
|
||||
lonsun = mod(v + w + 720.0,360.0)
|
||||
! Ecliptic coordinates of sun (rectangular):
|
||||
xs = r * cos(lonsun/rad)
|
||||
ys = r * sin(lonsun/rad)
|
||||
|
||||
! Equatorial coordinates of sun (rectangular):
|
||||
xe = xs
|
||||
ye = ys * cos(ecl/rad)
|
||||
ze = ys * sin(ecl/rad)
|
||||
|
||||
! RA and Dec in degrees:
|
||||
RA = rad*atan2(ye,xe)
|
||||
Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye))
|
||||
|
||||
GMST0 = (Ls + 180.0)/15.0
|
||||
LST = mod(GMST0+UT+lon/15.0+48.0,24.0) !LST in hours
|
||||
HA = 15.0*LST - RA !HA in degrees
|
||||
xx = cos(HA/rad)*cos(Dec/rad)
|
||||
yy = sin(HA/rad)*cos(Dec/rad)
|
||||
zz = sin(Dec/rad)
|
||||
xhor = xx*sin(lat/rad) - zz*cos(lat/rad)
|
||||
yhor = yy
|
||||
zhor = xx*cos(lat/rad) + zz*sin(lat/rad)
|
||||
Az = mod(rad*atan2(yhor,xhor) + 180.0 + 360.0,360.0)
|
||||
El = rad*asin(zhor)
|
||||
day=d-1.5
|
||||
|
||||
return
|
||||
end subroutine sun
|
||||
@ -1,25 +0,0 @@
|
||||
subroutine toxyz(alpha,delta,r,vec)
|
||||
|
||||
implicit real*8 (a-h,o-z)
|
||||
real*8 vec(3)
|
||||
|
||||
vec(1)=r*cos(delta)*cos(alpha)
|
||||
vec(2)=r*cos(delta)*sin(alpha)
|
||||
vec(3)=r*sin(delta)
|
||||
|
||||
return
|
||||
end
|
||||
|
||||
subroutine fromxyz(vec,alpha,delta,r)
|
||||
|
||||
implicit real*8 (a-h,o-z)
|
||||
real*8 vec(3)
|
||||
data twopi/6.283185307d0/
|
||||
|
||||
r=sqrt(vec(1)**2 + vec(2)**2 + vec(3)**2)
|
||||
alpha=atan2(vec(2),vec(1))
|
||||
if(alpha.lt.0.d0) alpha=alpha+twopi
|
||||
delta=asin(vec(3)/r)
|
||||
|
||||
return
|
||||
end
|
||||
25
libm65/toxyz.f90
Normal file
25
libm65/toxyz.f90
Normal file
@ -0,0 +1,25 @@
|
||||
subroutine toxyz(alpha,delta,r,vec)
|
||||
|
||||
implicit real*8 (a-h,o-z)
|
||||
real*8 vec(3)
|
||||
|
||||
vec(1)=r*cos(delta)*cos(alpha)
|
||||
vec(2)=r*cos(delta)*sin(alpha)
|
||||
vec(3)=r*sin(delta)
|
||||
|
||||
return
|
||||
end subroutine toxyz
|
||||
|
||||
subroutine fromxyz(vec,alpha,delta,r)
|
||||
|
||||
implicit real*8 (a-h,o-z)
|
||||
real*8 vec(3)
|
||||
data twopi/6.283185307d0/
|
||||
|
||||
r=sqrt(vec(1)**2 + vec(2)**2 + vec(3)**2)
|
||||
alpha=atan2(vec(2),vec(1))
|
||||
if(alpha.lt.0.d0) alpha=alpha+twopi
|
||||
delta=asin(vec(3)/r)
|
||||
|
||||
return
|
||||
end subroutine fromxyz
|
||||
@ -1,28 +0,0 @@
|
||||
subroutine trimlist(sig,km,ftol,indx,nsiz,nz)
|
||||
|
||||
parameter (MAXMSG=1000) !Size of decoded message list
|
||||
real sig(MAXMSG,30)
|
||||
integer indx(MAXMSG),nsiz(MAXMSG)
|
||||
|
||||
C 1 2 3 4 5 6 7 8
|
||||
C nfile nutc freq snr dt ipol flip sync
|
||||
|
||||
call indexx(km,sig(1,3),indx) !Sort list by frequency
|
||||
|
||||
n=1
|
||||
i0=1
|
||||
do i=2,km
|
||||
j0=indx(i-1)
|
||||
j=indx(i)
|
||||
if(sig(j,3)-sig(j0,3).gt.ftol) then
|
||||
nsiz(n)=i-i0
|
||||
i0=i
|
||||
n=n+1
|
||||
endif
|
||||
enddo
|
||||
nz=n
|
||||
nsiz(nz)=km+1-i0
|
||||
nsiz(nz+1)=-1
|
||||
|
||||
return
|
||||
end
|
||||
28
libm65/trimlist.f90
Normal file
28
libm65/trimlist.f90
Normal file
@ -0,0 +1,28 @@
|
||||
subroutine trimlist(sig,km,ftol,indx,nsiz,nz)
|
||||
|
||||
parameter (MAXMSG=1000) !Size of decoded message list
|
||||
real sig(MAXMSG,30)
|
||||
integer indx(MAXMSG),nsiz(MAXMSG)
|
||||
|
||||
! 1 2 3 4 5 6 7 8
|
||||
! nfile nutc freq snr dt ipol flip sync
|
||||
|
||||
call indexx(km,sig(1,3),indx) !Sort list by frequency
|
||||
|
||||
n=1
|
||||
i0=1
|
||||
do i=2,km
|
||||
j0=indx(i-1)
|
||||
j=indx(i)
|
||||
if(sig(j,3)-sig(j0,3).gt.ftol) then
|
||||
nsiz(n)=i-i0
|
||||
i0=i
|
||||
n=n+1
|
||||
endif
|
||||
enddo
|
||||
nz=n
|
||||
nsiz(nz)=km+1-i0
|
||||
nsiz(nz+1)=-1
|
||||
|
||||
return
|
||||
end subroutine trimlist
|
||||
@ -1,29 +0,0 @@
|
||||
subroutine twkfreq(c4aa,c4bb,n5,a)
|
||||
|
||||
complex c4aa(n5)
|
||||
complex c4bb(n5)
|
||||
real a(5)
|
||||
complex w,wstep
|
||||
data twopi/6.283185307/
|
||||
|
||||
C Apply AFC corrections to the c4aa and c4bb data
|
||||
w=1.0
|
||||
wstep=1.0
|
||||
x0=0.5*(n5+1)
|
||||
s=2.0/n5
|
||||
do i=1,n5
|
||||
x=s*(i-x0)
|
||||
if(mod(i,1000).eq.1) then
|
||||
p2=1.5*x*x - 0.5
|
||||
! p3=2.5*(x**3) - 1.5*x
|
||||
! p4=4.375*(x**4) - 3.75*(x**2) + 0.375
|
||||
dphi=(a(1) + x*a(2) + p2*a(3)) * (twopi/1378.125)
|
||||
wstep=cmplx(cos(dphi),sin(dphi))
|
||||
endif
|
||||
w=w*wstep
|
||||
c4aa(i)=w*c4aa(i)
|
||||
c4bb(i)=w*c4bb(i)
|
||||
enddo
|
||||
|
||||
return
|
||||
end
|
||||
29
libm65/twkfreq.f90
Normal file
29
libm65/twkfreq.f90
Normal file
@ -0,0 +1,29 @@
|
||||
subroutine twkfreq(c4aa,c4bb,n5,a)
|
||||
|
||||
complex c4aa(n5)
|
||||
complex c4bb(n5)
|
||||
real a(5)
|
||||
complex w,wstep
|
||||
data twopi/6.283185307/
|
||||
|
||||
! Apply AFC corrections to the c4aa and c4bb data
|
||||
w=1.0
|
||||
wstep=1.0
|
||||
x0=0.5*(n5+1)
|
||||
s=2.0/n5
|
||||
do i=1,n5
|
||||
x=s*(i-x0)
|
||||
if(mod(i,1000).eq.1) then
|
||||
p2=1.5*x*x - 0.5
|
||||
! p3=2.5*(x**3) - 1.5*x
|
||||
! p4=4.375*(x**4) - 3.75*(x**2) + 0.375
|
||||
dphi=(a(1) + x*a(2) + p2*a(3)) * (twopi/1378.125)
|
||||
wstep=cmplx(cos(dphi),sin(dphi))
|
||||
endif
|
||||
w=w*wstep
|
||||
c4aa(i)=w*c4aa(i)
|
||||
c4bb(i)=w*c4bb(i)
|
||||
enddo
|
||||
|
||||
return
|
||||
end subroutine twkfreq
|
||||
@ -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
libm65/unpackcall.f90
Normal file
142
libm65/unpackcall.f90
Normal 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
|
||||
@ -1,32 +0,0 @@
|
||||
subroutine unpackgrid(ng,grid)
|
||||
|
||||
parameter (NGBASE=180*180)
|
||||
character grid*4,grid6*6
|
||||
|
||||
grid=' '
|
||||
if(ng.ge.32400) go to 10
|
||||
dlat=mod(ng,180)-90
|
||||
dlong=(ng/180)*2 - 180 + 2
|
||||
call deg2grid(dlong,dlat,grid6)
|
||||
grid=grid6(:4)
|
||||
go to 100
|
||||
|
||||
10 n=ng-NGBASE-1
|
||||
if(n.ge.1 .and.n.le.30) then
|
||||
write(grid,1012) -n
|
||||
1012 format(i3.2)
|
||||
else if(n.ge.31 .and.n.le.60) then
|
||||
n=n-30
|
||||
write(grid,1022) -n
|
||||
1022 format('R',i3.2)
|
||||
else if(n.eq.61) then
|
||||
grid='RO'
|
||||
else if(n.eq.62) then
|
||||
grid='RRR'
|
||||
else if(n.eq.63) then
|
||||
grid='73'
|
||||
endif
|
||||
|
||||
100 return
|
||||
end
|
||||
|
||||
32
libm65/unpackgrid.f90
Normal file
32
libm65/unpackgrid.f90
Normal file
@ -0,0 +1,32 @@
|
||||
subroutine unpackgrid(ng,grid)
|
||||
|
||||
parameter (NGBASE=180*180)
|
||||
character grid*4,grid6*6
|
||||
|
||||
grid=' '
|
||||
if(ng.ge.32400) go to 10
|
||||
dlat=mod(ng,180)-90
|
||||
dlong=(ng/180)*2 - 180 + 2
|
||||
call deg2grid(dlong,dlat,grid6)
|
||||
grid=grid6(:4)
|
||||
go to 100
|
||||
|
||||
10 n=ng-NGBASE-1
|
||||
if(n.ge.1 .and.n.le.30) then
|
||||
write(grid,1012) -n
|
||||
1012 format(i3.2)
|
||||
else if(n.ge.31 .and.n.le.60) then
|
||||
n=n-30
|
||||
write(grid,1022) -n
|
||||
1022 format('R',i3.2)
|
||||
else if(n.eq.61) then
|
||||
grid='RO'
|
||||
else if(n.eq.62) then
|
||||
grid='RRR'
|
||||
else if(n.eq.63) then
|
||||
grid='73'
|
||||
endif
|
||||
|
||||
100 return
|
||||
end subroutine unpackgrid
|
||||
|
||||
@ -1,100 +0,0 @@
|
||||
subroutine unpackmsg(dat,msg)
|
||||
|
||||
parameter (NBASE=37*36*10*27*27*27)
|
||||
parameter (NGBASE=180*180)
|
||||
integer dat(12)
|
||||
character c1*12,c2*12,grid*4,msg*22,grid6*6,psfx*4,junk2*4
|
||||
logical cqnnn
|
||||
|
||||
cqnnn=.false.
|
||||
nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+
|
||||
+ ishft(dat(4),4) + iand(ishft(dat(5),-2),15)
|
||||
|
||||
nc2=ishft(iand(dat(5),3),26) + ishft(dat(6),20) +
|
||||
+ ishft(dat(7),14) + ishft(dat(8),8) + ishft(dat(9),2) +
|
||||
+ iand(ishft(dat(10),-4),3)
|
||||
|
||||
ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12)
|
||||
|
||||
if(ng.ge.32768) then
|
||||
call unpacktext(nc1,nc2,ng,msg)
|
||||
go to 100
|
||||
endif
|
||||
|
||||
call unpackcall(nc1,c1,iv2,psfx)
|
||||
if(iv2.eq.0) then
|
||||
! This is an "original JT65" message
|
||||
if(nc1.eq.NBASE+1) c1='CQ '
|
||||
if(nc1.eq.NBASE+2) c1='QRZ '
|
||||
nfreq=nc1-NBASE-3
|
||||
if(nfreq.ge.0 .and. nfreq.le.999) then
|
||||
write(c1,1002) nfreq
|
||||
1002 format('CQ ',i3.3)
|
||||
cqnnn=.true.
|
||||
endif
|
||||
endif
|
||||
|
||||
call unpackcall(nc2,c2,junk1,junk2)
|
||||
call unpackgrid(ng,grid)
|
||||
|
||||
if(iv2.gt.0) then
|
||||
! This is a JT65v2 message
|
||||
n1=len_trim(psfx)
|
||||
n2=len_trim(c2)
|
||||
if(iv2.eq.1) msg='CQ '//psfx(:n1)//'/'//c2(:n2)//' '//grid
|
||||
if(iv2.eq.2) msg='QRZ '//psfx(:n1)//'/'//c2(:n2)//' '//grid
|
||||
if(iv2.eq.3) msg='DE '//psfx(:n1)//'/'//c2(:n2)//' '//grid
|
||||
if(iv2.eq.4) msg='CQ '//c2(:n2)//'/'//psfx(:n1)//' '//grid
|
||||
if(iv2.eq.5) msg='QRZ '//c2(:n2)//'/'//psfx(:n1)//' '//grid
|
||||
if(iv2.eq.6) msg='DE '//c2(:n2)//'/'//psfx(:n1)//' '//grid
|
||||
if(iv2.eq.7) msg='DE '//c2(:n2)//' '//grid
|
||||
go to 100
|
||||
else
|
||||
|
||||
endif
|
||||
|
||||
grid6=grid//'ma'
|
||||
call grid2k(grid6,k)
|
||||
if(k.ge.1 .and. k.le.450) call getpfx2(k,c1)
|
||||
if(k.ge.451 .and. k.le.900) call getpfx2(k,c2)
|
||||
|
||||
i=index(c1,char(0))
|
||||
if(i.ge.3) c1=c1(1:i-1)//' '
|
||||
i=index(c2,char(0))
|
||||
if(i.ge.3) c2=c2(1:i-1)//' '
|
||||
|
||||
msg=' '
|
||||
j=0
|
||||
if(cqnnn) then
|
||||
msg=c1//' '
|
||||
j=7 !### ??? ###
|
||||
go to 10
|
||||
endif
|
||||
|
||||
do i=1,12
|
||||
j=j+1
|
||||
msg(j:j)=c1(i:i)
|
||||
if(c1(i:i).eq.' ') go to 10
|
||||
enddo
|
||||
j=j+1
|
||||
msg(j:j)=' '
|
||||
|
||||
10 do i=1,12
|
||||
if(j.le.21) j=j+1
|
||||
msg(j:j)=c2(i:i)
|
||||
if(c2(i:i).eq.' ') go to 20
|
||||
enddo
|
||||
if(j.le.21) j=j+1
|
||||
msg(j:j)=' '
|
||||
|
||||
20 if(k.eq.0) then
|
||||
do i=1,4
|
||||
if(j.le.21) j=j+1
|
||||
msg(j:j)=grid(i:i)
|
||||
enddo
|
||||
if(j.le.21) j=j+1
|
||||
msg(j:j)=' '
|
||||
endif
|
||||
|
||||
100 return
|
||||
end
|
||||
100
libm65/unpackmsg.f90
Normal file
100
libm65/unpackmsg.f90
Normal file
@ -0,0 +1,100 @@
|
||||
subroutine unpackmsg(dat,msg)
|
||||
|
||||
parameter (NBASE=37*36*10*27*27*27)
|
||||
parameter (NGBASE=180*180)
|
||||
integer dat(12)
|
||||
character c1*12,c2*12,grid*4,msg*22,grid6*6,psfx*4,junk2*4
|
||||
logical cqnnn
|
||||
|
||||
cqnnn=.false.
|
||||
nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10) + &
|
||||
ishft(dat(4),4) + iand(ishft(dat(5),-2),15)
|
||||
|
||||
nc2=ishft(iand(dat(5),3),26) + ishft(dat(6),20) + &
|
||||
ishft(dat(7),14) + ishft(dat(8),8) + ishft(dat(9),2) + &
|
||||
iand(ishft(dat(10),-4),3)
|
||||
|
||||
ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12)
|
||||
|
||||
if(ng.ge.32768) then
|
||||
call unpacktext(nc1,nc2,ng,msg)
|
||||
go to 100
|
||||
endif
|
||||
|
||||
call unpackcall(nc1,c1,iv2,psfx)
|
||||
if(iv2.eq.0) then
|
||||
! This is an "original JT65" message
|
||||
if(nc1.eq.NBASE+1) c1='CQ '
|
||||
if(nc1.eq.NBASE+2) c1='QRZ '
|
||||
nfreq=nc1-NBASE-3
|
||||
if(nfreq.ge.0 .and. nfreq.le.999) then
|
||||
write(c1,1002) nfreq
|
||||
1002 format('CQ ',i3.3)
|
||||
cqnnn=.true.
|
||||
endif
|
||||
endif
|
||||
|
||||
call unpackcall(nc2,c2,junk1,junk2)
|
||||
call unpackgrid(ng,grid)
|
||||
|
||||
if(iv2.gt.0) then
|
||||
! This is a JT65v2 message
|
||||
n1=len_trim(psfx)
|
||||
n2=len_trim(c2)
|
||||
if(iv2.eq.1) msg='CQ '//psfx(:n1)//'/'//c2(:n2)//' '//grid
|
||||
if(iv2.eq.2) msg='QRZ '//psfx(:n1)//'/'//c2(:n2)//' '//grid
|
||||
if(iv2.eq.3) msg='DE '//psfx(:n1)//'/'//c2(:n2)//' '//grid
|
||||
if(iv2.eq.4) msg='CQ '//c2(:n2)//'/'//psfx(:n1)//' '//grid
|
||||
if(iv2.eq.5) msg='QRZ '//c2(:n2)//'/'//psfx(:n1)//' '//grid
|
||||
if(iv2.eq.6) msg='DE '//c2(:n2)//'/'//psfx(:n1)//' '//grid
|
||||
if(iv2.eq.7) msg='DE '//c2(:n2)//' '//grid
|
||||
go to 100
|
||||
else
|
||||
|
||||
endif
|
||||
|
||||
grid6=grid//'ma'
|
||||
call grid2k(grid6,k)
|
||||
if(k.ge.1 .and. k.le.450) call getpfx2(k,c1)
|
||||
if(k.ge.451 .and. k.le.900) call getpfx2(k,c2)
|
||||
|
||||
i=index(c1,char(0))
|
||||
if(i.ge.3) c1=c1(1:i-1)//' '
|
||||
i=index(c2,char(0))
|
||||
if(i.ge.3) c2=c2(1:i-1)//' '
|
||||
|
||||
msg=' '
|
||||
j=0
|
||||
if(cqnnn) then
|
||||
msg=c1//' '
|
||||
j=7 !### ??? ###
|
||||
go to 10
|
||||
endif
|
||||
|
||||
do i=1,12
|
||||
j=j+1
|
||||
msg(j:j)=c1(i:i)
|
||||
if(c1(i:i).eq.' ') go to 10
|
||||
enddo
|
||||
j=j+1
|
||||
msg(j:j)=' '
|
||||
|
||||
10 do i=1,12
|
||||
if(j.le.21) j=j+1
|
||||
msg(j:j)=c2(i:i)
|
||||
if(c2(i:i).eq.' ') go to 20
|
||||
enddo
|
||||
if(j.le.21) j=j+1
|
||||
msg(j:j)=' '
|
||||
|
||||
20 if(k.eq.0) then
|
||||
do i=1,4
|
||||
if(j.le.21) j=j+1
|
||||
msg(j:j)=grid(i:i)
|
||||
enddo
|
||||
if(j.le.21) j=j+1
|
||||
msg(j:j)=' '
|
||||
endif
|
||||
|
||||
100 return
|
||||
end subroutine unpackmsg
|
||||
@ -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
|
||||
|
||||
|
||||
33
libm65/unpacktext.f90
Normal file
33
libm65/unpacktext.f90
Normal file
@ -0,0 +1,33 @@
|
||||
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
|
||||
Loading…
Reference in New Issue
Block a user