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

170
MoonDop.f
View File

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

154
afc65.f
View File

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

28
astropak.f
View File

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

8
avecom.h
View File

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

216
azdist.f
View File

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

134
bzap.f
View File

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

114
char.h
View File

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

62
chkmsg.f
View File

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

74
coord.f
View File

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

10
db.f
View File

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

78
dcoord.f
View File

@ -1,39 +1,39 @@
SUBROUTINE DCOORD(A0,B0,AP,BP,A1,B1,A2,B2) SUBROUTINE DCOORD(A0,B0,AP,BP,A1,B1,A2,B2)
implicit real*8 (a-h,o-z) implicit real*8 (a-h,o-z)
C Examples: C Examples:
C 1. From ha,dec to az,el: C 1. From ha,dec to az,el:
C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el) C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el)
C 2. From az,el to ha,dec: C 2. From az,el to ha,dec:
C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec) C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec)
C 3. From ra,dec to l,b C 3. From ra,dec to l,b
C call coord(4.635594495,-0.504691042,3.355395488,0.478220215, C call coord(4.635594495,-0.504691042,3.355395488,0.478220215,
C ra,dec,l,b) C ra,dec,l,b)
C 4. From l,b to ra,dec C 4. From l,b to ra,dec
C call coord(1.705981071d0,-1.050357016d0,2.146800277d0, C call coord(1.705981071d0,-1.050357016d0,2.146800277d0,
C 0.478220215d0,l,b,ra,dec) C 0.478220215d0,l,b,ra,dec)
C 5. From ecliptic latitude (eb) and longitude (el) to 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) C call coord(0.d0,0.d0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb)
SB0=sin(B0) SB0=sin(B0)
CB0=cos(B0) CB0=cos(B0)
SBP=sin(BP) SBP=sin(BP)
CBP=cos(BP) CBP=cos(BP)
SB1=sin(B1) SB1=sin(B1)
CB1=cos(B1) CB1=cos(B1)
SB2=SBP*SB1 + CBP*CB1*cos(AP-A1) SB2=SBP*SB1 + CBP*CB1*cos(AP-A1)
CB2=SQRT(1.D0-SB2**2) CB2=SQRT(1.D0-SB2**2)
B2=atan(SB2/CB2) B2=atan(SB2/CB2)
SAA=sin(AP-A1)*CB1/CB2 SAA=sin(AP-A1)*CB1/CB2
CAA=(SB1-SB2*SBP)/(CB2*CBP) CAA=(SB1-SB2*SBP)/(CB2*CBP)
CBB=SB0/CBP CBB=SB0/CBP
SBB=sin(AP-A0)*CB0 SBB=sin(AP-A0)*CB0
SA2=SAA*CBB-CAA*SBB SA2=SAA*CBB-CAA*SBB
CA2=CAA*CBB+SAA*SBB CA2=CAA*CBB+SAA*SBB
IF(CA2.LE.0.D0) TA2O2=(1.D0-CA2)/SA2 IF(CA2.LE.0.D0) TA2O2=(1.D0-CA2)/SA2
IF(CA2.GT.0.D0) TA2O2=SA2/(1.D0+CA2) IF(CA2.GT.0.D0) TA2O2=SA2/(1.D0+CA2)
A2=2.D0*atan(TA2O2) A2=2.D0*atan(TA2O2)
IF(A2.LT.0.D0) A2=A2+6.2831853071795864D0 IF(A2.LT.0.D0) A2=A2+6.2831853071795864D0
RETURN RETURN
END 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) real s3(64,63)
character callsign*12,grid*4,message*22,hisgrid*6,c*1,ceme*3 character callsign*12,grid*4,message*22,hisgrid*6,c*1,ceme*3
character*12 mycall,hiscall character*12 mycall,hiscall
character mycall0*12,hiscall0*12,hisgrid0*6
character*22 decoded character*22 decoded
character*22 testmsg(2*MAXCALLS + 2 + MAXRPT) character*22 testmsg(2*MAXCALLS + 2 + MAXRPT)
character*15 callgrid(MAXCALLS) character*15 callgrid(MAXCALLS)
character*180 line character*180 line
character*4 rpt(MAXRPT) character*4 rpt(MAXRPT)
integer ncode(63,2*MAXCALLS + 2 + MAXRPT) integer ncode(63,2*MAXCALLS + 2 + MAXRPT)
integer nflip(2*MAXCALLS + 2 + MAXRPT)
integer istat23(13)
real pp(2*MAXCALLS + 2 + MAXRPT) real pp(2*MAXCALLS + 2 + MAXRPT)
common/tmp9/ mrs(63),mrs2(63) common/mrscom/ mrs(63),mrs2(63)
#ifdef Win32
C This prevents some optimizations that break this subroutine.
volatile p1,p2,bias
#endif
data neme0/-99/ data neme0/-99/
data rpt/'-01','-02','-03','-04','-05', 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-21','R-22','R-23','R-24','R-25',
+ 'R-26','R-27','R-28','R-29','R-30', + 'R-26','R-27','R-28','R-29','R-30',
+ 'RO','RRR','73'/ + '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 rewind 23
k=0 k=0
icall=0 icall=0
@ -77,7 +82,7 @@ C This prevents some optimizations that break this subroutine.
mz=1 mz=1
if(n.eq.1 .and. j3.lt.1 .and. j4.lt.1 .and. 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 C Test for messages with MyCall + HisCall + report
do m=1,mz do m=1,mz
if(m.gt.1) grid=rpt(m-1) if(m.gt.1) grid=rpt(m-1)
@ -87,12 +92,14 @@ C Test for messages with MyCall + HisCall + report
k=k+1 k=k+1
testmsg(k)=message testmsg(k)=message
call encode65(message,ncode(1,k)) 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 if(m.eq.1 .and. flip.gt.0.0) then
message='CQ '//callgrid(icall) message='CQ '//callgrid(icall)
k=k+1 k=k+1
testmsg(k)=message testmsg(k)=message
call encode65(message,ncode(1,k)) call encode65(message,ncode(1,k))
nflip(k)=flip
endif endif
enddo enddo
if(nsked.eq.1) go to 20 if(nsked.eq.1) go to 20
@ -101,28 +108,33 @@ C Insert CQ message unless sync=OOO (flip=-1).
20 ntot=k 20 ntot=k
neme0=neme neme0=neme
30 mycall0=mycall
hiscall0=hiscall
hisgrid0=hisgrid
modified0=modified
ref0=0. ref0=0.
do j=1,63 do j=1,63
ref0=ref0 + s3(mrs(j),j) ref0=ref0 + s3(mrs(j),j)
enddo enddo
p1=-1.e30 p1=-1.e30
p2=-1.e30
do k=1,ntot do k=1,ntot
sum=0. if(flip.gt.0.0 .or. nflip(k).lt.0) then !Skip CQ msg if flip=-1
ref=ref0 sum=0.
do j=1,63 ref=ref0
i=ncode(j,k)+1 do j=1,63
sum=sum + s3(i,j) i=ncode(j,k)+1
if(i.eq.mrs(j)) then sum=sum + s3(i,j)
ref=ref - s3(i,j) + s3(mrs2(j),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 endif
enddo
p=sum/ref
pp(k)=p
if(p.gt.p1) then
p1=p
ip1=k
endif endif
enddo 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) if(pp(i).gt.p2 .and. pp(i).ne.p1) p2=pp(i)
enddo 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.1) bias=max(1.12*p2,0.335)
if(mode65.eq.2) bias=max(1.08*p2,0.405) if(mode65.eq.2) bias=max(1.08*p2,0.405)
if(mode65.ge.4) bias=max(1.04*p2,0.505) if(mode65.ge.4) bias=max(1.04*p2,0.505)
if(p2.eq.p1) stop 'Error in deep65'
qual=100.0*(p1-bias) qual=100.0*(p1-bias)
decoded=' ' decoded=' '
c=' ' c=' '
@ -145,6 +165,7 @@ C Insert CQ message unless sync=OOO (flip=-1).
qual=0. qual=0.
endif endif
decoded(22:22)=c decoded(22:22)=c
C Make sure everything is upper case. C Make sure everything is upper case.
do i=1,22 do i=1,22
if(decoded(i:i).ge.'a' .and. decoded(i:i).le.'z') 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) subroutine deg2grid(dlong0,dlat,grid)
real dlong !West longitude (deg) real dlong !West longitude (deg)
real dlat !Latitude (deg) real dlat !Latitude (deg)
character grid*6 character grid*6
dlong=dlong0 dlong=dlong0
if(dlong.lt.-180.0) dlong=dlong+360.0 if(dlong.lt.-180.0) dlong=dlong+360.0
if(dlong.gt.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. C Convert to units of 5 min of longitude, working east from 180 deg.
nlong=60.0*(180.0-dlong)/5.0 nlong=60.0*(180.0-dlong)/5.0
n1=nlong/240 !20-degree field n1=nlong/240 !20-degree field
n2=(nlong-240*n1)/24 !2 degree square n2=(nlong-240*n1)/24 !2 degree square
n3=nlong-240*n1-24*n2 !5 minute subsquare n3=nlong-240*n1-24*n2 !5 minute subsquare
grid(1:1)=char(ichar('A')+n1) grid(1:1)=char(ichar('A')+n1)
grid(3:3)=char(ichar('0')+n2) grid(3:3)=char(ichar('0')+n2)
grid(5:5)=char(ichar('a')+n3) grid(5:5)=char(ichar('a')+n3)
C Convert to units of 2.5 min of latitude, working north from -90 deg. C Convert to units of 2.5 min of latitude, working north from -90 deg.
nlat=60.0*(dlat+90)/2.5 nlat=60.0*(dlat+90)/2.5
n1=nlat/240 !10-degree field n1=nlat/240 !10-degree field
n2=(nlat-240*n1)/24 !1 degree square n2=(nlat-240*n1)/24 !1 degree square
n3=nlat-240*n1-24*n2 !2.5 minuts subsquare n3=nlat-240*n1-24*n2 !2.5 minuts subsquare
grid(2:2)=char(ichar('A')+n1) grid(2:2)=char(ichar('A')+n1)
grid(4:4)=char(ichar('0')+n2) grid(4:4)=char(ichar('0')+n2)
grid(6:6)=char(ichar('a')+n3) grid(6:6)=char(ichar('a')+n3)
return return
end end

142
demod64a.f
View File

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

58
detect.f
View File

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

26
encode65.f
View File

@ -1,13 +1,13 @@
subroutine encode65(message,sent) subroutine encode65(message,sent)
character message*22 character message*22
integer dgen(12) integer dgen(12)
integer sent(63) integer sent(63)
call packmsg(message,dgen) call packmsg(message,dgen)
call rs_encode(dgen,sent) call rs_encode(dgen,sent)
call interleave63(sent,1) call interleave63(sent,1)
call graycode(sent,63,1) call graycode(sent,63,1)
return return
end 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 s3(64,63)
real tmp(4032)
character decoded*22 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) integer mrsym(63),mr2sym(63),mrprob(63),mr2prob(63)
logical first logical first
data first/.true./,nsec1/0/ data first/.true./,nsec1/0/
save 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 if(ntest.lt.50 .or. nlow.gt.20) then
ncount=-999 !Flag bad data ncount=-999 !Flag bad data
go to 900 go to 900
endif 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 graycode(mrsym,63,-1)
call interleave63(mrsym,-1) call interleave63(mrsym,-1)
call interleave63(mrprob,-1) call interleave63(mrprob,-1)
ndec=1 ndec=1
nemax=30 nemax=30 !Was 200 (30)
maxe=8 maxe=8
xlambda=15.0 xlambda=12.0 !Was 15 (12)
if(ndec.eq.1) then if(ndec.eq.1) then
call graycode(mr2sym,63,-1) call graycode(mr2sym,63,-1)
@ -35,9 +46,9 @@
call flushqqq(22) call flushqqq(22)
call runqqq('kvasd.exe','-q',iret) call runqqq('kvasd.exe','-q',iret)
if(iret.ne.0) then 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.'/ 1000 format('Error in KV decoder, or no KV decoder present.'/
+ 'Using BM algorithm.') + 'Return code:',i8,'. Will use BM algorithm.')
ndec=0 ndec=0
first=.false. first=.false.
go to 20 go to 20

128
fftw3.f
View File

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

10
fivehz.h
View File

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

60
flat1.f
View File

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

56
flat2.f
View File

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

210
flatten.f
View File

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

700
four2.f
View File

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

156
four2a.f
View File

@ -1,75 +1,81 @@
SUBROUTINE FOUR2a (a,nfft,NDIM,ISIGN,IFORM) SUBROUTINE FOUR2a (a,nfft,NDIM,ISIGN,IFORM)
C IFORM = 1, 0 or -1, as data is C IFORM = 1, 0 or -1, as data is
C complex, real, or the first half of a complex array. Transform 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 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 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 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 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 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 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 reserved. The missing values may be obtained by complex conjuga-
C tion. C tion.
C The reverse transformation of a half complex array dimensioned 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 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 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 The transform will be real and returned to the input array.
parameter (NPMAX=100) parameter (NPMAX=100)
complex a(nfft) complex a(nfft)
integer nn(NPMAX),ns(NPMAX),nf(NPMAX),nl(NPMAX) complex aa(32768)
integer plan(NPMAX) integer nn(NPMAX),ns(NPMAX),nf(NPMAX),nl(NPMAX)
data nplan/0/ integer*8 plan(NPMAX)
include 'fftw3.f' data nplan/0/
save include 'fftw3.f'
save
if(nfft.lt.0) go to 999
if(nfft.lt.0) go to 999
nloc=loc(a)
do i=1,nplan nloc=loc(a)
if(nfft.eq.nn(i) .and. isign.eq.ns(i) .and. do i=1,nplan
+ iform.eq.nf(i) .and. nloc.eq.nl(i)) go to 10 if(nfft.eq.nn(i) .and. isign.eq.ns(i) .and.
enddo + iform.eq.nf(i) .and. nloc.eq.nl(i)) go to 10
if(nplan.ge.NPMAX) stop 'Too many FFTW plans requested.' enddo
nplan=nplan+1 if(nplan.ge.NPMAX) stop 'Too many FFTW plans requested.'
i=nplan nplan=nplan+1
nn(i)=nfft i=nplan
ns(i)=isign nn(i)=nfft
nf(i)=iform ns(i)=isign
nl(i)=nloc nf(i)=iform
nl(i)=nloc
C Planning: FFTW_ESTIMATE, FFTW_MEASURE, FFTW_PATIENT, FFTW_EXHAUSTIVE
nspeed=FFTW_ESTIMATE C Planning: FFTW_ESTIMATE, FFTW_MEASURE, FFTW_PATIENT, FFTW_EXHAUSTIVE
if(nfft.le.16384) nspeed=FFTW_MEASURE nspeed=FFTW_ESTIMATE
if(nfft.le.16384) nspeed=FFTW_MEASURE
if(isign.eq.-1 .and. iform.eq.1) then nspeed=FFTW_MEASURE
call sfftw_plan_dft_1d_(plan(i),nfft,a,a, if(nfft.le.32768) then
+ FFTW_FORWARD,nspeed) do j=1,nfft
else if(isign.eq.1 .and. iform.eq.1) then aa(j)=a(j)
call sfftw_plan_dft_1d_(plan(i),nfft,a,a, enddo
+ FFTW_BACKWARD,nspeed) endif
else if(isign.eq.-1 .and. iform.eq.0) then if(isign.eq.-1 .and. iform.eq.1) then
call sfftw_plan_dft_r2c_1d_(plan(i),nfft,a,a,nspeed) call sfftw_plan_dft_1d_(plan(i),nfft,a,a,
else if(isign.eq.1 .and. iform.eq.-1) then + FFTW_FORWARD,nspeed)
call sfftw_plan_dft_c2r_1d_(plan(i),nfft,a,a,nspeed) else if(isign.eq.1 .and. iform.eq.1) then
else call sfftw_plan_dft_1d_(plan(i),nfft,a,a,
stop 'Unsupported request in four2a' + FFTW_BACKWARD,nspeed)
endif else if(isign.eq.-1 .and. iform.eq.0) then
call sfftw_plan_dft_r2c_1d_(plan(i),nfft,a,a,nspeed)
i=nplan else if(isign.eq.1 .and. iform.eq.-1) then
! write(*,3001) i,nn(i),ns(i),nf(i),nl(i),plan(i) call sfftw_plan_dft_c2r_1d_(plan(i),nfft,a,a,nspeed)
! 3001 format(6i10) else
stop 'Unsupported request in four2a'
10 call sfftw_execute_(plan(i)) endif
return i=nplan
if(nfft.le.32768) then
999 do i=1,nplan do j=1,nfft
! print*,i,nn(i),ns(i),nf(i),nl(i),plan(i) a(j)=aa(j)
call sfftw_destroy_plan_(plan(i)) enddo
enddo endif
! print*,'FFTW plans destroyed:',nplan
10 call sfftw_execute_(plan(i))
return return
end
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) err=940)
#endif #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 #ifdef Win32
open(21,file=appdir(:iz)//'/ALL.TXT',status='unknown', & open(21,file=appdir(:iz)//'/ALL.TXT',status='unknown', &
access='append',share='denynone',err=950) access='append',share='denynone',err=950)

48
ftsky.f
View File

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

102
gcom1.f90
View File

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

200
gcom2.f90
View File

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

40
gcom3.f90
View File

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

20
gcom4.f90
View File

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

164
gen65.f
View File

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

72
gencwid.f
View File

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

26
gentone.f
View File

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

34
geocentric.f
View File

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

90
getpfx1.f
View File

@ -1,45 +1,45 @@
subroutine getpfx1(callsign,k) subroutine getpfx1(callsign,k)
character callsign*12 character callsign*12
character*8 c character*8 c
character addpfx*8 character addpfx*8
C Can't 'include' *.f90 in *.f C Can't 'include' *.f90 in *.f
common/gcom4/addpfx common/gcom4/addpfx
include 'pfx.f' include 'pfx.f'
iz=index(callsign,' ') - 1 iz=index(callsign,' ') - 1
if(iz.lt.0) iz=12 if(iz.lt.0) iz=12
islash=index(callsign(1:iz),'/') islash=index(callsign(1:iz),'/')
k=0 k=0
c=' ' c=' '
if(islash.gt.0 .and. islash.le.(iz-4)) then if(islash.gt.0 .and. islash.le.(iz-4)) then
! Add-on prefix ! Add-on prefix
c=callsign(1:islash-1) c=callsign(1:islash-1)
callsign=callsign(islash+1:iz) callsign=callsign(islash+1:iz)
do i=1,NZ do i=1,NZ
if(pfx(i)(1:4).eq.c) then if(pfx(i)(1:4).eq.c) then
k=i k=i
go to 10 go to 10
endif endif
enddo enddo
if(addpfx.eq.c) then if(addpfx.eq.c) then
k=449 k=449
go to 10 go to 10
endif endif
else if(islash.eq.(iz-1)) then else if(islash.eq.(iz-1)) then
! Add-on suffix ! Add-on suffix
c=callsign(islash+1:iz) c=callsign(islash+1:iz)
callsign=callsign(1:islash-1) callsign=callsign(1:islash-1)
do i=1,NZ2 do i=1,NZ2
if(sfx(i).eq.c(1:1)) then if(sfx(i).eq.c(1:1)) then
k=400+i k=400+i
go to 10 go to 10
endif endif
enddo enddo
endif endif
10 if(islash.ne.0 .and.k.eq.0) k=-1 10 if(islash.ne.0 .and.k.eq.0) k=-1
return return
end end

48
getpfx2.f
View File

@ -1,24 +1,24 @@
subroutine getpfx2(k0,callsign) subroutine getpfx2(k0,callsign)
character callsign*12 character callsign*12
include 'pfx.f' include 'pfx.f'
character addpfx*8 character addpfx*8
common/gcom4/addpfx common/gcom4/addpfx
k=k0 k=k0
if(k.gt.450) k=k-450 if(k.gt.450) k=k-450
if(k.ge.1 .and. k.le.NZ) then if(k.ge.1 .and. k.le.NZ) then
iz=index(pfx(k),' ') - 1 iz=index(pfx(k),' ') - 1
callsign=pfx(k)(1:iz)//'/'//callsign callsign=pfx(k)(1:iz)//'/'//callsign
else if(k.ge.401 .and. k.le.400+NZ2) then else if(k.ge.401 .and. k.le.400+NZ2) then
iz=index(callsign,' ') - 1 iz=index(callsign,' ') - 1
callsign=callsign(1:iz)//'/'//sfx(k-400) callsign=callsign(1:iz)//'/'//sfx(k-400)
else if(k.eq.449) then else if(k.eq.449) then
iz=index(addpfx,' ') - 1 iz=index(addpfx,' ') - 1
if(iz.lt.1) iz=8 if(iz.lt.1) iz=8
callsign=addpfx(1:iz)//'/'//callsign callsign=addpfx(1:iz)//'/'//callsign
endif endif
return return
end end

70
getsnr.f
View File

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

20
graycode.f
View File

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

80
grid2deg.f
View File

@ -1,40 +1,40 @@
subroutine grid2deg(grid0,dlong,dlat) subroutine grid2deg(grid0,dlong,dlat)
C Converts Maidenhead grid locator to degrees of West longitude C Converts Maidenhead grid locator to degrees of West longitude
C and North latitude. C and North latitude.
character*6 grid0,grid character*6 grid0,grid
character*1 g1,g2,g3,g4,g5,g6 character*1 g1,g2,g3,g4,g5,g6
grid=grid0 grid=grid0
i=ichar(grid(5:5)) i=ichar(grid(5:5))
if(grid(5:5).eq.' ' .or. i.le.64 .or. i.ge.128) grid(5:6)='mm' 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)= if(grid(1:1).ge.'a' .and. grid(1:1).le.'z') grid(1:1)=
+ char(ichar(grid(1:1))+ichar('A')-ichar('a')) + char(ichar(grid(1:1))+ichar('A')-ichar('a'))
if(grid(2:2).ge.'a' .and. grid(2:2).le.'z') grid(2:2)= if(grid(2:2).ge.'a' .and. grid(2:2).le.'z') grid(2:2)=
+ char(ichar(grid(2:2))+ichar('A')-ichar('a')) + char(ichar(grid(2:2))+ichar('A')-ichar('a'))
if(grid(5:5).ge.'A' .and. grid(5:5).le.'Z') grid(5:5)= if(grid(5:5).ge.'A' .and. grid(5:5).le.'Z') grid(5:5)=
+ char(ichar(grid(5:5))-ichar('A')+ichar('a')) + char(ichar(grid(5:5))-ichar('A')+ichar('a'))
if(grid(6:6).ge.'A' .and. grid(6:6).le.'Z') grid(6:6)= if(grid(6:6).ge.'A' .and. grid(6:6).le.'Z') grid(6:6)=
+ char(ichar(grid(6:6))-ichar('A')+ichar('a')) + char(ichar(grid(6:6))-ichar('A')+ichar('a'))
g1=grid(1:1) g1=grid(1:1)
g2=grid(2:2) g2=grid(2:2)
g3=grid(3:3) g3=grid(3:3)
g4=grid(4:4) g4=grid(4:4)
g5=grid(5:5) g5=grid(5:5)
g6=grid(6:6) g6=grid(6:6)
nlong = 180 - 20*(ichar(g1)-ichar('A')) nlong = 180 - 20*(ichar(g1)-ichar('A'))
n20d = 2*(ichar(g3)-ichar('0')) n20d = 2*(ichar(g3)-ichar('0'))
xminlong = 5*(ichar(g5)-ichar('a')+0.5) xminlong = 5*(ichar(g5)-ichar('a')+0.5)
dlong = nlong - n20d - xminlong/60.0 dlong = nlong - n20d - xminlong/60.0
c print*,nlong,n20d,xminlong,dlong c print*,nlong,n20d,xminlong,dlong
nlat = -90+10*(ichar(g2)-ichar('A')) + ichar(g4)-ichar('0') nlat = -90+10*(ichar(g2)-ichar('A')) + ichar(g4)-ichar('0')
xminlat = 2.5*(ichar(g6)-ichar('a')+0.5) xminlat = 2.5*(ichar(g6)-ichar('a')+0.5)
dlat = nlat + xminlat/60.0 dlat = nlat + xminlat/60.0
c print*,nlat,xminlat,dlat c print*,nlat,xminlat,dlat
return return
end end

24
grid2k.f
View File

@ -1,12 +1,12 @@
subroutine grid2k(grid,k) subroutine grid2k(grid,k)
character*6 grid character*6 grid
call grid2deg(grid,xlong,xlat) call grid2deg(grid,xlong,xlat)
nlong=nint(xlong) nlong=nint(xlong)
nlat=nint(xlat) nlat=nint(xlat)
k=0 k=0
if(nlat.ge.85) k=5*(nlong+179)/2 + nlat-84 if(nlat.ge.85) k=5*(nlong+179)/2 + nlat-84
return return
end end

38
indexx.f
View File

@ -1,19 +1,19 @@
subroutine indexx(n,arr,indx) subroutine indexx(n,arr,indx)
parameter (NMAX=3000) parameter (NMAX=3000)
integer indx(n) integer indx(n)
real arr(n) real arr(n)
real brr(NMAX) real brr(NMAX)
if(n.gt.NMAX) then if(n.gt.NMAX) then
print*,'n=',n,' too big in indexx.' print*,'n=',n,' too big in indexx.'
stop stop
endif endif
do i=1,n do i=1,n
brr(i)=arr(i) brr(i)=arr(i)
indx(i)=i indx(i)=i
enddo enddo
call ssort(brr,indx,n,2) call ssort(brr,indx,n,2)
return return
end end

114
int.h
View File

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

50
interleave63.f
View File

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

24
k2grid.f
View File

@ -1,12 +1,12 @@
subroutine k2grid(k,grid) subroutine k2grid(k,grid)
character grid*6 character grid*6
nlong=2*mod((k-1)/5,90)-179 nlong=2*mod((k-1)/5,90)-179
if(k.gt.450) nlong=nlong+180 if(k.gt.450) nlong=nlong+180
nlat=mod(k-1,5)+ 85 nlat=mod(k-1,5)+ 85
dlat=nlat dlat=nlat
dlong=nlong dlong=nlong
call deg2grid(dlong,dlat,grid) call deg2grid(dlong,dlat,grid)
return return
end end

62
limit.f
View File

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

134
lpf1.f
View File

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

52
map65.py
View File

@ -164,6 +164,22 @@ def testmsgs():
tx5.insert(0,"@1000") tx5.insert(0,"@1000")
tx6.insert(0,"@2000") 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 #------------------------------------------------------ logqso
def logqso(event=NONE): def logqso(event=NONE):
t=time.strftime("%Y-%b-%d,%H:%M",time.gmtime()) t=time.strftime("%Y-%b-%d,%H:%M",time.gmtime())
@ -1070,22 +1086,6 @@ def plot_yellow():
xy2.append(n) xy2.append(n)
graph1.create_line(xy2,fill="yellow") 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 #------------------------------------------------------ update
def update(): def update():
global root_geom,isec0,naz,nel,ndmiles,ndkm,nopen, \ global root_geom,isec0,naz,nel,ndmiles,ndkm,nopen, \
@ -1179,6 +1179,10 @@ def update():
bdecode.configure(bg='gray85',activebackground='gray95') bdecode.configure(bg='gray85',activebackground='gray95')
if Audio.gcom2.ndecoding: #Set button bg=light_blue while decoding if Audio.gcom2.ndecoding: #Set button bg=light_blue while decoding
bdecode.configure(bg='#66FFFF',activebackground='#66FFFF') bdecode.configure(bg='#66FFFF',activebackground='#66FFFF')
# print 'A'
Audio.map65a0() # @@@ Temporary @@@
# print 'B'
tx1.configure(bg='white') tx1.configure(bg='white')
tx2.configure(bg='white') tx2.configure(bg='white')
tx3.configure(bg='white') tx3.configure(bg='white')
@ -1251,6 +1255,21 @@ def update():
avetext.insert(END,lines[0]) avetext.insert(END,lines[0])
avetext.insert(END,lines[1]) avetext.insert(END,lines[1])
# avetext.configure(state=DISABLED) # 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 Audio.gcom2.ndecdone=2
if g.cmap != cmap0: if g.cmap != cmap0:
@ -1744,7 +1763,6 @@ msg7=Message(iframe6, text=' ', width=300,relief=SUNKEN)
msg7.pack(side=RIGHT, fill=X, padx=1) msg7.pack(side=RIGHT, fill=X, padx=1)
iframe6.pack(expand=1, fill=X, padx=4) iframe6.pack(expand=1, fill=X, padx=4)
frame.pack() frame.pack()
ldate.after(100,update) ldate.after(100,update)
lauto=0 lauto=0
isync=1 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, subroutine moon2(y,m,Day,UT,lon,lat,RA,Dec,topRA,topDec,
+ LST,HA,Az,El,dist) + LST,HA,Az,El,dist)
implicit none implicit none
integer y !Year integer y !Year
integer m !Month integer m !Month
integer Day !Day integer Day !Day
real*8 UT !UTC in hours real*8 UT !UTC in hours
real*8 RA,Dec !RA and Dec of moon real*8 RA,Dec !RA and Dec of moon
C NB: Double caps are single caps in the writeup. C NB: Double caps are single caps in the writeup.
real*8 NN !Longitude of ascending node real*8 NN !Longitude of ascending node
real*8 i !Inclination to the ecliptic real*8 i !Inclination to the ecliptic
real*8 w !Argument of perigee real*8 w !Argument of perigee
real*8 a !Semi-major axis real*8 a !Semi-major axis
real*8 e !Eccentricity real*8 e !Eccentricity
real*8 MM !Mean anomaly real*8 MM !Mean anomaly
real*8 v !True anomaly real*8 v !True anomaly
real*8 EE !Eccentric anomaly real*8 EE !Eccentric anomaly
real*8 ecl !Obliquity of the ecliptic real*8 ecl !Obliquity of the ecliptic
real*8 d !Ephemeris time argument in days real*8 d !Ephemeris time argument in days
real*8 r !Distance to sun, AU real*8 r !Distance to sun, AU
real*8 xv,yv !x and y coords in ecliptic real*8 xv,yv !x and y coords in ecliptic
real*8 lonecl,latecl !Ecliptic long and lat of moon real*8 lonecl,latecl !Ecliptic long and lat of moon
real*8 xg,yg,zg !Ecliptic rectangular coords real*8 xg,yg,zg !Ecliptic rectangular coords
real*8 Ms !Mean anomaly of sun real*8 Ms !Mean anomaly of sun
real*8 ws !Argument of perihelion of sun real*8 ws !Argument of perihelion of sun
real*8 Ls !Mean longitude of sun (Ns=0) real*8 Ls !Mean longitude of sun (Ns=0)
real*8 Lm !Mean longitude of moon real*8 Lm !Mean longitude of moon
real*8 DD !Mean elongation of moon real*8 DD !Mean elongation of moon
real*8 FF !Argument of latitude for moon real*8 FF !Argument of latitude for moon
real*8 xe,ye,ze !Equatorial geocentric coords of moon real*8 xe,ye,ze !Equatorial geocentric coords of moon
real*8 mpar !Parallax of moon (r_E / d) real*8 mpar !Parallax of moon (r_E / d)
real*8 lat,lon !Station coordinates on earth real*8 lat,lon !Station coordinates on earth
real*8 gclat !Geocentric latitude real*8 gclat !Geocentric latitude
real*8 rho !Earth radius factor real*8 rho !Earth radius factor
real*8 GMST0,LST,HA real*8 GMST0,LST,HA
real*8 g real*8 g
real*8 topRA,topDec !Topocentric coordinates of Moon real*8 topRA,topDec !Topocentric coordinates of Moon
real*8 Az,El real*8 Az,El
real*8 dist real*8 dist
real*8 rad,twopi,pi,pio2 real*8 rad,twopi,pi,pio2
data rad/57.2957795131d0/,twopi/6.283185307d0/ data rad/57.2957795131d0/,twopi/6.283185307d0/
d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + Day - 730530 + UT/24.d0 d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + Day - 730530 + UT/24.d0
ecl = 23.4393d0 - 3.563d-7 * d ecl = 23.4393d0 - 3.563d-7 * d
C Orbital elements for Moon: C Orbital elements for Moon:
NN = 125.1228d0 - 0.0529538083d0 * d NN = 125.1228d0 - 0.0529538083d0 * d
i = 5.1454d0 i = 5.1454d0
w = mod(318.0634d0 + 0.1643573223d0 * d + 360000.d0,360.d0) w = mod(318.0634d0 + 0.1643573223d0 * d + 360000.d0,360.d0)
a = 60.2666d0 a = 60.2666d0
e = 0.054900d0 e = 0.054900d0
MM = mod(115.3654d0 + 13.0649929509d0 * d + 360000.d0,360.d0) 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 = 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))
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) xv = a * (cos(EE/rad) - e)
yv = a * (sqrt(1.d0-e*e) * sin(EE/rad)) yv = a * (sqrt(1.d0-e*e) * sin(EE/rad))
v = mod(rad*atan2(yv,xv)+720.d0,360.d0) v = mod(rad*atan2(yv,xv)+720.d0,360.d0)
r = sqrt(xv*xv + yv*yv) r = sqrt(xv*xv + yv*yv)
C Get geocentric position in ecliptic rectangular coordinates: C Get geocentric position in ecliptic rectangular coordinates:
xg = r * (cos(NN/rad)*cos((v+w)/rad) - xg = r * (cos(NN/rad)*cos((v+w)/rad) -
+ sin(NN/rad)*sin((v+w)/rad)*cos(i/rad)) + sin(NN/rad)*sin((v+w)/rad)*cos(i/rad))
yg = r * (sin(NN/rad)*cos((v+w)/rad) + yg = r * (sin(NN/rad)*cos((v+w)/rad) +
+ cos(NN/rad)*sin((v+w)/rad)*cos(i/rad)) + cos(NN/rad)*sin((v+w)/rad)*cos(i/rad))
zg = r * (sin((v+w)/rad)*sin(i/rad)) zg = r * (sin((v+w)/rad)*sin(i/rad))
C Ecliptic longitude and latitude of moon: C Ecliptic longitude and latitude of moon:
lonecl = mod(rad*atan2(yg/rad,xg/rad)+720.d0,360.d0) lonecl = mod(rad*atan2(yg/rad,xg/rad)+720.d0,360.d0)
latecl = rad*atan2(zg/rad,sqrt(xg*xg + yg*yg)/rad) latecl = rad*atan2(zg/rad,sqrt(xg*xg + yg*yg)/rad)
C Now include orbital perturbations: C Now include orbital perturbations:
Ms = mod(356.0470d0 + 0.9856002585d0 * d + 3600000.d0,360.d0) Ms = mod(356.0470d0 + 0.9856002585d0 * d + 3600000.d0,360.d0)
ws = 282.9404d0 + 4.70935d-5*d ws = 282.9404d0 + 4.70935d-5*d
Ls = mod(Ms + ws + 720.d0,360.d0) Ls = mod(Ms + ws + 720.d0,360.d0)
Lm = mod(MM + w + NN+720.d0,360.d0) Lm = mod(MM + w + NN+720.d0,360.d0)
DD = mod(Lm - Ls + 360.d0,360.d0) DD = mod(Lm - Ls + 360.d0,360.d0)
FF = mod(Lm - NN + 360.d0,360.d0) FF = mod(Lm - NN + 360.d0,360.d0)
lonecl = lonecl lonecl = lonecl
+ -1.274d0 * sin((MM-2.d0*DD)/rad) + -1.274d0 * sin((MM-2.d0*DD)/rad)
+ +0.658d0 * sin(2.d0*DD/rad) + +0.658d0 * sin(2.d0*DD/rad)
+ -0.186d0 * sin(Ms/rad) + -0.186d0 * sin(Ms/rad)
+ -0.059d0 * sin((2.d0*MM-2.d0*DD)/rad) + -0.059d0 * sin((2.d0*MM-2.d0*DD)/rad)
+ -0.057d0 * sin((MM-2.d0*DD+Ms)/rad) + -0.057d0 * sin((MM-2.d0*DD+Ms)/rad)
+ +0.053d0 * sin((MM+2.d0*DD)/rad) + +0.053d0 * sin((MM+2.d0*DD)/rad)
+ +0.046d0 * sin((2.d0*DD-Ms)/rad) + +0.046d0 * sin((2.d0*DD-Ms)/rad)
+ +0.041d0 * sin((MM-Ms)/rad) + +0.041d0 * sin((MM-Ms)/rad)
+ -0.035d0 * sin(DD/rad) + -0.035d0 * sin(DD/rad)
+ -0.031d0 * sin((MM+Ms)/rad) + -0.031d0 * sin((MM+Ms)/rad)
+ -0.015d0 * sin((2.d0*FF-2.d0*DD)/rad) + -0.015d0 * sin((2.d0*FF-2.d0*DD)/rad)
+ +0.011d0 * sin((MM-4.d0*DD)/rad) + +0.011d0 * sin((MM-4.d0*DD)/rad)
latecl = latecl latecl = latecl
+ -0.173d0 * sin((FF-2.d0*DD)/rad) + -0.173d0 * sin((FF-2.d0*DD)/rad)
+ -0.055d0 * sin((MM-FF-2.d0*DD)/rad) + -0.055d0 * sin((MM-FF-2.d0*DD)/rad)
+ -0.046d0 * 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.033d0 * sin((FF+2.d0*DD)/rad)
+ +0.017d0 * sin((2.d0*MM+FF)/rad) + +0.017d0 * sin((2.d0*MM+FF)/rad)
r = 60.36298d0 r = 60.36298d0
+ - 3.27746d0*cos(MM/rad) + - 3.27746d0*cos(MM/rad)
+ - 0.57994d0*cos((MM-2.d0*DD)/rad) + - 0.57994d0*cos((MM-2.d0*DD)/rad)
+ - 0.46357d0*cos(2.d0*DD/rad) + - 0.46357d0*cos(2.d0*DD/rad)
+ - 0.08904d0*cos(2.d0*MM/rad) + - 0.08904d0*cos(2.d0*MM/rad)
+ + 0.03865d0*cos((2.d0*MM-2.d0*DD)/rad) + + 0.03865d0*cos((2.d0*MM-2.d0*DD)/rad)
+ - 0.03237d0*cos((2.d0*DD-Ms)/rad) + - 0.03237d0*cos((2.d0*DD-Ms)/rad)
+ - 0.02688d0*cos((MM+2.d0*DD)/rad) + - 0.02688d0*cos((MM+2.d0*DD)/rad)
+ - 0.02358d0*cos((MM-2.d0*DD+Ms)/rad) + - 0.02358d0*cos((MM-2.d0*DD+Ms)/rad)
+ - 0.02030d0*cos((MM-Ms)/rad) + - 0.02030d0*cos((MM-Ms)/rad)
+ + 0.01719d0*cos(DD/rad) + + 0.01719d0*cos(DD/rad)
+ + 0.01671d0*cos((MM+Ms)/rad) + + 0.01671d0*cos((MM+Ms)/rad)
dist=r*6378.140d0 dist=r*6378.140d0
C Geocentric coordinates: C Geocentric coordinates:
C Rectangular ecliptic coordinates of the moon: C Rectangular ecliptic coordinates of the moon:
xg = r * cos(lonecl/rad)*cos(latecl/rad) xg = r * cos(lonecl/rad)*cos(latecl/rad)
yg = r * sin(lonecl/rad)*cos(latecl/rad) yg = r * sin(lonecl/rad)*cos(latecl/rad)
zg = r * sin(latecl/rad) zg = r * sin(latecl/rad)
C Rectangular equatorial coordinates of the moon: C Rectangular equatorial coordinates of the moon:
xe = xg xe = xg
ye = yg*cos(ecl/rad) - zg*sin(ecl/rad) ye = yg*cos(ecl/rad) - zg*sin(ecl/rad)
ze = yg*sin(ecl/rad) + zg*cos(ecl/rad) ze = yg*sin(ecl/rad) + zg*cos(ecl/rad)
C Right Ascension, Declination: C Right Ascension, Declination:
RA = mod(rad*atan2(ye,xe)+360.d0,360.d0) RA = mod(rad*atan2(ye,xe)+360.d0,360.d0)
Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye)) Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye))
C Now convert to topocentric system: C Now convert to topocentric system:
mpar=rad*asin(1.d0/r) mpar=rad*asin(1.d0/r)
C alt_topoc = alt_geoc - mpar*cos(alt_geoc) C alt_topoc = alt_geoc - mpar*cos(alt_geoc)
gclat = lat - 0.1924d0*sin(2.d0*lat/rad) gclat = lat - 0.1924d0*sin(2.d0*lat/rad)
rho = 0.99883d0 + 0.00167d0*cos(2.d0*lat/rad) rho = 0.99883d0 + 0.00167d0*cos(2.d0*lat/rad)
GMST0 = (Ls + 180.d0)/15.d0 GMST0 = (Ls + 180.d0)/15.d0
LST = mod(GMST0+UT+lon/15.d0+48.d0,24.d0) !LST in hours LST = mod(GMST0+UT+lon/15.d0+48.d0,24.d0) !LST in hours
HA = 15.d0*LST - RA !HA in degrees HA = 15.d0*LST - RA !HA in degrees
g = rad*atan(tan(gclat/rad)/cos(HA/rad)) g = rad*atan(tan(gclat/rad)/cos(HA/rad))
topRA = RA - mpar*rho*cos(gclat/rad)*sin(HA/rad)/cos(Dec/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) topDec = Dec - mpar*rho*sin(gclat/rad)*sin((g-Dec)/rad)/sin(g/rad)
HA = 15.d0*LST - topRA !HA in degrees HA = 15.d0*LST - topRA !HA in degrees
if(HA.gt.180.d0) HA=HA-360.d0 if(HA.gt.180.d0) HA=HA-360.d0
if(HA.lt.-180.d0) HA=HA+360.d0 if(HA.lt.-180.d0) HA=HA+360.d0
pi=0.5d0*twopi pi=0.5d0*twopi
pio2=0.5d0*pi pio2=0.5d0*pi
call dcoord(pi,pio2-lat/rad,0.d0,lat/rad,ha*twopi/360, call dcoord(pi,pio2-lat/rad,0.d0,lat/rad,ha*twopi/360,
+ topDec/rad,az,el) + topDec/rad,az,el)
Az=az*rad Az=az*rad
El=El*rad El=El*rad
return return
end end

180
morse.f
View File

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

44
nchar.f
View File

@ -1,22 +1,22 @@
function nchar(c) function nchar(c)
C Convert ascii number, letter, or space to 0-36 for callsign packing. C Convert ascii number, letter, or space to 0-36 for callsign packing.
character c*1 character c*1
if(c.ge.'0' .and. c.le.'9') then if(c.ge.'0' .and. c.le.'9') then
n=ichar(c)-ichar('0') n=ichar(c)-ichar('0')
else if(c.ge.'A' .and. c.le.'Z') then else if(c.ge.'A' .and. c.le.'Z') then
n=ichar(c)-ichar('A') + 10 n=ichar(c)-ichar('A') + 10
else if(c.ge.'a' .and. c.le.'z') then else if(c.ge.'a' .and. c.le.'z') then
n=ichar(c)-ichar('a') + 10 n=ichar(c)-ichar('a') + 10
else if(c.ge.' ') then else if(c.ge.' ') then
n=36 n=36
else else
Print*,'Invalid character in callsign ',c,' ',ichar(c) Print*,'Invalid character in callsign ',c,' ',ichar(c)
stop stop
endif endif
nchar=n nchar=n
return return
end end

152
packcall.f
View File

@ -1,76 +1,76 @@
subroutine packcall(callsign,ncall,text) subroutine packcall(callsign,ncall,text)
C Pack a valid callsign into a 28-bit integer. C Pack a valid callsign into a 28-bit integer.
parameter (NBASE=37*36*10*27*27*27) parameter (NBASE=37*36*10*27*27*27)
character callsign*6,c*1,tmp*6 character callsign*6,c*1,tmp*6
logical text logical text
text=.false. text=.false.
C Work-around for Swaziland prefix: C Work-around for Swaziland prefix:
if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6) if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6)
if(callsign(1:3).eq.'CQ ') then if(callsign(1:3).eq.'CQ ') then
ncall=NBASE + 1 ncall=NBASE + 1
if(callsign(4:4).ge.'0' .and. callsign(4:4).le.'9' .and. 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(5:5).ge.'0' .and. callsign(5:5).le.'9' .and.
+ callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then + callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then
read(callsign(4:6),*) nfreq read(callsign(4:6),*) nfreq
ncall=NBASE + 3 + nfreq ncall=NBASE + 3 + nfreq
endif endif
return return
else if(callsign(1:4).eq.'QRZ ') then else if(callsign(1:4).eq.'QRZ ') then
ncall=NBASE + 2 ncall=NBASE + 2
return return
endif endif
tmp=' ' tmp=' '
if(callsign(3:3).ge.'0' .and. callsign(3:3).le.'9') then if(callsign(3:3).ge.'0' .and. callsign(3:3).le.'9') then
tmp=callsign tmp=callsign
else if(callsign(2:2).ge.'0' .and. callsign(2:2).le.'9') then else if(callsign(2:2).ge.'0' .and. callsign(2:2).le.'9') then
if(callsign(6:6).ne.' ') then if(callsign(6:6).ne.' ') then
text=.true. text=.true.
return return
endif endif
tmp=' '//callsign tmp=' '//callsign
else else
text=.true. text=.true.
return return
endif endif
do i=1,6 do i=1,6
c=tmp(i:i) c=tmp(i:i)
if(c.ge.'a' .and. c.le.'z') if(c.ge.'a' .and. c.le.'z')
+ tmp(i:i)=char(ichar(c)-ichar('a')+ichar('A')) + tmp(i:i)=char(ichar(c)-ichar('a')+ichar('A'))
enddo enddo
n1=0 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.'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 if(tmp(1:1).ge.'0' .and. tmp(1:1).le.'9') n1=1
n2=0 n2=0
if(tmp(2:2).ge.'A' .and. tmp(2:2).le.'Z') n2=1 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 if(tmp(2:2).ge.'0' .and. tmp(2:2).le.'9') n2=1
n3=0 n3=0
if(tmp(3:3).ge.'0' .and. tmp(3:3).le.'9') n3=1 if(tmp(3:3).ge.'0' .and. tmp(3:3).le.'9') n3=1
n4=0 n4=0
if((tmp(4:4).ge.'A'.and.tmp(4:4).le.'Z').or.tmp(4:4).eq.' ') n4=1 if((tmp(4:4).ge.'A'.and.tmp(4:4).le.'Z').or.tmp(4:4).eq.' ') n4=1
n5=0 n5=0
if((tmp(5:5).ge.'A'.and.tmp(5:5).le.'Z').or.tmp(5:5).eq.' ') n5=1 if((tmp(5:5).ge.'A'.and.tmp(5:5).le.'Z').or.tmp(5:5).eq.' ') n5=1
n6=0 n6=0
if((tmp(6:6).ge.'A'.and.tmp(6:6).le.'Z').or.tmp(6:6).eq.' ') n6=1 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 if(n1+n2+n3+n4+n5+n6 .ne. 6) then
text=.true. text=.true.
return return
endif endif
ncall=nchar(tmp(1:1)) ncall=nchar(tmp(1:1))
ncall=36*ncall+nchar(tmp(2:2)) ncall=36*ncall+nchar(tmp(2:2))
ncall=10*ncall+nchar(tmp(3:3)) ncall=10*ncall+nchar(tmp(3:3))
ncall=27*ncall+nchar(tmp(4:4))-10 ncall=27*ncall+nchar(tmp(4:4))-10
ncall=27*ncall+nchar(tmp(5:5))-10 ncall=27*ncall+nchar(tmp(5:5))-10
ncall=27*ncall+nchar(tmp(6:6))-10 ncall=27*ncall+nchar(tmp(6:6))-10
return return
end end

128
packdxcc.f
View File

@ -1,64 +1,64 @@
subroutine packdxcc(c,ng,ldxcc) subroutine packdxcc(c,ng,ldxcc)
character*3 c character*3 c
logical ldxcc logical ldxcc
parameter (NZ=303) parameter (NZ=303)
character*5 pfx(NZ) character*5 pfx(NZ)
data pfx/ data pfx/
+ '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ',
+ '3D2 ', '3DA ','3V ','3W ','3X ','3Y ', + '3D2 ', '3DA ','3V ','3W ','3X ','3Y ',
+ '4J ','4L ','4S ','4U1 ', '4W ', + '4J ','4L ','4S ','4U1 ', '4W ',
+ '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', + '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ',
+ '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', + '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ',
+ '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', + '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ',
+ '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', + '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ',
+ '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', + '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ',
+ 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', + 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ',
+ 'C3 ','C5 ','C6 ','C9 ','CE ','CE0 ', + 'C3 ','C5 ','C6 ','C9 ','CE ','CE0 ',
+ 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', + 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ',
+ 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', + 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ',
+ 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', + 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ',
+ 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', + 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ',
+ 'F ','FG ','FH ','FJ ','FK ', 'FM ','FO ', + 'F ','FG ','FH ','FJ ','FK ', 'FM ','FO ',
+ 'FP ','FR ', + 'FP ','FR ',
+ 'FT5 ', 'FW ','FY ','M ','MD ','MI ', + 'FT5 ', 'FW ','FY ','M ','MD ','MI ',
+ 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ',
+ 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ', + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ',
+ 'HL ','HM ','HP ','HR ','HS ','HV ','HZ ', + 'HL ','HM ','HP ','HR ','HS ','HV ','HZ ',
+ 'I ','IG9 ','IS ','IT9 ','J2 ','J3 ','J5 ','J6 ', + 'I ','IG9 ','IS ','IT9 ','J2 ','J3 ','J5 ','J6 ',
+ 'J7 ','J8 ','JA ','JD ', 'JT ','JW ', + 'J7 ','J8 ','JA ','JD ', 'JT ','JW ',
+ 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ',
+ 'KH4 ','KH5 ', 'KH6 ','KH7 ','KH8 ','KH9 ','KL ', + 'KH4 ','KH5 ', 'KH6 ','KH7 ','KH8 ','KH9 ','KL ',
+ 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', + 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ',
+ 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', + 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ',
+ 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', + 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ',
+ 'PJ2 ','PJ7 ','PY ','PY0 ', 'PZ ','R1F ', + 'PJ2 ','PJ7 ','PY ','PY0 ', 'PZ ','R1F ',
+ 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ',
+ 'ST ','SU ','SV ', 'SV5 ','SV9 ','T2 ','T30 ', + 'ST ','SU ','SV ', 'SV5 ','SV9 ','T2 ','T30 ',
+ 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ',
+ 'TA1 ','TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', + 'TA1 ','TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ',
+ 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', + 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ',
+ 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', + 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ',
+ 'V6 ','V7 ','V8 ','VE ','VK ','VK0 ', 'VK9 ', + 'V6 ','V7 ','V8 ','VE ','VK ','VK0 ', 'VK9 ',
+ 'VP2 ', + 'VP2 ',
+ 'VP5 ','VP6 ', 'VP8 ', + 'VP5 ','VP6 ', 'VP8 ',
+ 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', + 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ',
+ 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', + 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ',
+ 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', + 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ',
+ 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', + 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ',
+ 'ZD9 ','ZF ','ZK1 ', 'ZK2 ','ZK3 ','ZL ','ZL7 ', + 'ZD9 ','ZF ','ZK1 ', 'ZK2 ','ZK3 ','ZL ','ZL7 ',
+ 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 '/ + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 '/
ldxcc=.false. ldxcc=.false.
ng=0 ng=0
do i=1,NZ do i=1,NZ
if(pfx(i)(1:3).eq.c) go to 10 if(pfx(i)(1:3).eq.c) go to 10
enddo enddo
go to 20 go to 20
10 ng=180*180+61+i 10 ng=180*180+61+i
ldxcc=.true. ldxcc=.true.
20 return 20 return
end end

94
packgrid.f
View File

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

170
packmsg.f
View File

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

94
packtext.f
View File

@ -1,47 +1,47 @@
subroutine packtext(msg,nc1,nc2,nc3) subroutine packtext(msg,nc1,nc2,nc3)
parameter (MASK28=2**28 - 1) parameter (MASK28=2**28 - 1)
character*13 msg character*13 msg
character*44 c character*44 c
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/
nc1=0 nc1=0
nc2=0 nc2=0
nc3=0 nc3=0
do i=1,5 !First 5 characters in nc1 do i=1,5 !First 5 characters in nc1
do j=1,44 !Get character code do j=1,44 !Get character code
if(msg(i:i).eq.c(j:j)) go to 10 if(msg(i:i).eq.c(j:j)) go to 10
enddo enddo
j=37 j=37
10 j=j-1 !Codes should start at zero 10 j=j-1 !Codes should start at zero
nc1=42*nc1 + j nc1=42*nc1 + j
enddo enddo
do i=6,10 !Characters 6-10 in nc2 do i=6,10 !Characters 6-10 in nc2
do j=1,44 !Get character code do j=1,44 !Get character code
if(msg(i:i).eq.c(j:j)) go to 20 if(msg(i:i).eq.c(j:j)) go to 20
enddo enddo
j=37 j=37
20 j=j-1 !Codes should start at zero 20 j=j-1 !Codes should start at zero
nc2=42*nc2 + j nc2=42*nc2 + j
enddo enddo
do i=11,13 !Characters 11-13 in nc3 do i=11,13 !Characters 11-13 in nc3
do j=1,44 !Get character code do j=1,44 !Get character code
if(msg(i:i).eq.c(j:j)) go to 30 if(msg(i:i).eq.c(j:j)) go to 30
enddo enddo
j=37 j=37
30 j=j-1 !Codes should start at zero 30 j=j-1 !Codes should start at zero
nc3=42*nc3 + j nc3=42*nc3 + j
enddo enddo
C We now have used 17 bits in nc3. Must move one each to nc1 and nc2. C We now have used 17 bits in nc3. Must move one each to nc1 and nc2.
nc1=nc1+nc1 nc1=nc1+nc1
if(iand(nc3,32768).ne.0) nc1=nc1+1 if(iand(nc3,32768).ne.0) nc1=nc1+1
nc2=nc2+nc2 nc2=nc2+nc2
if(iand(nc3,65536).ne.0) nc2=nc2+1 if(iand(nc3,65536).ne.0) nc2=nc2+1
nc3=iand(nc3,32767) nc3=iand(nc3,32767)
return return
end end

26
pctile.f
View File

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

16
peakup.f
View File

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

100
pfx.f
View File

@ -1,50 +1,50 @@
parameter (NZ=338) !Total number of prefixes parameter (NZ=338) !Total number of prefixes
parameter (NZ2=12) !Total number of suffixes parameter (NZ2=12) !Total number of suffixes
character*1 sfx(NZ2) character*1 sfx(NZ2)
character*5 pfx(NZ) character*5 pfx(NZ)
data sfx/'P','0','1','2','3','4','5','6','7','8','9','A'/ data sfx/'P','0','1','2','3','4','5','6','7','8','9','A'/
data pfx/ data pfx/
+ '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ',
+ '3D2 ','3D2C ','3D2R ','3DA ','3V ','3W ','3X ','3Y ', + '3D2 ','3D2C ','3D2R ','3DA ','3V ','3W ','3X ','3Y ',
+ '3YB ','3YP ','4J ','4L ','4S ','4U1I ','4U1U ','4W ', + '3YB ','3YP ','4J ','4L ','4S ','4U1I ','4U1U ','4W ',
+ '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', + '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ',
+ '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', + '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ',
+ '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', + '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ',
+ '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', + '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ',
+ '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', + '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ',
+ 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', + 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ',
+ 'C3 ','C5 ','C6 ','C9 ','CE ','CE0X ','CE0Y ','CE0Z ', + 'C3 ','C5 ','C6 ','C9 ','CE ','CE0X ','CE0Y ','CE0Z ',
+ 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', + 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ',
+ 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', + 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ',
+ 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', + 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ',
+ 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', + 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ',
+ 'F ','FG ','FH ','FJ ','FK ','FKC ','FM ','FO ', + 'F ','FG ','FH ','FJ ','FK ','FKC ','FM ','FO ',
+ 'FOA ','FOC ','FOM ','FP ','FR ','FRG ','FRJ ','FRT ', + 'FOA ','FOC ','FOM ','FP ','FR ','FRG ','FRJ ','FRT ',
+ 'FT5W ','FT5X ','FT5Z ','FW ','FY ','M ','MD ','MI ', + 'FT5W ','FT5X ','FT5Z ','FW ','FY ','M ','MD ','MI ',
+ 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ',
+ 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0A ', + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0A ',
+ 'HK0M ','HL ','HM ','HP ','HR ','HS ','HV ','HZ ', + 'HK0M ','HL ','HM ','HP ','HR ','HS ','HV ','HZ ',
+ 'I ','IS ','IS0 ', 'J2 ','J3 ','J5 ','J6 ', + 'I ','IS ','IS0 ', 'J2 ','J3 ','J5 ','J6 ',
+ 'J7 ','J8 ','JA ','JDM ','JDO ','JT ','JW ', + 'J7 ','J8 ','JA ','JDM ','JDO ','JT ','JW ',
+ 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ',
+ 'KH4 ','KH5 ','KH5K ','KH6 ','KH7 ','KH8 ','KH9 ','KL ', + 'KH4 ','KH5 ','KH5K ','KH6 ','KH7 ','KH8 ','KH9 ','KL ',
+ 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', + 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ',
+ 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', + 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ',
+ 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', + 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ',
+ 'PJ2 ','PJ7 ','PY ','PY0F ','PT0S ','PY0T ','PZ ','R1F ', + 'PJ2 ','PJ7 ','PY ','PY0F ','PT0S ','PY0T ','PZ ','R1F ',
+ 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ',
+ 'ST ','SU ','SV ','SVA ','SV5 ','SV9 ','T2 ','T30 ', + 'ST ','SU ','SV ','SVA ','SV5 ','SV9 ','T2 ','T30 ',
+ 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ',
+ 'TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', + 'TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ',
+ 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', + 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ',
+ 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', + 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ',
+ 'V6 ','V7 ','V8 ','VE ','VK ','VK0H ','VK0M ','VK9C ', + 'V6 ','V7 ','V8 ','VE ','VK ','VK0H ','VK0M ','VK9C ',
+ 'VK9L ','VK9M ','VK9N ','VK9W ','VK9X ','VP2E ','VP2M ','VP2V ', + 'VK9L ','VK9M ','VK9N ','VK9W ','VK9X ','VP2E ','VP2M ','VP2V ',
+ 'VP5 ','VP6 ','VP6D ','VP8 ','VP8G ','VP8H ','VP8O ','VP8S ', + 'VP5 ','VP6 ','VP6D ','VP8 ','VP8G ','VP8H ','VP8O ','VP8S ',
+ 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', + 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ',
+ 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', + 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ',
+ 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', + 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ',
+ 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', + 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ',
+ 'ZD9 ','ZF ','ZK1N ','ZK1S ','ZK2 ','ZK3 ','ZL ','ZL7 ', + 'ZD9 ','ZF ','ZK1N ','ZK1S ','ZK2 ','ZK3 ','ZL ','ZL7 ',
+ 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 ','KC4 '/ + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 ','KC4 '/

56
pix2d65.f90
View File

@ -1,28 +1,28 @@
subroutine pix2d65(d2,jz) subroutine pix2d65(d2,jz)
! Compute data for green line in JT65 mode. ! Compute data for green line in JT65 mode.
integer*2 d2(jz) !Raw input data integer*2 d2(jz) !Raw input data
include 'gcom2.f90' include 'gcom2.f90'
sum=0. sum=0.
do i=1,jz do i=1,jz
sum=sum+d2(i) sum=sum+d2(i)
enddo enddo
nave=nint(sum/jz) nave=nint(sum/jz)
nadd=nint(53.0*11025.0/500.0) nadd=nint(53.0*11025.0/500.0)
ngreen=min(jz/nadd,500) ngreen=min(jz/nadd,500)
k=0 k=0
do i=1,ngreen do i=1,ngreen
sq=0. sq=0.
do n=1,nadd do n=1,nadd
k=k+1 k=k+1
d2(k)=d2(k)-nave d2(k)=d2(k)-nave
x=d2(k) x=d2(k)
sq=sq + x*x sq=sq + x*x
enddo enddo
green(i)=db(sq)-96.0 green(i)=db(sq)-96.0
enddo enddo
return return
end subroutine pix2d65 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) subroutine ps(dat,nfft,s)
parameter (NMAX=16384+2) parameter (NMAX=16384+2)
parameter (NHMAX=NMAX/2-1) parameter (NHMAX=NMAX/2-1)
real dat(nfft) real dat(nfft)
real s(NHMAX) real s(NHMAX)
real x(NMAX) real x(NMAX)
complex c(0:NHMAX) complex c(0:NHMAX)
equivalence (x,c) equivalence (x,c)
nh=nfft/2 nh=nfft/2
do i=1,nfft do i=1,nfft
x(i)=dat(i)/128.0 !### Why 128 ?? x(i)=dat(i)/128.0 !### Why 128 ??
enddo enddo
call xfft(x,nfft) call xfft(x,nfft)
fac=1.0/nfft fac=1.0/nfft
do i=1,nh do i=1,nh
s(i)=fac*(real(c(i))**2 + aimag(c(i))**2) s(i)=fac*(real(c(i))**2 + aimag(c(i))**2)
enddo enddo
return return
end end

12
resample.c
View File

@ -1,7 +1,8 @@
#include <stdio.h> #include <stdio.h>
#include <samplerate.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; SRC_DATA src_data;
int input_len; int input_len;
@ -10,7 +11,7 @@ int resample_( float din[], float dout[], double *samfac, int *jz)
double src_ratio; double src_ratio;
src_ratio=*samfac; src_ratio=*samfac;
input_len=*jz; input_len=*jzin;
output_len=(int) (input_len*src_ratio); output_len=(int) (input_len*src_ratio);
src_data.data_in=din; 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.input_frames=input_len;
src_data.output_frames=output_len; src_data.output_frames=output_len;
ierr=src_simple(&src_data,2,1); ierr=src_simple(&src_data,*conv_type,*channels);
*jz=output_len; *jzout=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);
*/
return ierr; return ierr;
} }

52
rfile2.f
View File

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

70
rs.h
View File

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

23
runqqq.F90
View File

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

62
set.f
View File

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

212
setup65.f
View File

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

380
short65.f
View File

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

82
slope.f
View File

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

26
smooth.f
View File

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

8
sort.f
View File

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

180
spec2d65.f
View File

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

570
ssort.f
View File

@ -1,285 +1,285 @@
subroutine ssort (x,y,n,kflag) subroutine ssort (x,y,n,kflag)
c***purpose sort an array and optionally make the same interchanges in c***purpose sort an array and optionally make the same interchanges in
c an auxiliary array. the array may be sorted in increasing c an auxiliary array. the array may be sorted in increasing
c or decreasing order. a slightly modified quicksort c or decreasing order. a slightly modified quicksort
c algorithm is used. c algorithm is used.
c c
c ssort sorts array x and optionally makes the same interchanges in 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 array y. the array x may be sorted in increasing order or
c decreasing order. a slightly modified quicksort algorithm is used. c decreasing order. a slightly modified quicksort algorithm is used.
c c
c description of parameters c description of parameters
c x - array of values to be sorted c x - array of values to be sorted
c y - array to be (optionally) carried along c y - array to be (optionally) carried along
c n - number of values in array x to be sorted c n - number of values in array x to be sorted
c kflag - control parameter c kflag - control parameter
c = 2 means sort x in increasing order and carry y along. 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 increasing order (ignoring y)
c = -1 means sort x in decreasing 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. c = -2 means sort x in decreasing order and carry y along.
integer kflag, n integer kflag, n
real x(n), y(n) real x(n), y(n)
real r, t, tt, tty, ty real r, t, tt, tty, ty
integer i, ij, j, k, kk, l, m, nn integer i, ij, j, k, kk, l, m, nn
integer il(21), iu(21) integer il(21), iu(21)
nn = n nn = n
if (nn .lt. 1) then if (nn .lt. 1) then
print*,'ssort: The number of sort elements is not positive.' print*,'ssort: The number of sort elements is not positive.'
print*,'ssort: n = ',nn,' kflag = ',kflag print*,'ssort: n = ',nn,' kflag = ',kflag
return return
endif endif
c c
kk = abs(kflag) kk = abs(kflag)
if (kk.ne.1 .and. kk.ne.2) then if (kk.ne.1 .and. kk.ne.2) then
print *, print *,
+ 'the sort control parameter, k, is not 2, 1, -1, or -2.' + 'the sort control parameter, k, is not 2, 1, -1, or -2.'
return return
endif endif
c c
c alter array x to get decreasing order if needed c alter array x to get decreasing order if needed
c c
if (kflag .le. -1) then if (kflag .le. -1) then
do 10 i=1,nn do 10 i=1,nn
x(i) = -x(i) x(i) = -x(i)
10 continue 10 continue
endif endif
c c
if (kk .eq. 2) go to 100 if (kk .eq. 2) go to 100
c c
c sort x only c sort x only
c c
m = 1 m = 1
i = 1 i = 1
j = nn j = nn
r = 0.375e0 r = 0.375e0
c c
20 if (i .eq. j) go to 60 20 if (i .eq. j) go to 60
if (r .le. 0.5898437e0) then if (r .le. 0.5898437e0) then
r = r+3.90625e-2 r = r+3.90625e-2
else else
r = r-0.21875e0 r = r-0.21875e0
endif endif
c c
30 k = i 30 k = i
c c
c select a central element of the array and save it in location t c select a central element of the array and save it in location t
c c
ij = i + int((j-i)*r) ij = i + int((j-i)*r)
t = x(ij) t = x(ij)
c c
c if first element of array is greater than t, interchange with t c if first element of array is greater than t, interchange with t
c c
if (x(i) .gt. t) then if (x(i) .gt. t) then
x(ij) = x(i) x(ij) = x(i)
x(i) = t x(i) = t
t = x(ij) t = x(ij)
endif endif
l = j l = j
c c
c if last element of array is less than than t, interchange with t c if last element of array is less than than t, interchange with t
c c
if (x(j) .lt. t) then if (x(j) .lt. t) then
x(ij) = x(j) x(ij) = x(j)
x(j) = t x(j) = t
t = x(ij) t = x(ij)
c c
c if first element of array is greater than t, interchange with t c if first element of array is greater than t, interchange with t
c c
if (x(i) .gt. t) then if (x(i) .gt. t) then
x(ij) = x(i) x(ij) = x(i)
x(i) = t x(i) = t
t = x(ij) t = x(ij)
endif endif
endif endif
c c
c find an element in the second half of the array which is smaller c find an element in the second half of the array which is smaller
c than t c than t
c c
40 l = l-1 40 l = l-1
if (x(l) .gt. t) go to 40 if (x(l) .gt. t) go to 40
c c
c find an element in the first half of the array which is greater c find an element in the first half of the array which is greater
c than t c than t
c c
50 k = k+1 50 k = k+1
if (x(k) .lt. t) go to 50 if (x(k) .lt. t) go to 50
c c
c interchange these elements c interchange these elements
c c
if (k .le. l) then if (k .le. l) then
tt = x(l) tt = x(l)
x(l) = x(k) x(l) = x(k)
x(k) = tt x(k) = tt
go to 40 go to 40
endif endif
c c
c save upper and lower subscripts of the array yet to be sorted c save upper and lower subscripts of the array yet to be sorted
c c
if (l-i .gt. j-k) then if (l-i .gt. j-k) then
il(m) = i il(m) = i
iu(m) = l iu(m) = l
i = k i = k
m = m+1 m = m+1
else else
il(m) = k il(m) = k
iu(m) = j iu(m) = j
j = l j = l
m = m+1 m = m+1
endif endif
go to 70 go to 70
c c
c begin again on another portion of the unsorted array c begin again on another portion of the unsorted array
c c
60 m = m-1 60 m = m-1
if (m .eq. 0) go to 190 if (m .eq. 0) go to 190
i = il(m) i = il(m)
j = iu(m) j = iu(m)
c c
70 if (j-i .ge. 1) go to 30 70 if (j-i .ge. 1) go to 30
if (i .eq. 1) go to 20 if (i .eq. 1) go to 20
i = i-1 i = i-1
c c
80 i = i+1 80 i = i+1
if (i .eq. j) go to 60 if (i .eq. j) go to 60
t = x(i+1) t = x(i+1)
if (x(i) .le. t) go to 80 if (x(i) .le. t) go to 80
k = i k = i
c c
90 x(k+1) = x(k) 90 x(k+1) = x(k)
k = k-1 k = k-1
if (t .lt. x(k)) go to 90 if (t .lt. x(k)) go to 90
x(k+1) = t x(k+1) = t
go to 80 go to 80
c c
c sort x and carry y along c sort x and carry y along
c c
100 m = 1 100 m = 1
i = 1 i = 1
j = nn j = nn
r = 0.375e0 r = 0.375e0
c c
110 if (i .eq. j) go to 150 110 if (i .eq. j) go to 150
if (r .le. 0.5898437e0) then if (r .le. 0.5898437e0) then
r = r+3.90625e-2 r = r+3.90625e-2
else else
r = r-0.21875e0 r = r-0.21875e0
endif endif
c c
120 k = i 120 k = i
c c
c select a central element of the array and save it in location t c select a central element of the array and save it in location t
c c
ij = i + int((j-i)*r) ij = i + int((j-i)*r)
t = x(ij) t = x(ij)
ty = y(ij) ty = y(ij)
c c
c if first element of array is greater than t, interchange with t c if first element of array is greater than t, interchange with t
c c
if (x(i) .gt. t) then if (x(i) .gt. t) then
x(ij) = x(i) x(ij) = x(i)
x(i) = t x(i) = t
t = x(ij) t = x(ij)
y(ij) = y(i) y(ij) = y(i)
y(i) = ty y(i) = ty
ty = y(ij) ty = y(ij)
endif endif
l = j l = j
c c
c if last element of array is less than t, interchange with t c if last element of array is less than t, interchange with t
c c
if (x(j) .lt. t) then if (x(j) .lt. t) then
x(ij) = x(j) x(ij) = x(j)
x(j) = t x(j) = t
t = x(ij) t = x(ij)
y(ij) = y(j) y(ij) = y(j)
y(j) = ty y(j) = ty
ty = y(ij) ty = y(ij)
c c
c if first element of array is greater than t, interchange with t c if first element of array is greater than t, interchange with t
c c
if (x(i) .gt. t) then if (x(i) .gt. t) then
x(ij) = x(i) x(ij) = x(i)
x(i) = t x(i) = t
t = x(ij) t = x(ij)
y(ij) = y(i) y(ij) = y(i)
y(i) = ty y(i) = ty
ty = y(ij) ty = y(ij)
endif endif
endif endif
c c
c find an element in the second half of the array which is smaller c find an element in the second half of the array which is smaller
c than t c than t
c c
130 l = l-1 130 l = l-1
if (x(l) .gt. t) go to 130 if (x(l) .gt. t) go to 130
c c
c find an element in the first half of the array which is greater c find an element in the first half of the array which is greater
c than t c than t
c c
140 k = k+1 140 k = k+1
if (x(k) .lt. t) go to 140 if (x(k) .lt. t) go to 140
c c
c interchange these elements c interchange these elements
c c
if (k .le. l) then if (k .le. l) then
tt = x(l) tt = x(l)
x(l) = x(k) x(l) = x(k)
x(k) = tt x(k) = tt
tty = y(l) tty = y(l)
y(l) = y(k) y(l) = y(k)
y(k) = tty y(k) = tty
go to 130 go to 130
endif endif
c c
c save upper and lower subscripts of the array yet to be sorted c save upper and lower subscripts of the array yet to be sorted
c c
if (l-i .gt. j-k) then if (l-i .gt. j-k) then
il(m) = i il(m) = i
iu(m) = l iu(m) = l
i = k i = k
m = m+1 m = m+1
else else
il(m) = k il(m) = k
iu(m) = j iu(m) = j
j = l j = l
m = m+1 m = m+1
endif endif
go to 160 go to 160
c c
c begin again on another portion of the unsorted array c begin again on another portion of the unsorted array
c c
150 m = m-1 150 m = m-1
if (m .eq. 0) go to 190 if (m .eq. 0) go to 190
i = il(m) i = il(m)
j = iu(m) j = iu(m)
c c
160 if (j-i .ge. 1) go to 120 160 if (j-i .ge. 1) go to 120
if (i .eq. 1) go to 110 if (i .eq. 1) go to 110
i = i-1 i = i-1
c c
170 i = i+1 170 i = i+1
if (i .eq. j) go to 150 if (i .eq. j) go to 150
t = x(i+1) t = x(i+1)
ty = y(i+1) ty = y(i+1)
if (x(i) .le. t) go to 170 if (x(i) .le. t) go to 170
k = i k = i
c c
180 x(k+1) = x(k) 180 x(k+1) = x(k)
y(k+1) = y(k) y(k+1) = y(k)
k = k-1 k = k-1
if (t .lt. x(k)) go to 180 if (t .lt. x(k)) go to 180
x(k+1) = t x(k+1) = t
y(k+1) = ty y(k+1) = ty
go to 170 go to 170
c c
c clean up c clean up
c c
190 if (kflag .le. -1) then 190 if (kflag .le. -1) then
do 200 i=1,nn do 200 i=1,nn
x(i) = -x(i) x(i) = -x(i)
200 continue 200 continue
endif endif
return return
end end

168
sun.f
View File

@ -1,84 +1,84 @@
subroutine sun(y,m,DD,UT,lon,lat,RA,Dec,LST,Az,El,mjd) subroutine sun(y,m,DD,UT,lon,lat,RA,Dec,LST,Az,El,mjd)
implicit none implicit none
integer y !Year integer y !Year
integer m !Month integer m !Month
integer DD !Day integer DD !Day
integer mjd !Modified Julian Date integer mjd !Modified Julian Date
real UT !UTC in hours real UT !UTC in hours
real RA,Dec !RA and Dec of sun real RA,Dec !RA and Dec of sun
C NB: Double caps here are single caps in the writeup. C NB: Double caps here are single caps in the writeup.
C Orbital elements of the Sun (also N=0, i=0, a=1): C Orbital elements of the Sun (also N=0, i=0, a=1):
real w !Argument of perihelion real w !Argument of perihelion
real e !Eccentricity real e !Eccentricity
real MM !Mean anomaly real MM !Mean anomaly
real Ls !Mean longitude real Ls !Mean longitude
C Other standard variables: C Other standard variables:
real v !True anomaly real v !True anomaly
real EE !Eccentric anomaly real EE !Eccentric anomaly
real ecl !Obliquity of the ecliptic real ecl !Obliquity of the ecliptic
real d !Ephemeris time argument in days real d !Ephemeris time argument in days
real r !Distance to sun, AU real r !Distance to sun, AU
real xv,yv !x and y coords in ecliptic real xv,yv !x and y coords in ecliptic
real lonsun !Ecliptic long and lat of sun real lonsun !Ecliptic long and lat of sun
real xs,ys !Ecliptic coords of sun (geocentric) real xs,ys !Ecliptic coords of sun (geocentric)
real xe,ye,ze !Equatorial coords of sun (geocentric) real xe,ye,ze !Equatorial coords of sun (geocentric)
real lon,lat real lon,lat
real GMST0,LST,HA real GMST0,LST,HA
real xx,yy,zz real xx,yy,zz
real xhor,yhor,zhor real xhor,yhor,zhor
real Az,El real Az,El
real rad real rad
data rad/57.2957795/ data rad/57.2957795/
C Time in days, with Jan 0, 2000 equal to 0.0: 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 d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + DD - 730530 + UT/24.0
mjd=d + 51543 mjd=d + 51543
ecl = 23.4393 - 3.563e-7 * d ecl = 23.4393 - 3.563e-7 * d
C Compute updated orbital elements for Sun: C Compute updated orbital elements for Sun:
w = 282.9404 + 4.70935e-5 * d w = 282.9404 + 4.70935e-5 * d
e = 0.016709 - 1.151e-9 * d e = 0.016709 - 1.151e-9 * d
MM = mod(356.0470d0 + 0.9856002585d0 * d + 360000.d0,360.d0) MM = mod(356.0470d0 + 0.9856002585d0 * d + 360000.d0,360.d0)
Ls = mod(w+MM+720.0,360.0) Ls = mod(w+MM+720.0,360.0)
EE = MM + e*rad*sin(MM/rad) * (1.0 + e*cos(M/rad)) 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)) EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.0 - e*cos(EE/rad))
xv = cos(EE/rad) - e xv = cos(EE/rad) - e
yv = sqrt(1.0-e*e) * sin(EE/rad) yv = sqrt(1.0-e*e) * sin(EE/rad)
v = rad*atan2(yv,xv) v = rad*atan2(yv,xv)
r = sqrt(xv*xv + yv*yv) r = sqrt(xv*xv + yv*yv)
lonsun = mod(v + w + 720.0,360.0) lonsun = mod(v + w + 720.0,360.0)
C Ecliptic coordinates of sun (rectangular): C Ecliptic coordinates of sun (rectangular):
xs = r * cos(lonsun/rad) xs = r * cos(lonsun/rad)
ys = r * sin(lonsun/rad) ys = r * sin(lonsun/rad)
C Equatorial coordinates of sun (rectangular): C Equatorial coordinates of sun (rectangular):
xe = xs xe = xs
ye = ys * cos(ecl/rad) ye = ys * cos(ecl/rad)
ze = ys * sin(ecl/rad) ze = ys * sin(ecl/rad)
C RA and Dec in degrees: C RA and Dec in degrees:
RA = rad*atan2(ye,xe) RA = rad*atan2(ye,xe)
Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye)) Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye))
GMST0 = (Ls + 180.0)/15.0 GMST0 = (Ls + 180.0)/15.0
LST = mod(GMST0+UT+lon/15.0+48.0,24.0) !LST in hours LST = mod(GMST0+UT+lon/15.0+48.0,24.0) !LST in hours
HA = 15.0*LST - RA !HA in degrees HA = 15.0*LST - RA !HA in degrees
xx = cos(HA/rad)*cos(Dec/rad) xx = cos(HA/rad)*cos(Dec/rad)
yy = sin(HA/rad)*cos(Dec/rad) yy = sin(HA/rad)*cos(Dec/rad)
zz = sin(Dec/rad) zz = sin(Dec/rad)
xhor = xx*sin(lat/rad) - zz*cos(lat/rad) xhor = xx*sin(lat/rad) - zz*cos(lat/rad)
yhor = yy yhor = yy
zhor = xx*cos(lat/rad) + zz*sin(lat/rad) zhor = xx*cos(lat/rad) + zz*sin(lat/rad)
Az = mod(rad*atan2(yhor,xhor) + 180.0 + 360.0,360.0) Az = mod(rad*atan2(yhor,xhor) + 180.0 + 360.0,360.0)
El = rad*asin(zhor) El = rad*asin(zhor)
return return
end 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) subroutine toxyz(alpha,delta,r,vec)
implicit real*8 (a-h,o-z) implicit real*8 (a-h,o-z)
real*8 vec(3) real*8 vec(3)
vec(1)=r*cos(delta)*cos(alpha) vec(1)=r*cos(delta)*cos(alpha)
vec(2)=r*cos(delta)*sin(alpha) vec(2)=r*cos(delta)*sin(alpha)
vec(3)=r*sin(delta) vec(3)=r*sin(delta)
return return
end end
subroutine fromxyz(vec,alpha,delta,r) subroutine fromxyz(vec,alpha,delta,r)
implicit real*8 (a-h,o-z) implicit real*8 (a-h,o-z)
real*8 vec(3) real*8 vec(3)
data twopi/6.283185307d0/ data twopi/6.283185307d0/
r=sqrt(vec(1)**2 + vec(2)**2 + vec(3)**2) r=sqrt(vec(1)**2 + vec(2)**2 + vec(3)**2)
alpha=atan2(vec(2),vec(1)) alpha=atan2(vec(2),vec(1))
if(alpha.lt.0.d0) alpha=alpha+twopi if(alpha.lt.0.d0) alpha=alpha+twopi
delta=asin(vec(3)/r) delta=asin(vec(3)/r)
return return
end end

70
unpackcall.f
View File

@ -1,35 +1,35 @@
subroutine unpackcall(ncall,word) subroutine unpackcall(ncall,word)
character word*12,c*37 character word*12,c*37
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/ data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/
n=ncall n=ncall
word='......' word='......'
if(n.ge.262177560) go to 999 !Plain text message ... if(n.ge.262177560) go to 999 !Plain text message ...
i=mod(n,27)+11 i=mod(n,27)+11
word(6:6)=c(i:i) word(6:6)=c(i:i)
n=n/27 n=n/27
i=mod(n,27)+11 i=mod(n,27)+11
word(5:5)=c(i:i) word(5:5)=c(i:i)
n=n/27 n=n/27
i=mod(n,27)+11 i=mod(n,27)+11
word(4:4)=c(i:i) word(4:4)=c(i:i)
n=n/27 n=n/27
i=mod(n,10)+1 i=mod(n,10)+1
word(3:3)=c(i:i) word(3:3)=c(i:i)
n=n/10 n=n/10
i=mod(n,36)+1 i=mod(n,36)+1
word(2:2)=c(i:i) word(2:2)=c(i:i)
n=n/36 n=n/36
i=n+1 i=n+1
word(1:1)=c(i:i) word(1:1)=c(i:i)
do i=1,4 do i=1,4
if(word(i:i).ne.' ') go to 10 if(word(i:i).ne.' ') go to 10
enddo enddo
go to 999 go to 999
10 word=word(i:) 10 word=word(i:)
999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:) 999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:)
return return
end end

64
unpackgrid.f
View File

@ -1,32 +1,32 @@
subroutine unpackgrid(ng,grid) subroutine unpackgrid(ng,grid)
parameter (NGBASE=180*180) parameter (NGBASE=180*180)
character grid*4,grid6*6 character grid*4,grid6*6
grid=' ' grid=' '
if(ng.ge.32400) go to 10 if(ng.ge.32400) go to 10
dlat=mod(ng,180)-90 dlat=mod(ng,180)-90
dlong=(ng/180)*2 - 180 + 2 dlong=(ng/180)*2 - 180 + 2
call deg2grid(dlong,dlat,grid6) call deg2grid(dlong,dlat,grid6)
grid=grid6 grid=grid6
go to 100 go to 100
10 n=ng-NGBASE-1 10 n=ng-NGBASE-1
if(n.ge.1 .and.n.le.30) then if(n.ge.1 .and.n.le.30) then
write(grid,1012) -n write(grid,1012) -n
1012 format(i3.2) 1012 format(i3.2)
else if(n.ge.31 .and.n.le.60) then else if(n.ge.31 .and.n.le.60) then
n=n-30 n=n-30
write(grid,1022) -n write(grid,1022) -n
1022 format('R',i3.2) 1022 format('R',i3.2)
else if(n.eq.61) then else if(n.eq.61) then
grid='RO' grid='RO'
else if(n.eq.62) then else if(n.eq.62) then
grid='RRR' grid='RRR'
else if(n.eq.63) then else if(n.eq.63) then
grid='73' grid='73'
endif endif
100 return 100 return
end end

178
unpackmsg.f
View File

@ -1,89 +1,89 @@
subroutine unpackmsg(dat,msg) subroutine unpackmsg(dat,msg)
parameter (NBASE=37*36*10*27*27*27) parameter (NBASE=37*36*10*27*27*27)
parameter (NGBASE=180*180) parameter (NGBASE=180*180)
integer dat(12) integer dat(12)
character c1*12,c2*12,grid*4,msg*22,grid6*6 character c1*12,c2*12,grid*4,msg*22,grid6*6
logical cqnnn logical cqnnn
cqnnn=.false. cqnnn=.false.
nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+ nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+
+ ishft(dat(4),4) + iand(ishft(dat(5),-2),15) + ishft(dat(4),4) + iand(ishft(dat(5),-2),15)
nc2=ishft(iand(dat(5),3),26) + ishft(dat(6),20) + nc2=ishft(iand(dat(5),3),26) + ishft(dat(6),20) +
+ ishft(dat(7),14) + ishft(dat(8),8) + ishft(dat(9),2) + + ishft(dat(7),14) + ishft(dat(8),8) + ishft(dat(9),2) +
+ iand(ishft(dat(10),-4),3) + iand(ishft(dat(10),-4),3)
ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12) ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12)
if(ng.gt.32768) then if(ng.gt.32768) then
call unpacktext(nc1,nc2,ng,msg) call unpacktext(nc1,nc2,ng,msg)
go to 100 go to 100
endif endif
if(nc1.lt.NBASE) then if(nc1.lt.NBASE) then
call unpackcall(nc1,c1) call unpackcall(nc1,c1)
else else
c1='......' c1='......'
if(nc1.eq.NBASE+1) c1='CQ ' if(nc1.eq.NBASE+1) c1='CQ '
if(nc1.eq.NBASE+2) c1='QRZ ' if(nc1.eq.NBASE+2) c1='QRZ '
nfreq=nc1-NBASE-3 nfreq=nc1-NBASE-3
if(nfreq.ge.0 .and. nfreq.le.999) then if(nfreq.ge.0 .and. nfreq.le.999) then
write(c1,1002) nfreq write(c1,1002) nfreq
1002 format('CQ ',i3.3) 1002 format('CQ ',i3.3)
cqnnn=.true. cqnnn=.true.
endif endif
endif endif
if(nc2.lt.NBASE) then if(nc2.lt.NBASE) then
call unpackcall(nc2,c2) call unpackcall(nc2,c2)
else else
c2='......' c2='......'
endif endif
call unpackgrid(ng,grid) call unpackgrid(ng,grid)
grid6=grid//'ma' grid6=grid//'ma'
call grid2k(grid6,k) call grid2k(grid6,k)
if(k.ge.1 .and. k.le.450) call getpfx2(k,c1) if(k.ge.1 .and. k.le.450) call getpfx2(k,c1)
if(k.ge.451 .and. k.le.900) call getpfx2(k,c2) if(k.ge.451 .and. k.le.900) call getpfx2(k,c2)
i=index(c1,char(0)) i=index(c1,char(0))
if(i.ge.3) c1=c1(1:i-1)//' ' if(i.ge.3) c1=c1(1:i-1)//' '
i=index(c2,char(0)) i=index(c2,char(0))
if(i.ge.3) c2=c2(1:i-1)//' ' if(i.ge.3) c2=c2(1:i-1)//' '
msg=' ' msg=' '
j=0 j=0
if(cqnnn) then if(cqnnn) then
msg=c1//' ' msg=c1//' '
j=7 !### ??? ### j=7 !### ??? ###
go to 10 go to 10
endif endif
do i=1,12 do i=1,12
j=j+1 j=j+1
msg(j:j)=c1(i:i) msg(j:j)=c1(i:i)
if(c1(i:i).eq.' ') go to 10 if(c1(i:i).eq.' ') go to 10
enddo enddo
j=j+1 j=j+1
msg(j:j)=' ' msg(j:j)=' '
10 do i=1,12 10 do i=1,12
if(j.le.21) j=j+1 if(j.le.21) j=j+1
msg(j:j)=c2(i:i) msg(j:j)=c2(i:i)
if(c2(i:i).eq.' ') go to 20 if(c2(i:i).eq.' ') go to 20
enddo enddo
j=j+1 j=j+1
msg(j:j)=' ' msg(j:j)=' '
20 if(k.eq.0) then 20 if(k.eq.0) then
do i=1,4 do i=1,4
if(j.le.21) j=j+1 if(j.le.21) j=j+1
msg(j:j)=grid(i:i) msg(j:j)=grid(i:i)
enddo enddo
j=j+1 j=j+1
msg(j:j)=' ' msg(j:j)=' '
endif endif
100 return 100 return
end end

70
unpacktext.f
View File

@ -1,35 +1,35 @@
subroutine unpacktext(nc1,nc2,nc3,msg) subroutine unpacktext(nc1,nc2,nc3,msg)
character*22 msg character*22 msg
character*44 c character*44 c
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/
nc3=iand(nc3,32767) !Remove the "plain text" bit nc3=iand(nc3,32767) !Remove the "plain text" bit
if(iand(nc1,1).ne.0) nc3=nc3+32768 if(iand(nc1,1).ne.0) nc3=nc3+32768
nc1=nc1/2 nc1=nc1/2
if(iand(nc2,1).ne.0) nc3=nc3+65536 if(iand(nc2,1).ne.0) nc3=nc3+65536
nc2=nc2/2 nc2=nc2/2
do i=5,1,-1 do i=5,1,-1
j=mod(nc1,42)+1 j=mod(nc1,42)+1
msg(i:i)=c(j:j) msg(i:i)=c(j:j)
nc1=nc1/42 nc1=nc1/42
enddo enddo
do i=10,6,-1 do i=10,6,-1
j=mod(nc2,42)+1 j=mod(nc2,42)+1
msg(i:i)=c(j:j) msg(i:i)=c(j:j)
nc2=nc2/42 nc2=nc2/42
enddo enddo
do i=13,11,-1 do i=13,11,-1
j=mod(nc3,42)+1 j=mod(nc3,42)+1
msg(i:i)=c(j:j) msg(i:i)=c(j:j)
nc3=nc3/42 nc3=nc3/42
enddo enddo
msg(14:22) = ' ' msg(14:22) = ' '
return return
end end

300
wsjtgen.F90
View File

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

168
xcor.f
View File

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

24
xfft.f
View File

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

368
xfft2.f
View File

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