w4kek/WSJT-X
1
0
Fork 0
mirror of https://github.com/saitohirga/WSJT-X.git synced 2025-02-03 09:44:24 -05:00
Code Issues Packages Projects Releases Wiki Activity

First good compile with map65a running inside map65.

Browse Source 
git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/map65@334 ab8295b8-cf94-4d9e-aec4-7959e3be5d79
This commit is contained in:
Joe Taylor 2007-01-11 21:25:52 +00:00
parent bc06bc211e
commit c43bfde2ed
94 changed files with 6836 additions and 6104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

204
GeoDist.f
View File

@ -1,102 +1,102 @@
subroutine geodist(Eplat, Eplon, Stlat, Stlon,
+ Az, Baz, Dist)
implicit none
real eplat, eplon, stlat, stlon, az, baz, dist
C JHT: In actual fact, I use the first two arguments for "My Location",
C the second two for "His location"; West longitude is positive.
c
c
c Taken directly from:
c Thomas, P.D., 1970, Spheroidal geodesics, reference systems,
c & local geometry, U.S. Naval Oceanographic Office SP-138,
c 165 pp.
c
c assumes North Latitude and East Longitude are positive
c
c EpLat, EpLon = End point Lat/Long
c Stlat, Stlon = Start point lat/long
c Az, BAz = direct & reverse azimuith
c Dist = Dist (km); Deg = central angle, discarded
c
real BOA, F, P1R, P2R, L1R, L2R, DLR, T1R, T2R, TM,
+ DTM, STM, CTM, SDTM,CDTM, KL, KK, SDLMR, L,
+ CD, DL, SD, T, U, V, D, X, E, Y, A, FF64, TDLPM,
+ HAPBR, HAMBR, A1M2, A2M1
real AL,BL,D2R,Pi2
data AL/6378206.4/ ! Clarke 1866 ellipsoid
data BL/6356583.8/
c real pi /3.14159265359/
data D2R/0.01745329251994/ ! degrees to radians conversion factor
data Pi2/6.28318530718/
BOA = BL/AL
F = 1.0 - BOA
c convert st/end pts to radians
P1R = Eplat * D2R
P2R = Stlat * D2R
L1R = Eplon * D2R
L2R = StLon * D2R
DLR = L2R - L1R ! DLR = Delta Long in Rads
T1R = ATan(BOA * Tan(P1R))
T2R = ATan(BOA * Tan(P2R))
TM = (T1R + T2R) / 2.0
DTM = (T2R - T1R) / 2.0
STM = Sin(TM)
CTM = Cos(TM)
SDTM = Sin(DTM)
CDTM = Cos(DTM)
KL = STM * CDTM
KK = SDTM * CTM
SDLMR = Sin(DLR/2.0)
L = SDTM * SDTM + SDLMR * SDLMR * (CDTM * CDTM - STM * STM)
CD = 1.0 - 2.0 * L
DL = ACos(CD)
SD = Sin(DL)
T = DL/SD
U = 2.0 * KL * KL / (1.0 - L)
V = 2.0 * KK * KK / L
D = 4.0 * T * T
X = U + V
E = -2.0 * CD
Y = U - V
A = -D * E
FF64 = F * F / 64.0
Dist = AL*SD*(T -(F/4.0)*(T*X-Y)+FF64*(X*(A+(T-(A+E)
+ /2.0)*X)+Y*(-2.0*D+E*Y)+D*X*Y))/1000.0
TDLPM = Tan((DLR+(-((E*(4.0-X)+2.0*Y)*((F/2.0)*T+FF64*
+ (32.0*T+(A-20.0*T)*X-2.0*(D+2.0)*Y))/4.0)*Tan(DLR)))/2.0)
HAPBR = ATan2(SDTM,(CTM*TDLPM))
HAMBR = Atan2(CDTM,(STM*TDLPM))
A1M2 = Pi2 + HAMBR - HAPBR
A2M1 = Pi2 - HAMBR - HAPBR
1 If ((A1M2 .ge. 0.0) .AND. (A1M2 .lt. Pi2)) GOTO 5
If (A1M2 .lt. Pi2) GOTO 4
A1M2 = A1M2 - Pi2
GOTO 1
4 A1M2 = A1M2 + Pi2
GOTO 1
c
c all of this gens the proper az, baz (forward and back azimuth)
c
5 If ((A2M1 .ge. 0.0) .AND. (A2M1 .lt. Pi2)) GOTO 9
If (A2M1 .lt. Pi2) GOTO 8
A2M1 = A2M1 - Pi2
GOTO 5
8 A2M1 = A2M1 + Pi2
GOTO 5
9 Az = A1M2 / D2R
BAZ = A2M1 / D2R
c
c Fix the mirrored coords here.
c
az = 360.0 - az
baz = 360.0 - baz
end
subroutine geodist(Eplat, Eplon, Stlat, Stlon,
+ Az, Baz, Dist)
implicit none
real eplat, eplon, stlat, stlon, az, baz, dist
C JHT: In actual fact, I use the first two arguments for "My Location",
C the second two for "His location"; West longitude is positive.
c
c
c Taken directly from:
c Thomas, P.D., 1970, Spheroidal geodesics, reference systems,
c & local geometry, U.S. Naval Oceanographic Office SP-138,
c 165 pp.
c
c assumes North Latitude and East Longitude are positive
c
c EpLat, EpLon = End point Lat/Long
c Stlat, Stlon = Start point lat/long
c Az, BAz = direct & reverse azimuith
c Dist = Dist (km); Deg = central angle, discarded
c
real BOA, F, P1R, P2R, L1R, L2R, DLR, T1R, T2R, TM,
+ DTM, STM, CTM, SDTM,CDTM, KL, KK, SDLMR, L,
+ CD, DL, SD, T, U, V, D, X, E, Y, A, FF64, TDLPM,
+ HAPBR, HAMBR, A1M2, A2M1
real AL,BL,D2R,Pi2
data AL/6378206.4/ ! Clarke 1866 ellipsoid
data BL/6356583.8/
c real pi /3.14159265359/
data D2R/0.01745329251994/ ! degrees to radians conversion factor
data Pi2/6.28318530718/
BOA = BL/AL
F = 1.0 - BOA
c convert st/end pts to radians
P1R = Eplat * D2R
P2R = Stlat * D2R
L1R = Eplon * D2R
L2R = StLon * D2R
DLR = L2R - L1R ! DLR = Delta Long in Rads
T1R = ATan(BOA * Tan(P1R))
T2R = ATan(BOA * Tan(P2R))
TM = (T1R + T2R) / 2.0
DTM = (T2R - T1R) / 2.0
STM = Sin(TM)
CTM = Cos(TM)
SDTM = Sin(DTM)
CDTM = Cos(DTM)
KL = STM * CDTM
KK = SDTM * CTM
SDLMR = Sin(DLR/2.0)
L = SDTM * SDTM + SDLMR * SDLMR * (CDTM * CDTM - STM * STM)
CD = 1.0 - 2.0 * L
DL = ACos(CD)
SD = Sin(DL)
T = DL/SD
U = 2.0 * KL * KL / (1.0 - L)
V = 2.0 * KK * KK / L
D = 4.0 * T * T
X = U + V
E = -2.0 * CD
Y = U - V
A = -D * E
FF64 = F * F / 64.0
Dist = AL*SD*(T -(F/4.0)*(T*X-Y)+FF64*(X*(A+(T-(A+E)
+ /2.0)*X)+Y*(-2.0*D+E*Y)+D*X*Y))/1000.0
TDLPM = Tan((DLR+(-((E*(4.0-X)+2.0*Y)*((F/2.0)*T+FF64*
+ (32.0*T+(A-20.0*T)*X-2.0*(D+2.0)*Y))/4.0)*Tan(DLR)))/2.0)
HAPBR = ATan2(SDTM,(CTM*TDLPM))
HAMBR = Atan2(CDTM,(STM*TDLPM))
A1M2 = Pi2 + HAMBR - HAPBR
A2M1 = Pi2 - HAMBR - HAPBR
1 If ((A1M2 .ge. 0.0) .AND. (A1M2 .lt. Pi2)) GOTO 5
If (A1M2 .lt. Pi2) GOTO 4
A1M2 = A1M2 - Pi2
GOTO 1
4 A1M2 = A1M2 + Pi2
GOTO 1
c
c all of this gens the proper az, baz (forward and back azimuth)
c
5 If ((A2M1 .ge. 0.0) .AND. (A2M1 .lt. Pi2)) GOTO 9
If (A2M1 .lt. Pi2) GOTO 8
A2M1 = A2M1 - Pi2
GOTO 5
8 A2M1 = A2M1 + Pi2
GOTO 5
9 Az = A1M2 / D2R
BAZ = A2M1 / D2R
c
c Fix the mirrored coords here.
c
az = 360.0 - az
baz = 360.0 - baz
end

170
MoonDop.f
View File

@ -1,85 +1,85 @@
subroutine MoonDop(nyear,month,nday,uth4,lon4,lat4,RAMoon4,
+ DecMoon4,LST4,HA4,AzMoon4,ElMoon4,ldeg4,bdeg4,vr4,dist4)
implicit real*8 (a-h,o-z)
real*4 uth4 !UT in hours
real*4 lon4 !West longitude, degrees
real*4 lat4 !Latitude, degrees
real*4 RAMoon4 !Topocentric RA of moon, hours
real*4 DecMoon4 !Topocentric Dec of Moon, degrees
real*4 LST4 !Locat sidereal time, hours
real*4 HA4 !Local Hour angle, degrees
real*4 AzMoon4 !Topocentric Azimuth of moon, degrees
real*4 ElMoon4 !Topocentric Elevation of moon, degrees
real*4 ldeg4 !Galactic longitude of moon, degrees
real*4 bdeg4 !Galactic latitude of moon, degrees
real*4 vr4 !Radial velocity of moon wrt obs, km/s
real*4 dist4 !Echo time, seconds
real*8 LST
real*8 RME(6) !Vector from Earth center to Moon
real*8 RAE(6) !Vector from Earth center to Obs
real*8 RMA(6) !Vector from Obs to Moon
real*8 pvsun(6)
real*8 rme0(6)
real*8 lrad
logical km,bary
common/stcomx/km,bary,pvsun
data rad/57.2957795130823d0/,twopi/6.28310530717959d0/
pi=0.5d0*twopi
km=.true.
dlat=lat4/rad
dlong1=lon4/rad
elev1=200.d0
call geocentric(dlat,elev1,dlat1,erad1)
dt=100.d0 !For numerical derivative, in seconds
UT=uth4
C NB: geodetic latitude used here, but geocentric latitude used when
C determining Earth-rotation contribution to Doppler.
call moon2(nyear,month,nDay,UT-dt/3600.d0,dlong1*rad,dlat*rad,
+ RA,Dec,topRA,topDec,LST,HA,Az0,El0,dist)
call toxyz(RA/rad,Dec/rad,dist,rme0) !Convert to rectangular coords
call moon2(nyear,month,nDay,UT,dlong1*rad,dlat*rad,
+ RA,Dec,topRA,topDec,LST,HA,Az,El,dist)
call toxyz(RA/rad,Dec/rad,dist,rme) !Convert to rectangular coords
phi=LST*twopi/24.d0
call toxyz(phi,dlat1,erad1,rae) !Gencentric numbers used here!
radps=twopi/(86400.d0/1.002737909d0)
rae(4)=-rae(2)*radps !Vel of Obs wrt Earth center
rae(5)=rae(1)*radps
rae(6)=0.d0
do i=1,3
rme(i+3)=(rme(i)-rme0(i))/dt
rma(i)=rme(i)-rae(i)
rma(i+3)=rme(i+3)-rae(i+3)
enddo
call fromxyz(rma,alpha1,delta1,dtopo0) !Get topocentric coords
vr=dot(rma(4),rma)/dtopo0
rarad=RA/rad
decrad=Dec/rad
call dcoord(4.635594495d0,-0.504691042d0,3.355395488d0,
+ 0.478220215d0,rarad,decrad,lrad,brad)
RAMoon4=topRA
DecMoon4=topDec
LST4=LST
HA4=HA
AzMoon4=Az
ElMoon4=El
ldeg4=lrad*rad
bdeg4=brad*rad
vr4=vr
dist4=dist
return
end
subroutine MoonDop(nyear,month,nday,uth4,lon4,lat4,RAMoon4,
+ DecMoon4,LST4,HA4,AzMoon4,ElMoon4,ldeg4,bdeg4,vr4,dist4)
implicit real*8 (a-h,o-z)
real*4 uth4 !UT in hours
real*4 lon4 !West longitude, degrees
real*4 lat4 !Latitude, degrees
real*4 RAMoon4 !Topocentric RA of moon, hours
real*4 DecMoon4 !Topocentric Dec of Moon, degrees
real*4 LST4 !Locat sidereal time, hours
real*4 HA4 !Local Hour angle, degrees
real*4 AzMoon4 !Topocentric Azimuth of moon, degrees
real*4 ElMoon4 !Topocentric Elevation of moon, degrees
real*4 ldeg4 !Galactic longitude of moon, degrees
real*4 bdeg4 !Galactic latitude of moon, degrees
real*4 vr4 !Radial velocity of moon wrt obs, km/s
real*4 dist4 !Echo time, seconds
real*8 LST
real*8 RME(6) !Vector from Earth center to Moon
real*8 RAE(6) !Vector from Earth center to Obs
real*8 RMA(6) !Vector from Obs to Moon
real*8 pvsun(6)
real*8 rme0(6)
real*8 lrad
logical km,bary
common/stcomx/km,bary,pvsun
data rad/57.2957795130823d0/,twopi/6.28310530717959d0/
pi=0.5d0*twopi
km=.true.
dlat=lat4/rad
dlong1=lon4/rad
elev1=200.d0
call geocentric(dlat,elev1,dlat1,erad1)
dt=100.d0 !For numerical derivative, in seconds
UT=uth4
C NB: geodetic latitude used here, but geocentric latitude used when
C determining Earth-rotation contribution to Doppler.
call moon2(nyear,month,nDay,UT-dt/3600.d0,dlong1*rad,dlat*rad,
+ RA,Dec,topRA,topDec,LST,HA,Az0,El0,dist)
call toxyz(RA/rad,Dec/rad,dist,rme0) !Convert to rectangular coords
call moon2(nyear,month,nDay,UT,dlong1*rad,dlat*rad,
+ RA,Dec,topRA,topDec,LST,HA,Az,El,dist)
call toxyz(RA/rad,Dec/rad,dist,rme) !Convert to rectangular coords
phi=LST*twopi/24.d0
call toxyz(phi,dlat1,erad1,rae) !Gencentric numbers used here!
radps=twopi/(86400.d0/1.002737909d0)
rae(4)=-rae(2)*radps !Vel of Obs wrt Earth center
rae(5)=rae(1)*radps
rae(6)=0.d0
do i=1,3
rme(i+3)=(rme(i)-rme0(i))/dt
rma(i)=rme(i)-rae(i)
rma(i+3)=rme(i+3)-rae(i+3)
enddo
call fromxyz(rma,alpha1,delta1,dtopo0) !Get topocentric coords
vr=dot(rma(4),rma)/dtopo0
rarad=RA/rad
decrad=Dec/rad
call dcoord(4.635594495d0,-0.504691042d0,3.355395488d0,
+ 0.478220215d0,rarad,decrad,lrad,brad)
RAMoon4=topRA
DecMoon4=topDec
LST4=LST
HA4=HA
AzMoon4=Az
ElMoon4=El
ldeg4=lrad*rad
bdeg4=brad*rad
vr4=vr
dist4=dist
return
end

154
afc65.f
View File

@ -1,77 +1,77 @@
subroutine afc65(s2,ipk,lagpk,flip,ftrack)
real s2(1024,320)
real s(-10:10)
real x(63),y(63),z(63)
real ftrack(126)
include 'prcom.h'
data s/21*0.0/
k=0
u=1.0
u1=0.2
fac=sqrt(1.0/u1)
do j=1,126
if(pr(j)*flip .lt. 0.0) go to 10
k=k+1
m=2*j-1+lagpk
if(m.lt.1 .or. m.gt.320) go to 10
smax=0.
do i=-10,10
s(i)=(1.0-u)*s(i) + u*s2(ipk+i,m)
if(s(i).gt.smax) then
smax=s(i)
ipk2=i
endif
enddo
u=u1
dfx=0.0
sig=100.0*fac*smax
if(ipk2.gt.-10 .and. ipk2.lt.10 .and. (sig.gt.2.0))
+ call peakup(s(ipk2-1),s(ipk2),s(ipk2+1),dfx)
dfx=ipk2+dfx
x(k)=j
y(k)=dfx
z(k)=sig
if(z(k).lt.1.5 .or. abs(y(k)).gt.5.5) then
y(k)=0.
z(k)=0.
endif
10 enddo
zlim=5.0
yfit=0.
k=0
do j=1,126
if(pr(j)*flip .lt. 0.0) go to 30
k=k+1
sumy=0.
sumz=0.
if(k.ge.1) then
sumz=z(k)
sumy=sumy+z(k)*y(k)
endif
do n=1,30
m=k-n
if(m.ge.1) then
sumz=sumz+z(m)
sumy=sumy+z(m)*y(m)
endif
m=k+n
if(m.le.63) then
sumz=sumz+z(m)
sumy=sumy+z(m)*y(m)
endif
if(sumz.ge.zlim) go to 20
enddo
n=30
20 yfit=0.
if(sumz.gt.0.0) yfit=sumy/sumz
30 ftrack(j)=yfit*2.691650
enddo
if(ftrack(1).eq.99.0) ftrack(1)=ftrack(2)
return
end
subroutine afc65(s2,ipk,lagpk,flip,ftrack)
real s2(1024,320)
real s(-10:10)
real x(63),y(63),z(63)
real ftrack(126)
include 'prcom.h'
data s/21*0.0/
k=0
u=1.0
u1=0.2
fac=sqrt(1.0/u1)
do j=1,126
if(pr(j)*flip .lt. 0.0) go to 10
k=k+1
m=2*j-1+lagpk
if(m.lt.1 .or. m.gt.320) go to 10
smax=0.
do i=-10,10
s(i)=(1.0-u)*s(i) + u*s2(ipk+i,m)
if(s(i).gt.smax) then
smax=s(i)
ipk2=i
endif
enddo
u=u1
dfx=0.0
sig=100.0*fac*smax
if(ipk2.gt.-10 .and. ipk2.lt.10 .and. (sig.gt.2.0))
+ call peakup(s(ipk2-1),s(ipk2),s(ipk2+1),dfx)
dfx=ipk2+dfx
x(k)=j
y(k)=dfx
z(k)=sig
if(z(k).lt.1.5 .or. abs(y(k)).gt.5.5) then
y(k)=0.
z(k)=0.
endif
10 enddo
zlim=5.0
yfit=0.
k=0
do j=1,126
if(pr(j)*flip .lt. 0.0) go to 30
k=k+1
sumy=0.
sumz=0.
if(k.ge.1) then
sumz=z(k)
sumy=sumy+z(k)*y(k)
endif
do n=1,30
m=k-n
if(m.ge.1) then
sumz=sumz+z(m)
sumy=sumy+z(m)*y(m)
endif
m=k+n
if(m.le.63) then
sumz=sumz+z(m)
sumy=sumy+z(m)*y(m)
endif
if(sumz.ge.zlim) go to 20
enddo
n=30
20 yfit=0.
if(sumz.gt.0.0) yfit=sumy/sumz
30 ftrack(j)=yfit*2.691650
enddo
if(ftrack(1).eq.99.0) ftrack(1)=ftrack(2)
return
end

28
astropak.f
View File

@ -1,14 +1,14 @@
! include 'astro.f'
include 'azdist.f'
include 'coord.f'
include 'dcoord.f'
include 'deg2grid.f'
include 'dot.f'
include 'ftsky.f'
include 'geocentric.f'
include 'GeoDist.f'
include 'grid2deg.f'
include 'moon2.f'
include 'MoonDop.f'
include 'sun.f'
include 'toxyz.f'
! include 'astro.f'
include 'azdist.f'
include 'coord.f'
include 'dcoord.f'
include 'deg2grid.f'
include 'dot.f'
include 'ftsky.f'
include 'geocentric.f'
include 'GeoDist.f'
include 'grid2deg.f'
include 'moon2.f'
include 'MoonDop.f'
include 'sun.f'
include 'toxyz.f'

8
avecom.h
View File

@ -1,4 +1,4 @@
parameter (MAXAVE=120)
common/ave/ppsave(64,63,MAXAVE),nflag(MAXAVE),nsave,
+ iseg(MAXAVE)
parameter (MAXAVE=120)
common/ave/ppsave(64,63,MAXAVE),nflag(MAXAVE),nsave,
+ iseg(MAXAVE)

216
azdist.f
View File

@ -1,108 +1,108 @@
subroutine azdist(MyGrid,HisGrid,utch,nAz,nEl,nDmiles,nDkm,
+ nHotAz,nHotABetter)
C Old calling sequence:
c subroutine azdist(MyGrid,HisGrid,UTChours,Az,Dmiles,Dkm,El,
c + HotA,HotB,HotABetter)
character*6 MyGrid,HisGrid,mygrid0,hisgrid0
real*8 utch,utch0
logical HotABetter,IamEast
real eltab(22),daztab(22)
data eltab/18.,15.,13.,11.,9.,8.,7.,6.,5.3,4.7,4.,3.3,2.7,
+ 2.,1.5,1.,0.8,0.6,0.4,0.2,0.0,0.0/
data daztab/21.,18.,16.,15.,14.,13.,12.,11.,10.7,10.3,10.,
+ 10.,10.,10.,10.,10.,10.,9.,9.,9.,8.,8./
data mygrid0/" "/,hisgrid0/" "/,utch0/-999.d0/
save
if(MyGrid.eq.HisGrid) then
naz=0
nel=0
ndmiles=0
ndkm=0
nhotaz=0
nhotabetter=1
go to 999
endif
if(mygrid.eq.mygrid0 .and. hisgrid.eq.hisgrid0 .and.
+ abs(utch-utch0).lt.0.1666667d0) go to 900
utch0=utch
mygrid0=mygrid
hisgrid0=hisgrid
utchours=utch
if(MyGrid(5:5).eq.' ') MyGrid(5:5)='m'
if(MyGrid(6:6).eq.' ') MyGrid(6:6)='m'
if(HisGrid(5:5).eq.' ') HisGrid(5:5)='m'
if(HisGrid(6:6).eq.' ') HisGrid(6:6)='m'
if(MyGrid.eq.HisGrid) then
Az=0.
Dmiles=0.
Dkm=0.0
El=0.
HotA=0.
HotB=0.
HotABetter=.true.
go to 900
endif
call grid2deg(MyGrid,dlong1,dlat1)
call grid2deg(HisGrid,dlong2,dlat2)
call geodist(dlat1,dlong1,dlat2,dlong2,Az,Baz,Dkm)
j=nint(Dkm/100.0)-4
if(j.lt.1) j=1
if(j.gt.21)j=21
ndkm=Dkm/100
d1=100.0*ndkm
u=(Dkm-d1)/100.0
El=eltab(j) + u * (eltab(j+1)-eltab(j))
daz=daztab(j) + u * (daztab(j+1)-daztab(j))
Dmiles=Dkm/1.609344
tmid=mod(UTChours-0.5*(dlong1+dlong2)/15.0+48.0,24.0)
IamEast=.false.
if(dlong1.lt.dlong2) IamEast=.true.
if(dlong1.eq.dlong2 .and. dlat1.gt.dlat2) IamEast=.false.
azEast=baz
if(IamEast) azEast=az
if((azEast.ge.45.0 .and. azEast.lt.135.0) .or.
+ (azEast.ge.225.0 .and. azEast.lt.315.0)) then
C The path will be taken as "east-west".
HotABetter=.true.
if(abs(tmid-6.0).lt.6.0) HotABetter=.false.
if((dlat1+dlat2)/2.0 .lt. 0.0) HotABetter=.not.HotABetter
else
C The path will be taken as "north-south".
HotABetter=.false.
if(abs(tmid-12.0).lt.6.0) HotABetter=.true.
endif
if(IamEast) then
HotA = Az - daz
HotB = Az + daz
else
HotA = Az + daz
HotB = Az - daz
endif
if(HotA.lt.0.0) HotA=HotA+360.0
if(HotA.gt.360.0) HotA=HotA-360.0
if(HotB.lt.0.0) HotB=HotB+360.0
if(HotB.gt.360.0) HotB=HotB-360.0
900 continue
naz=nint(Az)
nel=nint(el)
nDmiles=nint(Dmiles)
nDkm=nint(Dkm)
nHotAz=nint(HotB)
nHotABetter=0
if(HotABetter) then
nHotAz=nint(HotA)
nHotABetter=1
endif
999 return
end
subroutine azdist(MyGrid,HisGrid,utch,nAz,nEl,nDmiles,nDkm,
+ nHotAz,nHotABetter)
C Old calling sequence:
c subroutine azdist(MyGrid,HisGrid,UTChours,Az,Dmiles,Dkm,El,
c + HotA,HotB,HotABetter)
character*6 MyGrid,HisGrid,mygrid0,hisgrid0
real*8 utch,utch0
logical HotABetter,IamEast
real eltab(22),daztab(22)
data eltab/18.,15.,13.,11.,9.,8.,7.,6.,5.3,4.7,4.,3.3,2.7,
+ 2.,1.5,1.,0.8,0.6,0.4,0.2,0.0,0.0/
data daztab/21.,18.,16.,15.,14.,13.,12.,11.,10.7,10.3,10.,
+ 10.,10.,10.,10.,10.,10.,9.,9.,9.,8.,8./
data mygrid0/" "/,hisgrid0/" "/,utch0/-999.d0/
save
if(MyGrid.eq.HisGrid) then
naz=0
nel=0
ndmiles=0
ndkm=0
nhotaz=0
nhotabetter=1
go to 999
endif
if(mygrid.eq.mygrid0 .and. hisgrid.eq.hisgrid0 .and.
+ abs(utch-utch0).lt.0.1666667d0) go to 900
utch0=utch
mygrid0=mygrid
hisgrid0=hisgrid
utchours=utch
if(MyGrid(5:5).eq.' ') MyGrid(5:5)='m'
if(MyGrid(6:6).eq.' ') MyGrid(6:6)='m'
if(HisGrid(5:5).eq.' ') HisGrid(5:5)='m'
if(HisGrid(6:6).eq.' ') HisGrid(6:6)='m'
if(MyGrid.eq.HisGrid) then
Az=0.
Dmiles=0.
Dkm=0.0
El=0.
HotA=0.
HotB=0.
HotABetter=.true.
go to 900
endif
call grid2deg(MyGrid,dlong1,dlat1)
call grid2deg(HisGrid,dlong2,dlat2)
call geodist(dlat1,dlong1,dlat2,dlong2,Az,Baz,Dkm)
j=nint(Dkm/100.0)-4
if(j.lt.1) j=1
if(j.gt.21)j=21
ndkm=Dkm/100
d1=100.0*ndkm
u=(Dkm-d1)/100.0
El=eltab(j) + u * (eltab(j+1)-eltab(j))
daz=daztab(j) + u * (daztab(j+1)-daztab(j))
Dmiles=Dkm/1.609344
tmid=mod(UTChours-0.5*(dlong1+dlong2)/15.0+48.0,24.0)
IamEast=.false.
if(dlong1.lt.dlong2) IamEast=.true.
if(dlong1.eq.dlong2 .and. dlat1.gt.dlat2) IamEast=.false.
azEast=baz
if(IamEast) azEast=az
if((azEast.ge.45.0 .and. azEast.lt.135.0) .or.
+ (azEast.ge.225.0 .and. azEast.lt.315.0)) then
C The path will be taken as "east-west".
HotABetter=.true.
if(abs(tmid-6.0).lt.6.0) HotABetter=.false.
if((dlat1+dlat2)/2.0 .lt. 0.0) HotABetter=.not.HotABetter
else
C The path will be taken as "north-south".
HotABetter=.false.
if(abs(tmid-12.0).lt.6.0) HotABetter=.true.
endif
if(IamEast) then
HotA = Az - daz
HotB = Az + daz
else
HotA = Az + daz
HotB = Az - daz
endif
if(HotA.lt.0.0) HotA=HotA+360.0
if(HotA.gt.360.0) HotA=HotA-360.0
if(HotB.lt.0.0) HotB=HotB+360.0
if(HotB.gt.360.0) HotB=HotB-360.0
900 continue
naz=nint(Az)
nel=nint(el)
nDmiles=nint(Dmiles)
nDkm=nint(Dkm)
nHotAz=nint(HotB)
nHotABetter=0
if(HotABetter) then
nHotAz=nint(HotA)
nHotABetter=1
endif
999 return
end

134
bzap.f
View File

@ -1,67 +1,67 @@
subroutine bzap(dat,jz,nadd,mode,fzap)
parameter (NMAX=1024*1024)
parameter (NMAXH=NMAX)
real dat(jz),x(NMAX)
real fzap(200)
complex c(NMAX)
equivalence (x,c)
xn=log(float(jz))/log(2.0)
n=xn
if((xn-n).gt.0.) n=n+1
nfft=2**n
nh=nfft/nadd
nq=nh/2
do i=1,jz
x(i)=dat(i)
enddo
if(nfft.gt.jz) call zero(x(jz+1),nfft-jz)
call xfft(x,nfft)
C This is a kludge:
df=11025.0/(nadd*nfft)
if(mode.eq.2) df=11025.0/(2*nadd*nfft)
tol=10.
itol=nint(2.0/df)
do izap=1,200
if(fzap(izap).eq.0.0) goto 10
ia=(fzap(izap)-tol)/df
ib=(fzap(izap)+tol)/df
smax=0.
do i=ia+1,ib+1
s=real(c(i))**2 + aimag(c(i))**2
if(s.gt.smax) then
smax=s
ipk=i
endif
enddo
fzap(izap)=df*(ipk-1)
do i=ipk-itol,ipk+itol
c(i)=0.
enddo
enddo
10 ia=70/df
do i=1,ia
c(i)=0.
enddo
ia=2700.0/df
do i=ia,nq+1
c(i)=0.
enddo
do i=2,nq
c(nh+2-i)=conjg(c(i))
enddo
call four2a(c,nh,1,1,-1)
fac=1.0/nfft
do i=1,jz/nadd
dat(i)=fac*x(i)
enddo
return
end
subroutine bzap(dat,jz,nadd,mode,fzap)
parameter (NMAX=1024*1024)
parameter (NMAXH=NMAX)
real dat(jz),x(NMAX)
real fzap(200)
complex c(NMAX)
equivalence (x,c)
xn=log(float(jz))/log(2.0)
n=xn
if((xn-n).gt.0.) n=n+1
nfft=2**n
nh=nfft/nadd
nq=nh/2
do i=1,jz
x(i)=dat(i)
enddo
if(nfft.gt.jz) call zero(x(jz+1),nfft-jz)
call xfft(x,nfft)
C This is a kludge:
df=11025.0/(nadd*nfft)
if(mode.eq.2) df=11025.0/(2*nadd*nfft)
tol=10.
itol=nint(2.0/df)
do izap=1,200
if(fzap(izap).eq.0.0) goto 10
ia=(fzap(izap)-tol)/df
ib=(fzap(izap)+tol)/df
smax=0.
do i=ia+1,ib+1
s=real(c(i))**2 + aimag(c(i))**2
if(s.gt.smax) then
smax=s
ipk=i
endif
enddo
fzap(izap)=df*(ipk-1)
do i=ipk-itol,ipk+itol
c(i)=0.
enddo
enddo
10 ia=70/df
do i=1,ia
c(i)=0.
enddo
ia=2700.0/df
do i=ia,nq+1
c(i)=0.
enddo
do i=2,nq
c(nh+2-i)=conjg(c(i))
enddo
call four2a(c,nh,1,1,-1)
fac=1.0/nfft
do i=1,jz/nadd
dat(i)=fac*x(i)
enddo
return
end

114
char.h
View File

@ -1,57 +1,57 @@
/* Include file to configure the RS codec for character symbols
*
* Copyright 2002, Phil Karn, KA9Q
* May be used under the terms of the GNU General Public License (GPL)
*/
#define DTYPE unsigned char
/* Reed-Solomon codec control block */
struct rs {
int mm; /* Bits per symbol */
int nn; /* Symbols per block (= (1<<mm)-1) */
DTYPE *alpha_to; /* log lookup table */
DTYPE *index_of; /* Antilog lookup table */
DTYPE *genpoly; /* Generator polynomial */
int nroots; /* Number of generator roots = number of parity symbols */
int fcr; /* First consecutive root, index form */
int prim; /* Primitive element, index form */
int iprim; /* prim-th root of 1, index form */
int pad; /* Padding bytes in shortened block */
};
static inline int modnn(struct rs *rs,int x){
while (x >= rs->nn) {
x -= rs->nn;
x = (x >> rs->mm) + (x & rs->nn);
}
return x;
}
#define MODNN(x) modnn(rs,x)
#define MM (rs->mm)
#define NN (rs->nn)
#define ALPHA_TO (rs->alpha_to)
#define INDEX_OF (rs->index_of)
#define GENPOLY (rs->genpoly)
#define NROOTS (rs->nroots)
#define FCR (rs->fcr)
#define PRIM (rs->prim)
#define IPRIM (rs->iprim)
#define PAD (rs->pad)
#define A0 (NN)
#define ENCODE_RS encode_rs_char
#define DECODE_RS decode_rs_char
#define INIT_RS init_rs_char
#define FREE_RS free_rs_char
void ENCODE_RS(void *p,DTYPE *data,DTYPE *parity);
int DECODE_RS(void *p,DTYPE *data,int *eras_pos,int no_eras);
void *INIT_RS(int symsize,int gfpoly,int fcr,
int prim,int nroots,int pad);
void FREE_RS(void *p);
/* Include file to configure the RS codec for character symbols
*
* Copyright 2002, Phil Karn, KA9Q
* May be used under the terms of the GNU General Public License (GPL)
*/
#define DTYPE unsigned char
/* Reed-Solomon codec control block */
struct rs {
int mm; /* Bits per symbol */
int nn; /* Symbols per block (= (1<<mm)-1) */
DTYPE *alpha_to; /* log lookup table */
DTYPE *index_of; /* Antilog lookup table */
DTYPE *genpoly; /* Generator polynomial */
int nroots; /* Number of generator roots = number of parity symbols */
int fcr; /* First consecutive root, index form */
int prim; /* Primitive element, index form */
int iprim; /* prim-th root of 1, index form */
int pad; /* Padding bytes in shortened block */
};
static inline int modnn(struct rs *rs,int x){
while (x >= rs->nn) {
x -= rs->nn;
x = (x >> rs->mm) + (x & rs->nn);
}
return x;
}
#define MODNN(x) modnn(rs,x)
#define MM (rs->mm)
#define NN (rs->nn)
#define ALPHA_TO (rs->alpha_to)
#define INDEX_OF (rs->index_of)
#define GENPOLY (rs->genpoly)
#define NROOTS (rs->nroots)
#define FCR (rs->fcr)
#define PRIM (rs->prim)
#define IPRIM (rs->iprim)
#define PAD (rs->pad)
#define A0 (NN)
#define ENCODE_RS encode_rs_char
#define DECODE_RS decode_rs_char
#define INIT_RS init_rs_char
#define FREE_RS free_rs_char
void ENCODE_RS(void *p,DTYPE *data,DTYPE *parity);
int DECODE_RS(void *p,DTYPE *data,int *eras_pos,int no_eras);
void *INIT_RS(int symsize,int gfpoly,int fcr,
int prim,int nroots,int pad);
void FREE_RS(void *p);

62
chkmsg.f
View File

@ -1,31 +1,31 @@
subroutine chkmsg(message,cok,nspecial,flip)
character message*22,cok*3
nspecial=0
flip=1.0
cok=" "
do i=22,1,-1
if(message(i:i).ne.' ') go to 10
enddo
i=22
10 if(i.ge.11 .and. (message(i-3:i).eq.' OOO') .or.
+ (message(20:22).eq.' OO')) then
cok='OOO'
flip=-1.0
if(message(20:22).eq.' OO') then
message=message(1:19)
else
message=message(1:i-4)
endif
endif
! if(message(1:3).eq.'ATT') nspecial=1
if(message(1:2).eq.'RO') nspecial=2
if(message(1:3).eq.'RRR') nspecial=3
if(message(1:2).eq.'73') nspecial=4
return
end
subroutine chkmsg(message,cok,nspecial,flip)
character message*22,cok*3
nspecial=0
flip=1.0
cok=" "
do i=22,1,-1
if(message(i:i).ne.' ') go to 10
enddo
i=22
10 if(i.ge.11 .and. (message(i-3:i).eq.' OOO') .or.
+ (message(20:22).eq.' OO')) then
cok='OOO'
flip=-1.0
if(message(20:22).eq.' OO') then
message=message(1:19)
else
message=message(1:i-4)
endif
endif
! if(message(1:3).eq.'ATT') nspecial=1
if(message(1:2).eq.'RO') nspecial=2
if(message(1:3).eq.'RRR') nspecial=3
if(message(1:2).eq.'73') nspecial=4
return
end

74
coord.f
View File

@ -1,37 +1,37 @@
SUBROUTINE COORD(A0,B0,AP,BP,A1,B1,A2,B2)
C Examples:
C 1. From ha,dec to az,el:
C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el)
C 2. From az,el to ha,dec:
C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec)
C 3. From ra,dec to l,b
C call coord(4.635594495,-0.504691042,3.355395488,0.478220215,
C ra,dec,l,b)
C 4. From l,b to ra,dec
C call coord(1.705981071d0,-1.050357016d0,2.146800277d0,
C 0.478220215d0,l,b,ra,dec)
C 5. From ecliptic latitude (eb) and longitude (el) to ra, dec:
C call coord(0.e0,0.e0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb)
SB0=sin(B0)
CB0=cos(B0)
SBP=sin(BP)
CBP=cos(BP)
SB1=sin(B1)
CB1=cos(B1)
SB2=SBP*SB1 + CBP*CB1*cos(AP-A1)
CB2=SQRT(1.e0-SB2**2)
B2=atan(SB2/CB2)
SAA=sin(AP-A1)*CB1/CB2
CAA=(SB1-SB2*SBP)/(CB2*CBP)
CBB=SB0/CBP
SBB=sin(AP-A0)*CB0
SA2=SAA*CBB-CAA*SBB
CA2=CAA*CBB+SAA*SBB
IF(CA2.LE.0.e0) TA2O2=(1.e0-CA2)/SA2
IF(CA2.GT.0.e0) TA2O2=SA2/(1.e0+CA2)
A2=2.e0*atan(TA2O2)
IF(A2.LT.0.e0) A2=A2+6.2831853
RETURN
END
SUBROUTINE COORD(A0,B0,AP,BP,A1,B1,A2,B2)
C Examples:
C 1. From ha,dec to az,el:
C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el)
C 2. From az,el to ha,dec:
C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec)
C 3. From ra,dec to l,b
C call coord(4.635594495,-0.504691042,3.355395488,0.478220215,
C ra,dec,l,b)
C 4. From l,b to ra,dec
C call coord(1.705981071d0,-1.050357016d0,2.146800277d0,
C 0.478220215d0,l,b,ra,dec)
C 5. From ecliptic latitude (eb) and longitude (el) to ra, dec:
C call coord(0.e0,0.e0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb)
SB0=sin(B0)
CB0=cos(B0)
SBP=sin(BP)
CBP=cos(BP)
SB1=sin(B1)
CB1=cos(B1)
SB2=SBP*SB1 + CBP*CB1*cos(AP-A1)
CB2=SQRT(1.e0-SB2**2)
B2=atan(SB2/CB2)
SAA=sin(AP-A1)*CB1/CB2
CAA=(SB1-SB2*SBP)/(CB2*CBP)
CBB=SB0/CBP
SBB=sin(AP-A0)*CB0
SA2=SAA*CBB-CAA*SBB
CA2=CAA*CBB+SAA*SBB
IF(CA2.LE.0.e0) TA2O2=(1.e0-CA2)/SA2
IF(CA2.GT.0.e0) TA2O2=SA2/(1.e0+CA2)
A2=2.e0*atan(TA2O2)
IF(A2.LT.0.e0) A2=A2+6.2831853
RETURN
END

10
db.f
View File

@ -1,5 +1,5 @@
real function db(x)
db=-99.0
if(x.gt.1.259e-10) db=10.0*log10(x)
return
end
real function db(x)
db=-99.0
if(x.gt.1.259e-10) db=10.0*log10(x)
return
end

78
dcoord.f
View File

@ -1,39 +1,39 @@
SUBROUTINE DCOORD(A0,B0,AP,BP,A1,B1,A2,B2)
implicit real*8 (a-h,o-z)
C Examples:
C 1. From ha,dec to az,el:
C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el)
C 2. From az,el to ha,dec:
C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec)
C 3. From ra,dec to l,b
C call coord(4.635594495,-0.504691042,3.355395488,0.478220215,
C ra,dec,l,b)
C 4. From l,b to ra,dec
C call coord(1.705981071d0,-1.050357016d0,2.146800277d0,
C 0.478220215d0,l,b,ra,dec)
C 5. From ecliptic latitude (eb) and longitude (el) to ra, dec:
C call coord(0.d0,0.d0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb)
SB0=sin(B0)
CB0=cos(B0)
SBP=sin(BP)
CBP=cos(BP)
SB1=sin(B1)
CB1=cos(B1)
SB2=SBP*SB1 + CBP*CB1*cos(AP-A1)
CB2=SQRT(1.D0-SB2**2)
B2=atan(SB2/CB2)
SAA=sin(AP-A1)*CB1/CB2
CAA=(SB1-SB2*SBP)/(CB2*CBP)
CBB=SB0/CBP
SBB=sin(AP-A0)*CB0
SA2=SAA*CBB-CAA*SBB
CA2=CAA*CBB+SAA*SBB
IF(CA2.LE.0.D0) TA2O2=(1.D0-CA2)/SA2
IF(CA2.GT.0.D0) TA2O2=SA2/(1.D0+CA2)
A2=2.D0*atan(TA2O2)
IF(A2.LT.0.D0) A2=A2+6.2831853071795864D0
RETURN
END
SUBROUTINE DCOORD(A0,B0,AP,BP,A1,B1,A2,B2)
implicit real*8 (a-h,o-z)
C Examples:
C 1. From ha,dec to az,el:
C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el)
C 2. From az,el to ha,dec:
C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec)
C 3. From ra,dec to l,b
C call coord(4.635594495,-0.504691042,3.355395488,0.478220215,
C ra,dec,l,b)
C 4. From l,b to ra,dec
C call coord(1.705981071d0,-1.050357016d0,2.146800277d0,
C 0.478220215d0,l,b,ra,dec)
C 5. From ecliptic latitude (eb) and longitude (el) to ra, dec:
C call coord(0.d0,0.d0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb)
SB0=sin(B0)
CB0=cos(B0)
SBP=sin(BP)
CBP=cos(BP)
SB1=sin(B1)
CB1=cos(B1)
SB2=SBP*SB1 + CBP*CB1*cos(AP-A1)
CB2=SQRT(1.D0-SB2**2)
B2=atan(SB2/CB2)
SAA=sin(AP-A1)*CB1/CB2
CAA=(SB1-SB2*SBP)/(CB2*CBP)
CBB=SB0/CBP
SBB=sin(AP-A0)*CB0
SA2=SAA*CBB-CAA*SBB
CA2=CAA*CBB+SAA*SBB
IF(CA2.LE.0.D0) TA2O2=(1.D0-CA2)/SA2
IF(CA2.GT.0.D0) TA2O2=SA2/(1.D0+CA2)
A2=2.D0*atan(TA2O2)
IF(A2.LT.0.D0) A2=A2+6.2831853071795864D0
RETURN
END

124
decode1a.f Normal file
View File

@ -0,0 +1,124 @@
subroutine decode1a(id,newdat,nfilt,freq,nflip,ipol,sync2,a,dt,
+ pol,nkv,nhist,qual,decoded)
C Apply AFC corrections to a candidate JT65 signal, and then try
C to decode it.
parameter (NFFT1=77760,NFFT2=2430)
parameter (NMAX=60*96000) !Samples per 60 s
integer*2 id(4,NMAX) !46 MB: raw data from Linrad timf2
complex c2x(NMAX/4), c2y(NMAX/4) !After 1/4 filter and downsample
complex c3x(NMAX/16),c3y(NMAX/16) !After 1/16 filter and downsample
complex c4x(NMAX/64),c4y(NMAX/64) !After 1/64 filter and downsample
complex cx(NMAX/64), cy(NMAX/64) !Data at 1378.125 samples/s
complex c5x(NMAX/256),c5y(NMAX/256)
complex c5a(256), c5b(256)
real s2(256,126)
real a(5)
real*8 samratio
integer resample
logical first
character decoded*22
data first/.true./,jjjmin/1000/,jjjmax/-1000/
save
C Mix sync tone to baseband, low-pass filter, and decimate by 64
dt00=dt
C If freq=125.0 kHz, f0=48000 Hz.
f0=1000*(freq-77.0) !Freq of sync tone (0-96000 Hz)
if(nfilt.eq.1) then
call filbig(id,NMAX,f0,newdat,cx,cy,n5)
joff=0
else
call fil659(id,NMAX,f0,c2x,c2y,n2) !Pass 1: mix and filter both pol'ns
call fil658(c2x,n2,c3x,n3) !Pass 2
call fil658(c2y,n2,c3y,n3)
call fil658(c3x,n3,c4x,n4) !Pass 3
call fil658(c3y,n3,c4y,n4)
joff=-8
C Resample from 96000/64 = 1500 Hz to 1378.125 Hz
C Converter type: 0=Best quality sinc (band limited), BW=97%
C 1=medium quality sinc, BW=90%
C 2=fastest sinc, BW=80%
C 3=stepwise (very fast)
C 4=linear (very fast)
nconv_type=2 !### test! ###
nchans=2
samratio=1378.125d0/1500.d0
i1=resample(c4x,n4,nconv_type,nchans,samratio,cx,n5)
i2=resample(c4y,n4,nconv_type,nchans,samratio,cy,n5)
endif
sqa=0.
sqb=0.
do i=1,n5
sqa=sqa + real(cx(i))**2 + aimag(cx(i))**2
sqb=sqb + real(cy(i))**2 + aimag(cy(i))**2
enddo
sqa=sqa/n5
sqb=sqb/n5
C Find best DF, f1, f2, DT, and pol
! a(5)=dt00
! fsample=1378.125
! i0=nint((a(5)+0.5)*fsample)
! if(i0.lt.1) i0=1
! nz=n5+1-i0
! call afc65b(cx(i0),cy(i0),nz,fsample,nflip,ipol,a,dt,
! + ccfbest,dtbest)
call fil6521(cx,n5,c5x,n6)
call fil6521(cy,n5,c5y,n6)
fsample=1378.125/4.
a(5)=dt00
i0=nint((a(5)+0.5)*fsample) - 2
if(i0.lt.1) i0=1
nz=n6+1-i0
call afc65b(c5x(i0),c5y(i0),nz,fsample,nflip,ipol,a,dt,
+ ccfbest,dtbest)
pol=a(4)/57.2957795
aa=cos(pol)
bb=sin(pol)
sq0=aa*aa*sqa + bb*bb*sqb
sync2=3.7*ccfbest/sq0
C Apply AFC corrections to the time-domain signal
call twkfreq(cx,cy,n5,a)
C Compute spectrum at best polarization for each half symbol.
C Adding or subtracting a small number (e.g., 5) to j may make it decode.
nsym=126
nfft=256
j=(dt00+dtbest+2.685)*1378.125 + joff
if(j.lt.0) j=0
j0=j
do k=1,nsym
do i=1,nfft
j=j+1
c5a(i)=aa*cx(j) + bb*cy(j)
enddo
call four2a(c5a,nfft,1,1,1)
do i=1,nfft
j=j+1
c5b(i)=aa*cx(j) + bb*cy(j)
enddo
call four2a(c5b,nfft,1,1,1)
do i=1,256
s2(i,k)=real(c5a(i))**2 + aimag(c5a(i))**2 +
+ real(c5b(i))**2 + aimag(c5b(i))**2
enddo
enddo
flip=nflip
call decode65b(s2,flip,nkv,nhist,qual,decoded)
dt=dt00 + dtbest
return
end

59
decode65b.f Normal file
View File

@ -0,0 +1,59 @@
subroutine decode65b(s2,flip,nkv,nhist,qual,decoded)
real s2(256,126)
real s3(64,63)
logical first
character decoded*22,deepmsg*22
character mycall*12,hiscall*12,hisgrid*6
! include 'avecom.h'
include 'prcom.h'
data first/.true./
save
if(first) call setup65
first=.false.
call setup65
do j=1,63
k=mdat(j) !Points to data symbol
if(flip.lt.0.0) k=mdat2(j)
do i=1,64
s3(i,j)=s2(i+2,k) !### Check the "i+2" ###
enddo
enddo
mode65=2
nadd=mode65
call extract(s3,nadd,ncount,nhist,decoded) !Extract the message
C Suppress "birdie messages":
if(decoded(1:7).eq.'000AAA ') ncount=-1
if(decoded(1:7).eq.'0L6MWK ') ncount=-1
nkv=1
if(ncount.lt.0) then
nkv=0
decoded=' '
endif
qual=0.
if(nkv.eq.0) then
mycall='K1JT'
hiscall='W1ABC'
hisgrid='EM79'
neme=0
nsked=0
ndepth=5
if(ndepth.ge.1) call deep65(s3,mode65,neme,
+ nsked,flip,mycall,hiscall,hisgrid,deepmsg,qual)
C Save symbol spectra for possible decoding of average.
! do j=1,63
! k=mdat(j)
! if(flip.lt.0.0) k=mdat2(j)
! call move(s2(8,k),ppsave(1,j,nsave),64)
! enddo
endif
if(nkv.eq.0 .and. qual.ge.1.0) decoded=deepmsg
return
end

63
deep65.F
View File

@ -5,18 +5,17 @@
real s3(64,63)
character callsign*12,grid*4,message*22,hisgrid*6,c*1,ceme*3
character*12 mycall,hiscall
character mycall0*12,hiscall0*12,hisgrid0*6
character*22 decoded
character*22 testmsg(2*MAXCALLS + 2 + MAXRPT)
character*15 callgrid(MAXCALLS)
character*180 line
character*4 rpt(MAXRPT)
integer ncode(63,2*MAXCALLS + 2 + MAXRPT)
integer nflip(2*MAXCALLS + 2 + MAXRPT)
integer istat23(13)
real pp(2*MAXCALLS + 2 + MAXRPT)
common/tmp9/ mrs(63),mrs2(63)
#ifdef Win32
C This prevents some optimizations that break this subroutine.
volatile p1,p2,bias
#endif
common/mrscom/ mrs(63),mrs2(63)
data neme0/-99/
data rpt/'-01','-02','-03','-04','-05',
@ -32,7 +31,13 @@ C This prevents some optimizations that break this subroutine.
+ 'R-21','R-22','R-23','R-24','R-25',
+ 'R-26','R-27','R-28','R-29','R-30',
+ 'RO','RRR','73'/
save
! call fstatqqq(23,istat23,ierr) !@@@
! modified=istat23(10) !@@@
modified=0 !@@@
if(mycall.eq.mycall0 .and. hiscall.eq.hiscall0 .and.
+ hisgrid.eq.hisgrid0 .and. modified.eq.modified0) go to 30
rewind 23
k=0
icall=0
@ -77,7 +82,7 @@ C This prevents some optimizations that break this subroutine.
mz=1
if(n.eq.1 .and. j3.lt.1 .and. j4.lt.1 .and.
+ flip.gt.0.0 .and. callsign(1:6).ne.' ') mz=MAXRPT+1
+ callsign(1:6).ne.' ') mz=MAXRPT+1
C Test for messages with MyCall + HisCall + report
do m=1,mz
if(m.gt.1) grid=rpt(m-1)
@ -87,12 +92,14 @@ C Test for messages with MyCall + HisCall + report
k=k+1
testmsg(k)=message
call encode65(message,ncode(1,k))
C Insert CQ message unless sync=OOO (flip=-1).
nflip(k)=flip
C Insert CQ message
if(m.eq.1 .and. flip.gt.0.0) then
message='CQ '//callgrid(icall)
k=k+1
testmsg(k)=message
call encode65(message,ncode(1,k))
nflip(k)=flip
endif
enddo
if(nsked.eq.1) go to 20
@ -101,28 +108,33 @@ C Insert CQ message unless sync=OOO (flip=-1).
20 ntot=k
neme0=neme
30 mycall0=mycall
hiscall0=hiscall
hisgrid0=hisgrid
modified0=modified
ref0=0.
do j=1,63
ref0=ref0 + s3(mrs(j),j)
enddo
p1=-1.e30
p2=-1.e30
do k=1,ntot
sum=0.
ref=ref0
do j=1,63
i=ncode(j,k)+1
sum=sum + s3(i,j)
if(i.eq.mrs(j)) then
ref=ref - s3(i,j) + s3(mrs2(j),j)
if(flip.gt.0.0 .or. nflip(k).lt.0) then !Skip CQ msg if flip=-1
sum=0.
ref=ref0
do j=1,63
i=ncode(j,k)+1
sum=sum + s3(i,j)
if(i.eq.mrs(j)) then
ref=ref - s3(i,j) + s3(mrs2(j),j)
endif
enddo
p=sum/ref
pp(k)=p
if(p.gt.p1) then
p1=p
ip1=k
endif
enddo
p=sum/ref
pp(k)=p
if(p.gt.p1) then
p1=p
ip1=k
endif
enddo
@ -131,10 +143,18 @@ C Insert CQ message unless sync=OOO (flip=-1).
if(pp(i).gt.p2 .and. pp(i).ne.p1) p2=pp(i)
enddo
C ### Find out why this needs to be here ###
C ### It's OK without it, in Linux, if compiled without optimization.
! rewind 77
! write(77,*) p1,p2
if(mode65.eq.1) bias=max(1.12*p2,0.335)
if(mode65.eq.2) bias=max(1.08*p2,0.405)
if(mode65.ge.4) bias=max(1.04*p2,0.505)
if(p2.eq.p1) stop 'Error in deep65'
qual=100.0*(p1-bias)
decoded=' '
c=' '
@ -145,6 +165,7 @@ C Insert CQ message unless sync=OOO (flip=-1).
qual=0.
endif
decoded(22:22)=c
C Make sure everything is upper case.
do i=1,22
if(decoded(i:i).ge.'a' .and. decoded(i:i).le.'z')

60
deg2grid.f
View File

@ -1,30 +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
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
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

142
demod64a.f
View File

@ -1,71 +1,71 @@
subroutine demod64a(signal,nadd,mrsym,mrprob,
+ mr2sym,mr2prob,ntest,nlow)
C Demodulate the 64-bin spectra for each of 63 symbols in a frame.
C Parameters
C nadd number of spectra already summed
C mrsym most reliable symbol value
C mr2sym second most likely symbol value
C mrprob probability that mrsym was the transmitted value
C mr2prob probability that mr2sym was the transmitted value
implicit real*8 (a-h,o-z)
real*4 signal(64,63)
real*8 fs(64)
integer mrsym(63),mrprob(63),mr2sym(63),mr2prob(63)
common/tmp9/ mrs(63),mrs2(63)
afac=1.1 * float(nadd)**0.64
scale=255.999
C Compute average spectral value
sum=0.
do j=1,63
do i=1,64
sum=sum+signal(i,j)
enddo
enddo
ave=sum/(64.*63.)
C Compute probabilities for most reliable symbol values
do j=1,63
s1=-1.e30
fsum=0.
do i=1,64
x=min(afac*signal(i,j)/ave,50.d0)
fs(i)=exp(x)
fsum=fsum+fs(i)
if(signal(i,j).gt.s1) then
s1=signal(i,j)
i1=i !Most reliable
endif
enddo
s2=-1.e30
do i=1,64
if(i.ne.i1 .and. signal(i,j).gt.s2) then
s2=signal(i,j)
i2=i !Second most reliable
endif
enddo
p1=fs(i1)/fsum !Normalized probabilities
p2=fs(i2)/fsum
mrsym(j)=i1-1
mr2sym(j)=i2-1
mrprob(j)=scale*p1
mr2prob(j)=scale*p2
mrs(j)=i1
mrs2(j)=i2
enddo
sum=0.
nlow=0
do j=1,63
sum=sum+mrprob(j)
if(mrprob(j).le.5) nlow=nlow+1
enddo
ntest=sum/63
return
end
subroutine demod64a(signal,nadd,mrsym,mrprob,
+ mr2sym,mr2prob,ntest,nlow)
C Demodulate the 64-bin spectra for each of 63 symbols in a frame.
C Parameters
C nadd number of spectra already summed
C mrsym most reliable symbol value
C mr2sym second most likely symbol value
C mrprob probability that mrsym was the transmitted value
C mr2prob probability that mr2sym was the transmitted value
implicit real*8 (a-h,o-z)
real*4 signal(64,63)
real*8 fs(64)
integer mrsym(63),mrprob(63),mr2sym(63),mr2prob(63)
common/mrscom/ mrs(63),mrs2(63)
afac=1.1 * float(nadd)**0.64
scale=255.999
C Compute average spectral value
sum=0.
do j=1,63
do i=1,64
sum=sum+signal(i,j)
enddo
enddo
ave=sum/(64.*63.)
C Compute probabilities for most reliable symbol values
do j=1,63
s1=-1.e30
fsum=0.
do i=1,64
x=min(afac*signal(i,j)/ave,50.d0)
fs(i)=exp(x)
fsum=fsum+fs(i)
if(signal(i,j).gt.s1) then
s1=signal(i,j)
i1=i !Most reliable
endif
enddo
s2=-1.e30
do i=1,64
if(i.ne.i1 .and. signal(i,j).gt.s2) then
s2=signal(i,j)
i2=i !Second most reliable
endif
enddo
p1=fs(i1)/fsum !Normalized probabilities
p2=fs(i2)/fsum
mrsym(j)=i1-1
mr2sym(j)=i2-1
mrprob(j)=scale*p1
mr2prob(j)=scale*p2
mrs(j)=i1
mrs2(j)=i2
enddo
sum=0.
nlow=0
do j=1,63
sum=sum+mrprob(j)
if(mrprob(j).le.5) nlow=nlow+1
enddo
ntest=sum/63
return
end

58
detect.f
View File

@ -1,29 +1,29 @@
subroutine detect(data,npts,f,y)
C Compute powers at the tone frequencies using 1-sample steps.
parameter (NZ=11025,NSPD=25)
real data(npts)
real y(npts)
complex c(NZ)
complex csum
data twopi/6.283185307/
dpha=twopi*f/11025.0
do i=1,npts
c(i)=data(i)*cmplx(cos(dpha*i),-sin(dpha*i))
enddo
csum=0.
do i=1,NSPD
csum=csum+c(i)
enddo
y(1)=real(csum)**2 + aimag(csum)**2
do i=2,npts-(NSPD-1)
csum=csum-c(i-1)+c(i+NSPD-1)
y(i)=real(csum)**2 + aimag(csum)**2
enddo
return
end
subroutine detect(data,npts,f,y)
C Compute powers at the tone frequencies using 1-sample steps.
parameter (NZ=11025,NSPD=25)
real data(npts)
real y(npts)
complex c(NZ)
complex csum
data twopi/6.283185307/
dpha=twopi*f/11025.0
do i=1,npts
c(i)=data(i)*cmplx(cos(dpha*i),-sin(dpha*i))
enddo
csum=0.
do i=1,NSPD
csum=csum+c(i)
enddo
y(1)=real(csum)**2 + aimag(csum)**2
do i=2,npts-(NSPD-1)
csum=csum-c(i-1)+c(i+NSPD-1)
y(i)=real(csum)**2 + aimag(csum)**2
enddo
return
end

50
display.f Normal file
View File

@ -0,0 +1,50 @@
subroutine display(nutc)
parameter (MAXLINES=500)
integer indx(MAXLINES)
character*80 line(MAXLINES)
real freqkHz(MAXLINES)
integer utc(MAXLINES)
real*8 f0
ftol=0.02
rewind 26
do i=1,MAXLINES
read(26,1010,end=10) line(i)
1010 format(a80)
read(line(i),1020) f0,ndf,utc(i)
1020 format(f7.3,i5,26x,i5)
freqkHz(i)=1000.d0*(f0-144.d0) + 0.001d0*ndf
enddo
10 nz=i-1
call indexx(nz,freqkHz,indx)
nstart=1
rewind 24
write(24,3101) line(indx(1))
3101 format(a80)
do i=2,nz
j0=indx(i-1)
j=indx(i)
if(freqkHz(j)-freqkHz(j0).gt.ftol) then
if(nstart.eq.0) write(24,3101)
endfile 24
if(nstart.eq.1) then
!@@@ call sysqqq('sort -k 1.40 fort.24 | uniq > fort.13')
nstart=0
else
!@@@ call sysqqq('sort -k 1.40 fort.24 | uniq >> fort.13')
endif
rewind 24
endif
if(i.eq.nz) write(24,3101)
write(24,3101) line(j)
j0=j
enddo
endfile 24
!@@@ call sysqqq('sort -k 1.40 fort.24 | uniq >> fort.13')
return
end

22
dot.f
View File

@ -1,11 +1,11 @@
real*8 function dot(x,y)
real*8 x(3),y(3)
dot=0.d0
do i=1,3
dot=dot+x(i)*y(i)
enddo
return
end
real*8 function dot(x,y)
real*8 x(3),y(3)
dot=0.d0
do i=1,3
dot=dot+x(i)*y(i)
enddo
return
end

26
encode65.f
View File

@ -1,13 +1,13 @@
subroutine encode65(message,sent)
character message*22
integer dgen(12)
integer sent(63)
call packmsg(message,dgen)
call rs_encode(dgen,sent)
call interleave63(sent,1)
call graycode(sent,63,1)
return
end
subroutine encode65(message,sent)
character message*22
integer dgen(12)
integer sent(63)
call packmsg(message,dgen)
call rs_encode(dgen,sent)
call interleave63(sent,1)
call graycode(sent,63,1)
return
end

27
extract.f
View File

@ -1,28 +1,39 @@
subroutine extract(s3,nadd,ncount,decoded)
subroutine extract(s3,nadd,ncount,nhist,decoded)
real s3(64,63)
real tmp(4032)
character decoded*22
integer era(51),dat4(12),indx(63)
integer era(51),dat4(12),indx(64)
integer mrsym(63),mr2sym(63),mrprob(63),mr2prob(63)
logical first
data first/.true./,nsec1/0/
save
call demod64a(s3,nadd,mrsym,mrprob,mr2sym,mr2prob,ntest,nlow)
nfail=0
1 call demod64a(s3,nadd,mrsym,mrprob,mr2sym,mr2prob,ntest,nlow)
if(ntest.lt.50 .or. nlow.gt.20) then
ncount=-999 !Flag bad data
go to 900
endif
call chkhist(mrsym,nhist,ipk)
if(nhist.ge.20) then
nfail=nfail+1
call pctile(s3,tmp,4032,50,base) ! ### or, use ave from demod64a
do j=1,63
s3(ipk,j)=base
enddo
go to 1
endif
call graycode(mrsym,63,-1)
call interleave63(mrsym,-1)
call interleave63(mrprob,-1)
ndec=1
nemax=30
nemax=30 !Was 200 (30)
maxe=8
xlambda=15.0
xlambda=12.0 !Was 15 (12)
if(ndec.eq.1) then
call graycode(mr2sym,63,-1)
@ -35,9 +46,9 @@
call flushqqq(22)
call runqqq('kvasd.exe','-q',iret)
if(iret.ne.0) then
if(first) write(*,1000)
if(first) write(*,1000) iret
1000 format('Error in KV decoder, or no KV decoder present.'/
+ 'Using BM algorithm.')
+ 'Return code:',i8,'. Will use BM algorithm.')
ndec=0
first=.false.
go to 20

128
fftw3.f
View File

@ -1,64 +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)
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)

104
filbig.f Normal file
View File

@ -0,0 +1,104 @@
subroutine filbig(id,nmax,f0,newdat,c4a,c4b,n4)
C Filter and downsample complex data for X and Y polarizations,
C stored in array id(4,nmax). Output is downsampled from 96000 Hz
C to 1500 Hz, and the low-pass filter has f_cutoff = 375 Hz and
C f_stop = 750 Hz.
parameter (NFFT1=5376000,NFFT2=77175)
integer*2 id(4,nmax) !Input data
complex c4a(NFFT2),c4b(NFFT2) !Output data
complex ca(NFFT1),cb(NFFT1) !FFTs of input
real*8 df
real halfpulse(8) !Impulse response of filter (one side)
complex cfilt(NFFT2) !Filter (complex; imag = 0)
real rfilt(NFFT2) !Filter (real)
integer*8 plan1,plan2,plan3,plan4,plan5
logical first
include 'fftw3.f'
equivalence (rfilt,cfilt)
data first/.true./
data halfpulse/114.97547150,36.57879257,-20.93789101,
+ 5.89886379,1.59355187,-2.49138308,0.60910773,-0.04248129/
save
if(first) then
npatience=FFTW_ESTIMATE
! npatience=FFTW_MEASURE
C Plan the FFTs just once
call sfftw_plan_dft_1d_(plan1,NFFT1,ca,ca,
+ FFTW_BACKWARD,npatience)
call sfftw_plan_dft_1d_(plan2,NFFT1,cb,cb,
+ FFTW_BACKWARD,npatience)
call sfftw_plan_dft_1d_(plan3,NFFT2,c4a,c4a,
+ FFTW_FORWARD,npatience)
call sfftw_plan_dft_1d_(plan4,NFFT2,c4b,c4b,
+ FFTW_FORWARD,npatience)
call sfftw_plan_dft_1d_(plan5,NFFT2,cfilt,cfilt,
+ FFTW_BACKWARD,npatience)
C Convert impulse response to filter function
do i=1,NFFT2
cfilt(i)=0.
enddo
fac=0.00625/NFFT1
cfilt(1)=fac*halfpulse(1)
do i=2,8
cfilt(i)=fac*halfpulse(i)
cfilt(NFFT2+2-i)=fac*halfpulse(i)
enddo
call sfftw_execute_(plan5)
base=cfilt(NFFT2/2+1)
do i=1,NFFT2
rfilt(i)=real(cfilt(i))-base
enddo
df=96000.d0/NFFT1
first=.false.
endif
C When new data comes along, we need to compute a new "big FFT"
C If we just have a new f0, continue with the existing ca and cb.
if(newdat.ne.0) then
nz=min(nmax,NFFT1)
do i=1,nz
ca(i)=cmplx(float(id(1,i)),float(id(2,i)))
cb(i)=cmplx(float(id(3,i)),float(id(4,i)))
enddo
if(nmax.lt.NFFT1) then
do i=nmax+1,NFFT1
ca(i)=0.
cb(i)=0.
enddo
endif
call sfftw_execute_(plan1)
call sfftw_execute_(plan2)
newdat=0
endif
C NB: f0 is the frequency at which we want our filter centered.
C i0 is the bin number in ca and cb closest to f0.
i0=nint(f0/df) + 1
nh=NFFT2/2
do i=1,nh !Copy data into c4a and c4b,
j=i0+i-1 !and apply the filter function
c4a(i)=rfilt(i)*ca(j)
c4b(i)=rfilt(i)*cb(j)
enddo
do i=nh+1,NFFT2
j=i0+i-1-NFFT2
if(j.lt.1) j=j+NFFT2
c4a(i)=rfilt(i)*ca(j)
c4b(i)=rfilt(i)*cb(j)
enddo
C Do the short reverse transform, to go back to time domain.
call sfftw_execute_(plan3)
call sfftw_execute_(plan4)
n4=min(nmax/64,NFFT2)
return
end

540
fivehz.F90
View File

@ -1,270 +1,270 @@
subroutine fivehz
! Called at interrupt level from the PortAudio callback routine.
! For nspb=2048 the callback rate is nfsample/nspb = 5.38 Hz.
! Thus, we should be able to control the timing of T/R sequence events
! here to within about 0.2 s.
! Do not do anything very time consuming in this routine!!
! Disk I/O is a bad idea. Writing to stdout (for diagnostic purposes)
! seems to be OK.
#ifdef Win32
use dflib
use dfport
#endif
parameter (NTRING=64)
real*8 tt1(0:NTRING-1)
real*8 tstart,tstop,t60
logical first,txtime,filled
integer ptt
integer TxOKz
real*8 fs,fsample,tt,u
include 'gcom1.f90'
include 'gcom2.f90'
data first/.true./,nc0/1/,nc1/1/
save
n1=time()
n2=mod(n1,86400)
tt=n1-n2+tsec-0.1d0*ndsec
if(first) then
rxdelay=0.2
txdelay=0.4
tlatency=1.0
first=.false.
iptt=0
ntr0=-99
rxdone=.false.
ibuf00=-99
ncall=-1
u=0.05d0
fsample=11025.d0
mfsample=110250
filled=.false.
endif
if(txdelay.lt.0.2d0) txdelay=0.2d0
! Measure average sampling frequency over a recent interval
ncall=ncall+1
if(ncall.eq.9) then
ntt0=0
ntt1=0
tt1(ntt1)=tt
endif
! if(ncall.ge.10 .and. mod(ncall,2).eq.1) then
if(ncall.ge.10) then
ntt1=iand(ntt1+1,NTRING-1)
tt1(ntt1)=tt
if(ntt1.eq.NTRING-1) filled=.true.
if(filled) ntt0=iand(ntt1+1,NTRING-1)
if(mod(ncall,2).eq.1) then
nd=ntt1-ntt0
if(nd.lt.0) nd=nd+NTRING
fs=nd*2048.d0/(tt1(ntt1)-tt1(ntt0))
fsample=u*fs + (1.d0-u)*fsample
mfsample=nint(10.d0*fsample)
endif
endif
if(trperiod.le.0) trperiod=30
tx1=0.0 !Time to start a TX sequence
tx2=trperiod-(tlatency+txdelay) !Time to turn TX off
if(mode(1:4).eq.'JT65') then
if(nwave.lt.126*4096) nwave=126*4096
tx2=txdelay + nwave/11025.0
if(tx2.gt.(trperiod-2.0)) tx2=trperiod-tlatency-1.0
endif
if(TxFirst.eq.0) then
tx1=tx1+trperiod
tx2=tx2+trperiod
endif
t=mod(Tsec,2.d0*trperiod)
txtime = t.ge.tx1 .and. t.lt.tx2
! If we're transmitting, freeze the input buffer pointers where they were.
receiving=1
if(((txtime .and. (lauto.eq.1)) .or. TxOK.eq.1 .or. transmitting.eq.1) &
.and. (mute.eq.0)) then
receiving=0
ibuf=ibuf000
iwrite=iwrite000
endif
ibuf000=ibuf
iwrite000=iwrite
nsec=Tsec
ntr=mod(nsec/trperiod,2) !ntr=0 in 1st sequence, 1 in 2nd
if(ntr.ne.ntr0) then
ibuf0=ibuf !Start of new sequence, save ibuf
! if(mode(1:4).ne.'JT65') then
! ibuf0=ibuf0+3 !So we don't copy our own Tx
! if(ibuf0.gt.1024) ibuf0=ibuf0-1024
! endif
ntime=time() !Save start time
if(mantx.eq.1 .and. iptt.eq.1) then
mantx=0
TxOK=0
endif
endif
! Switch PTT line and TxOK appropriately
if(lauto.eq.1) then
if(txtime .and. iptt.eq.0 .and. &
mute.eq.0) i1=ptt(nport,pttport,1,iptt) !Raise PTT
if(.not.txtime .or. mute.eq.1) TxOK=0 !Lower TxOK
else
if(mantx.eq.1 .and. iptt.eq.0 .and. &
mute.eq.0) i2=ptt(nport,pttport,1,iptt) !Raise PTT
if(mantx.eq.0 .or. mute.eq.1) TxOK=0 !Lower TxOK
endif
! Calculate Tx waveform as needed
if((iptt.eq.1 .and. iptt0.eq.0) .or. nrestart.eq.1) then
call wsjtgen
nrestart=0
endif
! If PTT was just raised, start a countdown for raising TxOK:
nc1a=txdelay/0.18576
if(nc1a.lt.2) nc1a=2
if(iptt.eq.1 .and. iptt0.eq.0) nc1=-nc1a-1
if(nc1.le.0) nc1=nc1+1
if(nc1.eq.0) TxOK=1 ! We are transmitting
! If TxOK was just lowered, start a countdown for lowering PTT:
nc0a=(tlatency+txdelay)/0.18576
if(nc0a.lt.5) nc0a=5
if(TxOK.eq.0 .and. TxOKz.eq.1 .and. iptt.eq.1) nc0=-nc0a-1
if(nc0.le.0) nc0=nc0+1
if(nc0.eq.0) i3=ptt(nport,pttport,0,iptt)
if(iptt.eq.0 .and.TxOK.eq.0) then
sending=" "
sendingsh=0
endif
nbufs=ibuf-ibuf0
if(nbufs.lt.0) nbufs=nbufs+1024
tdata=nbufs*2048.0/11025.0
if(mode(1:4).eq.'JT65' .and. monitoring.eq.1 .and. tdata.gt.53.0 &
.and. ibuf0.ne.ibuf00) then
rxdone=.true.
ibuf00=ibuf0
endif
! Diagnostic timing information:
! t60=mod(tsec,60.d0)
! if(TxOK.ne.TxOKz) then
! if(TxOK.eq.1) write(*,1101) 'D2:',t
!1101 format(a3,f8.1,i8)
! if(TxOK.eq.0) then
! tstop=tsec
! write(*,1101) 'D3:',t,nc0a
! endif
! endif
! if(iptt.ne.iptt0) then
! if(iptt.eq.1) then
! tstart=tsec
! write(*,1101) 'D1:',t,nc1a
! endif
! if(iptt.eq.0) write(*,1101) 'D4:',t
! endif
iptt0=iptt
TxOKz=TxOK
ntr0=ntr
return
end subroutine fivehz
subroutine fivehztx
! Called at interrupt level from the PortAudio output callback.
#ifdef Win32
use dflib
use dfport
#endif
parameter (NTRING=64)
real*8 tt1(0:NTRING-1)
logical first,filled
real*8 fs,fsample,tt,u
include 'gcom1.f90'
data first/.true./
save
n1=time()
n2=mod(n1,86400)
tt=n1-n2+tsec-0.1d0*ndsec
if(first) then
first=.false.
ncall=-1
fsample=11025.d0
u=0.05d0
mfsample2=110250
filled=.false.
endif
! Measure average sampling frequency over a recent interval
ncall=ncall+1
if(ncall.eq.9) then
ntt0=0
ntt1=0
tt1(ntt1)=tt
endif
if(ncall.ge.10) then
ntt1=iand(ntt1+1,NTRING-1)
tt1(ntt1)=tt
if(ntt1.eq.NTRING-1) filled=.true.
if(filled) ntt0=iand(ntt1+1,NTRING-1)
if(mod(ncall,2).eq.1) then
nd=ntt1-ntt0
if(nd.lt.0) nd=nd+NTRING
fs=nd*2048.d0/(tt1(ntt1)-tt1(ntt0))
fsample=u*fs + (1.d0-u)*fsample
mfsample2=nint(10.d0*fsample)
endif
endif
return
end subroutine fivehztx
subroutine addnoise(n)
integer*2 n
real*8 txsnrdb0
include 'gcom1.f90'
data idum/0/
save
if(txsnrdb.gt.40.0) return
if(txsnrdb.ne.txsnrdb0) then
snr=10.0**(0.05*(txsnrdb-1))
fac=3000.0
if(snr.gt.1.0) fac=3000.0/snr
txsnrdb0=txsnrdb
endif
i=fac*(gran(idum) + n*snr/32768.0)
if(i>32767) i=32767;
if(i<-32767) i=-32767;
n=i
return
end subroutine addnoise
real function gran(idum)
real r(12)
if(idum.lt.0) then
call random_seed
idum=0
endif
call random_number(r)
gran=sum(r)-6.0
end function gran
subroutine fivehz
! Called at interrupt level from the PortAudio callback routine.
! For nspb=2048 the callback rate is nfsample/nspb = 5.38 Hz.
! Thus, we should be able to control the timing of T/R sequence events
! here to within about 0.2 s.
! Do not do anything very time consuming in this routine!!
! Disk I/O is a bad idea. Writing to stdout (for diagnostic purposes)
! seems to be OK.
#ifdef Win32
use dflib
use dfport
#endif
parameter (NTRING=64)
real*8 tt1(0:NTRING-1)
real*8 tstart,tstop,t60
logical first,txtime,filled
integer ptt
integer TxOKz
real*8 fs,fsample,tt,u
include 'gcom1.f90'
include 'gcom2.f90'
data first/.true./,nc0/1/,nc1/1/
save
n1=time()
n2=mod(n1,86400)
tt=n1-n2+tsec-0.1d0*ndsec
if(first) then
rxdelay=0.2
txdelay=0.4
tlatency=1.0
first=.false.
iptt=0
ntr0=-99
rxdone=.false.
ibuf00=-99
ncall=-1
u=0.05d0
fsample=11025.d0
mfsample=110250
filled=.false.
endif
if(txdelay.lt.0.2d0) txdelay=0.2d0
! Measure average sampling frequency over a recent interval
ncall=ncall+1
if(ncall.eq.9) then
ntt0=0
ntt1=0
tt1(ntt1)=tt
endif
! if(ncall.ge.10 .and. mod(ncall,2).eq.1) then
if(ncall.ge.10) then
ntt1=iand(ntt1+1,NTRING-1)
tt1(ntt1)=tt
if(ntt1.eq.NTRING-1) filled=.true.
if(filled) ntt0=iand(ntt1+1,NTRING-1)
if(mod(ncall,2).eq.1) then
nd=ntt1-ntt0
if(nd.lt.0) nd=nd+NTRING
fs=nd*2048.d0/(tt1(ntt1)-tt1(ntt0))
fsample=u*fs + (1.d0-u)*fsample
mfsample=nint(10.d0*fsample)
endif
endif
if(trperiod.le.0) trperiod=30
tx1=0.0 !Time to start a TX sequence
tx2=trperiod-(tlatency+txdelay) !Time to turn TX off
if(mode(1:4).eq.'JT65') then
if(nwave.lt.126*4096) nwave=126*4096
tx2=txdelay + nwave/11025.0
if(tx2.gt.(trperiod-2.0)) tx2=trperiod-tlatency-1.0
endif
if(TxFirst.eq.0) then
tx1=tx1+trperiod
tx2=tx2+trperiod
endif
t=mod(Tsec,2.d0*trperiod)
txtime = t.ge.tx1 .and. t.lt.tx2
! If we're transmitting, freeze the input buffer pointers where they were.
receiving=1
if(((txtime .and. (lauto.eq.1)) .or. TxOK.eq.1 .or. transmitting.eq.1) &
.and. (mute.eq.0)) then
receiving=0
ibuf=ibuf000
iwrite=iwrite000
endif
ibuf000=ibuf
iwrite000=iwrite
nsec=Tsec
ntr=mod(nsec/trperiod,2) !ntr=0 in 1st sequence, 1 in 2nd
if(ntr.ne.ntr0) then
ibuf0=ibuf !Start of new sequence, save ibuf
! if(mode(1:4).ne.'JT65') then
! ibuf0=ibuf0+3 !So we don't copy our own Tx
! if(ibuf0.gt.1024) ibuf0=ibuf0-1024
! endif
ntime=time() !Save start time
if(mantx.eq.1 .and. iptt.eq.1) then
mantx=0
TxOK=0
endif
endif
! Switch PTT line and TxOK appropriately
if(lauto.eq.1) then
if(txtime .and. iptt.eq.0 .and. &
mute.eq.0) i1=ptt(nport,pttport,1,iptt) !Raise PTT
if(.not.txtime .or. mute.eq.1) TxOK=0 !Lower TxOK
else
if(mantx.eq.1 .and. iptt.eq.0 .and. &
mute.eq.0) i2=ptt(nport,pttport,1,iptt) !Raise PTT
if(mantx.eq.0 .or. mute.eq.1) TxOK=0 !Lower TxOK
endif
! Calculate Tx waveform as needed
if((iptt.eq.1 .and. iptt0.eq.0) .or. nrestart.eq.1) then
call wsjtgen
nrestart=0
endif
! If PTT was just raised, start a countdown for raising TxOK:
nc1a=txdelay/0.18576
if(nc1a.lt.2) nc1a=2
if(iptt.eq.1 .and. iptt0.eq.0) nc1=-nc1a-1
if(nc1.le.0) nc1=nc1+1
if(nc1.eq.0) TxOK=1 ! We are transmitting
! If TxOK was just lowered, start a countdown for lowering PTT:
nc0a=(tlatency+txdelay)/0.18576
if(nc0a.lt.5) nc0a=5
if(TxOK.eq.0 .and. TxOKz.eq.1 .and. iptt.eq.1) nc0=-nc0a-1
if(nc0.le.0) nc0=nc0+1
if(nc0.eq.0) i3=ptt(nport,pttport,0,iptt)
if(iptt.eq.0 .and.TxOK.eq.0) then
sending=" "
sendingsh=0
endif
nbufs=ibuf-ibuf0
if(nbufs.lt.0) nbufs=nbufs+1024
tdata=nbufs*2048.0/11025.0
if(mode(1:4).eq.'JT65' .and. monitoring.eq.1 .and. tdata.gt.53.0 &
.and. ibuf0.ne.ibuf00) then
rxdone=.true.
ibuf00=ibuf0
endif
! Diagnostic timing information:
! t60=mod(tsec,60.d0)
! if(TxOK.ne.TxOKz) then
! if(TxOK.eq.1) write(*,1101) 'D2:',t
!1101 format(a3,f8.1,i8)
! if(TxOK.eq.0) then
! tstop=tsec
! write(*,1101) 'D3:',t,nc0a
! endif
! endif
! if(iptt.ne.iptt0) then
! if(iptt.eq.1) then
! tstart=tsec
! write(*,1101) 'D1:',t,nc1a
! endif
! if(iptt.eq.0) write(*,1101) 'D4:',t
! endif
iptt0=iptt
TxOKz=TxOK
ntr0=ntr
return
end subroutine fivehz
subroutine fivehztx
! Called at interrupt level from the PortAudio output callback.
#ifdef Win32
use dflib
use dfport
#endif
parameter (NTRING=64)
real*8 tt1(0:NTRING-1)
logical first,filled
real*8 fs,fsample,tt,u
include 'gcom1.f90'
data first/.true./
save
n1=time()
n2=mod(n1,86400)
tt=n1-n2+tsec-0.1d0*ndsec
if(first) then
first=.false.
ncall=-1
fsample=11025.d0
u=0.05d0
mfsample2=110250
filled=.false.
endif
! Measure average sampling frequency over a recent interval
ncall=ncall+1
if(ncall.eq.9) then
ntt0=0
ntt1=0
tt1(ntt1)=tt
endif
if(ncall.ge.10) then
ntt1=iand(ntt1+1,NTRING-1)
tt1(ntt1)=tt
if(ntt1.eq.NTRING-1) filled=.true.
if(filled) ntt0=iand(ntt1+1,NTRING-1)
if(mod(ncall,2).eq.1) then
nd=ntt1-ntt0
if(nd.lt.0) nd=nd+NTRING
fs=nd*2048.d0/(tt1(ntt1)-tt1(ntt0))
fsample=u*fs + (1.d0-u)*fsample
mfsample2=nint(10.d0*fsample)
endif
endif
return
end subroutine fivehztx
subroutine addnoise(n)
integer*2 n
real*8 txsnrdb0
include 'gcom1.f90'
data idum/0/
save
if(txsnrdb.gt.40.0) return
if(txsnrdb.ne.txsnrdb0) then
snr=10.0**(0.05*(txsnrdb-1))
fac=3000.0
if(snr.gt.1.0) fac=3000.0/snr
txsnrdb0=txsnrdb
endif
i=fac*(gran(idum) + n*snr/32768.0)
if(i>32767) i=32767;
if(i<-32767) i=-32767;
n=i
return
end subroutine addnoise
real function gran(idum)
real r(12)
if(idum.lt.0) then
call random_seed
idum=0
endif
call random_number(r)
gran=sum(r)-6.0
end function gran

10
fivehz.h
View File

@ -1,5 +1,5 @@
#include <inttypes.h>
void addnoise_(int16_t *n2);
void fivehztx_(void);
void fivehz_(void);
#include <inttypes.h>
void addnoise_(int16_t *n2);
void fivehztx_(void);
void fivehz_(void);

60
flat1.f
View File

@ -1,30 +1,30 @@
subroutine flat1(psavg,s2,nh,nsteps,nhmax,nsmax)
real psavg(nh)
real s2(nhmax,nsmax)
real x(8192),tmp(33)
nsmo=33
ia=nsmo/2 + 1
ib=nh - nsmo/2 - 1
do i=ia,ib
call pctile(psavg(i-nsmo/2),tmp,nsmo,50,x(i))
enddo
do i=1,ia-1
x(i)=x(ia)
enddo
do i=ib+1,nh
x(i)=x(ib)
enddo
do i=1,nh
psavg(i)=psavg(i)/x(i)
do j=1,nsteps
s2(i,j)=s2(i,j)/x(i)
enddo
enddo
return
end
subroutine flat1(psavg,s2,nh,nsteps,nhmax,nsmax)
real psavg(nh)
real s2(nhmax,nsmax)
real x(8192),tmp(33)
nsmo=33
ia=nsmo/2 + 1
ib=nh - nsmo/2 - 1
do i=ia,ib
call pctile(psavg(i-nsmo/2),tmp,nsmo,50,x(i))
enddo
do i=1,ia-1
x(i)=x(ia)
enddo
do i=ib+1,nh
x(i)=x(ib)
enddo
do i=1,nh
psavg(i)=psavg(i)/x(i)
do j=1,nsteps
s2(i,j)=s2(i,j)/x(i)
enddo
enddo
return
end

56
flat2.f
View File

@ -1,28 +1,28 @@
subroutine flat2(ss,n,nsum)
real ss(2048)
real ref(2048)
real tmp(2048)
nsmo=20
base=50*(float(nsum)**1.5)
ia=nsmo+1
ib=n-nsmo-1
do i=ia,ib
call pctile(ss(i-nsmo),tmp,2*nsmo+1,50,ref(i))
enddo
call pctile(ref(ia),tmp,ib-ia+1,68,base2)
C Don't flatten if signal is extremely low (e.g., RX is off).
if(base2.gt.0.05*base) then
do i=ia,ib
ss(i)=base*ss(i)/ref(i)
enddo
else
do i=1,n
ss(i)=0.
enddo
endif
return
end
subroutine flat2(ss,n,nsum)
real ss(2048)
real ref(2048)
real tmp(2048)
nsmo=20
base=50*(float(nsum)**1.5)
ia=nsmo+1
ib=n-nsmo-1
do i=ia,ib
call pctile(ss(i-nsmo),tmp,2*nsmo+1,50,ref(i))
enddo
call pctile(ref(ia),tmp,ib-ia+1,68,base2)
C Don't flatten if signal is extremely low (e.g., RX is off).
if(base2.gt.0.05*base) then
do i=ia,ib
ss(i)=base*ss(i)/ref(i)
enddo
else
do i=1,n
ss(i)=0.
enddo
endif
return
end

210
flatten.f
View File

@ -1,105 +1,105 @@
subroutine flatten(s2,nbins,jz,psa,ref,birdie,variance)
C Examines the 2-d spectrum s2(nbins,jz) and makes a reference spectrum
C from the jz/2 spectra below the 50th percentile in total power. Uses
C reference spectrum (with birdies removed) to flatten the passband.
real s2(nbins,jz) !2d spectrum
real psa(nbins) !Grand average spectrum
real ref(nbins) !Ref spect: smoothed ave of lower half
real birdie(nbins) !Spec (with birdies) for plot, in dB
real variance(nbins)
real ref2(750) !Work array
real power(300)
C Find power in each time block, then get median
do j=1,jz
s=0.
do i=1,nbins
s=s+s2(i,j)
enddo
power(j)=s
enddo
call pctile(power,ref2,jz,50,xmedian)
if(jz.lt.5) go to 900
C Get variance in each freq channel, using only those spectra with
C power below the median.
do i=1,nbins
s=0.
nsum=0
do j=1,jz
if(power(j).le.xmedian) then
s=s+s2(i,j)
nsum=nsum+1
endif
enddo
s=s/nsum
sq=0.
do j=1,jz
if(power(j).le.xmedian) sq=sq + (s2(i,j)/s-1.0)**2
enddo
variance(i)=sq/nsum
enddo
C Get grand average, and average of spectra with power below median.
call zero(psa,nbins)
call zero(ref,nbins)
nsum=0
do j=1,jz
call add(psa,s2(1,j),psa,nbins)
if(power(j).le.xmedian) then
call add(ref,s2(1,j),ref,nbins)
nsum=nsum+1
endif
enddo
do i=1,nbins !Normalize the averages
psa(i)=psa(i)/jz
ref(i)=ref(i)/nsum
birdie(i)=ref(i) !Copy ref into birdie
enddo
C Compute smoothed reference spectrum with narrow lines (birdies) removed
do i=4,nbins-3
rmax=-1.e10
do k=i-3,i+3 !Get highest point within +/- 3 bins
if(ref(k).gt.rmax) then
rmax=ref(k)
kpk=k
endif
enddo
sum=0.
nsum=0
do k=i-3,i+3
if(abs(k-kpk).gt.1) then
sum=sum+ref(k)
nsum=nsum+1
endif
enddo
ref2(i)=sum/nsum
enddo
call move(ref2(4),ref(4),nbins-6) !Copy smoothed ref back into ref
call pctile(ref(4),ref2,nbins-6,50,xmedian) !Get median in-band level
C Fix ends of reference spectrum
do i=1,3
ref(i)=ref(4)
ref(nbins+1-i)=ref(nbins-3)
enddo
facmax=30.0/xmedian
do i=1,nbins !Flatten the 2d spectrum
fac=xmedian/ref(i)
fac=min(fac,facmax)
do j=1,jz
s2(i,j)=fac*s2(i,j)
enddo
psa(i)=dB(psa(i)) + 25.
ref(i)=dB(ref(i)) + 25.
birdie(i)=db(birdie(i)) + 25.
enddo
900 continue
return
end
subroutine flatten(s2,nbins,jz,psa,ref,birdie,variance)
C Examines the 2-d spectrum s2(nbins,jz) and makes a reference spectrum
C from the jz/2 spectra below the 50th percentile in total power. Uses
C reference spectrum (with birdies removed) to flatten the passband.
real s2(nbins,jz) !2d spectrum
real psa(nbins) !Grand average spectrum
real ref(nbins) !Ref spect: smoothed ave of lower half
real birdie(nbins) !Spec (with birdies) for plot, in dB
real variance(nbins)
real ref2(750) !Work array
real power(300)
C Find power in each time block, then get median
do j=1,jz
s=0.
do i=1,nbins
s=s+s2(i,j)
enddo
power(j)=s
enddo
call pctile(power,ref2,jz,50,xmedian)
if(jz.lt.5) go to 900
C Get variance in each freq channel, using only those spectra with
C power below the median.
do i=1,nbins
s=0.
nsum=0
do j=1,jz
if(power(j).le.xmedian) then
s=s+s2(i,j)
nsum=nsum+1
endif
enddo
s=s/nsum
sq=0.
do j=1,jz
if(power(j).le.xmedian) sq=sq + (s2(i,j)/s-1.0)**2
enddo
variance(i)=sq/nsum
enddo
C Get grand average, and average of spectra with power below median.
call zero(psa,nbins)
call zero(ref,nbins)
nsum=0
do j=1,jz
call add(psa,s2(1,j),psa,nbins)
if(power(j).le.xmedian) then
call add(ref,s2(1,j),ref,nbins)
nsum=nsum+1
endif
enddo
do i=1,nbins !Normalize the averages
psa(i)=psa(i)/jz
ref(i)=ref(i)/nsum
birdie(i)=ref(i) !Copy ref into birdie
enddo
C Compute smoothed reference spectrum with narrow lines (birdies) removed
do i=4,nbins-3
rmax=-1.e10
do k=i-3,i+3 !Get highest point within +/- 3 bins
if(ref(k).gt.rmax) then
rmax=ref(k)
kpk=k
endif
enddo
sum=0.
nsum=0
do k=i-3,i+3
if(abs(k-kpk).gt.1) then
sum=sum+ref(k)
nsum=nsum+1
endif
enddo
ref2(i)=sum/nsum
enddo
call move(ref2(4),ref(4),nbins-6) !Copy smoothed ref back into ref
call pctile(ref(4),ref2,nbins-6,50,xmedian) !Get median in-band level
C Fix ends of reference spectrum
do i=1,3
ref(i)=ref(4)
ref(nbins+1-i)=ref(nbins-3)
enddo
facmax=30.0/xmedian
do i=1,nbins !Flatten the 2d spectrum
fac=xmedian/ref(i)
fac=min(fac,facmax)
do j=1,jz
s2(i,j)=fac*s2(i,j)
enddo
psa(i)=dB(psa(i)) + 25.
ref(i)=dB(ref(i)) + 25.
birdie(i)=db(birdie(i)) + 25.
enddo
900 continue
return
end

700
four2.f
View File

@ -1,350 +1,350 @@
SUBROUTINE FOUR2a (DATA,N,NDIM,ISIGN,IFORM)
C Cooley-Tukey fast Fourier transform in USASI basic Fortran.
C multi-dimensional transform, each dimension a power of two,
C complex or real data.
C TRANSFORM(K1,K2,...) = SUM(DATA(J1,J2,...)*EXP(ISIGN*2*PI*SQRT(-1)
C *((J1-1)*(K1-1)/N(1)+(J2-1)*(K2-1)/N(2)+...))), summed for all
C J1 and K1 from 1 to N(1), J2 and K2 from 1 TO N(2),
C etc, for all NDIM subscripts. NDIM must be positive and
C each N(IDIM) must be a power of two. ISIGN is +1 or -1.
C Let NTOT = N(1)*N(2)*...*N(NDIM). Then a -1 transform
C followed by a +1 one (or vice versa) returns NTOT
C times the original data.
C IFORM = 1, 0 or -1, as data is
C complex, real, or the first half of a complex array. Transform
C values are returned in array DATA. They are complex, real, or
C the first half of a complex array, as IFORM = 1, -1 or 0.
C The transform of a real array (IFORM = 0) dimensioned N(1) by N(2)
C by ... will be returned in the same array, now considered to
C be complex of dimensions N(1)/2+1 by N(2) by .... Note that if
C IFORM = 0 or -1, N(1) must be even, and enough room must be
C reserved. The missing values may be obtained by complex conjuga-
C tion.
C The reverse transformation of a half complex array dimensioned
C N(1)/2+1 by N(2) by ..., is accomplished by setting IFORM
C to -1. In the N array, N(1) must be the true N(1), not N(1)/2+1.
C The transform will be real and returned to the input array.
C Running time is proportional to NTOT*LOG2(NTOT), rather than
C the naive NTOT**2. Furthermore, less error is built up.
C Written by Norman Brenner of MIT Lincoln Laboratory, January 1969.
C See IEEE Audio Transactions (June 1967), Special issue on FFT.
parameter(NMAX=2048*1024)
DIMENSION DATA(NMAX), N(1)
NTOT=1
DO 10 IDIM=1,NDIM
10 NTOT=NTOT*N(IDIM)
IF (IFORM) 70,20,20
20 NREM=NTOT
DO 60 IDIM=1,NDIM
NREM=NREM/N(IDIM)
NPREV=NTOT/(N(IDIM)*NREM)
NCURR=N(IDIM)
IF (IDIM-1+IFORM) 30,30,40
30 NCURR=NCURR/2
40 CALL BITRV (DATA,NPREV,NCURR,NREM)
CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN)
IF (IDIM-1+IFORM) 50,50,60
50 CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM)
NTOT=(NTOT/N(1))*(N(1)/2+1)
60 CONTINUE
RETURN
70 NTOT=(NTOT/N(1))*(N(1)/2+1)
NREM=1
DO 100 JDIM=1,NDIM
IDIM=NDIM+1-JDIM
NCURR=N(IDIM)
IF (IDIM-1) 80,80,90
80 NCURR=NCURR/2
CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM)
NTOT=NTOT/(N(1)/2+1)*N(1)
90 NPREV=NTOT/(N(IDIM)*NREM)
CALL BITRV (DATA,NPREV,NCURR,NREM)
CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN)
100 NREM=NREM*N(IDIM)
RETURN
END
SUBROUTINE BITRV (DATA,NPREV,N,NREM)
C SHUFFLE THE DATA BY BIT REVERSAL.
C DIMENSION DATA(NPREV,N,NREM)
C COMPLEX DATA
C EXCHANGE DATA(J1,J4REV,J5) WITH DATA(J1,J4,J5) FOR ALL J1 FROM 1
C TO NPREV, ALL J4 FROM 1 TO N (WHICH MUST BE A POWER OF TWO), AND
C ALL J5 FROM 1 TO NREM. J4REV-1 IS THE BIT REVERSAL OF J4-1. E.G.
C SUPPOSE N = 32. THEN FOR J4-1 = 10011, J4REV-1 = 11001, ETC.
parameter(NMAX=2048*1024)
DIMENSION DATA(NMAX)
IP0=2
IP1=IP0*NPREV
IP4=IP1*N
IP5=IP4*NREM
I4REV=1
C I4REV = 1+(J4REV-1)*IP1
DO 60 I4=1,IP4,IP1
C I4 = 1+(J4-1)*IP1
IF (I4-I4REV) 10,30,30
10 I1MAX=I4+IP1-IP0
DO 20 I1=I4,I1MAX,IP0
C I1 = 1+(J1-1)*IP0+(J4-1)*IP1
DO 20 I5=I1,IP5,IP4
C I5 = 1+(J1-1)*IP0+(J4-1)*IP1+(J5-1)*IP4
I5REV=I4REV+I5-I4
C I5REV = 1+(J1-1)*IP0+(J4REV-1)*IP1+(J5-1)*IP4
TEMPR=DATA(I5)
TEMPI=DATA(I5+1)
DATA(I5)=DATA(I5REV)
DATA(I5+1)=DATA(I5REV+1)
DATA(I5REV)=TEMPR
20 DATA(I5REV+1)=TEMPI
C ADD ONE WITH DOWNWARD CARRY TO THE HIGH ORDER BIT OF J4REV-1.
30 IP2=IP4/2
40 IF (I4REV-IP2) 60,60,50
50 I4REV=I4REV-IP2
IP2=IP2/2
IF (IP2-IP1) 60,40,40
60 I4REV=I4REV+IP2
RETURN
END
SUBROUTINE COOL2 (DATA,NPREV,N,NREM,ISIGN)
C DISCRETE FOURIER TRANSFORM OF LENGTH N. IN-PLACE COOLEY-TUKEY
C ALGORITHM, BIT-REVERSED TO NORMAL ORDER, SANDE-TUKEY PHASE SHIFTS.
C DIMENSION DATA(NPREV,N,NREM)
C COMPLEX DATA
C DATA(J1,K4,J5) = SUM(DATA(J1,J4,J5)*EXP(ISIGN*2*PI*I*(J4-1)*
C (K4-1)/N)), SUMMED OVER J4 = 1 TO N FOR ALL J1 FROM 1 TO NPREV,
C K4 FROM 1 TO N AND J5 FROM 1 TO NREM. N MUST BE A POWER OF TWO.
C METHOD--LET IPREV TAKE THE VALUES 1, 2 OR 4, 4 OR 8, ..., N/16,
C N/4, N. THE CHOICE BETWEEN 2 OR 4, ETC., DEPENDS ON WHETHER N IS
C A POWER OF FOUR. DEFINE IFACT = 2 OR 4, THE NEXT FACTOR THAT
C IPREV MUST TAKE, AND IREM = N/(IFACT*IPREV). THEN--
C DIMENSION DATA(NPREV,IPREV,IFACT,IREM,NREM)
C COMPLEX DATA
C DATA(J1,J2,K3,J4,J5) = SUM(DATA(J1,J2,J3,J4,J5)*EXP(ISIGN*2*PI*I*
C (K3-1)*((J3-1)/IFACT+(J2-1)/(IFACT*IPREV)))), SUMMED OVER J3 = 1
C TO IFACT FOR ALL J1 FROM 1 TO NPREV, J2 FROM 1 TO IPREV, K3 FROM
C 1 TO IFACT, J4 FROM 1 TO IREM AND J5 FROM 1 TO NREM. THIS IS
C A PHASE-SHIFTED DISCRETE FOURIER TRANSFORM OF LENGTH IFACT.
C FACTORING N BY FOURS SAVES ABOUT TWENTY FIVE PERCENT OVER FACTOR-
C ING BY TWOS. DATA MUST BE BIT-REVERSED INITIALLY.
C IT IS NOT NECESSARY TO REWRITE THIS SUBROUTINE INTO COMPLEX
C NOTATION SO LONG AS THE FORTRAN COMPILER USED STORES REAL AND
C IMAGINARY PARTS IN ADJACENT STORAGE LOCATIONS. IT MUST ALSO
C STORE ARRAYS WITH THE FIRST SUBSCRIPT INCREASING FASTEST.
parameter(NMAX=2048*1024)
DIMENSION DATA(NMAX)
real*8 twopi,wstpr,wstpi,wr,wi,w2r,w2i,w3r,w3i,wtempr
TWOPI=6.2831853072*FLOAT(ISIGN)
IP0=2
IP1=IP0*NPREV
IP4=IP1*N
IP5=IP4*NREM
IP2=IP1
C IP2=IP1*IPROD
NPART=N
10 IF (NPART-2) 60,30,20
20 NPART=NPART/4
GO TO 10
C DO A FOURIER TRANSFORM OF LENGTH TWO
30 IF (IP2-IP4) 40,160,160
40 IP3=IP2*2
C IP3=IP2*IFACT
DO 50 I1=1,IP1,IP0
C I1 = 1+(J1-1)*IP0
DO 50 I5=I1,IP5,IP3
C I5 = 1+(J1-1)*IP0+(J4-1)*IP3+(J5-1)*IP4
I3A=I5
I3B=I3A+IP2
C I3 = 1+(J1-1)*IP0+(J2-1)*IP1+(J3-1)*IP2+(J4-1)*IP3+(J5-1)*IP4
TEMPR=DATA(I3B)
TEMPI=DATA(I3B+1)
DATA(I3B)=DATA(I3A)-TEMPR
DATA(I3B+1)=DATA(I3A+1)-TEMPI
DATA(I3A)=DATA(I3A)+TEMPR
50 DATA(I3A+1)=DATA(I3A+1)+TEMPI
IP2=IP3
C DO A FOURIER TRANSFORM OF LENGTH FOUR (FROM BIT REVERSED ORDER)
60 IF (IP2-IP4) 70,160,160
70 IP3=IP2*4
C IP3=IP2*IFACT
C COMPUTE TWOPI THRU WR AND WI IN DOUBLE PRECISION, IF AVAILABLE.
THETA=TWOPI/FLOAT(IP3/IP1)
SINTH=SIN(THETA/2)
WSTPR=-2*SINTH*SINTH
WSTPI=SIN(THETA)
WR=1.
WI=0.
DO 150 I2=1,IP2,IP1
C I2 = 1+(J2-1)*IP1
IF (I2-1) 90,90,80
80 W2R=WR*WR-WI*WI
W2I=2*WR*WI
W3R=W2R*WR-W2I*WI
W3I=W2R*WI+W2I*WR
90 I1MAX=I2+IP1-IP0
DO 140 I1=I2,I1MAX,IP0
C I1 = 1+(J1-1)*IP0+(J2-1)*IP1
DO 140 I5=I1,IP5,IP3
C I5 = 1+(J1-1)*IP0+(J2-1)*IP1+(J4-1)*IP3+(J5-1)*IP4
I3A=I5
I3B=I3A+IP2
I3C=I3B+IP2
I3D=I3C+IP2
C I3 = 1+(J1-1)*IP0+(J2-1)*IP1+(J3-1)*IP2+(J4-1)*IP3+(J5-1)*IP4
IF (I2-1) 110,110,100
C APPLY THE PHASE SHIFT FACTORS
100 TEMPR=DATA(I3B)
DATA(I3B)=W2R*DATA(I3B)-W2I*DATA(I3B+1)
DATA(I3B+1)=W2R*DATA(I3B+1)+W2I*TEMPR
TEMPR=DATA(I3C)
DATA(I3C)=WR*DATA(I3C)-WI*DATA(I3C+1)
DATA(I3C+1)=WR*DATA(I3C+1)+WI*TEMPR
TEMPR=DATA(I3D)
DATA(I3D)=W3R*DATA(I3D)-W3I*DATA(I3D+1)
DATA(I3D+1)=W3R*DATA(I3D+1)+W3I*TEMPR
110 T0R=DATA(I3A)+DATA(I3B)
T0I=DATA(I3A+1)+DATA(I3B+1)
T1R=DATA(I3A)-DATA(I3B)
T1I=DATA(I3A+1)-DATA(I3B+1)
T2R=DATA(I3C)+DATA(I3D)
T2I=DATA(I3C+1)+DATA(I3D+1)
T3R=DATA(I3C)-DATA(I3D)
T3I=DATA(I3C+1)-DATA(I3D+1)
DATA(I3A)=T0R+T2R
DATA(I3A+1)=T0I+T2I
DATA(I3C)=T0R-T2R
DATA(I3C+1)=T0I-T2I
IF (ISIGN) 120,120,130
120 T3R=-T3R
T3I=-T3I
130 DATA(I3B)=T1R-T3I
DATA(I3B+1)=T1I+T3R
DATA(I3D)=T1R+T3I
140 DATA(I3D+1)=T1I-T3R
WTEMPR=WR
WR=WSTPR*WTEMPR-WSTPI*WI+WTEMPR
150 WI=WSTPR*WI+WSTPI*WTEMPR+WI
IP2=IP3
GO TO 60
160 RETURN
END
SUBROUTINE FIXRL (DATA,N,NREM,ISIGN,IFORM)
C FOR IFORM = 0, CONVERT THE TRANSFORM OF A DOUBLED-UP REAL ARRAY,
C CONSIDERED COMPLEX, INTO ITS TRUE TRANSFORM. SUPPLY ONLY THE
C FIRST HALF OF THE COMPLEX TRANSFORM, AS THE SECOND HALF HAS
C CONJUGATE SYMMETRY. FOR IFORM = -1, CONVERT THE FIRST HALF
C OF THE TRUE TRANSFORM INTO THE TRANSFORM OF A DOUBLED-UP REAL
C ARRAY. N MUST BE EVEN.
C USING COMPLEX NOTATION AND SUBSCRIPTS STARTING AT ZERO, THE
C TRANSFORMATION IS--
C DIMENSION DATA(N,NREM)
C ZSTP = EXP(ISIGN*2*PI*I/N)
C DO 10 I2=0,NREM-1
C DATA(0,I2) = CONJ(DATA(0,I2))*(1+I)
C DO 10 I1=1,N/4
C Z = (1+(2*IFORM+1)*I*ZSTP**I1)/2
C I1CNJ = N/2-I1
C DIF = DATA(I1,I2)-CONJ(DATA(I1CNJ,I2))
C TEMP = Z*DIF
C DATA(I1,I2) = (DATA(I1,I2)-TEMP)*(1-IFORM)
C 10 DATA(I1CNJ,I2) = (DATA(I1CNJ,I2)+CONJ(TEMP))*(1-IFORM)
C IF I1=I1CNJ, THE CALCULATION FOR THAT VALUE COLLAPSES INTO
C A SIMPLE CONJUGATION OF DATA(I1,I2).
parameter(NMAX=2048*1024)
DIMENSION DATA(NMAX)
TWOPI=6.283185307*FLOAT(ISIGN)
IP0=2
IP1=IP0*(N/2)
IP2=IP1*NREM
IF (IFORM) 10,70,70
C PACK THE REAL INPUT VALUES (TWO PER COLUMN)
10 J1=IP1+1
DATA(2)=DATA(J1)
IF (NREM-1) 70,70,20
20 J1=J1+IP0
I2MIN=IP1+1
DO 60 I2=I2MIN,IP2,IP1
DATA(I2)=DATA(J1)
J1=J1+IP0
IF (N-2) 50,50,30
30 I1MIN=I2+IP0
I1MAX=I2+IP1-IP0
DO 40 I1=I1MIN,I1MAX,IP0
DATA(I1)=DATA(J1)
DATA(I1+1)=DATA(J1+1)
40 J1=J1+IP0
50 DATA(I2+1)=DATA(J1)
60 J1=J1+IP0
70 DO 80 I2=1,IP2,IP1
TEMPR=DATA(I2)
DATA(I2)=DATA(I2)+DATA(I2+1)
80 DATA(I2+1)=TEMPR-DATA(I2+1)
IF (N-2) 200,200,90
90 THETA=TWOPI/FLOAT(N)
SINTH=SIN(THETA/2.)
ZSTPR=-2.*SINTH*SINTH
ZSTPI=SIN(THETA)
ZR=(1.-ZSTPI)/2.
ZI=(1.+ZSTPR)/2.
IF (IFORM) 100,110,110
100 ZR=1.-ZR
ZI=-ZI
110 I1MIN=IP0+1
I1MAX=IP0*(N/4)+1
DO 190 I1=I1MIN,I1MAX,IP0
DO 180 I2=I1,IP2,IP1
I2CNJ=IP0*(N/2+1)-2*I1+I2
IF (I2-I2CNJ) 150,120,120
120 IF (ISIGN*(2*IFORM+1)) 130,140,140
130 DATA(I2+1)=-DATA(I2+1)
140 IF (IFORM) 170,180,180
150 DIFR=DATA(I2)-DATA(I2CNJ)
DIFI=DATA(I2+1)+DATA(I2CNJ+1)
TEMPR=DIFR*ZR-DIFI*ZI
TEMPI=DIFR*ZI+DIFI*ZR
DATA(I2)=DATA(I2)-TEMPR
DATA(I2+1)=DATA(I2+1)-TEMPI
DATA(I2CNJ)=DATA(I2CNJ)+TEMPR
DATA(I2CNJ+1)=DATA(I2CNJ+1)-TEMPI
IF (IFORM) 160,180,180
160 DATA(I2CNJ)=DATA(I2CNJ)+DATA(I2CNJ)
DATA(I2CNJ+1)=DATA(I2CNJ+1)+DATA(I2CNJ+1)
170 DATA(I2)=DATA(I2)+DATA(I2)
DATA(I2+1)=DATA(I2+1)+DATA(I2+1)
180 CONTINUE
TEMPR=ZR-.5
ZR=ZSTPR*TEMPR-ZSTPI*ZI+ZR
190 ZI=ZSTPR*ZI+ZSTPI*TEMPR+ZI
C RECURSION SAVES TIME, AT A SLIGHT LOSS IN ACCURACY. IF AVAILABLE,
C USE DOUBLE PRECISION TO COMPUTE ZR AND ZI.
200 IF (IFORM) 270,210,210
C UNPACK THE REAL TRANSFORM VALUES (TWO PER COLUMN)
210 I2=IP2+1
I1=I2
J1=IP0*(N/2+1)*NREM+1
GO TO 250
220 DATA(J1)=DATA(I1)
DATA(J1+1)=DATA(I1+1)
I1=I1-IP0
J1=J1-IP0
230 IF (I2-I1) 220,240,240
240 DATA(J1)=DATA(I1)
DATA(J1+1)=0.
250 I2=I2-IP1
J1=J1-IP0
DATA(J1)=DATA(I2+1)
DATA(J1+1)=0.
I1=I1-IP0
J1=J1-IP0
IF (I2-1) 260,260,230
260 DATA(2)=0.
270 RETURN
END
SUBROUTINE FOUR2a (DATA,N,NDIM,ISIGN,IFORM)
C Cooley-Tukey fast Fourier transform in USASI basic Fortran.
C multi-dimensional transform, each dimension a power of two,
C complex or real data.
C TRANSFORM(K1,K2,...) = SUM(DATA(J1,J2,...)*EXP(ISIGN*2*PI*SQRT(-1)
C *((J1-1)*(K1-1)/N(1)+(J2-1)*(K2-1)/N(2)+...))), summed for all
C J1 and K1 from 1 to N(1), J2 and K2 from 1 TO N(2),
C etc, for all NDIM subscripts. NDIM must be positive and
C each N(IDIM) must be a power of two. ISIGN is +1 or -1.
C Let NTOT = N(1)*N(2)*...*N(NDIM). Then a -1 transform
C followed by a +1 one (or vice versa) returns NTOT
C times the original data.
C IFORM = 1, 0 or -1, as data is
C complex, real, or the first half of a complex array. Transform
C values are returned in array DATA. They are complex, real, or
C the first half of a complex array, as IFORM = 1, -1 or 0.
C The transform of a real array (IFORM = 0) dimensioned N(1) by N(2)
C by ... will be returned in the same array, now considered to
C be complex of dimensions N(1)/2+1 by N(2) by .... Note that if
C IFORM = 0 or -1, N(1) must be even, and enough room must be
C reserved. The missing values may be obtained by complex conjuga-
C tion.
C The reverse transformation of a half complex array dimensioned
C N(1)/2+1 by N(2) by ..., is accomplished by setting IFORM
C to -1. In the N array, N(1) must be the true N(1), not N(1)/2+1.
C The transform will be real and returned to the input array.
C Running time is proportional to NTOT*LOG2(NTOT), rather than
C the naive NTOT**2. Furthermore, less error is built up.
C Written by Norman Brenner of MIT Lincoln Laboratory, January 1969.
C See IEEE Audio Transactions (June 1967), Special issue on FFT.
parameter(NMAX=2048*1024)
DIMENSION DATA(NMAX), N(1)
NTOT=1
DO 10 IDIM=1,NDIM
10 NTOT=NTOT*N(IDIM)
IF (IFORM) 70,20,20
20 NREM=NTOT
DO 60 IDIM=1,NDIM
NREM=NREM/N(IDIM)
NPREV=NTOT/(N(IDIM)*NREM)
NCURR=N(IDIM)
IF (IDIM-1+IFORM) 30,30,40
30 NCURR=NCURR/2
40 CALL BITRV (DATA,NPREV,NCURR,NREM)
CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN)
IF (IDIM-1+IFORM) 50,50,60
50 CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM)
NTOT=(NTOT/N(1))*(N(1)/2+1)
60 CONTINUE
RETURN
70 NTOT=(NTOT/N(1))*(N(1)/2+1)
NREM=1
DO 100 JDIM=1,NDIM
IDIM=NDIM+1-JDIM
NCURR=N(IDIM)
IF (IDIM-1) 80,80,90
80 NCURR=NCURR/2
CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM)
NTOT=NTOT/(N(1)/2+1)*N(1)
90 NPREV=NTOT/(N(IDIM)*NREM)
CALL BITRV (DATA,NPREV,NCURR,NREM)
CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN)
100 NREM=NREM*N(IDIM)
RETURN
END
SUBROUTINE BITRV (DATA,NPREV,N,NREM)
C SHUFFLE THE DATA BY BIT REVERSAL.
C DIMENSION DATA(NPREV,N,NREM)
C COMPLEX DATA
C EXCHANGE DATA(J1,J4REV,J5) WITH DATA(J1,J4,J5) FOR ALL J1 FROM 1
C TO NPREV, ALL J4 FROM 1 TO N (WHICH MUST BE A POWER OF TWO), AND
C ALL J5 FROM 1 TO NREM. J4REV-1 IS THE BIT REVERSAL OF J4-1. E.G.
C SUPPOSE N = 32. THEN FOR J4-1 = 10011, J4REV-1 = 11001, ETC.
parameter(NMAX=2048*1024)
DIMENSION DATA(NMAX)
IP0=2
IP1=IP0*NPREV
IP4=IP1*N
IP5=IP4*NREM
I4REV=1
C I4REV = 1+(J4REV-1)*IP1
DO 60 I4=1,IP4,IP1
C I4 = 1+(J4-1)*IP1
IF (I4-I4REV) 10,30,30
10 I1MAX=I4+IP1-IP0
DO 20 I1=I4,I1MAX,IP0
C I1 = 1+(J1-1)*IP0+(J4-1)*IP1
DO 20 I5=I1,IP5,IP4
C I5 = 1+(J1-1)*IP0+(J4-1)*IP1+(J5-1)*IP4
I5REV=I4REV+I5-I4
C I5REV = 1+(J1-1)*IP0+(J4REV-1)*IP1+(J5-1)*IP4
TEMPR=DATA(I5)
TEMPI=DATA(I5+1)
DATA(I5)=DATA(I5REV)
DATA(I5+1)=DATA(I5REV+1)
DATA(I5REV)=TEMPR
20 DATA(I5REV+1)=TEMPI
C ADD ONE WITH DOWNWARD CARRY TO THE HIGH ORDER BIT OF J4REV-1.
30 IP2=IP4/2
40 IF (I4REV-IP2) 60,60,50
50 I4REV=I4REV-IP2
IP2=IP2/2
IF (IP2-IP1) 60,40,40
60 I4REV=I4REV+IP2
RETURN
END
SUBROUTINE COOL2 (DATA,NPREV,N,NREM,ISIGN)
C DISCRETE FOURIER TRANSFORM OF LENGTH N. IN-PLACE COOLEY-TUKEY
C ALGORITHM, BIT-REVERSED TO NORMAL ORDER, SANDE-TUKEY PHASE SHIFTS.
C DIMENSION DATA(NPREV,N,NREM)
C COMPLEX DATA
C DATA(J1,K4,J5) = SUM(DATA(J1,J4,J5)*EXP(ISIGN*2*PI*I*(J4-1)*
C (K4-1)/N)), SUMMED OVER J4 = 1 TO N FOR ALL J1 FROM 1 TO NPREV,
C K4 FROM 1 TO N AND J5 FROM 1 TO NREM. N MUST BE A POWER OF TWO.
C METHOD--LET IPREV TAKE THE VALUES 1, 2 OR 4, 4 OR 8, ..., N/16,
C N/4, N. THE CHOICE BETWEEN 2 OR 4, ETC., DEPENDS ON WHETHER N IS
C A POWER OF FOUR. DEFINE IFACT = 2 OR 4, THE NEXT FACTOR THAT
C IPREV MUST TAKE, AND IREM = N/(IFACT*IPREV). THEN--
C DIMENSION DATA(NPREV,IPREV,IFACT,IREM,NREM)
C COMPLEX DATA
C DATA(J1,J2,K3,J4,J5) = SUM(DATA(J1,J2,J3,J4,J5)*EXP(ISIGN*2*PI*I*
C (K3-1)*((J3-1)/IFACT+(J2-1)/(IFACT*IPREV)))), SUMMED OVER J3 = 1
C TO IFACT FOR ALL J1 FROM 1 TO NPREV, J2 FROM 1 TO IPREV, K3 FROM
C 1 TO IFACT, J4 FROM 1 TO IREM AND J5 FROM 1 TO NREM. THIS IS
C A PHASE-SHIFTED DISCRETE FOURIER TRANSFORM OF LENGTH IFACT.
C FACTORING N BY FOURS SAVES ABOUT TWENTY FIVE PERCENT OVER FACTOR-
C ING BY TWOS. DATA MUST BE BIT-REVERSED INITIALLY.
C IT IS NOT NECESSARY TO REWRITE THIS SUBROUTINE INTO COMPLEX
C NOTATION SO LONG AS THE FORTRAN COMPILER USED STORES REAL AND
C IMAGINARY PARTS IN ADJACENT STORAGE LOCATIONS. IT MUST ALSO
C STORE ARRAYS WITH THE FIRST SUBSCRIPT INCREASING FASTEST.
parameter(NMAX=2048*1024)
DIMENSION DATA(NMAX)
real*8 twopi,wstpr,wstpi,wr,wi,w2r,w2i,w3r,w3i,wtempr
TWOPI=6.2831853072*FLOAT(ISIGN)
IP0=2
IP1=IP0*NPREV
IP4=IP1*N
IP5=IP4*NREM
IP2=IP1
C IP2=IP1*IPROD
NPART=N
10 IF (NPART-2) 60,30,20
20 NPART=NPART/4
GO TO 10
C DO A FOURIER TRANSFORM OF LENGTH TWO
30 IF (IP2-IP4) 40,160,160
40 IP3=IP2*2
C IP3=IP2*IFACT
DO 50 I1=1,IP1,IP0
C I1 = 1+(J1-1)*IP0
DO 50 I5=I1,IP5,IP3
C I5 = 1+(J1-1)*IP0+(J4-1)*IP3+(J5-1)*IP4
I3A=I5
I3B=I3A+IP2
C I3 = 1+(J1-1)*IP0+(J2-1)*IP1+(J3-1)*IP2+(J4-1)*IP3+(J5-1)*IP4
TEMPR=DATA(I3B)
TEMPI=DATA(I3B+1)
DATA(I3B)=DATA(I3A)-TEMPR
DATA(I3B+1)=DATA(I3A+1)-TEMPI
DATA(I3A)=DATA(I3A)+TEMPR
50 DATA(I3A+1)=DATA(I3A+1)+TEMPI
IP2=IP3
C DO A FOURIER TRANSFORM OF LENGTH FOUR (FROM BIT REVERSED ORDER)
60 IF (IP2-IP4) 70,160,160
70 IP3=IP2*4
C IP3=IP2*IFACT
C COMPUTE TWOPI THRU WR AND WI IN DOUBLE PRECISION, IF AVAILABLE.
THETA=TWOPI/FLOAT(IP3/IP1)
SINTH=SIN(THETA/2)
WSTPR=-2*SINTH*SINTH
WSTPI=SIN(THETA)
WR=1.
WI=0.
DO 150 I2=1,IP2,IP1
C I2 = 1+(J2-1)*IP1
IF (I2-1) 90,90,80
80 W2R=WR*WR-WI*WI
W2I=2*WR*WI
W3R=W2R*WR-W2I*WI
W3I=W2R*WI+W2I*WR
90 I1MAX=I2+IP1-IP0
DO 140 I1=I2,I1MAX,IP0
C I1 = 1+(J1-1)*IP0+(J2-1)*IP1
DO 140 I5=I1,IP5,IP3
C I5 = 1+(J1-1)*IP0+(J2-1)*IP1+(J4-1)*IP3+(J5-1)*IP4
I3A=I5
I3B=I3A+IP2
I3C=I3B+IP2
I3D=I3C+IP2
C I3 = 1+(J1-1)*IP0+(J2-1)*IP1+(J3-1)*IP2+(J4-1)*IP3+(J5-1)*IP4
IF (I2-1) 110,110,100
C APPLY THE PHASE SHIFT FACTORS
100 TEMPR=DATA(I3B)
DATA(I3B)=W2R*DATA(I3B)-W2I*DATA(I3B+1)
DATA(I3B+1)=W2R*DATA(I3B+1)+W2I*TEMPR
TEMPR=DATA(I3C)
DATA(I3C)=WR*DATA(I3C)-WI*DATA(I3C+1)
DATA(I3C+1)=WR*DATA(I3C+1)+WI*TEMPR
TEMPR=DATA(I3D)
DATA(I3D)=W3R*DATA(I3D)-W3I*DATA(I3D+1)
DATA(I3D+1)=W3R*DATA(I3D+1)+W3I*TEMPR
110 T0R=DATA(I3A)+DATA(I3B)
T0I=DATA(I3A+1)+DATA(I3B+1)
T1R=DATA(I3A)-DATA(I3B)
T1I=DATA(I3A+1)-DATA(I3B+1)
T2R=DATA(I3C)+DATA(I3D)
T2I=DATA(I3C+1)+DATA(I3D+1)
T3R=DATA(I3C)-DATA(I3D)
T3I=DATA(I3C+1)-DATA(I3D+1)
DATA(I3A)=T0R+T2R
DATA(I3A+1)=T0I+T2I
DATA(I3C)=T0R-T2R
DATA(I3C+1)=T0I-T2I
IF (ISIGN) 120,120,130
120 T3R=-T3R
T3I=-T3I
130 DATA(I3B)=T1R-T3I
DATA(I3B+1)=T1I+T3R
DATA(I3D)=T1R+T3I
140 DATA(I3D+1)=T1I-T3R
WTEMPR=WR
WR=WSTPR*WTEMPR-WSTPI*WI+WTEMPR
150 WI=WSTPR*WI+WSTPI*WTEMPR+WI
IP2=IP3
GO TO 60
160 RETURN
END
SUBROUTINE FIXRL (DATA,N,NREM,ISIGN,IFORM)
C FOR IFORM = 0, CONVERT THE TRANSFORM OF A DOUBLED-UP REAL ARRAY,
C CONSIDERED COMPLEX, INTO ITS TRUE TRANSFORM. SUPPLY ONLY THE
C FIRST HALF OF THE COMPLEX TRANSFORM, AS THE SECOND HALF HAS
C CONJUGATE SYMMETRY. FOR IFORM = -1, CONVERT THE FIRST HALF
C OF THE TRUE TRANSFORM INTO THE TRANSFORM OF A DOUBLED-UP REAL
C ARRAY. N MUST BE EVEN.
C USING COMPLEX NOTATION AND SUBSCRIPTS STARTING AT ZERO, THE
C TRANSFORMATION IS--
C DIMENSION DATA(N,NREM)
C ZSTP = EXP(ISIGN*2*PI*I/N)
C DO 10 I2=0,NREM-1
C DATA(0,I2) = CONJ(DATA(0,I2))*(1+I)
C DO 10 I1=1,N/4
C Z = (1+(2*IFORM+1)*I*ZSTP**I1)/2
C I1CNJ = N/2-I1
C DIF = DATA(I1,I2)-CONJ(DATA(I1CNJ,I2))
C TEMP = Z*DIF
C DATA(I1,I2) = (DATA(I1,I2)-TEMP)*(1-IFORM)
C 10 DATA(I1CNJ,I2) = (DATA(I1CNJ,I2)+CONJ(TEMP))*(1-IFORM)
C IF I1=I1CNJ, THE CALCULATION FOR THAT VALUE COLLAPSES INTO
C A SIMPLE CONJUGATION OF DATA(I1,I2).
parameter(NMAX=2048*1024)
DIMENSION DATA(NMAX)
TWOPI=6.283185307*FLOAT(ISIGN)
IP0=2
IP1=IP0*(N/2)
IP2=IP1*NREM
IF (IFORM) 10,70,70
C PACK THE REAL INPUT VALUES (TWO PER COLUMN)
10 J1=IP1+1
DATA(2)=DATA(J1)
IF (NREM-1) 70,70,20
20 J1=J1+IP0
I2MIN=IP1+1
DO 60 I2=I2MIN,IP2,IP1
DATA(I2)=DATA(J1)
J1=J1+IP0
IF (N-2) 50,50,30
30 I1MIN=I2+IP0
I1MAX=I2+IP1-IP0
DO 40 I1=I1MIN,I1MAX,IP0
DATA(I1)=DATA(J1)
DATA(I1+1)=DATA(J1+1)
40 J1=J1+IP0
50 DATA(I2+1)=DATA(J1)
60 J1=J1+IP0
70 DO 80 I2=1,IP2,IP1
TEMPR=DATA(I2)
DATA(I2)=DATA(I2)+DATA(I2+1)
80 DATA(I2+1)=TEMPR-DATA(I2+1)
IF (N-2) 200,200,90
90 THETA=TWOPI/FLOAT(N)
SINTH=SIN(THETA/2.)
ZSTPR=-2.*SINTH*SINTH
ZSTPI=SIN(THETA)
ZR=(1.-ZSTPI)/2.
ZI=(1.+ZSTPR)/2.
IF (IFORM) 100,110,110
100 ZR=1.-ZR
ZI=-ZI
110 I1MIN=IP0+1
I1MAX=IP0*(N/4)+1
DO 190 I1=I1MIN,I1MAX,IP0
DO 180 I2=I1,IP2,IP1
I2CNJ=IP0*(N/2+1)-2*I1+I2
IF (I2-I2CNJ) 150,120,120
120 IF (ISIGN*(2*IFORM+1)) 130,140,140
130 DATA(I2+1)=-DATA(I2+1)
140 IF (IFORM) 170,180,180
150 DIFR=DATA(I2)-DATA(I2CNJ)
DIFI=DATA(I2+1)+DATA(I2CNJ+1)
TEMPR=DIFR*ZR-DIFI*ZI
TEMPI=DIFR*ZI+DIFI*ZR
DATA(I2)=DATA(I2)-TEMPR
DATA(I2+1)=DATA(I2+1)-TEMPI
DATA(I2CNJ)=DATA(I2CNJ)+TEMPR
DATA(I2CNJ+1)=DATA(I2CNJ+1)-TEMPI
IF (IFORM) 160,180,180
160 DATA(I2CNJ)=DATA(I2CNJ)+DATA(I2CNJ)
DATA(I2CNJ+1)=DATA(I2CNJ+1)+DATA(I2CNJ+1)
170 DATA(I2)=DATA(I2)+DATA(I2)
DATA(I2+1)=DATA(I2+1)+DATA(I2+1)
180 CONTINUE
TEMPR=ZR-.5
ZR=ZSTPR*TEMPR-ZSTPI*ZI+ZR
190 ZI=ZSTPR*ZI+ZSTPI*TEMPR+ZI
C RECURSION SAVES TIME, AT A SLIGHT LOSS IN ACCURACY. IF AVAILABLE,
C USE DOUBLE PRECISION TO COMPUTE ZR AND ZI.
200 IF (IFORM) 270,210,210
C UNPACK THE REAL TRANSFORM VALUES (TWO PER COLUMN)
210 I2=IP2+1
I1=I2
J1=IP0*(N/2+1)*NREM+1
GO TO 250
220 DATA(J1)=DATA(I1)
DATA(J1+1)=DATA(I1+1)
I1=I1-IP0
J1=J1-IP0
230 IF (I2-I1) 220,240,240
240 DATA(J1)=DATA(I1)
DATA(J1+1)=0.
250 I2=I2-IP1
J1=J1-IP0
DATA(J1)=DATA(I2+1)
DATA(J1+1)=0.
I1=I1-IP0
J1=J1-IP0
IF (I2-1) 260,260,230
260 DATA(2)=0.
270 RETURN
END

156
four2a.f
View File

@ -1,75 +1,81 @@
SUBROUTINE FOUR2a (a,nfft,NDIM,ISIGN,IFORM)
C IFORM = 1, 0 or -1, as data is
C complex, real, or the first half of a complex array. Transform
C values are returned in array DATA. They are complex, real, or
C the first half of a complex array, as IFORM = 1, -1 or 0.
C The transform of a real array (IFORM = 0) dimensioned N(1) by N(2)
C by ... will be returned in the same array, now considered to
C be complex of dimensions N(1)/2+1 by N(2) by .... Note that if
C IFORM = 0 or -1, N(1) must be even, and enough room must be
C reserved. The missing values may be obtained by complex conjuga-
C tion.
C The reverse transformation of a half complex array dimensioned
C N(1)/2+1 by N(2) by ..., is accomplished by setting IFORM
C to -1. In the N array, N(1) must be the true N(1), not N(1)/2+1.
C The transform will be real and returned to the input array.
parameter (NPMAX=100)
complex a(nfft)
integer nn(NPMAX),ns(NPMAX),nf(NPMAX),nl(NPMAX)
integer plan(NPMAX)
data nplan/0/
include 'fftw3.f'
save
if(nfft.lt.0) go to 999
nloc=loc(a)
do i=1,nplan
if(nfft.eq.nn(i) .and. isign.eq.ns(i) .and.
+ iform.eq.nf(i) .and. nloc.eq.nl(i)) go to 10
enddo
if(nplan.ge.NPMAX) stop 'Too many FFTW plans requested.'
nplan=nplan+1
i=nplan
nn(i)=nfft
ns(i)=isign
nf(i)=iform
nl(i)=nloc
C Planning: FFTW_ESTIMATE, FFTW_MEASURE, FFTW_PATIENT, FFTW_EXHAUSTIVE
nspeed=FFTW_ESTIMATE
if(nfft.le.16384) nspeed=FFTW_MEASURE
if(isign.eq.-1 .and. iform.eq.1) then
call sfftw_plan_dft_1d_(plan(i),nfft,a,a,
+ FFTW_FORWARD,nspeed)
else if(isign.eq.1 .and. iform.eq.1) then
call sfftw_plan_dft_1d_(plan(i),nfft,a,a,
+ FFTW_BACKWARD,nspeed)
else if(isign.eq.-1 .and. iform.eq.0) then
call sfftw_plan_dft_r2c_1d_(plan(i),nfft,a,a,nspeed)
else if(isign.eq.1 .and. iform.eq.-1) then
call sfftw_plan_dft_c2r_1d_(plan(i),nfft,a,a,nspeed)
else
stop 'Unsupported request in four2a'
endif
i=nplan
! write(*,3001) i,nn(i),ns(i),nf(i),nl(i),plan(i)
! 3001 format(6i10)
10 call sfftw_execute_(plan(i))
return
999 do i=1,nplan
! print*,i,nn(i),ns(i),nf(i),nl(i),plan(i)
call sfftw_destroy_plan_(plan(i))
enddo
! print*,'FFTW plans destroyed:',nplan
return
end
SUBROUTINE FOUR2a (a,nfft,NDIM,ISIGN,IFORM)
C IFORM = 1, 0 or -1, as data is
C complex, real, or the first half of a complex array. Transform
C values are returned in array DATA. They are complex, real, or
C the first half of a complex array, as IFORM = 1, -1 or 0.
C The transform of a real array (IFORM = 0) dimensioned N(1) by N(2)
C by ... will be returned in the same array, now considered to
C be complex of dimensions N(1)/2+1 by N(2) by .... Note that if
C IFORM = 0 or -1, N(1) must be even, and enough room must be
C reserved. The missing values may be obtained by complex conjuga-
C tion.
C The reverse transformation of a half complex array dimensioned
C N(1)/2+1 by N(2) by ..., is accomplished by setting IFORM
C to -1. In the N array, N(1) must be the true N(1), not N(1)/2+1.
C The transform will be real and returned to the input array.
parameter (NPMAX=100)
complex a(nfft)
complex aa(32768)
integer nn(NPMAX),ns(NPMAX),nf(NPMAX),nl(NPMAX)
integer*8 plan(NPMAX)
data nplan/0/
include 'fftw3.f'
save
if(nfft.lt.0) go to 999
nloc=loc(a)
do i=1,nplan
if(nfft.eq.nn(i) .and. isign.eq.ns(i) .and.
+ iform.eq.nf(i) .and. nloc.eq.nl(i)) go to 10
enddo
if(nplan.ge.NPMAX) stop 'Too many FFTW plans requested.'
nplan=nplan+1
i=nplan
nn(i)=nfft
ns(i)=isign
nf(i)=iform
nl(i)=nloc
C Planning: FFTW_ESTIMATE, FFTW_MEASURE, FFTW_PATIENT, FFTW_EXHAUSTIVE
nspeed=FFTW_ESTIMATE
if(nfft.le.16384) nspeed=FFTW_MEASURE
nspeed=FFTW_MEASURE
if(nfft.le.32768) then
do j=1,nfft
aa(j)=a(j)
enddo
endif
if(isign.eq.-1 .and. iform.eq.1) then
call sfftw_plan_dft_1d_(plan(i),nfft,a,a,
+ FFTW_FORWARD,nspeed)
else if(isign.eq.1 .and. iform.eq.1) then
call sfftw_plan_dft_1d_(plan(i),nfft,a,a,
+ FFTW_BACKWARD,nspeed)
else if(isign.eq.-1 .and. iform.eq.0) then
call sfftw_plan_dft_r2c_1d_(plan(i),nfft,a,a,nspeed)
else if(isign.eq.1 .and. iform.eq.-1) then
call sfftw_plan_dft_c2r_1d_(plan(i),nfft,a,a,nspeed)
else
stop 'Unsupported request in four2a'
endif
i=nplan
if(nfft.le.32768) then
do j=1,nfft
a(j)=aa(j)
enddo
endif
10 call sfftw_execute_(plan(i))
return
999 do i=1,nplan
call sfftw_destroy_plan_(plan(i))
enddo
return
end

9
ftn_init.F90
View File

@ -69,6 +69,15 @@ subroutine ftn_init
err=940)
#endif
#ifdef Win32
open(19,file=appdir(:iz)//'/bandmap.txt',status='unknown', &
share='denynone',err=910)
#else
open(19,file=appdir(:iz)//'/bandmap.txt',status='unknown', &
err=910)
#endif
endfile 19
#ifdef Win32
open(21,file=appdir(:iz)//'/ALL.TXT',status='unknown', &
access='append',share='denynone',err=950)

48
ftsky.f
View File

@ -1,24 +1,24 @@
real function ftsky(l,b)
C Returns 408 MHz sky temperature for l,b (in degrees), from
C Haslam, et al. survey. Must have already read the entire
C file tsky.dat into memory.
real*4 l,b
integer*2 nsky
common/sky/ nsky(360,180)
save
j=nint(b+91.0)
if(j.gt.180) j=180
xl=l
if(xl.lt.0.0) xl=xl+360.0
i=nint(xl+1.0)
if(i.gt.360) i=i-360
ftsky=0.0
if(i.ge.1 .and. i.le.360 .and. j.ge.1 .and. j.le.180) then
ftsky=0.1*nsky(i,j)
endif
return
end
real function ftsky(l,b)
C Returns 408 MHz sky temperature for l,b (in degrees), from
C Haslam, et al. survey. Must have already read the entire
C file tsky.dat into memory.
real*4 l,b
integer*2 nsky
common/sky/ nsky(360,180)
save
j=nint(b+91.0)
if(j.gt.180) j=180
xl=l
if(xl.lt.0.0) xl=xl+360.0
i=nint(xl+1.0)
if(i.gt.360) i=i-360
ftsky=0.0
if(i.ge.1 .and. i.le.360 .and. j.ge.1 .and. j.le.180) then
ftsky=0.1*nsky(i,j)
endif
return
end

102
gcom1.f90
View File

@ -1,51 +1,51 @@
! Variable Purpose Set in Thread
!---------------------------------------------------------------------------
integer NRXMAX !Max length of Rx ring buffers
integer NTXMAX !Max length of Tx waveform in samples
parameter(NRXMAX=2097152) ! =2048*1024
parameter(NTXMAX=1653750) ! =150*11025
real*8 tbuf !Tsec at time of input callback SoundIn
integer ntrbuf !(obsolete?)
real*8 Tsec !Present time SoundIn,SoundOut
real*8 rxdelay !Delay between PTT=1 and Tx audio SoundIn
real*8 txdelay !Delay from end of Tx Audio and PTT=0 SoundOut
real*8 samfacin !(Input sample rate)/11025 GUI
real*8 samfacout !(Output sample rate)/11025 GUI
real*8 txsnrdb !SNR for simulations GUI
integer*2 y1 !Ring buffer for audio channel 0 SoundIn
integer*2 y2 !Ring buffer for audio channel 1 SoundIn
integer nmax !Actual length of Rx ring buffers GUI
integer iwrite !Write pointer to Rx ring buffer SoundIn
integer iread !Read pointer to Rx ring buffer GUI
integer*2 iwave !Data for audio output SoundIn
integer nwave !Number of samples in iwave SoundIn
integer TxOK !OK to transmit? SoundIn
! NB: TxOK=1 only in SoundIn; TxOK=0 also in GUI
integer Receiving !Actually receiving? SoundIn
integer Transmitting !Actually transmitting? SoundOut
integer TxFirst !Transmit first? GUI
integer TRPeriod !Tx or Rx period in seconds GUI
integer ibuf !Most recent input buffer# SoundIn
integer ibuf0 !Buffer# at start of Rx sequence SoundIn
real ave !(why is this here?) GUI
real rms !(why is this here?) GUI
integer ngo !Set to 0 to terminate audio streams GUI
integer level !S-meter level, 0-100 GUI
integer mute !True means "don't transmit" GUI
integer newdat !New data available for waterfall? GUI
integer ndsec !Dsec in units of 0.1 s GUI
integer ndevin !Device# for audio input GUI
integer ndevout !Device# for audio output GUI
integer mfsample !Measured sample rate, input SoundIn
integer mfsample2 !Measured sample rate, output SoundOut
integer ns0 !Time at last ALL.TXT date entry Decoder
character*12 devin_name,devout_name ! GUI
common/gcom1/Tbuf(1024),ntrbuf(1024),Tsec,rxdelay,txdelay, &
samfacin,samfacout,txsnrdb,y1(NRXMAX),y2(NRXMAX), &
nmax,iwrite,iread,iwave(NTXMAX),nwave,TxOK,Receiving,Transmitting, &
TxFirst,TRPeriod,ibuf,ibuf0,ave,rms,ngo,level,mute,newdat,ndsec, &
ndevin,ndevout,mfsample,mfsample2,ns0,devin_name,devout_name
!### volatile /gcom1/
! Variable Purpose Set in Thread
!---------------------------------------------------------------------------
integer NRXMAX !Max length of Rx ring buffers
integer NTXMAX !Max length of Tx waveform in samples
parameter(NRXMAX=2097152) ! =2048*1024
parameter(NTXMAX=1653750) ! =150*11025
real*8 tbuf !Tsec at time of input callback SoundIn
integer ntrbuf !(obsolete?)
real*8 Tsec !Present time SoundIn,SoundOut
real*8 rxdelay !Delay between PTT=1 and Tx audio SoundIn
real*8 txdelay !Delay from end of Tx Audio and PTT=0 SoundOut
real*8 samfacin !(Input sample rate)/11025 GUI
real*8 samfacout !(Output sample rate)/11025 GUI
real*8 txsnrdb !SNR for simulations GUI
integer*2 y1 !Ring buffer for audio channel 0 SoundIn
integer*2 y2 !Ring buffer for audio channel 1 SoundIn
integer nmax !Actual length of Rx ring buffers GUI
integer iwrite !Write pointer to Rx ring buffer SoundIn
integer iread !Read pointer to Rx ring buffer GUI
integer*2 iwave !Data for audio output SoundIn
integer nwave !Number of samples in iwave SoundIn
integer TxOK !OK to transmit? SoundIn
! NB: TxOK=1 only in SoundIn; TxOK=0 also in GUI
integer Receiving !Actually receiving? SoundIn
integer Transmitting !Actually transmitting? SoundOut
integer TxFirst !Transmit first? GUI
integer TRPeriod !Tx or Rx period in seconds GUI
integer ibuf !Most recent input buffer# SoundIn
integer ibuf0 !Buffer# at start of Rx sequence SoundIn
real ave !(why is this here?) GUI
real rms !(why is this here?) GUI
integer ngo !Set to 0 to terminate audio streams GUI
integer level !S-meter level, 0-100 GUI
integer mute !True means "don't transmit" GUI
integer newdat !New data available for waterfall? GUI
integer ndsec !Dsec in units of 0.1 s GUI
integer ndevin !Device# for audio input GUI
integer ndevout !Device# for audio output GUI
integer mfsample !Measured sample rate, input SoundIn
integer mfsample2 !Measured sample rate, output SoundOut
integer ns0 !Time at last ALL.TXT date entry Decoder
character*12 devin_name,devout_name ! GUI
common/gcom1/Tbuf(1024),ntrbuf(1024),Tsec,rxdelay,txdelay, &
samfacin,samfacout,txsnrdb,y1(NRXMAX),y2(NRXMAX), &
nmax,iwrite,iread,iwave(NTXMAX),nwave,TxOK,Receiving,Transmitting, &
TxFirst,TRPeriod,ibuf,ibuf0,ave,rms,ngo,level,mute,newdat,ndsec, &
ndevin,ndevout,mfsample,mfsample2,ns0,devin_name,devout_name
!### volatile /gcom1/

200
gcom2.f90
View File

@ -1,100 +1,100 @@
! Variable Purpose Set in Thread
!-------------------------------------------------------------------------
real ps0 !Spectrum of best ping, FSK441/JT6m Decoder
real psavg !Average spectrum Decoder
real s2 !2d spectrum for horizontal waterfall GUI
real ccf !CCF in time (blue curve) Decoder
real green !Data for green line GUI
integer ngreen !Length of green GUI
real dgain !Digital audio gain setting GUI
integer iter !(why is this here??)
integer ndecoding !Decoder status (see decode2.f90) GUI,Decoder
integer ndecoding0 !Status on previous decode GUI,Decoder
integer mousebutton !Which button was clicked? GUI
integer ndecdone !Is decoder finished? GUI,Decoder
integer npingtime !Time in file of mouse-selected ping GUI,Decoder
integer ierr !(why is this here?)
integer lauto !Are we in Auto mode? GUI
integer mantx !Manual transmission requested? GUI,SoundIn
integer nrestart !True if transmission should restart GUI,SoundIn
integer ntr !Are we in 2nd sequence? SoundIn
integer nmsg !Length of Tx message SoundIn
integer nsave !Which files to save? GUI
integer nadd5 !Prepend 5 sec of 0's before decoding? GUI
integer dftolerance !DF tolerance (Hz) GUI
logical LDecoded !Was a message decoded? Decoder
logical rxdone !Has the Rx sequence finished? SoundIn,Decoder
integer monitoring !Are we monitoring? GUI
integer nzap !Is Zap checked? GUI
integer nsavecum !(why is this here?)
integer minsigdb !Decoder threshold setting GUI
integer nclearave !Set to 1 to clear JT65 avg GUI,Decoder
integer nfreeze !Is Freeze checked? GUI
integer nafc !Is AFC checked? GUI
integer nmode !Which WSJT mode? GUI,Decoder
integer mode65 !JT65 sub-mode (A/B/C ==> 1/2/4) GUI,SoundIn,Decoder
integer nclip !Clipping level GUI
integer ndebug !Write debugging info? GUI
integer nblank !Is NB checked? GUI
integer nfmid !Center frequency of main display GUI
integer nfrange !Frequency range of main display GUI
integer nport !Requested COM port number GUI
integer mousedf !Mouse-selected freq offset, DF GUI
integer neme !EME calls only in deep search? GUI
integer nsked !Sked mode for deep search? GUI
integer naggressive !Is "Aggressive decoding" checked? GUI
integer ntx2 !Is "No shorthands if Tx1" checked? GUI
integer nslim2 !2nd Decoder threshold for FSK441. JT6M GUI
integer nagain !Decode same file again? GUI
integer nsavelast !Save last file? GUI
integer shok !Shorthand messages OK? GUI
integer sendingsh !Sending a shorthand message? SoundIn
integer*2 d2a !Rx data, extracted from y1 Decoder
integer*2 d2b !Rx data, selected by mouse-pick Decoder
integer*2 b !Pixel values for waterfall spectrum GUI
integer jza !Length of data in d2a GUI,Decoder
integer jzb !(why is this here?)
integer ntime !Integer Unix time (now) SoundIn
integer idinterval !Interval between CWIDs, minutes GUI
integer msmax !(why is this here?)
integer lenappdir !Length of Appdir string GUI
integer idf !Frequency offset in Hz Decoder
integer ndiskdat !1 if data read from disk, 0 otherwise GUI
integer nlines !Available lines of waterfall data GUI
integer nflat !Is waterfall to be flattened? GUI
integer ntxreq !Tx msg# requested GUI
integer ntxnow !Tx msg# being sent now GUI
integer ndepth !Requested "depth" of JT65 decoding GUI
integer nspecial !JT65 shorthand msg#: RO=2 RRR=3 73=4 Decoder
integer ndf !Measured DF in Hz Decoder
real ss1 !Magenta curve for JT65 shorthand msg Decoder
real ss2 !Orange curve for JT65 shorthand msg Decoder
character mycall*12 !My call sign GUI
character hiscall*12 !His call sign GUI
character hisgrid*6 !His grid locator GUI
character txmsg*28 !Message to be transmitted GUI
character sending*28 !Message being sent SoundIn
character mode*6 !WSJT operating mode GUI
character utcdate*12 !UTC date GUI
character*24 fname0 !Filenames to be recorded, read, ... Decoder
character*24 fnamea
character*24 fnameb
character*24 decodedfile
character*80 AppDir !WSJT installation directory GUI
character*80 filetokilla !Filenames (full path) Decoder
character*80 filetokillb
character*12 pttport
common/gcom2/ps0(431),psavg(450),s2(64,3100),ccf(-5:540), &
green(500),ngreen,dgain,iter,ndecoding,ndecoding0,mousebutton, &
ndecdone,npingtime,ierr,lauto,mantx,nrestart,ntr,nmsg,nsave,nadd5, &
dftolerance,LDecoded,rxdone,monitoring,nzap,nsavecum,minsigdb, &
nclearave,nfreeze,nafc,nmode,mode65,nclip,ndebug,nblank,nport, &
mousedf,neme,nsked,naggressive,ntx2,nslim2,nagain,nsavelast, &
shok,sendingsh,d2a(661500),d2b(661500),b(60000),jza,jzb,ntime, &
idinterval,msmax,lenappdir,idf,ndiskdat,nlines,nflat,ntxreq,ntxnow, &
ndepth,nspecial,ndf,nfmid,nfrange,ss1(-224:224),ss2(-224:224), &
mycall,hiscall,hisgrid,txmsg,sending,mode,fname0,fnamea, &
fnameb,decodedfile,AppDir,filetokilla,filetokillb,utcdate,pttport
!### volatile /gcom2/
! Variable Purpose Set in Thread
!-------------------------------------------------------------------------
real ps0 !Spectrum of best ping, FSK441/JT6m Decoder
real psavg !Average spectrum Decoder
real s2 !2d spectrum for horizontal waterfall GUI
real ccf !CCF in time (blue curve) Decoder
real green !Data for green line GUI
integer ngreen !Length of green GUI
real dgain !Digital audio gain setting GUI
integer iter !(why is this here??)
integer ndecoding !Decoder status (see decode2.f90) GUI,Decoder
integer ndecoding0 !Status on previous decode GUI,Decoder
integer mousebutton !Which button was clicked? GUI
integer ndecdone !Is decoder finished? GUI,Decoder
integer npingtime !Time in file of mouse-selected ping GUI,Decoder
integer ierr !(why is this here?)
integer lauto !Are we in Auto mode? GUI
integer mantx !Manual transmission requested? GUI,SoundIn
integer nrestart !True if transmission should restart GUI,SoundIn
integer ntr !Are we in 2nd sequence? SoundIn
integer nmsg !Length of Tx message SoundIn
integer nsave !Which files to save? GUI
integer nadd5 !Prepend 5 sec of 0's before decoding? GUI
integer dftolerance !DF tolerance (Hz) GUI
logical LDecoded !Was a message decoded? Decoder
logical rxdone !Has the Rx sequence finished? SoundIn,Decoder
integer monitoring !Are we monitoring? GUI
integer nzap !Is Zap checked? GUI
integer nsavecum !(why is this here?)
integer minsigdb !Decoder threshold setting GUI
integer nclearave !Set to 1 to clear JT65 avg GUI,Decoder
integer nfreeze !Is Freeze checked? GUI
integer nafc !Is AFC checked? GUI
integer nmode !Which WSJT mode? GUI,Decoder
integer mode65 !JT65 sub-mode (A/B/C ==> 1/2/4) GUI,SoundIn,Decoder
integer nclip !Clipping level GUI
integer ndebug !Write debugging info? GUI
integer nblank !Is NB checked? GUI
integer nfmid !Center frequency of main display GUI
integer nfrange !Frequency range of main display GUI
integer nport !Requested COM port number GUI
integer mousedf !Mouse-selected freq offset, DF GUI
integer neme !EME calls only in deep search? GUI
integer nsked !Sked mode for deep search? GUI
integer naggressive !Is "Aggressive decoding" checked? GUI
integer ntx2 !Is "No shorthands if Tx1" checked? GUI
integer nslim2 !2nd Decoder threshold for FSK441. JT6M GUI
integer nagain !Decode same file again? GUI
integer nsavelast !Save last file? GUI
integer shok !Shorthand messages OK? GUI
integer sendingsh !Sending a shorthand message? SoundIn
integer*2 d2a !Rx data, extracted from y1 Decoder
integer*2 d2b !Rx data, selected by mouse-pick Decoder
integer*2 b !Pixel values for waterfall spectrum GUI
integer jza !Length of data in d2a GUI,Decoder
integer jzb !(why is this here?)
integer ntime !Integer Unix time (now) SoundIn
integer idinterval !Interval between CWIDs, minutes GUI
integer msmax !(why is this here?)
integer lenappdir !Length of Appdir string GUI
integer idf !Frequency offset in Hz Decoder
integer ndiskdat !1 if data read from disk, 0 otherwise GUI
integer nlines !Available lines of waterfall data GUI
integer nflat !Is waterfall to be flattened? GUI
integer ntxreq !Tx msg# requested GUI
integer ntxnow !Tx msg# being sent now GUI
integer ndepth !Requested "depth" of JT65 decoding GUI
integer nspecial !JT65 shorthand msg#: RO=2 RRR=3 73=4 Decoder
integer ndf !Measured DF in Hz Decoder
real ss1 !Magenta curve for JT65 shorthand msg Decoder
real ss2 !Orange curve for JT65 shorthand msg Decoder
character mycall*12 !My call sign GUI
character hiscall*12 !His call sign GUI
character hisgrid*6 !His grid locator GUI
character txmsg*28 !Message to be transmitted GUI
character sending*28 !Message being sent SoundIn
character mode*6 !WSJT operating mode GUI
character utcdate*12 !UTC date GUI
character*24 fname0 !Filenames to be recorded, read, ... Decoder
character*24 fnamea
character*24 fnameb
character*24 decodedfile
character*80 AppDir !WSJT installation directory GUI
character*80 filetokilla !Filenames (full path) Decoder
character*80 filetokillb
character*12 pttport
common/gcom2/ps0(431),psavg(450),s2(64,3100),ccf(-5:540), &
green(500),ngreen,dgain,iter,ndecoding,ndecoding0,mousebutton, &
ndecdone,npingtime,ierr,lauto,mantx,nrestart,ntr,nmsg,nsave,nadd5, &
dftolerance,LDecoded,rxdone,monitoring,nzap,nsavecum,minsigdb, &
nclearave,nfreeze,nafc,nmode,mode65,nclip,ndebug,nblank,nport, &
mousedf,neme,nsked,naggressive,ntx2,nslim2,nagain,nsavelast, &
shok,sendingsh,d2a(661500),d2b(661500),b(60000),jza,jzb,ntime, &
idinterval,msmax,lenappdir,idf,ndiskdat,nlines,nflat,ntxreq,ntxnow, &
ndepth,nspecial,ndf,nfmid,nfrange,ss1(-224:224),ss2(-224:224), &
mycall,hiscall,hisgrid,txmsg,sending,mode,fname0,fnamea, &
fnameb,decodedfile,AppDir,filetokilla,filetokillb,utcdate,pttport
!### volatile /gcom2/

40
gcom3.f90
View File

@ -1,20 +1,20 @@
! Variable Purpose Set in Thread
!-------------------------------------------------------------------------
integer*2 nfmt2 !Standard header for *.WAV file Decoder
integer*2 nchan2
integer*2 nbitsam2
integer*2 nbytesam2
integer*4 nchunk
integer*4 lenfmt
integer*4 nsamrate
integer*4 nbytesec
integer*4 ndata
character*4 ariff
character*4 awave
character*4 afmt
character*4 adata
common/gcom3/ariff,nchunk,awave,afmt,lenfmt,nfmt2,nchan2,nsamrate, &
nbytesec,nbytesam2,nbitsam2,adata,ndata
!### volatile /gcom3/
! Variable Purpose Set in Thread
!-------------------------------------------------------------------------
integer*2 nfmt2 !Standard header for *.WAV file Decoder
integer*2 nchan2
integer*2 nbitsam2
integer*2 nbytesam2
integer*4 nchunk
integer*4 lenfmt
integer*4 nsamrate
integer*4 nbytesec
integer*4 ndata
character*4 ariff
character*4 awave
character*4 afmt
character*4 adata
common/gcom3/ariff,nchunk,awave,afmt,lenfmt,nfmt2,nchan2,nsamrate, &
nbytesec,nbytesam2,nbitsam2,adata,ndata
!### volatile /gcom3/

20
gcom4.f90
View File

@ -1,10 +1,10 @@
! Variable Purpose Set in Thread
!-------------------------------------------------------------------------
character addpfx*8 !Add-on prefix, as in ZA/PA2CHR GUI
integer*2 d2c !Rx data recovered from recorded file GUI
integer jzc !Length of data available in d2c GUI
character filename*24 !Name of wave file read from disk GUI
common/gcom4/addpfx,d2c(661500),jzc,filename
!### volatile /gcom4/
! Variable Purpose Set in Thread
!-------------------------------------------------------------------------
character addpfx*8 !Add-on prefix, as in ZA/PA2CHR GUI
integer*2 d2c !Rx data recovered from recorded file GUI
integer jzc !Length of data available in d2c GUI
character filename*24 !Name of wave file read from disk GUI
common/gcom4/addpfx,d2c(661500),jzc,filename
!### volatile /gcom4/

164
gen65.f
View File

@ -1,82 +1,82 @@
subroutine gen65(message,mode65,samfac,iwave,nwave,sendingsh,
+ msgsent)
C Encodes a JT65 message into a wavefile.
parameter (NMAX=60*11025) !Max length of wave file
character*22 message !Message to be generated
character*22 msgsent !Message as it will be received
character*3 cok !' ' or 'OOO'
character*6 c1,c2
real*8 t,dt,phi,f,f0,dfgen,dphi,twopi,samfac,tsymbol
integer*2 iwave(NMAX) !Generated wave file
integer dgen(12)
integer sent(63)
integer sendingsh
common/c1c2/c1,c2
include 'prcom.h'
data twopi/6.283185307d0/
save
if(abs(pr(1)).ne.1.0) call setup65
call chkmsg(message,cok,nspecial,flip)
if(nspecial.eq.0) then
call packmsg(message,dgen) !Pack message into 72 bits
sendingsh=0
if(iand(dgen(10),8).ne.0) sendingsh=-1 !Plain text flag
call rs_encode(dgen,sent)
call interleave63(sent,1) !Apply interleaving
call graycode(sent,63,1) !Apply Gray code
tsymbol=4096.d0/11025.d0
nsym=126 !Symbols per transmission
else
tsymbol=16384.d0/11025.d0
nsym=32
sendingsh=1 !Flag for shorthand message
endif
C Set up necessary constants
dt=1.0/(samfac*11025.0)
f0=118*11025.d0/1024
dfgen=mode65*11025.0/4096.0
t=0.d0
phi=0.d0
k=0
j0=0
ndata=(nsym*11025.d0*samfac*tsymbol)/2
ndata=2*ndata
do i=1,ndata
t=t+dt
j=int(t/tsymbol) + 1 !Symbol number, 1-126
if(j.ne.j0) then
f=f0
if(nspecial.ne.0 .and. mod(j,2).eq.0) f=f0+10*nspecial*dfgen
if(nspecial.eq.0 .and. flip*pr(j).lt.0.0) then
k=k+1
f=f0+(sent(k)+2)*dfgen
endif
dphi=twopi*dt*f
j0=j
endif
phi=phi+dphi
iwave(i)=32767.0*sin(phi)
enddo
do j=1,5512 !Put another 0.5 sec of silence at end
i=i+1
iwave(i)=0
enddo
nwave=i
call unpackmsg(dgen,msgsent)
if(flip.lt.0.0) then
do i=22,1,-1
if(msgsent(i:i).ne.' ') goto 10
enddo
10 msgsent=msgsent(1:i)//' OOO'
endif
return
end
subroutine gen65(message,mode65,samfac,iwave,nwave,sendingsh,
+ msgsent)
C Encodes a JT65 message into a wavefile.
parameter (NMAX=60*11025) !Max length of wave file
character*22 message !Message to be generated
character*22 msgsent !Message as it will be received
character*3 cok !' ' or 'OOO'
character*6 c1,c2
real*8 t,dt,phi,f,f0,dfgen,dphi,twopi,samfac,tsymbol
integer*2 iwave(NMAX) !Generated wave file
integer dgen(12)
integer sent(63)
integer sendingsh
common/c1c2/c1,c2
include 'prcom.h'
data twopi/6.283185307d0/
save
if(abs(pr(1)).ne.1.0) call setup65
call chkmsg(message,cok,nspecial,flip)
if(nspecial.eq.0) then
call packmsg(message,dgen) !Pack message into 72 bits
sendingsh=0
if(iand(dgen(10),8).ne.0) sendingsh=-1 !Plain text flag
call rs_encode(dgen,sent)
call interleave63(sent,1) !Apply interleaving
call graycode(sent,63,1) !Apply Gray code
tsymbol=4096.d0/11025.d0
nsym=126 !Symbols per transmission
else
tsymbol=16384.d0/11025.d0
nsym=32
sendingsh=1 !Flag for shorthand message
endif
C Set up necessary constants
dt=1.0/(samfac*11025.0)
f0=118*11025.d0/1024
dfgen=mode65*11025.0/4096.0
t=0.d0
phi=0.d0
k=0
j0=0
ndata=(nsym*11025.d0*samfac*tsymbol)/2
ndata=2*ndata
do i=1,ndata
t=t+dt
j=int(t/tsymbol) + 1 !Symbol number, 1-126
if(j.ne.j0) then
f=f0
if(nspecial.ne.0 .and. mod(j,2).eq.0) f=f0+10*nspecial*dfgen
if(nspecial.eq.0 .and. flip*pr(j).lt.0.0) then
k=k+1
f=f0+(sent(k)+2)*dfgen
endif
dphi=twopi*dt*f
j0=j
endif
phi=phi+dphi
iwave(i)=32767.0*sin(phi)
enddo
do j=1,5512 !Put another 0.5 sec of silence at end
i=i+1
iwave(i)=0
enddo
nwave=i
call unpackmsg(dgen,msgsent)
if(flip.lt.0.0) then
do i=22,1,-1
if(msgsent(i:i).ne.' ') goto 10
enddo
10 msgsent=msgsent(1:i)//' OOO'
endif
return
end

72
gencwid.f
View File

@ -1,36 +1,36 @@
subroutine gencwid(msg,wpm,freqcw,samfac,iwave,nwave)
parameter (NMAX=10*11025)
character msg*22,msg2*22
integer*2 iwave(NMAX)
integer*1 idat(460)
real*8 dt,t,twopi,pha,dpha,tdit,samfac
data twopi/6.283185307d0/
do i=1,22
if(msg(i:i).eq.' ') go to 10
enddo
10 iz=i-1
msg2=msg(1:iz)//' '
call morse(msg2,idat,ndits) !Encode part 1 of msg
tdit=1.2d0/wpm !Key-down dit time, seconds
dt=1.d0/(11025.d0*samfac)
nwave=ndits*tdit/dt
pha=0.
dpha=twopi*freqcw*dt
t=0.d0
s=0.
u=wpm/(11025*0.03)
do i=1,nwave
t=t+dt
pha=pha+dpha
j=t/tdit + 1
s=s + u*(idat(j)-s)
iwave(i)=nint(s*32767.d0*sin(pha))
enddo
return
end
subroutine gencwid(msg,wpm,freqcw,samfac,iwave,nwave)
parameter (NMAX=10*11025)
character msg*22,msg2*22
integer*2 iwave(NMAX)
integer*1 idat(460)
real*8 dt,t,twopi,pha,dpha,tdit,samfac
data twopi/6.283185307d0/
do i=1,22
if(msg(i:i).eq.' ') go to 10
enddo
10 iz=i-1
msg2=msg(1:iz)//' '
call morse(msg2,idat,ndits) !Encode part 1 of msg
tdit=1.2d0/wpm !Key-down dit time, seconds
dt=1.d0/(11025.d0*samfac)
nwave=ndits*tdit/dt
pha=0.
dpha=twopi*freqcw*dt
t=0.d0
s=0.
u=wpm/(11025*0.03)
do i=1,nwave
t=t+dt
pha=pha+dpha
j=t/tdit + 1
s=s + u*(idat(j)-s)
iwave(i)=nint(s*32767.d0*sin(pha))
enddo
return
end

26
gentone.f
View File

@ -1,13 +1,13 @@
subroutine gentone(x,n,k)
real*4 x(512)
dt=1.0/11025.0
f=(n+51)*11025.0/512.0
do i=1,512
x(i)=sin(6.2831853*i*dt*f)
enddo
k=k+512
return
end
subroutine gentone(x,n,k)
real*4 x(512)
dt=1.0/11025.0
f=(n+51)*11025.0/512.0
do i=1,512
x(i)=sin(6.2831853*i*dt*f)
enddo
k=k+512
return
end

34
geocentric.f
View File

@ -1,17 +1,17 @@
subroutine geocentric(alat,elev,hlt,erad)
implicit real*8 (a-h,o-z)
C IAU 1976 flattening f, equatorial radius a
f = 1.d0/298.257d0
a = 6378140.d0
c = 1.d0/sqrt(1.d0 + (-2.d0 + f)*f*sin(alat)*sin(alat))
arcf = (a*c + elev)*cos(alat)
arsf = (a*(1.d0 - f)*(1.d0 - f)*c + elev)*sin(alat)
hlt = datan2(arsf,arcf)
erad = sqrt(arcf*arcf + arsf*arsf)
erad = 0.001d0*erad
return
end
subroutine geocentric(alat,elev,hlt,erad)
implicit real*8 (a-h,o-z)
C IAU 1976 flattening f, equatorial radius a
f = 1.d0/298.257d0
a = 6378140.d0
c = 1.d0/sqrt(1.d0 + (-2.d0 + f)*f*sin(alat)*sin(alat))
arcf = (a*c + elev)*cos(alat)
arsf = (a*(1.d0 - f)*(1.d0 - f)*c + elev)*sin(alat)
hlt = datan2(arsf,arcf)
erad = sqrt(arcf*arcf + arsf*arsf)
erad = 0.001d0*erad
return
end

90
getpfx1.f
View File

@ -1,45 +1,45 @@
subroutine getpfx1(callsign,k)
character callsign*12
character*8 c
character addpfx*8
C Can't 'include' *.f90 in *.f
common/gcom4/addpfx
include 'pfx.f'
iz=index(callsign,' ') - 1
if(iz.lt.0) iz=12
islash=index(callsign(1:iz),'/')
k=0
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) k=-1
return
end
subroutine getpfx1(callsign,k)
character callsign*12
character*8 c
character addpfx*8
C Can't 'include' *.f90 in *.f
common/gcom4/addpfx
include 'pfx.f'
iz=index(callsign,' ') - 1
if(iz.lt.0) iz=12
islash=index(callsign(1:iz),'/')
k=0
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) k=-1
return
end

48
getpfx2.f
View File

@ -1,24 +1,24 @@
subroutine getpfx2(k0,callsign)
character callsign*12
include 'pfx.f'
character addpfx*8
common/gcom4/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(k0,callsign)
character callsign*12
include 'pfx.f'
character addpfx*8
common/gcom4/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

70
getsnr.f
View File

@ -1,35 +1,35 @@
subroutine getsnr(x,nz,snr)
real x(nz)
smax=-1.e30
do i=1,nz
if(x(i).gt.smax) then
ipk=i
smax=x(i)
endif
s=s+x(i)
enddo
s=0.
ns=0
do i=1,nz
if(abs(i-ipk).ge.3) then
s=s+x(i)
ns=ns+1
endif
enddo
ave=s/ns
sq=0.
do i=1,nz
if(abs(i-ipk).ge.3) then
sq=sq+(x(i)-ave)**2
ns=ns+1
endif
enddo
rms=sqrt(sq/(nz-2))
snr=(smax-ave)/rms
return
end
subroutine getsnr(x,nz,snr)
real x(nz)
smax=-1.e30
do i=1,nz
if(x(i).gt.smax) then
ipk=i
smax=x(i)
endif
s=s+x(i)
enddo
s=0.
ns=0
do i=1,nz
if(abs(i-ipk).ge.3) then
s=s+x(i)
ns=ns+1
endif
enddo
ave=s/ns
sq=0.
do i=1,nz
if(abs(i-ipk).ge.3) then
sq=sq+(x(i)-ave)**2
ns=ns+1
endif
enddo
rms=sqrt(sq/(nz-2))
snr=(smax-ave)/rms
return
end

20
graycode.f
View File

@ -1,10 +1,10 @@
subroutine graycode(dat,n,idir)
integer dat(n)
do i=1,n
dat(i)=igray(dat(i),idir)
enddo
return
end
subroutine graycode(dat,n,idir)
integer dat(n)
do i=1,n
dat(i)=igray(dat(i),idir)
enddo
return
end

80
grid2deg.f
View File

@ -1,40 +1,40 @@
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
c print*,nlong,n20d,xminlong,dlong
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
c print*,nlat,xminlat,dlat
return
end
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
c print*,nlong,n20d,xminlong,dlong
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
c print*,nlat,xminlat,dlat
return
end

24
grid2k.f
View File

@ -1,12 +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(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

38
indexx.f
View File

@ -1,19 +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(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

114
int.h
View File

@ -1,57 +1,57 @@
/* Include file to configure the RS codec for integer symbols
*
* Copyright 2002, Phil Karn, KA9Q
* May be used under the terms of the GNU General Public License (GPL)
*/
#define DTYPE int
/* Reed-Solomon codec control block */
struct rs {
int mm; /* Bits per symbol */
int nn; /* Symbols per block (= (1<<mm)-1) */
DTYPE *alpha_to; /* log lookup table */
DTYPE *index_of; /* Antilog lookup table */
DTYPE *genpoly; /* Generator polynomial */
int nroots; /* Number of generator roots = number of parity symbols */
int fcr; /* First consecutive root, index form */
int prim; /* Primitive element, index form */
int iprim; /* prim-th root of 1, index form */
int pad; /* Padding bytes in shortened block */
};
static int modnn(struct rs *rs,int x){
while (x >= rs->nn) {
x -= rs->nn;
x = (x >> rs->mm) + (x & rs->nn);
}
return x;
}
#define MODNN(x) modnn(rs,x)
#define MM (rs->mm)
#define NN (rs->nn)
#define ALPHA_TO (rs->alpha_to)
#define INDEX_OF (rs->index_of)
#define GENPOLY (rs->genpoly)
//#define NROOTS (rs->nroots)
#define NROOTS (51)
#define FCR (rs->fcr)
#define PRIM (rs->prim)
#define IPRIM (rs->iprim)
#define PAD (rs->pad)
#define A0 (NN)
#define ENCODE_RS encode_rs_int
#define DECODE_RS decode_rs_int
#define INIT_RS init_rs_int
#define FREE_RS free_rs_int
void ENCODE_RS(void *p,DTYPE *data,DTYPE *parity);
int DECODE_RS(void *p,DTYPE *data,int *eras_pos,int no_eras);
void *INIT_RS(int symsize,int gfpoly,int fcr,
int prim,int nroots,int pad);
void FREE_RS(void *p);
/* Include file to configure the RS codec for integer symbols
*
* Copyright 2002, Phil Karn, KA9Q
* May be used under the terms of the GNU General Public License (GPL)
*/
#define DTYPE int
/* Reed-Solomon codec control block */
struct rs {
int mm; /* Bits per symbol */
int nn; /* Symbols per block (= (1<<mm)-1) */
DTYPE *alpha_to; /* log lookup table */
DTYPE *index_of; /* Antilog lookup table */
DTYPE *genpoly; /* Generator polynomial */
int nroots; /* Number of generator roots = number of parity symbols */
int fcr; /* First consecutive root, index form */
int prim; /* Primitive element, index form */
int iprim; /* prim-th root of 1, index form */
int pad; /* Padding bytes in shortened block */
};
static int modnn(struct rs *rs,int x){
while (x >= rs->nn) {
x -= rs->nn;
x = (x >> rs->mm) + (x & rs->nn);
}
return x;
}
#define MODNN(x) modnn(rs,x)
#define MM (rs->mm)
#define NN (rs->nn)
#define ALPHA_TO (rs->alpha_to)
#define INDEX_OF (rs->index_of)
#define GENPOLY (rs->genpoly)
//#define NROOTS (rs->nroots)
#define NROOTS (51)
#define FCR (rs->fcr)
#define PRIM (rs->prim)
#define IPRIM (rs->iprim)
#define PAD (rs->pad)
#define A0 (NN)
#define ENCODE_RS encode_rs_int
#define DECODE_RS decode_rs_int
#define INIT_RS init_rs_int
#define FREE_RS free_rs_int
void ENCODE_RS(void *p,DTYPE *data,DTYPE *parity);
int DECODE_RS(void *p,DTYPE *data,int *eras_pos,int no_eras);
void *INIT_RS(int symsize,int gfpoly,int fcr,
int prim,int nroots,int pad);
void FREE_RS(void *p);

50
interleave63.f
View File

@ -1,25 +1,25 @@
subroutine interleave63(d1,idir)
C Interleave (idir=1) or de-interleave (idir=-1) the array d1.
integer d1(0:6,0:8)
integer d2(0:8,0:6)
if(idir.ge.0) then
do i=0,6
do j=0,8
d2(j,i)=d1(i,j)
enddo
enddo
call move(d2,d1,63)
else
call move(d1,d2,63)
do i=0,6
do j=0,8
d1(i,j)=d2(j,i)
enddo
enddo
endif
return
end
subroutine interleave63(d1,idir)
C Interleave (idir=1) or de-interleave (idir=-1) the array d1.
integer d1(0:6,0:8)
integer d2(0:8,0:6)
if(idir.ge.0) then
do i=0,6
do j=0,8
d2(j,i)=d1(i,j)
enddo
enddo
call move(d2,d1,63)
else
call move(d1,d2,63)
do i=0,6
do j=0,8
d1(i,j)=d2(j,i)
enddo
enddo
endif
return
end

24
k2grid.f
View File

@ -1,12 +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(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

62
limit.f
View File

@ -1,31 +1,31 @@
subroutine limit(x,jz)
real x(jz)
logical noping
common/limcom/ nslim2
noping=.false.
xlim=1.e30
if(nslim2.eq.1) xlim=3.0
if(nslim2.ge.2) xlim=1.0
if(nslim2.ge.3) noping=.true.
sq=0.
do i=1,jz
sq=sq+x(i)*x(i)
enddo
rms=sqrt(sq/jz)
rms0=14.5
x1=xlim*rms0
fac=1.0/xlim
if(fac.lt.1.0) fac=1.0
if(noping .and. rms.gt.20.0) fac=0.01 !Crude attempt at ping excision
do i=1,jz
if(x(i).lt.-x1) x(i)=-x1
if(x(i).gt.x1) x(i)=x1
x(i)=fac*x(i)
enddo
return
end
subroutine limit(x,jz)
real x(jz)
logical noping
common/limcom/ nslim2
noping=.false.
xlim=1.e30
if(nslim2.eq.1) xlim=3.0
if(nslim2.ge.2) xlim=1.0
if(nslim2.ge.3) noping=.true.
sq=0.
do i=1,jz
sq=sq+x(i)*x(i)
enddo
rms=sqrt(sq/jz)
rms0=14.5
x1=xlim*rms0
fac=1.0/xlim
if(fac.lt.1.0) fac=1.0
if(noping .and. rms.gt.20.0) fac=0.01 !Crude attempt at ping excision
do i=1,jz
if(x(i).lt.-x1) x(i)=-x1
if(x(i).gt.x1) x(i)=x1
x(i)=fac*x(i)
enddo
return
end

134
lpf1.f
View File

@ -1,67 +1,67 @@
subroutine lpf1(dat,jz,nz,mousedf,mousedf2)
parameter (NMAX=1024*1024)
parameter (NMAXH=NMAX)
real dat(jz),x(NMAX)
complex c(0:NMAXH)
equivalence (x,c)
C Find FFT length
xn=log(float(jz))/log(2.0)
n=xn
if((xn-n).gt.0.) n=n+1
nfft=2**n
nh=nfft/2
C Load data into real array x; pad with zeros up to nfft.
do i=1,jz
x(i)=dat(i)
enddo
if(nfft.gt.jz) call zero(x(jz+1),nfft-jz)
C Do the FFT
call xfft(x,nfft)
df=11025.0/nfft
ia=70/df
do i=0,ia
c(i)=0.
enddo
ia=5000.0/df
do i=ia,nh
c(i)=0.
enddo
C See if frequency needs to be shifted:
ndf=0
if(mousedf.lt.-600) ndf=-670
if(mousedf.gt.600) ndf=1000
if(mousedf.gt.1600) ndf=2000
if(mousedf.gt.2600) ndf=3000
if(ndf.ne.0) then
C Shift frequency up or down by ndf Hz:
i0=nint(ndf/df)
if(i0.lt.0) then
do i=nh,-i0,-1
c(i)=c(i+i0)
enddo
do i=0,-i0-1
c(i)=0.
enddo
else
do i=0,nh-i0
c(i)=c(i+i0)
enddo
endif
endif
mousedf2=mousedf-ndf !Adjust mousedf
call four2a(c,nh,1,1,-1) !Return to time domain
fac=1.0/nfft
nz=jz/2
do i=1,nz
dat(i)=fac*x(i)
enddo
return
end
subroutine lpf1(dat,jz,nz,mousedf,mousedf2)
parameter (NMAX=1024*1024)
parameter (NMAXH=NMAX)
real dat(jz),x(NMAX)
complex c(0:NMAXH)
equivalence (x,c)
C Find FFT length
xn=log(float(jz))/log(2.0)
n=xn
if((xn-n).gt.0.) n=n+1
nfft=2**n
nh=nfft/2
C Load data into real array x; pad with zeros up to nfft.
do i=1,jz
x(i)=dat(i)
enddo
if(nfft.gt.jz) call zero(x(jz+1),nfft-jz)
C Do the FFT
call xfft(x,nfft)
df=11025.0/nfft
ia=70/df
do i=0,ia
c(i)=0.
enddo
ia=5000.0/df
do i=ia,nh
c(i)=0.
enddo
C See if frequency needs to be shifted:
ndf=0
if(mousedf.lt.-600) ndf=-670
if(mousedf.gt.600) ndf=1000
if(mousedf.gt.1600) ndf=2000
if(mousedf.gt.2600) ndf=3000
if(ndf.ne.0) then
C Shift frequency up or down by ndf Hz:
i0=nint(ndf/df)
if(i0.lt.0) then
do i=nh,-i0,-1
c(i)=c(i+i0)
enddo
do i=0,-i0-1
c(i)=0.
enddo
else
do i=0,nh-i0
c(i)=c(i+i0)
enddo
endif
endif
mousedf2=mousedf-ndf !Adjust mousedf
call four2a(c,nh,1,1,-1) !Return to time domain
fac=1.0/nfft
nz=jz/2
do i=1,nz
dat(i)=fac*x(i)
enddo
return
end

52
map65.py
View File

@ -164,6 +164,22 @@ def testmsgs():
tx5.insert(0,"@1000")
tx6.insert(0,"@2000")
#------------------------------------------------------ bandmap
def bandmap(event=NONE):
global Version,bm,bm_geom,bmtext
bm=Toplevel(root)
bm.geometry(bm_geom)
if g.Win32: bm.iconbitmap("wsjt.ico")
iframe_bm1 = Frame(bm, bd=1, relief=SUNKEN)
bmtext=Text(iframe_bm1, height=35, width=45, bg="Navy", fg="yellow")
bmtext.pack(side=LEFT, fill=X, padx=1)
bmsb = Scrollbar(iframe_bm1, orient=VERTICAL, command=bmtext.yview)
bmsb.pack(side=RIGHT, fill=Y)
bmtext.configure(yscrollcommand=bmsb.set)
# bmtext.insert(END,'144.103 CQ EA3DXU JN11\n')
# bmtext.insert(END,'144.118 OH6KTL RA3AQ KO85 OOO')
iframe_bm1.pack(expand=1, fill=X, padx=4)
#------------------------------------------------------ logqso
def logqso(event=NONE):
t=time.strftime("%Y-%b-%d,%H:%M",time.gmtime())
@ -1070,22 +1086,6 @@ def plot_yellow():
xy2.append(n)
graph1.create_line(xy2,fill="yellow")
#------------------------------------------------------ bandmap
def bandmap(event=NONE):
global Version,bm,bm_geom
bm=Toplevel(root)
bm.geometry(bm_geom)
if g.Win32: bm.iconbitmap("wsjt.ico")
iframe_bm1 = Frame(bm, bd=1, relief=SUNKEN)
text=Text(iframe_bm1, height=35, width=32, bg="Navy", fg="yellow")
text.pack(side=LEFT, fill=X, padx=1)
sb = Scrollbar(iframe_bm1, orient=VERTICAL, command=text.yview)
sb.pack(side=RIGHT, fill=Y)
text.configure(yscrollcommand=sb.set)
text.insert(END,'144.103 CQ EA3DXU JN11\n')
text.insert(END,'144.118 OH6KTL RA3AQ KO85 OOO')
iframe_bm1.pack(expand=1, fill=X, padx=4)
#------------------------------------------------------ update
def update():
global root_geom,isec0,naz,nel,ndmiles,ndkm,nopen, \
@ -1179,6 +1179,10 @@ def update():
bdecode.configure(bg='gray85',activebackground='gray95')
if Audio.gcom2.ndecoding: #Set button bg=light_blue while decoding
bdecode.configure(bg='#66FFFF',activebackground='#66FFFF')
# print 'A'
Audio.map65a0() # @@@ Temporary @@@
# print 'B'
tx1.configure(bg='white')
tx2.configure(bg='white')
tx3.configure(bg='white')
@ -1251,6 +1255,21 @@ def update():
avetext.insert(END,lines[0])
avetext.insert(END,lines[1])
# avetext.configure(state=DISABLED)
try:
f=open(appdir+'/bandmap.txt',mode='r')
lines=f.readlines()
f.close()
except:
lines=""
bmtext.configure(state=NORMAL)
bmtext.insert(END,' Freq DF Pol UTC\n')
bmtext.insert(END,'--------------------------------------------\n')
for i in range(len(lines)):
bmtext.insert(END,lines[i])
bmtext.see(END)
Audio.gcom2.ndecdone=2
if g.cmap != cmap0:
@ -1744,7 +1763,6 @@ msg7=Message(iframe6, text=' ', width=300,relief=SUNKEN)
msg7.pack(side=RIGHT, fill=X, padx=1)
iframe6.pack(expand=1, fill=X, padx=4)
frame.pack()
ldate.after(100,update)
lauto=0
isync=1

288
map65a.f Normal file
View File

@ -0,0 +1,288 @@
subroutine map65a
C Processes timf2 data from Linrad to find and decode JT65 signals.
parameter (NMAX=60*96000) !Samples per 60 s file
parameter (MAXMSG=1000) !Size of decoded message list
integer*2 id(4,NMAX) !46 MB: raw data from Linrad timf2
parameter (NFFT=32768) !Half symbol = 17833 samples;
real ss(4,322,NFFT) !169 MB: half-symbol spectra
real savg(4,NFFT)
real tavg(-50:50) !Temp for finding local base level
real base(4) !Local basel level at 4 pol'ns
real tmp (200) !Temp storage for pctile sorting
real short(3,NFFT) !SNR dt ipol for potential shorthands
real sig(MAXMSG,30) !Parameters of detected signals
real a(5)
character*22 msg(MAXMSG)
character*3 shmsg0(4),shmsg
character arg*12,infile*11,outfile*11
integer indx(MAXMSG),nsiz(MAXMSG)
logical done(MAXMSG)
integer rfile3
character decoded*22,blank*22,cbad*1
data blank/' '/
data shmsg0/'ATT','RO ','RRR','73 '/
tskip=0.
fselect=0.
! fselect=103.0
nmin=1
infile='061111.0745'
C Initialize some constants
! open(22,file='kvasd.dat',access='direct',recl=1024,
! + status='unknown')
open(23,file='CALL3.TXT',status='unknown')
! nbytes=8*(4*96000+9000) !Empirical, for 061111_0744.dat.48
! nskip=8*nint(96000*(tskip+4.09375))
! n=rfile3(infile,id,nskip) !Skip to start of minute
! if(n.ne.nskip) go to 9999
df=96000.0/NFFT !df = 96000/NFFT = 2.930 Hz
fa=0.0
fb=60000.0
ia=nint((fa+23000.0)/df + 1.0) ! 23000 = 48000 - 25000
ib=nint((fb+23000.0)/df + 1.0)
ftol=0.020 !Frequency tolerance (kHz)
kk=0
nkk=1
do nfile=1,nmin
! n=rfile3(infile,id,8*NMAX) !Read 60 s of data (approx 46 MB)
n=8*NMAX
call rfile3a(infile,id,n,ierr)
newdat=1
nz=n/8
read(infile(8:11),*) nutc
if(fselect.gt.0.0) then
nfilt=1 !nfilt=2 is faster for selected freq
freq=fselect+1.600
nflip=-1 !May need to try both +/- 1
ipol=4 !Try all four?
dt=2.314240 !Not needed?
call decode1a(id,newdat,nfilt,freq,nflip,ipol,sync2,
+ a,dt,pol,nkv,nhist,qual,decoded)
write(11,1010) nutc,nsync1,nsync2,dt,ndf,decoded,
+ nkv,nqual
1010 format(i4.4,i5,i4,f5.1,i5,2x,a22,2i3)
if(nfile.eq.1) go to 999
endif
nfilt=1
do i=1,NFFT
short(1,i)=0.
short(2,i)=0.
short(3,i)=0.
enddo
call symspec(id,nz,ss,savg)
freq0=-999.
sync10=-999.
fshort0=-999.
sync20=-999.
ntry=0
do i=ia,ib !Search over freq range
freq=0.001*((i-1)*df - 23000) + 100.0
C Find the local base level for each polarization; update every 10 bins.
if(mod(i-ia,10).eq.0) then
do jp=1,4
do ii=-50,50
tavg(ii)=savg(jp,i+ii)
enddo
call pctile(tavg,tmp,101,50,base(jp))
enddo
endif
C Find max signal at this frequency
smax=0.
do jp=1,4
if(savg(jp,i)/base(jp).gt.smax) smax=savg(jp,i)/base(jp)
enddo
if(smax.gt.1.1) then
ntry=ntry+1
C Look for JT65 sync patterns and shorthand square-wave patterns.
call ccf65(ss(1,1,i),sync1,ipol,dt,flipk,
+ syncshort,snr2,ipol2,dt2)
shmsg=' '
C Is there a shorthand tone above threshold?
if(syncshort.gt.1.0) then
C### Do shorthand AFC here (or maybe after finding a pair?) ###
short(1,i)=syncshort
short(2,i)=dt2
short(3,i)=ipol2
C Check to see if lower tone of shorthand pair was found.
do j=2,4
i0=i-nint(j*53.8330078/df)
C Should this be i0 +/- 1, or just i0?
C Should we also insist that difference in DT be either 1.5 or -1.5 s?
if(short(1,i0).gt.1.0) then
fshort=0.001*((i0-1)*df - 23000) + 100.0
C Keep only the best candidate within ftol.
if(fshort-fshort0.le.ftol .and. sync2.gt.sync20
+ .and. nkk.eq.2) kk=kk-1
if(fshort-fshort0.gt.ftol .or.
+ sync2.gt.sync20) then
kk=kk+1
sig(kk,1)=nfile
sig(kk,2)=nutc
sig(kk,3)=fshort
sig(kk,4)=syncshort
sig(kk,5)=dt2
sig(kk,6)=45*(ipol2-1)/57.2957795
sig(kk,7)=0
sig(kk,8)=snr2
sig(kk,9)=0
sig(kk,10)=0
! sig(kk,11)=rms0
sig(kk,12)=savg(ipol2,i)
sig(kk,13)=0
sig(kk,14)=0
sig(kk,15)=0
sig(kk,16)=0
! sig(kk,17)=0
sig(kk,18)=0
msg(kk)=shmsg0(j)
fshort0=fshort
sync20=sync2
nkk=2
endif
endif
enddo
endif
C Is sync1 above threshold?
if(sync1.gt.1.0) then
C Keep only the best candidate within ftol.
C (Am I deleting any good decodes by doing this? Any harm in omitting
C these statements??)
if(freq-freq0.le.ftol .and. sync1.gt.sync10 .and.
+ nkk.eq.1) kk=kk-1
if(freq-freq0.gt.ftol .or. sync1.gt.sync10) then
nflip=nint(flipk)
call decode1a(id,newdat,nfilt,freq,nflip,ipol,
+ sync2,a,dt,pol,nkv,nhist,qual,decoded)
kk=kk+1
sig(kk,1)=nfile
sig(kk,2)=nutc
sig(kk,3)=freq
sig(kk,4)=sync1
sig(kk,5)=dt
sig(kk,6)=pol
sig(kk,7)=flipk
sig(kk,8)=sync2
sig(kk,9)=nkv
sig(kk,10)=qual
! sig(kk,11)=rms0
sig(kk,12)=savg(ipol,i)
sig(kk,13)=a(1)
sig(kk,14)=a(2)
sig(kk,15)=a(3)
sig(kk,16)=a(4)
! sig(kk,17)=a(5)
sig(kk,18)=nhist
msg(kk)=decoded
freq0=freq
sync10=sync1
nkk=1
endif
endif
endif
enddo
! write(*,1010)
C Trim the list and produce a sorted index and sizes of groups.
C (Should trimlist remove all but best SNR for given UTC and message content?)
call trimlist(sig,kk,indx,nsiz,nz)
do i=1,kk
done(i)=.false.
enddo
j=0
ilatest=-1
do n=1,nz
ifile0=0
do m=1,nsiz(n)
i=indx(j+m)
ifile=sig(i,1)
if(ifile.gt.ifile0 .and.msg(i).ne.blank) then
ilatest=i
ifile0=ifile
endif
enddo
i=ilatest
if(i.ge.1) then
if(.not.done(i)) then
done(i)=.true.
nutc=sig(i,2)
freq=sig(i,3)
sync1=sig(i,4)
dt=sig(i,5)
npol=nint(57.2957795*sig(i,6))
flip=sig(i,7)
sync2=sig(i,8)
nkv=sig(i,9)
nqual=min(sig(i,10),10.0)
! rms0=sig(i,11)
nsavg=sig(i,12) !Was used for diagnostic ...
do k=1,5
a(k)=sig(i,12+k)
enddo
nhist=sig(i,18)
decoded=msg(i)
if(flip.lt.0.0) then
do i=22,1,-1
if(decoded(i:i).ne.' ') go to 10
enddo
stop 'Error in message format'
10 if(i.le.18) decoded(i+2:i+4)='OOO'
endif
nkHz=nint(freq-1.600)
f0=144.0+0.001*nkHz
ndf=nint(1000.0*(freq-1.600-nkHz))
ndf0=nint(a(1))
ndf1=nint(a(2))
ndf2=nint(a(3))
nsync1=sync1
nsync2=nint(10.0*log10(sync2)) - 40 !### empirical ###
cbad=' '
if(abs(f0-144.103).lt.0.001) then
write(11,1010) nutc,nsync1,nsync2,dt,ndf,decoded,
+ nkv,nqual
endif
write(19,1012) f0,ndf,npol,nutc,decoded
1012 format(f7.3,i5,i4,i5.4,2x,a22)
write(26,1014) f0,ndf,ndf0,ndf1,ndf2,dt,npol,nsync1,
+ nsync2,nutc,decoded,nkv,nqual,nhist
1014 format(f7.3,i5,3i3,f5.1,i5,i3,i4,i5.4,2x,a22,3i3)
endif
endif
j=j+nsiz(n)
enddo
call display(nutc)
! if(nfile.ge.1) go to 999
100 continue
enddo
999 call four2a(cx,-1,1,1,1) !Destroy the FFTW plans
9999 end

334
moon2.f
View File

@ -1,167 +1,167 @@
subroutine moon2(y,m,Day,UT,lon,lat,RA,Dec,topRA,topDec,
+ LST,HA,Az,El,dist)
implicit none
integer y !Year
integer m !Month
integer Day !Day
real*8 UT !UTC in hours
real*8 RA,Dec !RA and Dec of moon
C NB: Double caps are single caps in the writeup.
real*8 NN !Longitude of ascending node
real*8 i !Inclination to the ecliptic
real*8 w !Argument of perigee
real*8 a !Semi-major axis
real*8 e !Eccentricity
real*8 MM !Mean anomaly
real*8 v !True anomaly
real*8 EE !Eccentric anomaly
real*8 ecl !Obliquity of the ecliptic
real*8 d !Ephemeris time argument in days
real*8 r !Distance to sun, AU
real*8 xv,yv !x and y coords in ecliptic
real*8 lonecl,latecl !Ecliptic long and lat of moon
real*8 xg,yg,zg !Ecliptic rectangular coords
real*8 Ms !Mean anomaly of sun
real*8 ws !Argument of perihelion of sun
real*8 Ls !Mean longitude of sun (Ns=0)
real*8 Lm !Mean longitude of moon
real*8 DD !Mean elongation of moon
real*8 FF !Argument of latitude for moon
real*8 xe,ye,ze !Equatorial geocentric coords of moon
real*8 mpar !Parallax of moon (r_E / d)
real*8 lat,lon !Station coordinates on earth
real*8 gclat !Geocentric latitude
real*8 rho !Earth radius factor
real*8 GMST0,LST,HA
real*8 g
real*8 topRA,topDec !Topocentric coordinates of Moon
real*8 Az,El
real*8 dist
real*8 rad,twopi,pi,pio2
data rad/57.2957795131d0/,twopi/6.283185307d0/
d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + Day - 730530 + UT/24.d0
ecl = 23.4393d0 - 3.563d-7 * d
C Orbital elements for Moon:
NN = 125.1228d0 - 0.0529538083d0 * d
i = 5.1454d0
w = mod(318.0634d0 + 0.1643573223d0 * d + 360000.d0,360.d0)
a = 60.2666d0
e = 0.054900d0
MM = mod(115.3654d0 + 13.0649929509d0 * d + 360000.d0,360.d0)
EE = MM + e*rad*sin(MM/rad) * (1.d0 + e*cos(M/rad))
EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.d0 - e*cos(EE/rad))
EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.d0 - e*cos(EE/rad))
xv = a * (cos(EE/rad) - e)
yv = a * (sqrt(1.d0-e*e) * sin(EE/rad))
v = mod(rad*atan2(yv,xv)+720.d0,360.d0)
r = sqrt(xv*xv + yv*yv)
C Get geocentric position in ecliptic rectangular coordinates:
xg = r * (cos(NN/rad)*cos((v+w)/rad) -
+ sin(NN/rad)*sin((v+w)/rad)*cos(i/rad))
yg = r * (sin(NN/rad)*cos((v+w)/rad) +
+ cos(NN/rad)*sin((v+w)/rad)*cos(i/rad))
zg = r * (sin((v+w)/rad)*sin(i/rad))
C Ecliptic longitude and latitude of moon:
lonecl = mod(rad*atan2(yg/rad,xg/rad)+720.d0,360.d0)
latecl = rad*atan2(zg/rad,sqrt(xg*xg + yg*yg)/rad)
C Now include orbital perturbations:
Ms = mod(356.0470d0 + 0.9856002585d0 * d + 3600000.d0,360.d0)
ws = 282.9404d0 + 4.70935d-5*d
Ls = mod(Ms + ws + 720.d0,360.d0)
Lm = mod(MM + w + NN+720.d0,360.d0)
DD = mod(Lm - Ls + 360.d0,360.d0)
FF = mod(Lm - NN + 360.d0,360.d0)
lonecl = lonecl
+ -1.274d0 * sin((MM-2.d0*DD)/rad)
+ +0.658d0 * sin(2.d0*DD/rad)
+ -0.186d0 * sin(Ms/rad)
+ -0.059d0 * sin((2.d0*MM-2.d0*DD)/rad)
+ -0.057d0 * sin((MM-2.d0*DD+Ms)/rad)
+ +0.053d0 * sin((MM+2.d0*DD)/rad)
+ +0.046d0 * sin((2.d0*DD-Ms)/rad)
+ +0.041d0 * sin((MM-Ms)/rad)
+ -0.035d0 * sin(DD/rad)
+ -0.031d0 * sin((MM+Ms)/rad)
+ -0.015d0 * sin((2.d0*FF-2.d0*DD)/rad)
+ +0.011d0 * sin((MM-4.d0*DD)/rad)
latecl = latecl
+ -0.173d0 * sin((FF-2.d0*DD)/rad)
+ -0.055d0 * sin((MM-FF-2.d0*DD)/rad)
+ -0.046d0 * sin((MM+FF-2.d0*DD)/rad)
+ +0.033d0 * sin((FF+2.d0*DD)/rad)
+ +0.017d0 * sin((2.d0*MM+FF)/rad)
r = 60.36298d0
+ - 3.27746d0*cos(MM/rad)
+ - 0.57994d0*cos((MM-2.d0*DD)/rad)
+ - 0.46357d0*cos(2.d0*DD/rad)
+ - 0.08904d0*cos(2.d0*MM/rad)
+ + 0.03865d0*cos((2.d0*MM-2.d0*DD)/rad)
+ - 0.03237d0*cos((2.d0*DD-Ms)/rad)
+ - 0.02688d0*cos((MM+2.d0*DD)/rad)
+ - 0.02358d0*cos((MM-2.d0*DD+Ms)/rad)
+ - 0.02030d0*cos((MM-Ms)/rad)
+ + 0.01719d0*cos(DD/rad)
+ + 0.01671d0*cos((MM+Ms)/rad)
dist=r*6378.140d0
C Geocentric coordinates:
C Rectangular ecliptic coordinates of the moon:
xg = r * cos(lonecl/rad)*cos(latecl/rad)
yg = r * sin(lonecl/rad)*cos(latecl/rad)
zg = r * sin(latecl/rad)
C Rectangular equatorial coordinates of the moon:
xe = xg
ye = yg*cos(ecl/rad) - zg*sin(ecl/rad)
ze = yg*sin(ecl/rad) + zg*cos(ecl/rad)
C Right Ascension, Declination:
RA = mod(rad*atan2(ye,xe)+360.d0,360.d0)
Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye))
C Now convert to topocentric system:
mpar=rad*asin(1.d0/r)
C alt_topoc = alt_geoc - mpar*cos(alt_geoc)
gclat = lat - 0.1924d0*sin(2.d0*lat/rad)
rho = 0.99883d0 + 0.00167d0*cos(2.d0*lat/rad)
GMST0 = (Ls + 180.d0)/15.d0
LST = mod(GMST0+UT+lon/15.d0+48.d0,24.d0) !LST in hours
HA = 15.d0*LST - RA !HA in degrees
g = rad*atan(tan(gclat/rad)/cos(HA/rad))
topRA = RA - mpar*rho*cos(gclat/rad)*sin(HA/rad)/cos(Dec/rad)
topDec = Dec - mpar*rho*sin(gclat/rad)*sin((g-Dec)/rad)/sin(g/rad)
HA = 15.d0*LST - topRA !HA in degrees
if(HA.gt.180.d0) HA=HA-360.d0
if(HA.lt.-180.d0) HA=HA+360.d0
pi=0.5d0*twopi
pio2=0.5d0*pi
call dcoord(pi,pio2-lat/rad,0.d0,lat/rad,ha*twopi/360,
+ topDec/rad,az,el)
Az=az*rad
El=El*rad
return
end
subroutine moon2(y,m,Day,UT,lon,lat,RA,Dec,topRA,topDec,
+ LST,HA,Az,El,dist)
implicit none
integer y !Year
integer m !Month
integer Day !Day
real*8 UT !UTC in hours
real*8 RA,Dec !RA and Dec of moon
C NB: Double caps are single caps in the writeup.
real*8 NN !Longitude of ascending node
real*8 i !Inclination to the ecliptic
real*8 w !Argument of perigee
real*8 a !Semi-major axis
real*8 e !Eccentricity
real*8 MM !Mean anomaly
real*8 v !True anomaly
real*8 EE !Eccentric anomaly
real*8 ecl !Obliquity of the ecliptic
real*8 d !Ephemeris time argument in days
real*8 r !Distance to sun, AU
real*8 xv,yv !x and y coords in ecliptic
real*8 lonecl,latecl !Ecliptic long and lat of moon
real*8 xg,yg,zg !Ecliptic rectangular coords
real*8 Ms !Mean anomaly of sun
real*8 ws !Argument of perihelion of sun
real*8 Ls !Mean longitude of sun (Ns=0)
real*8 Lm !Mean longitude of moon
real*8 DD !Mean elongation of moon
real*8 FF !Argument of latitude for moon
real*8 xe,ye,ze !Equatorial geocentric coords of moon
real*8 mpar !Parallax of moon (r_E / d)
real*8 lat,lon !Station coordinates on earth
real*8 gclat !Geocentric latitude
real*8 rho !Earth radius factor
real*8 GMST0,LST,HA
real*8 g
real*8 topRA,topDec !Topocentric coordinates of Moon
real*8 Az,El
real*8 dist
real*8 rad,twopi,pi,pio2
data rad/57.2957795131d0/,twopi/6.283185307d0/
d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + Day - 730530 + UT/24.d0
ecl = 23.4393d0 - 3.563d-7 * d
C Orbital elements for Moon:
NN = 125.1228d0 - 0.0529538083d0 * d
i = 5.1454d0
w = mod(318.0634d0 + 0.1643573223d0 * d + 360000.d0,360.d0)
a = 60.2666d0
e = 0.054900d0
MM = mod(115.3654d0 + 13.0649929509d0 * d + 360000.d0,360.d0)
EE = MM + e*rad*sin(MM/rad) * (1.d0 + e*cos(M/rad))
EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.d0 - e*cos(EE/rad))
EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.d0 - e*cos(EE/rad))
xv = a * (cos(EE/rad) - e)
yv = a * (sqrt(1.d0-e*e) * sin(EE/rad))
v = mod(rad*atan2(yv,xv)+720.d0,360.d0)
r = sqrt(xv*xv + yv*yv)
C Get geocentric position in ecliptic rectangular coordinates:
xg = r * (cos(NN/rad)*cos((v+w)/rad) -
+ sin(NN/rad)*sin((v+w)/rad)*cos(i/rad))
yg = r * (sin(NN/rad)*cos((v+w)/rad) +
+ cos(NN/rad)*sin((v+w)/rad)*cos(i/rad))
zg = r * (sin((v+w)/rad)*sin(i/rad))
C Ecliptic longitude and latitude of moon:
lonecl = mod(rad*atan2(yg/rad,xg/rad)+720.d0,360.d0)
latecl = rad*atan2(zg/rad,sqrt(xg*xg + yg*yg)/rad)
C Now include orbital perturbations:
Ms = mod(356.0470d0 + 0.9856002585d0 * d + 3600000.d0,360.d0)
ws = 282.9404d0 + 4.70935d-5*d
Ls = mod(Ms + ws + 720.d0,360.d0)
Lm = mod(MM + w + NN+720.d0,360.d0)
DD = mod(Lm - Ls + 360.d0,360.d0)
FF = mod(Lm - NN + 360.d0,360.d0)
lonecl = lonecl
+ -1.274d0 * sin((MM-2.d0*DD)/rad)
+ +0.658d0 * sin(2.d0*DD/rad)
+ -0.186d0 * sin(Ms/rad)
+ -0.059d0 * sin((2.d0*MM-2.d0*DD)/rad)
+ -0.057d0 * sin((MM-2.d0*DD+Ms)/rad)
+ +0.053d0 * sin((MM+2.d0*DD)/rad)
+ +0.046d0 * sin((2.d0*DD-Ms)/rad)
+ +0.041d0 * sin((MM-Ms)/rad)
+ -0.035d0 * sin(DD/rad)
+ -0.031d0 * sin((MM+Ms)/rad)
+ -0.015d0 * sin((2.d0*FF-2.d0*DD)/rad)
+ +0.011d0 * sin((MM-4.d0*DD)/rad)
latecl = latecl
+ -0.173d0 * sin((FF-2.d0*DD)/rad)
+ -0.055d0 * sin((MM-FF-2.d0*DD)/rad)
+ -0.046d0 * sin((MM+FF-2.d0*DD)/rad)
+ +0.033d0 * sin((FF+2.d0*DD)/rad)
+ +0.017d0 * sin((2.d0*MM+FF)/rad)
r = 60.36298d0
+ - 3.27746d0*cos(MM/rad)
+ - 0.57994d0*cos((MM-2.d0*DD)/rad)
+ - 0.46357d0*cos(2.d0*DD/rad)
+ - 0.08904d0*cos(2.d0*MM/rad)
+ + 0.03865d0*cos((2.d0*MM-2.d0*DD)/rad)
+ - 0.03237d0*cos((2.d0*DD-Ms)/rad)
+ - 0.02688d0*cos((MM+2.d0*DD)/rad)
+ - 0.02358d0*cos((MM-2.d0*DD+Ms)/rad)
+ - 0.02030d0*cos((MM-Ms)/rad)
+ + 0.01719d0*cos(DD/rad)
+ + 0.01671d0*cos((MM+Ms)/rad)
dist=r*6378.140d0
C Geocentric coordinates:
C Rectangular ecliptic coordinates of the moon:
xg = r * cos(lonecl/rad)*cos(latecl/rad)
yg = r * sin(lonecl/rad)*cos(latecl/rad)
zg = r * sin(latecl/rad)
C Rectangular equatorial coordinates of the moon:
xe = xg
ye = yg*cos(ecl/rad) - zg*sin(ecl/rad)
ze = yg*sin(ecl/rad) + zg*cos(ecl/rad)
C Right Ascension, Declination:
RA = mod(rad*atan2(ye,xe)+360.d0,360.d0)
Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye))
C Now convert to topocentric system:
mpar=rad*asin(1.d0/r)
C alt_topoc = alt_geoc - mpar*cos(alt_geoc)
gclat = lat - 0.1924d0*sin(2.d0*lat/rad)
rho = 0.99883d0 + 0.00167d0*cos(2.d0*lat/rad)
GMST0 = (Ls + 180.d0)/15.d0
LST = mod(GMST0+UT+lon/15.d0+48.d0,24.d0) !LST in hours
HA = 15.d0*LST - RA !HA in degrees
g = rad*atan(tan(gclat/rad)/cos(HA/rad))
topRA = RA - mpar*rho*cos(gclat/rad)*sin(HA/rad)/cos(Dec/rad)
topDec = Dec - mpar*rho*sin(gclat/rad)*sin((g-Dec)/rad)/sin(g/rad)
HA = 15.d0*LST - topRA !HA in degrees
if(HA.gt.180.d0) HA=HA-360.d0
if(HA.lt.-180.d0) HA=HA+360.d0
pi=0.5d0*twopi
pio2=0.5d0*pi
call dcoord(pi,pio2-lat/rad,0.d0,lat/rad,ha*twopi/360,
+ topDec/rad,az,el)
Az=az*rad
El=El*rad
return
end

180
morse.f
View File

@ -1,90 +1,90 @@
subroutine morse(msg,idat,n)
C Convert ascii message to a Morse code bit string.
C Dash = 3 dots
C Space between dots, dashes = 1 dot
C Space between letters = 3 dots
C Space between words = 7 dots
character*22 msg
integer*1 idat(460)
integer*1 ic(21,38)
data ic/
+ 1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,20,
+ 1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,18,
+ 1,0,1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,16,
+ 1,0,1,0,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14,
+ 1,0,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12,
+ 1,0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,1,1,0,1,0,1,0,1,0,0,0,0,0,0,0,14,
+ 1,1,1,0,1,1,1,0,1,1,1,0,1,0,1,0,0,0,0,0,16,
+ 1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,0,0,0,18,
+ 1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6,
+ 1,1,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 2,
+ 1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 4,
+ 1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14,
+ 1,1,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,0,1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6,
+ 1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12,
+ 1,0,1,1,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,1,1,0,1,0,1,1,1,0,0,0,0,0,0,0,14,
+ 1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6,
+ 1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 4,
+ 1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14,
+ 1,1,1,0,1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,14,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 2/ !Incremental word space
save
C Find length of message
do i=22,1,-1
if(msg(i:i).ne.' ') go to 1
enddo
1 msglen=i
n=0
do k=1,msglen
jj=ichar(msg(k:k))
if(jj.ge.97 .and. jj.le.122) jj=jj-32 !Convert lower to upper case
if(jj.ge.48 .and. jj.le.57) j=jj-48 !Numbers
if(jj.ge.65 .and. jj.le.90) j=jj-55 !Letters
if(jj.eq.47) j=36 !Slash (/)
if(jj.eq.32) j=37 !Word space
j=j+1
C Insert this character
nmax=ic(21,j)
do i=1,nmax
n=n+1
idat(n)=ic(i,j)
enddo
C Insert character space of 2 dit lengths:
n=n+1
idat(n)=0
n=n+1
idat(n)=0
enddo
C Insert word space at end of message
do j=1,4
n=n+1
idat(n)=0
enddo
return
end
subroutine morse(msg,idat,n)
C Convert ascii message to a Morse code bit string.
C Dash = 3 dots
C Space between dots, dashes = 1 dot
C Space between letters = 3 dots
C Space between words = 7 dots
character*22 msg
integer*1 idat(460)
integer*1 ic(21,38)
data ic/
+ 1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,20,
+ 1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,18,
+ 1,0,1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,16,
+ 1,0,1,0,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14,
+ 1,0,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12,
+ 1,0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,1,1,0,1,0,1,0,1,0,0,0,0,0,0,0,14,
+ 1,1,1,0,1,1,1,0,1,1,1,0,1,0,1,0,0,0,0,0,16,
+ 1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,0,0,0,18,
+ 1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6,
+ 1,1,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 2,
+ 1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 4,
+ 1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14,
+ 1,1,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,0,1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6,
+ 1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12,
+ 1,0,1,1,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,1,1,0,1,0,1,1,1,0,0,0,0,0,0,0,14,
+ 1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6,
+ 1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 4,
+ 1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8,
+ 1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10,
+ 1,1,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14,
+ 1,1,1,0,1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,12,
+ 1,1,1,0,1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,14,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 2/ !Incremental word space
save
C Find length of message
do i=22,1,-1
if(msg(i:i).ne.' ') go to 1
enddo
1 msglen=i
n=0
do k=1,msglen
jj=ichar(msg(k:k))
if(jj.ge.97 .and. jj.le.122) jj=jj-32 !Convert lower to upper case
if(jj.ge.48 .and. jj.le.57) j=jj-48 !Numbers
if(jj.ge.65 .and. jj.le.90) j=jj-55 !Letters
if(jj.eq.47) j=36 !Slash (/)
if(jj.eq.32) j=37 !Word space
j=j+1
C Insert this character
nmax=ic(21,j)
do i=1,nmax
n=n+1
idat(n)=ic(i,j)
enddo
C Insert character space of 2 dit lengths:
n=n+1
idat(n)=0
n=n+1
idat(n)=0
enddo
C Insert word space at end of message
do j=1,4
n=n+1
idat(n)=0
enddo
return
end

44
nchar.f
View File

@ -1,22 +1,22 @@
function nchar(c)
C Convert ascii number, letter, or space to 0-36 for callsign packing.
character c*1
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(c)
C Convert ascii number, letter, or space to 0-36 for callsign packing.
character c*1
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

152
packcall.f
View File

@ -1,76 +1,76 @@
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
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
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(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
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
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

128
packdxcc.f
View File

@ -1,64 +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(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

94
packgrid.f
View File

@ -1,47 +1,47 @@
subroutine packgrid(grid,ng,text)
parameter (NGBASE=180*180)
character*4 grid
logical text
text=.false.
if(grid.eq.' ') go to 90 !Blank grid is OK
C Test for numerical signal report, etc.
if(grid(1:1).eq.'-') then
read(grid(2:3),*,err=1,end=1) n
1 ng=NGBASE+1+n
go to 100
else if(grid(1:2).eq.'R-') then
read(grid(3:4),*,err=2,end=2) n
2 if(n.eq.0) go to 90
ng=NGBASE+31+n
go to 100
else if(grid(1:2).eq.'RO') then
ng=NGBASE+62
go to 100
else if(grid(1:3).eq.'RRR') then
ng=NGBASE+63
go to 100
else if(grid(1:2).eq.'73') then
ng=NGBASE+64
go to 100
endif
if(grid(1:1).lt.'A' .or. grid(1:1).gt.'Z') text=.true.
if(grid(2:2).lt.'A' .or. grid(2:2).gt.'Z') text=.true.
if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true.
if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true.
if(text) go to 100
call grid2deg(grid//'mm',dlong,dlat)
long=dlong
lat=dlat+ 90.0
ng=((long+180)/2)*180 + lat
go to 100
90 ng=NGBASE + 1
100 return
end
subroutine packgrid(grid,ng,text)
parameter (NGBASE=180*180)
character*4 grid
logical text
text=.false.
if(grid.eq.' ') go to 90 !Blank grid is OK
C Test for numerical signal report, etc.
if(grid(1:1).eq.'-') then
read(grid(2:3),*,err=1,end=1) n
1 ng=NGBASE+1+n
go to 100
else if(grid(1:2).eq.'R-') then
read(grid(3:4),*,err=2,end=2) n
2 if(n.eq.0) go to 90
ng=NGBASE+31+n
go to 100
else if(grid(1:2).eq.'RO') then
ng=NGBASE+62
go to 100
else if(grid(1:3).eq.'RRR') then
ng=NGBASE+63
go to 100
else if(grid(1:2).eq.'73') then
ng=NGBASE+64
go to 100
endif
if(grid(1:1).lt.'A' .or. grid(1:1).gt.'Z') text=.true.
if(grid(2:2).lt.'A' .or. grid(2:2).gt.'Z') text=.true.
if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true.
if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true.
if(text) go to 100
call grid2deg(grid//'mm',dlong,dlat)
long=dlong
lat=dlat+ 90.0
ng=((long+180)/2)*180 + lat
go to 100
90 ng=NGBASE + 1
100 return
end

170
packmsg.f
View File

@ -1,85 +1,85 @@
subroutine packmsg(msg,dat)
parameter (NBASE=37*36*10*27*27*27)
character*22 msg
integer dat(12)
character*12 c1,c2
character*4 c3
character*6 grid6
c character*3 dxcc !Where is DXCC implemented?
logical text1,text2,text3
C Convert all letters to upper case
do i=1,22
if(msg(i:i).ge.'a' .and. msg(i:i).le.'z')
+ msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a'))
enddo
C See if it's a CQ message
if(msg(1:3).eq.'CQ ') then
i=3
C ... and if so, does it have a reply frequency?
if(msg(4:4).ge.'0' .and. msg(4:4).le.'9' .and.
+ msg(5:5).ge.'0' .and. msg(5:5).le.'9' .and.
+ msg(6:6).ge.'0' .and. msg(6:6).le.'9') i=7
go to 1
endif
do i=1,22
if(msg(i:i).eq.' ') go to 1 !Get 1st blank
enddo
go to 10 !Consider msg as plain text
1 ia=i
c1=msg(1:ia-1)
do i=ia+1,22
if(msg(i:i).eq.' ') go to 2 !Get 2nd blank
enddo
go to 10 !Consider msg as plain text
2 ib=i
c2=msg(ia+1:ib-1)
do i=ib+1,22
if(msg(i:i).eq.' ') go to 3 !Get 3rd blank
enddo
go to 10 !Consider msg as plain text
3 ic=i
c3=' '
if(ic.ge.ib+1) c3=msg(ib+1:ic)
if(c3.eq.'OOO ') c3=' ' !Strip out the OOO flag
call getpfx1(c1,k1)
call packcall(c1,nc1,text1)
call getpfx1(c2,k2)
call packcall(c2,nc2,text2)
if(k1.lt.0 .or. k2.lt.0 .or. k1*k2.ne.0) go to 10
if(k2.gt.0) k2=k2+450
k=max(k1,k2)
if(k.gt.0) then
call k2grid(k,grid6)
c3=grid6
endif
call packgrid(c3,ng,text3)
if((.not.text1) .and. (.not.text2) .and. (.not.text3)) go to 20
C The message will be treated as plain text.
10 call packtext(msg,nc1,nc2,ng)
ng=ng+32768
C Encode data into 6-bit words
20 dat(1)=iand(ishft(nc1,-22),63) !6 bits
dat(2)=iand(ishft(nc1,-16),63) !6 bits
dat(3)=iand(ishft(nc1,-10),63) !6 bits
dat(4)=iand(ishft(nc1, -4),63) !6 bits
dat(5)=4*iand(nc1,15)+iand(ishft(nc2,-26),3) !4+2 bits
dat(6)=iand(ishft(nc2,-20),63) !6 bits
dat(7)=iand(ishft(nc2,-14),63) !6 bits
dat(8)=iand(ishft(nc2, -8),63) !6 bits
dat(9)=iand(ishft(nc2, -2),63) !6 bits
dat(10)=16*iand(nc2,3)+iand(ishft(ng,-12),15) !2+4 bits
dat(11)=iand(ishft(ng,-6),63)
dat(12)=iand(ng,63)
return
end
subroutine packmsg(msg,dat)
parameter (NBASE=37*36*10*27*27*27)
character*22 msg
integer dat(12)
character*12 c1,c2
character*4 c3
character*6 grid6
c character*3 dxcc !Where is DXCC implemented?
logical text1,text2,text3
C Convert all letters to upper case
do i=1,22
if(msg(i:i).ge.'a' .and. msg(i:i).le.'z')
+ msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a'))
enddo
C See if it's a CQ message
if(msg(1:3).eq.'CQ ') then
i=3
C ... and if so, does it have a reply frequency?
if(msg(4:4).ge.'0' .and. msg(4:4).le.'9' .and.
+ msg(5:5).ge.'0' .and. msg(5:5).le.'9' .and.
+ msg(6:6).ge.'0' .and. msg(6:6).le.'9') i=7
go to 1
endif
do i=1,22
if(msg(i:i).eq.' ') go to 1 !Get 1st blank
enddo
go to 10 !Consider msg as plain text
1 ia=i
c1=msg(1:ia-1)
do i=ia+1,22
if(msg(i:i).eq.' ') go to 2 !Get 2nd blank
enddo
go to 10 !Consider msg as plain text
2 ib=i
c2=msg(ia+1:ib-1)
do i=ib+1,22
if(msg(i:i).eq.' ') go to 3 !Get 3rd blank
enddo
go to 10 !Consider msg as plain text
3 ic=i
c3=' '
if(ic.ge.ib+1) c3=msg(ib+1:ic)
if(c3.eq.'OOO ') c3=' ' !Strip out the OOO flag
call getpfx1(c1,k1)
call packcall(c1,nc1,text1)
call getpfx1(c2,k2)
call packcall(c2,nc2,text2)
if(k1.lt.0 .or. k2.lt.0 .or. k1*k2.ne.0) go to 10
if(k2.gt.0) k2=k2+450
k=max(k1,k2)
if(k.gt.0) then
call k2grid(k,grid6)
c3=grid6
endif
call packgrid(c3,ng,text3)
if((.not.text1) .and. (.not.text2) .and. (.not.text3)) go to 20
C The message will be treated as plain text.
10 call packtext(msg,nc1,nc2,ng)
ng=ng+32768
C Encode data into 6-bit words
20 dat(1)=iand(ishft(nc1,-22),63) !6 bits
dat(2)=iand(ishft(nc1,-16),63) !6 bits
dat(3)=iand(ishft(nc1,-10),63) !6 bits
dat(4)=iand(ishft(nc1, -4),63) !6 bits
dat(5)=4*iand(nc1,15)+iand(ishft(nc2,-26),3) !4+2 bits
dat(6)=iand(ishft(nc2,-20),63) !6 bits
dat(7)=iand(ishft(nc2,-14),63) !6 bits
dat(8)=iand(ishft(nc2, -8),63) !6 bits
dat(9)=iand(ishft(nc2, -2),63) !6 bits
dat(10)=16*iand(nc2,3)+iand(ishft(ng,-12),15) !2+4 bits
dat(11)=iand(ishft(ng,-6),63)
dat(12)=iand(ng,63)
return
end

94
packtext.f
View File

@ -1,47 +1,47 @@
subroutine packtext(msg,nc1,nc2,nc3)
parameter (MASK28=2**28 - 1)
character*13 msg
character*44 c
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/
nc1=0
nc2=0
nc3=0
do i=1,5 !First 5 characters in nc1
do j=1,44 !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,44 !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,44 !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
subroutine packtext(msg,nc1,nc2,nc3)
parameter (MASK28=2**28 - 1)
character*13 msg
character*44 c
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/
nc1=0
nc2=0
nc3=0
do i=1,5 !First 5 characters in nc1
do j=1,44 !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,44 !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,44 !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

26
pctile.f
View File

@ -1,13 +1,13 @@
subroutine pctile(x,tmp,nmax,npct,xpct)
real x(nmax),tmp(nmax)
do i=1,nmax
tmp(i)=x(i)
enddo
call sort(nmax,tmp)
j=nint(nmax*0.01*npct)
if(j.lt.1) j=1
xpct=tmp(j)
return
end
subroutine pctile(x,tmp,nmax,npct,xpct)
real x(nmax),tmp(nmax)
do i=1,nmax
tmp(i)=x(i)
enddo
call sort(nmax,tmp)
j=nint(nmax*0.01*npct)
if(j.lt.1) j=1
xpct=tmp(j)
return
end

16
peakup.f
View File

@ -1,8 +1,8 @@
subroutine peakup(ym,y0,yp,dx)
b=(yp-ym)/2.0
c=(yp+ym-2.0*y0)/2.0
dx=-b/(2.0*c)
return
end
subroutine peakup(ym,y0,yp,dx)
b=(yp-ym)/2.0
c=(yp+ym-2.0*y0)/2.0
dx=-b/(2.0*c)
return
end

100
pfx.f
View File

@ -1,50 +1,50 @@
parameter (NZ=338) !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 '/
parameter (NZ=338) !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 '/

56
pix2d65.f90
View File

@ -1,28 +1,28 @@
subroutine pix2d65(d2,jz)
! Compute data for green line in JT65 mode.
integer*2 d2(jz) !Raw input data
include 'gcom2.f90'
sum=0.
do i=1,jz
sum=sum+d2(i)
enddo
nave=nint(sum/jz)
nadd=nint(53.0*11025.0/500.0)
ngreen=min(jz/nadd,500)
k=0
do i=1,ngreen
sq=0.
do n=1,nadd
k=k+1
d2(k)=d2(k)-nave
x=d2(k)
sq=sq + x*x
enddo
green(i)=db(sq)-96.0
enddo
return
end subroutine pix2d65
subroutine pix2d65(d2,jz)
! Compute data for green line in JT65 mode.
integer*2 d2(jz) !Raw input data
include 'gcom2.f90'
sum=0.
do i=1,jz
sum=sum+d2(i)
enddo
nave=nint(sum/jz)
nadd=nint(53.0*11025.0/500.0)
ngreen=min(jz/nadd,500)
k=0
do i=1,ngreen
sq=0.
do n=1,nadd
k=k+1
d2(k)=d2(k)-nave
x=d2(k)
sq=sq + x*x
enddo
green(i)=db(sq)-96.0
enddo
return
end subroutine pix2d65

2246
portaudio.h
View File

File diff suppressed because it is too large Load Diff

2
prcom.h
View File

@ -1 +1 @@
common/prcom/pr(135),mdat(126),mref(126,2),mdat2(126),mref2(126,2)
common/prcom/pr(135),mdat(126),mref(126,2),mdat2(126),mref2(126,2)

46
ps.f
View File

@ -1,23 +1,23 @@
subroutine ps(dat,nfft,s)
parameter (NMAX=16384+2)
parameter (NHMAX=NMAX/2-1)
real dat(nfft)
real s(NHMAX)
real x(NMAX)
complex c(0:NHMAX)
equivalence (x,c)
nh=nfft/2
do i=1,nfft
x(i)=dat(i)/128.0 !### Why 128 ??
enddo
call xfft(x,nfft)
fac=1.0/nfft
do i=1,nh
s(i)=fac*(real(c(i))**2 + aimag(c(i))**2)
enddo
return
end
subroutine ps(dat,nfft,s)
parameter (NMAX=16384+2)
parameter (NHMAX=NMAX/2-1)
real dat(nfft)
real s(NHMAX)
real x(NMAX)
complex c(0:NHMAX)
equivalence (x,c)
nh=nfft/2
do i=1,nfft
x(i)=dat(i)/128.0 !### Why 128 ??
enddo
call xfft(x,nfft)
fac=1.0/nfft
do i=1,nh
s(i)=fac*(real(c(i))**2 + aimag(c(i))**2)
enddo
return
end

12
resample.c
View File

@ -1,7 +1,8 @@
#include <stdio.h>
#include <samplerate.h>
int resample_( float din[], float dout[], double *samfac, int *jz)
int resample_(float din[], int *jzin, int *conv_type, int *channels,
double *samfac, float dout[], int *jzout)
{
SRC_DATA src_data;
int input_len;
@ -10,7 +11,7 @@ int resample_( float din[], float dout[], double *samfac, int *jz)
double src_ratio;
src_ratio=*samfac;
input_len=*jz;
input_len=*jzin;
output_len=(int) (input_len*src_ratio);
src_data.data_in=din;
@ -19,10 +20,7 @@ int resample_( float din[], float dout[], double *samfac, int *jz)
src_data.input_frames=input_len;
src_data.output_frames=output_len;
ierr=src_simple(&src_data,2,1);
*jz=output_len;
/* printf("%d %d %d %d %f\n",input_len,output_len,src_data.input_frames_used,
src_data.output_frames_gen,src_ratio);
*/
ierr=src_simple(&src_data,*conv_type,*channels);
*jzout=output_len;
return ierr;
}

52
rfile2.f
View File

@ -1,26 +1,26 @@
subroutine rfile2(fname,buf,n,nr)
C Write a wave file to disk.
integer RMODE
parameter(RMODE=0)
integer*1 buf(n)
integer open,read,close
integer fd
character fname*80
data iz/0/ !Silence g77 warning
do i=80,1,-1
if(fname(i:i).ne.' ') then
iz=i
go to 10
endif
enddo
10 fname=fname(1:iz)//char(0)
fd=open(fname,RMODE) !Open file for reading
nr=read(fd,buf,n)
i=close(fd)
return
end
subroutine rfile2(fname,buf,n,nr)
C Write a wave file to disk.
integer RMODE
parameter(RMODE=0)
integer*1 buf(n)
integer open,read,close
integer fd
character fname*80
data iz/0/ !Silence g77 warning
do i=80,1,-1
if(fname(i:i).ne.' ') then
iz=i
go to 10
endif
enddo
10 fname=fname(1:iz)//char(0)
fd=open(fname,RMODE) !Open file for reading
nr=read(fd,buf,n)
i=close(fd)
return
end

70
rs.h
View File

@ -1,35 +1,35 @@
/* User include file for the Reed-Solomon codec
* Copyright 2002, Phil Karn KA9Q
* May be used under the terms of the GNU General Public License (GPL)
*/
/* General purpose RS codec, 8-bit symbols */
void encode_rs_char(void *rs,unsigned char *data,unsigned char *parity);
int decode_rs_char(void *rs,unsigned char *data,int *eras_pos,
int no_eras);
void *init_rs_char(int symsize,int gfpoly,
int fcr,int prim,int nroots,
int pad);
void free_rs_char(void *rs);
/* General purpose RS codec, integer symbols */
void encode_rs_int(void *rs,int *data,int *parity);
int decode_rs_int(void *rs,int *data,int *eras_pos,int no_eras);
void *init_rs_int(int symsize,int gfpoly,int fcr,
int prim,int nroots,int pad);
void free_rs_int(void *rs);
/* CCSDS standard (255,223) RS codec with conventional (*not* dual-basis)
* symbol representation
*/
void encode_rs_8(unsigned char *data,unsigned char *parity,int pad);
int decode_rs_8(unsigned char *data,int *eras_pos,int no_eras,int pad);
/* CCSDS standard (255,223) RS codec with dual-basis symbol representation */
void encode_rs_ccsds(unsigned char *data,unsigned char *parity,int pad);
int decode_rs_ccsds(unsigned char *data,int *eras_pos,int no_eras,int pad);
/* Tables to map from conventional->dual (Taltab) and
* dual->conventional (Tal1tab) bases
*/
extern unsigned char Taltab[],Tal1tab[];
/* User include file for the Reed-Solomon codec
* Copyright 2002, Phil Karn KA9Q
* May be used under the terms of the GNU General Public License (GPL)
*/
/* General purpose RS codec, 8-bit symbols */
void encode_rs_char(void *rs,unsigned char *data,unsigned char *parity);
int decode_rs_char(void *rs,unsigned char *data,int *eras_pos,
int no_eras);
void *init_rs_char(int symsize,int gfpoly,
int fcr,int prim,int nroots,
int pad);
void free_rs_char(void *rs);
/* General purpose RS codec, integer symbols */
void encode_rs_int(void *rs,int *data,int *parity);
int decode_rs_int(void *rs,int *data,int *eras_pos,int no_eras);
void *init_rs_int(int symsize,int gfpoly,int fcr,
int prim,int nroots,int pad);
void free_rs_int(void *rs);
/* CCSDS standard (255,223) RS codec with conventional (*not* dual-basis)
* symbol representation
*/
void encode_rs_8(unsigned char *data,unsigned char *parity,int pad);
int decode_rs_8(unsigned char *data,int *eras_pos,int no_eras,int pad);
/* CCSDS standard (255,223) RS codec with dual-basis symbol representation */
void encode_rs_ccsds(unsigned char *data,unsigned char *parity,int pad);
int decode_rs_ccsds(unsigned char *data,int *eras_pos,int no_eras,int pad);
/* Tables to map from conventional->dual (Taltab) and
* dual->conventional (Tal1tab) bases
*/
extern unsigned char Taltab[],Tal1tab[];

23
runqqq.F90
View File

@ -15,26 +15,3 @@ subroutine runqqq(fname,cmnd,iret)
return
end subroutine runqqq
subroutine flushqqq(lu)
#ifdef Win32
use dfport
#endif
call flush(lu)
return
end subroutine flushqqq
subroutine sleepqqq(n)
#ifdef Win32
use dflib
call sleepqq(n)
#else
call usleep(n*1000)
#endif
return
end subroutine sleepqqq

392
samplerate.h
View File

@ -1,196 +1,196 @@
/*
** Copyright (C) 2002-2004 Erik de Castro Lopo <erikd@mega-nerd.com>
**
** This program is free software; you can redistribute it and/or modify
** it under the terms of the GNU General Public License as published by
** the Free Software Foundation; either version 2 of the License, or
** (at your option) any later version.
**
** This program is distributed in the hope that it will be useful,
** but WITHOUT ANY WARRANTY; without even the implied warranty of
** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
** GNU General Public License for more details.
**
** You should have received a copy of the GNU General Public License
** along with this program; if not, write to the Free Software
** Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
*/
/*
** API documentation is available here:
** http://www.mega-nerd.com/SRC/api.html
*/
#ifndef SAMPLERATE_H
#define SAMPLERATE_H
#ifdef __cplusplus
extern "C" {
#endif /* __cplusplus */
/* Opaque data type SRC_STATE. */
typedef struct SRC_STATE_tag SRC_STATE ;
/* SRC_DATA is used to pass data to src_simple() and src_process(). */
typedef struct
{ float *data_in, *data_out ;
long input_frames, output_frames ;
long input_frames_used, output_frames_gen ;
int end_of_input ;
double src_ratio ;
} SRC_DATA ;
/* SRC_CB_DATA is used with callback based API. */
typedef struct
{ long frames ;
float *data_in ;
} SRC_CB_DATA ;
/*
** User supplied callback function type for use with src_callback_new()
** and src_callback_read(). First parameter is the same pointer that was
** passed into src_callback_new(). Second parameter is pointer to a
** pointer. The user supplied callback function must modify *data to
** point to the start of the user supplied float array. The user supplied
** function must return the number of frames that **data points to.
*/
typedef long (*src_callback_t) (void *cb_data, float **data) ;
/*
** Standard initialisation function : return an anonymous pointer to the
** internal state of the converter. Choose a converter from the enums below.
** Error returned in *error.
*/
SRC_STATE* src_new (int converter_type, int channels, int *error) ;
/*
** Initilisation for callback based API : return an anonymous pointer to the
** internal state of the converter. Choose a converter from the enums below.
** The cb_data pointer can point to any data or be set to NULL. Whatever the
** value, when processing, user supplied function "func" gets called with
** cb_data as first parameter.
*/
SRC_STATE* src_callback_new (src_callback_t func, int converter_type, int channels,
int *error, void* cb_data) ;
/*
** Cleanup all internal allocations.
** Always returns NULL.
*/
SRC_STATE* src_delete (SRC_STATE *state) ;
/*
** Standard processing function.
** Returns non zero on error.
*/
int src_process (SRC_STATE *state, SRC_DATA *data) ;
/*
** Callback based processing function. Read up to frames worth of data from
** the converter int *data and return frames read or -1 on error.
*/
long src_callback_read (SRC_STATE *state, double src_ratio, long frames, float *data) ;
/*
** Simple interface for performing a single conversion from input buffer to
** output buffer at a fixed conversion ratio.
** Simple interface does not require initialisation as it can only operate on
** a single buffer worth of audio.
*/
int src_simple (SRC_DATA *data, int converter_type, int channels) ;
/*
** This library contains a number of different sample rate converters,
** numbered 0 through N.
**
** Return a string giving either a name or a more full description of each
** sample rate converter or NULL if no sample rate converter exists for
** the given value. The converters are sequentially numbered from 0 to N.
*/
const char *src_get_name (int converter_type) ;
const char *src_get_description (int converter_type) ;
const char *src_get_version (void) ;
/*
** Set a new SRC ratio. This allows step responses
** in the conversion ratio.
** Returns non zero on error.
*/
int src_set_ratio (SRC_STATE *state, double new_ratio) ;
/*
** Reset the internal SRC state.
** Does not modify the quality settings.
** Does not free any memory allocations.
** Returns non zero on error.
*/
int src_reset (SRC_STATE *state) ;
/*
** Return TRUE if ratio is a valid conversion ratio, FALSE
** otherwise.
*/
int src_is_valid_ratio (double ratio) ;
/*
** Return an error number.
*/
int src_error (SRC_STATE *state) ;
/*
** Convert the error number into a string.
*/
const char* src_strerror (int error) ;
/*
** The following enums can be used to set the interpolator type
** using the function src_set_converter().
*/
enum
{
SRC_SINC_BEST_QUALITY = 0,
SRC_SINC_MEDIUM_QUALITY = 1,
SRC_SINC_FASTEST = 2,
SRC_ZERO_ORDER_HOLD = 3,
SRC_LINEAR = 4
} ;
/*
** Extra helper functions for converting from short to float and
** back again.
*/
void src_short_to_float_array (const short *in, float *out, int len) ;
void src_float_to_short_array (const float *in, short *out, int len) ;
#ifdef __cplusplus
} /* extern "C" */
#endif /* __cplusplus */
#endif /* SAMPLERATE_H */
/*
** Do not edit or modify anything in this comment block.
** The arch-tag line is a file identity tag for the GNU Arch
** revision control system.
**
** arch-tag: 5421ef3e-c898-4ec3-8671-ea03d943ee00
*/
/*
** Copyright (C) 2002-2004 Erik de Castro Lopo <erikd@mega-nerd.com>
**
** This program is free software; you can redistribute it and/or modify
** it under the terms of the GNU General Public License as published by
** the Free Software Foundation; either version 2 of the License, or
** (at your option) any later version.
**
** This program is distributed in the hope that it will be useful,
** but WITHOUT ANY WARRANTY; without even the implied warranty of
** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
** GNU General Public License for more details.
**
** You should have received a copy of the GNU General Public License
** along with this program; if not, write to the Free Software
** Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
*/
/*
** API documentation is available here:
** http://www.mega-nerd.com/SRC/api.html
*/
#ifndef SAMPLERATE_H
#define SAMPLERATE_H
#ifdef __cplusplus
extern "C" {
#endif /* __cplusplus */
/* Opaque data type SRC_STATE. */
typedef struct SRC_STATE_tag SRC_STATE ;
/* SRC_DATA is used to pass data to src_simple() and src_process(). */
typedef struct
{ float *data_in, *data_out ;
long input_frames, output_frames ;
long input_frames_used, output_frames_gen ;
int end_of_input ;
double src_ratio ;
} SRC_DATA ;
/* SRC_CB_DATA is used with callback based API. */
typedef struct
{ long frames ;
float *data_in ;
} SRC_CB_DATA ;
/*
** User supplied callback function type for use with src_callback_new()
** and src_callback_read(). First parameter is the same pointer that was
** passed into src_callback_new(). Second parameter is pointer to a
** pointer. The user supplied callback function must modify *data to
** point to the start of the user supplied float array. The user supplied
** function must return the number of frames that **data points to.
*/
typedef long (*src_callback_t) (void *cb_data, float **data) ;
/*
** Standard initialisation function : return an anonymous pointer to the
** internal state of the converter. Choose a converter from the enums below.
** Error returned in *error.
*/
SRC_STATE* src_new (int converter_type, int channels, int *error) ;
/*
** Initilisation for callback based API : return an anonymous pointer to the
** internal state of the converter. Choose a converter from the enums below.
** The cb_data pointer can point to any data or be set to NULL. Whatever the
** value, when processing, user supplied function "func" gets called with
** cb_data as first parameter.
*/
SRC_STATE* src_callback_new (src_callback_t func, int converter_type, int channels,
int *error, void* cb_data) ;
/*
** Cleanup all internal allocations.
** Always returns NULL.
*/
SRC_STATE* src_delete (SRC_STATE *state) ;
/*
** Standard processing function.
** Returns non zero on error.
*/
int src_process (SRC_STATE *state, SRC_DATA *data) ;
/*
** Callback based processing function. Read up to frames worth of data from
** the converter int *data and return frames read or -1 on error.
*/
long src_callback_read (SRC_STATE *state, double src_ratio, long frames, float *data) ;
/*
** Simple interface for performing a single conversion from input buffer to
** output buffer at a fixed conversion ratio.
** Simple interface does not require initialisation as it can only operate on
** a single buffer worth of audio.
*/
int src_simple (SRC_DATA *data, int converter_type, int channels) ;
/*
** This library contains a number of different sample rate converters,
** numbered 0 through N.
**
** Return a string giving either a name or a more full description of each
** sample rate converter or NULL if no sample rate converter exists for
** the given value. The converters are sequentially numbered from 0 to N.
*/
const char *src_get_name (int converter_type) ;
const char *src_get_description (int converter_type) ;
const char *src_get_version (void) ;
/*
** Set a new SRC ratio. This allows step responses
** in the conversion ratio.
** Returns non zero on error.
*/
int src_set_ratio (SRC_STATE *state, double new_ratio) ;
/*
** Reset the internal SRC state.
** Does not modify the quality settings.
** Does not free any memory allocations.
** Returns non zero on error.
*/
int src_reset (SRC_STATE *state) ;
/*
** Return TRUE if ratio is a valid conversion ratio, FALSE
** otherwise.
*/
int src_is_valid_ratio (double ratio) ;
/*
** Return an error number.
*/
int src_error (SRC_STATE *state) ;
/*
** Convert the error number into a string.
*/
const char* src_strerror (int error) ;
/*
** The following enums can be used to set the interpolator type
** using the function src_set_converter().
*/
enum
{
SRC_SINC_BEST_QUALITY = 0,
SRC_SINC_MEDIUM_QUALITY = 1,
SRC_SINC_FASTEST = 2,
SRC_ZERO_ORDER_HOLD = 3,
SRC_LINEAR = 4
} ;
/*
** Extra helper functions for converting from short to float and
** back again.
*/
void src_short_to_float_array (const short *in, float *out, int len) ;
void src_float_to_short_array (const float *in, short *out, int len) ;
#ifdef __cplusplus
} /* extern "C" */
#endif /* __cplusplus */
#endif /* SAMPLERATE_H */
/*
** Do not edit or modify anything in this comment block.
** The arch-tag line is a file identity tag for the GNU Arch
** revision control system.
**
** arch-tag: 5421ef3e-c898-4ec3-8671-ea03d943ee00
*/

62
set.f
View File

@ -1,31 +1,31 @@
subroutine set(a,y,n)
real y(n)
do i=1,n
y(i)=a
enddo
return
end
subroutine move(x,y,n)
real x(n),y(n)
do i=1,n
y(i)=x(i)
enddo
return
end
subroutine zero(x,n)
real x(n)
do i=1,n
x(i)=0.0
enddo
return
end
subroutine add(a,b,c,n)
real a(n),b(n),c(n)
do i=1,n
c(i)=a(i)+b(i)
enddo
return
end
subroutine set(a,y,n)
real y(n)
do i=1,n
y(i)=a
enddo
return
end
subroutine move(x,y,n)
real x(n),y(n)
do i=1,n
y(i)=x(i)
enddo
return
end
subroutine zero(x,n)
real x(n)
do i=1,n
x(i)=0.0
enddo
return
end
subroutine add(a,b,c,n)
real a(n),b(n),c(n)
do i=1,n
c(i)=a(i)+b(i)
enddo
return
end

212
setup65.f
View File

@ -1,106 +1,106 @@
subroutine setup65
C Defines arrays related to the pseudo-random synchronizing pattern.
C Executed at program start.
integer npra(135),nprc(126)
include 'prcom.h'
C JT44
data npra/
+ 1,1,1,0,1,0,0,0,0,1,1,1,0,0,1,1,0,0,0,0,
+ 1,0,0,1,0,0,0,1,0,1,0,1,1,1,0,1,0,1,1,1,
+ 1,0,0,1,0,0,1,0,1,1,1,0,0,1,1,1,0,0,0,0,
+ 0,0,1,1,1,0,1,1,1,0,1,0,0,1,1,1,1,0,1,0,
+ 1,0,0,1,0,1,0,0,0,0,0,0,1,0,1,0,1,0,1,0,
+ 1,1,1,1,1,0,1,0,1,1,0,1,0,0,0,0,0,1,1,0,
+ 1,1,1,0,1,1,0,1,1,0,1,0,1,1,0/
C JT65
data nprc/
+ 1,0,0,1,1,0,0,0,1,1,1,1,1,1,0,1,0,1,0,0,
+ 0,1,0,1,1,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1,
+ 0,1,1,0,1,1,1,1,0,0,0,1,1,0,1,0,1,0,1,1,
+ 0,0,1,1,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,1,
+ 1,0,0,0,0,0,0,0,1,1,0,1,0,0,1,0,1,1,0,1,
+ 0,1,0,1,0,0,1,1,0,0,1,0,0,1,0,0,0,0,1,1,
+ 1,1,1,1,1,1/
data mr2/0/ !Silence g77 warning
C Put the appropriate pseudo-random sequence into pr
nsym=126
do i=1,nsym
pr(i)=2*nprc(i)-1
enddo
C Determine locations of data and reference symbols
k=0
mr1=0
do i=1,nsym
if(pr(i).lt.0.0) then
k=k+1
mdat(k)=i
else
mr2=i
if(mr1.eq.0) mr1=i
endif
enddo
nsig=k
C Determine the reference symbols for each data symbol.
do k=1,nsig
m=mdat(k)
mref(k,1)=mr1
do n=1,10 !Get ref symbol before data
if((m-n).gt.0) then
if (pr(m-n).gt.0.0) go to 10
endif
enddo
go to 12
10 mref(k,1)=m-n
12 mref(k,2)=mr2
do n=1,10 !Get ref symbol after data
if((m+n).le.nsym) then
if (pr(m+n).gt.0.0) go to 20
endif
enddo
go to 22
20 mref(k,2)=m+n
22 enddo
C Now do it all again, using opposite logic on pr(i)
k=0
mr1=0
do i=1,nsym
if(pr(i).gt.0.0) then
k=k+1
mdat2(k)=i
else
mr2=i
if(mr1.eq.0) mr1=i
endif
enddo
nsig=k
do k=1,nsig
m=mdat2(k)
mref2(k,1)=mr1
do n=1,10
if((m-n).gt.0) then
if (pr(m-n).lt.0.0) go to 110
endif
enddo
go to 112
110 mref2(k,1)=m-n
112 mref2(k,2)=mr2
do n=1,10
if((m+n).le.nsym) then
if (pr(m+n).lt.0.0) go to 120
endif
enddo
go to 122
120 mref2(k,2)=m+n
122 enddo
return
end
subroutine setup65
C Defines arrays related to the pseudo-random synchronizing pattern.
C Executed at program start.
integer npra(135),nprc(126)
include 'prcom.h'
C JT44
data npra/
+ 1,1,1,0,1,0,0,0,0,1,1,1,0,0,1,1,0,0,0,0,
+ 1,0,0,1,0,0,0,1,0,1,0,1,1,1,0,1,0,1,1,1,
+ 1,0,0,1,0,0,1,0,1,1,1,0,0,1,1,1,0,0,0,0,
+ 0,0,1,1,1,0,1,1,1,0,1,0,0,1,1,1,1,0,1,0,
+ 1,0,0,1,0,1,0,0,0,0,0,0,1,0,1,0,1,0,1,0,
+ 1,1,1,1,1,0,1,0,1,1,0,1,0,0,0,0,0,1,1,0,
+ 1,1,1,0,1,1,0,1,1,0,1,0,1,1,0/
C JT65
data nprc/
+ 1,0,0,1,1,0,0,0,1,1,1,1,1,1,0,1,0,1,0,0,
+ 0,1,0,1,1,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1,
+ 0,1,1,0,1,1,1,1,0,0,0,1,1,0,1,0,1,0,1,1,
+ 0,0,1,1,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,1,
+ 1,0,0,0,0,0,0,0,1,1,0,1,0,0,1,0,1,1,0,1,
+ 0,1,0,1,0,0,1,1,0,0,1,0,0,1,0,0,0,0,1,1,
+ 1,1,1,1,1,1/
data mr2/0/ !Silence g77 warning
C Put the appropriate pseudo-random sequence into pr
nsym=126
do i=1,nsym
pr(i)=2*nprc(i)-1
enddo
C Determine locations of data and reference symbols
k=0
mr1=0
do i=1,nsym
if(pr(i).lt.0.0) then
k=k+1
mdat(k)=i
else
mr2=i
if(mr1.eq.0) mr1=i
endif
enddo
nsig=k
C Determine the reference symbols for each data symbol.
do k=1,nsig
m=mdat(k)
mref(k,1)=mr1
do n=1,10 !Get ref symbol before data
if((m-n).gt.0) then
if (pr(m-n).gt.0.0) go to 10
endif
enddo
go to 12
10 mref(k,1)=m-n
12 mref(k,2)=mr2
do n=1,10 !Get ref symbol after data
if((m+n).le.nsym) then
if (pr(m+n).gt.0.0) go to 20
endif
enddo
go to 22
20 mref(k,2)=m+n
22 enddo
C Now do it all again, using opposite logic on pr(i)
k=0
mr1=0
do i=1,nsym
if(pr(i).gt.0.0) then
k=k+1
mdat2(k)=i
else
mr2=i
if(mr1.eq.0) mr1=i
endif
enddo
nsig=k
do k=1,nsig
m=mdat2(k)
mref2(k,1)=mr1
do n=1,10
if((m-n).gt.0) then
if (pr(m-n).lt.0.0) go to 110
endif
enddo
go to 112
110 mref2(k,1)=m-n
112 mref2(k,2)=mr2
do n=1,10
if((m+n).le.nsym) then
if (pr(m+n).lt.0.0) go to 120
endif
enddo
go to 122
120 mref2(k,2)=m+n
122 enddo
return
end

380
short65.f
View File

@ -1,190 +1,190 @@
subroutine short65(data,jz,NFreeze,MouseDF,DFTolerance,
+ mode65,nspecialbest,nstest,dfsh,iderrbest,idriftbest,
+ snrdb,ss1a,ss2a,nwsh,idfsh)
C Checks to see if this might be a shorthand message.
C This is done before zapping, downsampling, or normal decoding.
parameter (NP2=60*11025) !Size of data array
parameter (NFFT=16384) !FFT length
parameter (NH=NFFT/2) !Step size
parameter (MAXSTEPS=60*11025/NH) !Max # of steps
real data(jz)
integer DFTolerance
real s2(NH,MAXSTEPS) !2d spectrum
real ss(NH,4) !Save spectra in four phase bins
real psavg(NH)
real sigmax(4) !Peak of spectrum at each phase
real ss1a(-224:224) !Lower magenta curve
real ss2a(-224:224) !Upper magenta curve
real ss1(-473:1784) !Lower magenta curve (temp)
real ss2(-473:1784) !Upper magenta curve (temp)
real ssavg(-11:11)
integer ipk(4) !Peak bin at each phase
save
nspecialbest=0 !Default return value
nstest=0
df=11025.0/NFFT
C Do 16 k FFTs, stepped by 8k. (*** Maybe should step by 4k? ***)
call zero(psavg,NH)
nsteps=(jz-NH)/(4*NH)
nsteps=4*nsteps !Number of steps
do j=1,nsteps
k=(j-1)*NH + 1
call ps(data(k),NFFT,s2(1,j)) !Get power spectra
if(mode65.eq.4) then
call smooth(s2(1,j),NH)
call smooth(s2(1,j),NH)
endif
call add(psavg,s2(1,j),psavg,NH)
enddo
call flat1(psavg,s2,NH,nsteps,NH,MAXSTEPS)
nfac=40*mode65
dtstep=0.5/df
fac=dtstep/(60.0*df)
C Define range of frequencies to be searched
fa=max(200.0,1270.46+MouseDF-600.0)
fb=min(4800.0,1270.46+MouseDF+600.0)
ia=fa/df
ib=fb/df + 4.1*nfac !Upper tone is above sync tone by 4*nfac*df Hz
if(NFreeze.eq.1) then
fa=max(200.0,1270.46+MouseDF-DFTolerance)
fb=min(4800.0,1270.46+MouseDF+DFTolerance)
endif
ia2=fa/df
ib2=fb/df + 4.1*nfac !Upper tone is above sync tone by 4*nfac*df Hz
if(ib2.gt.NH) ib2=NH
C Find strongest line in each of the 4 phases, repeating for each drift rate.
sbest=0.
snrbest=0.
idz=6.0/df !Is this the right drift range?
do idrift=-idz,idz
drift=idrift*df*60.0/49.04
call zero(ss,4*NH) !Clear the accumulating array
do j=1,nsteps
n=mod(j-1,4)+1
k=nint((j-nsteps/2)*drift*fac) + ia
call add(ss(ia,n),s2(k,j),ss(ia,n),ib-ia+1)
enddo
do n=1,4
sigmax(n)=0.
do i=ia2,ib2
sig=ss(i,n)
if(sig.ge.sigmax(n)) then
ipk(n)=i
sigmax(n)=sig
if(sig.ge.sbest) then
sbest=sig
nbest=n
fdotsh=drift
endif
endif
enddo
enddo
n2best=nbest+2
if(n2best.gt.4) n2best=nbest-2
xdf=min(ipk(nbest),ipk(n2best))*df - 1270.46
if(NFreeze.eq.1 .and. abs(xdf-mousedf).gt.DFTolerance) goto 10
idiff=abs(ipk(nbest)-ipk(n2best))
xk=float(idiff)/nfac
k=nint(xk)
iderr=nint((xk-k)*nfac)
nspecial=0
maxerr=nint(0.008*abs(idiff) + 0.51)
if(abs(iderr).le.maxerr .and. k.ge.2 .and. k.le.4) nspecial=k
if(nspecial.gt.0) then
call getsnr(ss(ia2,nbest),ib2-ia2+1,snr1)
call getsnr(ss(ia2,n2best),ib2-ia2+1,snr2)
snr=0.5*(snr1+snr2)
if(snr.gt.snrbest) then
snrbest=snr
nspecialbest=nspecial
nstest=snr/2.0 - 2.0 !Threshold set here
if(nstest.lt.0) nstest=0
if(nstest.gt.10) nstest=10
dfsh=nint(xdf)
iderrbest=iderr
idriftbest=idrift
snrdb=db(snr) - db(2500.0/df) - db(sqrt(nsteps/4.0))+1.8
n1=nbest
n2=n2best
ipk1=ipk(n1)
ipk2=ipk(n2)
endif
endif
if(nstest.eq.0) nspecial=0
10 enddo
if(nstest.eq.0) nspecialbest=0
df4=4.0*df
if(nstest.gt.0) then
if(ipk1.gt.ipk2) then
ntmp=n1
n1=n2
n2=ntmp
ntmp=ipk1
ipk1=ipk2
ipk2=ntmp
endif
call zero(ss1,2258)
call zero(ss2,2258)
do i=ia2,ib2,4
f=df*i
k=nint((f-1270.46)/df4)
ss1(k)=0.3 * (ss(i-2,n1) + ss(i-1,n1) + ss(i,n1) +
+ ss(i+1,n1) + ss(i+2,n1))
ss2(k)=0.3 * (ss(i-2,n2) + ss(i-1,n2) + ss(i,n2) +
+ ss(i+1,n2) + ss(i+2,n2))
enddo
kpk1=nint(0.25*ipk1-472.0)
kpk2=kpk1 + nspecial*mode65*10
ssmax=0.
do i=-10,10
ssavg(i)=ss1(kpk1+i) + ss2(kpk2+i)
if(ssavg(i).gt.ssmax) then
ssmax=ssavg(i)
itop=i
endif
enddo
base=0.25*(ssavg(-10)+ssavg(-9)+ssavg(9)+ssavg(10))
shalf=0.5*(ssmax+base)
do k=1,8
if(ssavg(itop-k).lt.shalf) go to 110
enddo
k=8
110 x=(ssavg(itop-(k-1))-shalf)/(ssavg(itop-(k-1))-ssavg(itop-k))
do k=1,8
if(ssavg(itop+k).lt.shalf) go to 120
enddo
k=8
120 x=x+(ssavg(itop+(k-1))-shalf)/(ssavg(itop+(k-1))-ssavg(itop+k))
nwsh=nint(x*df4)
endif
C See if orange/magenta curves need to be shifted:
idfsh=0
if(mousedf.lt.-600) idfsh=-670
if(mousedf.gt.600) idfsh=1000
if(mousedf.gt.1600) idfsh=2000
if(mousedf.gt.2600) idfsh=3000
i0=nint(idfsh/df4)
do i=-224,224
ss1a(i)=ss1(i+i0)
ss2a(i)=ss2(i+i0)
enddo
return
end
subroutine short65(data,jz,NFreeze,MouseDF,DFTolerance,
+ mode65,nspecialbest,nstest,dfsh,iderrbest,idriftbest,
+ snrdb,ss1a,ss2a,nwsh,idfsh)
C Checks to see if this might be a shorthand message.
C This is done before zapping, downsampling, or normal decoding.
parameter (NP2=60*11025) !Size of data array
parameter (NFFT=16384) !FFT length
parameter (NH=NFFT/2) !Step size
parameter (MAXSTEPS=60*11025/NH) !Max # of steps
real data(jz)
integer DFTolerance
real s2(NH,MAXSTEPS) !2d spectrum
real ss(NH,4) !Save spectra in four phase bins
real psavg(NH)
real sigmax(4) !Peak of spectrum at each phase
real ss1a(-224:224) !Lower magenta curve
real ss2a(-224:224) !Upper magenta curve
real ss1(-473:1784) !Lower magenta curve (temp)
real ss2(-473:1784) !Upper magenta curve (temp)
real ssavg(-11:11)
integer ipk(4) !Peak bin at each phase
save
nspecialbest=0 !Default return value
nstest=0
df=11025.0/NFFT
C Do 16 k FFTs, stepped by 8k. (*** Maybe should step by 4k? ***)
call zero(psavg,NH)
nsteps=(jz-NH)/(4*NH)
nsteps=4*nsteps !Number of steps
do j=1,nsteps
k=(j-1)*NH + 1
call ps(data(k),NFFT,s2(1,j)) !Get power spectra
if(mode65.eq.4) then
call smooth(s2(1,j),NH)
call smooth(s2(1,j),NH)
endif
call add(psavg,s2(1,j),psavg,NH)
enddo
call flat1(psavg,s2,NH,nsteps,NH,MAXSTEPS)
nfac=40*mode65
dtstep=0.5/df
fac=dtstep/(60.0*df)
C Define range of frequencies to be searched
fa=max(200.0,1270.46+MouseDF-600.0)
fb=min(4800.0,1270.46+MouseDF+600.0)
ia=fa/df
ib=fb/df + 4.1*nfac !Upper tone is above sync tone by 4*nfac*df Hz
if(NFreeze.eq.1) then
fa=max(200.0,1270.46+MouseDF-DFTolerance)
fb=min(4800.0,1270.46+MouseDF+DFTolerance)
endif
ia2=fa/df
ib2=fb/df + 4.1*nfac !Upper tone is above sync tone by 4*nfac*df Hz
if(ib2.gt.NH) ib2=NH
C Find strongest line in each of the 4 phases, repeating for each drift rate.
sbest=0.
snrbest=0.
idz=6.0/df !Is this the right drift range?
do idrift=-idz,idz
drift=idrift*df*60.0/49.04
call zero(ss,4*NH) !Clear the accumulating array
do j=1,nsteps
n=mod(j-1,4)+1
k=nint((j-nsteps/2)*drift*fac) + ia
call add(ss(ia,n),s2(k,j),ss(ia,n),ib-ia+1)
enddo
do n=1,4
sigmax(n)=0.
do i=ia2,ib2
sig=ss(i,n)
if(sig.ge.sigmax(n)) then
ipk(n)=i
sigmax(n)=sig
if(sig.ge.sbest) then
sbest=sig
nbest=n
fdotsh=drift
endif
endif
enddo
enddo
n2best=nbest+2
if(n2best.gt.4) n2best=nbest-2
xdf=min(ipk(nbest),ipk(n2best))*df - 1270.46
if(NFreeze.eq.1 .and. abs(xdf-mousedf).gt.DFTolerance) goto 10
idiff=abs(ipk(nbest)-ipk(n2best))
xk=float(idiff)/nfac
k=nint(xk)
iderr=nint((xk-k)*nfac)
nspecial=0
maxerr=nint(0.008*abs(idiff) + 0.51)
if(abs(iderr).le.maxerr .and. k.ge.2 .and. k.le.4) nspecial=k
if(nspecial.gt.0) then
call getsnr(ss(ia2,nbest),ib2-ia2+1,snr1)
call getsnr(ss(ia2,n2best),ib2-ia2+1,snr2)
snr=0.5*(snr1+snr2)
if(snr.gt.snrbest) then
snrbest=snr
nspecialbest=nspecial
nstest=snr/2.0 - 2.0 !Threshold set here
if(nstest.lt.0) nstest=0
if(nstest.gt.10) nstest=10
dfsh=nint(xdf)
iderrbest=iderr
idriftbest=idrift
snrdb=db(snr) - db(2500.0/df) - db(sqrt(nsteps/4.0))+1.8
n1=nbest
n2=n2best
ipk1=ipk(n1)
ipk2=ipk(n2)
endif
endif
if(nstest.eq.0) nspecial=0
10 enddo
if(nstest.eq.0) nspecialbest=0
df4=4.0*df
if(nstest.gt.0) then
if(ipk1.gt.ipk2) then
ntmp=n1
n1=n2
n2=ntmp
ntmp=ipk1
ipk1=ipk2
ipk2=ntmp
endif
call zero(ss1,2258)
call zero(ss2,2258)
do i=ia2,ib2,4
f=df*i
k=nint((f-1270.46)/df4)
ss1(k)=0.3 * (ss(i-2,n1) + ss(i-1,n1) + ss(i,n1) +
+ ss(i+1,n1) + ss(i+2,n1))
ss2(k)=0.3 * (ss(i-2,n2) + ss(i-1,n2) + ss(i,n2) +
+ ss(i+1,n2) + ss(i+2,n2))
enddo
kpk1=nint(0.25*ipk1-472.0)
kpk2=kpk1 + nspecial*mode65*10
ssmax=0.
do i=-10,10
ssavg(i)=ss1(kpk1+i) + ss2(kpk2+i)
if(ssavg(i).gt.ssmax) then
ssmax=ssavg(i)
itop=i
endif
enddo
base=0.25*(ssavg(-10)+ssavg(-9)+ssavg(9)+ssavg(10))
shalf=0.5*(ssmax+base)
do k=1,8
if(ssavg(itop-k).lt.shalf) go to 110
enddo
k=8
110 x=(ssavg(itop-(k-1))-shalf)/(ssavg(itop-(k-1))-ssavg(itop-k))
do k=1,8
if(ssavg(itop+k).lt.shalf) go to 120
enddo
k=8
120 x=x+(ssavg(itop+(k-1))-shalf)/(ssavg(itop+(k-1))-ssavg(itop+k))
nwsh=nint(x*df4)
endif
C See if orange/magenta curves need to be shifted:
idfsh=0
if(mousedf.lt.-600) idfsh=-670
if(mousedf.gt.600) idfsh=1000
if(mousedf.gt.1600) idfsh=2000
if(mousedf.gt.2600) idfsh=3000
i0=nint(idfsh/df4)
do i=-224,224
ss1a(i)=ss1(i+i0)
ss2a(i)=ss2(i+i0)
enddo
return
end

82
slope.f
View File

@ -1,41 +1,41 @@
subroutine slope(y,npts,xpk)
C Remove best-fit slope from data in y(i). When fitting the straight line,
C ignore the peak around xpk +/- 2.
real y(npts)
real x(100)
do i=1,npts
x(i)=i
enddo
sumw=0.
sumx=0.
sumy=0.
sumx2=0.
sumxy=0.
sumy2=0.
do i=1,npts
if(abs(i-xpk).gt.2.0) then
sumw=sumw + 1.0
sumx=sumx + x(i)
sumy=sumy + y(i)
sumx2=sumx2 + x(i)**2
sumxy=sumxy + x(i)*y(i)
sumy2=sumy2 + y(i)**2
endif
enddo
delta=sumw*sumx2 - sumx**2
a=(sumx2*sumy - sumx*sumxy) / delta
b=(sumw*sumxy - sumx*sumy) / delta
do i=1,npts
y(i)=y(i)-(a + b*x(i))
enddo
return
end
subroutine slope(y,npts,xpk)
C Remove best-fit slope from data in y(i). When fitting the straight line,
C ignore the peak around xpk +/- 2.
real y(npts)
real x(100)
do i=1,npts
x(i)=i
enddo
sumw=0.
sumx=0.
sumy=0.
sumx2=0.
sumxy=0.
sumy2=0.
do i=1,npts
if(abs(i-xpk).gt.2.0) then
sumw=sumw + 1.0
sumx=sumx + x(i)
sumy=sumy + y(i)
sumx2=sumx2 + x(i)**2
sumxy=sumxy + x(i)*y(i)
sumy2=sumy2 + y(i)**2
endif
enddo
delta=sumw*sumx2 - sumx**2
a=(sumx2*sumy - sumx*sumxy) / delta
b=(sumw*sumxy - sumx*sumy) / delta
do i=1,npts
y(i)=y(i)-(a + b*x(i))
enddo
return
end

26
smooth.f
View File

@ -1,13 +1,13 @@
subroutine smooth(x,nz)
real x(nz)
x0=x(1)
do i=2,nz-1
x1=x(i)
x(i)=0.5*x(i) + 0.25*(x0+x(i+1))
x0=x1
enddo
return
end
subroutine smooth(x,nz)
real x(nz)
x0=x(1)
do i=2,nz-1
x1=x(i)
x(i)=0.5*x(i) + 0.25*(x0+x(i+1))
x0=x1
enddo
return
end

8
sort.f
View File

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

180
spec2d65.f
View File

@ -1,90 +1,90 @@
subroutine spec2d65(dat,jz,nsym,flip,istart,f0,
+ ftrack,nafc,mode65,s2)
C Computes the spectrum for each of 126 symbols.
C NB: At this point, istart, f0, and ftrack are supposedly known.
C The JT65 signal has Sync bin + 2 guard bins + 64 data bins = 67 bins.
C We add 5 extra bins at top and bottom for drift, making 77 bins in all.
parameter (NMAX=2048) !Max length of FFTs
real dat(jz) !Raw data
real s2(77,126) !Spectra of all symbols
real s(77)
real ref(77)
real ps(77)
real x(NMAX)
real ftrack(126)
real*8 pha,dpha,twopi
complex cx(NMAX)
c complex work(NMAX)
include 'prcom.h'
equivalence (x,cx)
data twopi/6.28318530718d0/
save
C Peak up in frequency and time, and compute ftrack.
call ftpeak65(dat,jz,istart,f0,flip,pr,nafc,ftrack)
nfft=2048/mode65 !Size of FFTs
dt=2.0/11025.0
df=0.5*11025.0/nfft
call zero(ps,77)
k=istart-nfft
C NB: this could be done starting with array c3, in ftpeak65, instead
C of the dat() array. Would save some time this way ...
do j=1,nsym
call zero(s,77)
do m=1,mode65
k=k+nfft
if(k.ge.1 .and. k.le.(jz-nfft)) then
C Mix sync tone down to f=5*df (==> bin 6 of array cx, after FFT)
dpha=twopi*dt*(f0 + ftrack(j) - 5.0*df)
pha=0.0
do i=1,nfft
pha=pha+dpha
cx(i)=dat(k-1+i)*cmplx(cos(pha),-sin(pha))
enddo
call four2a(cx,nfft,1,-1,1)
do i=1,77
s(i)=s(i) + real(cx(i))**2 + aimag(cx(i))**2
enddo
else
call zero(s,77)
endif
enddo
call move(s,s2(1,j),77)
call add(ps,s,ps,77)
enddo
C Flatten the spectra by dividing through by the average of the
C "sync on" spectra, with the sync tone explicitly deleted.
nref=nsym/2
do i=1,77
C First we sum all the sync-on spectra:
ref(i)=0.
do j=1,nsym
if(flip*pr(j).gt.0.0) ref(i)=ref(i)+s2(i,j)
enddo
ref(i)=ref(i)/nref !Normalize
enddo
C Remove the sync tone itself:
base=0.25*(ref(1)+ref(2)+ref(10)+ref(11))
do i=3,9
ref(i)=base
enddo
C Now flatten the spectra for all the data symbols:
do i=1,77
fac=1.0/ref(i)
do j=1,nsym
s2(i,j)=fac*s2(i,j)
if(s2(i,j).eq.0.0) s2(i,j)=1.0 !### To fix problem in mfskprob
enddo
enddo
return
end
subroutine spec2d65(dat,jz,nsym,flip,istart,f0,
+ ftrack,nafc,mode65,s2)
C Computes the spectrum for each of 126 symbols.
C NB: At this point, istart, f0, and ftrack are supposedly known.
C The JT65 signal has Sync bin + 2 guard bins + 64 data bins = 67 bins.
C We add 5 extra bins at top and bottom for drift, making 77 bins in all.
parameter (NMAX=2048) !Max length of FFTs
real dat(jz) !Raw data
real s2(77,126) !Spectra of all symbols
real s(77)
real ref(77)
real ps(77)
real x(NMAX)
real ftrack(126)
real*8 pha,dpha,twopi
complex cx(NMAX)
c complex work(NMAX)
include 'prcom.h'
equivalence (x,cx)
data twopi/6.28318530718d0/
save
C Peak up in frequency and time, and compute ftrack.
call ftpeak65(dat,jz,istart,f0,flip,pr,nafc,ftrack)
nfft=2048/mode65 !Size of FFTs
dt=2.0/11025.0
df=0.5*11025.0/nfft
call zero(ps,77)
k=istart-nfft
C NB: this could be done starting with array c3, in ftpeak65, instead
C of the dat() array. Would save some time this way ...
do j=1,nsym
call zero(s,77)
do m=1,mode65
k=k+nfft
if(k.ge.1 .and. k.le.(jz-nfft)) then
C Mix sync tone down to f=5*df (==> bin 6 of array cx, after FFT)
dpha=twopi*dt*(f0 + ftrack(j) - 5.0*df)
pha=0.0
do i=1,nfft
pha=pha+dpha
cx(i)=dat(k-1+i)*cmplx(cos(pha),-sin(pha))
enddo
call four2a(cx,nfft,1,-1,1)
do i=1,77
s(i)=s(i) + real(cx(i))**2 + aimag(cx(i))**2
enddo
else
call zero(s,77)
endif
enddo
call move(s,s2(1,j),77)
call add(ps,s,ps,77)
enddo
C Flatten the spectra by dividing through by the average of the
C "sync on" spectra, with the sync tone explicitly deleted.
nref=nsym/2
do i=1,77
C First we sum all the sync-on spectra:
ref(i)=0.
do j=1,nsym
if(flip*pr(j).gt.0.0) ref(i)=ref(i)+s2(i,j)
enddo
ref(i)=ref(i)/nref !Normalize
enddo
C Remove the sync tone itself:
base=0.25*(ref(1)+ref(2)+ref(10)+ref(11))
do i=3,9
ref(i)=base
enddo
C Now flatten the spectra for all the data symbols:
do i=1,77
fac=1.0/ref(i)
do j=1,nsym
s2(i,j)=fac*s2(i,j)
if(s2(i,j).eq.0.0) s2(i,j)=1.0 !### To fix problem in mfskprob
enddo
enddo
return
end

570
ssort.f
View File

@ -1,285 +1,285 @@
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 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
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 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

168
sun.f
View File

@ -1,84 +1,84 @@
subroutine sun(y,m,DD,UT,lon,lat,RA,Dec,LST,Az,El,mjd)
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
real xs,ys !Ecliptic coords of sun (geocentric)
real xe,ye,ze !Equatorial coords of sun (geocentric)
real lon,lat
real GMST0,LST,HA
real xx,yy,zz
real xhor,yhor,zhor
real Az,El
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)
return
end
subroutine sun(y,m,DD,UT,lon,lat,RA,Dec,LST,Az,El,mjd)
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
real xs,ys !Ecliptic coords of sun (geocentric)
real xe,ye,ze !Equatorial coords of sun (geocentric)
real lon,lat
real GMST0,LST,HA
real xx,yy,zz
real xhor,yhor,zhor
real Az,El
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)
return
end

67
symspec.f Normal file
View File

@ -0,0 +1,67 @@
subroutine symspec(id,nz,ss,savg)
C Compute spectra at four polarizations, using half-symbol steps.
parameter (NFFT=32768)
integer*2 id(4,nz)
real ss(4,322,NFFT)
real savg(4,NFFT)
complex cx(NFFT),cy(NFFT) ! pad to 32k with zeros
complex z
real*8 ts,hsym
fac=1.e-4
hsym=2048.d0*96000.d0/11025.d0 !Samples per half symbol
npts=hsym !Integral samples per half symbol
nsteps=322 !Half symbols per transmission
do ip=1,4
do i=1,NFFT
savg(ip,i)=0.
enddo
enddo
ts=1.d0 - hsym
do n=1,nsteps
ts=ts+hsym !Update exact sample pointer
i0=ts !Starting sample pointer
do i=1,npts !Copy data to FFT arrays
xr=fac*id(1,i0+i)
xi=fac*id(2,i0+i)
cx(i)=cmplx(xr,xi)
yr=fac*id(3,i0+i)
yi=fac*id(4,i0+i)
cy(i)=cmplx(yr,yi)
enddo
do i=npts+1,NFFT !Pad to 32k with zeros
cx(i)=0.
cy(i)=0.
enddo
call four2a(cx,NFFT,1,1,1) !Do the FFTs
call four2a(cy,NFFT,1,1,1)
do i=1,NFFT !Save and accumulate power spectra
s=real(cx(i))**2 + aimag(cx(i))**2
ss(1,n,i)=s ! Pol = 0
savg(1,i)=savg(1,i) + s
z=cx(i) + cy(i)
s=0.5*(real(z)**2 + aimag(z)**2)
ss(2,n,i)=s ! Pol = 45
savg(2,i)=savg(2,i) + s
s=real(cy(i))**2 + aimag(cy(i))**2
ss(3,n,i)=s ! Pol = 90
savg(3,i)=savg(3,i) + s
z=cx(i) - cy(i)
s=0.5*(real(z)**2 + aimag(z)**2)
ss(4,n,i)=s ! Pol = 135
savg(4,i)=savg(4,i) + s
enddo
enddo
return
end

50
toxyz.f
View File

@ -1,25 +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 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 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

70
unpackcall.f
View File

@ -1,35 +1,35 @@
subroutine unpackcall(ncall,word)
character word*12,c*37
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/
n=ncall
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:)
999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:)
return
end
subroutine unpackcall(ncall,word)
character word*12,c*37
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/
n=ncall
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:)
999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:)
return
end

64
unpackgrid.f
View File

@ -1,32 +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
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(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
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

178
unpackmsg.f
View File

@ -1,89 +1,89 @@
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
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.gt.32768) then
call unpacktext(nc1,nc2,ng,msg)
go to 100
endif
if(nc1.lt.NBASE) then
call unpackcall(nc1,c1)
else
c1='......'
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
if(nc2.lt.NBASE) then
call unpackcall(nc2,c2)
else
c2='......'
endif
call unpackgrid(ng,grid)
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
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
j=j+1
msg(j:j)=' '
endif
100 return
end
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
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.gt.32768) then
call unpacktext(nc1,nc2,ng,msg)
go to 100
endif
if(nc1.lt.NBASE) then
call unpackcall(nc1,c1)
else
c1='......'
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
if(nc2.lt.NBASE) then
call unpackcall(nc2,c2)
else
c2='......'
endif
call unpackgrid(ng,grid)
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
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
j=j+1
msg(j:j)=' '
endif
100 return
end

70
unpacktext.f
View File

@ -1,35 +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(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

300
wsjtgen.F90
View File

@ -1,150 +1,150 @@
subroutine wsjtgen
! Compute the waveform to be transmitted.
! Input: txmsg message to be transmitted, up to 28 characters
! samfacout fsample_out/11025.d0
! Output: iwave waveform data, i*2 format
! nwave number of samples
! sendingsh 0=normal; 1=shorthand (FSK441) or plain text (JT65)
parameter (NMSGMAX=28) !Max characters per message
parameter (NSPD=25) !Samples per dit
parameter (NDPC=3) !Dits per character
parameter (NWMAX=661500) !Max length of waveform = 60*11025
parameter (NTONES=4) !Number of FSK tones
integer itone(84)
character msg*28,msgsent*22,idmsg*22
real*8 freq,pha,dpha,twopi,dt
character testfile*27,tfile2*80
logical lcwid
integer*2 icwid(110250),jwave(NWMAX)
integer*1 hdr(44)
integer*2 nfmt2,nchan2,nbitsam2,nbytesam2
character*4 ariff,awave,afmt,adata
common/hdr/ariff,lenfile,awave,afmt,lenfmt,nfmt2,nchan2, &
nsamrate,nbytesec,nbytesam2,nbitsam2,adata,ndata,jwave
equivalence (ariff,hdr)
data twopi/6.28318530718d0/
include 'gcom1.f90'
include 'gcom2.f90'
fsample_out=11025.d0*samfacout
lcwid=.false.
if(idinterval.gt.0) then
n=(mod(int(tsec/60.d0),idinterval))
if(n.eq.(1-txfirst)) lcwid=.true.
if(idinterval.eq.1) lcwid=.true.
endif
msg=txmsg
ntxnow=ntxreq
! Convert all letters to upper case
do i=1,28
if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') &
msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a'))
enddo
txmsg=msg
! Find message length
do i=NMSGMAX,1,-1
if(msg(i:i).ne.' ') go to 10
enddo
i=1
10 nmsg=i
nmsg0=nmsg
if(msg(1:1).eq.'@') then
if(msg(2:2).eq.'/' .or. ichar(msg(2:2)).eq.92) then
txmsg=msg
testfile=msg(2:)
#ifdef Win32
open(18,file=testfile,form='binary',status='old',err=12)
go to 14
12 print*,'Cannot open test file ',msg(2:)
go to 999
14 read(18) hdr
if(ndata.gt.NTxMax) ndata=NTxMax
call rfile(18,iwave,ndata,ierr)
close(18)
if(ierr.ne.0) print*,'Error reading test file ',msg(2:)
#else
tfile2=testfile
call rfile2(tfile2,hdr,44+2*661500,nr)
if(nr.le.0) then
print*,'Error reading ',testfile
stop
endif
do i=1,ndata/2
iwave(i)=jwave(i)
enddo
#endif
nwave=ndata/2
do i=nwave,NTXMAX
iwave(i)=0
enddo
sending=txmsg
sendingsh=2
go to 999
endif
! Transmit a fixed tone at specified frequency
freq=1000.0
if(msg(2:2).eq.'A' .or. msg(2:2).eq.'a') freq=882
if(msg(2:2).eq.'B' .or. msg(2:2).eq.'b') freq=1323
if(msg(2:2).eq.'C' .or. msg(2:2).eq.'c') freq=1764
if(msg(2:2).eq.'D' .or. msg(2:2).eq.'d') freq=2205
if(freq.eq.1000.0) then
read(msg(2:),*,err=1) freq
goto 2
1 txmsg='@1000'
nmsg=5
nmsg0=5
endif
2 nwave=60*fsample_out
dpha=twopi*freq/fsample_out
do i=1,nwave
iwave(i)=32767.0*sin(i*dpha)
enddo
goto 900
endif
dt=1.d0/fsample_out
LTone=2
! We're in JT65 mode.
if(mode(5:5).eq.'A') mode65=1
if(mode(5:5).eq.'B') mode65=2
if(mode(5:5).eq.'C') mode65=4
call gen65(msg,mode65,samfacout,iwave,nwave,sendingsh,msgsent)
if(lcwid) then
! Generate and insert the CW ID.
wpm=25.
freqcw=800.
idmsg=MyCall//' '
call gencwid(idmsg,wpm,freqcw,samfacout,icwid,ncwid)
k=nwave
do i=1,ncwid
k=k+1
iwave(k)=icwid(i)
enddo
do i=1,2205 !Add 0.2 s of silence
k=k+1
iwave(k)=0
enddo
nwave=k
endif
900 sending=txmsg
if(sendingsh.ne.1) sending=msgsent
nmsg=nmsg0
999 return
end subroutine wsjtgen
subroutine wsjtgen
! Compute the waveform to be transmitted.
! Input: txmsg message to be transmitted, up to 28 characters
! samfacout fsample_out/11025.d0
! Output: iwave waveform data, i*2 format
! nwave number of samples
! sendingsh 0=normal; 1=shorthand (FSK441) or plain text (JT65)
parameter (NMSGMAX=28) !Max characters per message
parameter (NSPD=25) !Samples per dit
parameter (NDPC=3) !Dits per character
parameter (NWMAX=661500) !Max length of waveform = 60*11025
parameter (NTONES=4) !Number of FSK tones
integer itone(84)
character msg*28,msgsent*22,idmsg*22
real*8 freq,pha,dpha,twopi,dt
character testfile*27,tfile2*80
logical lcwid
integer*2 icwid(110250),jwave(NWMAX)
integer*1 hdr(44)
integer*2 nfmt2,nchan2,nbitsam2,nbytesam2
character*4 ariff,awave,afmt,adata
common/hdr/ariff,lenfile,awave,afmt,lenfmt,nfmt2,nchan2, &
nsamrate,nbytesec,nbytesam2,nbitsam2,adata,ndata,jwave
equivalence (ariff,hdr)
data twopi/6.28318530718d0/
include 'gcom1.f90'
include 'gcom2.f90'
fsample_out=11025.d0*samfacout
lcwid=.false.
if(idinterval.gt.0) then
n=(mod(int(tsec/60.d0),idinterval))
if(n.eq.(1-txfirst)) lcwid=.true.
if(idinterval.eq.1) lcwid=.true.
endif
msg=txmsg
ntxnow=ntxreq
! Convert all letters to upper case
do i=1,28
if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') &
msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a'))
enddo
txmsg=msg
! Find message length
do i=NMSGMAX,1,-1
if(msg(i:i).ne.' ') go to 10
enddo
i=1
10 nmsg=i
nmsg0=nmsg
if(msg(1:1).eq.'@') then
if(msg(2:2).eq.'/' .or. ichar(msg(2:2)).eq.92) then
txmsg=msg
testfile=msg(2:)
#ifdef Win32
open(18,file=testfile,form='binary',status='old',err=12)
go to 14
12 print*,'Cannot open test file ',msg(2:)
go to 999
14 read(18) hdr
if(ndata.gt.NTxMax) ndata=NTxMax
call rfile(18,iwave,ndata,ierr)
close(18)
if(ierr.ne.0) print*,'Error reading test file ',msg(2:)
#else
tfile2=testfile
call rfile2(tfile2,hdr,44+2*661500,nr)
if(nr.le.0) then
print*,'Error reading ',testfile
stop
endif
do i=1,ndata/2
iwave(i)=jwave(i)
enddo
#endif
nwave=ndata/2
do i=nwave,NTXMAX
iwave(i)=0
enddo
sending=txmsg
sendingsh=2
go to 999
endif
! Transmit a fixed tone at specified frequency
freq=1000.0
if(msg(2:2).eq.'A' .or. msg(2:2).eq.'a') freq=882
if(msg(2:2).eq.'B' .or. msg(2:2).eq.'b') freq=1323
if(msg(2:2).eq.'C' .or. msg(2:2).eq.'c') freq=1764
if(msg(2:2).eq.'D' .or. msg(2:2).eq.'d') freq=2205
if(freq.eq.1000.0) then
read(msg(2:),*,err=1) freq
goto 2
1 txmsg='@1000'
nmsg=5
nmsg0=5
endif
2 nwave=60*fsample_out
dpha=twopi*freq/fsample_out
do i=1,nwave
iwave(i)=32767.0*sin(i*dpha)
enddo
goto 900
endif
dt=1.d0/fsample_out
LTone=2
! We're in JT65 mode.
if(mode(5:5).eq.'A') mode65=1
if(mode(5:5).eq.'B') mode65=2
if(mode(5:5).eq.'C') mode65=4
call gen65(msg,mode65,samfacout,iwave,nwave,sendingsh,msgsent)
if(lcwid) then
! Generate and insert the CW ID.
wpm=25.
freqcw=800.
idmsg=MyCall//' '
call gencwid(idmsg,wpm,freqcw,samfacout,icwid,ncwid)
k=nwave
do i=1,ncwid
k=k+1
iwave(k)=icwid(i)
enddo
do i=1,2205 !Add 0.2 s of silence
k=k+1
iwave(k)=0
enddo
nwave=k
endif
900 sending=txmsg
if(sendingsh.ne.1) sending=msgsent
nmsg=nmsg0
999 return
end subroutine wsjtgen

168
xcor.f
View File

@ -1,84 +1,84 @@
subroutine xcor(s2,ipk,nsteps,nsym,lag1,lag2,
+ ccf,ccf0,lagpk,flip,fdot)
C Computes ccf of a row of s2 and the pseudo-random array pr. Returns
C peak of the CCF and the lag at which peak occurs. For JT65, the
C CCF peak may be either positive or negative, with negative implying
C the "OOO" message.
parameter (NHMAX=1024) !Max length of power spectra
parameter (NSMAX=320) !Max number of half-symbol steps
real s2(NHMAX,NSMAX) !2d spectrum, stepped by half-symbols
real a(NSMAX),a2(NSMAX)
real ccf(-5:540)
include 'prcom.h'
common/clipcom/ nclip
data lagmin/0/ !Silence g77 warning
save
df=11025.0/4096.
dtstep=0.5/df
fac=dtstep/(60.0*df)
do j=1,nsteps
ii=nint((j-nsteps/2)*fdot*fac)+ipk
a(j)=s2(ii,j)
enddo
C If requested, clip the spectrum that will be cross correlated.
nclip=0 !Turn it off
if(nclip.gt.0) then
call pctile(a,a2,nsteps,50,base)
alow=a2(nint(nsteps*0.16))
ahigh=a2(nint(nsteps*0.84))
rms=min(base-alow,ahigh-base)
clip=4.0-nclip
atop=base+clip*rms
abot=base-clip*rms
do i=1,nsteps
if(nclip.lt.4) then
a(i)=min(a(i),atop)
a(i)=max(a(i),abot)
else
if(a(i).ge.base) then
a(i)=1.0
else
a(i)=-1.0
endif
endif
enddo
endif
ccfmax=0.
ccfmin=0.
do lag=lag1,lag2
x=0.
do i=1,nsym
j=2*i-1+lag
if(j.ge.1 .and. j.le.nsteps) x=x+a(j)*pr(i)
enddo
ccf(lag)=2*x !The 2 is for plotting scale
if(ccf(lag).gt.ccfmax) then
ccfmax=ccf(lag)
lagpk=lag
endif
if(ccf(lag).lt.ccfmin) then
ccfmin=ccf(lag)
lagmin=lag
endif
enddo
ccf0=ccfmax
flip=1.0
if(-ccfmin.gt.ccfmax) then
do lag=lag1,lag2
ccf(lag)=-ccf(lag)
enddo
lagpk=lagmin
ccf0=-ccfmin
flip=-1.0
endif
return
end
subroutine xcor(s2,ipk,nsteps,nsym,lag1,lag2,
+ ccf,ccf0,lagpk,flip,fdot)
C Computes ccf of a row of s2 and the pseudo-random array pr. Returns
C peak of the CCF and the lag at which peak occurs. For JT65, the
C CCF peak may be either positive or negative, with negative implying
C the "OOO" message.
parameter (NHMAX=1024) !Max length of power spectra
parameter (NSMAX=320) !Max number of half-symbol steps
real s2(NHMAX,NSMAX) !2d spectrum, stepped by half-symbols
real a(NSMAX),a2(NSMAX)
real ccf(-5:540)
include 'prcom.h'
common/clipcom/ nclip
data lagmin/0/ !Silence g77 warning
save
df=11025.0/4096.
dtstep=0.5/df
fac=dtstep/(60.0*df)
do j=1,nsteps
ii=nint((j-nsteps/2)*fdot*fac)+ipk
a(j)=s2(ii,j)
enddo
C If requested, clip the spectrum that will be cross correlated.
nclip=0 !Turn it off
if(nclip.gt.0) then
call pctile(a,a2,nsteps,50,base)
alow=a2(nint(nsteps*0.16))
ahigh=a2(nint(nsteps*0.84))
rms=min(base-alow,ahigh-base)
clip=4.0-nclip
atop=base+clip*rms
abot=base-clip*rms
do i=1,nsteps
if(nclip.lt.4) then
a(i)=min(a(i),atop)
a(i)=max(a(i),abot)
else
if(a(i).ge.base) then
a(i)=1.0
else
a(i)=-1.0
endif
endif
enddo
endif
ccfmax=0.
ccfmin=0.
do lag=lag1,lag2
x=0.
do i=1,nsym
j=2*i-1+lag
if(j.ge.1 .and. j.le.nsteps) x=x+a(j)*pr(i)
enddo
ccf(lag)=2*x !The 2 is for plotting scale
if(ccf(lag).gt.ccfmax) then
ccfmax=ccf(lag)
lagpk=lag
endif
if(ccf(lag).lt.ccfmin) then
ccfmin=ccf(lag)
lagmin=lag
endif
enddo
ccf0=ccfmax
flip=1.0
if(-ccfmin.gt.ccfmax) then
do lag=lag1,lag2
ccf(lag)=-ccf(lag)
enddo
lagpk=lagmin
ccf0=-ccfmin
flip=-1.0
endif
return
end

24
xfft.f
View File

@ -1,12 +1,12 @@
subroutine xfft(x,nfft)
C Real-to-complex FFT.
real x(nfft)
! call four2(x,nfft,1,-1,0)
call four2a(x,nfft,1,-1,0)
return
end
subroutine xfft(x,nfft)
C Real-to-complex FFT.
real x(nfft)
! call four2(x,nfft,1,-1,0)
call four2a(x,nfft,1,-1,0)
return
end

368
xfft2.f
View File

@ -1,184 +1,184 @@
SUBROUTINE xfft2(DATA,NB)
c
c the cooley-tukey fast fourier transform in usasi basic fortran
c
C .. Scalar Arguments ..
INTEGER NB
C ..
C .. Array Arguments ..
REAL DATA(NB+2)
C ..
C .. Local Scalars ..
REAL DIFI,DIFR,RTHLF,SUMI,SUMR,T2I,T2R,T3I,T3R,T4I,
+ T4R,TEMPI,TEMPR,THETA,TWOPI,U1I,U1R,U2I,U2R,U3I,U3R,
+ U4I,U4R,W2I,W2R,W3I,W3R,WI,WR,WSTPI,WSTPR
INTEGER I,I2,IPAR,J,K1,K2,K3,K4,KDIF,KMIN,
+ KSTEP,L,LMAX,M,MMAX,NH
C ..
C .. Intrinsic Functions ..
INTRINSIC COS,MAX0,REAL,SIN
C ..
C .. Data statements ..
DATA TWOPI/6.2831853071796/,RTHLF/0.70710678118655/
c
c 1. real transform for the 1st dimension, n even. method--
c transform a complex array of length n/2 whose real parts
c are the even numbered real values and whose imaginary parts
c are the odd numbered real values. separate and supply
c the second half by conjugate symmetry.
c
NH = NB/2
c
c shuffle data by bit reversal, since n=2**k.
c
J = 1
DO 131 I2 = 1,NB,2
IF (J-I2) 124,127,127
124 TEMPR = DATA(I2)
TEMPI = DATA(I2+1)
DATA(I2) = DATA(J)
DATA(I2+1) = DATA(J+1)
DATA(J) = TEMPR
DATA(J+1) = TEMPI
127 M = NH
128 IF (J-M) 130,130,129
129 J = J - M
M = M/2
IF (M-2) 130,128,128
130 J = J + M
131 CONTINUE
c
c main loop for factors of two. perform fourier transforms of
c length four, with one of length two if needed. the twiddle factor
c w=exp(-2*pi*sqrt(-1)*m/(4*mmax)). check for w=-sqrt(-1)
c and repeat for w=w*(1-sqrt(-1))/sqrt(2).
c
IF (NB-2) 174,174,143
143 IPAR = NH
144 IF (IPAR-2) 149,146,145
145 IPAR = IPAR/4
GO TO 144
146 DO 147 K1 = 1,NB,4
K2 = K1 + 2
TEMPR = DATA(K2)
TEMPI = DATA(K2+1)
DATA(K2) = DATA(K1) - TEMPR
DATA(K2+1) = DATA(K1+1) - TEMPI
DATA(K1) = DATA(K1) + TEMPR
DATA(K1+1) = DATA(K1+1) + TEMPI
147 CONTINUE
149 MMAX = 2
150 IF (MMAX-NH) 151,174,174
151 LMAX = MAX0(4,MMAX/2)
DO 173 L = 2,LMAX,4
M = L
IF (MMAX-2) 156,156,152
152 THETA = -TWOPI*REAL(L)/REAL(4*MMAX)
WR = COS(THETA)
WI = SIN(THETA)
155 W2R = WR*WR - WI*WI
W2I = 2.*WR*WI
W3R = W2R*WR - W2I*WI
W3I = W2R*WI + W2I*WR
156 KMIN = 1 + IPAR*M
IF (MMAX-2) 157,157,158
157 KMIN = 1
158 KDIF = IPAR*MMAX
159 KSTEP = 4*KDIF
IF (KSTEP-NB) 160,160,169
160 DO 168 K1 = KMIN,NB,KSTEP
K2 = K1 + KDIF
K3 = K2 + KDIF
K4 = K3 + KDIF
IF (MMAX-2) 161,161,164
161 U1R = DATA(K1) + DATA(K2)
U1I = DATA(K1+1) + DATA(K2+1)
U2R = DATA(K3) + DATA(K4)
U2I = DATA(K3+1) + DATA(K4+1)
U3R = DATA(K1) - DATA(K2)
U3I = DATA(K1+1) - DATA(K2+1)
U4R = DATA(K3+1) - DATA(K4+1)
U4I = DATA(K4) - DATA(K3)
GO TO 167
164 T2R = W2R*DATA(K2) - W2I*DATA(K2+1)
T2I = W2R*DATA(K2+1) + W2I*DATA(K2)
T3R = WR*DATA(K3) - WI*DATA(K3+1)
T3I = WR*DATA(K3+1) + WI*DATA(K3)
T4R = W3R*DATA(K4) - W3I*DATA(K4+1)
T4I = W3R*DATA(K4+1) + W3I*DATA(K4)
U1R = DATA(K1) + T2R
U1I = DATA(K1+1) + T2I
U2R = T3R + T4R
U2I = T3I + T4I
U3R = DATA(K1) - T2R
U3I = DATA(K1+1) - T2I
U4R = T3I - T4I
U4I = T4R - T3R
167 DATA(K1) = U1R + U2R
DATA(K1+1) = U1I + U2I
DATA(K2) = U3R + U4R
DATA(K2+1) = U3I + U4I
DATA(K3) = U1R - U2R
DATA(K3+1) = U1I - U2I
DATA(K4) = U3R - U4R
DATA(K4+1) = U3I - U4I
168 CONTINUE
KDIF = KSTEP
KMIN = 4*KMIN - 3
GO TO 159
169 M = M + LMAX
IF (M-MMAX) 170,170,173
170 TEMPR = WR
WR = (WR+WI)*RTHLF
WI = (WI-TEMPR)*RTHLF
GO TO 155
173 CONTINUE
IPAR = 3 - IPAR
MMAX = MMAX + MMAX
GO TO 150
c
c complete a real transform in the 1st dimension, n even, by con-
c jugate symmetries.
c
174 THETA = -TWOPI/REAL(NB)
WSTPR = COS(THETA)
WSTPI = SIN(THETA)
WR = WSTPR
WI = WSTPI
I = 3
J = NB - 1
GO TO 207
205 SUMR = (DATA(I)+DATA(J))/2.
SUMI = (DATA(I+1)+DATA(J+1))/2.
DIFR = (DATA(I)-DATA(J))/2.
DIFI = (DATA(I+1)-DATA(J+1))/2.
TEMPR = WR*SUMI + WI*DIFR
TEMPI = WI*SUMI - WR*DIFR
DATA(I) = SUMR + TEMPR
DATA(I+1) = DIFI + TEMPI
DATA(J) = SUMR - TEMPR
DATA(J+1) = -DIFI + TEMPI
I = I + 2
J = J - 2
TEMPR = WR
WR = WR*WSTPR - WI*WSTPI
WI = TEMPR*WSTPI + WI*WSTPR
207 IF (I-J) 205,208,211
208 DATA(I+1) = -DATA(I+1)
211 DATA(NB+1) = DATA(1) - DATA(2)
DATA(NB+2) = 0.
DATA(1) = DATA(1) + DATA(2)
DATA(2) = 0.
RETURN
END
SUBROUTINE xfft2(DATA,NB)
c
c the cooley-tukey fast fourier transform in usasi basic fortran
c
C .. Scalar Arguments ..
INTEGER NB
C ..
C .. Array Arguments ..
REAL DATA(NB+2)
C ..
C .. Local Scalars ..
REAL DIFI,DIFR,RTHLF,SUMI,SUMR,T2I,T2R,T3I,T3R,T4I,
+ T4R,TEMPI,TEMPR,THETA,TWOPI,U1I,U1R,U2I,U2R,U3I,U3R,
+ U4I,U4R,W2I,W2R,W3I,W3R,WI,WR,WSTPI,WSTPR
INTEGER I,I2,IPAR,J,K1,K2,K3,K4,KDIF,KMIN,
+ KSTEP,L,LMAX,M,MMAX,NH
C ..
C .. Intrinsic Functions ..
INTRINSIC COS,MAX0,REAL,SIN
C ..
C .. Data statements ..
DATA TWOPI/6.2831853071796/,RTHLF/0.70710678118655/
c
c 1. real transform for the 1st dimension, n even. method--
c transform a complex array of length n/2 whose real parts
c are the even numbered real values and whose imaginary parts
c are the odd numbered real values. separate and supply
c the second half by conjugate symmetry.
c
NH = NB/2
c
c shuffle data by bit reversal, since n=2**k.
c
J = 1
DO 131 I2 = 1,NB,2
IF (J-I2) 124,127,127
124 TEMPR = DATA(I2)
TEMPI = DATA(I2+1)
DATA(I2) = DATA(J)
DATA(I2+1) = DATA(J+1)
DATA(J) = TEMPR
DATA(J+1) = TEMPI
127 M = NH
128 IF (J-M) 130,130,129
129 J = J - M
M = M/2
IF (M-2) 130,128,128
130 J = J + M
131 CONTINUE
c
c main loop for factors of two. perform fourier transforms of
c length four, with one of length two if needed. the twiddle factor
c w=exp(-2*pi*sqrt(-1)*m/(4*mmax)). check for w=-sqrt(-1)
c and repeat for w=w*(1-sqrt(-1))/sqrt(2).
c
IF (NB-2) 174,174,143
143 IPAR = NH
144 IF (IPAR-2) 149,146,145
145 IPAR = IPAR/4
GO TO 144
146 DO 147 K1 = 1,NB,4
K2 = K1 + 2
TEMPR = DATA(K2)
TEMPI = DATA(K2+1)
DATA(K2) = DATA(K1) - TEMPR
DATA(K2+1) = DATA(K1+1) - TEMPI
DATA(K1) = DATA(K1) + TEMPR
DATA(K1+1) = DATA(K1+1) + TEMPI
147 CONTINUE
149 MMAX = 2
150 IF (MMAX-NH) 151,174,174
151 LMAX = MAX0(4,MMAX/2)
DO 173 L = 2,LMAX,4
M = L
IF (MMAX-2) 156,156,152
152 THETA = -TWOPI*REAL(L)/REAL(4*MMAX)
WR = COS(THETA)
WI = SIN(THETA)
155 W2R = WR*WR - WI*WI
W2I = 2.*WR*WI
W3R = W2R*WR - W2I*WI
W3I = W2R*WI + W2I*WR
156 KMIN = 1 + IPAR*M
IF (MMAX-2) 157,157,158
157 KMIN = 1
158 KDIF = IPAR*MMAX
159 KSTEP = 4*KDIF
IF (KSTEP-NB) 160,160,169
160 DO 168 K1 = KMIN,NB,KSTEP
K2 = K1 + KDIF
K3 = K2 + KDIF
K4 = K3 + KDIF
IF (MMAX-2) 161,161,164
161 U1R = DATA(K1) + DATA(K2)
U1I = DATA(K1+1) + DATA(K2+1)
U2R = DATA(K3) + DATA(K4)
U2I = DATA(K3+1) + DATA(K4+1)
U3R = DATA(K1) - DATA(K2)
U3I = DATA(K1+1) - DATA(K2+1)
U4R = DATA(K3+1) - DATA(K4+1)
U4I = DATA(K4) - DATA(K3)
GO TO 167
164 T2R = W2R*DATA(K2) - W2I*DATA(K2+1)
T2I = W2R*DATA(K2+1) + W2I*DATA(K2)
T3R = WR*DATA(K3) - WI*DATA(K3+1)
T3I = WR*DATA(K3+1) + WI*DATA(K3)
T4R = W3R*DATA(K4) - W3I*DATA(K4+1)
T4I = W3R*DATA(K4+1) + W3I*DATA(K4)
U1R = DATA(K1) + T2R
U1I = DATA(K1+1) + T2I
U2R = T3R + T4R
U2I = T3I + T4I
U3R = DATA(K1) - T2R
U3I = DATA(K1+1) - T2I
U4R = T3I - T4I
U4I = T4R - T3R
167 DATA(K1) = U1R + U2R
DATA(K1+1) = U1I + U2I
DATA(K2) = U3R + U4R
DATA(K2+1) = U3I + U4I
DATA(K3) = U1R - U2R
DATA(K3+1) = U1I - U2I
DATA(K4) = U3R - U4R
DATA(K4+1) = U3I - U4I
168 CONTINUE
KDIF = KSTEP
KMIN = 4*KMIN - 3
GO TO 159
169 M = M + LMAX
IF (M-MMAX) 170,170,173
170 TEMPR = WR
WR = (WR+WI)*RTHLF
WI = (WI-TEMPR)*RTHLF
GO TO 155
173 CONTINUE
IPAR = 3 - IPAR
MMAX = MMAX + MMAX
GO TO 150
c
c complete a real transform in the 1st dimension, n even, by con-
c jugate symmetries.
c
174 THETA = -TWOPI/REAL(NB)
WSTPR = COS(THETA)
WSTPI = SIN(THETA)
WR = WSTPR
WI = WSTPI
I = 3
J = NB - 1
GO TO 207
205 SUMR = (DATA(I)+DATA(J))/2.
SUMI = (DATA(I+1)+DATA(J+1))/2.
DIFR = (DATA(I)-DATA(J))/2.
DIFI = (DATA(I+1)-DATA(J+1))/2.
TEMPR = WR*SUMI + WI*DIFR
TEMPI = WI*SUMI - WR*DIFR
DATA(I) = SUMR + TEMPR
DATA(I+1) = DIFI + TEMPI
DATA(J) = SUMR - TEMPR
DATA(J+1) = -DIFI + TEMPI
I = I + 2
J = J - 2
TEMPR = WR
WR = WR*WSTPR - WI*WSTPI
WI = TEMPR*WSTPI + WI*WSTPR
207 IF (I-J) 205,208,211
208 DATA(I+1) = -DATA(I+1)
211 DATA(NB+1) = DATA(1) - DATA(2)
DATA(NB+2) = 0.
DATA(1) = DATA(1) + DATA(2)
DATA(2) = 0.
RETURN
END