From c43bfde2edd37e095d790bfc46191dead5f4b6b9 Mon Sep 17 00:00:00 2001 From: Joe Taylor Date: Thu, 11 Jan 2007 21:25:52 +0000 Subject: [PATCH] First good compile with map65a running inside map65. git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/map65@334 ab8295b8-cf94-4d9e-aec4-7959e3be5d79 --- GeoDist.f | 204 ++--- MoonDop.f | 170 ++-- afc65.f | 154 ++-- astropak.f | 28 +- avecom.h | 8 +- azdist.f | 216 ++--- bzap.f | 134 +-- char.h | 114 +-- chkmsg.f | 62 +- coord.f | 74 +- db.f | 10 +- dcoord.f | 78 +- decode1a.f | 124 +++ decode65b.f | 59 ++ deep65.F | 63 +- deg2grid.f | 60 +- demod64a.f | 142 +-- detect.f | 58 +- display.f | 50 ++ dot.f | 22 +- encode65.f | 26 +- extract.f | 27 +- fftw3.f | 128 +-- filbig.f | 104 +++ fivehz.F90 | 540 ++++++------ fivehz.h | 10 +- flat1.f | 60 +- flat2.f | 56 +- flatten.f | 210 ++--- four2.f | 700 +++++++-------- four2a.f | 156 ++-- ftn_init.F90 | 9 + ftsky.f | 48 +- gcom1.f90 | 102 +-- gcom2.f90 | 200 ++--- gcom3.f90 | 40 +- gcom4.f90 | 20 +- gen65.f | 164 ++-- gencwid.f | 72 +- gentone.f | 26 +- geocentric.f | 34 +- getpfx1.f | 90 +- getpfx2.f | 48 +- getsnr.f | 70 +- graycode.f | 20 +- grid2deg.f | 80 +- grid2k.f | 24 +- indexx.f | 38 +- int.h | 114 +-- interleave63.f | 50 +- k2grid.f | 24 +- limit.f | 62 +- lpf1.f | 134 +-- map65.py | 52 +- map65a.f | 288 +++++++ moon2.f | 334 +++---- morse.f | 180 ++-- nchar.f | 44 +- packcall.f | 152 ++-- packdxcc.f | 128 +-- packgrid.f | 94 +- packmsg.f | 170 ++-- packtext.f | 94 +- pctile.f | 26 +- peakup.f | 16 +- pfx.f | 100 +-- pix2d65.f90 | 56 +- portaudio.h | 2246 ++++++++++++++++++++++++------------------------ prcom.h | 2 +- ps.f | 46 +- resample.c | 12 +- rfile2.f | 52 +- rs.h | 70 +- runqqq.F90 | 23 - samplerate.h | 392 ++++----- set.f | 62 +- setup65.f | 212 ++--- short65.f | 380 ++++---- slope.f | 82 +- smooth.f | 26 +- sort.f | 8 +- spec2d65.f | 180 ++-- ssort.f | 570 ++++++------ sun.f | 168 ++-- symspec.f | 67 ++ toxyz.f | 50 +- unpackcall.f | 70 +- unpackgrid.f | 64 +- unpackmsg.f | 178 ++-- unpacktext.f | 70 +- wsjtgen.F90 | 300 +++---- xcor.f | 168 ++-- xfft.f | 24 +- xfft2.f | 368 ++++---- 94 files changed, 6836 insertions(+), 6104 deletions(-) create mode 100644 decode1a.f create mode 100644 decode65b.f create mode 100644 display.f create mode 100644 filbig.f create mode 100644 map65a.f create mode 100644 symspec.f diff --git a/GeoDist.f b/GeoDist.f index 3de97c22a..e896ded90 100644 --- a/GeoDist.f +++ b/GeoDist.f @@ -1,102 +1,102 @@ - subroutine geodist(Eplat, Eplon, Stlat, Stlon, - + Az, Baz, Dist) - implicit none - real eplat, eplon, stlat, stlon, az, baz, dist - -C JHT: In actual fact, I use the first two arguments for "My Location", -C the second two for "His location"; West longitude is positive. - -c -c -c Taken directly from: -c Thomas, P.D., 1970, Spheroidal geodesics, reference systems, -c & local geometry, U.S. Naval Oceanographic Office SP-138, -c 165 pp. -c -c assumes North Latitude and East Longitude are positive -c -c EpLat, EpLon = End point Lat/Long -c Stlat, Stlon = Start point lat/long -c Az, BAz = direct & reverse azimuith -c Dist = Dist (km); Deg = central angle, discarded -c - - real BOA, F, P1R, P2R, L1R, L2R, DLR, T1R, T2R, TM, - + DTM, STM, CTM, SDTM,CDTM, KL, KK, SDLMR, L, - + CD, DL, SD, T, U, V, D, X, E, Y, A, FF64, TDLPM, - + HAPBR, HAMBR, A1M2, A2M1 - - real AL,BL,D2R,Pi2 - - data AL/6378206.4/ ! Clarke 1866 ellipsoid - data BL/6356583.8/ -c real pi /3.14159265359/ - data D2R/0.01745329251994/ ! degrees to radians conversion factor - data Pi2/6.28318530718/ - - BOA = BL/AL - F = 1.0 - BOA -c convert st/end pts to radians - P1R = Eplat * D2R - P2R = Stlat * D2R - L1R = Eplon * D2R - L2R = StLon * D2R - DLR = L2R - L1R ! DLR = Delta Long in Rads - T1R = ATan(BOA * Tan(P1R)) - T2R = ATan(BOA * Tan(P2R)) - TM = (T1R + T2R) / 2.0 - DTM = (T2R - T1R) / 2.0 - STM = Sin(TM) - CTM = Cos(TM) - SDTM = Sin(DTM) - CDTM = Cos(DTM) - KL = STM * CDTM - KK = SDTM * CTM - SDLMR = Sin(DLR/2.0) - L = SDTM * SDTM + SDLMR * SDLMR * (CDTM * CDTM - STM * STM) - CD = 1.0 - 2.0 * L - DL = ACos(CD) - SD = Sin(DL) - T = DL/SD - U = 2.0 * KL * KL / (1.0 - L) - V = 2.0 * KK * KK / L - D = 4.0 * T * T - X = U + V - E = -2.0 * CD - Y = U - V - A = -D * E - FF64 = F * F / 64.0 - Dist = AL*SD*(T -(F/4.0)*(T*X-Y)+FF64*(X*(A+(T-(A+E) - + /2.0)*X)+Y*(-2.0*D+E*Y)+D*X*Y))/1000.0 - TDLPM = Tan((DLR+(-((E*(4.0-X)+2.0*Y)*((F/2.0)*T+FF64* - + (32.0*T+(A-20.0*T)*X-2.0*(D+2.0)*Y))/4.0)*Tan(DLR)))/2.0) - HAPBR = ATan2(SDTM,(CTM*TDLPM)) - HAMBR = Atan2(CDTM,(STM*TDLPM)) - A1M2 = Pi2 + HAMBR - HAPBR - A2M1 = Pi2 - HAMBR - HAPBR - -1 If ((A1M2 .ge. 0.0) .AND. (A1M2 .lt. Pi2)) GOTO 5 - If (A1M2 .lt. Pi2) GOTO 4 - A1M2 = A1M2 - Pi2 - GOTO 1 -4 A1M2 = A1M2 + Pi2 - GOTO 1 -c -c all of this gens the proper az, baz (forward and back azimuth) -c - -5 If ((A2M1 .ge. 0.0) .AND. (A2M1 .lt. Pi2)) GOTO 9 - If (A2M1 .lt. Pi2) GOTO 8 - A2M1 = A2M1 - Pi2 - GOTO 5 -8 A2M1 = A2M1 + Pi2 - GOTO 5 - -9 Az = A1M2 / D2R - BAZ = A2M1 / D2R -c -c Fix the mirrored coords here. -c - az = 360.0 - az - baz = 360.0 - baz - end + subroutine geodist(Eplat, Eplon, Stlat, Stlon, + + Az, Baz, Dist) + implicit none + real eplat, eplon, stlat, stlon, az, baz, dist + +C JHT: In actual fact, I use the first two arguments for "My Location", +C the second two for "His location"; West longitude is positive. + +c +c +c Taken directly from: +c Thomas, P.D., 1970, Spheroidal geodesics, reference systems, +c & local geometry, U.S. Naval Oceanographic Office SP-138, +c 165 pp. +c +c assumes North Latitude and East Longitude are positive +c +c EpLat, EpLon = End point Lat/Long +c Stlat, Stlon = Start point lat/long +c Az, BAz = direct & reverse azimuith +c Dist = Dist (km); Deg = central angle, discarded +c + + real BOA, F, P1R, P2R, L1R, L2R, DLR, T1R, T2R, TM, + + DTM, STM, CTM, SDTM,CDTM, KL, KK, SDLMR, L, + + CD, DL, SD, T, U, V, D, X, E, Y, A, FF64, TDLPM, + + HAPBR, HAMBR, A1M2, A2M1 + + real AL,BL,D2R,Pi2 + + data AL/6378206.4/ ! Clarke 1866 ellipsoid + data BL/6356583.8/ +c real pi /3.14159265359/ + data D2R/0.01745329251994/ ! degrees to radians conversion factor + data Pi2/6.28318530718/ + + BOA = BL/AL + F = 1.0 - BOA +c convert st/end pts to radians + P1R = Eplat * D2R + P2R = Stlat * D2R + L1R = Eplon * D2R + L2R = StLon * D2R + DLR = L2R - L1R ! DLR = Delta Long in Rads + T1R = ATan(BOA * Tan(P1R)) + T2R = ATan(BOA * Tan(P2R)) + TM = (T1R + T2R) / 2.0 + DTM = (T2R - T1R) / 2.0 + STM = Sin(TM) + CTM = Cos(TM) + SDTM = Sin(DTM) + CDTM = Cos(DTM) + KL = STM * CDTM + KK = SDTM * CTM + SDLMR = Sin(DLR/2.0) + L = SDTM * SDTM + SDLMR * SDLMR * (CDTM * CDTM - STM * STM) + CD = 1.0 - 2.0 * L + DL = ACos(CD) + SD = Sin(DL) + T = DL/SD + U = 2.0 * KL * KL / (1.0 - L) + V = 2.0 * KK * KK / L + D = 4.0 * T * T + X = U + V + E = -2.0 * CD + Y = U - V + A = -D * E + FF64 = F * F / 64.0 + Dist = AL*SD*(T -(F/4.0)*(T*X-Y)+FF64*(X*(A+(T-(A+E) + + /2.0)*X)+Y*(-2.0*D+E*Y)+D*X*Y))/1000.0 + TDLPM = Tan((DLR+(-((E*(4.0-X)+2.0*Y)*((F/2.0)*T+FF64* + + (32.0*T+(A-20.0*T)*X-2.0*(D+2.0)*Y))/4.0)*Tan(DLR)))/2.0) + HAPBR = ATan2(SDTM,(CTM*TDLPM)) + HAMBR = Atan2(CDTM,(STM*TDLPM)) + A1M2 = Pi2 + HAMBR - HAPBR + A2M1 = Pi2 - HAMBR - HAPBR + +1 If ((A1M2 .ge. 0.0) .AND. (A1M2 .lt. Pi2)) GOTO 5 + If (A1M2 .lt. Pi2) GOTO 4 + A1M2 = A1M2 - Pi2 + GOTO 1 +4 A1M2 = A1M2 + Pi2 + GOTO 1 +c +c all of this gens the proper az, baz (forward and back azimuth) +c + +5 If ((A2M1 .ge. 0.0) .AND. (A2M1 .lt. Pi2)) GOTO 9 + If (A2M1 .lt. Pi2) GOTO 8 + A2M1 = A2M1 - Pi2 + GOTO 5 +8 A2M1 = A2M1 + Pi2 + GOTO 5 + +9 Az = A1M2 / D2R + BAZ = A2M1 / D2R +c +c Fix the mirrored coords here. +c + az = 360.0 - az + baz = 360.0 - baz + end diff --git a/MoonDop.f b/MoonDop.f index a71f141c7..e9959b1ca 100644 --- a/MoonDop.f +++ b/MoonDop.f @@ -1,85 +1,85 @@ - subroutine MoonDop(nyear,month,nday,uth4,lon4,lat4,RAMoon4, - + DecMoon4,LST4,HA4,AzMoon4,ElMoon4,ldeg4,bdeg4,vr4,dist4) - - implicit real*8 (a-h,o-z) - real*4 uth4 !UT in hours - real*4 lon4 !West longitude, degrees - real*4 lat4 !Latitude, degrees - real*4 RAMoon4 !Topocentric RA of moon, hours - real*4 DecMoon4 !Topocentric Dec of Moon, degrees - real*4 LST4 !Locat sidereal time, hours - real*4 HA4 !Local Hour angle, degrees - real*4 AzMoon4 !Topocentric Azimuth of moon, degrees - real*4 ElMoon4 !Topocentric Elevation of moon, degrees - real*4 ldeg4 !Galactic longitude of moon, degrees - real*4 bdeg4 !Galactic latitude of moon, degrees - real*4 vr4 !Radial velocity of moon wrt obs, km/s - real*4 dist4 !Echo time, seconds - - real*8 LST - real*8 RME(6) !Vector from Earth center to Moon - real*8 RAE(6) !Vector from Earth center to Obs - real*8 RMA(6) !Vector from Obs to Moon - real*8 pvsun(6) - real*8 rme0(6) - real*8 lrad - logical km,bary - - common/stcomx/km,bary,pvsun - data rad/57.2957795130823d0/,twopi/6.28310530717959d0/ - - pi=0.5d0*twopi - km=.true. - dlat=lat4/rad - dlong1=lon4/rad - elev1=200.d0 - call geocentric(dlat,elev1,dlat1,erad1) - - dt=100.d0 !For numerical derivative, in seconds - UT=uth4 - -C NB: geodetic latitude used here, but geocentric latitude used when -C determining Earth-rotation contribution to Doppler. - - call moon2(nyear,month,nDay,UT-dt/3600.d0,dlong1*rad,dlat*rad, - + RA,Dec,topRA,topDec,LST,HA,Az0,El0,dist) - call toxyz(RA/rad,Dec/rad,dist,rme0) !Convert to rectangular coords - - call moon2(nyear,month,nDay,UT,dlong1*rad,dlat*rad, - + RA,Dec,topRA,topDec,LST,HA,Az,El,dist) - call toxyz(RA/rad,Dec/rad,dist,rme) !Convert to rectangular coords - - phi=LST*twopi/24.d0 - call toxyz(phi,dlat1,erad1,rae) !Gencentric numbers used here! - radps=twopi/(86400.d0/1.002737909d0) - rae(4)=-rae(2)*radps !Vel of Obs wrt Earth center - rae(5)=rae(1)*radps - rae(6)=0.d0 - - do i=1,3 - rme(i+3)=(rme(i)-rme0(i))/dt - rma(i)=rme(i)-rae(i) - rma(i+3)=rme(i+3)-rae(i+3) - enddo - - call fromxyz(rma,alpha1,delta1,dtopo0) !Get topocentric coords - vr=dot(rma(4),rma)/dtopo0 - - rarad=RA/rad - decrad=Dec/rad - call dcoord(4.635594495d0,-0.504691042d0,3.355395488d0, - + 0.478220215d0,rarad,decrad,lrad,brad) - - RAMoon4=topRA - DecMoon4=topDec - LST4=LST - HA4=HA - AzMoon4=Az - ElMoon4=El - ldeg4=lrad*rad - bdeg4=brad*rad - vr4=vr - dist4=dist - - return - end + subroutine MoonDop(nyear,month,nday,uth4,lon4,lat4,RAMoon4, + + DecMoon4,LST4,HA4,AzMoon4,ElMoon4,ldeg4,bdeg4,vr4,dist4) + + implicit real*8 (a-h,o-z) + real*4 uth4 !UT in hours + real*4 lon4 !West longitude, degrees + real*4 lat4 !Latitude, degrees + real*4 RAMoon4 !Topocentric RA of moon, hours + real*4 DecMoon4 !Topocentric Dec of Moon, degrees + real*4 LST4 !Locat sidereal time, hours + real*4 HA4 !Local Hour angle, degrees + real*4 AzMoon4 !Topocentric Azimuth of moon, degrees + real*4 ElMoon4 !Topocentric Elevation of moon, degrees + real*4 ldeg4 !Galactic longitude of moon, degrees + real*4 bdeg4 !Galactic latitude of moon, degrees + real*4 vr4 !Radial velocity of moon wrt obs, km/s + real*4 dist4 !Echo time, seconds + + real*8 LST + real*8 RME(6) !Vector from Earth center to Moon + real*8 RAE(6) !Vector from Earth center to Obs + real*8 RMA(6) !Vector from Obs to Moon + real*8 pvsun(6) + real*8 rme0(6) + real*8 lrad + logical km,bary + + common/stcomx/km,bary,pvsun + data rad/57.2957795130823d0/,twopi/6.28310530717959d0/ + + pi=0.5d0*twopi + km=.true. + dlat=lat4/rad + dlong1=lon4/rad + elev1=200.d0 + call geocentric(dlat,elev1,dlat1,erad1) + + dt=100.d0 !For numerical derivative, in seconds + UT=uth4 + +C NB: geodetic latitude used here, but geocentric latitude used when +C determining Earth-rotation contribution to Doppler. + + call moon2(nyear,month,nDay,UT-dt/3600.d0,dlong1*rad,dlat*rad, + + RA,Dec,topRA,topDec,LST,HA,Az0,El0,dist) + call toxyz(RA/rad,Dec/rad,dist,rme0) !Convert to rectangular coords + + call moon2(nyear,month,nDay,UT,dlong1*rad,dlat*rad, + + RA,Dec,topRA,topDec,LST,HA,Az,El,dist) + call toxyz(RA/rad,Dec/rad,dist,rme) !Convert to rectangular coords + + phi=LST*twopi/24.d0 + call toxyz(phi,dlat1,erad1,rae) !Gencentric numbers used here! + radps=twopi/(86400.d0/1.002737909d0) + rae(4)=-rae(2)*radps !Vel of Obs wrt Earth center + rae(5)=rae(1)*radps + rae(6)=0.d0 + + do i=1,3 + rme(i+3)=(rme(i)-rme0(i))/dt + rma(i)=rme(i)-rae(i) + rma(i+3)=rme(i+3)-rae(i+3) + enddo + + call fromxyz(rma,alpha1,delta1,dtopo0) !Get topocentric coords + vr=dot(rma(4),rma)/dtopo0 + + rarad=RA/rad + decrad=Dec/rad + call dcoord(4.635594495d0,-0.504691042d0,3.355395488d0, + + 0.478220215d0,rarad,decrad,lrad,brad) + + RAMoon4=topRA + DecMoon4=topDec + LST4=LST + HA4=HA + AzMoon4=Az + ElMoon4=El + ldeg4=lrad*rad + bdeg4=brad*rad + vr4=vr + dist4=dist + + return + end diff --git a/afc65.f b/afc65.f index f55fb5f34..1a9b3b42e 100644 --- a/afc65.f +++ b/afc65.f @@ -1,77 +1,77 @@ - subroutine afc65(s2,ipk,lagpk,flip,ftrack) - - real s2(1024,320) - real s(-10:10) - real x(63),y(63),z(63) - real ftrack(126) - include 'prcom.h' - data s/21*0.0/ - - k=0 - u=1.0 - u1=0.2 - fac=sqrt(1.0/u1) - do j=1,126 - if(pr(j)*flip .lt. 0.0) go to 10 - k=k+1 - m=2*j-1+lagpk - if(m.lt.1 .or. m.gt.320) go to 10 - smax=0. - do i=-10,10 - s(i)=(1.0-u)*s(i) + u*s2(ipk+i,m) - if(s(i).gt.smax) then - smax=s(i) - ipk2=i - endif - enddo - u=u1 - dfx=0.0 - sig=100.0*fac*smax - if(ipk2.gt.-10 .and. ipk2.lt.10 .and. (sig.gt.2.0)) - + call peakup(s(ipk2-1),s(ipk2),s(ipk2+1),dfx) - dfx=ipk2+dfx - x(k)=j - y(k)=dfx - z(k)=sig - if(z(k).lt.1.5 .or. abs(y(k)).gt.5.5) then - y(k)=0. - z(k)=0. - endif - 10 enddo - - zlim=5.0 - yfit=0. - k=0 - do j=1,126 - if(pr(j)*flip .lt. 0.0) go to 30 - k=k+1 - sumy=0. - sumz=0. - if(k.ge.1) then - sumz=z(k) - sumy=sumy+z(k)*y(k) - endif - do n=1,30 - m=k-n - if(m.ge.1) then - sumz=sumz+z(m) - sumy=sumy+z(m)*y(m) - endif - m=k+n - if(m.le.63) then - sumz=sumz+z(m) - sumy=sumy+z(m)*y(m) - endif - if(sumz.ge.zlim) go to 20 - enddo - n=30 - 20 yfit=0. - if(sumz.gt.0.0) yfit=sumy/sumz - - 30 ftrack(j)=yfit*2.691650 - enddo - if(ftrack(1).eq.99.0) ftrack(1)=ftrack(2) - - return - end - + subroutine afc65(s2,ipk,lagpk,flip,ftrack) + + real s2(1024,320) + real s(-10:10) + real x(63),y(63),z(63) + real ftrack(126) + include 'prcom.h' + data s/21*0.0/ + + k=0 + u=1.0 + u1=0.2 + fac=sqrt(1.0/u1) + do j=1,126 + if(pr(j)*flip .lt. 0.0) go to 10 + k=k+1 + m=2*j-1+lagpk + if(m.lt.1 .or. m.gt.320) go to 10 + smax=0. + do i=-10,10 + s(i)=(1.0-u)*s(i) + u*s2(ipk+i,m) + if(s(i).gt.smax) then + smax=s(i) + ipk2=i + endif + enddo + u=u1 + dfx=0.0 + sig=100.0*fac*smax + if(ipk2.gt.-10 .and. ipk2.lt.10 .and. (sig.gt.2.0)) + + call peakup(s(ipk2-1),s(ipk2),s(ipk2+1),dfx) + dfx=ipk2+dfx + x(k)=j + y(k)=dfx + z(k)=sig + if(z(k).lt.1.5 .or. abs(y(k)).gt.5.5) then + y(k)=0. + z(k)=0. + endif + 10 enddo + + zlim=5.0 + yfit=0. + k=0 + do j=1,126 + if(pr(j)*flip .lt. 0.0) go to 30 + k=k+1 + sumy=0. + sumz=0. + if(k.ge.1) then + sumz=z(k) + sumy=sumy+z(k)*y(k) + endif + do n=1,30 + m=k-n + if(m.ge.1) then + sumz=sumz+z(m) + sumy=sumy+z(m)*y(m) + endif + m=k+n + if(m.le.63) then + sumz=sumz+z(m) + sumy=sumy+z(m)*y(m) + endif + if(sumz.ge.zlim) go to 20 + enddo + n=30 + 20 yfit=0. + if(sumz.gt.0.0) yfit=sumy/sumz + + 30 ftrack(j)=yfit*2.691650 + enddo + if(ftrack(1).eq.99.0) ftrack(1)=ftrack(2) + + return + end + diff --git a/astropak.f b/astropak.f index b1e004e3e..d28781e4b 100644 --- a/astropak.f +++ b/astropak.f @@ -1,14 +1,14 @@ -! include 'astro.f' - include 'azdist.f' - include 'coord.f' - include 'dcoord.f' - include 'deg2grid.f' - include 'dot.f' - include 'ftsky.f' - include 'geocentric.f' - include 'GeoDist.f' - include 'grid2deg.f' - include 'moon2.f' - include 'MoonDop.f' - include 'sun.f' - include 'toxyz.f' +! include 'astro.f' + include 'azdist.f' + include 'coord.f' + include 'dcoord.f' + include 'deg2grid.f' + include 'dot.f' + include 'ftsky.f' + include 'geocentric.f' + include 'GeoDist.f' + include 'grid2deg.f' + include 'moon2.f' + include 'MoonDop.f' + include 'sun.f' + include 'toxyz.f' diff --git a/avecom.h b/avecom.h index 6ac8fe244..6cc378569 100644 --- a/avecom.h +++ b/avecom.h @@ -1,4 +1,4 @@ - parameter (MAXAVE=120) - common/ave/ppsave(64,63,MAXAVE),nflag(MAXAVE),nsave, - + iseg(MAXAVE) - + parameter (MAXAVE=120) + common/ave/ppsave(64,63,MAXAVE),nflag(MAXAVE),nsave, + + iseg(MAXAVE) + diff --git a/azdist.f b/azdist.f index 94abe9f5d..1927faf58 100644 --- a/azdist.f +++ b/azdist.f @@ -1,108 +1,108 @@ - subroutine azdist(MyGrid,HisGrid,utch,nAz,nEl,nDmiles,nDkm, - + nHotAz,nHotABetter) - -C Old calling sequence: -c subroutine azdist(MyGrid,HisGrid,UTChours,Az,Dmiles,Dkm,El, -c + HotA,HotB,HotABetter) - - character*6 MyGrid,HisGrid,mygrid0,hisgrid0 - real*8 utch,utch0 - logical HotABetter,IamEast - real eltab(22),daztab(22) - data eltab/18.,15.,13.,11.,9.,8.,7.,6.,5.3,4.7,4.,3.3,2.7, - + 2.,1.5,1.,0.8,0.6,0.4,0.2,0.0,0.0/ - data daztab/21.,18.,16.,15.,14.,13.,12.,11.,10.7,10.3,10., - + 10.,10.,10.,10.,10.,10.,9.,9.,9.,8.,8./ - data mygrid0/" "/,hisgrid0/" "/,utch0/-999.d0/ - save - - if(MyGrid.eq.HisGrid) then - naz=0 - nel=0 - ndmiles=0 - ndkm=0 - nhotaz=0 - nhotabetter=1 - go to 999 - endif - - if(mygrid.eq.mygrid0 .and. hisgrid.eq.hisgrid0 .and. - + abs(utch-utch0).lt.0.1666667d0) go to 900 - utch0=utch - mygrid0=mygrid - hisgrid0=hisgrid - utchours=utch - - if(MyGrid(5:5).eq.' ') MyGrid(5:5)='m' - if(MyGrid(6:6).eq.' ') MyGrid(6:6)='m' - if(HisGrid(5:5).eq.' ') HisGrid(5:5)='m' - if(HisGrid(6:6).eq.' ') HisGrid(6:6)='m' - - if(MyGrid.eq.HisGrid) then - Az=0. - Dmiles=0. - Dkm=0.0 - El=0. - HotA=0. - HotB=0. - HotABetter=.true. - go to 900 - endif - - call grid2deg(MyGrid,dlong1,dlat1) - call grid2deg(HisGrid,dlong2,dlat2) - call geodist(dlat1,dlong1,dlat2,dlong2,Az,Baz,Dkm) - - j=nint(Dkm/100.0)-4 - if(j.lt.1) j=1 - if(j.gt.21)j=21 - ndkm=Dkm/100 - d1=100.0*ndkm - u=(Dkm-d1)/100.0 - El=eltab(j) + u * (eltab(j+1)-eltab(j)) - daz=daztab(j) + u * (daztab(j+1)-daztab(j)) - Dmiles=Dkm/1.609344 - - tmid=mod(UTChours-0.5*(dlong1+dlong2)/15.0+48.0,24.0) - IamEast=.false. - if(dlong1.lt.dlong2) IamEast=.true. - if(dlong1.eq.dlong2 .and. dlat1.gt.dlat2) IamEast=.false. - azEast=baz - if(IamEast) azEast=az - if((azEast.ge.45.0 .and. azEast.lt.135.0) .or. - + (azEast.ge.225.0 .and. azEast.lt.315.0)) then -C The path will be taken as "east-west". - HotABetter=.true. - if(abs(tmid-6.0).lt.6.0) HotABetter=.false. - if((dlat1+dlat2)/2.0 .lt. 0.0) HotABetter=.not.HotABetter - else -C The path will be taken as "north-south". - HotABetter=.false. - if(abs(tmid-12.0).lt.6.0) HotABetter=.true. - endif - if(IamEast) then - HotA = Az - daz - HotB = Az + daz - else - HotA = Az + daz - HotB = Az - daz - endif - if(HotA.lt.0.0) HotA=HotA+360.0 - if(HotA.gt.360.0) HotA=HotA-360.0 - if(HotB.lt.0.0) HotB=HotB+360.0 - if(HotB.gt.360.0) HotB=HotB-360.0 - - 900 continue - naz=nint(Az) - nel=nint(el) - nDmiles=nint(Dmiles) - nDkm=nint(Dkm) - nHotAz=nint(HotB) - nHotABetter=0 - if(HotABetter) then - nHotAz=nint(HotA) - nHotABetter=1 - endif - - 999 return - end + subroutine azdist(MyGrid,HisGrid,utch,nAz,nEl,nDmiles,nDkm, + + nHotAz,nHotABetter) + +C Old calling sequence: +c subroutine azdist(MyGrid,HisGrid,UTChours,Az,Dmiles,Dkm,El, +c + HotA,HotB,HotABetter) + + character*6 MyGrid,HisGrid,mygrid0,hisgrid0 + real*8 utch,utch0 + logical HotABetter,IamEast + real eltab(22),daztab(22) + data eltab/18.,15.,13.,11.,9.,8.,7.,6.,5.3,4.7,4.,3.3,2.7, + + 2.,1.5,1.,0.8,0.6,0.4,0.2,0.0,0.0/ + data daztab/21.,18.,16.,15.,14.,13.,12.,11.,10.7,10.3,10., + + 10.,10.,10.,10.,10.,10.,9.,9.,9.,8.,8./ + data mygrid0/" "/,hisgrid0/" "/,utch0/-999.d0/ + save + + if(MyGrid.eq.HisGrid) then + naz=0 + nel=0 + ndmiles=0 + ndkm=0 + nhotaz=0 + nhotabetter=1 + go to 999 + endif + + if(mygrid.eq.mygrid0 .and. hisgrid.eq.hisgrid0 .and. + + abs(utch-utch0).lt.0.1666667d0) go to 900 + utch0=utch + mygrid0=mygrid + hisgrid0=hisgrid + utchours=utch + + if(MyGrid(5:5).eq.' ') MyGrid(5:5)='m' + if(MyGrid(6:6).eq.' ') MyGrid(6:6)='m' + if(HisGrid(5:5).eq.' ') HisGrid(5:5)='m' + if(HisGrid(6:6).eq.' ') HisGrid(6:6)='m' + + if(MyGrid.eq.HisGrid) then + Az=0. + Dmiles=0. + Dkm=0.0 + El=0. + HotA=0. + HotB=0. + HotABetter=.true. + go to 900 + endif + + call grid2deg(MyGrid,dlong1,dlat1) + call grid2deg(HisGrid,dlong2,dlat2) + call geodist(dlat1,dlong1,dlat2,dlong2,Az,Baz,Dkm) + + j=nint(Dkm/100.0)-4 + if(j.lt.1) j=1 + if(j.gt.21)j=21 + ndkm=Dkm/100 + d1=100.0*ndkm + u=(Dkm-d1)/100.0 + El=eltab(j) + u * (eltab(j+1)-eltab(j)) + daz=daztab(j) + u * (daztab(j+1)-daztab(j)) + Dmiles=Dkm/1.609344 + + tmid=mod(UTChours-0.5*(dlong1+dlong2)/15.0+48.0,24.0) + IamEast=.false. + if(dlong1.lt.dlong2) IamEast=.true. + if(dlong1.eq.dlong2 .and. dlat1.gt.dlat2) IamEast=.false. + azEast=baz + if(IamEast) azEast=az + if((azEast.ge.45.0 .and. azEast.lt.135.0) .or. + + (azEast.ge.225.0 .and. azEast.lt.315.0)) then +C The path will be taken as "east-west". + HotABetter=.true. + if(abs(tmid-6.0).lt.6.0) HotABetter=.false. + if((dlat1+dlat2)/2.0 .lt. 0.0) HotABetter=.not.HotABetter + else +C The path will be taken as "north-south". + HotABetter=.false. + if(abs(tmid-12.0).lt.6.0) HotABetter=.true. + endif + if(IamEast) then + HotA = Az - daz + HotB = Az + daz + else + HotA = Az + daz + HotB = Az - daz + endif + if(HotA.lt.0.0) HotA=HotA+360.0 + if(HotA.gt.360.0) HotA=HotA-360.0 + if(HotB.lt.0.0) HotB=HotB+360.0 + if(HotB.gt.360.0) HotB=HotB-360.0 + + 900 continue + naz=nint(Az) + nel=nint(el) + nDmiles=nint(Dmiles) + nDkm=nint(Dkm) + nHotAz=nint(HotB) + nHotABetter=0 + if(HotABetter) then + nHotAz=nint(HotA) + nHotABetter=1 + endif + + 999 return + end diff --git a/bzap.f b/bzap.f index 4ac36d9f0..fc60e93c6 100644 --- a/bzap.f +++ b/bzap.f @@ -1,67 +1,67 @@ - subroutine bzap(dat,jz,nadd,mode,fzap) - - parameter (NMAX=1024*1024) - parameter (NMAXH=NMAX) - real dat(jz),x(NMAX) - real fzap(200) - complex c(NMAX) - equivalence (x,c) - - xn=log(float(jz))/log(2.0) - n=xn - if((xn-n).gt.0.) n=n+1 - nfft=2**n - nh=nfft/nadd - nq=nh/2 - do i=1,jz - x(i)=dat(i) - enddo - if(nfft.gt.jz) call zero(x(jz+1),nfft-jz) - - call xfft(x,nfft) - -C This is a kludge: - df=11025.0/(nadd*nfft) - if(mode.eq.2) df=11025.0/(2*nadd*nfft) - - tol=10. - itol=nint(2.0/df) - do izap=1,200 - if(fzap(izap).eq.0.0) goto 10 - ia=(fzap(izap)-tol)/df - ib=(fzap(izap)+tol)/df - smax=0. - do i=ia+1,ib+1 - s=real(c(i))**2 + aimag(c(i))**2 - if(s.gt.smax) then - smax=s - ipk=i - endif - enddo - fzap(izap)=df*(ipk-1) - - do i=ipk-itol,ipk+itol - c(i)=0. - enddo - enddo - - 10 ia=70/df - do i=1,ia - c(i)=0. - enddo - ia=2700.0/df - do i=ia,nq+1 - c(i)=0. - enddo - do i=2,nq - c(nh+2-i)=conjg(c(i)) - enddo - - call four2a(c,nh,1,1,-1) - fac=1.0/nfft - do i=1,jz/nadd - dat(i)=fac*x(i) - enddo - - return - end + subroutine bzap(dat,jz,nadd,mode,fzap) + + parameter (NMAX=1024*1024) + parameter (NMAXH=NMAX) + real dat(jz),x(NMAX) + real fzap(200) + complex c(NMAX) + equivalence (x,c) + + xn=log(float(jz))/log(2.0) + n=xn + if((xn-n).gt.0.) n=n+1 + nfft=2**n + nh=nfft/nadd + nq=nh/2 + do i=1,jz + x(i)=dat(i) + enddo + if(nfft.gt.jz) call zero(x(jz+1),nfft-jz) + + call xfft(x,nfft) + +C This is a kludge: + df=11025.0/(nadd*nfft) + if(mode.eq.2) df=11025.0/(2*nadd*nfft) + + tol=10. + itol=nint(2.0/df) + do izap=1,200 + if(fzap(izap).eq.0.0) goto 10 + ia=(fzap(izap)-tol)/df + ib=(fzap(izap)+tol)/df + smax=0. + do i=ia+1,ib+1 + s=real(c(i))**2 + aimag(c(i))**2 + if(s.gt.smax) then + smax=s + ipk=i + endif + enddo + fzap(izap)=df*(ipk-1) + + do i=ipk-itol,ipk+itol + c(i)=0. + enddo + enddo + + 10 ia=70/df + do i=1,ia + c(i)=0. + enddo + ia=2700.0/df + do i=ia,nq+1 + c(i)=0. + enddo + do i=2,nq + c(nh+2-i)=conjg(c(i)) + enddo + + call four2a(c,nh,1,1,-1) + fac=1.0/nfft + do i=1,jz/nadd + dat(i)=fac*x(i) + enddo + + return + end diff --git a/char.h b/char.h index cc477ec7c..469dd8624 100644 --- a/char.h +++ b/char.h @@ -1,57 +1,57 @@ -/* Include file to configure the RS codec for character symbols - * - * Copyright 2002, Phil Karn, KA9Q - * May be used under the terms of the GNU General Public License (GPL) - */ -#define DTYPE unsigned char - -/* Reed-Solomon codec control block */ -struct rs { - int mm; /* Bits per symbol */ - int nn; /* Symbols per block (= (1<= rs->nn) { - x -= rs->nn; - x = (x >> rs->mm) + (x & rs->nn); - } - return x; -} -#define MODNN(x) modnn(rs,x) - -#define MM (rs->mm) -#define NN (rs->nn) -#define ALPHA_TO (rs->alpha_to) -#define INDEX_OF (rs->index_of) -#define GENPOLY (rs->genpoly) -#define NROOTS (rs->nroots) -#define FCR (rs->fcr) -#define PRIM (rs->prim) -#define IPRIM (rs->iprim) -#define PAD (rs->pad) -#define A0 (NN) - -#define ENCODE_RS encode_rs_char -#define DECODE_RS decode_rs_char -#define INIT_RS init_rs_char -#define FREE_RS free_rs_char - -void ENCODE_RS(void *p,DTYPE *data,DTYPE *parity); -int DECODE_RS(void *p,DTYPE *data,int *eras_pos,int no_eras); -void *INIT_RS(int symsize,int gfpoly,int fcr, - int prim,int nroots,int pad); -void FREE_RS(void *p); - - - - - +/* Include file to configure the RS codec for character symbols + * + * Copyright 2002, Phil Karn, KA9Q + * May be used under the terms of the GNU General Public License (GPL) + */ +#define DTYPE unsigned char + +/* Reed-Solomon codec control block */ +struct rs { + int mm; /* Bits per symbol */ + int nn; /* Symbols per block (= (1<= rs->nn) { + x -= rs->nn; + x = (x >> rs->mm) + (x & rs->nn); + } + return x; +} +#define MODNN(x) modnn(rs,x) + +#define MM (rs->mm) +#define NN (rs->nn) +#define ALPHA_TO (rs->alpha_to) +#define INDEX_OF (rs->index_of) +#define GENPOLY (rs->genpoly) +#define NROOTS (rs->nroots) +#define FCR (rs->fcr) +#define PRIM (rs->prim) +#define IPRIM (rs->iprim) +#define PAD (rs->pad) +#define A0 (NN) + +#define ENCODE_RS encode_rs_char +#define DECODE_RS decode_rs_char +#define INIT_RS init_rs_char +#define FREE_RS free_rs_char + +void ENCODE_RS(void *p,DTYPE *data,DTYPE *parity); +int DECODE_RS(void *p,DTYPE *data,int *eras_pos,int no_eras); +void *INIT_RS(int symsize,int gfpoly,int fcr, + int prim,int nroots,int pad); +void FREE_RS(void *p); + + + + + diff --git a/chkmsg.f b/chkmsg.f index 7f19da4fb..ea67f0b26 100644 --- a/chkmsg.f +++ b/chkmsg.f @@ -1,31 +1,31 @@ - subroutine chkmsg(message,cok,nspecial,flip) - - character message*22,cok*3 - - nspecial=0 - flip=1.0 - cok=" " - - do i=22,1,-1 - if(message(i:i).ne.' ') go to 10 - enddo - i=22 - - 10 if(i.ge.11 .and. (message(i-3:i).eq.' OOO') .or. - + (message(20:22).eq.' OO')) then - cok='OOO' - flip=-1.0 - if(message(20:22).eq.' OO') then - message=message(1:19) - else - message=message(1:i-4) - endif - endif - -! if(message(1:3).eq.'ATT') nspecial=1 - if(message(1:2).eq.'RO') nspecial=2 - if(message(1:3).eq.'RRR') nspecial=3 - if(message(1:2).eq.'73') nspecial=4 - - return - end + subroutine chkmsg(message,cok,nspecial,flip) + + character message*22,cok*3 + + nspecial=0 + flip=1.0 + cok=" " + + do i=22,1,-1 + if(message(i:i).ne.' ') go to 10 + enddo + i=22 + + 10 if(i.ge.11 .and. (message(i-3:i).eq.' OOO') .or. + + (message(20:22).eq.' OO')) then + cok='OOO' + flip=-1.0 + if(message(20:22).eq.' OO') then + message=message(1:19) + else + message=message(1:i-4) + endif + endif + +! if(message(1:3).eq.'ATT') nspecial=1 + if(message(1:2).eq.'RO') nspecial=2 + if(message(1:3).eq.'RRR') nspecial=3 + if(message(1:2).eq.'73') nspecial=4 + + return + end diff --git a/coord.f b/coord.f index 696ca9c26..a7641350e 100644 --- a/coord.f +++ b/coord.f @@ -1,37 +1,37 @@ - SUBROUTINE COORD(A0,B0,AP,BP,A1,B1,A2,B2) - -C Examples: -C 1. From ha,dec to az,el: -C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el) -C 2. From az,el to ha,dec: -C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec) -C 3. From ra,dec to l,b -C call coord(4.635594495,-0.504691042,3.355395488,0.478220215, -C ra,dec,l,b) -C 4. From l,b to ra,dec -C call coord(1.705981071d0,-1.050357016d0,2.146800277d0, -C 0.478220215d0,l,b,ra,dec) -C 5. From ecliptic latitude (eb) and longitude (el) to ra, dec: -C call coord(0.e0,0.e0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb) - - SB0=sin(B0) - CB0=cos(B0) - SBP=sin(BP) - CBP=cos(BP) - SB1=sin(B1) - CB1=cos(B1) - SB2=SBP*SB1 + CBP*CB1*cos(AP-A1) - CB2=SQRT(1.e0-SB2**2) - B2=atan(SB2/CB2) - SAA=sin(AP-A1)*CB1/CB2 - CAA=(SB1-SB2*SBP)/(CB2*CBP) - CBB=SB0/CBP - SBB=sin(AP-A0)*CB0 - SA2=SAA*CBB-CAA*SBB - CA2=CAA*CBB+SAA*SBB - IF(CA2.LE.0.e0) TA2O2=(1.e0-CA2)/SA2 - IF(CA2.GT.0.e0) TA2O2=SA2/(1.e0+CA2) - A2=2.e0*atan(TA2O2) - IF(A2.LT.0.e0) A2=A2+6.2831853 - RETURN - END + SUBROUTINE COORD(A0,B0,AP,BP,A1,B1,A2,B2) + +C Examples: +C 1. From ha,dec to az,el: +C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el) +C 2. From az,el to ha,dec: +C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec) +C 3. From ra,dec to l,b +C call coord(4.635594495,-0.504691042,3.355395488,0.478220215, +C ra,dec,l,b) +C 4. From l,b to ra,dec +C call coord(1.705981071d0,-1.050357016d0,2.146800277d0, +C 0.478220215d0,l,b,ra,dec) +C 5. From ecliptic latitude (eb) and longitude (el) to ra, dec: +C call coord(0.e0,0.e0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb) + + SB0=sin(B0) + CB0=cos(B0) + SBP=sin(BP) + CBP=cos(BP) + SB1=sin(B1) + CB1=cos(B1) + SB2=SBP*SB1 + CBP*CB1*cos(AP-A1) + CB2=SQRT(1.e0-SB2**2) + B2=atan(SB2/CB2) + SAA=sin(AP-A1)*CB1/CB2 + CAA=(SB1-SB2*SBP)/(CB2*CBP) + CBB=SB0/CBP + SBB=sin(AP-A0)*CB0 + SA2=SAA*CBB-CAA*SBB + CA2=CAA*CBB+SAA*SBB + IF(CA2.LE.0.e0) TA2O2=(1.e0-CA2)/SA2 + IF(CA2.GT.0.e0) TA2O2=SA2/(1.e0+CA2) + A2=2.e0*atan(TA2O2) + IF(A2.LT.0.e0) A2=A2+6.2831853 + RETURN + END diff --git a/db.f b/db.f index c487e8595..92e6df59b 100644 --- a/db.f +++ b/db.f @@ -1,5 +1,5 @@ - real function db(x) - db=-99.0 - if(x.gt.1.259e-10) db=10.0*log10(x) - return - end + real function db(x) + db=-99.0 + if(x.gt.1.259e-10) db=10.0*log10(x) + return + end diff --git a/dcoord.f b/dcoord.f index 6fbab9232..aed49450e 100644 --- a/dcoord.f +++ b/dcoord.f @@ -1,39 +1,39 @@ - SUBROUTINE DCOORD(A0,B0,AP,BP,A1,B1,A2,B2) - - implicit real*8 (a-h,o-z) -C Examples: -C 1. From ha,dec to az,el: -C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el) -C 2. From az,el to ha,dec: -C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec) -C 3. From ra,dec to l,b -C call coord(4.635594495,-0.504691042,3.355395488,0.478220215, -C ra,dec,l,b) -C 4. From l,b to ra,dec -C call coord(1.705981071d0,-1.050357016d0,2.146800277d0, -C 0.478220215d0,l,b,ra,dec) -C 5. From ecliptic latitude (eb) and longitude (el) to ra, dec: -C call coord(0.d0,0.d0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb) - - SB0=sin(B0) - CB0=cos(B0) - SBP=sin(BP) - CBP=cos(BP) - SB1=sin(B1) - CB1=cos(B1) - SB2=SBP*SB1 + CBP*CB1*cos(AP-A1) - CB2=SQRT(1.D0-SB2**2) - B2=atan(SB2/CB2) - SAA=sin(AP-A1)*CB1/CB2 - CAA=(SB1-SB2*SBP)/(CB2*CBP) - CBB=SB0/CBP - SBB=sin(AP-A0)*CB0 - SA2=SAA*CBB-CAA*SBB - CA2=CAA*CBB+SAA*SBB - IF(CA2.LE.0.D0) TA2O2=(1.D0-CA2)/SA2 - IF(CA2.GT.0.D0) TA2O2=SA2/(1.D0+CA2) - A2=2.D0*atan(TA2O2) - IF(A2.LT.0.D0) A2=A2+6.2831853071795864D0 - - RETURN - END + SUBROUTINE DCOORD(A0,B0,AP,BP,A1,B1,A2,B2) + + implicit real*8 (a-h,o-z) +C Examples: +C 1. From ha,dec to az,el: +C call coord(pi,pio2-lat,0.,lat,ha,dec,az,el) +C 2. From az,el to ha,dec: +C call coord(pi,pio2-lat,0.,lat,az,el,ha,dec) +C 3. From ra,dec to l,b +C call coord(4.635594495,-0.504691042,3.355395488,0.478220215, +C ra,dec,l,b) +C 4. From l,b to ra,dec +C call coord(1.705981071d0,-1.050357016d0,2.146800277d0, +C 0.478220215d0,l,b,ra,dec) +C 5. From ecliptic latitude (eb) and longitude (el) to ra, dec: +C call coord(0.d0,0.d0,-pio2,pio2-23.443*pi/180,ra,dec,el,eb) + + SB0=sin(B0) + CB0=cos(B0) + SBP=sin(BP) + CBP=cos(BP) + SB1=sin(B1) + CB1=cos(B1) + SB2=SBP*SB1 + CBP*CB1*cos(AP-A1) + CB2=SQRT(1.D0-SB2**2) + B2=atan(SB2/CB2) + SAA=sin(AP-A1)*CB1/CB2 + CAA=(SB1-SB2*SBP)/(CB2*CBP) + CBB=SB0/CBP + SBB=sin(AP-A0)*CB0 + SA2=SAA*CBB-CAA*SBB + CA2=CAA*CBB+SAA*SBB + IF(CA2.LE.0.D0) TA2O2=(1.D0-CA2)/SA2 + IF(CA2.GT.0.D0) TA2O2=SA2/(1.D0+CA2) + A2=2.D0*atan(TA2O2) + IF(A2.LT.0.D0) A2=A2+6.2831853071795864D0 + + RETURN + END diff --git a/decode1a.f b/decode1a.f new file mode 100644 index 000000000..f55134730 --- /dev/null +++ b/decode1a.f @@ -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 diff --git a/decode65b.f b/decode65b.f new file mode 100644 index 000000000..bbb60d790 --- /dev/null +++ b/decode65b.f @@ -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 diff --git a/deep65.F b/deep65.F index 7231e9c9d..832fc813a 100644 --- a/deep65.F +++ b/deep65.F @@ -5,18 +5,17 @@ real s3(64,63) character callsign*12,grid*4,message*22,hisgrid*6,c*1,ceme*3 character*12 mycall,hiscall + character mycall0*12,hiscall0*12,hisgrid0*6 character*22 decoded character*22 testmsg(2*MAXCALLS + 2 + MAXRPT) character*15 callgrid(MAXCALLS) character*180 line character*4 rpt(MAXRPT) integer ncode(63,2*MAXCALLS + 2 + MAXRPT) + integer nflip(2*MAXCALLS + 2 + MAXRPT) + integer istat23(13) real pp(2*MAXCALLS + 2 + MAXRPT) - common/tmp9/ mrs(63),mrs2(63) -#ifdef Win32 -C This prevents some optimizations that break this subroutine. - volatile p1,p2,bias -#endif + common/mrscom/ mrs(63),mrs2(63) data neme0/-99/ data rpt/'-01','-02','-03','-04','-05', @@ -32,7 +31,13 @@ C This prevents some optimizations that break this subroutine. + 'R-21','R-22','R-23','R-24','R-25', + 'R-26','R-27','R-28','R-29','R-30', + 'RO','RRR','73'/ + save +! call fstatqqq(23,istat23,ierr) !@@@ +! modified=istat23(10) !@@@ + modified=0 !@@@ + if(mycall.eq.mycall0 .and. hiscall.eq.hiscall0 .and. + + hisgrid.eq.hisgrid0 .and. modified.eq.modified0) go to 30 rewind 23 k=0 icall=0 @@ -77,7 +82,7 @@ C This prevents some optimizations that break this subroutine. mz=1 if(n.eq.1 .and. j3.lt.1 .and. j4.lt.1 .and. - + flip.gt.0.0 .and. callsign(1:6).ne.' ') mz=MAXRPT+1 + + callsign(1:6).ne.' ') mz=MAXRPT+1 C Test for messages with MyCall + HisCall + report do m=1,mz if(m.gt.1) grid=rpt(m-1) @@ -87,12 +92,14 @@ C Test for messages with MyCall + HisCall + report k=k+1 testmsg(k)=message call encode65(message,ncode(1,k)) -C Insert CQ message unless sync=OOO (flip=-1). + nflip(k)=flip +C Insert CQ message if(m.eq.1 .and. flip.gt.0.0) then message='CQ '//callgrid(icall) k=k+1 testmsg(k)=message call encode65(message,ncode(1,k)) + nflip(k)=flip endif enddo if(nsked.eq.1) go to 20 @@ -101,28 +108,33 @@ C Insert CQ message unless sync=OOO (flip=-1). 20 ntot=k neme0=neme + 30 mycall0=mycall + hiscall0=hiscall + hisgrid0=hisgrid + modified0=modified ref0=0. do j=1,63 ref0=ref0 + s3(mrs(j),j) enddo p1=-1.e30 - p2=-1.e30 do k=1,ntot - sum=0. - ref=ref0 - do j=1,63 - i=ncode(j,k)+1 - sum=sum + s3(i,j) - if(i.eq.mrs(j)) then - ref=ref - s3(i,j) + s3(mrs2(j),j) + if(flip.gt.0.0 .or. nflip(k).lt.0) then !Skip CQ msg if flip=-1 + sum=0. + ref=ref0 + do j=1,63 + i=ncode(j,k)+1 + sum=sum + s3(i,j) + if(i.eq.mrs(j)) then + ref=ref - s3(i,j) + s3(mrs2(j),j) + endif + enddo + p=sum/ref + pp(k)=p + if(p.gt.p1) then + p1=p + ip1=k endif - enddo - p=sum/ref - pp(k)=p - if(p.gt.p1) then - p1=p - ip1=k endif enddo @@ -131,10 +143,18 @@ C Insert CQ message unless sync=OOO (flip=-1). if(pp(i).gt.p2 .and. pp(i).ne.p1) p2=pp(i) enddo +C ### Find out why this needs to be here ### +C ### It's OK without it, in Linux, if compiled without optimization. +! rewind 77 +! write(77,*) p1,p2 + if(mode65.eq.1) bias=max(1.12*p2,0.335) if(mode65.eq.2) bias=max(1.08*p2,0.405) if(mode65.ge.4) bias=max(1.04*p2,0.505) + + if(p2.eq.p1) stop 'Error in deep65' qual=100.0*(p1-bias) + decoded=' ' c=' ' @@ -145,6 +165,7 @@ C Insert CQ message unless sync=OOO (flip=-1). qual=0. endif decoded(22:22)=c + C Make sure everything is upper case. do i=1,22 if(decoded(i:i).ge.'a' .and. decoded(i:i).le.'z') diff --git a/deg2grid.f b/deg2grid.f index 8c64028a8..257acf86d 100644 --- a/deg2grid.f +++ b/deg2grid.f @@ -1,30 +1,30 @@ - subroutine deg2grid(dlong0,dlat,grid) - - real dlong !West longitude (deg) - real dlat !Latitude (deg) - character grid*6 - - dlong=dlong0 - if(dlong.lt.-180.0) dlong=dlong+360.0 - if(dlong.gt.180.0) dlong=dlong-360.0 - -C Convert to units of 5 min of longitude, working east from 180 deg. - nlong=60.0*(180.0-dlong)/5.0 - n1=nlong/240 !20-degree field - n2=(nlong-240*n1)/24 !2 degree square - n3=nlong-240*n1-24*n2 !5 minute subsquare - grid(1:1)=char(ichar('A')+n1) - grid(3:3)=char(ichar('0')+n2) - grid(5:5)=char(ichar('a')+n3) - -C Convert to units of 2.5 min of latitude, working north from -90 deg. - nlat=60.0*(dlat+90)/2.5 - n1=nlat/240 !10-degree field - n2=(nlat-240*n1)/24 !1 degree square - n3=nlat-240*n1-24*n2 !2.5 minuts subsquare - grid(2:2)=char(ichar('A')+n1) - grid(4:4)=char(ichar('0')+n2) - grid(6:6)=char(ichar('a')+n3) - - return - end + subroutine deg2grid(dlong0,dlat,grid) + + real dlong !West longitude (deg) + real dlat !Latitude (deg) + character grid*6 + + dlong=dlong0 + if(dlong.lt.-180.0) dlong=dlong+360.0 + if(dlong.gt.180.0) dlong=dlong-360.0 + +C Convert to units of 5 min of longitude, working east from 180 deg. + nlong=60.0*(180.0-dlong)/5.0 + n1=nlong/240 !20-degree field + n2=(nlong-240*n1)/24 !2 degree square + n3=nlong-240*n1-24*n2 !5 minute subsquare + grid(1:1)=char(ichar('A')+n1) + grid(3:3)=char(ichar('0')+n2) + grid(5:5)=char(ichar('a')+n3) + +C Convert to units of 2.5 min of latitude, working north from -90 deg. + nlat=60.0*(dlat+90)/2.5 + n1=nlat/240 !10-degree field + n2=(nlat-240*n1)/24 !1 degree square + n3=nlat-240*n1-24*n2 !2.5 minuts subsquare + grid(2:2)=char(ichar('A')+n1) + grid(4:4)=char(ichar('0')+n2) + grid(6:6)=char(ichar('a')+n3) + + return + end diff --git a/demod64a.f b/demod64a.f index fc024f862..cf057a011 100644 --- a/demod64a.f +++ b/demod64a.f @@ -1,71 +1,71 @@ - subroutine demod64a(signal,nadd,mrsym,mrprob, - + mr2sym,mr2prob,ntest,nlow) - -C Demodulate the 64-bin spectra for each of 63 symbols in a frame. - -C Parameters -C nadd number of spectra already summed -C mrsym most reliable symbol value -C mr2sym second most likely symbol value -C mrprob probability that mrsym was the transmitted value -C mr2prob probability that mr2sym was the transmitted value - - implicit real*8 (a-h,o-z) - real*4 signal(64,63) - real*8 fs(64) - integer mrsym(63),mrprob(63),mr2sym(63),mr2prob(63) - common/tmp9/ mrs(63),mrs2(63) - - afac=1.1 * float(nadd)**0.64 - scale=255.999 - -C Compute average spectral value - sum=0. - do j=1,63 - do i=1,64 - sum=sum+signal(i,j) - enddo - enddo - ave=sum/(64.*63.) - -C Compute probabilities for most reliable symbol values - do j=1,63 - s1=-1.e30 - fsum=0. - do i=1,64 - x=min(afac*signal(i,j)/ave,50.d0) - fs(i)=exp(x) - fsum=fsum+fs(i) - if(signal(i,j).gt.s1) then - s1=signal(i,j) - i1=i !Most reliable - endif - enddo - - s2=-1.e30 - do i=1,64 - if(i.ne.i1 .and. signal(i,j).gt.s2) then - s2=signal(i,j) - i2=i !Second most reliable - endif - enddo - p1=fs(i1)/fsum !Normalized probabilities - p2=fs(i2)/fsum - mrsym(j)=i1-1 - mr2sym(j)=i2-1 - mrprob(j)=scale*p1 - mr2prob(j)=scale*p2 - mrs(j)=i1 - mrs2(j)=i2 - enddo - - sum=0. - nlow=0 - do j=1,63 - sum=sum+mrprob(j) - if(mrprob(j).le.5) nlow=nlow+1 - enddo - ntest=sum/63 - - return - end + subroutine demod64a(signal,nadd,mrsym,mrprob, + + mr2sym,mr2prob,ntest,nlow) + +C Demodulate the 64-bin spectra for each of 63 symbols in a frame. + +C Parameters +C nadd number of spectra already summed +C mrsym most reliable symbol value +C mr2sym second most likely symbol value +C mrprob probability that mrsym was the transmitted value +C mr2prob probability that mr2sym was the transmitted value + + implicit real*8 (a-h,o-z) + real*4 signal(64,63) + real*8 fs(64) + integer mrsym(63),mrprob(63),mr2sym(63),mr2prob(63) + common/mrscom/ mrs(63),mrs2(63) + + afac=1.1 * float(nadd)**0.64 + scale=255.999 + +C Compute average spectral value + sum=0. + do j=1,63 + do i=1,64 + sum=sum+signal(i,j) + enddo + enddo + ave=sum/(64.*63.) + +C Compute probabilities for most reliable symbol values + do j=1,63 + s1=-1.e30 + fsum=0. + do i=1,64 + x=min(afac*signal(i,j)/ave,50.d0) + fs(i)=exp(x) + fsum=fsum+fs(i) + if(signal(i,j).gt.s1) then + s1=signal(i,j) + i1=i !Most reliable + endif + enddo + + s2=-1.e30 + do i=1,64 + if(i.ne.i1 .and. signal(i,j).gt.s2) then + s2=signal(i,j) + i2=i !Second most reliable + endif + enddo + p1=fs(i1)/fsum !Normalized probabilities + p2=fs(i2)/fsum + mrsym(j)=i1-1 + mr2sym(j)=i2-1 + mrprob(j)=scale*p1 + mr2prob(j)=scale*p2 + mrs(j)=i1 + mrs2(j)=i2 + enddo + + sum=0. + nlow=0 + do j=1,63 + sum=sum+mrprob(j) + if(mrprob(j).le.5) nlow=nlow+1 + enddo + ntest=sum/63 + + return + end diff --git a/detect.f b/detect.f index 82acbab42..dcea8f917 100644 --- a/detect.f +++ b/detect.f @@ -1,29 +1,29 @@ - subroutine detect(data,npts,f,y) - -C Compute powers at the tone frequencies using 1-sample steps. - - parameter (NZ=11025,NSPD=25) - real data(npts) - real y(npts) - complex c(NZ) - complex csum - data twopi/6.283185307/ - - dpha=twopi*f/11025.0 - do i=1,npts - c(i)=data(i)*cmplx(cos(dpha*i),-sin(dpha*i)) - enddo - - csum=0. - do i=1,NSPD - csum=csum+c(i) - enddo - - y(1)=real(csum)**2 + aimag(csum)**2 - do i=2,npts-(NSPD-1) - csum=csum-c(i-1)+c(i+NSPD-1) - y(i)=real(csum)**2 + aimag(csum)**2 - enddo - - return - end + subroutine detect(data,npts,f,y) + +C Compute powers at the tone frequencies using 1-sample steps. + + parameter (NZ=11025,NSPD=25) + real data(npts) + real y(npts) + complex c(NZ) + complex csum + data twopi/6.283185307/ + + dpha=twopi*f/11025.0 + do i=1,npts + c(i)=data(i)*cmplx(cos(dpha*i),-sin(dpha*i)) + enddo + + csum=0. + do i=1,NSPD + csum=csum+c(i) + enddo + + y(1)=real(csum)**2 + aimag(csum)**2 + do i=2,npts-(NSPD-1) + csum=csum-c(i-1)+c(i+NSPD-1) + y(i)=real(csum)**2 + aimag(csum)**2 + enddo + + return + end diff --git a/display.f b/display.f new file mode 100644 index 000000000..f3a03a487 --- /dev/null +++ b/display.f @@ -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 diff --git a/dot.f b/dot.f index 8e2d826bf..f4c378820 100644 --- a/dot.f +++ b/dot.f @@ -1,11 +1,11 @@ - real*8 function dot(x,y) - - real*8 x(3),y(3) - - dot=0.d0 - do i=1,3 - dot=dot+x(i)*y(i) - enddo - - return - end + real*8 function dot(x,y) + + real*8 x(3),y(3) + + dot=0.d0 + do i=1,3 + dot=dot+x(i)*y(i) + enddo + + return + end diff --git a/encode65.f b/encode65.f index 670c2e583..1fca85ae4 100644 --- a/encode65.f +++ b/encode65.f @@ -1,13 +1,13 @@ - subroutine encode65(message,sent) - - character message*22 - integer dgen(12) - integer sent(63) - - call packmsg(message,dgen) - call rs_encode(dgen,sent) - call interleave63(sent,1) - call graycode(sent,63,1) - - return - end + subroutine encode65(message,sent) + + character message*22 + integer dgen(12) + integer sent(63) + + call packmsg(message,dgen) + call rs_encode(dgen,sent) + call interleave63(sent,1) + call graycode(sent,63,1) + + return + end diff --git a/extract.f b/extract.f index 4a06c326a..77a4dfd46 100644 --- a/extract.f +++ b/extract.f @@ -1,28 +1,39 @@ - subroutine extract(s3,nadd,ncount,decoded) + subroutine extract(s3,nadd,ncount,nhist,decoded) real s3(64,63) + real tmp(4032) character decoded*22 - integer era(51),dat4(12),indx(63) + integer era(51),dat4(12),indx(64) integer mrsym(63),mr2sym(63),mrprob(63),mr2prob(63) logical first data first/.true./,nsec1/0/ save - call demod64a(s3,nadd,mrsym,mrprob,mr2sym,mr2prob,ntest,nlow) - + nfail=0 + 1 call demod64a(s3,nadd,mrsym,mrprob,mr2sym,mr2prob,ntest,nlow) if(ntest.lt.50 .or. nlow.gt.20) then ncount=-999 !Flag bad data go to 900 endif + call chkhist(mrsym,nhist,ipk) + + if(nhist.ge.20) then + nfail=nfail+1 + call pctile(s3,tmp,4032,50,base) ! ### or, use ave from demod64a + do j=1,63 + s3(ipk,j)=base + enddo + go to 1 + endif call graycode(mrsym,63,-1) call interleave63(mrsym,-1) call interleave63(mrprob,-1) ndec=1 - nemax=30 + nemax=30 !Was 200 (30) maxe=8 - xlambda=15.0 + xlambda=12.0 !Was 15 (12) if(ndec.eq.1) then call graycode(mr2sym,63,-1) @@ -35,9 +46,9 @@ call flushqqq(22) call runqqq('kvasd.exe','-q',iret) if(iret.ne.0) then - if(first) write(*,1000) + if(first) write(*,1000) iret 1000 format('Error in KV decoder, or no KV decoder present.'/ - + 'Using BM algorithm.') + + 'Return code:',i8,'. Will use BM algorithm.') ndec=0 first=.false. go to 20 diff --git a/fftw3.f b/fftw3.f index 3410184ca..90748b2fd 100644 --- a/fftw3.f +++ b/fftw3.f @@ -1,64 +1,64 @@ - INTEGER FFTW_R2HC - PARAMETER (FFTW_R2HC=0) - INTEGER FFTW_HC2R - PARAMETER (FFTW_HC2R=1) - INTEGER FFTW_DHT - PARAMETER (FFTW_DHT=2) - INTEGER FFTW_REDFT00 - PARAMETER (FFTW_REDFT00=3) - INTEGER FFTW_REDFT01 - PARAMETER (FFTW_REDFT01=4) - INTEGER FFTW_REDFT10 - PARAMETER (FFTW_REDFT10=5) - INTEGER FFTW_REDFT11 - PARAMETER (FFTW_REDFT11=6) - INTEGER FFTW_RODFT00 - PARAMETER (FFTW_RODFT00=7) - INTEGER FFTW_RODFT01 - PARAMETER (FFTW_RODFT01=8) - INTEGER FFTW_RODFT10 - PARAMETER (FFTW_RODFT10=9) - INTEGER FFTW_RODFT11 - PARAMETER (FFTW_RODFT11=10) - INTEGER FFTW_FORWARD - PARAMETER (FFTW_FORWARD=-1) - INTEGER FFTW_BACKWARD - PARAMETER (FFTW_BACKWARD=+1) - INTEGER FFTW_MEASURE - PARAMETER (FFTW_MEASURE=0) - INTEGER FFTW_DESTROY_INPUT - PARAMETER (FFTW_DESTROY_INPUT=1) - INTEGER FFTW_UNALIGNED - PARAMETER (FFTW_UNALIGNED=2) - INTEGER FFTW_CONSERVE_MEMORY - PARAMETER (FFTW_CONSERVE_MEMORY=4) - INTEGER FFTW_EXHAUSTIVE - PARAMETER (FFTW_EXHAUSTIVE=8) - INTEGER FFTW_PRESERVE_INPUT - PARAMETER (FFTW_PRESERVE_INPUT=16) - INTEGER FFTW_PATIENT - PARAMETER (FFTW_PATIENT=32) - INTEGER FFTW_ESTIMATE - PARAMETER (FFTW_ESTIMATE=64) - INTEGER FFTW_ESTIMATE_PATIENT - PARAMETER (FFTW_ESTIMATE_PATIENT=128) - INTEGER FFTW_BELIEVE_PCOST - PARAMETER (FFTW_BELIEVE_PCOST=256) - INTEGER FFTW_DFT_R2HC_ICKY - PARAMETER (FFTW_DFT_R2HC_ICKY=512) - INTEGER FFTW_NONTHREADED_ICKY - PARAMETER (FFTW_NONTHREADED_ICKY=1024) - INTEGER FFTW_NO_BUFFERING - PARAMETER (FFTW_NO_BUFFERING=2048) - INTEGER FFTW_NO_INDIRECT_OP - PARAMETER (FFTW_NO_INDIRECT_OP=4096) - INTEGER FFTW_ALLOW_LARGE_GENERIC - PARAMETER (FFTW_ALLOW_LARGE_GENERIC=8192) - INTEGER FFTW_NO_RANK_SPLITS - PARAMETER (FFTW_NO_RANK_SPLITS=16384) - INTEGER FFTW_NO_VRANK_SPLITS - PARAMETER (FFTW_NO_VRANK_SPLITS=32768) - INTEGER FFTW_NO_VRECURSE - PARAMETER (FFTW_NO_VRECURSE=65536) - INTEGER FFTW_NO_SIMD - PARAMETER (FFTW_NO_SIMD=131072) + INTEGER FFTW_R2HC + PARAMETER (FFTW_R2HC=0) + INTEGER FFTW_HC2R + PARAMETER (FFTW_HC2R=1) + INTEGER FFTW_DHT + PARAMETER (FFTW_DHT=2) + INTEGER FFTW_REDFT00 + PARAMETER (FFTW_REDFT00=3) + INTEGER FFTW_REDFT01 + PARAMETER (FFTW_REDFT01=4) + INTEGER FFTW_REDFT10 + PARAMETER (FFTW_REDFT10=5) + INTEGER FFTW_REDFT11 + PARAMETER (FFTW_REDFT11=6) + INTEGER FFTW_RODFT00 + PARAMETER (FFTW_RODFT00=7) + INTEGER FFTW_RODFT01 + PARAMETER (FFTW_RODFT01=8) + INTEGER FFTW_RODFT10 + PARAMETER (FFTW_RODFT10=9) + INTEGER FFTW_RODFT11 + PARAMETER (FFTW_RODFT11=10) + INTEGER FFTW_FORWARD + PARAMETER (FFTW_FORWARD=-1) + INTEGER FFTW_BACKWARD + PARAMETER (FFTW_BACKWARD=+1) + INTEGER FFTW_MEASURE + PARAMETER (FFTW_MEASURE=0) + INTEGER FFTW_DESTROY_INPUT + PARAMETER (FFTW_DESTROY_INPUT=1) + INTEGER FFTW_UNALIGNED + PARAMETER (FFTW_UNALIGNED=2) + INTEGER FFTW_CONSERVE_MEMORY + PARAMETER (FFTW_CONSERVE_MEMORY=4) + INTEGER FFTW_EXHAUSTIVE + PARAMETER (FFTW_EXHAUSTIVE=8) + INTEGER FFTW_PRESERVE_INPUT + PARAMETER (FFTW_PRESERVE_INPUT=16) + INTEGER FFTW_PATIENT + PARAMETER (FFTW_PATIENT=32) + INTEGER FFTW_ESTIMATE + PARAMETER (FFTW_ESTIMATE=64) + INTEGER FFTW_ESTIMATE_PATIENT + PARAMETER (FFTW_ESTIMATE_PATIENT=128) + INTEGER FFTW_BELIEVE_PCOST + PARAMETER (FFTW_BELIEVE_PCOST=256) + INTEGER FFTW_DFT_R2HC_ICKY + PARAMETER (FFTW_DFT_R2HC_ICKY=512) + INTEGER FFTW_NONTHREADED_ICKY + PARAMETER (FFTW_NONTHREADED_ICKY=1024) + INTEGER FFTW_NO_BUFFERING + PARAMETER (FFTW_NO_BUFFERING=2048) + INTEGER FFTW_NO_INDIRECT_OP + PARAMETER (FFTW_NO_INDIRECT_OP=4096) + INTEGER FFTW_ALLOW_LARGE_GENERIC + PARAMETER (FFTW_ALLOW_LARGE_GENERIC=8192) + INTEGER FFTW_NO_RANK_SPLITS + PARAMETER (FFTW_NO_RANK_SPLITS=16384) + INTEGER FFTW_NO_VRANK_SPLITS + PARAMETER (FFTW_NO_VRANK_SPLITS=32768) + INTEGER FFTW_NO_VRECURSE + PARAMETER (FFTW_NO_VRECURSE=65536) + INTEGER FFTW_NO_SIMD + PARAMETER (FFTW_NO_SIMD=131072) diff --git a/filbig.f b/filbig.f new file mode 100644 index 000000000..529817aa9 --- /dev/null +++ b/filbig.f @@ -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 diff --git a/fivehz.F90 b/fivehz.F90 index 7ed19234b..1aeada908 100644 --- a/fivehz.F90 +++ b/fivehz.F90 @@ -1,270 +1,270 @@ -subroutine fivehz - -! Called at interrupt level from the PortAudio callback routine. -! For nspb=2048 the callback rate is nfsample/nspb = 5.38 Hz. -! Thus, we should be able to control the timing of T/R sequence events -! here to within about 0.2 s. - -! Do not do anything very time consuming in this routine!! -! Disk I/O is a bad idea. Writing to stdout (for diagnostic purposes) -! seems to be OK. - -#ifdef Win32 - use dflib - use dfport -#endif - - parameter (NTRING=64) - real*8 tt1(0:NTRING-1) - real*8 tstart,tstop,t60 - logical first,txtime,filled - integer ptt - integer TxOKz - real*8 fs,fsample,tt,u - include 'gcom1.f90' - include 'gcom2.f90' - data first/.true./,nc0/1/,nc1/1/ - save - - n1=time() - n2=mod(n1,86400) - tt=n1-n2+tsec-0.1d0*ndsec - - if(first) then - rxdelay=0.2 - txdelay=0.4 - tlatency=1.0 - first=.false. - iptt=0 - ntr0=-99 - rxdone=.false. - ibuf00=-99 - ncall=-1 - u=0.05d0 - fsample=11025.d0 - mfsample=110250 - filled=.false. - endif - - if(txdelay.lt.0.2d0) txdelay=0.2d0 - -! Measure average sampling frequency over a recent interval - ncall=ncall+1 - if(ncall.eq.9) then - ntt0=0 - ntt1=0 - tt1(ntt1)=tt - endif -! if(ncall.ge.10 .and. mod(ncall,2).eq.1) then - if(ncall.ge.10) then - ntt1=iand(ntt1+1,NTRING-1) - tt1(ntt1)=tt - if(ntt1.eq.NTRING-1) filled=.true. - if(filled) ntt0=iand(ntt1+1,NTRING-1) - if(mod(ncall,2).eq.1) then - nd=ntt1-ntt0 - if(nd.lt.0) nd=nd+NTRING - fs=nd*2048.d0/(tt1(ntt1)-tt1(ntt0)) - fsample=u*fs + (1.d0-u)*fsample - mfsample=nint(10.d0*fsample) - endif - endif - - if(trperiod.le.0) trperiod=30 - tx1=0.0 !Time to start a TX sequence - tx2=trperiod-(tlatency+txdelay) !Time to turn TX off - if(mode(1:4).eq.'JT65') then - if(nwave.lt.126*4096) nwave=126*4096 - tx2=txdelay + nwave/11025.0 - if(tx2.gt.(trperiod-2.0)) tx2=trperiod-tlatency-1.0 - endif - - if(TxFirst.eq.0) then - tx1=tx1+trperiod - tx2=tx2+trperiod - endif - - t=mod(Tsec,2.d0*trperiod) - txtime = t.ge.tx1 .and. t.lt.tx2 - -! If we're transmitting, freeze the input buffer pointers where they were. - receiving=1 - if(((txtime .and. (lauto.eq.1)) .or. TxOK.eq.1 .or. transmitting.eq.1) & - .and. (mute.eq.0)) then - receiving=0 - ibuf=ibuf000 - iwrite=iwrite000 - endif - ibuf000=ibuf - iwrite000=iwrite - nsec=Tsec - ntr=mod(nsec/trperiod,2) !ntr=0 in 1st sequence, 1 in 2nd - - if(ntr.ne.ntr0) then - ibuf0=ibuf !Start of new sequence, save ibuf -! if(mode(1:4).ne.'JT65') then -! ibuf0=ibuf0+3 !So we don't copy our own Tx -! if(ibuf0.gt.1024) ibuf0=ibuf0-1024 -! endif - ntime=time() !Save start time - if(mantx.eq.1 .and. iptt.eq.1) then - mantx=0 - TxOK=0 - endif - endif - -! Switch PTT line and TxOK appropriately - if(lauto.eq.1) then - if(txtime .and. iptt.eq.0 .and. & - mute.eq.0) i1=ptt(nport,pttport,1,iptt) !Raise PTT - if(.not.txtime .or. mute.eq.1) TxOK=0 !Lower TxOK - else - if(mantx.eq.1 .and. iptt.eq.0 .and. & - mute.eq.0) i2=ptt(nport,pttport,1,iptt) !Raise PTT - if(mantx.eq.0 .or. mute.eq.1) TxOK=0 !Lower TxOK - endif - -! Calculate Tx waveform as needed - if((iptt.eq.1 .and. iptt0.eq.0) .or. nrestart.eq.1) then - call wsjtgen - nrestart=0 - endif - -! If PTT was just raised, start a countdown for raising TxOK: - nc1a=txdelay/0.18576 - if(nc1a.lt.2) nc1a=2 - if(iptt.eq.1 .and. iptt0.eq.0) nc1=-nc1a-1 - if(nc1.le.0) nc1=nc1+1 - if(nc1.eq.0) TxOK=1 ! We are transmitting - -! If TxOK was just lowered, start a countdown for lowering PTT: - nc0a=(tlatency+txdelay)/0.18576 - if(nc0a.lt.5) nc0a=5 - if(TxOK.eq.0 .and. TxOKz.eq.1 .and. iptt.eq.1) nc0=-nc0a-1 - if(nc0.le.0) nc0=nc0+1 - if(nc0.eq.0) i3=ptt(nport,pttport,0,iptt) - - if(iptt.eq.0 .and.TxOK.eq.0) then - sending=" " - sendingsh=0 - endif - - nbufs=ibuf-ibuf0 - if(nbufs.lt.0) nbufs=nbufs+1024 - tdata=nbufs*2048.0/11025.0 - if(mode(1:4).eq.'JT65' .and. monitoring.eq.1 .and. tdata.gt.53.0 & - .and. ibuf0.ne.ibuf00) then - rxdone=.true. - ibuf00=ibuf0 - endif - -! Diagnostic timing information: -! t60=mod(tsec,60.d0) -! if(TxOK.ne.TxOKz) then -! if(TxOK.eq.1) write(*,1101) 'D2:',t -!1101 format(a3,f8.1,i8) -! if(TxOK.eq.0) then -! tstop=tsec -! write(*,1101) 'D3:',t,nc0a -! endif -! endif -! if(iptt.ne.iptt0) then -! if(iptt.eq.1) then -! tstart=tsec -! write(*,1101) 'D1:',t,nc1a -! endif -! if(iptt.eq.0) write(*,1101) 'D4:',t -! endif - - iptt0=iptt - TxOKz=TxOK - ntr0=ntr - - return -end subroutine fivehz - -subroutine fivehztx - -! Called at interrupt level from the PortAudio output callback. - -#ifdef Win32 - use dflib - use dfport -#endif - - parameter (NTRING=64) - real*8 tt1(0:NTRING-1) - logical first,filled - real*8 fs,fsample,tt,u - include 'gcom1.f90' - data first/.true./ - save - - n1=time() - n2=mod(n1,86400) - tt=n1-n2+tsec-0.1d0*ndsec - - if(first) then - first=.false. - ncall=-1 - fsample=11025.d0 - u=0.05d0 - mfsample2=110250 - filled=.false. - endif - -! Measure average sampling frequency over a recent interval - ncall=ncall+1 - if(ncall.eq.9) then - ntt0=0 - ntt1=0 - tt1(ntt1)=tt - endif - if(ncall.ge.10) then - ntt1=iand(ntt1+1,NTRING-1) - tt1(ntt1)=tt - if(ntt1.eq.NTRING-1) filled=.true. - if(filled) ntt0=iand(ntt1+1,NTRING-1) - if(mod(ncall,2).eq.1) then - nd=ntt1-ntt0 - if(nd.lt.0) nd=nd+NTRING - fs=nd*2048.d0/(tt1(ntt1)-tt1(ntt0)) - fsample=u*fs + (1.d0-u)*fsample - mfsample2=nint(10.d0*fsample) - endif - endif - - return -end subroutine fivehztx - -subroutine addnoise(n) - integer*2 n - real*8 txsnrdb0 - include 'gcom1.f90' - data idum/0/ - save - - if(txsnrdb.gt.40.0) return - if(txsnrdb.ne.txsnrdb0) then - snr=10.0**(0.05*(txsnrdb-1)) - fac=3000.0 - if(snr.gt.1.0) fac=3000.0/snr - txsnrdb0=txsnrdb - endif - i=fac*(gran(idum) + n*snr/32768.0) - if(i>32767) i=32767; - if(i<-32767) i=-32767; - n=i - - return -end subroutine addnoise - -real function gran(idum) - real r(12) - if(idum.lt.0) then - call random_seed - idum=0 - endif - call random_number(r) - gran=sum(r)-6.0 -end function gran +subroutine fivehz + +! Called at interrupt level from the PortAudio callback routine. +! For nspb=2048 the callback rate is nfsample/nspb = 5.38 Hz. +! Thus, we should be able to control the timing of T/R sequence events +! here to within about 0.2 s. + +! Do not do anything very time consuming in this routine!! +! Disk I/O is a bad idea. Writing to stdout (for diagnostic purposes) +! seems to be OK. + +#ifdef Win32 + use dflib + use dfport +#endif + + parameter (NTRING=64) + real*8 tt1(0:NTRING-1) + real*8 tstart,tstop,t60 + logical first,txtime,filled + integer ptt + integer TxOKz + real*8 fs,fsample,tt,u + include 'gcom1.f90' + include 'gcom2.f90' + data first/.true./,nc0/1/,nc1/1/ + save + + n1=time() + n2=mod(n1,86400) + tt=n1-n2+tsec-0.1d0*ndsec + + if(first) then + rxdelay=0.2 + txdelay=0.4 + tlatency=1.0 + first=.false. + iptt=0 + ntr0=-99 + rxdone=.false. + ibuf00=-99 + ncall=-1 + u=0.05d0 + fsample=11025.d0 + mfsample=110250 + filled=.false. + endif + + if(txdelay.lt.0.2d0) txdelay=0.2d0 + +! Measure average sampling frequency over a recent interval + ncall=ncall+1 + if(ncall.eq.9) then + ntt0=0 + ntt1=0 + tt1(ntt1)=tt + endif +! if(ncall.ge.10 .and. mod(ncall,2).eq.1) then + if(ncall.ge.10) then + ntt1=iand(ntt1+1,NTRING-1) + tt1(ntt1)=tt + if(ntt1.eq.NTRING-1) filled=.true. + if(filled) ntt0=iand(ntt1+1,NTRING-1) + if(mod(ncall,2).eq.1) then + nd=ntt1-ntt0 + if(nd.lt.0) nd=nd+NTRING + fs=nd*2048.d0/(tt1(ntt1)-tt1(ntt0)) + fsample=u*fs + (1.d0-u)*fsample + mfsample=nint(10.d0*fsample) + endif + endif + + if(trperiod.le.0) trperiod=30 + tx1=0.0 !Time to start a TX sequence + tx2=trperiod-(tlatency+txdelay) !Time to turn TX off + if(mode(1:4).eq.'JT65') then + if(nwave.lt.126*4096) nwave=126*4096 + tx2=txdelay + nwave/11025.0 + if(tx2.gt.(trperiod-2.0)) tx2=trperiod-tlatency-1.0 + endif + + if(TxFirst.eq.0) then + tx1=tx1+trperiod + tx2=tx2+trperiod + endif + + t=mod(Tsec,2.d0*trperiod) + txtime = t.ge.tx1 .and. t.lt.tx2 + +! If we're transmitting, freeze the input buffer pointers where they were. + receiving=1 + if(((txtime .and. (lauto.eq.1)) .or. TxOK.eq.1 .or. transmitting.eq.1) & + .and. (mute.eq.0)) then + receiving=0 + ibuf=ibuf000 + iwrite=iwrite000 + endif + ibuf000=ibuf + iwrite000=iwrite + nsec=Tsec + ntr=mod(nsec/trperiod,2) !ntr=0 in 1st sequence, 1 in 2nd + + if(ntr.ne.ntr0) then + ibuf0=ibuf !Start of new sequence, save ibuf +! if(mode(1:4).ne.'JT65') then +! ibuf0=ibuf0+3 !So we don't copy our own Tx +! if(ibuf0.gt.1024) ibuf0=ibuf0-1024 +! endif + ntime=time() !Save start time + if(mantx.eq.1 .and. iptt.eq.1) then + mantx=0 + TxOK=0 + endif + endif + +! Switch PTT line and TxOK appropriately + if(lauto.eq.1) then + if(txtime .and. iptt.eq.0 .and. & + mute.eq.0) i1=ptt(nport,pttport,1,iptt) !Raise PTT + if(.not.txtime .or. mute.eq.1) TxOK=0 !Lower TxOK + else + if(mantx.eq.1 .and. iptt.eq.0 .and. & + mute.eq.0) i2=ptt(nport,pttport,1,iptt) !Raise PTT + if(mantx.eq.0 .or. mute.eq.1) TxOK=0 !Lower TxOK + endif + +! Calculate Tx waveform as needed + if((iptt.eq.1 .and. iptt0.eq.0) .or. nrestart.eq.1) then + call wsjtgen + nrestart=0 + endif + +! If PTT was just raised, start a countdown for raising TxOK: + nc1a=txdelay/0.18576 + if(nc1a.lt.2) nc1a=2 + if(iptt.eq.1 .and. iptt0.eq.0) nc1=-nc1a-1 + if(nc1.le.0) nc1=nc1+1 + if(nc1.eq.0) TxOK=1 ! We are transmitting + +! If TxOK was just lowered, start a countdown for lowering PTT: + nc0a=(tlatency+txdelay)/0.18576 + if(nc0a.lt.5) nc0a=5 + if(TxOK.eq.0 .and. TxOKz.eq.1 .and. iptt.eq.1) nc0=-nc0a-1 + if(nc0.le.0) nc0=nc0+1 + if(nc0.eq.0) i3=ptt(nport,pttport,0,iptt) + + if(iptt.eq.0 .and.TxOK.eq.0) then + sending=" " + sendingsh=0 + endif + + nbufs=ibuf-ibuf0 + if(nbufs.lt.0) nbufs=nbufs+1024 + tdata=nbufs*2048.0/11025.0 + if(mode(1:4).eq.'JT65' .and. monitoring.eq.1 .and. tdata.gt.53.0 & + .and. ibuf0.ne.ibuf00) then + rxdone=.true. + ibuf00=ibuf0 + endif + +! Diagnostic timing information: +! t60=mod(tsec,60.d0) +! if(TxOK.ne.TxOKz) then +! if(TxOK.eq.1) write(*,1101) 'D2:',t +!1101 format(a3,f8.1,i8) +! if(TxOK.eq.0) then +! tstop=tsec +! write(*,1101) 'D3:',t,nc0a +! endif +! endif +! if(iptt.ne.iptt0) then +! if(iptt.eq.1) then +! tstart=tsec +! write(*,1101) 'D1:',t,nc1a +! endif +! if(iptt.eq.0) write(*,1101) 'D4:',t +! endif + + iptt0=iptt + TxOKz=TxOK + ntr0=ntr + + return +end subroutine fivehz + +subroutine fivehztx + +! Called at interrupt level from the PortAudio output callback. + +#ifdef Win32 + use dflib + use dfport +#endif + + parameter (NTRING=64) + real*8 tt1(0:NTRING-1) + logical first,filled + real*8 fs,fsample,tt,u + include 'gcom1.f90' + data first/.true./ + save + + n1=time() + n2=mod(n1,86400) + tt=n1-n2+tsec-0.1d0*ndsec + + if(first) then + first=.false. + ncall=-1 + fsample=11025.d0 + u=0.05d0 + mfsample2=110250 + filled=.false. + endif + +! Measure average sampling frequency over a recent interval + ncall=ncall+1 + if(ncall.eq.9) then + ntt0=0 + ntt1=0 + tt1(ntt1)=tt + endif + if(ncall.ge.10) then + ntt1=iand(ntt1+1,NTRING-1) + tt1(ntt1)=tt + if(ntt1.eq.NTRING-1) filled=.true. + if(filled) ntt0=iand(ntt1+1,NTRING-1) + if(mod(ncall,2).eq.1) then + nd=ntt1-ntt0 + if(nd.lt.0) nd=nd+NTRING + fs=nd*2048.d0/(tt1(ntt1)-tt1(ntt0)) + fsample=u*fs + (1.d0-u)*fsample + mfsample2=nint(10.d0*fsample) + endif + endif + + return +end subroutine fivehztx + +subroutine addnoise(n) + integer*2 n + real*8 txsnrdb0 + include 'gcom1.f90' + data idum/0/ + save + + if(txsnrdb.gt.40.0) return + if(txsnrdb.ne.txsnrdb0) then + snr=10.0**(0.05*(txsnrdb-1)) + fac=3000.0 + if(snr.gt.1.0) fac=3000.0/snr + txsnrdb0=txsnrdb + endif + i=fac*(gran(idum) + n*snr/32768.0) + if(i>32767) i=32767; + if(i<-32767) i=-32767; + n=i + + return +end subroutine addnoise + +real function gran(idum) + real r(12) + if(idum.lt.0) then + call random_seed + idum=0 + endif + call random_number(r) + gran=sum(r)-6.0 +end function gran diff --git a/fivehz.h b/fivehz.h index 9a9717e17..f39fe4be0 100644 --- a/fivehz.h +++ b/fivehz.h @@ -1,5 +1,5 @@ -#include - -void addnoise_(int16_t *n2); -void fivehztx_(void); -void fivehz_(void); +#include + +void addnoise_(int16_t *n2); +void fivehztx_(void); +void fivehz_(void); diff --git a/flat1.f b/flat1.f index 9eba653e0..37adbfff3 100644 --- a/flat1.f +++ b/flat1.f @@ -1,30 +1,30 @@ - subroutine flat1(psavg,s2,nh,nsteps,nhmax,nsmax) - - real psavg(nh) - real s2(nhmax,nsmax) - real x(8192),tmp(33) - - nsmo=33 - ia=nsmo/2 + 1 - ib=nh - nsmo/2 - 1 - do i=ia,ib - call pctile(psavg(i-nsmo/2),tmp,nsmo,50,x(i)) - enddo - do i=1,ia-1 - x(i)=x(ia) - enddo - do i=ib+1,nh - x(i)=x(ib) - enddo - - do i=1,nh - psavg(i)=psavg(i)/x(i) - do j=1,nsteps - s2(i,j)=s2(i,j)/x(i) - enddo - enddo - - return - end - - + subroutine flat1(psavg,s2,nh,nsteps,nhmax,nsmax) + + real psavg(nh) + real s2(nhmax,nsmax) + real x(8192),tmp(33) + + nsmo=33 + ia=nsmo/2 + 1 + ib=nh - nsmo/2 - 1 + do i=ia,ib + call pctile(psavg(i-nsmo/2),tmp,nsmo,50,x(i)) + enddo + do i=1,ia-1 + x(i)=x(ia) + enddo + do i=ib+1,nh + x(i)=x(ib) + enddo + + do i=1,nh + psavg(i)=psavg(i)/x(i) + do j=1,nsteps + s2(i,j)=s2(i,j)/x(i) + enddo + enddo + + return + end + + diff --git a/flat2.f b/flat2.f index 8cf75225f..f4d4156e8 100644 --- a/flat2.f +++ b/flat2.f @@ -1,28 +1,28 @@ - subroutine flat2(ss,n,nsum) - - real ss(2048) - real ref(2048) - real tmp(2048) - - nsmo=20 - base=50*(float(nsum)**1.5) - ia=nsmo+1 - ib=n-nsmo-1 - do i=ia,ib - call pctile(ss(i-nsmo),tmp,2*nsmo+1,50,ref(i)) - enddo - call pctile(ref(ia),tmp,ib-ia+1,68,base2) - -C Don't flatten if signal is extremely low (e.g., RX is off). - if(base2.gt.0.05*base) then - do i=ia,ib - ss(i)=base*ss(i)/ref(i) - enddo - else - do i=1,n - ss(i)=0. - enddo - endif - - return - end + subroutine flat2(ss,n,nsum) + + real ss(2048) + real ref(2048) + real tmp(2048) + + nsmo=20 + base=50*(float(nsum)**1.5) + ia=nsmo+1 + ib=n-nsmo-1 + do i=ia,ib + call pctile(ss(i-nsmo),tmp,2*nsmo+1,50,ref(i)) + enddo + call pctile(ref(ia),tmp,ib-ia+1,68,base2) + +C Don't flatten if signal is extremely low (e.g., RX is off). + if(base2.gt.0.05*base) then + do i=ia,ib + ss(i)=base*ss(i)/ref(i) + enddo + else + do i=1,n + ss(i)=0. + enddo + endif + + return + end diff --git a/flatten.f b/flatten.f index a0da1293c..1db43a1fa 100644 --- a/flatten.f +++ b/flatten.f @@ -1,105 +1,105 @@ - subroutine flatten(s2,nbins,jz,psa,ref,birdie,variance) - -C Examines the 2-d spectrum s2(nbins,jz) and makes a reference spectrum -C from the jz/2 spectra below the 50th percentile in total power. Uses -C reference spectrum (with birdies removed) to flatten the passband. - - real s2(nbins,jz) !2d spectrum - real psa(nbins) !Grand average spectrum - real ref(nbins) !Ref spect: smoothed ave of lower half - real birdie(nbins) !Spec (with birdies) for plot, in dB - real variance(nbins) - real ref2(750) !Work array - real power(300) - -C Find power in each time block, then get median - do j=1,jz - s=0. - do i=1,nbins - s=s+s2(i,j) - enddo - power(j)=s - enddo - call pctile(power,ref2,jz,50,xmedian) - if(jz.lt.5) go to 900 - -C Get variance in each freq channel, using only those spectra with -C power below the median. - do i=1,nbins - s=0. - nsum=0 - do j=1,jz - if(power(j).le.xmedian) then - s=s+s2(i,j) - nsum=nsum+1 - endif - enddo - s=s/nsum - sq=0. - do j=1,jz - if(power(j).le.xmedian) sq=sq + (s2(i,j)/s-1.0)**2 - enddo - variance(i)=sq/nsum - enddo - -C Get grand average, and average of spectra with power below median. - call zero(psa,nbins) - call zero(ref,nbins) - nsum=0 - do j=1,jz - call add(psa,s2(1,j),psa,nbins) - if(power(j).le.xmedian) then - call add(ref,s2(1,j),ref,nbins) - nsum=nsum+1 - endif - enddo - do i=1,nbins !Normalize the averages - psa(i)=psa(i)/jz - ref(i)=ref(i)/nsum - birdie(i)=ref(i) !Copy ref into birdie - enddo - -C Compute smoothed reference spectrum with narrow lines (birdies) removed - do i=4,nbins-3 - rmax=-1.e10 - do k=i-3,i+3 !Get highest point within +/- 3 bins - if(ref(k).gt.rmax) then - rmax=ref(k) - kpk=k - endif - enddo - sum=0. - nsum=0 - do k=i-3,i+3 - if(abs(k-kpk).gt.1) then - sum=sum+ref(k) - nsum=nsum+1 - endif - enddo - ref2(i)=sum/nsum - enddo - call move(ref2(4),ref(4),nbins-6) !Copy smoothed ref back into ref - - call pctile(ref(4),ref2,nbins-6,50,xmedian) !Get median in-band level - -C Fix ends of reference spectrum - do i=1,3 - ref(i)=ref(4) - ref(nbins+1-i)=ref(nbins-3) - enddo - - facmax=30.0/xmedian - do i=1,nbins !Flatten the 2d spectrum - fac=xmedian/ref(i) - fac=min(fac,facmax) - do j=1,jz - s2(i,j)=fac*s2(i,j) - enddo - psa(i)=dB(psa(i)) + 25. - ref(i)=dB(ref(i)) + 25. - birdie(i)=db(birdie(i)) + 25. - enddo - -900 continue - return - end + subroutine flatten(s2,nbins,jz,psa,ref,birdie,variance) + +C Examines the 2-d spectrum s2(nbins,jz) and makes a reference spectrum +C from the jz/2 spectra below the 50th percentile in total power. Uses +C reference spectrum (with birdies removed) to flatten the passband. + + real s2(nbins,jz) !2d spectrum + real psa(nbins) !Grand average spectrum + real ref(nbins) !Ref spect: smoothed ave of lower half + real birdie(nbins) !Spec (with birdies) for plot, in dB + real variance(nbins) + real ref2(750) !Work array + real power(300) + +C Find power in each time block, then get median + do j=1,jz + s=0. + do i=1,nbins + s=s+s2(i,j) + enddo + power(j)=s + enddo + call pctile(power,ref2,jz,50,xmedian) + if(jz.lt.5) go to 900 + +C Get variance in each freq channel, using only those spectra with +C power below the median. + do i=1,nbins + s=0. + nsum=0 + do j=1,jz + if(power(j).le.xmedian) then + s=s+s2(i,j) + nsum=nsum+1 + endif + enddo + s=s/nsum + sq=0. + do j=1,jz + if(power(j).le.xmedian) sq=sq + (s2(i,j)/s-1.0)**2 + enddo + variance(i)=sq/nsum + enddo + +C Get grand average, and average of spectra with power below median. + call zero(psa,nbins) + call zero(ref,nbins) + nsum=0 + do j=1,jz + call add(psa,s2(1,j),psa,nbins) + if(power(j).le.xmedian) then + call add(ref,s2(1,j),ref,nbins) + nsum=nsum+1 + endif + enddo + do i=1,nbins !Normalize the averages + psa(i)=psa(i)/jz + ref(i)=ref(i)/nsum + birdie(i)=ref(i) !Copy ref into birdie + enddo + +C Compute smoothed reference spectrum with narrow lines (birdies) removed + do i=4,nbins-3 + rmax=-1.e10 + do k=i-3,i+3 !Get highest point within +/- 3 bins + if(ref(k).gt.rmax) then + rmax=ref(k) + kpk=k + endif + enddo + sum=0. + nsum=0 + do k=i-3,i+3 + if(abs(k-kpk).gt.1) then + sum=sum+ref(k) + nsum=nsum+1 + endif + enddo + ref2(i)=sum/nsum + enddo + call move(ref2(4),ref(4),nbins-6) !Copy smoothed ref back into ref + + call pctile(ref(4),ref2,nbins-6,50,xmedian) !Get median in-band level + +C Fix ends of reference spectrum + do i=1,3 + ref(i)=ref(4) + ref(nbins+1-i)=ref(nbins-3) + enddo + + facmax=30.0/xmedian + do i=1,nbins !Flatten the 2d spectrum + fac=xmedian/ref(i) + fac=min(fac,facmax) + do j=1,jz + s2(i,j)=fac*s2(i,j) + enddo + psa(i)=dB(psa(i)) + 25. + ref(i)=dB(ref(i)) + 25. + birdie(i)=db(birdie(i)) + 25. + enddo + +900 continue + return + end diff --git a/four2.f b/four2.f index c6bc9441a..b3f4aeaa9 100755 --- a/four2.f +++ b/four2.f @@ -1,350 +1,350 @@ - SUBROUTINE FOUR2a (DATA,N,NDIM,ISIGN,IFORM) - -C Cooley-Tukey fast Fourier transform in USASI basic Fortran. -C multi-dimensional transform, each dimension a power of two, -C complex or real data. - -C TRANSFORM(K1,K2,...) = SUM(DATA(J1,J2,...)*EXP(ISIGN*2*PI*SQRT(-1) -C *((J1-1)*(K1-1)/N(1)+(J2-1)*(K2-1)/N(2)+...))), summed for all -C J1 and K1 from 1 to N(1), J2 and K2 from 1 TO N(2), -C etc, for all NDIM subscripts. NDIM must be positive and -C each N(IDIM) must be a power of two. ISIGN is +1 or -1. -C Let NTOT = N(1)*N(2)*...*N(NDIM). Then a -1 transform -C followed by a +1 one (or vice versa) returns NTOT -C times the original data. - -C IFORM = 1, 0 or -1, as data is -C complex, real, or the first half of a complex array. Transform -C values are returned in array DATA. They are complex, real, or -C the first half of a complex array, as IFORM = 1, -1 or 0. - -C The transform of a real array (IFORM = 0) dimensioned N(1) by N(2) -C by ... will be returned in the same array, now considered to -C be complex of dimensions N(1)/2+1 by N(2) by .... Note that if -C IFORM = 0 or -1, N(1) must be even, and enough room must be -C reserved. The missing values may be obtained by complex conjuga- -C tion. - -C The reverse transformation of a half complex array dimensioned -C N(1)/2+1 by N(2) by ..., is accomplished by setting IFORM -C to -1. In the N array, N(1) must be the true N(1), not N(1)/2+1. -C The transform will be real and returned to the input array. - -C Running time is proportional to NTOT*LOG2(NTOT), rather than -C the naive NTOT**2. Furthermore, less error is built up. - -C Written by Norman Brenner of MIT Lincoln Laboratory, January 1969. -C See IEEE Audio Transactions (June 1967), Special issue on FFT. - - parameter(NMAX=2048*1024) - DIMENSION DATA(NMAX), N(1) - NTOT=1 - DO 10 IDIM=1,NDIM - 10 NTOT=NTOT*N(IDIM) - IF (IFORM) 70,20,20 - 20 NREM=NTOT - DO 60 IDIM=1,NDIM - NREM=NREM/N(IDIM) - NPREV=NTOT/(N(IDIM)*NREM) - NCURR=N(IDIM) - IF (IDIM-1+IFORM) 30,30,40 - 30 NCURR=NCURR/2 - 40 CALL BITRV (DATA,NPREV,NCURR,NREM) - CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN) - IF (IDIM-1+IFORM) 50,50,60 - 50 CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM) - NTOT=(NTOT/N(1))*(N(1)/2+1) - 60 CONTINUE - RETURN - 70 NTOT=(NTOT/N(1))*(N(1)/2+1) - NREM=1 - DO 100 JDIM=1,NDIM - IDIM=NDIM+1-JDIM - NCURR=N(IDIM) - IF (IDIM-1) 80,80,90 - 80 NCURR=NCURR/2 - CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM) - NTOT=NTOT/(N(1)/2+1)*N(1) - 90 NPREV=NTOT/(N(IDIM)*NREM) - CALL BITRV (DATA,NPREV,NCURR,NREM) - CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN) - 100 NREM=NREM*N(IDIM) - RETURN - END - SUBROUTINE BITRV (DATA,NPREV,N,NREM) -C SHUFFLE THE DATA BY BIT REVERSAL. -C DIMENSION DATA(NPREV,N,NREM) -C COMPLEX DATA -C EXCHANGE DATA(J1,J4REV,J5) WITH DATA(J1,J4,J5) FOR ALL J1 FROM 1 -C TO NPREV, ALL J4 FROM 1 TO N (WHICH MUST BE A POWER OF TWO), AND -C ALL J5 FROM 1 TO NREM. J4REV-1 IS THE BIT REVERSAL OF J4-1. E.G. -C SUPPOSE N = 32. THEN FOR J4-1 = 10011, J4REV-1 = 11001, ETC. - parameter(NMAX=2048*1024) - DIMENSION DATA(NMAX) - IP0=2 - IP1=IP0*NPREV - IP4=IP1*N - IP5=IP4*NREM - I4REV=1 -C I4REV = 1+(J4REV-1)*IP1 - DO 60 I4=1,IP4,IP1 -C I4 = 1+(J4-1)*IP1 - IF (I4-I4REV) 10,30,30 - 10 I1MAX=I4+IP1-IP0 - DO 20 I1=I4,I1MAX,IP0 -C I1 = 1+(J1-1)*IP0+(J4-1)*IP1 - DO 20 I5=I1,IP5,IP4 -C I5 = 1+(J1-1)*IP0+(J4-1)*IP1+(J5-1)*IP4 - I5REV=I4REV+I5-I4 -C I5REV = 1+(J1-1)*IP0+(J4REV-1)*IP1+(J5-1)*IP4 - TEMPR=DATA(I5) - TEMPI=DATA(I5+1) - DATA(I5)=DATA(I5REV) - DATA(I5+1)=DATA(I5REV+1) - DATA(I5REV)=TEMPR - 20 DATA(I5REV+1)=TEMPI -C ADD ONE WITH DOWNWARD CARRY TO THE HIGH ORDER BIT OF J4REV-1. - 30 IP2=IP4/2 - 40 IF (I4REV-IP2) 60,60,50 - 50 I4REV=I4REV-IP2 - IP2=IP2/2 - IF (IP2-IP1) 60,40,40 - 60 I4REV=I4REV+IP2 - RETURN - END - SUBROUTINE COOL2 (DATA,NPREV,N,NREM,ISIGN) -C DISCRETE FOURIER TRANSFORM OF LENGTH N. IN-PLACE COOLEY-TUKEY -C ALGORITHM, BIT-REVERSED TO NORMAL ORDER, SANDE-TUKEY PHASE SHIFTS. -C DIMENSION DATA(NPREV,N,NREM) -C COMPLEX DATA -C DATA(J1,K4,J5) = SUM(DATA(J1,J4,J5)*EXP(ISIGN*2*PI*I*(J4-1)* -C (K4-1)/N)), SUMMED OVER J4 = 1 TO N FOR ALL J1 FROM 1 TO NPREV, -C K4 FROM 1 TO N AND J5 FROM 1 TO NREM. N MUST BE A POWER OF TWO. -C METHOD--LET IPREV TAKE THE VALUES 1, 2 OR 4, 4 OR 8, ..., N/16, -C N/4, N. THE CHOICE BETWEEN 2 OR 4, ETC., DEPENDS ON WHETHER N IS -C A POWER OF FOUR. DEFINE IFACT = 2 OR 4, THE NEXT FACTOR THAT -C IPREV MUST TAKE, AND IREM = N/(IFACT*IPREV). THEN-- -C DIMENSION DATA(NPREV,IPREV,IFACT,IREM,NREM) -C COMPLEX DATA -C DATA(J1,J2,K3,J4,J5) = SUM(DATA(J1,J2,J3,J4,J5)*EXP(ISIGN*2*PI*I* -C (K3-1)*((J3-1)/IFACT+(J2-1)/(IFACT*IPREV)))), SUMMED OVER J3 = 1 -C TO IFACT FOR ALL J1 FROM 1 TO NPREV, J2 FROM 1 TO IPREV, K3 FROM -C 1 TO IFACT, J4 FROM 1 TO IREM AND J5 FROM 1 TO NREM. THIS IS -C A PHASE-SHIFTED DISCRETE FOURIER TRANSFORM OF LENGTH IFACT. -C FACTORING N BY FOURS SAVES ABOUT TWENTY FIVE PERCENT OVER FACTOR- -C ING BY TWOS. DATA MUST BE BIT-REVERSED INITIALLY. -C IT IS NOT NECESSARY TO REWRITE THIS SUBROUTINE INTO COMPLEX -C NOTATION SO LONG AS THE FORTRAN COMPILER USED STORES REAL AND -C IMAGINARY PARTS IN ADJACENT STORAGE LOCATIONS. IT MUST ALSO -C STORE ARRAYS WITH THE FIRST SUBSCRIPT INCREASING FASTEST. - parameter(NMAX=2048*1024) - DIMENSION DATA(NMAX) - - real*8 twopi,wstpr,wstpi,wr,wi,w2r,w2i,w3r,w3i,wtempr - - TWOPI=6.2831853072*FLOAT(ISIGN) - IP0=2 - IP1=IP0*NPREV - IP4=IP1*N - IP5=IP4*NREM - IP2=IP1 -C IP2=IP1*IPROD - NPART=N - 10 IF (NPART-2) 60,30,20 - 20 NPART=NPART/4 - GO TO 10 -C DO A FOURIER TRANSFORM OF LENGTH TWO - 30 IF (IP2-IP4) 40,160,160 - 40 IP3=IP2*2 -C IP3=IP2*IFACT - DO 50 I1=1,IP1,IP0 -C I1 = 1+(J1-1)*IP0 - DO 50 I5=I1,IP5,IP3 -C I5 = 1+(J1-1)*IP0+(J4-1)*IP3+(J5-1)*IP4 - I3A=I5 - I3B=I3A+IP2 -C I3 = 1+(J1-1)*IP0+(J2-1)*IP1+(J3-1)*IP2+(J4-1)*IP3+(J5-1)*IP4 - TEMPR=DATA(I3B) - TEMPI=DATA(I3B+1) - DATA(I3B)=DATA(I3A)-TEMPR - DATA(I3B+1)=DATA(I3A+1)-TEMPI - DATA(I3A)=DATA(I3A)+TEMPR - 50 DATA(I3A+1)=DATA(I3A+1)+TEMPI - IP2=IP3 -C DO A FOURIER TRANSFORM OF LENGTH FOUR (FROM BIT REVERSED ORDER) - 60 IF (IP2-IP4) 70,160,160 - 70 IP3=IP2*4 -C IP3=IP2*IFACT -C COMPUTE TWOPI THRU WR AND WI IN DOUBLE PRECISION, IF AVAILABLE. - THETA=TWOPI/FLOAT(IP3/IP1) - SINTH=SIN(THETA/2) - WSTPR=-2*SINTH*SINTH - WSTPI=SIN(THETA) - WR=1. - WI=0. - DO 150 I2=1,IP2,IP1 -C I2 = 1+(J2-1)*IP1 - IF (I2-1) 90,90,80 - 80 W2R=WR*WR-WI*WI - W2I=2*WR*WI - W3R=W2R*WR-W2I*WI - W3I=W2R*WI+W2I*WR - 90 I1MAX=I2+IP1-IP0 - DO 140 I1=I2,I1MAX,IP0 -C I1 = 1+(J1-1)*IP0+(J2-1)*IP1 - DO 140 I5=I1,IP5,IP3 -C I5 = 1+(J1-1)*IP0+(J2-1)*IP1+(J4-1)*IP3+(J5-1)*IP4 - I3A=I5 - I3B=I3A+IP2 - I3C=I3B+IP2 - I3D=I3C+IP2 -C I3 = 1+(J1-1)*IP0+(J2-1)*IP1+(J3-1)*IP2+(J4-1)*IP3+(J5-1)*IP4 - IF (I2-1) 110,110,100 -C APPLY THE PHASE SHIFT FACTORS - 100 TEMPR=DATA(I3B) - DATA(I3B)=W2R*DATA(I3B)-W2I*DATA(I3B+1) - DATA(I3B+1)=W2R*DATA(I3B+1)+W2I*TEMPR - TEMPR=DATA(I3C) - DATA(I3C)=WR*DATA(I3C)-WI*DATA(I3C+1) - DATA(I3C+1)=WR*DATA(I3C+1)+WI*TEMPR - TEMPR=DATA(I3D) - DATA(I3D)=W3R*DATA(I3D)-W3I*DATA(I3D+1) - DATA(I3D+1)=W3R*DATA(I3D+1)+W3I*TEMPR - 110 T0R=DATA(I3A)+DATA(I3B) - T0I=DATA(I3A+1)+DATA(I3B+1) - T1R=DATA(I3A)-DATA(I3B) - T1I=DATA(I3A+1)-DATA(I3B+1) - T2R=DATA(I3C)+DATA(I3D) - T2I=DATA(I3C+1)+DATA(I3D+1) - T3R=DATA(I3C)-DATA(I3D) - T3I=DATA(I3C+1)-DATA(I3D+1) - DATA(I3A)=T0R+T2R - DATA(I3A+1)=T0I+T2I - DATA(I3C)=T0R-T2R - DATA(I3C+1)=T0I-T2I - IF (ISIGN) 120,120,130 - 120 T3R=-T3R - T3I=-T3I - 130 DATA(I3B)=T1R-T3I - DATA(I3B+1)=T1I+T3R - DATA(I3D)=T1R+T3I - 140 DATA(I3D+1)=T1I-T3R - WTEMPR=WR - WR=WSTPR*WTEMPR-WSTPI*WI+WTEMPR - 150 WI=WSTPR*WI+WSTPI*WTEMPR+WI - IP2=IP3 - GO TO 60 - 160 RETURN - END - SUBROUTINE FIXRL (DATA,N,NREM,ISIGN,IFORM) -C FOR IFORM = 0, CONVERT THE TRANSFORM OF A DOUBLED-UP REAL ARRAY, -C CONSIDERED COMPLEX, INTO ITS TRUE TRANSFORM. SUPPLY ONLY THE -C FIRST HALF OF THE COMPLEX TRANSFORM, AS THE SECOND HALF HAS -C CONJUGATE SYMMETRY. FOR IFORM = -1, CONVERT THE FIRST HALF -C OF THE TRUE TRANSFORM INTO THE TRANSFORM OF A DOUBLED-UP REAL -C ARRAY. N MUST BE EVEN. -C USING COMPLEX NOTATION AND SUBSCRIPTS STARTING AT ZERO, THE -C TRANSFORMATION IS-- -C DIMENSION DATA(N,NREM) -C ZSTP = EXP(ISIGN*2*PI*I/N) -C DO 10 I2=0,NREM-1 -C DATA(0,I2) = CONJ(DATA(0,I2))*(1+I) -C DO 10 I1=1,N/4 -C Z = (1+(2*IFORM+1)*I*ZSTP**I1)/2 -C I1CNJ = N/2-I1 -C DIF = DATA(I1,I2)-CONJ(DATA(I1CNJ,I2)) -C TEMP = Z*DIF -C DATA(I1,I2) = (DATA(I1,I2)-TEMP)*(1-IFORM) -C 10 DATA(I1CNJ,I2) = (DATA(I1CNJ,I2)+CONJ(TEMP))*(1-IFORM) -C IF I1=I1CNJ, THE CALCULATION FOR THAT VALUE COLLAPSES INTO -C A SIMPLE CONJUGATION OF DATA(I1,I2). - parameter(NMAX=2048*1024) - DIMENSION DATA(NMAX) - TWOPI=6.283185307*FLOAT(ISIGN) - IP0=2 - IP1=IP0*(N/2) - IP2=IP1*NREM - IF (IFORM) 10,70,70 -C PACK THE REAL INPUT VALUES (TWO PER COLUMN) - 10 J1=IP1+1 - DATA(2)=DATA(J1) - IF (NREM-1) 70,70,20 - 20 J1=J1+IP0 - I2MIN=IP1+1 - DO 60 I2=I2MIN,IP2,IP1 - DATA(I2)=DATA(J1) - J1=J1+IP0 - IF (N-2) 50,50,30 - 30 I1MIN=I2+IP0 - I1MAX=I2+IP1-IP0 - DO 40 I1=I1MIN,I1MAX,IP0 - DATA(I1)=DATA(J1) - DATA(I1+1)=DATA(J1+1) - 40 J1=J1+IP0 - 50 DATA(I2+1)=DATA(J1) - 60 J1=J1+IP0 - 70 DO 80 I2=1,IP2,IP1 - TEMPR=DATA(I2) - DATA(I2)=DATA(I2)+DATA(I2+1) - 80 DATA(I2+1)=TEMPR-DATA(I2+1) - IF (N-2) 200,200,90 - 90 THETA=TWOPI/FLOAT(N) - SINTH=SIN(THETA/2.) - ZSTPR=-2.*SINTH*SINTH - ZSTPI=SIN(THETA) - ZR=(1.-ZSTPI)/2. - ZI=(1.+ZSTPR)/2. - IF (IFORM) 100,110,110 - 100 ZR=1.-ZR - ZI=-ZI - 110 I1MIN=IP0+1 - I1MAX=IP0*(N/4)+1 - DO 190 I1=I1MIN,I1MAX,IP0 - DO 180 I2=I1,IP2,IP1 - I2CNJ=IP0*(N/2+1)-2*I1+I2 - IF (I2-I2CNJ) 150,120,120 - 120 IF (ISIGN*(2*IFORM+1)) 130,140,140 - 130 DATA(I2+1)=-DATA(I2+1) - 140 IF (IFORM) 170,180,180 - 150 DIFR=DATA(I2)-DATA(I2CNJ) - DIFI=DATA(I2+1)+DATA(I2CNJ+1) - TEMPR=DIFR*ZR-DIFI*ZI - TEMPI=DIFR*ZI+DIFI*ZR - DATA(I2)=DATA(I2)-TEMPR - DATA(I2+1)=DATA(I2+1)-TEMPI - DATA(I2CNJ)=DATA(I2CNJ)+TEMPR - DATA(I2CNJ+1)=DATA(I2CNJ+1)-TEMPI - IF (IFORM) 160,180,180 - 160 DATA(I2CNJ)=DATA(I2CNJ)+DATA(I2CNJ) - DATA(I2CNJ+1)=DATA(I2CNJ+1)+DATA(I2CNJ+1) - 170 DATA(I2)=DATA(I2)+DATA(I2) - DATA(I2+1)=DATA(I2+1)+DATA(I2+1) - 180 CONTINUE - TEMPR=ZR-.5 - ZR=ZSTPR*TEMPR-ZSTPI*ZI+ZR - 190 ZI=ZSTPR*ZI+ZSTPI*TEMPR+ZI -C RECURSION SAVES TIME, AT A SLIGHT LOSS IN ACCURACY. IF AVAILABLE, -C USE DOUBLE PRECISION TO COMPUTE ZR AND ZI. - 200 IF (IFORM) 270,210,210 -C UNPACK THE REAL TRANSFORM VALUES (TWO PER COLUMN) - 210 I2=IP2+1 - I1=I2 - J1=IP0*(N/2+1)*NREM+1 - GO TO 250 - 220 DATA(J1)=DATA(I1) - DATA(J1+1)=DATA(I1+1) - I1=I1-IP0 - J1=J1-IP0 - 230 IF (I2-I1) 220,240,240 - 240 DATA(J1)=DATA(I1) - DATA(J1+1)=0. - 250 I2=I2-IP1 - J1=J1-IP0 - DATA(J1)=DATA(I2+1) - DATA(J1+1)=0. - I1=I1-IP0 - J1=J1-IP0 - IF (I2-1) 260,260,230 - 260 DATA(2)=0. - 270 RETURN - END + SUBROUTINE FOUR2a (DATA,N,NDIM,ISIGN,IFORM) + +C Cooley-Tukey fast Fourier transform in USASI basic Fortran. +C multi-dimensional transform, each dimension a power of two, +C complex or real data. + +C TRANSFORM(K1,K2,...) = SUM(DATA(J1,J2,...)*EXP(ISIGN*2*PI*SQRT(-1) +C *((J1-1)*(K1-1)/N(1)+(J2-1)*(K2-1)/N(2)+...))), summed for all +C J1 and K1 from 1 to N(1), J2 and K2 from 1 TO N(2), +C etc, for all NDIM subscripts. NDIM must be positive and +C each N(IDIM) must be a power of two. ISIGN is +1 or -1. +C Let NTOT = N(1)*N(2)*...*N(NDIM). Then a -1 transform +C followed by a +1 one (or vice versa) returns NTOT +C times the original data. + +C IFORM = 1, 0 or -1, as data is +C complex, real, or the first half of a complex array. Transform +C values are returned in array DATA. They are complex, real, or +C the first half of a complex array, as IFORM = 1, -1 or 0. + +C The transform of a real array (IFORM = 0) dimensioned N(1) by N(2) +C by ... will be returned in the same array, now considered to +C be complex of dimensions N(1)/2+1 by N(2) by .... Note that if +C IFORM = 0 or -1, N(1) must be even, and enough room must be +C reserved. The missing values may be obtained by complex conjuga- +C tion. + +C The reverse transformation of a half complex array dimensioned +C N(1)/2+1 by N(2) by ..., is accomplished by setting IFORM +C to -1. In the N array, N(1) must be the true N(1), not N(1)/2+1. +C The transform will be real and returned to the input array. + +C Running time is proportional to NTOT*LOG2(NTOT), rather than +C the naive NTOT**2. Furthermore, less error is built up. + +C Written by Norman Brenner of MIT Lincoln Laboratory, January 1969. +C See IEEE Audio Transactions (June 1967), Special issue on FFT. + + parameter(NMAX=2048*1024) + DIMENSION DATA(NMAX), N(1) + NTOT=1 + DO 10 IDIM=1,NDIM + 10 NTOT=NTOT*N(IDIM) + IF (IFORM) 70,20,20 + 20 NREM=NTOT + DO 60 IDIM=1,NDIM + NREM=NREM/N(IDIM) + NPREV=NTOT/(N(IDIM)*NREM) + NCURR=N(IDIM) + IF (IDIM-1+IFORM) 30,30,40 + 30 NCURR=NCURR/2 + 40 CALL BITRV (DATA,NPREV,NCURR,NREM) + CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN) + IF (IDIM-1+IFORM) 50,50,60 + 50 CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM) + NTOT=(NTOT/N(1))*(N(1)/2+1) + 60 CONTINUE + RETURN + 70 NTOT=(NTOT/N(1))*(N(1)/2+1) + NREM=1 + DO 100 JDIM=1,NDIM + IDIM=NDIM+1-JDIM + NCURR=N(IDIM) + IF (IDIM-1) 80,80,90 + 80 NCURR=NCURR/2 + CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM) + NTOT=NTOT/(N(1)/2+1)*N(1) + 90 NPREV=NTOT/(N(IDIM)*NREM) + CALL BITRV (DATA,NPREV,NCURR,NREM) + CALL COOL2 (DATA,NPREV,NCURR,NREM,ISIGN) + 100 NREM=NREM*N(IDIM) + RETURN + END + SUBROUTINE BITRV (DATA,NPREV,N,NREM) +C SHUFFLE THE DATA BY BIT REVERSAL. +C DIMENSION DATA(NPREV,N,NREM) +C COMPLEX DATA +C EXCHANGE DATA(J1,J4REV,J5) WITH DATA(J1,J4,J5) FOR ALL J1 FROM 1 +C TO NPREV, ALL J4 FROM 1 TO N (WHICH MUST BE A POWER OF TWO), AND +C ALL J5 FROM 1 TO NREM. J4REV-1 IS THE BIT REVERSAL OF J4-1. E.G. +C SUPPOSE N = 32. THEN FOR J4-1 = 10011, J4REV-1 = 11001, ETC. + parameter(NMAX=2048*1024) + DIMENSION DATA(NMAX) + IP0=2 + IP1=IP0*NPREV + IP4=IP1*N + IP5=IP4*NREM + I4REV=1 +C I4REV = 1+(J4REV-1)*IP1 + DO 60 I4=1,IP4,IP1 +C I4 = 1+(J4-1)*IP1 + IF (I4-I4REV) 10,30,30 + 10 I1MAX=I4+IP1-IP0 + DO 20 I1=I4,I1MAX,IP0 +C I1 = 1+(J1-1)*IP0+(J4-1)*IP1 + DO 20 I5=I1,IP5,IP4 +C I5 = 1+(J1-1)*IP0+(J4-1)*IP1+(J5-1)*IP4 + I5REV=I4REV+I5-I4 +C I5REV = 1+(J1-1)*IP0+(J4REV-1)*IP1+(J5-1)*IP4 + TEMPR=DATA(I5) + TEMPI=DATA(I5+1) + DATA(I5)=DATA(I5REV) + DATA(I5+1)=DATA(I5REV+1) + DATA(I5REV)=TEMPR + 20 DATA(I5REV+1)=TEMPI +C ADD ONE WITH DOWNWARD CARRY TO THE HIGH ORDER BIT OF J4REV-1. + 30 IP2=IP4/2 + 40 IF (I4REV-IP2) 60,60,50 + 50 I4REV=I4REV-IP2 + IP2=IP2/2 + IF (IP2-IP1) 60,40,40 + 60 I4REV=I4REV+IP2 + RETURN + END + SUBROUTINE COOL2 (DATA,NPREV,N,NREM,ISIGN) +C DISCRETE FOURIER TRANSFORM OF LENGTH N. IN-PLACE COOLEY-TUKEY +C ALGORITHM, BIT-REVERSED TO NORMAL ORDER, SANDE-TUKEY PHASE SHIFTS. +C DIMENSION DATA(NPREV,N,NREM) +C COMPLEX DATA +C DATA(J1,K4,J5) = SUM(DATA(J1,J4,J5)*EXP(ISIGN*2*PI*I*(J4-1)* +C (K4-1)/N)), SUMMED OVER J4 = 1 TO N FOR ALL J1 FROM 1 TO NPREV, +C K4 FROM 1 TO N AND J5 FROM 1 TO NREM. N MUST BE A POWER OF TWO. +C METHOD--LET IPREV TAKE THE VALUES 1, 2 OR 4, 4 OR 8, ..., N/16, +C N/4, N. THE CHOICE BETWEEN 2 OR 4, ETC., DEPENDS ON WHETHER N IS +C A POWER OF FOUR. DEFINE IFACT = 2 OR 4, THE NEXT FACTOR THAT +C IPREV MUST TAKE, AND IREM = N/(IFACT*IPREV). THEN-- +C DIMENSION DATA(NPREV,IPREV,IFACT,IREM,NREM) +C COMPLEX DATA +C DATA(J1,J2,K3,J4,J5) = SUM(DATA(J1,J2,J3,J4,J5)*EXP(ISIGN*2*PI*I* +C (K3-1)*((J3-1)/IFACT+(J2-1)/(IFACT*IPREV)))), SUMMED OVER J3 = 1 +C TO IFACT FOR ALL J1 FROM 1 TO NPREV, J2 FROM 1 TO IPREV, K3 FROM +C 1 TO IFACT, J4 FROM 1 TO IREM AND J5 FROM 1 TO NREM. THIS IS +C A PHASE-SHIFTED DISCRETE FOURIER TRANSFORM OF LENGTH IFACT. +C FACTORING N BY FOURS SAVES ABOUT TWENTY FIVE PERCENT OVER FACTOR- +C ING BY TWOS. DATA MUST BE BIT-REVERSED INITIALLY. +C IT IS NOT NECESSARY TO REWRITE THIS SUBROUTINE INTO COMPLEX +C NOTATION SO LONG AS THE FORTRAN COMPILER USED STORES REAL AND +C IMAGINARY PARTS IN ADJACENT STORAGE LOCATIONS. IT MUST ALSO +C STORE ARRAYS WITH THE FIRST SUBSCRIPT INCREASING FASTEST. + parameter(NMAX=2048*1024) + DIMENSION DATA(NMAX) + + real*8 twopi,wstpr,wstpi,wr,wi,w2r,w2i,w3r,w3i,wtempr + + TWOPI=6.2831853072*FLOAT(ISIGN) + IP0=2 + IP1=IP0*NPREV + IP4=IP1*N + IP5=IP4*NREM + IP2=IP1 +C IP2=IP1*IPROD + NPART=N + 10 IF (NPART-2) 60,30,20 + 20 NPART=NPART/4 + GO TO 10 +C DO A FOURIER TRANSFORM OF LENGTH TWO + 30 IF (IP2-IP4) 40,160,160 + 40 IP3=IP2*2 +C IP3=IP2*IFACT + DO 50 I1=1,IP1,IP0 +C I1 = 1+(J1-1)*IP0 + DO 50 I5=I1,IP5,IP3 +C I5 = 1+(J1-1)*IP0+(J4-1)*IP3+(J5-1)*IP4 + I3A=I5 + I3B=I3A+IP2 +C I3 = 1+(J1-1)*IP0+(J2-1)*IP1+(J3-1)*IP2+(J4-1)*IP3+(J5-1)*IP4 + TEMPR=DATA(I3B) + TEMPI=DATA(I3B+1) + DATA(I3B)=DATA(I3A)-TEMPR + DATA(I3B+1)=DATA(I3A+1)-TEMPI + DATA(I3A)=DATA(I3A)+TEMPR + 50 DATA(I3A+1)=DATA(I3A+1)+TEMPI + IP2=IP3 +C DO A FOURIER TRANSFORM OF LENGTH FOUR (FROM BIT REVERSED ORDER) + 60 IF (IP2-IP4) 70,160,160 + 70 IP3=IP2*4 +C IP3=IP2*IFACT +C COMPUTE TWOPI THRU WR AND WI IN DOUBLE PRECISION, IF AVAILABLE. + THETA=TWOPI/FLOAT(IP3/IP1) + SINTH=SIN(THETA/2) + WSTPR=-2*SINTH*SINTH + WSTPI=SIN(THETA) + WR=1. + WI=0. + DO 150 I2=1,IP2,IP1 +C I2 = 1+(J2-1)*IP1 + IF (I2-1) 90,90,80 + 80 W2R=WR*WR-WI*WI + W2I=2*WR*WI + W3R=W2R*WR-W2I*WI + W3I=W2R*WI+W2I*WR + 90 I1MAX=I2+IP1-IP0 + DO 140 I1=I2,I1MAX,IP0 +C I1 = 1+(J1-1)*IP0+(J2-1)*IP1 + DO 140 I5=I1,IP5,IP3 +C I5 = 1+(J1-1)*IP0+(J2-1)*IP1+(J4-1)*IP3+(J5-1)*IP4 + I3A=I5 + I3B=I3A+IP2 + I3C=I3B+IP2 + I3D=I3C+IP2 +C I3 = 1+(J1-1)*IP0+(J2-1)*IP1+(J3-1)*IP2+(J4-1)*IP3+(J5-1)*IP4 + IF (I2-1) 110,110,100 +C APPLY THE PHASE SHIFT FACTORS + 100 TEMPR=DATA(I3B) + DATA(I3B)=W2R*DATA(I3B)-W2I*DATA(I3B+1) + DATA(I3B+1)=W2R*DATA(I3B+1)+W2I*TEMPR + TEMPR=DATA(I3C) + DATA(I3C)=WR*DATA(I3C)-WI*DATA(I3C+1) + DATA(I3C+1)=WR*DATA(I3C+1)+WI*TEMPR + TEMPR=DATA(I3D) + DATA(I3D)=W3R*DATA(I3D)-W3I*DATA(I3D+1) + DATA(I3D+1)=W3R*DATA(I3D+1)+W3I*TEMPR + 110 T0R=DATA(I3A)+DATA(I3B) + T0I=DATA(I3A+1)+DATA(I3B+1) + T1R=DATA(I3A)-DATA(I3B) + T1I=DATA(I3A+1)-DATA(I3B+1) + T2R=DATA(I3C)+DATA(I3D) + T2I=DATA(I3C+1)+DATA(I3D+1) + T3R=DATA(I3C)-DATA(I3D) + T3I=DATA(I3C+1)-DATA(I3D+1) + DATA(I3A)=T0R+T2R + DATA(I3A+1)=T0I+T2I + DATA(I3C)=T0R-T2R + DATA(I3C+1)=T0I-T2I + IF (ISIGN) 120,120,130 + 120 T3R=-T3R + T3I=-T3I + 130 DATA(I3B)=T1R-T3I + DATA(I3B+1)=T1I+T3R + DATA(I3D)=T1R+T3I + 140 DATA(I3D+1)=T1I-T3R + WTEMPR=WR + WR=WSTPR*WTEMPR-WSTPI*WI+WTEMPR + 150 WI=WSTPR*WI+WSTPI*WTEMPR+WI + IP2=IP3 + GO TO 60 + 160 RETURN + END + SUBROUTINE FIXRL (DATA,N,NREM,ISIGN,IFORM) +C FOR IFORM = 0, CONVERT THE TRANSFORM OF A DOUBLED-UP REAL ARRAY, +C CONSIDERED COMPLEX, INTO ITS TRUE TRANSFORM. SUPPLY ONLY THE +C FIRST HALF OF THE COMPLEX TRANSFORM, AS THE SECOND HALF HAS +C CONJUGATE SYMMETRY. FOR IFORM = -1, CONVERT THE FIRST HALF +C OF THE TRUE TRANSFORM INTO THE TRANSFORM OF A DOUBLED-UP REAL +C ARRAY. N MUST BE EVEN. +C USING COMPLEX NOTATION AND SUBSCRIPTS STARTING AT ZERO, THE +C TRANSFORMATION IS-- +C DIMENSION DATA(N,NREM) +C ZSTP = EXP(ISIGN*2*PI*I/N) +C DO 10 I2=0,NREM-1 +C DATA(0,I2) = CONJ(DATA(0,I2))*(1+I) +C DO 10 I1=1,N/4 +C Z = (1+(2*IFORM+1)*I*ZSTP**I1)/2 +C I1CNJ = N/2-I1 +C DIF = DATA(I1,I2)-CONJ(DATA(I1CNJ,I2)) +C TEMP = Z*DIF +C DATA(I1,I2) = (DATA(I1,I2)-TEMP)*(1-IFORM) +C 10 DATA(I1CNJ,I2) = (DATA(I1CNJ,I2)+CONJ(TEMP))*(1-IFORM) +C IF I1=I1CNJ, THE CALCULATION FOR THAT VALUE COLLAPSES INTO +C A SIMPLE CONJUGATION OF DATA(I1,I2). + parameter(NMAX=2048*1024) + DIMENSION DATA(NMAX) + TWOPI=6.283185307*FLOAT(ISIGN) + IP0=2 + IP1=IP0*(N/2) + IP2=IP1*NREM + IF (IFORM) 10,70,70 +C PACK THE REAL INPUT VALUES (TWO PER COLUMN) + 10 J1=IP1+1 + DATA(2)=DATA(J1) + IF (NREM-1) 70,70,20 + 20 J1=J1+IP0 + I2MIN=IP1+1 + DO 60 I2=I2MIN,IP2,IP1 + DATA(I2)=DATA(J1) + J1=J1+IP0 + IF (N-2) 50,50,30 + 30 I1MIN=I2+IP0 + I1MAX=I2+IP1-IP0 + DO 40 I1=I1MIN,I1MAX,IP0 + DATA(I1)=DATA(J1) + DATA(I1+1)=DATA(J1+1) + 40 J1=J1+IP0 + 50 DATA(I2+1)=DATA(J1) + 60 J1=J1+IP0 + 70 DO 80 I2=1,IP2,IP1 + TEMPR=DATA(I2) + DATA(I2)=DATA(I2)+DATA(I2+1) + 80 DATA(I2+1)=TEMPR-DATA(I2+1) + IF (N-2) 200,200,90 + 90 THETA=TWOPI/FLOAT(N) + SINTH=SIN(THETA/2.) + ZSTPR=-2.*SINTH*SINTH + ZSTPI=SIN(THETA) + ZR=(1.-ZSTPI)/2. + ZI=(1.+ZSTPR)/2. + IF (IFORM) 100,110,110 + 100 ZR=1.-ZR + ZI=-ZI + 110 I1MIN=IP0+1 + I1MAX=IP0*(N/4)+1 + DO 190 I1=I1MIN,I1MAX,IP0 + DO 180 I2=I1,IP2,IP1 + I2CNJ=IP0*(N/2+1)-2*I1+I2 + IF (I2-I2CNJ) 150,120,120 + 120 IF (ISIGN*(2*IFORM+1)) 130,140,140 + 130 DATA(I2+1)=-DATA(I2+1) + 140 IF (IFORM) 170,180,180 + 150 DIFR=DATA(I2)-DATA(I2CNJ) + DIFI=DATA(I2+1)+DATA(I2CNJ+1) + TEMPR=DIFR*ZR-DIFI*ZI + TEMPI=DIFR*ZI+DIFI*ZR + DATA(I2)=DATA(I2)-TEMPR + DATA(I2+1)=DATA(I2+1)-TEMPI + DATA(I2CNJ)=DATA(I2CNJ)+TEMPR + DATA(I2CNJ+1)=DATA(I2CNJ+1)-TEMPI + IF (IFORM) 160,180,180 + 160 DATA(I2CNJ)=DATA(I2CNJ)+DATA(I2CNJ) + DATA(I2CNJ+1)=DATA(I2CNJ+1)+DATA(I2CNJ+1) + 170 DATA(I2)=DATA(I2)+DATA(I2) + DATA(I2+1)=DATA(I2+1)+DATA(I2+1) + 180 CONTINUE + TEMPR=ZR-.5 + ZR=ZSTPR*TEMPR-ZSTPI*ZI+ZR + 190 ZI=ZSTPR*ZI+ZSTPI*TEMPR+ZI +C RECURSION SAVES TIME, AT A SLIGHT LOSS IN ACCURACY. IF AVAILABLE, +C USE DOUBLE PRECISION TO COMPUTE ZR AND ZI. + 200 IF (IFORM) 270,210,210 +C UNPACK THE REAL TRANSFORM VALUES (TWO PER COLUMN) + 210 I2=IP2+1 + I1=I2 + J1=IP0*(N/2+1)*NREM+1 + GO TO 250 + 220 DATA(J1)=DATA(I1) + DATA(J1+1)=DATA(I1+1) + I1=I1-IP0 + J1=J1-IP0 + 230 IF (I2-I1) 220,240,240 + 240 DATA(J1)=DATA(I1) + DATA(J1+1)=0. + 250 I2=I2-IP1 + J1=J1-IP0 + DATA(J1)=DATA(I2+1) + DATA(J1+1)=0. + I1=I1-IP0 + J1=J1-IP0 + IF (I2-1) 260,260,230 + 260 DATA(2)=0. + 270 RETURN + END diff --git a/four2a.f b/four2a.f index f308ccc75..10b2d5a3b 100644 --- a/four2a.f +++ b/four2a.f @@ -1,75 +1,81 @@ - SUBROUTINE FOUR2a (a,nfft,NDIM,ISIGN,IFORM) - -C IFORM = 1, 0 or -1, as data is -C complex, real, or the first half of a complex array. Transform -C values are returned in array DATA. They are complex, real, or -C the first half of a complex array, as IFORM = 1, -1 or 0. - -C The transform of a real array (IFORM = 0) dimensioned N(1) by N(2) -C by ... will be returned in the same array, now considered to -C be complex of dimensions N(1)/2+1 by N(2) by .... Note that if -C IFORM = 0 or -1, N(1) must be even, and enough room must be -C reserved. The missing values may be obtained by complex conjuga- -C tion. - -C The reverse transformation of a half complex array dimensioned -C N(1)/2+1 by N(2) by ..., is accomplished by setting IFORM -C to -1. In the N array, N(1) must be the true N(1), not N(1)/2+1. -C The transform will be real and returned to the input array. - - parameter (NPMAX=100) - complex a(nfft) - integer nn(NPMAX),ns(NPMAX),nf(NPMAX),nl(NPMAX) - integer plan(NPMAX) - data nplan/0/ - include 'fftw3.f' - save - - if(nfft.lt.0) go to 999 - - nloc=loc(a) - do i=1,nplan - if(nfft.eq.nn(i) .and. isign.eq.ns(i) .and. - + iform.eq.nf(i) .and. nloc.eq.nl(i)) go to 10 - enddo - if(nplan.ge.NPMAX) stop 'Too many FFTW plans requested.' - nplan=nplan+1 - i=nplan - nn(i)=nfft - ns(i)=isign - nf(i)=iform - nl(i)=nloc - -C Planning: FFTW_ESTIMATE, FFTW_MEASURE, FFTW_PATIENT, FFTW_EXHAUSTIVE - nspeed=FFTW_ESTIMATE - if(nfft.le.16384) nspeed=FFTW_MEASURE - - if(isign.eq.-1 .and. iform.eq.1) then - call sfftw_plan_dft_1d_(plan(i),nfft,a,a, - + FFTW_FORWARD,nspeed) - else if(isign.eq.1 .and. iform.eq.1) then - call sfftw_plan_dft_1d_(plan(i),nfft,a,a, - + FFTW_BACKWARD,nspeed) - else if(isign.eq.-1 .and. iform.eq.0) then - call sfftw_plan_dft_r2c_1d_(plan(i),nfft,a,a,nspeed) - else if(isign.eq.1 .and. iform.eq.-1) then - call sfftw_plan_dft_c2r_1d_(plan(i),nfft,a,a,nspeed) - else - stop 'Unsupported request in four2a' - endif - - i=nplan -! write(*,3001) i,nn(i),ns(i),nf(i),nl(i),plan(i) -! 3001 format(6i10) - - 10 call sfftw_execute_(plan(i)) - return - - 999 do i=1,nplan -! print*,i,nn(i),ns(i),nf(i),nl(i),plan(i) - call sfftw_destroy_plan_(plan(i)) - enddo -! print*,'FFTW plans destroyed:',nplan - - return - end + SUBROUTINE FOUR2a (a,nfft,NDIM,ISIGN,IFORM) + +C IFORM = 1, 0 or -1, as data is +C complex, real, or the first half of a complex array. Transform +C values are returned in array DATA. They are complex, real, or +C the first half of a complex array, as IFORM = 1, -1 or 0. + +C The transform of a real array (IFORM = 0) dimensioned N(1) by N(2) +C by ... will be returned in the same array, now considered to +C be complex of dimensions N(1)/2+1 by N(2) by .... Note that if +C IFORM = 0 or -1, N(1) must be even, and enough room must be +C reserved. The missing values may be obtained by complex conjuga- +C tion. + +C The reverse transformation of a half complex array dimensioned +C N(1)/2+1 by N(2) by ..., is accomplished by setting IFORM +C to -1. In the N array, N(1) must be the true N(1), not N(1)/2+1. +C The transform will be real and returned to the input array. + + parameter (NPMAX=100) + complex a(nfft) + complex aa(32768) + integer nn(NPMAX),ns(NPMAX),nf(NPMAX),nl(NPMAX) + integer*8 plan(NPMAX) + data nplan/0/ + include 'fftw3.f' + save + + if(nfft.lt.0) go to 999 + + nloc=loc(a) + do i=1,nplan + if(nfft.eq.nn(i) .and. isign.eq.ns(i) .and. + + iform.eq.nf(i) .and. nloc.eq.nl(i)) go to 10 + enddo + if(nplan.ge.NPMAX) stop 'Too many FFTW plans requested.' + nplan=nplan+1 + i=nplan + nn(i)=nfft + ns(i)=isign + nf(i)=iform + nl(i)=nloc + +C Planning: FFTW_ESTIMATE, FFTW_MEASURE, FFTW_PATIENT, FFTW_EXHAUSTIVE + nspeed=FFTW_ESTIMATE + if(nfft.le.16384) nspeed=FFTW_MEASURE + nspeed=FFTW_MEASURE + if(nfft.le.32768) then + do j=1,nfft + aa(j)=a(j) + enddo + endif + if(isign.eq.-1 .and. iform.eq.1) then + call sfftw_plan_dft_1d_(plan(i),nfft,a,a, + + FFTW_FORWARD,nspeed) + else if(isign.eq.1 .and. iform.eq.1) then + call sfftw_plan_dft_1d_(plan(i),nfft,a,a, + + FFTW_BACKWARD,nspeed) + else if(isign.eq.-1 .and. iform.eq.0) then + call sfftw_plan_dft_r2c_1d_(plan(i),nfft,a,a,nspeed) + else if(isign.eq.1 .and. iform.eq.-1) then + call sfftw_plan_dft_c2r_1d_(plan(i),nfft,a,a,nspeed) + else + stop 'Unsupported request in four2a' + endif + i=nplan + if(nfft.le.32768) then + do j=1,nfft + a(j)=aa(j) + enddo + endif + + 10 call sfftw_execute_(plan(i)) + return + + 999 do i=1,nplan + call sfftw_destroy_plan_(plan(i)) + enddo + + return + end diff --git a/ftn_init.F90 b/ftn_init.F90 index 64ae7cf3a..c8b9a69e6 100644 --- a/ftn_init.F90 +++ b/ftn_init.F90 @@ -69,6 +69,15 @@ subroutine ftn_init err=940) #endif +#ifdef Win32 + open(19,file=appdir(:iz)//'/bandmap.txt',status='unknown', & + share='denynone',err=910) +#else + open(19,file=appdir(:iz)//'/bandmap.txt',status='unknown', & + err=910) +#endif + endfile 19 + #ifdef Win32 open(21,file=appdir(:iz)//'/ALL.TXT',status='unknown', & access='append',share='denynone',err=950) diff --git a/ftsky.f b/ftsky.f index 5a6a93744..4ed6bb82c 100644 --- a/ftsky.f +++ b/ftsky.f @@ -1,24 +1,24 @@ - real function ftsky(l,b) - -C Returns 408 MHz sky temperature for l,b (in degrees), from -C Haslam, et al. survey. Must have already read the entire -C file tsky.dat into memory. - - real*4 l,b - integer*2 nsky - common/sky/ nsky(360,180) - save - - j=nint(b+91.0) - if(j.gt.180) j=180 - xl=l - if(xl.lt.0.0) xl=xl+360.0 - i=nint(xl+1.0) - if(i.gt.360) i=i-360 - ftsky=0.0 - if(i.ge.1 .and. i.le.360 .and. j.ge.1 .and. j.le.180) then - ftsky=0.1*nsky(i,j) - endif - - return - end + real function ftsky(l,b) + +C Returns 408 MHz sky temperature for l,b (in degrees), from +C Haslam, et al. survey. Must have already read the entire +C file tsky.dat into memory. + + real*4 l,b + integer*2 nsky + common/sky/ nsky(360,180) + save + + j=nint(b+91.0) + if(j.gt.180) j=180 + xl=l + if(xl.lt.0.0) xl=xl+360.0 + i=nint(xl+1.0) + if(i.gt.360) i=i-360 + ftsky=0.0 + if(i.ge.1 .and. i.le.360 .and. j.ge.1 .and. j.le.180) then + ftsky=0.1*nsky(i,j) + endif + + return + end diff --git a/gcom1.f90 b/gcom1.f90 index e1578ca28..96d10616c 100644 --- a/gcom1.f90 +++ b/gcom1.f90 @@ -1,51 +1,51 @@ -! Variable Purpose Set in Thread -!--------------------------------------------------------------------------- -integer NRXMAX !Max length of Rx ring buffers -integer NTXMAX !Max length of Tx waveform in samples -parameter(NRXMAX=2097152) ! =2048*1024 -parameter(NTXMAX=1653750) ! =150*11025 -real*8 tbuf !Tsec at time of input callback SoundIn -integer ntrbuf !(obsolete?) -real*8 Tsec !Present time SoundIn,SoundOut -real*8 rxdelay !Delay between PTT=1 and Tx audio SoundIn -real*8 txdelay !Delay from end of Tx Audio and PTT=0 SoundOut -real*8 samfacin !(Input sample rate)/11025 GUI -real*8 samfacout !(Output sample rate)/11025 GUI -real*8 txsnrdb !SNR for simulations GUI -integer*2 y1 !Ring buffer for audio channel 0 SoundIn -integer*2 y2 !Ring buffer for audio channel 1 SoundIn -integer nmax !Actual length of Rx ring buffers GUI -integer iwrite !Write pointer to Rx ring buffer SoundIn -integer iread !Read pointer to Rx ring buffer GUI -integer*2 iwave !Data for audio output SoundIn -integer nwave !Number of samples in iwave SoundIn -integer TxOK !OK to transmit? SoundIn -! NB: TxOK=1 only in SoundIn; TxOK=0 also in GUI -integer Receiving !Actually receiving? SoundIn -integer Transmitting !Actually transmitting? SoundOut -integer TxFirst !Transmit first? GUI -integer TRPeriod !Tx or Rx period in seconds GUI -integer ibuf !Most recent input buffer# SoundIn -integer ibuf0 !Buffer# at start of Rx sequence SoundIn -real ave !(why is this here?) GUI -real rms !(why is this here?) GUI -integer ngo !Set to 0 to terminate audio streams GUI -integer level !S-meter level, 0-100 GUI -integer mute !True means "don't transmit" GUI -integer newdat !New data available for waterfall? GUI -integer ndsec !Dsec in units of 0.1 s GUI -integer ndevin !Device# for audio input GUI -integer ndevout !Device# for audio output GUI -integer mfsample !Measured sample rate, input SoundIn -integer mfsample2 !Measured sample rate, output SoundOut -integer ns0 !Time at last ALL.TXT date entry Decoder -character*12 devin_name,devout_name ! GUI - -common/gcom1/Tbuf(1024),ntrbuf(1024),Tsec,rxdelay,txdelay, & - samfacin,samfacout,txsnrdb,y1(NRXMAX),y2(NRXMAX), & - nmax,iwrite,iread,iwave(NTXMAX),nwave,TxOK,Receiving,Transmitting, & - TxFirst,TRPeriod,ibuf,ibuf0,ave,rms,ngo,level,mute,newdat,ndsec, & - ndevin,ndevout,mfsample,mfsample2,ns0,devin_name,devout_name - -!### volatile /gcom1/ - +! Variable Purpose Set in Thread +!--------------------------------------------------------------------------- +integer NRXMAX !Max length of Rx ring buffers +integer NTXMAX !Max length of Tx waveform in samples +parameter(NRXMAX=2097152) ! =2048*1024 +parameter(NTXMAX=1653750) ! =150*11025 +real*8 tbuf !Tsec at time of input callback SoundIn +integer ntrbuf !(obsolete?) +real*8 Tsec !Present time SoundIn,SoundOut +real*8 rxdelay !Delay between PTT=1 and Tx audio SoundIn +real*8 txdelay !Delay from end of Tx Audio and PTT=0 SoundOut +real*8 samfacin !(Input sample rate)/11025 GUI +real*8 samfacout !(Output sample rate)/11025 GUI +real*8 txsnrdb !SNR for simulations GUI +integer*2 y1 !Ring buffer for audio channel 0 SoundIn +integer*2 y2 !Ring buffer for audio channel 1 SoundIn +integer nmax !Actual length of Rx ring buffers GUI +integer iwrite !Write pointer to Rx ring buffer SoundIn +integer iread !Read pointer to Rx ring buffer GUI +integer*2 iwave !Data for audio output SoundIn +integer nwave !Number of samples in iwave SoundIn +integer TxOK !OK to transmit? SoundIn +! NB: TxOK=1 only in SoundIn; TxOK=0 also in GUI +integer Receiving !Actually receiving? SoundIn +integer Transmitting !Actually transmitting? SoundOut +integer TxFirst !Transmit first? GUI +integer TRPeriod !Tx or Rx period in seconds GUI +integer ibuf !Most recent input buffer# SoundIn +integer ibuf0 !Buffer# at start of Rx sequence SoundIn +real ave !(why is this here?) GUI +real rms !(why is this here?) GUI +integer ngo !Set to 0 to terminate audio streams GUI +integer level !S-meter level, 0-100 GUI +integer mute !True means "don't transmit" GUI +integer newdat !New data available for waterfall? GUI +integer ndsec !Dsec in units of 0.1 s GUI +integer ndevin !Device# for audio input GUI +integer ndevout !Device# for audio output GUI +integer mfsample !Measured sample rate, input SoundIn +integer mfsample2 !Measured sample rate, output SoundOut +integer ns0 !Time at last ALL.TXT date entry Decoder +character*12 devin_name,devout_name ! GUI + +common/gcom1/Tbuf(1024),ntrbuf(1024),Tsec,rxdelay,txdelay, & + samfacin,samfacout,txsnrdb,y1(NRXMAX),y2(NRXMAX), & + nmax,iwrite,iread,iwave(NTXMAX),nwave,TxOK,Receiving,Transmitting, & + TxFirst,TRPeriod,ibuf,ibuf0,ave,rms,ngo,level,mute,newdat,ndsec, & + ndevin,ndevout,mfsample,mfsample2,ns0,devin_name,devout_name + +!### volatile /gcom1/ + diff --git a/gcom2.f90 b/gcom2.f90 index 128e608a5..7c10b0ce9 100644 --- a/gcom2.f90 +++ b/gcom2.f90 @@ -1,100 +1,100 @@ -! Variable Purpose Set in Thread -!------------------------------------------------------------------------- -real ps0 !Spectrum of best ping, FSK441/JT6m Decoder -real psavg !Average spectrum Decoder -real s2 !2d spectrum for horizontal waterfall GUI -real ccf !CCF in time (blue curve) Decoder -real green !Data for green line GUI -integer ngreen !Length of green GUI -real dgain !Digital audio gain setting GUI -integer iter !(why is this here??) -integer ndecoding !Decoder status (see decode2.f90) GUI,Decoder -integer ndecoding0 !Status on previous decode GUI,Decoder -integer mousebutton !Which button was clicked? GUI -integer ndecdone !Is decoder finished? GUI,Decoder -integer npingtime !Time in file of mouse-selected ping GUI,Decoder -integer ierr !(why is this here?) -integer lauto !Are we in Auto mode? GUI -integer mantx !Manual transmission requested? GUI,SoundIn -integer nrestart !True if transmission should restart GUI,SoundIn -integer ntr !Are we in 2nd sequence? SoundIn -integer nmsg !Length of Tx message SoundIn -integer nsave !Which files to save? GUI -integer nadd5 !Prepend 5 sec of 0's before decoding? GUI -integer dftolerance !DF tolerance (Hz) GUI -logical LDecoded !Was a message decoded? Decoder -logical rxdone !Has the Rx sequence finished? SoundIn,Decoder -integer monitoring !Are we monitoring? GUI -integer nzap !Is Zap checked? GUI -integer nsavecum !(why is this here?) -integer minsigdb !Decoder threshold setting GUI -integer nclearave !Set to 1 to clear JT65 avg GUI,Decoder -integer nfreeze !Is Freeze checked? GUI -integer nafc !Is AFC checked? GUI -integer nmode !Which WSJT mode? GUI,Decoder -integer mode65 !JT65 sub-mode (A/B/C ==> 1/2/4) GUI,SoundIn,Decoder -integer nclip !Clipping level GUI -integer ndebug !Write debugging info? GUI -integer nblank !Is NB checked? GUI -integer nfmid !Center frequency of main display GUI -integer nfrange !Frequency range of main display GUI -integer nport !Requested COM port number GUI -integer mousedf !Mouse-selected freq offset, DF GUI -integer neme !EME calls only in deep search? GUI -integer nsked !Sked mode for deep search? GUI -integer naggressive !Is "Aggressive decoding" checked? GUI -integer ntx2 !Is "No shorthands if Tx1" checked? GUI -integer nslim2 !2nd Decoder threshold for FSK441. JT6M GUI -integer nagain !Decode same file again? GUI -integer nsavelast !Save last file? GUI -integer shok !Shorthand messages OK? GUI -integer sendingsh !Sending a shorthand message? SoundIn -integer*2 d2a !Rx data, extracted from y1 Decoder -integer*2 d2b !Rx data, selected by mouse-pick Decoder -integer*2 b !Pixel values for waterfall spectrum GUI -integer jza !Length of data in d2a GUI,Decoder -integer jzb !(why is this here?) -integer ntime !Integer Unix time (now) SoundIn -integer idinterval !Interval between CWIDs, minutes GUI -integer msmax !(why is this here?) -integer lenappdir !Length of Appdir string GUI -integer idf !Frequency offset in Hz Decoder -integer ndiskdat !1 if data read from disk, 0 otherwise GUI -integer nlines !Available lines of waterfall data GUI -integer nflat !Is waterfall to be flattened? GUI -integer ntxreq !Tx msg# requested GUI -integer ntxnow !Tx msg# being sent now GUI -integer ndepth !Requested "depth" of JT65 decoding GUI -integer nspecial !JT65 shorthand msg#: RO=2 RRR=3 73=4 Decoder -integer ndf !Measured DF in Hz Decoder -real ss1 !Magenta curve for JT65 shorthand msg Decoder -real ss2 !Orange curve for JT65 shorthand msg Decoder -character mycall*12 !My call sign GUI -character hiscall*12 !His call sign GUI -character hisgrid*6 !His grid locator GUI -character txmsg*28 !Message to be transmitted GUI -character sending*28 !Message being sent SoundIn -character mode*6 !WSJT operating mode GUI -character utcdate*12 !UTC date GUI -character*24 fname0 !Filenames to be recorded, read, ... Decoder -character*24 fnamea -character*24 fnameb -character*24 decodedfile -character*80 AppDir !WSJT installation directory GUI -character*80 filetokilla !Filenames (full path) Decoder -character*80 filetokillb -character*12 pttport - -common/gcom2/ps0(431),psavg(450),s2(64,3100),ccf(-5:540), & - green(500),ngreen,dgain,iter,ndecoding,ndecoding0,mousebutton, & - ndecdone,npingtime,ierr,lauto,mantx,nrestart,ntr,nmsg,nsave,nadd5, & - dftolerance,LDecoded,rxdone,monitoring,nzap,nsavecum,minsigdb, & - nclearave,nfreeze,nafc,nmode,mode65,nclip,ndebug,nblank,nport, & - mousedf,neme,nsked,naggressive,ntx2,nslim2,nagain,nsavelast, & - shok,sendingsh,d2a(661500),d2b(661500),b(60000),jza,jzb,ntime, & - idinterval,msmax,lenappdir,idf,ndiskdat,nlines,nflat,ntxreq,ntxnow, & - ndepth,nspecial,ndf,nfmid,nfrange,ss1(-224:224),ss2(-224:224), & - mycall,hiscall,hisgrid,txmsg,sending,mode,fname0,fnamea, & - fnameb,decodedfile,AppDir,filetokilla,filetokillb,utcdate,pttport - -!### volatile /gcom2/ +! Variable Purpose Set in Thread +!------------------------------------------------------------------------- +real ps0 !Spectrum of best ping, FSK441/JT6m Decoder +real psavg !Average spectrum Decoder +real s2 !2d spectrum for horizontal waterfall GUI +real ccf !CCF in time (blue curve) Decoder +real green !Data for green line GUI +integer ngreen !Length of green GUI +real dgain !Digital audio gain setting GUI +integer iter !(why is this here??) +integer ndecoding !Decoder status (see decode2.f90) GUI,Decoder +integer ndecoding0 !Status on previous decode GUI,Decoder +integer mousebutton !Which button was clicked? GUI +integer ndecdone !Is decoder finished? GUI,Decoder +integer npingtime !Time in file of mouse-selected ping GUI,Decoder +integer ierr !(why is this here?) +integer lauto !Are we in Auto mode? GUI +integer mantx !Manual transmission requested? GUI,SoundIn +integer nrestart !True if transmission should restart GUI,SoundIn +integer ntr !Are we in 2nd sequence? SoundIn +integer nmsg !Length of Tx message SoundIn +integer nsave !Which files to save? GUI +integer nadd5 !Prepend 5 sec of 0's before decoding? GUI +integer dftolerance !DF tolerance (Hz) GUI +logical LDecoded !Was a message decoded? Decoder +logical rxdone !Has the Rx sequence finished? SoundIn,Decoder +integer monitoring !Are we monitoring? GUI +integer nzap !Is Zap checked? GUI +integer nsavecum !(why is this here?) +integer minsigdb !Decoder threshold setting GUI +integer nclearave !Set to 1 to clear JT65 avg GUI,Decoder +integer nfreeze !Is Freeze checked? GUI +integer nafc !Is AFC checked? GUI +integer nmode !Which WSJT mode? GUI,Decoder +integer mode65 !JT65 sub-mode (A/B/C ==> 1/2/4) GUI,SoundIn,Decoder +integer nclip !Clipping level GUI +integer ndebug !Write debugging info? GUI +integer nblank !Is NB checked? GUI +integer nfmid !Center frequency of main display GUI +integer nfrange !Frequency range of main display GUI +integer nport !Requested COM port number GUI +integer mousedf !Mouse-selected freq offset, DF GUI +integer neme !EME calls only in deep search? GUI +integer nsked !Sked mode for deep search? GUI +integer naggressive !Is "Aggressive decoding" checked? GUI +integer ntx2 !Is "No shorthands if Tx1" checked? GUI +integer nslim2 !2nd Decoder threshold for FSK441. JT6M GUI +integer nagain !Decode same file again? GUI +integer nsavelast !Save last file? GUI +integer shok !Shorthand messages OK? GUI +integer sendingsh !Sending a shorthand message? SoundIn +integer*2 d2a !Rx data, extracted from y1 Decoder +integer*2 d2b !Rx data, selected by mouse-pick Decoder +integer*2 b !Pixel values for waterfall spectrum GUI +integer jza !Length of data in d2a GUI,Decoder +integer jzb !(why is this here?) +integer ntime !Integer Unix time (now) SoundIn +integer idinterval !Interval between CWIDs, minutes GUI +integer msmax !(why is this here?) +integer lenappdir !Length of Appdir string GUI +integer idf !Frequency offset in Hz Decoder +integer ndiskdat !1 if data read from disk, 0 otherwise GUI +integer nlines !Available lines of waterfall data GUI +integer nflat !Is waterfall to be flattened? GUI +integer ntxreq !Tx msg# requested GUI +integer ntxnow !Tx msg# being sent now GUI +integer ndepth !Requested "depth" of JT65 decoding GUI +integer nspecial !JT65 shorthand msg#: RO=2 RRR=3 73=4 Decoder +integer ndf !Measured DF in Hz Decoder +real ss1 !Magenta curve for JT65 shorthand msg Decoder +real ss2 !Orange curve for JT65 shorthand msg Decoder +character mycall*12 !My call sign GUI +character hiscall*12 !His call sign GUI +character hisgrid*6 !His grid locator GUI +character txmsg*28 !Message to be transmitted GUI +character sending*28 !Message being sent SoundIn +character mode*6 !WSJT operating mode GUI +character utcdate*12 !UTC date GUI +character*24 fname0 !Filenames to be recorded, read, ... Decoder +character*24 fnamea +character*24 fnameb +character*24 decodedfile +character*80 AppDir !WSJT installation directory GUI +character*80 filetokilla !Filenames (full path) Decoder +character*80 filetokillb +character*12 pttport + +common/gcom2/ps0(431),psavg(450),s2(64,3100),ccf(-5:540), & + green(500),ngreen,dgain,iter,ndecoding,ndecoding0,mousebutton, & + ndecdone,npingtime,ierr,lauto,mantx,nrestart,ntr,nmsg,nsave,nadd5, & + dftolerance,LDecoded,rxdone,monitoring,nzap,nsavecum,minsigdb, & + nclearave,nfreeze,nafc,nmode,mode65,nclip,ndebug,nblank,nport, & + mousedf,neme,nsked,naggressive,ntx2,nslim2,nagain,nsavelast, & + shok,sendingsh,d2a(661500),d2b(661500),b(60000),jza,jzb,ntime, & + idinterval,msmax,lenappdir,idf,ndiskdat,nlines,nflat,ntxreq,ntxnow, & + ndepth,nspecial,ndf,nfmid,nfrange,ss1(-224:224),ss2(-224:224), & + mycall,hiscall,hisgrid,txmsg,sending,mode,fname0,fnamea, & + fnameb,decodedfile,AppDir,filetokilla,filetokillb,utcdate,pttport + +!### volatile /gcom2/ diff --git a/gcom3.f90 b/gcom3.f90 index 223cf5748..8761efcbc 100644 --- a/gcom3.f90 +++ b/gcom3.f90 @@ -1,20 +1,20 @@ -! Variable Purpose Set in Thread -!------------------------------------------------------------------------- -integer*2 nfmt2 !Standard header for *.WAV file Decoder -integer*2 nchan2 -integer*2 nbitsam2 -integer*2 nbytesam2 -integer*4 nchunk -integer*4 lenfmt -integer*4 nsamrate -integer*4 nbytesec -integer*4 ndata -character*4 ariff -character*4 awave -character*4 afmt -character*4 adata - -common/gcom3/ariff,nchunk,awave,afmt,lenfmt,nfmt2,nchan2,nsamrate, & - nbytesec,nbytesam2,nbitsam2,adata,ndata - -!### volatile /gcom3/ +! Variable Purpose Set in Thread +!------------------------------------------------------------------------- +integer*2 nfmt2 !Standard header for *.WAV file Decoder +integer*2 nchan2 +integer*2 nbitsam2 +integer*2 nbytesam2 +integer*4 nchunk +integer*4 lenfmt +integer*4 nsamrate +integer*4 nbytesec +integer*4 ndata +character*4 ariff +character*4 awave +character*4 afmt +character*4 adata + +common/gcom3/ariff,nchunk,awave,afmt,lenfmt,nfmt2,nchan2,nsamrate, & + nbytesec,nbytesam2,nbitsam2,adata,ndata + +!### volatile /gcom3/ diff --git a/gcom4.f90 b/gcom4.f90 index d7ac35cc8..239f16e30 100644 --- a/gcom4.f90 +++ b/gcom4.f90 @@ -1,10 +1,10 @@ -! Variable Purpose Set in Thread -!------------------------------------------------------------------------- -character addpfx*8 !Add-on prefix, as in ZA/PA2CHR GUI -integer*2 d2c !Rx data recovered from recorded file GUI -integer jzc !Length of data available in d2c GUI -character filename*24 !Name of wave file read from disk GUI - -common/gcom4/addpfx,d2c(661500),jzc,filename - -!### volatile /gcom4/ +! Variable Purpose Set in Thread +!------------------------------------------------------------------------- +character addpfx*8 !Add-on prefix, as in ZA/PA2CHR GUI +integer*2 d2c !Rx data recovered from recorded file GUI +integer jzc !Length of data available in d2c GUI +character filename*24 !Name of wave file read from disk GUI + +common/gcom4/addpfx,d2c(661500),jzc,filename + +!### volatile /gcom4/ diff --git a/gen65.f b/gen65.f index 5d9c768b7..5b3896568 100644 --- a/gen65.f +++ b/gen65.f @@ -1,82 +1,82 @@ - subroutine gen65(message,mode65,samfac,iwave,nwave,sendingsh, - + msgsent) - -C Encodes a JT65 message into a wavefile. - - parameter (NMAX=60*11025) !Max length of wave file - character*22 message !Message to be generated - character*22 msgsent !Message as it will be received - character*3 cok !' ' or 'OOO' - character*6 c1,c2 - real*8 t,dt,phi,f,f0,dfgen,dphi,twopi,samfac,tsymbol - - integer*2 iwave(NMAX) !Generated wave file - integer dgen(12) - integer sent(63) - integer sendingsh - common/c1c2/c1,c2 - include 'prcom.h' - data twopi/6.283185307d0/ - save - - if(abs(pr(1)).ne.1.0) call setup65 - - call chkmsg(message,cok,nspecial,flip) - if(nspecial.eq.0) then - call packmsg(message,dgen) !Pack message into 72 bits - sendingsh=0 - if(iand(dgen(10),8).ne.0) sendingsh=-1 !Plain text flag - call rs_encode(dgen,sent) - call interleave63(sent,1) !Apply interleaving - call graycode(sent,63,1) !Apply Gray code - tsymbol=4096.d0/11025.d0 - nsym=126 !Symbols per transmission - else - tsymbol=16384.d0/11025.d0 - nsym=32 - sendingsh=1 !Flag for shorthand message - endif - -C Set up necessary constants - dt=1.0/(samfac*11025.0) - f0=118*11025.d0/1024 - dfgen=mode65*11025.0/4096.0 - t=0.d0 - phi=0.d0 - k=0 - j0=0 - ndata=(nsym*11025.d0*samfac*tsymbol)/2 - ndata=2*ndata - do i=1,ndata - t=t+dt - j=int(t/tsymbol) + 1 !Symbol number, 1-126 - if(j.ne.j0) then - f=f0 - if(nspecial.ne.0 .and. mod(j,2).eq.0) f=f0+10*nspecial*dfgen - if(nspecial.eq.0 .and. flip*pr(j).lt.0.0) then - k=k+1 - f=f0+(sent(k)+2)*dfgen - endif - dphi=twopi*dt*f - j0=j - endif - phi=phi+dphi - iwave(i)=32767.0*sin(phi) - enddo - - do j=1,5512 !Put another 0.5 sec of silence at end - i=i+1 - iwave(i)=0 - enddo - nwave=i - call unpackmsg(dgen,msgsent) - if(flip.lt.0.0) then - do i=22,1,-1 - if(msgsent(i:i).ne.' ') goto 10 - enddo - 10 msgsent=msgsent(1:i)//' OOO' - endif - - return - end - + subroutine gen65(message,mode65,samfac,iwave,nwave,sendingsh, + + msgsent) + +C Encodes a JT65 message into a wavefile. + + parameter (NMAX=60*11025) !Max length of wave file + character*22 message !Message to be generated + character*22 msgsent !Message as it will be received + character*3 cok !' ' or 'OOO' + character*6 c1,c2 + real*8 t,dt,phi,f,f0,dfgen,dphi,twopi,samfac,tsymbol + + integer*2 iwave(NMAX) !Generated wave file + integer dgen(12) + integer sent(63) + integer sendingsh + common/c1c2/c1,c2 + include 'prcom.h' + data twopi/6.283185307d0/ + save + + if(abs(pr(1)).ne.1.0) call setup65 + + call chkmsg(message,cok,nspecial,flip) + if(nspecial.eq.0) then + call packmsg(message,dgen) !Pack message into 72 bits + sendingsh=0 + if(iand(dgen(10),8).ne.0) sendingsh=-1 !Plain text flag + call rs_encode(dgen,sent) + call interleave63(sent,1) !Apply interleaving + call graycode(sent,63,1) !Apply Gray code + tsymbol=4096.d0/11025.d0 + nsym=126 !Symbols per transmission + else + tsymbol=16384.d0/11025.d0 + nsym=32 + sendingsh=1 !Flag for shorthand message + endif + +C Set up necessary constants + dt=1.0/(samfac*11025.0) + f0=118*11025.d0/1024 + dfgen=mode65*11025.0/4096.0 + t=0.d0 + phi=0.d0 + k=0 + j0=0 + ndata=(nsym*11025.d0*samfac*tsymbol)/2 + ndata=2*ndata + do i=1,ndata + t=t+dt + j=int(t/tsymbol) + 1 !Symbol number, 1-126 + if(j.ne.j0) then + f=f0 + if(nspecial.ne.0 .and. mod(j,2).eq.0) f=f0+10*nspecial*dfgen + if(nspecial.eq.0 .and. flip*pr(j).lt.0.0) then + k=k+1 + f=f0+(sent(k)+2)*dfgen + endif + dphi=twopi*dt*f + j0=j + endif + phi=phi+dphi + iwave(i)=32767.0*sin(phi) + enddo + + do j=1,5512 !Put another 0.5 sec of silence at end + i=i+1 + iwave(i)=0 + enddo + nwave=i + call unpackmsg(dgen,msgsent) + if(flip.lt.0.0) then + do i=22,1,-1 + if(msgsent(i:i).ne.' ') goto 10 + enddo + 10 msgsent=msgsent(1:i)//' OOO' + endif + + return + end + diff --git a/gencwid.f b/gencwid.f index b415ded45..7061610a4 100644 --- a/gencwid.f +++ b/gencwid.f @@ -1,36 +1,36 @@ - subroutine gencwid(msg,wpm,freqcw,samfac,iwave,nwave) - - parameter (NMAX=10*11025) - character msg*22,msg2*22 - integer*2 iwave(NMAX) - - integer*1 idat(460) - real*8 dt,t,twopi,pha,dpha,tdit,samfac - data twopi/6.283185307d0/ - - do i=1,22 - if(msg(i:i).eq.' ') go to 10 - enddo - 10 iz=i-1 - msg2=msg(1:iz)//' ' - call morse(msg2,idat,ndits) !Encode part 1 of msg - - tdit=1.2d0/wpm !Key-down dit time, seconds - dt=1.d0/(11025.d0*samfac) - nwave=ndits*tdit/dt - pha=0. - dpha=twopi*freqcw*dt - t=0.d0 - s=0. - u=wpm/(11025*0.03) - do i=1,nwave - t=t+dt - pha=pha+dpha - j=t/tdit + 1 - s=s + u*(idat(j)-s) - iwave(i)=nint(s*32767.d0*sin(pha)) - enddo - - return - end - + subroutine gencwid(msg,wpm,freqcw,samfac,iwave,nwave) + + parameter (NMAX=10*11025) + character msg*22,msg2*22 + integer*2 iwave(NMAX) + + integer*1 idat(460) + real*8 dt,t,twopi,pha,dpha,tdit,samfac + data twopi/6.283185307d0/ + + do i=1,22 + if(msg(i:i).eq.' ') go to 10 + enddo + 10 iz=i-1 + msg2=msg(1:iz)//' ' + call morse(msg2,idat,ndits) !Encode part 1 of msg + + tdit=1.2d0/wpm !Key-down dit time, seconds + dt=1.d0/(11025.d0*samfac) + nwave=ndits*tdit/dt + pha=0. + dpha=twopi*freqcw*dt + t=0.d0 + s=0. + u=wpm/(11025*0.03) + do i=1,nwave + t=t+dt + pha=pha+dpha + j=t/tdit + 1 + s=s + u*(idat(j)-s) + iwave(i)=nint(s*32767.d0*sin(pha)) + enddo + + return + end + diff --git a/gentone.f b/gentone.f index 1a47ab07b..d827bbff9 100644 --- a/gentone.f +++ b/gentone.f @@ -1,13 +1,13 @@ - subroutine gentone(x,n,k) - - real*4 x(512) - - dt=1.0/11025.0 - f=(n+51)*11025.0/512.0 - do i=1,512 - x(i)=sin(6.2831853*i*dt*f) - enddo - k=k+512 - - return - end + subroutine gentone(x,n,k) + + real*4 x(512) + + dt=1.0/11025.0 + f=(n+51)*11025.0/512.0 + do i=1,512 + x(i)=sin(6.2831853*i*dt*f) + enddo + k=k+512 + + return + end diff --git a/geocentric.f b/geocentric.f index 1767f9cf8..0af575d81 100644 --- a/geocentric.f +++ b/geocentric.f @@ -1,17 +1,17 @@ - subroutine geocentric(alat,elev,hlt,erad) - - implicit real*8 (a-h,o-z) - -C IAU 1976 flattening f, equatorial radius a - f = 1.d0/298.257d0 - a = 6378140.d0 - c = 1.d0/sqrt(1.d0 + (-2.d0 + f)*f*sin(alat)*sin(alat)) - arcf = (a*c + elev)*cos(alat) - arsf = (a*(1.d0 - f)*(1.d0 - f)*c + elev)*sin(alat) - hlt = datan2(arsf,arcf) - erad = sqrt(arcf*arcf + arsf*arsf) - erad = 0.001d0*erad - - return - end - + subroutine geocentric(alat,elev,hlt,erad) + + implicit real*8 (a-h,o-z) + +C IAU 1976 flattening f, equatorial radius a + f = 1.d0/298.257d0 + a = 6378140.d0 + c = 1.d0/sqrt(1.d0 + (-2.d0 + f)*f*sin(alat)*sin(alat)) + arcf = (a*c + elev)*cos(alat) + arsf = (a*(1.d0 - f)*(1.d0 - f)*c + elev)*sin(alat) + hlt = datan2(arsf,arcf) + erad = sqrt(arcf*arcf + arsf*arsf) + erad = 0.001d0*erad + + return + end + diff --git a/getpfx1.f b/getpfx1.f index 58f798df8..2a1e541e2 100644 --- a/getpfx1.f +++ b/getpfx1.f @@ -1,45 +1,45 @@ - subroutine getpfx1(callsign,k) - - character callsign*12 - character*8 c - character addpfx*8 -C Can't 'include' *.f90 in *.f - common/gcom4/addpfx - include 'pfx.f' - - iz=index(callsign,' ') - 1 - if(iz.lt.0) iz=12 - islash=index(callsign(1:iz),'/') - k=0 - c=' ' - if(islash.gt.0 .and. islash.le.(iz-4)) then -! Add-on prefix - c=callsign(1:islash-1) - callsign=callsign(islash+1:iz) - do i=1,NZ - if(pfx(i)(1:4).eq.c) then - k=i - go to 10 - endif - enddo - if(addpfx.eq.c) then - k=449 - go to 10 - endif - - else if(islash.eq.(iz-1)) then -! Add-on suffix - c=callsign(islash+1:iz) - callsign=callsign(1:islash-1) - do i=1,NZ2 - if(sfx(i).eq.c(1:1)) then - k=400+i - go to 10 - endif - enddo - endif - - 10 if(islash.ne.0 .and.k.eq.0) k=-1 - return - end - + subroutine getpfx1(callsign,k) + + character callsign*12 + character*8 c + character addpfx*8 +C Can't 'include' *.f90 in *.f + common/gcom4/addpfx + include 'pfx.f' + + iz=index(callsign,' ') - 1 + if(iz.lt.0) iz=12 + islash=index(callsign(1:iz),'/') + k=0 + c=' ' + if(islash.gt.0 .and. islash.le.(iz-4)) then +! Add-on prefix + c=callsign(1:islash-1) + callsign=callsign(islash+1:iz) + do i=1,NZ + if(pfx(i)(1:4).eq.c) then + k=i + go to 10 + endif + enddo + if(addpfx.eq.c) then + k=449 + go to 10 + endif + + else if(islash.eq.(iz-1)) then +! Add-on suffix + c=callsign(islash+1:iz) + callsign=callsign(1:islash-1) + do i=1,NZ2 + if(sfx(i).eq.c(1:1)) then + k=400+i + go to 10 + endif + enddo + endif + + 10 if(islash.ne.0 .and.k.eq.0) k=-1 + return + end + diff --git a/getpfx2.f b/getpfx2.f index fc7a20c53..cbf339939 100644 --- a/getpfx2.f +++ b/getpfx2.f @@ -1,24 +1,24 @@ - subroutine getpfx2(k0,callsign) - - character callsign*12 - include 'pfx.f' - character addpfx*8 - common/gcom4/addpfx - - k=k0 - if(k.gt.450) k=k-450 - if(k.ge.1 .and. k.le.NZ) then - iz=index(pfx(k),' ') - 1 - callsign=pfx(k)(1:iz)//'/'//callsign - else if(k.ge.401 .and. k.le.400+NZ2) then - iz=index(callsign,' ') - 1 - callsign=callsign(1:iz)//'/'//sfx(k-400) - else if(k.eq.449) then - iz=index(addpfx,' ') - 1 - if(iz.lt.1) iz=8 - callsign=addpfx(1:iz)//'/'//callsign - endif - - return - end - + subroutine getpfx2(k0,callsign) + + character callsign*12 + include 'pfx.f' + character addpfx*8 + common/gcom4/addpfx + + k=k0 + if(k.gt.450) k=k-450 + if(k.ge.1 .and. k.le.NZ) then + iz=index(pfx(k),' ') - 1 + callsign=pfx(k)(1:iz)//'/'//callsign + else if(k.ge.401 .and. k.le.400+NZ2) then + iz=index(callsign,' ') - 1 + callsign=callsign(1:iz)//'/'//sfx(k-400) + else if(k.eq.449) then + iz=index(addpfx,' ') - 1 + if(iz.lt.1) iz=8 + callsign=addpfx(1:iz)//'/'//callsign + endif + + return + end + diff --git a/getsnr.f b/getsnr.f index fddf4016f..b6418778e 100644 --- a/getsnr.f +++ b/getsnr.f @@ -1,35 +1,35 @@ - subroutine getsnr(x,nz,snr) - - real x(nz) - - smax=-1.e30 - do i=1,nz - if(x(i).gt.smax) then - ipk=i - smax=x(i) - endif - s=s+x(i) - enddo - - s=0. - ns=0 - do i=1,nz - if(abs(i-ipk).ge.3) then - s=s+x(i) - ns=ns+1 - endif - enddo - ave=s/ns - - sq=0. - do i=1,nz - if(abs(i-ipk).ge.3) then - sq=sq+(x(i)-ave)**2 - ns=ns+1 - endif - enddo - rms=sqrt(sq/(nz-2)) - snr=(smax-ave)/rms - - return - end + subroutine getsnr(x,nz,snr) + + real x(nz) + + smax=-1.e30 + do i=1,nz + if(x(i).gt.smax) then + ipk=i + smax=x(i) + endif + s=s+x(i) + enddo + + s=0. + ns=0 + do i=1,nz + if(abs(i-ipk).ge.3) then + s=s+x(i) + ns=ns+1 + endif + enddo + ave=s/ns + + sq=0. + do i=1,nz + if(abs(i-ipk).ge.3) then + sq=sq+(x(i)-ave)**2 + ns=ns+1 + endif + enddo + rms=sqrt(sq/(nz-2)) + snr=(smax-ave)/rms + + return + end diff --git a/graycode.f b/graycode.f index 24c03e943..0edc2af2d 100644 --- a/graycode.f +++ b/graycode.f @@ -1,10 +1,10 @@ - subroutine graycode(dat,n,idir) - - integer dat(n) - do i=1,n - dat(i)=igray(dat(i),idir) - enddo - - return - end - + subroutine graycode(dat,n,idir) + + integer dat(n) + do i=1,n + dat(i)=igray(dat(i),idir) + enddo + + return + end + diff --git a/grid2deg.f b/grid2deg.f index 4864af3c8..c1667d4d7 100644 --- a/grid2deg.f +++ b/grid2deg.f @@ -1,40 +1,40 @@ - subroutine grid2deg(grid0,dlong,dlat) - -C Converts Maidenhead grid locator to degrees of West longitude -C and North latitude. - - character*6 grid0,grid - character*1 g1,g2,g3,g4,g5,g6 - - grid=grid0 - i=ichar(grid(5:5)) - if(grid(5:5).eq.' ' .or. i.le.64 .or. i.ge.128) grid(5:6)='mm' - - if(grid(1:1).ge.'a' .and. grid(1:1).le.'z') grid(1:1)= - + char(ichar(grid(1:1))+ichar('A')-ichar('a')) - if(grid(2:2).ge.'a' .and. grid(2:2).le.'z') grid(2:2)= - + char(ichar(grid(2:2))+ichar('A')-ichar('a')) - if(grid(5:5).ge.'A' .and. grid(5:5).le.'Z') grid(5:5)= - + char(ichar(grid(5:5))-ichar('A')+ichar('a')) - if(grid(6:6).ge.'A' .and. grid(6:6).le.'Z') grid(6:6)= - + char(ichar(grid(6:6))-ichar('A')+ichar('a')) - - g1=grid(1:1) - g2=grid(2:2) - g3=grid(3:3) - g4=grid(4:4) - g5=grid(5:5) - g6=grid(6:6) - - nlong = 180 - 20*(ichar(g1)-ichar('A')) - n20d = 2*(ichar(g3)-ichar('0')) - xminlong = 5*(ichar(g5)-ichar('a')+0.5) - dlong = nlong - n20d - xminlong/60.0 -c print*,nlong,n20d,xminlong,dlong - nlat = -90+10*(ichar(g2)-ichar('A')) + ichar(g4)-ichar('0') - xminlat = 2.5*(ichar(g6)-ichar('a')+0.5) - dlat = nlat + xminlat/60.0 -c print*,nlat,xminlat,dlat - - return - end + subroutine grid2deg(grid0,dlong,dlat) + +C Converts Maidenhead grid locator to degrees of West longitude +C and North latitude. + + character*6 grid0,grid + character*1 g1,g2,g3,g4,g5,g6 + + grid=grid0 + i=ichar(grid(5:5)) + if(grid(5:5).eq.' ' .or. i.le.64 .or. i.ge.128) grid(5:6)='mm' + + if(grid(1:1).ge.'a' .and. grid(1:1).le.'z') grid(1:1)= + + char(ichar(grid(1:1))+ichar('A')-ichar('a')) + if(grid(2:2).ge.'a' .and. grid(2:2).le.'z') grid(2:2)= + + char(ichar(grid(2:2))+ichar('A')-ichar('a')) + if(grid(5:5).ge.'A' .and. grid(5:5).le.'Z') grid(5:5)= + + char(ichar(grid(5:5))-ichar('A')+ichar('a')) + if(grid(6:6).ge.'A' .and. grid(6:6).le.'Z') grid(6:6)= + + char(ichar(grid(6:6))-ichar('A')+ichar('a')) + + g1=grid(1:1) + g2=grid(2:2) + g3=grid(3:3) + g4=grid(4:4) + g5=grid(5:5) + g6=grid(6:6) + + nlong = 180 - 20*(ichar(g1)-ichar('A')) + n20d = 2*(ichar(g3)-ichar('0')) + xminlong = 5*(ichar(g5)-ichar('a')+0.5) + dlong = nlong - n20d - xminlong/60.0 +c print*,nlong,n20d,xminlong,dlong + nlat = -90+10*(ichar(g2)-ichar('A')) + ichar(g4)-ichar('0') + xminlat = 2.5*(ichar(g6)-ichar('a')+0.5) + dlat = nlat + xminlat/60.0 +c print*,nlat,xminlat,dlat + + return + end diff --git a/grid2k.f b/grid2k.f index 1306a95a2..b79f290ed 100644 --- a/grid2k.f +++ b/grid2k.f @@ -1,12 +1,12 @@ - subroutine grid2k(grid,k) - - character*6 grid - - call grid2deg(grid,xlong,xlat) - nlong=nint(xlong) - nlat=nint(xlat) - k=0 - if(nlat.ge.85) k=5*(nlong+179)/2 + nlat-84 - - return - end + subroutine grid2k(grid,k) + + character*6 grid + + call grid2deg(grid,xlong,xlat) + nlong=nint(xlong) + nlat=nint(xlat) + k=0 + if(nlat.ge.85) k=5*(nlong+179)/2 + nlat-84 + + return + end diff --git a/indexx.f b/indexx.f index df2a5330e..11e0fefd2 100644 --- a/indexx.f +++ b/indexx.f @@ -1,19 +1,19 @@ - subroutine indexx(n,arr,indx) - - parameter (NMAX=3000) - integer indx(n) - real arr(n) - real brr(NMAX) - if(n.gt.NMAX) then - print*,'n=',n,' too big in indexx.' - stop - endif - do i=1,n - brr(i)=arr(i) - indx(i)=i - enddo - call ssort(brr,indx,n,2) - - return - end - + subroutine indexx(n,arr,indx) + + parameter (NMAX=3000) + integer indx(n) + real arr(n) + real brr(NMAX) + if(n.gt.NMAX) then + print*,'n=',n,' too big in indexx.' + stop + endif + do i=1,n + brr(i)=arr(i) + indx(i)=i + enddo + call ssort(brr,indx,n,2) + + return + end + diff --git a/int.h b/int.h index 056241e12..0591b1181 100644 --- a/int.h +++ b/int.h @@ -1,57 +1,57 @@ -/* Include file to configure the RS codec for integer symbols - * - * Copyright 2002, Phil Karn, KA9Q - * May be used under the terms of the GNU General Public License (GPL) - */ -#define DTYPE int - -/* Reed-Solomon codec control block */ -struct rs { - int mm; /* Bits per symbol */ - int nn; /* Symbols per block (= (1<= rs->nn) { - x -= rs->nn; - x = (x >> rs->mm) + (x & rs->nn); - } - return x; -} -#define MODNN(x) modnn(rs,x) - -#define MM (rs->mm) -#define NN (rs->nn) -#define ALPHA_TO (rs->alpha_to) -#define INDEX_OF (rs->index_of) -#define GENPOLY (rs->genpoly) -//#define NROOTS (rs->nroots) -#define NROOTS (51) -#define FCR (rs->fcr) -#define PRIM (rs->prim) -#define IPRIM (rs->iprim) -#define PAD (rs->pad) -#define A0 (NN) - -#define ENCODE_RS encode_rs_int -#define DECODE_RS decode_rs_int -#define INIT_RS init_rs_int -#define FREE_RS free_rs_int - -void ENCODE_RS(void *p,DTYPE *data,DTYPE *parity); -int DECODE_RS(void *p,DTYPE *data,int *eras_pos,int no_eras); -void *INIT_RS(int symsize,int gfpoly,int fcr, - int prim,int nroots,int pad); -void FREE_RS(void *p); - - - - +/* Include file to configure the RS codec for integer symbols + * + * Copyright 2002, Phil Karn, KA9Q + * May be used under the terms of the GNU General Public License (GPL) + */ +#define DTYPE int + +/* Reed-Solomon codec control block */ +struct rs { + int mm; /* Bits per symbol */ + int nn; /* Symbols per block (= (1<= rs->nn) { + x -= rs->nn; + x = (x >> rs->mm) + (x & rs->nn); + } + return x; +} +#define MODNN(x) modnn(rs,x) + +#define MM (rs->mm) +#define NN (rs->nn) +#define ALPHA_TO (rs->alpha_to) +#define INDEX_OF (rs->index_of) +#define GENPOLY (rs->genpoly) +//#define NROOTS (rs->nroots) +#define NROOTS (51) +#define FCR (rs->fcr) +#define PRIM (rs->prim) +#define IPRIM (rs->iprim) +#define PAD (rs->pad) +#define A0 (NN) + +#define ENCODE_RS encode_rs_int +#define DECODE_RS decode_rs_int +#define INIT_RS init_rs_int +#define FREE_RS free_rs_int + +void ENCODE_RS(void *p,DTYPE *data,DTYPE *parity); +int DECODE_RS(void *p,DTYPE *data,int *eras_pos,int no_eras); +void *INIT_RS(int symsize,int gfpoly,int fcr, + int prim,int nroots,int pad); +void FREE_RS(void *p); + + + + diff --git a/interleave63.f b/interleave63.f index f6793023a..c07dbd4c1 100644 --- a/interleave63.f +++ b/interleave63.f @@ -1,25 +1,25 @@ - subroutine interleave63(d1,idir) - -C Interleave (idir=1) or de-interleave (idir=-1) the array d1. - - integer d1(0:6,0:8) - integer d2(0:8,0:6) - - if(idir.ge.0) then - do i=0,6 - do j=0,8 - d2(j,i)=d1(i,j) - enddo - enddo - call move(d2,d1,63) - else - call move(d1,d2,63) - do i=0,6 - do j=0,8 - d1(i,j)=d2(j,i) - enddo - enddo - endif - - return - end + subroutine interleave63(d1,idir) + +C Interleave (idir=1) or de-interleave (idir=-1) the array d1. + + integer d1(0:6,0:8) + integer d2(0:8,0:6) + + if(idir.ge.0) then + do i=0,6 + do j=0,8 + d2(j,i)=d1(i,j) + enddo + enddo + call move(d2,d1,63) + else + call move(d1,d2,63) + do i=0,6 + do j=0,8 + d1(i,j)=d2(j,i) + enddo + enddo + endif + + return + end diff --git a/k2grid.f b/k2grid.f index 6fcd7f3e4..5ce4ec691 100644 --- a/k2grid.f +++ b/k2grid.f @@ -1,12 +1,12 @@ - subroutine k2grid(k,grid) - character grid*6 - - nlong=2*mod((k-1)/5,90)-179 - if(k.gt.450) nlong=nlong+180 - nlat=mod(k-1,5)+ 85 - dlat=nlat - dlong=nlong - call deg2grid(dlong,dlat,grid) - - return - end + subroutine k2grid(k,grid) + character grid*6 + + nlong=2*mod((k-1)/5,90)-179 + if(k.gt.450) nlong=nlong+180 + nlat=mod(k-1,5)+ 85 + dlat=nlat + dlong=nlong + call deg2grid(dlong,dlat,grid) + + return + end diff --git a/limit.f b/limit.f index 0dec7e1d4..aaa2927c2 100644 --- a/limit.f +++ b/limit.f @@ -1,31 +1,31 @@ - subroutine limit(x,jz) - - real x(jz) - logical noping - common/limcom/ nslim2 - - noping=.false. - xlim=1.e30 - if(nslim2.eq.1) xlim=3.0 - if(nslim2.ge.2) xlim=1.0 - if(nslim2.ge.3) noping=.true. - - sq=0. - do i=1,jz - sq=sq+x(i)*x(i) - enddo - rms=sqrt(sq/jz) - rms0=14.5 - x1=xlim*rms0 - fac=1.0/xlim - if(fac.lt.1.0) fac=1.0 - if(noping .and. rms.gt.20.0) fac=0.01 !Crude attempt at ping excision - - do i=1,jz - if(x(i).lt.-x1) x(i)=-x1 - if(x(i).gt.x1) x(i)=x1 - x(i)=fac*x(i) - enddo - - return - end + subroutine limit(x,jz) + + real x(jz) + logical noping + common/limcom/ nslim2 + + noping=.false. + xlim=1.e30 + if(nslim2.eq.1) xlim=3.0 + if(nslim2.ge.2) xlim=1.0 + if(nslim2.ge.3) noping=.true. + + sq=0. + do i=1,jz + sq=sq+x(i)*x(i) + enddo + rms=sqrt(sq/jz) + rms0=14.5 + x1=xlim*rms0 + fac=1.0/xlim + if(fac.lt.1.0) fac=1.0 + if(noping .and. rms.gt.20.0) fac=0.01 !Crude attempt at ping excision + + do i=1,jz + if(x(i).lt.-x1) x(i)=-x1 + if(x(i).gt.x1) x(i)=x1 + x(i)=fac*x(i) + enddo + + return + end diff --git a/lpf1.f b/lpf1.f index 4a5188f8e..698923375 100644 --- a/lpf1.f +++ b/lpf1.f @@ -1,67 +1,67 @@ - subroutine lpf1(dat,jz,nz,mousedf,mousedf2) - - parameter (NMAX=1024*1024) - parameter (NMAXH=NMAX) - real dat(jz),x(NMAX) - complex c(0:NMAXH) - equivalence (x,c) - -C Find FFT length - xn=log(float(jz))/log(2.0) - n=xn - if((xn-n).gt.0.) n=n+1 - nfft=2**n - nh=nfft/2 - -C Load data into real array x; pad with zeros up to nfft. - do i=1,jz - x(i)=dat(i) - enddo - if(nfft.gt.jz) call zero(x(jz+1),nfft-jz) -C Do the FFT - call xfft(x,nfft) - df=11025.0/nfft - - ia=70/df - do i=0,ia - c(i)=0. - enddo - ia=5000.0/df - do i=ia,nh - c(i)=0. - enddo - -C See if frequency needs to be shifted: - ndf=0 - if(mousedf.lt.-600) ndf=-670 - if(mousedf.gt.600) ndf=1000 - if(mousedf.gt.1600) ndf=2000 - if(mousedf.gt.2600) ndf=3000 - - if(ndf.ne.0) then -C Shift frequency up or down by ndf Hz: - i0=nint(ndf/df) - if(i0.lt.0) then - do i=nh,-i0,-1 - c(i)=c(i+i0) - enddo - do i=0,-i0-1 - c(i)=0. - enddo - else - do i=0,nh-i0 - c(i)=c(i+i0) - enddo - endif - endif - - mousedf2=mousedf-ndf !Adjust mousedf - call four2a(c,nh,1,1,-1) !Return to time domain - fac=1.0/nfft - nz=jz/2 - do i=1,nz - dat(i)=fac*x(i) - enddo - - return - end + subroutine lpf1(dat,jz,nz,mousedf,mousedf2) + + parameter (NMAX=1024*1024) + parameter (NMAXH=NMAX) + real dat(jz),x(NMAX) + complex c(0:NMAXH) + equivalence (x,c) + +C Find FFT length + xn=log(float(jz))/log(2.0) + n=xn + if((xn-n).gt.0.) n=n+1 + nfft=2**n + nh=nfft/2 + +C Load data into real array x; pad with zeros up to nfft. + do i=1,jz + x(i)=dat(i) + enddo + if(nfft.gt.jz) call zero(x(jz+1),nfft-jz) +C Do the FFT + call xfft(x,nfft) + df=11025.0/nfft + + ia=70/df + do i=0,ia + c(i)=0. + enddo + ia=5000.0/df + do i=ia,nh + c(i)=0. + enddo + +C See if frequency needs to be shifted: + ndf=0 + if(mousedf.lt.-600) ndf=-670 + if(mousedf.gt.600) ndf=1000 + if(mousedf.gt.1600) ndf=2000 + if(mousedf.gt.2600) ndf=3000 + + if(ndf.ne.0) then +C Shift frequency up or down by ndf Hz: + i0=nint(ndf/df) + if(i0.lt.0) then + do i=nh,-i0,-1 + c(i)=c(i+i0) + enddo + do i=0,-i0-1 + c(i)=0. + enddo + else + do i=0,nh-i0 + c(i)=c(i+i0) + enddo + endif + endif + + mousedf2=mousedf-ndf !Adjust mousedf + call four2a(c,nh,1,1,-1) !Return to time domain + fac=1.0/nfft + nz=jz/2 + do i=1,nz + dat(i)=fac*x(i) + enddo + + return + end diff --git a/map65.py b/map65.py index 13778ce9a..54367d054 100644 --- a/map65.py +++ b/map65.py @@ -164,6 +164,22 @@ def testmsgs(): tx5.insert(0,"@1000") tx6.insert(0,"@2000") +#------------------------------------------------------ bandmap +def bandmap(event=NONE): + global Version,bm,bm_geom,bmtext + bm=Toplevel(root) + bm.geometry(bm_geom) + if g.Win32: bm.iconbitmap("wsjt.ico") + iframe_bm1 = Frame(bm, bd=1, relief=SUNKEN) + bmtext=Text(iframe_bm1, height=35, width=45, bg="Navy", fg="yellow") + bmtext.pack(side=LEFT, fill=X, padx=1) + bmsb = Scrollbar(iframe_bm1, orient=VERTICAL, command=bmtext.yview) + bmsb.pack(side=RIGHT, fill=Y) + bmtext.configure(yscrollcommand=bmsb.set) +# bmtext.insert(END,'144.103 CQ EA3DXU JN11\n') +# bmtext.insert(END,'144.118 OH6KTL RA3AQ KO85 OOO') + iframe_bm1.pack(expand=1, fill=X, padx=4) + #------------------------------------------------------ logqso def logqso(event=NONE): t=time.strftime("%Y-%b-%d,%H:%M",time.gmtime()) @@ -1070,22 +1086,6 @@ def plot_yellow(): xy2.append(n) graph1.create_line(xy2,fill="yellow") -#------------------------------------------------------ bandmap -def bandmap(event=NONE): - global Version,bm,bm_geom - bm=Toplevel(root) - bm.geometry(bm_geom) - if g.Win32: bm.iconbitmap("wsjt.ico") - iframe_bm1 = Frame(bm, bd=1, relief=SUNKEN) - text=Text(iframe_bm1, height=35, width=32, bg="Navy", fg="yellow") - text.pack(side=LEFT, fill=X, padx=1) - sb = Scrollbar(iframe_bm1, orient=VERTICAL, command=text.yview) - sb.pack(side=RIGHT, fill=Y) - text.configure(yscrollcommand=sb.set) - text.insert(END,'144.103 CQ EA3DXU JN11\n') - text.insert(END,'144.118 OH6KTL RA3AQ KO85 OOO') - iframe_bm1.pack(expand=1, fill=X, padx=4) - #------------------------------------------------------ update def update(): global root_geom,isec0,naz,nel,ndmiles,ndkm,nopen, \ @@ -1179,6 +1179,10 @@ def update(): bdecode.configure(bg='gray85',activebackground='gray95') if Audio.gcom2.ndecoding: #Set button bg=light_blue while decoding bdecode.configure(bg='#66FFFF',activebackground='#66FFFF') +# print 'A' + Audio.map65a0() # @@@ Temporary @@@ +# print 'B' + tx1.configure(bg='white') tx2.configure(bg='white') tx3.configure(bg='white') @@ -1251,6 +1255,21 @@ def update(): avetext.insert(END,lines[0]) avetext.insert(END,lines[1]) # avetext.configure(state=DISABLED) + + try: + f=open(appdir+'/bandmap.txt',mode='r') + lines=f.readlines() + f.close() + except: + lines="" + bmtext.configure(state=NORMAL) + bmtext.insert(END,' Freq DF Pol UTC\n') + bmtext.insert(END,'--------------------------------------------\n') + + for i in range(len(lines)): + bmtext.insert(END,lines[i]) + bmtext.see(END) + Audio.gcom2.ndecdone=2 if g.cmap != cmap0: @@ -1744,7 +1763,6 @@ msg7=Message(iframe6, text=' ', width=300,relief=SUNKEN) msg7.pack(side=RIGHT, fill=X, padx=1) iframe6.pack(expand=1, fill=X, padx=4) frame.pack() - ldate.after(100,update) lauto=0 isync=1 diff --git a/map65a.f b/map65a.f new file mode 100644 index 000000000..a8447b783 --- /dev/null +++ b/map65a.f @@ -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 diff --git a/moon2.f b/moon2.f index 3456f8451..f212c7aa0 100644 --- a/moon2.f +++ b/moon2.f @@ -1,167 +1,167 @@ - subroutine moon2(y,m,Day,UT,lon,lat,RA,Dec,topRA,topDec, - + LST,HA,Az,El,dist) - - implicit none - - integer y !Year - integer m !Month - integer Day !Day - real*8 UT !UTC in hours - real*8 RA,Dec !RA and Dec of moon - -C NB: Double caps are single caps in the writeup. - - real*8 NN !Longitude of ascending node - real*8 i !Inclination to the ecliptic - real*8 w !Argument of perigee - real*8 a !Semi-major axis - real*8 e !Eccentricity - real*8 MM !Mean anomaly - - real*8 v !True anomaly - real*8 EE !Eccentric anomaly - real*8 ecl !Obliquity of the ecliptic - - real*8 d !Ephemeris time argument in days - real*8 r !Distance to sun, AU - real*8 xv,yv !x and y coords in ecliptic - real*8 lonecl,latecl !Ecliptic long and lat of moon - real*8 xg,yg,zg !Ecliptic rectangular coords - real*8 Ms !Mean anomaly of sun - real*8 ws !Argument of perihelion of sun - real*8 Ls !Mean longitude of sun (Ns=0) - real*8 Lm !Mean longitude of moon - real*8 DD !Mean elongation of moon - real*8 FF !Argument of latitude for moon - real*8 xe,ye,ze !Equatorial geocentric coords of moon - real*8 mpar !Parallax of moon (r_E / d) - real*8 lat,lon !Station coordinates on earth - real*8 gclat !Geocentric latitude - real*8 rho !Earth radius factor - real*8 GMST0,LST,HA - real*8 g - real*8 topRA,topDec !Topocentric coordinates of Moon - real*8 Az,El - real*8 dist - - real*8 rad,twopi,pi,pio2 - data rad/57.2957795131d0/,twopi/6.283185307d0/ - - d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + Day - 730530 + UT/24.d0 - ecl = 23.4393d0 - 3.563d-7 * d - -C Orbital elements for Moon: - NN = 125.1228d0 - 0.0529538083d0 * d - i = 5.1454d0 - w = mod(318.0634d0 + 0.1643573223d0 * d + 360000.d0,360.d0) - a = 60.2666d0 - e = 0.054900d0 - MM = mod(115.3654d0 + 13.0649929509d0 * d + 360000.d0,360.d0) - - EE = MM + e*rad*sin(MM/rad) * (1.d0 + e*cos(M/rad)) - EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.d0 - e*cos(EE/rad)) - EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.d0 - e*cos(EE/rad)) - - xv = a * (cos(EE/rad) - e) - yv = a * (sqrt(1.d0-e*e) * sin(EE/rad)) - - v = mod(rad*atan2(yv,xv)+720.d0,360.d0) - r = sqrt(xv*xv + yv*yv) - -C Get geocentric position in ecliptic rectangular coordinates: - - xg = r * (cos(NN/rad)*cos((v+w)/rad) - - + sin(NN/rad)*sin((v+w)/rad)*cos(i/rad)) - yg = r * (sin(NN/rad)*cos((v+w)/rad) + - + cos(NN/rad)*sin((v+w)/rad)*cos(i/rad)) - zg = r * (sin((v+w)/rad)*sin(i/rad)) - -C Ecliptic longitude and latitude of moon: - lonecl = mod(rad*atan2(yg/rad,xg/rad)+720.d0,360.d0) - latecl = rad*atan2(zg/rad,sqrt(xg*xg + yg*yg)/rad) - -C Now include orbital perturbations: - Ms = mod(356.0470d0 + 0.9856002585d0 * d + 3600000.d0,360.d0) - ws = 282.9404d0 + 4.70935d-5*d - Ls = mod(Ms + ws + 720.d0,360.d0) - Lm = mod(MM + w + NN+720.d0,360.d0) - DD = mod(Lm - Ls + 360.d0,360.d0) - FF = mod(Lm - NN + 360.d0,360.d0) - - lonecl = lonecl - + -1.274d0 * sin((MM-2.d0*DD)/rad) - + +0.658d0 * sin(2.d0*DD/rad) - + -0.186d0 * sin(Ms/rad) - + -0.059d0 * sin((2.d0*MM-2.d0*DD)/rad) - + -0.057d0 * sin((MM-2.d0*DD+Ms)/rad) - + +0.053d0 * sin((MM+2.d0*DD)/rad) - + +0.046d0 * sin((2.d0*DD-Ms)/rad) - + +0.041d0 * sin((MM-Ms)/rad) - + -0.035d0 * sin(DD/rad) - + -0.031d0 * sin((MM+Ms)/rad) - + -0.015d0 * sin((2.d0*FF-2.d0*DD)/rad) - + +0.011d0 * sin((MM-4.d0*DD)/rad) - - latecl = latecl - + -0.173d0 * sin((FF-2.d0*DD)/rad) - + -0.055d0 * sin((MM-FF-2.d0*DD)/rad) - + -0.046d0 * sin((MM+FF-2.d0*DD)/rad) - + +0.033d0 * sin((FF+2.d0*DD)/rad) - + +0.017d0 * sin((2.d0*MM+FF)/rad) - - r = 60.36298d0 - + - 3.27746d0*cos(MM/rad) - + - 0.57994d0*cos((MM-2.d0*DD)/rad) - + - 0.46357d0*cos(2.d0*DD/rad) - + - 0.08904d0*cos(2.d0*MM/rad) - + + 0.03865d0*cos((2.d0*MM-2.d0*DD)/rad) - + - 0.03237d0*cos((2.d0*DD-Ms)/rad) - + - 0.02688d0*cos((MM+2.d0*DD)/rad) - + - 0.02358d0*cos((MM-2.d0*DD+Ms)/rad) - + - 0.02030d0*cos((MM-Ms)/rad) - + + 0.01719d0*cos(DD/rad) - + + 0.01671d0*cos((MM+Ms)/rad) - - dist=r*6378.140d0 - -C Geocentric coordinates: -C Rectangular ecliptic coordinates of the moon: - - xg = r * cos(lonecl/rad)*cos(latecl/rad) - yg = r * sin(lonecl/rad)*cos(latecl/rad) - zg = r * sin(latecl/rad) - -C Rectangular equatorial coordinates of the moon: - xe = xg - ye = yg*cos(ecl/rad) - zg*sin(ecl/rad) - ze = yg*sin(ecl/rad) + zg*cos(ecl/rad) - -C Right Ascension, Declination: - RA = mod(rad*atan2(ye,xe)+360.d0,360.d0) - Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye)) - -C Now convert to topocentric system: - mpar=rad*asin(1.d0/r) -C alt_topoc = alt_geoc - mpar*cos(alt_geoc) - gclat = lat - 0.1924d0*sin(2.d0*lat/rad) - rho = 0.99883d0 + 0.00167d0*cos(2.d0*lat/rad) - GMST0 = (Ls + 180.d0)/15.d0 - LST = mod(GMST0+UT+lon/15.d0+48.d0,24.d0) !LST in hours - HA = 15.d0*LST - RA !HA in degrees - g = rad*atan(tan(gclat/rad)/cos(HA/rad)) - topRA = RA - mpar*rho*cos(gclat/rad)*sin(HA/rad)/cos(Dec/rad) - topDec = Dec - mpar*rho*sin(gclat/rad)*sin((g-Dec)/rad)/sin(g/rad) - - HA = 15.d0*LST - topRA !HA in degrees - if(HA.gt.180.d0) HA=HA-360.d0 - if(HA.lt.-180.d0) HA=HA+360.d0 - - pi=0.5d0*twopi - pio2=0.5d0*pi - call dcoord(pi,pio2-lat/rad,0.d0,lat/rad,ha*twopi/360, - + topDec/rad,az,el) - Az=az*rad - El=El*rad - - return - end + subroutine moon2(y,m,Day,UT,lon,lat,RA,Dec,topRA,topDec, + + LST,HA,Az,El,dist) + + implicit none + + integer y !Year + integer m !Month + integer Day !Day + real*8 UT !UTC in hours + real*8 RA,Dec !RA and Dec of moon + +C NB: Double caps are single caps in the writeup. + + real*8 NN !Longitude of ascending node + real*8 i !Inclination to the ecliptic + real*8 w !Argument of perigee + real*8 a !Semi-major axis + real*8 e !Eccentricity + real*8 MM !Mean anomaly + + real*8 v !True anomaly + real*8 EE !Eccentric anomaly + real*8 ecl !Obliquity of the ecliptic + + real*8 d !Ephemeris time argument in days + real*8 r !Distance to sun, AU + real*8 xv,yv !x and y coords in ecliptic + real*8 lonecl,latecl !Ecliptic long and lat of moon + real*8 xg,yg,zg !Ecliptic rectangular coords + real*8 Ms !Mean anomaly of sun + real*8 ws !Argument of perihelion of sun + real*8 Ls !Mean longitude of sun (Ns=0) + real*8 Lm !Mean longitude of moon + real*8 DD !Mean elongation of moon + real*8 FF !Argument of latitude for moon + real*8 xe,ye,ze !Equatorial geocentric coords of moon + real*8 mpar !Parallax of moon (r_E / d) + real*8 lat,lon !Station coordinates on earth + real*8 gclat !Geocentric latitude + real*8 rho !Earth radius factor + real*8 GMST0,LST,HA + real*8 g + real*8 topRA,topDec !Topocentric coordinates of Moon + real*8 Az,El + real*8 dist + + real*8 rad,twopi,pi,pio2 + data rad/57.2957795131d0/,twopi/6.283185307d0/ + + d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + Day - 730530 + UT/24.d0 + ecl = 23.4393d0 - 3.563d-7 * d + +C Orbital elements for Moon: + NN = 125.1228d0 - 0.0529538083d0 * d + i = 5.1454d0 + w = mod(318.0634d0 + 0.1643573223d0 * d + 360000.d0,360.d0) + a = 60.2666d0 + e = 0.054900d0 + MM = mod(115.3654d0 + 13.0649929509d0 * d + 360000.d0,360.d0) + + EE = MM + e*rad*sin(MM/rad) * (1.d0 + e*cos(M/rad)) + EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.d0 - e*cos(EE/rad)) + EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.d0 - e*cos(EE/rad)) + + xv = a * (cos(EE/rad) - e) + yv = a * (sqrt(1.d0-e*e) * sin(EE/rad)) + + v = mod(rad*atan2(yv,xv)+720.d0,360.d0) + r = sqrt(xv*xv + yv*yv) + +C Get geocentric position in ecliptic rectangular coordinates: + + xg = r * (cos(NN/rad)*cos((v+w)/rad) - + + sin(NN/rad)*sin((v+w)/rad)*cos(i/rad)) + yg = r * (sin(NN/rad)*cos((v+w)/rad) + + + cos(NN/rad)*sin((v+w)/rad)*cos(i/rad)) + zg = r * (sin((v+w)/rad)*sin(i/rad)) + +C Ecliptic longitude and latitude of moon: + lonecl = mod(rad*atan2(yg/rad,xg/rad)+720.d0,360.d0) + latecl = rad*atan2(zg/rad,sqrt(xg*xg + yg*yg)/rad) + +C Now include orbital perturbations: + Ms = mod(356.0470d0 + 0.9856002585d0 * d + 3600000.d0,360.d0) + ws = 282.9404d0 + 4.70935d-5*d + Ls = mod(Ms + ws + 720.d0,360.d0) + Lm = mod(MM + w + NN+720.d0,360.d0) + DD = mod(Lm - Ls + 360.d0,360.d0) + FF = mod(Lm - NN + 360.d0,360.d0) + + lonecl = lonecl + + -1.274d0 * sin((MM-2.d0*DD)/rad) + + +0.658d0 * sin(2.d0*DD/rad) + + -0.186d0 * sin(Ms/rad) + + -0.059d0 * sin((2.d0*MM-2.d0*DD)/rad) + + -0.057d0 * sin((MM-2.d0*DD+Ms)/rad) + + +0.053d0 * sin((MM+2.d0*DD)/rad) + + +0.046d0 * sin((2.d0*DD-Ms)/rad) + + +0.041d0 * sin((MM-Ms)/rad) + + -0.035d0 * sin(DD/rad) + + -0.031d0 * sin((MM+Ms)/rad) + + -0.015d0 * sin((2.d0*FF-2.d0*DD)/rad) + + +0.011d0 * sin((MM-4.d0*DD)/rad) + + latecl = latecl + + -0.173d0 * sin((FF-2.d0*DD)/rad) + + -0.055d0 * sin((MM-FF-2.d0*DD)/rad) + + -0.046d0 * sin((MM+FF-2.d0*DD)/rad) + + +0.033d0 * sin((FF+2.d0*DD)/rad) + + +0.017d0 * sin((2.d0*MM+FF)/rad) + + r = 60.36298d0 + + - 3.27746d0*cos(MM/rad) + + - 0.57994d0*cos((MM-2.d0*DD)/rad) + + - 0.46357d0*cos(2.d0*DD/rad) + + - 0.08904d0*cos(2.d0*MM/rad) + + + 0.03865d0*cos((2.d0*MM-2.d0*DD)/rad) + + - 0.03237d0*cos((2.d0*DD-Ms)/rad) + + - 0.02688d0*cos((MM+2.d0*DD)/rad) + + - 0.02358d0*cos((MM-2.d0*DD+Ms)/rad) + + - 0.02030d0*cos((MM-Ms)/rad) + + + 0.01719d0*cos(DD/rad) + + + 0.01671d0*cos((MM+Ms)/rad) + + dist=r*6378.140d0 + +C Geocentric coordinates: +C Rectangular ecliptic coordinates of the moon: + + xg = r * cos(lonecl/rad)*cos(latecl/rad) + yg = r * sin(lonecl/rad)*cos(latecl/rad) + zg = r * sin(latecl/rad) + +C Rectangular equatorial coordinates of the moon: + xe = xg + ye = yg*cos(ecl/rad) - zg*sin(ecl/rad) + ze = yg*sin(ecl/rad) + zg*cos(ecl/rad) + +C Right Ascension, Declination: + RA = mod(rad*atan2(ye,xe)+360.d0,360.d0) + Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye)) + +C Now convert to topocentric system: + mpar=rad*asin(1.d0/r) +C alt_topoc = alt_geoc - mpar*cos(alt_geoc) + gclat = lat - 0.1924d0*sin(2.d0*lat/rad) + rho = 0.99883d0 + 0.00167d0*cos(2.d0*lat/rad) + GMST0 = (Ls + 180.d0)/15.d0 + LST = mod(GMST0+UT+lon/15.d0+48.d0,24.d0) !LST in hours + HA = 15.d0*LST - RA !HA in degrees + g = rad*atan(tan(gclat/rad)/cos(HA/rad)) + topRA = RA - mpar*rho*cos(gclat/rad)*sin(HA/rad)/cos(Dec/rad) + topDec = Dec - mpar*rho*sin(gclat/rad)*sin((g-Dec)/rad)/sin(g/rad) + + HA = 15.d0*LST - topRA !HA in degrees + if(HA.gt.180.d0) HA=HA-360.d0 + if(HA.lt.-180.d0) HA=HA+360.d0 + + pi=0.5d0*twopi + pio2=0.5d0*pi + call dcoord(pi,pio2-lat/rad,0.d0,lat/rad,ha*twopi/360, + + topDec/rad,az,el) + Az=az*rad + El=El*rad + + return + end diff --git a/morse.f b/morse.f index f2b9fc288..fb0c521ea 100644 --- a/morse.f +++ b/morse.f @@ -1,90 +1,90 @@ - subroutine morse(msg,idat,n) - -C Convert ascii message to a Morse code bit string. -C Dash = 3 dots -C Space between dots, dashes = 1 dot -C Space between letters = 3 dots -C Space between words = 7 dots - - character*22 msg - integer*1 idat(460) - integer*1 ic(21,38) - data ic/ - + 1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,20, - + 1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,18, - + 1,0,1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,16, - + 1,0,1,0,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14, - + 1,0,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12, - + 1,0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, - + 1,1,1,0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,12, - + 1,1,1,0,1,1,1,0,1,0,1,0,1,0,0,0,0,0,0,0,14, - + 1,1,1,0,1,1,1,0,1,1,1,0,1,0,1,0,0,0,0,0,16, - + 1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,0,0,0,18, - + 1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6, - + 1,1,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, - + 1,1,1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,12, - + 1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, - + 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 2, - + 1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, - + 1,1,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, - + 1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, - + 1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 4, - + 1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14, - + 1,1,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10, - + 1,0,1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, - + 1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, - + 1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6, - + 1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12, - + 1,0,1,1,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,12, - + 1,1,1,0,1,1,1,0,1,0,1,1,1,0,0,0,0,0,0,0,14, - + 1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, - + 1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6, - + 1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 4, - + 1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, - + 1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10, - + 1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10, - + 1,1,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12, - + 1,1,1,0,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14, - + 1,1,1,0,1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,12, - + 1,1,1,0,1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,14, - + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 2/ !Incremental word space - save - -C Find length of message - do i=22,1,-1 - if(msg(i:i).ne.' ') go to 1 - enddo - 1 msglen=i - - n=0 - do k=1,msglen - jj=ichar(msg(k:k)) - if(jj.ge.97 .and. jj.le.122) jj=jj-32 !Convert lower to upper case - if(jj.ge.48 .and. jj.le.57) j=jj-48 !Numbers - if(jj.ge.65 .and. jj.le.90) j=jj-55 !Letters - if(jj.eq.47) j=36 !Slash (/) - if(jj.eq.32) j=37 !Word space - j=j+1 - -C Insert this character - nmax=ic(21,j) - do i=1,nmax - n=n+1 - idat(n)=ic(i,j) - enddo - -C Insert character space of 2 dit lengths: - n=n+1 - idat(n)=0 - n=n+1 - idat(n)=0 - enddo - -C Insert word space at end of message - do j=1,4 - n=n+1 - idat(n)=0 - enddo - - return - end + subroutine morse(msg,idat,n) + +C Convert ascii message to a Morse code bit string. +C Dash = 3 dots +C Space between dots, dashes = 1 dot +C Space between letters = 3 dots +C Space between words = 7 dots + + character*22 msg + integer*1 idat(460) + integer*1 ic(21,38) + data ic/ + + 1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,20, + + 1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,18, + + 1,0,1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,16, + + 1,0,1,0,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14, + + 1,0,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12, + + 1,0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, + + 1,1,1,0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,12, + + 1,1,1,0,1,1,1,0,1,0,1,0,1,0,0,0,0,0,0,0,14, + + 1,1,1,0,1,1,1,0,1,1,1,0,1,0,1,0,0,0,0,0,16, + + 1,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,0,0,0,18, + + 1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6, + + 1,1,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, + + 1,1,1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,12, + + 1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, + + 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 2, + + 1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, + + 1,1,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, + + 1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, + + 1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 4, + + 1,0,1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14, + + 1,1,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10, + + 1,0,1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,10, + + 1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, + + 1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6, + + 1,1,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12, + + 1,0,1,1,1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,12, + + 1,1,1,0,1,1,1,0,1,0,1,1,1,0,0,0,0,0,0,0,14, + + 1,0,1,1,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, + + 1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 6, + + 1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 4, + + 1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 8, + + 1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10, + + 1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,10, + + 1,1,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,12, + + 1,1,1,0,1,0,1,1,1,0,1,1,1,0,0,0,0,0,0,0,14, + + 1,1,1,0,1,1,1,0,1,0,1,0,0,0,0,0,0,0,0,0,12, + + 1,1,1,0,1,0,1,0,1,1,1,0,1,0,0,0,0,0,0,0,14, + + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 2/ !Incremental word space + save + +C Find length of message + do i=22,1,-1 + if(msg(i:i).ne.' ') go to 1 + enddo + 1 msglen=i + + n=0 + do k=1,msglen + jj=ichar(msg(k:k)) + if(jj.ge.97 .and. jj.le.122) jj=jj-32 !Convert lower to upper case + if(jj.ge.48 .and. jj.le.57) j=jj-48 !Numbers + if(jj.ge.65 .and. jj.le.90) j=jj-55 !Letters + if(jj.eq.47) j=36 !Slash (/) + if(jj.eq.32) j=37 !Word space + j=j+1 + +C Insert this character + nmax=ic(21,j) + do i=1,nmax + n=n+1 + idat(n)=ic(i,j) + enddo + +C Insert character space of 2 dit lengths: + n=n+1 + idat(n)=0 + n=n+1 + idat(n)=0 + enddo + +C Insert word space at end of message + do j=1,4 + n=n+1 + idat(n)=0 + enddo + + return + end diff --git a/nchar.f b/nchar.f index d8ae3ec50..b4263ac1c 100644 --- a/nchar.f +++ b/nchar.f @@ -1,22 +1,22 @@ - function nchar(c) - -C Convert ascii number, letter, or space to 0-36 for callsign packing. - - character c*1 - - if(c.ge.'0' .and. c.le.'9') then - n=ichar(c)-ichar('0') - else if(c.ge.'A' .and. c.le.'Z') then - n=ichar(c)-ichar('A') + 10 - else if(c.ge.'a' .and. c.le.'z') then - n=ichar(c)-ichar('a') + 10 - else if(c.ge.' ') then - n=36 - else - Print*,'Invalid character in callsign ',c,' ',ichar(c) - stop - endif - nchar=n - - return - end + function nchar(c) + +C Convert ascii number, letter, or space to 0-36 for callsign packing. + + character c*1 + + if(c.ge.'0' .and. c.le.'9') then + n=ichar(c)-ichar('0') + else if(c.ge.'A' .and. c.le.'Z') then + n=ichar(c)-ichar('A') + 10 + else if(c.ge.'a' .and. c.le.'z') then + n=ichar(c)-ichar('a') + 10 + else if(c.ge.' ') then + n=36 + else + Print*,'Invalid character in callsign ',c,' ',ichar(c) + stop + endif + nchar=n + + return + end diff --git a/packcall.f b/packcall.f index b47c8257f..0abb19fed 100644 --- a/packcall.f +++ b/packcall.f @@ -1,76 +1,76 @@ - subroutine packcall(callsign,ncall,text) - -C Pack a valid callsign into a 28-bit integer. - - parameter (NBASE=37*36*10*27*27*27) - character callsign*6,c*1,tmp*6 - logical text - - text=.false. - -C Work-around for Swaziland prefix: - if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6) - - if(callsign(1:3).eq.'CQ ') then - ncall=NBASE + 1 - if(callsign(4:4).ge.'0' .and. callsign(4:4).le.'9' .and. - + callsign(5:5).ge.'0' .and. callsign(5:5).le.'9' .and. - + callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then - read(callsign(4:6),*) nfreq - ncall=NBASE + 3 + nfreq - endif - return - else if(callsign(1:4).eq.'QRZ ') then - ncall=NBASE + 2 - return - endif - - tmp=' ' - if(callsign(3:3).ge.'0' .and. callsign(3:3).le.'9') then - tmp=callsign - else if(callsign(2:2).ge.'0' .and. callsign(2:2).le.'9') then - if(callsign(6:6).ne.' ') then - text=.true. - return - endif - tmp=' '//callsign - else - text=.true. - return - endif - - do i=1,6 - c=tmp(i:i) - if(c.ge.'a' .and. c.le.'z') - + tmp(i:i)=char(ichar(c)-ichar('a')+ichar('A')) - enddo - - n1=0 - if((tmp(1:1).ge.'A'.and.tmp(1:1).le.'Z').or.tmp(1:1).eq.' ') n1=1 - if(tmp(1:1).ge.'0' .and. tmp(1:1).le.'9') n1=1 - n2=0 - if(tmp(2:2).ge.'A' .and. tmp(2:2).le.'Z') n2=1 - if(tmp(2:2).ge.'0' .and. tmp(2:2).le.'9') n2=1 - n3=0 - if(tmp(3:3).ge.'0' .and. tmp(3:3).le.'9') n3=1 - n4=0 - if((tmp(4:4).ge.'A'.and.tmp(4:4).le.'Z').or.tmp(4:4).eq.' ') n4=1 - n5=0 - if((tmp(5:5).ge.'A'.and.tmp(5:5).le.'Z').or.tmp(5:5).eq.' ') n5=1 - n6=0 - if((tmp(6:6).ge.'A'.and.tmp(6:6).le.'Z').or.tmp(6:6).eq.' ') n6=1 - - if(n1+n2+n3+n4+n5+n6 .ne. 6) then - text=.true. - return - endif - - ncall=nchar(tmp(1:1)) - ncall=36*ncall+nchar(tmp(2:2)) - ncall=10*ncall+nchar(tmp(3:3)) - ncall=27*ncall+nchar(tmp(4:4))-10 - ncall=27*ncall+nchar(tmp(5:5))-10 - ncall=27*ncall+nchar(tmp(6:6))-10 - - return - end + subroutine packcall(callsign,ncall,text) + +C Pack a valid callsign into a 28-bit integer. + + parameter (NBASE=37*36*10*27*27*27) + character callsign*6,c*1,tmp*6 + logical text + + text=.false. + +C Work-around for Swaziland prefix: + if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6) + + if(callsign(1:3).eq.'CQ ') then + ncall=NBASE + 1 + if(callsign(4:4).ge.'0' .and. callsign(4:4).le.'9' .and. + + callsign(5:5).ge.'0' .and. callsign(5:5).le.'9' .and. + + callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then + read(callsign(4:6),*) nfreq + ncall=NBASE + 3 + nfreq + endif + return + else if(callsign(1:4).eq.'QRZ ') then + ncall=NBASE + 2 + return + endif + + tmp=' ' + if(callsign(3:3).ge.'0' .and. callsign(3:3).le.'9') then + tmp=callsign + else if(callsign(2:2).ge.'0' .and. callsign(2:2).le.'9') then + if(callsign(6:6).ne.' ') then + text=.true. + return + endif + tmp=' '//callsign + else + text=.true. + return + endif + + do i=1,6 + c=tmp(i:i) + if(c.ge.'a' .and. c.le.'z') + + tmp(i:i)=char(ichar(c)-ichar('a')+ichar('A')) + enddo + + n1=0 + if((tmp(1:1).ge.'A'.and.tmp(1:1).le.'Z').or.tmp(1:1).eq.' ') n1=1 + if(tmp(1:1).ge.'0' .and. tmp(1:1).le.'9') n1=1 + n2=0 + if(tmp(2:2).ge.'A' .and. tmp(2:2).le.'Z') n2=1 + if(tmp(2:2).ge.'0' .and. tmp(2:2).le.'9') n2=1 + n3=0 + if(tmp(3:3).ge.'0' .and. tmp(3:3).le.'9') n3=1 + n4=0 + if((tmp(4:4).ge.'A'.and.tmp(4:4).le.'Z').or.tmp(4:4).eq.' ') n4=1 + n5=0 + if((tmp(5:5).ge.'A'.and.tmp(5:5).le.'Z').or.tmp(5:5).eq.' ') n5=1 + n6=0 + if((tmp(6:6).ge.'A'.and.tmp(6:6).le.'Z').or.tmp(6:6).eq.' ') n6=1 + + if(n1+n2+n3+n4+n5+n6 .ne. 6) then + text=.true. + return + endif + + ncall=nchar(tmp(1:1)) + ncall=36*ncall+nchar(tmp(2:2)) + ncall=10*ncall+nchar(tmp(3:3)) + ncall=27*ncall+nchar(tmp(4:4))-10 + ncall=27*ncall+nchar(tmp(5:5))-10 + ncall=27*ncall+nchar(tmp(6:6))-10 + + return + end diff --git a/packdxcc.f b/packdxcc.f index ac370ef3f..add5e7be9 100644 --- a/packdxcc.f +++ b/packdxcc.f @@ -1,64 +1,64 @@ - subroutine packdxcc(c,ng,ldxcc) - - character*3 c - logical ldxcc - - parameter (NZ=303) - character*5 pfx(NZ) - data pfx/ - + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', - + '3D2 ', '3DA ','3V ','3W ','3X ','3Y ', - + '4J ','4L ','4S ','4U1 ', '4W ', - + '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', - + '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', - + '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', - + '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', - + '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', - + 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', - + 'C3 ','C5 ','C6 ','C9 ','CE ','CE0 ', - + 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', - + 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', - + 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', - + 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', - + 'F ','FG ','FH ','FJ ','FK ', 'FM ','FO ', - + 'FP ','FR ', - + 'FT5 ', 'FW ','FY ','M ','MD ','MI ', - + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', - + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ', - + 'HL ','HM ','HP ','HR ','HS ','HV ','HZ ', - + 'I ','IG9 ','IS ','IT9 ','J2 ','J3 ','J5 ','J6 ', - + 'J7 ','J8 ','JA ','JD ', 'JT ','JW ', - + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', - + 'KH4 ','KH5 ', 'KH6 ','KH7 ','KH8 ','KH9 ','KL ', - + 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', - + 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', - + 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', - + 'PJ2 ','PJ7 ','PY ','PY0 ', 'PZ ','R1F ', - + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', - + 'ST ','SU ','SV ', 'SV5 ','SV9 ','T2 ','T30 ', - + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', - + 'TA1 ','TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', - + 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', - + 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', - + 'V6 ','V7 ','V8 ','VE ','VK ','VK0 ', 'VK9 ', - + 'VP2 ', - + 'VP5 ','VP6 ', 'VP8 ', - + 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', - + 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', - + 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', - + 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', - + 'ZD9 ','ZF ','ZK1 ', 'ZK2 ','ZK3 ','ZL ','ZL7 ', - + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 '/ - - ldxcc=.false. - ng=0 - do i=1,NZ - if(pfx(i)(1:3).eq.c) go to 10 - enddo - go to 20 - - 10 ng=180*180+61+i - ldxcc=.true. - - 20 return - end + subroutine packdxcc(c,ng,ldxcc) + + character*3 c + logical ldxcc + + parameter (NZ=303) + character*5 pfx(NZ) + data pfx/ + + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', + + '3D2 ', '3DA ','3V ','3W ','3X ','3Y ', + + '4J ','4L ','4S ','4U1 ', '4W ', + + '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', + + '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', + + '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', + + '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', + + '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', + + 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', + + 'C3 ','C5 ','C6 ','C9 ','CE ','CE0 ', + + 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', + + 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', + + 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', + + 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', + + 'F ','FG ','FH ','FJ ','FK ', 'FM ','FO ', + + 'FP ','FR ', + + 'FT5 ', 'FW ','FY ','M ','MD ','MI ', + + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', + + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ', + + 'HL ','HM ','HP ','HR ','HS ','HV ','HZ ', + + 'I ','IG9 ','IS ','IT9 ','J2 ','J3 ','J5 ','J6 ', + + 'J7 ','J8 ','JA ','JD ', 'JT ','JW ', + + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', + + 'KH4 ','KH5 ', 'KH6 ','KH7 ','KH8 ','KH9 ','KL ', + + 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', + + 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', + + 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', + + 'PJ2 ','PJ7 ','PY ','PY0 ', 'PZ ','R1F ', + + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', + + 'ST ','SU ','SV ', 'SV5 ','SV9 ','T2 ','T30 ', + + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', + + 'TA1 ','TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', + + 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', + + 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', + + 'V6 ','V7 ','V8 ','VE ','VK ','VK0 ', 'VK9 ', + + 'VP2 ', + + 'VP5 ','VP6 ', 'VP8 ', + + 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', + + 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', + + 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', + + 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', + + 'ZD9 ','ZF ','ZK1 ', 'ZK2 ','ZK3 ','ZL ','ZL7 ', + + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 '/ + + ldxcc=.false. + ng=0 + do i=1,NZ + if(pfx(i)(1:3).eq.c) go to 10 + enddo + go to 20 + + 10 ng=180*180+61+i + ldxcc=.true. + + 20 return + end diff --git a/packgrid.f b/packgrid.f index 1d881d158..2dc77ae19 100644 --- a/packgrid.f +++ b/packgrid.f @@ -1,47 +1,47 @@ - subroutine packgrid(grid,ng,text) - - parameter (NGBASE=180*180) - character*4 grid - logical text - - text=.false. - if(grid.eq.' ') go to 90 !Blank grid is OK - -C Test for numerical signal report, etc. - if(grid(1:1).eq.'-') then - read(grid(2:3),*,err=1,end=1) n - 1 ng=NGBASE+1+n - go to 100 - else if(grid(1:2).eq.'R-') then - read(grid(3:4),*,err=2,end=2) n - 2 if(n.eq.0) go to 90 - ng=NGBASE+31+n - go to 100 - else if(grid(1:2).eq.'RO') then - ng=NGBASE+62 - go to 100 - else if(grid(1:3).eq.'RRR') then - ng=NGBASE+63 - go to 100 - else if(grid(1:2).eq.'73') then - ng=NGBASE+64 - go to 100 - endif - - if(grid(1:1).lt.'A' .or. grid(1:1).gt.'Z') text=.true. - if(grid(2:2).lt.'A' .or. grid(2:2).gt.'Z') text=.true. - if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true. - if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true. - if(text) go to 100 - - call grid2deg(grid//'mm',dlong,dlat) - long=dlong - lat=dlat+ 90.0 - ng=((long+180)/2)*180 + lat - go to 100 - - 90 ng=NGBASE + 1 - - 100 return - end - + subroutine packgrid(grid,ng,text) + + parameter (NGBASE=180*180) + character*4 grid + logical text + + text=.false. + if(grid.eq.' ') go to 90 !Blank grid is OK + +C Test for numerical signal report, etc. + if(grid(1:1).eq.'-') then + read(grid(2:3),*,err=1,end=1) n + 1 ng=NGBASE+1+n + go to 100 + else if(grid(1:2).eq.'R-') then + read(grid(3:4),*,err=2,end=2) n + 2 if(n.eq.0) go to 90 + ng=NGBASE+31+n + go to 100 + else if(grid(1:2).eq.'RO') then + ng=NGBASE+62 + go to 100 + else if(grid(1:3).eq.'RRR') then + ng=NGBASE+63 + go to 100 + else if(grid(1:2).eq.'73') then + ng=NGBASE+64 + go to 100 + endif + + if(grid(1:1).lt.'A' .or. grid(1:1).gt.'Z') text=.true. + if(grid(2:2).lt.'A' .or. grid(2:2).gt.'Z') text=.true. + if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true. + if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true. + if(text) go to 100 + + call grid2deg(grid//'mm',dlong,dlat) + long=dlong + lat=dlat+ 90.0 + ng=((long+180)/2)*180 + lat + go to 100 + + 90 ng=NGBASE + 1 + + 100 return + end + diff --git a/packmsg.f b/packmsg.f index bc0dfd17e..5d5f301e8 100644 --- a/packmsg.f +++ b/packmsg.f @@ -1,85 +1,85 @@ - subroutine packmsg(msg,dat) - - parameter (NBASE=37*36*10*27*27*27) - character*22 msg - integer dat(12) - character*12 c1,c2 - character*4 c3 - character*6 grid6 -c character*3 dxcc !Where is DXCC implemented? - logical text1,text2,text3 - -C Convert all letters to upper case - do i=1,22 - if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') - + msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a')) - enddo - -C See if it's a CQ message - if(msg(1:3).eq.'CQ ') then - i=3 -C ... and if so, does it have a reply frequency? - if(msg(4:4).ge.'0' .and. msg(4:4).le.'9' .and. - + msg(5:5).ge.'0' .and. msg(5:5).le.'9' .and. - + msg(6:6).ge.'0' .and. msg(6:6).le.'9') i=7 - go to 1 - endif - - do i=1,22 - if(msg(i:i).eq.' ') go to 1 !Get 1st blank - enddo - go to 10 !Consider msg as plain text - - 1 ia=i - c1=msg(1:ia-1) - do i=ia+1,22 - if(msg(i:i).eq.' ') go to 2 !Get 2nd blank - enddo - go to 10 !Consider msg as plain text - - 2 ib=i - c2=msg(ia+1:ib-1) - - do i=ib+1,22 - if(msg(i:i).eq.' ') go to 3 !Get 3rd blank - enddo - go to 10 !Consider msg as plain text - - 3 ic=i - c3=' ' - if(ic.ge.ib+1) c3=msg(ib+1:ic) - if(c3.eq.'OOO ') c3=' ' !Strip out the OOO flag - call getpfx1(c1,k1) - call packcall(c1,nc1,text1) - call getpfx1(c2,k2) - call packcall(c2,nc2,text2) - if(k1.lt.0 .or. k2.lt.0 .or. k1*k2.ne.0) go to 10 - if(k2.gt.0) k2=k2+450 - k=max(k1,k2) - if(k.gt.0) then - call k2grid(k,grid6) - c3=grid6 - endif - call packgrid(c3,ng,text3) - if((.not.text1) .and. (.not.text2) .and. (.not.text3)) go to 20 - -C The message will be treated as plain text. - 10 call packtext(msg,nc1,nc2,ng) - ng=ng+32768 - -C Encode data into 6-bit words - 20 dat(1)=iand(ishft(nc1,-22),63) !6 bits - dat(2)=iand(ishft(nc1,-16),63) !6 bits - dat(3)=iand(ishft(nc1,-10),63) !6 bits - dat(4)=iand(ishft(nc1, -4),63) !6 bits - dat(5)=4*iand(nc1,15)+iand(ishft(nc2,-26),3) !4+2 bits - dat(6)=iand(ishft(nc2,-20),63) !6 bits - dat(7)=iand(ishft(nc2,-14),63) !6 bits - dat(8)=iand(ishft(nc2, -8),63) !6 bits - dat(9)=iand(ishft(nc2, -2),63) !6 bits - dat(10)=16*iand(nc2,3)+iand(ishft(ng,-12),15) !2+4 bits - dat(11)=iand(ishft(ng,-6),63) - dat(12)=iand(ng,63) - - return - end + subroutine packmsg(msg,dat) + + parameter (NBASE=37*36*10*27*27*27) + character*22 msg + integer dat(12) + character*12 c1,c2 + character*4 c3 + character*6 grid6 +c character*3 dxcc !Where is DXCC implemented? + logical text1,text2,text3 + +C Convert all letters to upper case + do i=1,22 + if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') + + msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a')) + enddo + +C See if it's a CQ message + if(msg(1:3).eq.'CQ ') then + i=3 +C ... and if so, does it have a reply frequency? + if(msg(4:4).ge.'0' .and. msg(4:4).le.'9' .and. + + msg(5:5).ge.'0' .and. msg(5:5).le.'9' .and. + + msg(6:6).ge.'0' .and. msg(6:6).le.'9') i=7 + go to 1 + endif + + do i=1,22 + if(msg(i:i).eq.' ') go to 1 !Get 1st blank + enddo + go to 10 !Consider msg as plain text + + 1 ia=i + c1=msg(1:ia-1) + do i=ia+1,22 + if(msg(i:i).eq.' ') go to 2 !Get 2nd blank + enddo + go to 10 !Consider msg as plain text + + 2 ib=i + c2=msg(ia+1:ib-1) + + do i=ib+1,22 + if(msg(i:i).eq.' ') go to 3 !Get 3rd blank + enddo + go to 10 !Consider msg as plain text + + 3 ic=i + c3=' ' + if(ic.ge.ib+1) c3=msg(ib+1:ic) + if(c3.eq.'OOO ') c3=' ' !Strip out the OOO flag + call getpfx1(c1,k1) + call packcall(c1,nc1,text1) + call getpfx1(c2,k2) + call packcall(c2,nc2,text2) + if(k1.lt.0 .or. k2.lt.0 .or. k1*k2.ne.0) go to 10 + if(k2.gt.0) k2=k2+450 + k=max(k1,k2) + if(k.gt.0) then + call k2grid(k,grid6) + c3=grid6 + endif + call packgrid(c3,ng,text3) + if((.not.text1) .and. (.not.text2) .and. (.not.text3)) go to 20 + +C The message will be treated as plain text. + 10 call packtext(msg,nc1,nc2,ng) + ng=ng+32768 + +C Encode data into 6-bit words + 20 dat(1)=iand(ishft(nc1,-22),63) !6 bits + dat(2)=iand(ishft(nc1,-16),63) !6 bits + dat(3)=iand(ishft(nc1,-10),63) !6 bits + dat(4)=iand(ishft(nc1, -4),63) !6 bits + dat(5)=4*iand(nc1,15)+iand(ishft(nc2,-26),3) !4+2 bits + dat(6)=iand(ishft(nc2,-20),63) !6 bits + dat(7)=iand(ishft(nc2,-14),63) !6 bits + dat(8)=iand(ishft(nc2, -8),63) !6 bits + dat(9)=iand(ishft(nc2, -2),63) !6 bits + dat(10)=16*iand(nc2,3)+iand(ishft(ng,-12),15) !2+4 bits + dat(11)=iand(ishft(ng,-6),63) + dat(12)=iand(ng,63) + + return + end diff --git a/packtext.f b/packtext.f index c06581a0a..52d299dd1 100644 --- a/packtext.f +++ b/packtext.f @@ -1,47 +1,47 @@ - subroutine packtext(msg,nc1,nc2,nc3) - - parameter (MASK28=2**28 - 1) - character*13 msg - character*44 c - data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ - - nc1=0 - nc2=0 - nc3=0 - - do i=1,5 !First 5 characters in nc1 - do j=1,44 !Get character code - if(msg(i:i).eq.c(j:j)) go to 10 - enddo - j=37 - 10 j=j-1 !Codes should start at zero - nc1=42*nc1 + j - enddo - - do i=6,10 !Characters 6-10 in nc2 - do j=1,44 !Get character code - if(msg(i:i).eq.c(j:j)) go to 20 - enddo - j=37 - 20 j=j-1 !Codes should start at zero - nc2=42*nc2 + j - enddo - - do i=11,13 !Characters 11-13 in nc3 - do j=1,44 !Get character code - if(msg(i:i).eq.c(j:j)) go to 30 - enddo - j=37 - 30 j=j-1 !Codes should start at zero - nc3=42*nc3 + j - enddo - -C We now have used 17 bits in nc3. Must move one each to nc1 and nc2. - nc1=nc1+nc1 - if(iand(nc3,32768).ne.0) nc1=nc1+1 - nc2=nc2+nc2 - if(iand(nc3,65536).ne.0) nc2=nc2+1 - nc3=iand(nc3,32767) - - return - end + subroutine packtext(msg,nc1,nc2,nc3) + + parameter (MASK28=2**28 - 1) + character*13 msg + character*44 c + data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ + + nc1=0 + nc2=0 + nc3=0 + + do i=1,5 !First 5 characters in nc1 + do j=1,44 !Get character code + if(msg(i:i).eq.c(j:j)) go to 10 + enddo + j=37 + 10 j=j-1 !Codes should start at zero + nc1=42*nc1 + j + enddo + + do i=6,10 !Characters 6-10 in nc2 + do j=1,44 !Get character code + if(msg(i:i).eq.c(j:j)) go to 20 + enddo + j=37 + 20 j=j-1 !Codes should start at zero + nc2=42*nc2 + j + enddo + + do i=11,13 !Characters 11-13 in nc3 + do j=1,44 !Get character code + if(msg(i:i).eq.c(j:j)) go to 30 + enddo + j=37 + 30 j=j-1 !Codes should start at zero + nc3=42*nc3 + j + enddo + +C We now have used 17 bits in nc3. Must move one each to nc1 and nc2. + nc1=nc1+nc1 + if(iand(nc3,32768).ne.0) nc1=nc1+1 + nc2=nc2+nc2 + if(iand(nc3,65536).ne.0) nc2=nc2+1 + nc3=iand(nc3,32767) + + return + end diff --git a/pctile.f b/pctile.f index e0336ba21..c0b95aea6 100644 --- a/pctile.f +++ b/pctile.f @@ -1,13 +1,13 @@ - subroutine pctile(x,tmp,nmax,npct,xpct) - real x(nmax),tmp(nmax) - - do i=1,nmax - tmp(i)=x(i) - enddo - call sort(nmax,tmp) - j=nint(nmax*0.01*npct) - if(j.lt.1) j=1 - xpct=tmp(j) - - return - end + subroutine pctile(x,tmp,nmax,npct,xpct) + real x(nmax),tmp(nmax) + + do i=1,nmax + tmp(i)=x(i) + enddo + call sort(nmax,tmp) + j=nint(nmax*0.01*npct) + if(j.lt.1) j=1 + xpct=tmp(j) + + return + end diff --git a/peakup.f b/peakup.f index 74b4be2a4..bef58cc32 100644 --- a/peakup.f +++ b/peakup.f @@ -1,8 +1,8 @@ - subroutine peakup(ym,y0,yp,dx) - - b=(yp-ym)/2.0 - c=(yp+ym-2.0*y0)/2.0 - dx=-b/(2.0*c) - - return - end + subroutine peakup(ym,y0,yp,dx) + + b=(yp-ym)/2.0 + c=(yp+ym-2.0*y0)/2.0 + dx=-b/(2.0*c) + + return + end diff --git a/pfx.f b/pfx.f index 34efb37f5..1e8ae4069 100644 --- a/pfx.f +++ b/pfx.f @@ -1,50 +1,50 @@ - parameter (NZ=338) !Total number of prefixes - parameter (NZ2=12) !Total number of suffixes - character*1 sfx(NZ2) - character*5 pfx(NZ) - - data sfx/'P','0','1','2','3','4','5','6','7','8','9','A'/ - data pfx/ - + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', - + '3D2 ','3D2C ','3D2R ','3DA ','3V ','3W ','3X ','3Y ', - + '3YB ','3YP ','4J ','4L ','4S ','4U1I ','4U1U ','4W ', - + '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', - + '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', - + '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', - + '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', - + '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', - + 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', - + 'C3 ','C5 ','C6 ','C9 ','CE ','CE0X ','CE0Y ','CE0Z ', - + 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', - + 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', - + 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', - + 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', - + 'F ','FG ','FH ','FJ ','FK ','FKC ','FM ','FO ', - + 'FOA ','FOC ','FOM ','FP ','FR ','FRG ','FRJ ','FRT ', - + 'FT5W ','FT5X ','FT5Z ','FW ','FY ','M ','MD ','MI ', - + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', - + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0A ', - + 'HK0M ','HL ','HM ','HP ','HR ','HS ','HV ','HZ ', - + 'I ','IS ','IS0 ', 'J2 ','J3 ','J5 ','J6 ', - + 'J7 ','J8 ','JA ','JDM ','JDO ','JT ','JW ', - + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', - + 'KH4 ','KH5 ','KH5K ','KH6 ','KH7 ','KH8 ','KH9 ','KL ', - + 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', - + 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', - + 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', - + 'PJ2 ','PJ7 ','PY ','PY0F ','PT0S ','PY0T ','PZ ','R1F ', - + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', - + 'ST ','SU ','SV ','SVA ','SV5 ','SV9 ','T2 ','T30 ', - + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', - + 'TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', - + 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', - + 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', - + 'V6 ','V7 ','V8 ','VE ','VK ','VK0H ','VK0M ','VK9C ', - + 'VK9L ','VK9M ','VK9N ','VK9W ','VK9X ','VP2E ','VP2M ','VP2V ', - + 'VP5 ','VP6 ','VP6D ','VP8 ','VP8G ','VP8H ','VP8O ','VP8S ', - + 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', - + 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', - + 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', - + 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', - + 'ZD9 ','ZF ','ZK1N ','ZK1S ','ZK2 ','ZK3 ','ZL ','ZL7 ', - + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 ','KC4 '/ + parameter (NZ=338) !Total number of prefixes + parameter (NZ2=12) !Total number of suffixes + character*1 sfx(NZ2) + character*5 pfx(NZ) + + data sfx/'P','0','1','2','3','4','5','6','7','8','9','A'/ + data pfx/ + + '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', + + '3D2 ','3D2C ','3D2R ','3DA ','3V ','3W ','3X ','3Y ', + + '3YB ','3YP ','4J ','4L ','4S ','4U1I ','4U1U ','4W ', + + '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', + + '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', + + '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', + + '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', + + '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', + + 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', + + 'C3 ','C5 ','C6 ','C9 ','CE ','CE0X ','CE0Y ','CE0Z ', + + 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', + + 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', + + 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', + + 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', + + 'F ','FG ','FH ','FJ ','FK ','FKC ','FM ','FO ', + + 'FOA ','FOC ','FOM ','FP ','FR ','FRG ','FRJ ','FRT ', + + 'FT5W ','FT5X ','FT5Z ','FW ','FY ','M ','MD ','MI ', + + 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', + + 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0A ', + + 'HK0M ','HL ','HM ','HP ','HR ','HS ','HV ','HZ ', + + 'I ','IS ','IS0 ', 'J2 ','J3 ','J5 ','J6 ', + + 'J7 ','J8 ','JA ','JDM ','JDO ','JT ','JW ', + + 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', + + 'KH4 ','KH5 ','KH5K ','KH6 ','KH7 ','KH8 ','KH9 ','KL ', + + 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', + + 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', + + 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', + + 'PJ2 ','PJ7 ','PY ','PY0F ','PT0S ','PY0T ','PZ ','R1F ', + + 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', + + 'ST ','SU ','SV ','SVA ','SV5 ','SV9 ','T2 ','T30 ', + + 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', + + 'TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', + + 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', + + 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', + + 'V6 ','V7 ','V8 ','VE ','VK ','VK0H ','VK0M ','VK9C ', + + 'VK9L ','VK9M ','VK9N ','VK9W ','VK9X ','VP2E ','VP2M ','VP2V ', + + 'VP5 ','VP6 ','VP6D ','VP8 ','VP8G ','VP8H ','VP8O ','VP8S ', + + 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', + + 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', + + 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', + + 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', + + 'ZD9 ','ZF ','ZK1N ','ZK1S ','ZK2 ','ZK3 ','ZL ','ZL7 ', + + 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 ','KC4 '/ diff --git a/pix2d65.f90 b/pix2d65.f90 index 0daf73d18..936756cc0 100644 --- a/pix2d65.f90 +++ b/pix2d65.f90 @@ -1,28 +1,28 @@ -subroutine pix2d65(d2,jz) - -! Compute data for green line in JT65 mode. - - integer*2 d2(jz) !Raw input data - include 'gcom2.f90' - - sum=0. - do i=1,jz - sum=sum+d2(i) - enddo - nave=nint(sum/jz) - nadd=nint(53.0*11025.0/500.0) - ngreen=min(jz/nadd,500) - k=0 - do i=1,ngreen - sq=0. - do n=1,nadd - k=k+1 - d2(k)=d2(k)-nave - x=d2(k) - sq=sq + x*x - enddo - green(i)=db(sq)-96.0 - enddo - - return -end subroutine pix2d65 +subroutine pix2d65(d2,jz) + +! Compute data for green line in JT65 mode. + + integer*2 d2(jz) !Raw input data + include 'gcom2.f90' + + sum=0. + do i=1,jz + sum=sum+d2(i) + enddo + nave=nint(sum/jz) + nadd=nint(53.0*11025.0/500.0) + ngreen=min(jz/nadd,500) + k=0 + do i=1,ngreen + sq=0. + do n=1,nadd + k=k+1 + d2(k)=d2(k)-nave + x=d2(k) + sq=sq + x*x + enddo + green(i)=db(sq)-96.0 + enddo + + return +end subroutine pix2d65 diff --git a/portaudio.h b/portaudio.h index 250fba021..cc30a28a1 100644 --- a/portaudio.h +++ b/portaudio.h @@ -1,1123 +1,1123 @@ - -#ifndef PORTAUDIO_H -#define PORTAUDIO_H -/* - * $Id: portaudio.h,v 1.1 2005/11/29 21:27:24 joe Exp $ - * PortAudio Portable Real-Time Audio Library - * PortAudio API Header File - * Latest version available at: http://www.portaudio.com/ - * - * Copyright (c) 1999-2002 Ross Bencina and Phil Burk - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files - * (the "Software"), to deal in the Software without restriction, - * including without limitation the rights to use, copy, modify, merge, - * publish, distribute, sublicense, and/or sell copies of the Software, - * and to permit persons to whom the Software is furnished to do so, - * subject to the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * Any person wishing to distribute modifications to the Software is - * requested to send the modifications to the original developer so that - * they can be incorporated into the canonical version. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR - * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** @file - @brief The PortAudio API. -*/ - - -#ifdef __cplusplus -extern "C" -{ -#endif /* __cplusplus */ - - -/** Retrieve the release number of the currently running PortAudio build, - eg 1900. -*/ -int Pa_GetVersion( void ); - - -/** Retrieve a textual description of the current PortAudio build, - eg "PortAudio V19-devel 13 October 2002". -*/ -const char* Pa_GetVersionText( void ); - - -/** Error codes returned by PortAudio functions. - Note that with the exception of paNoError, all PaErrorCodes are negative. -*/ - -typedef int PaError; -typedef enum PaErrorCode -{ - paNoError = 0, - - paNotInitialized = -10000, - paUnanticipatedHostError, - paInvalidChannelCount, - paInvalidSampleRate, - paInvalidDevice, - paInvalidFlag, - paSampleFormatNotSupported, - paBadIODeviceCombination, - paInsufficientMemory, - paBufferTooBig, - paBufferTooSmall, - paNullCallback, - paBadStreamPtr, - paTimedOut, - paInternalError, - paDeviceUnavailable, - paIncompatibleHostApiSpecificStreamInfo, - paStreamIsStopped, - paStreamIsNotStopped, - paInputOverflowed, - paOutputUnderflowed, - paHostApiNotFound, - paInvalidHostApi, - paCanNotReadFromACallbackStream, /**< @todo review error code name */ - paCanNotWriteToACallbackStream, /**< @todo review error code name */ - paCanNotReadFromAnOutputOnlyStream, /**< @todo review error code name */ - paCanNotWriteToAnInputOnlyStream, /**< @todo review error code name */ - paIncompatibleStreamHostApi -} PaErrorCode; - - -/** Translate the supplied PortAudio error code into a human readable - message. -*/ -const char *Pa_GetErrorText( PaError errorCode ); - - -/** Library initialization function - call this before using PortAudio. - This function initialises internal data structures and prepares underlying - host APIs for use. This function MUST be called before using any other - PortAudio API functions. - - If Pa_Initialize() is called multiple times, each successful - call must be matched with a corresponding call to Pa_Terminate(). - Pairs of calls to Pa_Initialize()/Pa_Terminate() may overlap, and are not - required to be fully nested. - - Note that if Pa_Initialize() returns an error code, Pa_Terminate() should - NOT be called. - - @return paNoError if successful, otherwise an error code indicating the cause - of failure. - - @see Pa_Terminate -*/ -PaError Pa_Initialize( void ); - - -/** Library termination function - call this when finished using PortAudio. - This function deallocates all resources allocated by PortAudio since it was - initializied by a call to Pa_Initialize(). In cases where Pa_Initialise() has - been called multiple times, each call must be matched with a corresponding call - to Pa_Terminate(). The final matching call to Pa_Terminate() will automatically - close any PortAudio streams that are still open. - - Pa_Terminate() MUST be called before exiting a program which uses PortAudio. - Failure to do so may result in serious resource leaks, such as audio devices - not being available until the next reboot. - - @return paNoError if successful, otherwise an error code indicating the cause - of failure. - - @see Pa_Initialize -*/ -PaError Pa_Terminate( void ); - - - -/** The type used to refer to audio devices. Values of this type usually - range from 0 to (Pa_DeviceCount-1), and may also take on the PaNoDevice - and paUseHostApiSpecificDeviceSpecification values. - - @see Pa_DeviceCount, paNoDevice, paUseHostApiSpecificDeviceSpecification -*/ -typedef int PaDeviceIndex; - - -/** A special PaDeviceIndex value indicating that no device is available, - or should be used. - - @see PaDeviceIndex -*/ -#define paNoDevice ((PaDeviceIndex)-1) - - -/** A special PaDeviceIndex value indicating that the device(s) to be used - are specified in the host api specific stream info structure. - - @see PaDeviceIndex -*/ -#define paUseHostApiSpecificDeviceSpecification ((PaDeviceIndex)-2) - - -/* Host API enumeration mechanism */ - -/** The type used to enumerate to host APIs at runtime. Values of this type - range from 0 to (Pa_GetHostApiCount()-1). - - @see Pa_GetHostApiCount -*/ -typedef int PaHostApiIndex; - - -/** Retrieve the number of available host APIs. Even if a host API is - available it may have no devices available. - - @return A non-negative value indicating the number of available host APIs - or, a PaErrorCode (which are always negative) if PortAudio is not initialized - or an error is encountered. - - @see PaHostApiIndex -*/ -PaHostApiIndex Pa_GetHostApiCount( void ); - - -/** Retrieve the index of the default host API. The default host API will be - the lowest common denominator host API on the current platform and is - unlikely to provide the best performance. - - @return A non-negative value ranging from 0 to (Pa_GetHostApiCount()-1) - indicating the default host API index or, a PaErrorCode (which are always - negative) if PortAudio is not initialized or an error is encountered. -*/ -PaHostApiIndex Pa_GetDefaultHostApi( void ); - - -/** Unchanging unique identifiers for each supported host API. This type - is used in the PaHostApiInfo structure. The values are guaranteed to be - unique and to never change, thus allowing code to be written that - conditionally uses host API specific extensions. - - New type ids will be allocated when support for a host API reaches - "public alpha" status, prior to that developers should use the - paInDevelopment type id. - - @see PaHostApiInfo -*/ -typedef enum PaHostApiTypeId -{ - paInDevelopment=0, /* use while developing support for a new host API */ - paDirectSound=1, - paMME=2, - paASIO=3, - paSoundManager=4, - paCoreAudio=5, - paOSS=7, - paALSA=8, - paAL=9, - paBeOS=10, - paWDMKS=11, - paJACK=12 -} PaHostApiTypeId; - - -/** A structure containing information about a particular host API. */ - -typedef struct PaHostApiInfo -{ - /** this is struct version 1 */ - int structVersion; - /** The well known unique identifier of this host API @see PaHostApiTypeId */ - PaHostApiTypeId type; - /** A textual description of the host API for display on user interfaces. */ - const char *name; - - /** The number of devices belonging to this host API. This field may be - used in conjunction with Pa_HostApiDeviceIndexToDeviceIndex() to enumerate - all devices for this host API. - @see Pa_HostApiDeviceIndexToDeviceIndex - */ - int deviceCount; - - /** The the default input device for this host API. The value will be a - device index ranging from 0 to (Pa_GetDeviceCount()-1), or paNoDevice - if no default input device is available. - */ - PaDeviceIndex defaultInputDevice; - - /** The the default output device for this host API. The value will be a - device index ranging from 0 to (Pa_GetDeviceCount()-1), or paNoDevice - if no default output device is available. - */ - PaDeviceIndex defaultOutputDevice; - -} PaHostApiInfo; - - -/** Retrieve a pointer to a structure containing information about a specific - host Api. - - @param hostApi A valid host API index ranging from 0 to (Pa_GetHostApiCount()-1) - - @return A pointer to an immutable PaHostApiInfo structure describing - a specific host API. If the hostApi parameter is out of range or an error - is encountered, the function returns NULL. - - The returned structure is owned by the PortAudio implementation and must not - be manipulated or freed. The pointer is only guaranteed to be valid between - calls to Pa_Initialize() and Pa_Terminate(). -*/ -const PaHostApiInfo * Pa_GetHostApiInfo( PaHostApiIndex hostApi ); - - -/** Convert a static host API unique identifier, into a runtime - host API index. - - @param type A unique host API identifier belonging to the PaHostApiTypeId - enumeration. - - @return A valid PaHostApiIndex ranging from 0 to (Pa_GetHostApiCount()-1) or, - a PaErrorCode (which are always negative) if PortAudio is not initialized - or an error is encountered. - - The paHostApiNotFound error code indicates that the host API specified by the - type parameter is not available. - - @see PaHostApiTypeId -*/ -PaHostApiIndex Pa_HostApiTypeIdToHostApiIndex( PaHostApiTypeId type ); - - -/** Convert a host-API-specific device index to standard PortAudio device index. - This function may be used in conjunction with the deviceCount field of - PaHostApiInfo to enumerate all devices for the specified host API. - - @param hostApi A valid host API index ranging from 0 to (Pa_GetHostApiCount()-1) - - @param hostApiDeviceIndex A valid per-host device index in the range - 0 to (Pa_GetHostApiInfo(hostApi)->deviceCount-1) - - @return A non-negative PaDeviceIndex ranging from 0 to (Pa_GetDeviceCount()-1) - or, a PaErrorCode (which are always negative) if PortAudio is not initialized - or an error is encountered. - - A paInvalidHostApi error code indicates that the host API index specified by - the hostApi parameter is out of range. - - A paInvalidDevice error code indicates that the hostApiDeviceIndex parameter - is out of range. - - @see PaHostApiInfo -*/ -PaDeviceIndex Pa_HostApiDeviceIndexToDeviceIndex( PaHostApiIndex hostApi, - int hostApiDeviceIndex ); - - - -/** Structure used to return information about a host error condition. -*/ -typedef struct PaHostErrorInfo{ - PaHostApiTypeId hostApiType; /**< the host API which returned the error code */ - long errorCode; /**< the error code returned */ - const char *errorText; /**< a textual description of the error if available, otherwise a zero-length string */ -}PaHostErrorInfo; - - -/** Return information about the last host error encountered. The error - information returned by Pa_GetLastHostErrorInfo() will never be modified - asyncronously by errors occurring in other PortAudio owned threads - (such as the thread that manages the stream callback.) - - This function is provided as a last resort, primarily to enhance debugging - by providing clients with access to all available error information. - - @return A pointer to an immutable structure constaining information about - the host error. The values in this structure will only be valid if a - PortAudio function has previously returned the paUnanticipatedHostError - error code. -*/ -const PaHostErrorInfo* Pa_GetLastHostErrorInfo( void ); - - - -/* Device enumeration and capabilities */ - -/** Retrieve the number of available devices. The number of available devices - may be zero. - - @return A non-negative value indicating the number of available devices or, - a PaErrorCode (which are always negative) if PortAudio is not initialized - or an error is encountered. -*/ -PaDeviceIndex Pa_GetDeviceCount( void ); - - -/** Retrieve the index of the default input device. The result can be - used in the inputDevice parameter to Pa_OpenStream(). - - @return The default input device index for the default host API, or paNoDevice - if no default input device is available or an error was encountered. -*/ -PaDeviceIndex Pa_GetDefaultInputDevice( void ); - - -/** Retrieve the index of the default output device. The result can be - used in the outputDevice parameter to Pa_OpenStream(). - - @return The default output device index for the defualt host API, or paNoDevice - if no default output device is available or an error was encountered. - - @note - On the PC, the user can specify a default device by - setting an environment variable. For example, to use device #1. -
- set PA_RECOMMENDED_OUTPUT_DEVICE=1
-
- The user should first determine the available device ids by using - the supplied application "pa_devs". -*/ -PaDeviceIndex Pa_GetDefaultOutputDevice( void ); - - -/** The type used to represent monotonic time in seconds that can be used - for syncronisation. The type is used for the outTime argument to the - PaStreamCallback and as the result of Pa_GetStreamTime(). - - @see PaStreamCallback, Pa_GetStreamTime -*/ -typedef double PaTime; - - -/** A type used to specify one or more sample formats. Each value indicates - a possible format for sound data passed to and from the stream callback, - Pa_ReadStream and Pa_WriteStream. - - The standard formats paFloat32, paInt16, paInt32, paInt24, paInt8 - and aUInt8 are usually implemented by all implementations. - - The floating point representation (paFloat32) uses +1.0 and -1.0 as the - maximum and minimum respectively. - - paUInt8 is an unsigned 8 bit format where 128 is considered "ground" - - The paNonInterleaved flag indicates that a multichannel buffer is passed - as a set of non-interleaved pointers. - - @see Pa_OpenStream, Pa_OpenDefaultStream, PaDeviceInfo - @see paFloat32, paInt16, paInt32, paInt24, paInt8 - @see paUInt8, paCustomFormat, paNonInterleaved -*/ -typedef unsigned long PaSampleFormat; - - -#define paFloat32 ((PaSampleFormat) 0x00000001) /**< @see PaSampleFormat */ -#define paInt32 ((PaSampleFormat) 0x00000002) /**< @see PaSampleFormat */ -#define paInt24 ((PaSampleFormat) 0x00000004) /**< Packed 24 bit format. @see PaSampleFormat */ -#define paInt16 ((PaSampleFormat) 0x00000008) /**< @see PaSampleFormat */ -#define paInt8 ((PaSampleFormat) 0x00000010) /**< @see PaSampleFormat */ -#define paUInt8 ((PaSampleFormat) 0x00000020) /**< @see PaSampleFormat */ -#define paCustomFormat ((PaSampleFormat) 0x00010000)/**< @see PaSampleFormat */ - -#define paNonInterleaved ((PaSampleFormat) 0x80000000) - -/** A structure providing information and capabilities of PortAudio devices. - Devices may support input, output or both input and output. -*/ -typedef struct PaDeviceInfo -{ - int structVersion; /* this is struct version 2 */ - const char *name; - PaHostApiIndex hostApi; /* note this is a host API index, not a type id*/ - - int maxInputChannels; - int maxOutputChannels; - - /* Default latency values for interactive performance. */ - PaTime defaultLowInputLatency; - PaTime defaultLowOutputLatency; - /* Default latency values for robust non-interactive applications (eg. playing sound files). */ - PaTime defaultHighInputLatency; - PaTime defaultHighOutputLatency; - - double defaultSampleRate; -} PaDeviceInfo; - - -/** Retrieve a pointer to a PaDeviceInfo structure containing information - about the specified device. - @return A pointer to an immutable PaDeviceInfo structure. If the device - parameter is out of range the function returns NULL. - - @param device A valid device index in the range 0 to (Pa_GetDeviceCount()-1) - - @note PortAudio manages the memory referenced by the returned pointer, - the client must not manipulate or free the memory. The pointer is only - guaranteed to be valid between calls to Pa_Initialize() and Pa_Terminate(). - - @see PaDeviceInfo, PaDeviceIndex -*/ -const PaDeviceInfo* Pa_GetDeviceInfo( PaDeviceIndex device ); - - -/** Parameters for one direction (input or output) of a stream. -*/ -typedef struct PaStreamParameters -{ - /** A valid device index in the range 0 to (Pa_GetDeviceCount()-1) - specifying the device to be used or the special constant - paUseHostApiSpecificDeviceSpecification which indicates that the actual - device(s) to use are specified in hostApiSpecificStreamInfo. - This field must not be set to paNoDevice. - */ - PaDeviceIndex device; - - /** The number of channels of sound to be delivered to the - stream callback or accessed by Pa_ReadStream() or Pa_WriteStream(). - It can range from 1 to the value of maxInputChannels in the - PaDeviceInfo record for the device specified by the device parameter. - */ - int channelCount; - - /** The sample format of the buffer provided to the stream callback, - a_ReadStream() or Pa_WriteStream(). It may be any of the formats described - by the PaSampleFormat enumeration. - */ - PaSampleFormat sampleFormat; - - /** The desired latency in seconds. Where practical, implementations should - configure their latency based on these parameters, otherwise they may - choose the closest viable latency instead. Unless the suggested latency - is greater than the absolute upper limit for the device implementations - shouldround the suggestedLatency up to the next practial value - ie to - provide an equal or higher latency than suggestedLatency whereever possibe. - Actual latency values for an open stream may be retrieved using the - inputLatency and outputLatency fields of the PaStreamInfo structure - returned by Pa_GetStreamInfo(). - @see default*Latency in PaDeviceInfo, *Latency in PaStreamInfo - */ - PaTime suggestedLatency; - - /** An optional pointer to a host api specific data structure - containing additional information for device setup and/or stream processing. - hostApiSpecificStreamInfo is never required for correct operation, - if not used it should be set to NULL. - */ - void *hostApiSpecificStreamInfo; - -} PaStreamParameters; - - -/** Return code for Pa_IsFormatSupported indicating success. */ -#define paFormatIsSupported (0) - -/** Determine whether it would be possible to open a stream with the specified - parameters. - - @param inputParameters A structure that describes the input parameters used to - open a stream. The suggestedLatency field is ignored. See PaStreamParameters - for a description of these parameters. inputParameters must be NULL for - output-only streams. - - @param outputParameters A structure that describes the output parameters used - to open a stream. The suggestedLatency field is ignored. See PaStreamParameters - for a description of these parameters. outputParameters must be NULL for - input-only streams. - - @param sampleRate The required sampleRate. For full-duplex streams it is the - sample rate for both input and output - - @return Returns 0 if the format is supported, and an error code indicating why - the format is not supported otherwise. The constant paFormatIsSupported is - provided to compare with the return value for success. - - @see paFormatIsSupported, PaStreamParameters -*/ -PaError Pa_IsFormatSupported( const PaStreamParameters *inputParameters, - const PaStreamParameters *outputParameters, - double sampleRate ); - - - -/* Streaming types and functions */ - - -/** - A single PaStream can provide multiple channels of real-time - streaming audio input and output to a client application. A stream - provides access to audio hardware represented by one or more - PaDevices. Depending on the underlying Host API, it may be possible - to open multiple streams using the same device, however this behavior - is implementation defined. Portable applications should assume that - a PaDevice may be simultaneously used by at most one PaStream. - - Pointers to PaStream objects are passed between PortAudio functions that - operate on streams. - - @see Pa_OpenStream, Pa_OpenDefaultStream, Pa_OpenDefaultStream, Pa_CloseStream, - Pa_StartStream, Pa_StopStream, Pa_AbortStream, Pa_IsStreamActive, - Pa_GetStreamTime, Pa_GetStreamCpuLoad - -*/ -typedef void PaStream; - - -/** Can be passed as the framesPerBuffer parameter to Pa_OpenStream() - or Pa_OpenDefaultStream() to indicate that the stream callback will - accept buffers of any size. -*/ -#define paFramesPerBufferUnspecified (0) - - -/** Flags used to control the behavior of a stream. They are passed as - parameters to Pa_OpenStream or Pa_OpenDefaultStream. Multiple flags may be - ORed together. - - @see Pa_OpenStream, Pa_OpenDefaultStream - @see paNoFlag, paClipOff, paDitherOff, paNeverDropInput, - paPrimeOutputBuffersUsingStreamCallback, paPlatformSpecificFlags -*/ -typedef unsigned long PaStreamFlags; - -/** @see PaStreamFlags */ -#define paNoFlag ((PaStreamFlags) 0) - -/** Disable default clipping of out of range samples. - @see PaStreamFlags -*/ -#define paClipOff ((PaStreamFlags) 0x00000001) - -/** Disable default dithering. - @see PaStreamFlags -*/ -#define paDitherOff ((PaStreamFlags) 0x00000002) - -/** Flag requests that where possible a full duplex stream will not discard - overflowed input samples without calling the stream callback. This flag is - only valid for full duplex callback streams and only when used in combination - with the paFramesPerBufferUnspecified (0) framesPerBuffer parameter. Using - this flag incorrectly results in a paInvalidFlag error being returned from - Pa_OpenStream and Pa_OpenDefaultStream. - - @see PaStreamFlags, paFramesPerBufferUnspecified -*/ -#define paNeverDropInput ((PaStreamFlags) 0x00000004) - -/** Call the stream callback to fill initial output buffers, rather than the - default behavior of priming the buffers with zeros (silence). This flag has - no effect for input-only and blocking read/write streams. - - @see PaStreamFlags -*/ -#define paPrimeOutputBuffersUsingStreamCallback ((PaStreamFlags) 0x00000008) - -/** A mask specifying the platform specific bits. - @see PaStreamFlags -*/ -#define paPlatformSpecificFlags ((PaStreamFlags)0xFFFF0000) - -/** - Timing information for the buffers passed to the stream callback. -*/ -typedef struct PaStreamCallbackTimeInfo{ - PaTime inputBufferAdcTime; - PaTime currentTime; - PaTime outputBufferDacTime; -} PaStreamCallbackTimeInfo; - - -/** - Flag bit constants for the statusFlags to PaStreamCallback. - - @see paInputUnderflow, paInputOverflow, paOutputUnderflow, paOutputOverflow, - paPrimingOutput -*/ -typedef unsigned long PaStreamCallbackFlags; - -/** In a stream opened with paFramesPerBufferUnspecified, indicates that - input data is all silence (zeros) because no real data is available. In a - stream opened without paFramesPerBufferUnspecified, it indicates that one or - more zero samples have been inserted into the input buffer to compensate - for an input underflow. - @see PaStreamCallbackFlags -*/ -#define paInputUnderflow ((PaStreamCallbackFlags) 0x00000001) - -/** In a stream opened with paFramesPerBufferUnspecified, indicates that data - prior to the first sample of the input buffer was discarded due to an - overflow, possibly because the stream callback is using too much CPU time. - Otherwise indicates that data prior to one or more samples in the - input buffer was discarded. - @see PaStreamCallbackFlags -*/ -#define paInputOverflow ((PaStreamCallbackFlags) 0x00000002) - -/** Indicates that output data (or a gap) was inserted, possibly because the - stream callback is using too much CPU time. - @see PaStreamCallbackFlags -*/ -#define paOutputUnderflow ((PaStreamCallbackFlags) 0x00000004) - -/** Indicates that output data will be discarded because no room is available. - @see PaStreamCallbackFlags -*/ -#define paOutputOverflow ((PaStreamCallbackFlags) 0x00000008) - -/** Some of all of the output data will be used to prime the stream, input - data may be zero. - @see PaStreamCallbackFlags -*/ -#define paPrimingOutput ((PaStreamCallbackFlags) 0x00000010) - -/** - Allowable return values for the PaStreamCallback. - @see PaStreamCallback -*/ -typedef enum PaStreamCallbackResult -{ - paContinue=0, - paComplete=1, - paAbort=2 -} PaStreamCallbackResult; - - -/** - Functions of type PaStreamCallback are implemented by PortAudio clients. - They consume, process or generate audio in response to requests from an - active PortAudio stream. - - @param input and @param output are arrays of interleaved samples, - the format, packing and number of channels used by the buffers are - determined by parameters to Pa_OpenStream(). - - @param frameCount The number of sample frames to be processed by - the stream callback. - - @param timeInfo The time in seconds when the first sample of the input - buffer was received at the audio input, the time in seconds when the first - sample of the output buffer will begin being played at the audio output, and - the time in seconds when the stream callback was called. - See also Pa_GetStreamTime() - - @param statusFlags Flags indicating whether input and/or output buffers - have been inserted or will be dropped to overcome underflow or overflow - conditions. - - @param userData The value of a user supplied pointer passed to - Pa_OpenStream() intended for storing synthesis data etc. - - @return - The stream callback should return one of the values in the - PaStreamCallbackResult enumeration. To ensure that the callback continues - to be called, it should return paContinue (0). Either paComplete or paAbort - can be returned to finish stream processing, after either of these values is - returned the callback will not be called again. If paAbort is returned the - stream will finish as soon as possible. If paComplete is returned, the stream - will continue until all buffers generated by the callback have been played. - This may be useful in applications such as soundfile players where a specific - duration of output is required. However, it is not necessary to utilise this - mechanism as Pa_StopStream(), Pa_AbortStream() or Pa_CloseStream() can also - be used to stop the stream. The callback must always fill the entire output - buffer irrespective of its return value. - - @see Pa_OpenStream, Pa_OpenDefaultStream - - @note With the exception of Pa_GetStreamCpuLoad() it is not permissable to call - PortAudio API functions from within the stream callback. -*/ -typedef int PaStreamCallback( - const void *input, void *output, - unsigned long frameCount, - const PaStreamCallbackTimeInfo* timeInfo, - PaStreamCallbackFlags statusFlags, - void *userData ); - - -/** Opens a stream for either input, output or both. - - @param stream The address of a PaStream pointer which will receive - a pointer to the newly opened stream. - - @param inputParameters A structure that describes the input parameters used by - the opened stream. See PaStreamParameters for a description of these parameters. - inputParameters must be NULL for output-only streams. - - @param outputParameters A structure that describes the output parameters used by - the opened stream. See PaStreamParameters for a description of these parameters. - outputParameters must be NULL for input-only streams. - - @param sampleRate The desired sampleRate. For full-duplex streams it is the - sample rate for both input and output - - @param framesPerBuffer The number of frames passed to the stream callback - function, or the preferred block granularity for a blocking read/write stream. - The special value paFramesPerBufferUnspecified (0) may be used to request that - the stream callback will recieve an optimal (and possibly varying) number of - frames based on host requirements and the requested latency settings. - Note: With some host APIs, the use of non-zero framesPerBuffer for a callback - stream may introduce an additional layer of buffering which could introduce - additional latency. PortAudio guarantees that the additional latency - will be kept to the theoretical minimum however, it is strongly recommended - that a non-zero framesPerBuffer value only be used when your algorithm - requires a fixed number of frames per stream callback. - - @param streamFlags Flags which modify the behaviour of the streaming process. - This parameter may contain a combination of flags ORed together. Some flags may - only be relevant to certain buffer formats. - - @param streamCallback A pointer to a client supplied function that is responsible - for processing and filling input and output buffers. If this parameter is NULL - the stream will be opened in 'blocking read/write' mode. In blocking mode, - the client can receive sample data using Pa_ReadStream and write sample data - using Pa_WriteStream, the number of samples that may be read or written - without blocking is returned by Pa_GetStreamReadAvailable and - Pa_GetStreamWriteAvailable respectively. - - @param userData A client supplied pointer which is passed to the stream callback - function. It could for example, contain a pointer to instance data necessary - for processing the audio buffers. This parameter is ignored if streamCallback - is NULL. - - @return - Upon success Pa_OpenStream() returns paNoError and places a pointer to a - valid PaStream in the stream argument. The stream is inactive (stopped). - If a call to Pa_OpenStream() fails, a non-zero error code is returned (see - PaError for possible error codes) and the value of stream is invalid. - - @see PaStreamParameters, PaStreamCallback, Pa_ReadStream, Pa_WriteStream, - Pa_GetStreamReadAvailable, Pa_GetStreamWriteAvailable -*/ -PaError Pa_OpenStream( PaStream** stream, - const PaStreamParameters *inputParameters, - const PaStreamParameters *outputParameters, - double sampleRate, - unsigned long framesPerBuffer, - PaStreamFlags streamFlags, - PaStreamCallback *streamCallback, - void *userData ); - - -/** A simplified version of Pa_OpenStream() that opens the default input - and/or output devices. - - @param stream The address of a PaStream pointer which will receive - a pointer to the newly opened stream. - - @param numInputChannels The number of channels of sound that will be supplied - to the stream callback or returned by Pa_ReadStream. It can range from 1 to - the value of maxInputChannels in the PaDeviceInfo record for the default input - device. If 0 the stream is opened as an output-only stream. - - @param numOutputChannels The number of channels of sound to be delivered to the - stream callback or passed to Pa_WriteStream. It can range from 1 to the value - of maxOutputChannels in the PaDeviceInfo record for the default output dvice. - If 0 the stream is opened as an output-only stream. - - @param sampleFormat The sample format of both the input and output buffers - provided to the callback or passed to and from Pa_ReadStream and Pa_WriteStream. - sampleFormat may be any of the formats described by the PaSampleFormat - enumeration. - - @param sampleRate Same as Pa_OpenStream parameter of the same name. - @param framesPerBuffer Same as Pa_OpenStream parameter of the same name. - @param streamCallback Same as Pa_OpenStream parameter of the same name. - @param userData Same as Pa_OpenStream parameter of the same name. - - @return As for Pa_OpenStream - - @see Pa_OpenStream, PaStreamCallback -*/ -PaError Pa_OpenDefaultStream( PaStream** stream, - int numInputChannels, - int numOutputChannels, - PaSampleFormat sampleFormat, - double sampleRate, - unsigned long framesPerBuffer, - PaStreamCallback *streamCallback, - void *userData ); - - -/** Closes an audio stream. If the audio stream is active it - discards any pending buffers as if Pa_AbortStream() had been called. -*/ -PaError Pa_CloseStream( PaStream *stream ); - - -/** Functions of type PaStreamFinishedCallback are implemented by PortAudio - clients. They can be registered with a stream using the Pa_SetStreamFinishedCallback - function. Once registered they are called when the stream becomes inactive - (ie once a call to Pa_StopStream() will not block). - A stream will become inactive after the stream callback returns non-zero, - or when Pa_StopStream or Pa_AbortStream is called. For a stream providing audio - output, if the stream callback returns paComplete, or Pa_StopStream is called, - the stream finished callback will not be called until all generated sample data - has been played. - - @param userData The userData parameter supplied to Pa_OpenStream() - - @see Pa_SetStreamFinishedCallback -*/ -typedef void PaStreamFinishedCallback( void *userData ); - - -/** Register a stream finished callback function which will be called when the - stream becomes inactive. See the description of PaStreamFinishedCallback for - further details about when the callback will be called. - - @param stream a pointer to a PaStream that is in the stopped state - if the - stream is not stopped, the stream's finished callback will remain unchanged - and an error code will be returned. - - @param streamFinishedCallback a pointer to a function with the same signature - as PaStreamFinishedCallback, that will be called when the stream becomes - inactive. Passing NULL for this parameter will un-register a previously - registered stream finished callback function. - - @return on success returns paNoError, otherwise an error code indicating the cause - of the error. - - @see PaStreamFinishedCallback -*/ -PaError Pa_SetStreamFinishedCallback( PaStream *stream, PaStreamFinishedCallback* streamFinishedCallback ); - - -/** Commences audio processing. -*/ -PaError Pa_StartStream( PaStream *stream ); - - -/** Terminates audio processing. It waits until all pending - audio buffers have been played before it returns. -*/ -PaError Pa_StopStream( PaStream *stream ); - - -/** Terminates audio processing immediately without waiting for pending - buffers to complete. -*/ -PaError Pa_AbortStream( PaStream *stream ); - - -/** Determine whether the stream is stopped. - A stream is considered to be stopped prior to a successful call to - Pa_StartStream and after a successful call to Pa_StopStream or Pa_AbortStream. - If a stream callback returns a value other than paContinue the stream is NOT - considered to be stopped. - - @return Returns one (1) when the stream is stopped, zero (0) when - the stream is running or, a PaErrorCode (which are always negative) if - PortAudio is not initialized or an error is encountered. - - @see Pa_StopStream, Pa_AbortStream, Pa_IsStreamActive -*/ -PaError Pa_IsStreamStopped( PaStream *stream ); - - -/** Determine whether the stream is active. - A stream is active after a successful call to Pa_StartStream(), until it - becomes inactive either as a result of a call to Pa_StopStream() or - Pa_AbortStream(), or as a result of a return value other than paContinue from - the stream callback. In the latter case, the stream is considered inactive - after the last buffer has finished playing. - - @return Returns one (1) when the stream is active (ie playing or recording - audio), zero (0) when not playing or, a PaErrorCode (which are always negative) - if PortAudio is not initialized or an error is encountered. - - @see Pa_StopStream, Pa_AbortStream, Pa_IsStreamStopped -*/ -PaError Pa_IsStreamActive( PaStream *stream ); - - - -/** A structure containing unchanging information about an open stream. - @see Pa_GetStreamInfo -*/ - -typedef struct PaStreamInfo -{ - /** this is struct version 1 */ - int structVersion; - - /** The input latency of the stream in seconds. This value provides the most - accurate estimate of input latency available to the implementation. It may - differ significantly from the suggestedLatency value passed to Pa_OpenStream(). - The value of this field will be zero (0.) for output-only streams. - @see PaTime - */ - PaTime inputLatency; - - /** The output latency of the stream in seconds. This value provides the most - accurate estimate of output latency available to the implementation. It may - differ significantly from the suggestedLatency value passed to Pa_OpenStream(). - The value of this field will be zero (0.) for input-only streams. - @see PaTime - */ - PaTime outputLatency; - - /** The sample rate of the stream in Hertz (samples per second). In cases - where the hardware sample rate is inaccurate and PortAudio is aware of it, - the value of this field may be different from the sampleRate parameter - passed to Pa_OpenStream(). If information about the actual hardware sample - rate is not available, this field will have the same value as the sampleRate - parameter passed to Pa_OpenStream(). - */ - double sampleRate; - -} PaStreamInfo; - - -/** Retrieve a pointer to a PaStreamInfo structure containing information - about the specified stream. - @return A pointer to an immutable PaStreamInfo structure. If the stream - parameter invalid, or an error is encountered, the function returns NULL. - - @param stream A pointer to an open stream previously created with Pa_OpenStream. - - @note PortAudio manages the memory referenced by the returned pointer, - the client must not manipulate or free the memory. The pointer is only - guaranteed to be valid until the specified stream is closed. - - @see PaStreamInfo -*/ -const PaStreamInfo* Pa_GetStreamInfo( PaStream *stream ); - - -/** Determine the current time for the stream according to the same clock used - to generate buffer timestamps. This time may be used for syncronising other - events to the audio stream, for example synchronizing audio to MIDI. - - @return The stream's current time in seconds, or 0 if an error occurred. - - @see PaTime, PaStreamCallback -*/ -PaTime Pa_GetStreamTime( PaStream *stream ); - - -/** Retrieve CPU usage information for the specified stream. - The "CPU Load" is a fraction of total CPU time consumed by a callback stream's - audio processing routines including, but not limited to the client supplied - stream callback. This function does not work with blocking read/write streams. - - This function may be called from the stream callback function or the - application. - - @return - A floating point value, typically between 0.0 and 1.0, where 1.0 indicates - that the stream callback is consuming the maximum number of CPU cycles possible - to maintain real-time operation. A value of 0.5 would imply that PortAudio and - the stream callback was consuming roughly 50% of the available CPU time. The - return value may exceed 1.0. A value of 0.0 will always be returned for a - blocking read/write stream, or if an error occurrs. -*/ -double Pa_GetStreamCpuLoad( PaStream* stream ); - - -/** Read samples from an input stream. The function doesn't return until - the entire buffer has been filled - this may involve waiting for the operating - system to supply the data. - - @param stream A pointer to an open stream previously created with Pa_OpenStream. - - @param buffer A pointer to a buffer of sample frames. The buffer contains - samples in the format specified by the inputParameters->sampleFormat field - used to open the stream, and the number of channels specified by - inputParameters->numChannels. If non-interleaved samples were requested, - buffer is a pointer to the first element of an array of non-interleaved - buffer pointers, one for each channel. - - @param frames The number of frames to be read into buffer. This parameter - is not constrained to a specific range, however high performance applications - will want to match this parameter to the framesPerBuffer parameter used - when opening the stream. - - @return On success PaNoError will be returned, or PaInputOverflowed if input - data was discarded by PortAudio after the previous call and before this call. -*/ -PaError Pa_ReadStream( PaStream* stream, - void *buffer, - unsigned long frames ); - - -/** Write samples to an output stream. This function doesn't return until the - entire buffer has been consumed - this may involve waiting for the operating - system to consume the data. - - @param stream A pointer to an open stream previously created with Pa_OpenStream. - - @param buffer A pointer to a buffer of sample frames. The buffer contains - samples in the format specified by the outputParameters->sampleFormat field - used to open the stream, and the number of channels specified by - outputParameters->numChannels. If non-interleaved samples were requested, - buffer is a pointer to the first element of an array of non-interleaved - buffer pointers, one for each channel. - - @param frames The number of frames to be written from buffer. This parameter - is not constrained to a specific range, however high performance applications - will want to match this parameter to the framesPerBuffer parameter used - when opening the stream. - - @return On success PaNoError will be returned, or paOutputUnderflowed if - additional output data was inserted after the previous call and before this - call. -*/ -PaError Pa_WriteStream( PaStream* stream, - const void *buffer, - unsigned long frames ); - - -/** Retrieve the number of frames that can be read from the stream without - waiting. - - @return Returns a non-negative value representing the maximum number of frames - that can be read from the stream without blocking or busy waiting or, a - PaErrorCode (which are always negative) if PortAudio is not initialized or an - error is encountered. -*/ -signed long Pa_GetStreamReadAvailable( PaStream* stream ); - - -/** Retrieve the number of frames that can be written to the stream without - waiting. - - @return Returns a non-negative value representing the maximum number of frames - that can be written to the stream without blocking or busy waiting or, a - PaErrorCode (which are always negative) if PortAudio is not initialized or an - error is encountered. -*/ -signed long Pa_GetStreamWriteAvailable( PaStream* stream ); - - -/* Miscellaneous utilities */ - - -/** Retrieve the size of a given sample format in bytes. - - @return The size in bytes of a single sample in the specified format, - or paSampleFormatNotSupported if the format is not supported. -*/ -PaError Pa_GetSampleSize( PaSampleFormat format ); - - -/** Put the caller to sleep for at least 'msec' milliseconds. This function is - provided only as a convenience for authors of portable code (such as the tests - and examples in the PortAudio distribution.) - - The function may sleep longer than requested so don't rely on this for accurate - musical timing. -*/ -void Pa_Sleep( long msec ); - - - -#ifdef __cplusplus -} -#endif /* __cplusplus */ -#endif /* PORTAUDIO_H */ + +#ifndef PORTAUDIO_H +#define PORTAUDIO_H +/* + * $Id: portaudio.h,v 1.1 2005/11/29 21:27:24 joe Exp $ + * PortAudio Portable Real-Time Audio Library + * PortAudio API Header File + * Latest version available at: http://www.portaudio.com/ + * + * Copyright (c) 1999-2002 Ross Bencina and Phil Burk + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files + * (the "Software"), to deal in the Software without restriction, + * including without limitation the rights to use, copy, modify, merge, + * publish, distribute, sublicense, and/or sell copies of the Software, + * and to permit persons to whom the Software is furnished to do so, + * subject to the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * Any person wishing to distribute modifications to the Software is + * requested to send the modifications to the original developer so that + * they can be incorporated into the canonical version. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR + * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF + * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + */ + +/** @file + @brief The PortAudio API. +*/ + + +#ifdef __cplusplus +extern "C" +{ +#endif /* __cplusplus */ + + +/** Retrieve the release number of the currently running PortAudio build, + eg 1900. +*/ +int Pa_GetVersion( void ); + + +/** Retrieve a textual description of the current PortAudio build, + eg "PortAudio V19-devel 13 October 2002". +*/ +const char* Pa_GetVersionText( void ); + + +/** Error codes returned by PortAudio functions. + Note that with the exception of paNoError, all PaErrorCodes are negative. +*/ + +typedef int PaError; +typedef enum PaErrorCode +{ + paNoError = 0, + + paNotInitialized = -10000, + paUnanticipatedHostError, + paInvalidChannelCount, + paInvalidSampleRate, + paInvalidDevice, + paInvalidFlag, + paSampleFormatNotSupported, + paBadIODeviceCombination, + paInsufficientMemory, + paBufferTooBig, + paBufferTooSmall, + paNullCallback, + paBadStreamPtr, + paTimedOut, + paInternalError, + paDeviceUnavailable, + paIncompatibleHostApiSpecificStreamInfo, + paStreamIsStopped, + paStreamIsNotStopped, + paInputOverflowed, + paOutputUnderflowed, + paHostApiNotFound, + paInvalidHostApi, + paCanNotReadFromACallbackStream, /**< @todo review error code name */ + paCanNotWriteToACallbackStream, /**< @todo review error code name */ + paCanNotReadFromAnOutputOnlyStream, /**< @todo review error code name */ + paCanNotWriteToAnInputOnlyStream, /**< @todo review error code name */ + paIncompatibleStreamHostApi +} PaErrorCode; + + +/** Translate the supplied PortAudio error code into a human readable + message. +*/ +const char *Pa_GetErrorText( PaError errorCode ); + + +/** Library initialization function - call this before using PortAudio. + This function initialises internal data structures and prepares underlying + host APIs for use. This function MUST be called before using any other + PortAudio API functions. + + If Pa_Initialize() is called multiple times, each successful + call must be matched with a corresponding call to Pa_Terminate(). + Pairs of calls to Pa_Initialize()/Pa_Terminate() may overlap, and are not + required to be fully nested. + + Note that if Pa_Initialize() returns an error code, Pa_Terminate() should + NOT be called. + + @return paNoError if successful, otherwise an error code indicating the cause + of failure. + + @see Pa_Terminate +*/ +PaError Pa_Initialize( void ); + + +/** Library termination function - call this when finished using PortAudio. + This function deallocates all resources allocated by PortAudio since it was + initializied by a call to Pa_Initialize(). In cases where Pa_Initialise() has + been called multiple times, each call must be matched with a corresponding call + to Pa_Terminate(). The final matching call to Pa_Terminate() will automatically + close any PortAudio streams that are still open. + + Pa_Terminate() MUST be called before exiting a program which uses PortAudio. + Failure to do so may result in serious resource leaks, such as audio devices + not being available until the next reboot. + + @return paNoError if successful, otherwise an error code indicating the cause + of failure. + + @see Pa_Initialize +*/ +PaError Pa_Terminate( void ); + + + +/** The type used to refer to audio devices. Values of this type usually + range from 0 to (Pa_DeviceCount-1), and may also take on the PaNoDevice + and paUseHostApiSpecificDeviceSpecification values. + + @see Pa_DeviceCount, paNoDevice, paUseHostApiSpecificDeviceSpecification +*/ +typedef int PaDeviceIndex; + + +/** A special PaDeviceIndex value indicating that no device is available, + or should be used. + + @see PaDeviceIndex +*/ +#define paNoDevice ((PaDeviceIndex)-1) + + +/** A special PaDeviceIndex value indicating that the device(s) to be used + are specified in the host api specific stream info structure. + + @see PaDeviceIndex +*/ +#define paUseHostApiSpecificDeviceSpecification ((PaDeviceIndex)-2) + + +/* Host API enumeration mechanism */ + +/** The type used to enumerate to host APIs at runtime. Values of this type + range from 0 to (Pa_GetHostApiCount()-1). + + @see Pa_GetHostApiCount +*/ +typedef int PaHostApiIndex; + + +/** Retrieve the number of available host APIs. Even if a host API is + available it may have no devices available. + + @return A non-negative value indicating the number of available host APIs + or, a PaErrorCode (which are always negative) if PortAudio is not initialized + or an error is encountered. + + @see PaHostApiIndex +*/ +PaHostApiIndex Pa_GetHostApiCount( void ); + + +/** Retrieve the index of the default host API. The default host API will be + the lowest common denominator host API on the current platform and is + unlikely to provide the best performance. + + @return A non-negative value ranging from 0 to (Pa_GetHostApiCount()-1) + indicating the default host API index or, a PaErrorCode (which are always + negative) if PortAudio is not initialized or an error is encountered. +*/ +PaHostApiIndex Pa_GetDefaultHostApi( void ); + + +/** Unchanging unique identifiers for each supported host API. This type + is used in the PaHostApiInfo structure. The values are guaranteed to be + unique and to never change, thus allowing code to be written that + conditionally uses host API specific extensions. + + New type ids will be allocated when support for a host API reaches + "public alpha" status, prior to that developers should use the + paInDevelopment type id. + + @see PaHostApiInfo +*/ +typedef enum PaHostApiTypeId +{ + paInDevelopment=0, /* use while developing support for a new host API */ + paDirectSound=1, + paMME=2, + paASIO=3, + paSoundManager=4, + paCoreAudio=5, + paOSS=7, + paALSA=8, + paAL=9, + paBeOS=10, + paWDMKS=11, + paJACK=12 +} PaHostApiTypeId; + + +/** A structure containing information about a particular host API. */ + +typedef struct PaHostApiInfo +{ + /** this is struct version 1 */ + int structVersion; + /** The well known unique identifier of this host API @see PaHostApiTypeId */ + PaHostApiTypeId type; + /** A textual description of the host API for display on user interfaces. */ + const char *name; + + /** The number of devices belonging to this host API. This field may be + used in conjunction with Pa_HostApiDeviceIndexToDeviceIndex() to enumerate + all devices for this host API. + @see Pa_HostApiDeviceIndexToDeviceIndex + */ + int deviceCount; + + /** The the default input device for this host API. The value will be a + device index ranging from 0 to (Pa_GetDeviceCount()-1), or paNoDevice + if no default input device is available. + */ + PaDeviceIndex defaultInputDevice; + + /** The the default output device for this host API. The value will be a + device index ranging from 0 to (Pa_GetDeviceCount()-1), or paNoDevice + if no default output device is available. + */ + PaDeviceIndex defaultOutputDevice; + +} PaHostApiInfo; + + +/** Retrieve a pointer to a structure containing information about a specific + host Api. + + @param hostApi A valid host API index ranging from 0 to (Pa_GetHostApiCount()-1) + + @return A pointer to an immutable PaHostApiInfo structure describing + a specific host API. If the hostApi parameter is out of range or an error + is encountered, the function returns NULL. + + The returned structure is owned by the PortAudio implementation and must not + be manipulated or freed. The pointer is only guaranteed to be valid between + calls to Pa_Initialize() and Pa_Terminate(). +*/ +const PaHostApiInfo * Pa_GetHostApiInfo( PaHostApiIndex hostApi ); + + +/** Convert a static host API unique identifier, into a runtime + host API index. + + @param type A unique host API identifier belonging to the PaHostApiTypeId + enumeration. + + @return A valid PaHostApiIndex ranging from 0 to (Pa_GetHostApiCount()-1) or, + a PaErrorCode (which are always negative) if PortAudio is not initialized + or an error is encountered. + + The paHostApiNotFound error code indicates that the host API specified by the + type parameter is not available. + + @see PaHostApiTypeId +*/ +PaHostApiIndex Pa_HostApiTypeIdToHostApiIndex( PaHostApiTypeId type ); + + +/** Convert a host-API-specific device index to standard PortAudio device index. + This function may be used in conjunction with the deviceCount field of + PaHostApiInfo to enumerate all devices for the specified host API. + + @param hostApi A valid host API index ranging from 0 to (Pa_GetHostApiCount()-1) + + @param hostApiDeviceIndex A valid per-host device index in the range + 0 to (Pa_GetHostApiInfo(hostApi)->deviceCount-1) + + @return A non-negative PaDeviceIndex ranging from 0 to (Pa_GetDeviceCount()-1) + or, a PaErrorCode (which are always negative) if PortAudio is not initialized + or an error is encountered. + + A paInvalidHostApi error code indicates that the host API index specified by + the hostApi parameter is out of range. + + A paInvalidDevice error code indicates that the hostApiDeviceIndex parameter + is out of range. + + @see PaHostApiInfo +*/ +PaDeviceIndex Pa_HostApiDeviceIndexToDeviceIndex( PaHostApiIndex hostApi, + int hostApiDeviceIndex ); + + + +/** Structure used to return information about a host error condition. +*/ +typedef struct PaHostErrorInfo{ + PaHostApiTypeId hostApiType; /**< the host API which returned the error code */ + long errorCode; /**< the error code returned */ + const char *errorText; /**< a textual description of the error if available, otherwise a zero-length string */ +}PaHostErrorInfo; + + +/** Return information about the last host error encountered. The error + information returned by Pa_GetLastHostErrorInfo() will never be modified + asyncronously by errors occurring in other PortAudio owned threads + (such as the thread that manages the stream callback.) + + This function is provided as a last resort, primarily to enhance debugging + by providing clients with access to all available error information. + + @return A pointer to an immutable structure constaining information about + the host error. The values in this structure will only be valid if a + PortAudio function has previously returned the paUnanticipatedHostError + error code. +*/ +const PaHostErrorInfo* Pa_GetLastHostErrorInfo( void ); + + + +/* Device enumeration and capabilities */ + +/** Retrieve the number of available devices. The number of available devices + may be zero. + + @return A non-negative value indicating the number of available devices or, + a PaErrorCode (which are always negative) if PortAudio is not initialized + or an error is encountered. +*/ +PaDeviceIndex Pa_GetDeviceCount( void ); + + +/** Retrieve the index of the default input device. The result can be + used in the inputDevice parameter to Pa_OpenStream(). + + @return The default input device index for the default host API, or paNoDevice + if no default input device is available or an error was encountered. +*/ +PaDeviceIndex Pa_GetDefaultInputDevice( void ); + + +/** Retrieve the index of the default output device. The result can be + used in the outputDevice parameter to Pa_OpenStream(). + + @return The default output device index for the defualt host API, or paNoDevice + if no default output device is available or an error was encountered. + + @note + On the PC, the user can specify a default device by + setting an environment variable. For example, to use device #1. +
+ set PA_RECOMMENDED_OUTPUT_DEVICE=1
+
+ The user should first determine the available device ids by using + the supplied application "pa_devs". +*/ +PaDeviceIndex Pa_GetDefaultOutputDevice( void ); + + +/** The type used to represent monotonic time in seconds that can be used + for syncronisation. The type is used for the outTime argument to the + PaStreamCallback and as the result of Pa_GetStreamTime(). + + @see PaStreamCallback, Pa_GetStreamTime +*/ +typedef double PaTime; + + +/** A type used to specify one or more sample formats. Each value indicates + a possible format for sound data passed to and from the stream callback, + Pa_ReadStream and Pa_WriteStream. + + The standard formats paFloat32, paInt16, paInt32, paInt24, paInt8 + and aUInt8 are usually implemented by all implementations. + + The floating point representation (paFloat32) uses +1.0 and -1.0 as the + maximum and minimum respectively. + + paUInt8 is an unsigned 8 bit format where 128 is considered "ground" + + The paNonInterleaved flag indicates that a multichannel buffer is passed + as a set of non-interleaved pointers. + + @see Pa_OpenStream, Pa_OpenDefaultStream, PaDeviceInfo + @see paFloat32, paInt16, paInt32, paInt24, paInt8 + @see paUInt8, paCustomFormat, paNonInterleaved +*/ +typedef unsigned long PaSampleFormat; + + +#define paFloat32 ((PaSampleFormat) 0x00000001) /**< @see PaSampleFormat */ +#define paInt32 ((PaSampleFormat) 0x00000002) /**< @see PaSampleFormat */ +#define paInt24 ((PaSampleFormat) 0x00000004) /**< Packed 24 bit format. @see PaSampleFormat */ +#define paInt16 ((PaSampleFormat) 0x00000008) /**< @see PaSampleFormat */ +#define paInt8 ((PaSampleFormat) 0x00000010) /**< @see PaSampleFormat */ +#define paUInt8 ((PaSampleFormat) 0x00000020) /**< @see PaSampleFormat */ +#define paCustomFormat ((PaSampleFormat) 0x00010000)/**< @see PaSampleFormat */ + +#define paNonInterleaved ((PaSampleFormat) 0x80000000) + +/** A structure providing information and capabilities of PortAudio devices. + Devices may support input, output or both input and output. +*/ +typedef struct PaDeviceInfo +{ + int structVersion; /* this is struct version 2 */ + const char *name; + PaHostApiIndex hostApi; /* note this is a host API index, not a type id*/ + + int maxInputChannels; + int maxOutputChannels; + + /* Default latency values for interactive performance. */ + PaTime defaultLowInputLatency; + PaTime defaultLowOutputLatency; + /* Default latency values for robust non-interactive applications (eg. playing sound files). */ + PaTime defaultHighInputLatency; + PaTime defaultHighOutputLatency; + + double defaultSampleRate; +} PaDeviceInfo; + + +/** Retrieve a pointer to a PaDeviceInfo structure containing information + about the specified device. + @return A pointer to an immutable PaDeviceInfo structure. If the device + parameter is out of range the function returns NULL. + + @param device A valid device index in the range 0 to (Pa_GetDeviceCount()-1) + + @note PortAudio manages the memory referenced by the returned pointer, + the client must not manipulate or free the memory. The pointer is only + guaranteed to be valid between calls to Pa_Initialize() and Pa_Terminate(). + + @see PaDeviceInfo, PaDeviceIndex +*/ +const PaDeviceInfo* Pa_GetDeviceInfo( PaDeviceIndex device ); + + +/** Parameters for one direction (input or output) of a stream. +*/ +typedef struct PaStreamParameters +{ + /** A valid device index in the range 0 to (Pa_GetDeviceCount()-1) + specifying the device to be used or the special constant + paUseHostApiSpecificDeviceSpecification which indicates that the actual + device(s) to use are specified in hostApiSpecificStreamInfo. + This field must not be set to paNoDevice. + */ + PaDeviceIndex device; + + /** The number of channels of sound to be delivered to the + stream callback or accessed by Pa_ReadStream() or Pa_WriteStream(). + It can range from 1 to the value of maxInputChannels in the + PaDeviceInfo record for the device specified by the device parameter. + */ + int channelCount; + + /** The sample format of the buffer provided to the stream callback, + a_ReadStream() or Pa_WriteStream(). It may be any of the formats described + by the PaSampleFormat enumeration. + */ + PaSampleFormat sampleFormat; + + /** The desired latency in seconds. Where practical, implementations should + configure their latency based on these parameters, otherwise they may + choose the closest viable latency instead. Unless the suggested latency + is greater than the absolute upper limit for the device implementations + shouldround the suggestedLatency up to the next practial value - ie to + provide an equal or higher latency than suggestedLatency whereever possibe. + Actual latency values for an open stream may be retrieved using the + inputLatency and outputLatency fields of the PaStreamInfo structure + returned by Pa_GetStreamInfo(). + @see default*Latency in PaDeviceInfo, *Latency in PaStreamInfo + */ + PaTime suggestedLatency; + + /** An optional pointer to a host api specific data structure + containing additional information for device setup and/or stream processing. + hostApiSpecificStreamInfo is never required for correct operation, + if not used it should be set to NULL. + */ + void *hostApiSpecificStreamInfo; + +} PaStreamParameters; + + +/** Return code for Pa_IsFormatSupported indicating success. */ +#define paFormatIsSupported (0) + +/** Determine whether it would be possible to open a stream with the specified + parameters. + + @param inputParameters A structure that describes the input parameters used to + open a stream. The suggestedLatency field is ignored. See PaStreamParameters + for a description of these parameters. inputParameters must be NULL for + output-only streams. + + @param outputParameters A structure that describes the output parameters used + to open a stream. The suggestedLatency field is ignored. See PaStreamParameters + for a description of these parameters. outputParameters must be NULL for + input-only streams. + + @param sampleRate The required sampleRate. For full-duplex streams it is the + sample rate for both input and output + + @return Returns 0 if the format is supported, and an error code indicating why + the format is not supported otherwise. The constant paFormatIsSupported is + provided to compare with the return value for success. + + @see paFormatIsSupported, PaStreamParameters +*/ +PaError Pa_IsFormatSupported( const PaStreamParameters *inputParameters, + const PaStreamParameters *outputParameters, + double sampleRate ); + + + +/* Streaming types and functions */ + + +/** + A single PaStream can provide multiple channels of real-time + streaming audio input and output to a client application. A stream + provides access to audio hardware represented by one or more + PaDevices. Depending on the underlying Host API, it may be possible + to open multiple streams using the same device, however this behavior + is implementation defined. Portable applications should assume that + a PaDevice may be simultaneously used by at most one PaStream. + + Pointers to PaStream objects are passed between PortAudio functions that + operate on streams. + + @see Pa_OpenStream, Pa_OpenDefaultStream, Pa_OpenDefaultStream, Pa_CloseStream, + Pa_StartStream, Pa_StopStream, Pa_AbortStream, Pa_IsStreamActive, + Pa_GetStreamTime, Pa_GetStreamCpuLoad + +*/ +typedef void PaStream; + + +/** Can be passed as the framesPerBuffer parameter to Pa_OpenStream() + or Pa_OpenDefaultStream() to indicate that the stream callback will + accept buffers of any size. +*/ +#define paFramesPerBufferUnspecified (0) + + +/** Flags used to control the behavior of a stream. They are passed as + parameters to Pa_OpenStream or Pa_OpenDefaultStream. Multiple flags may be + ORed together. + + @see Pa_OpenStream, Pa_OpenDefaultStream + @see paNoFlag, paClipOff, paDitherOff, paNeverDropInput, + paPrimeOutputBuffersUsingStreamCallback, paPlatformSpecificFlags +*/ +typedef unsigned long PaStreamFlags; + +/** @see PaStreamFlags */ +#define paNoFlag ((PaStreamFlags) 0) + +/** Disable default clipping of out of range samples. + @see PaStreamFlags +*/ +#define paClipOff ((PaStreamFlags) 0x00000001) + +/** Disable default dithering. + @see PaStreamFlags +*/ +#define paDitherOff ((PaStreamFlags) 0x00000002) + +/** Flag requests that where possible a full duplex stream will not discard + overflowed input samples without calling the stream callback. This flag is + only valid for full duplex callback streams and only when used in combination + with the paFramesPerBufferUnspecified (0) framesPerBuffer parameter. Using + this flag incorrectly results in a paInvalidFlag error being returned from + Pa_OpenStream and Pa_OpenDefaultStream. + + @see PaStreamFlags, paFramesPerBufferUnspecified +*/ +#define paNeverDropInput ((PaStreamFlags) 0x00000004) + +/** Call the stream callback to fill initial output buffers, rather than the + default behavior of priming the buffers with zeros (silence). This flag has + no effect for input-only and blocking read/write streams. + + @see PaStreamFlags +*/ +#define paPrimeOutputBuffersUsingStreamCallback ((PaStreamFlags) 0x00000008) + +/** A mask specifying the platform specific bits. + @see PaStreamFlags +*/ +#define paPlatformSpecificFlags ((PaStreamFlags)0xFFFF0000) + +/** + Timing information for the buffers passed to the stream callback. +*/ +typedef struct PaStreamCallbackTimeInfo{ + PaTime inputBufferAdcTime; + PaTime currentTime; + PaTime outputBufferDacTime; +} PaStreamCallbackTimeInfo; + + +/** + Flag bit constants for the statusFlags to PaStreamCallback. + + @see paInputUnderflow, paInputOverflow, paOutputUnderflow, paOutputOverflow, + paPrimingOutput +*/ +typedef unsigned long PaStreamCallbackFlags; + +/** In a stream opened with paFramesPerBufferUnspecified, indicates that + input data is all silence (zeros) because no real data is available. In a + stream opened without paFramesPerBufferUnspecified, it indicates that one or + more zero samples have been inserted into the input buffer to compensate + for an input underflow. + @see PaStreamCallbackFlags +*/ +#define paInputUnderflow ((PaStreamCallbackFlags) 0x00000001) + +/** In a stream opened with paFramesPerBufferUnspecified, indicates that data + prior to the first sample of the input buffer was discarded due to an + overflow, possibly because the stream callback is using too much CPU time. + Otherwise indicates that data prior to one or more samples in the + input buffer was discarded. + @see PaStreamCallbackFlags +*/ +#define paInputOverflow ((PaStreamCallbackFlags) 0x00000002) + +/** Indicates that output data (or a gap) was inserted, possibly because the + stream callback is using too much CPU time. + @see PaStreamCallbackFlags +*/ +#define paOutputUnderflow ((PaStreamCallbackFlags) 0x00000004) + +/** Indicates that output data will be discarded because no room is available. + @see PaStreamCallbackFlags +*/ +#define paOutputOverflow ((PaStreamCallbackFlags) 0x00000008) + +/** Some of all of the output data will be used to prime the stream, input + data may be zero. + @see PaStreamCallbackFlags +*/ +#define paPrimingOutput ((PaStreamCallbackFlags) 0x00000010) + +/** + Allowable return values for the PaStreamCallback. + @see PaStreamCallback +*/ +typedef enum PaStreamCallbackResult +{ + paContinue=0, + paComplete=1, + paAbort=2 +} PaStreamCallbackResult; + + +/** + Functions of type PaStreamCallback are implemented by PortAudio clients. + They consume, process or generate audio in response to requests from an + active PortAudio stream. + + @param input and @param output are arrays of interleaved samples, + the format, packing and number of channels used by the buffers are + determined by parameters to Pa_OpenStream(). + + @param frameCount The number of sample frames to be processed by + the stream callback. + + @param timeInfo The time in seconds when the first sample of the input + buffer was received at the audio input, the time in seconds when the first + sample of the output buffer will begin being played at the audio output, and + the time in seconds when the stream callback was called. + See also Pa_GetStreamTime() + + @param statusFlags Flags indicating whether input and/or output buffers + have been inserted or will be dropped to overcome underflow or overflow + conditions. + + @param userData The value of a user supplied pointer passed to + Pa_OpenStream() intended for storing synthesis data etc. + + @return + The stream callback should return one of the values in the + PaStreamCallbackResult enumeration. To ensure that the callback continues + to be called, it should return paContinue (0). Either paComplete or paAbort + can be returned to finish stream processing, after either of these values is + returned the callback will not be called again. If paAbort is returned the + stream will finish as soon as possible. If paComplete is returned, the stream + will continue until all buffers generated by the callback have been played. + This may be useful in applications such as soundfile players where a specific + duration of output is required. However, it is not necessary to utilise this + mechanism as Pa_StopStream(), Pa_AbortStream() or Pa_CloseStream() can also + be used to stop the stream. The callback must always fill the entire output + buffer irrespective of its return value. + + @see Pa_OpenStream, Pa_OpenDefaultStream + + @note With the exception of Pa_GetStreamCpuLoad() it is not permissable to call + PortAudio API functions from within the stream callback. +*/ +typedef int PaStreamCallback( + const void *input, void *output, + unsigned long frameCount, + const PaStreamCallbackTimeInfo* timeInfo, + PaStreamCallbackFlags statusFlags, + void *userData ); + + +/** Opens a stream for either input, output or both. + + @param stream The address of a PaStream pointer which will receive + a pointer to the newly opened stream. + + @param inputParameters A structure that describes the input parameters used by + the opened stream. See PaStreamParameters for a description of these parameters. + inputParameters must be NULL for output-only streams. + + @param outputParameters A structure that describes the output parameters used by + the opened stream. See PaStreamParameters for a description of these parameters. + outputParameters must be NULL for input-only streams. + + @param sampleRate The desired sampleRate. For full-duplex streams it is the + sample rate for both input and output + + @param framesPerBuffer The number of frames passed to the stream callback + function, or the preferred block granularity for a blocking read/write stream. + The special value paFramesPerBufferUnspecified (0) may be used to request that + the stream callback will recieve an optimal (and possibly varying) number of + frames based on host requirements and the requested latency settings. + Note: With some host APIs, the use of non-zero framesPerBuffer for a callback + stream may introduce an additional layer of buffering which could introduce + additional latency. PortAudio guarantees that the additional latency + will be kept to the theoretical minimum however, it is strongly recommended + that a non-zero framesPerBuffer value only be used when your algorithm + requires a fixed number of frames per stream callback. + + @param streamFlags Flags which modify the behaviour of the streaming process. + This parameter may contain a combination of flags ORed together. Some flags may + only be relevant to certain buffer formats. + + @param streamCallback A pointer to a client supplied function that is responsible + for processing and filling input and output buffers. If this parameter is NULL + the stream will be opened in 'blocking read/write' mode. In blocking mode, + the client can receive sample data using Pa_ReadStream and write sample data + using Pa_WriteStream, the number of samples that may be read or written + without blocking is returned by Pa_GetStreamReadAvailable and + Pa_GetStreamWriteAvailable respectively. + + @param userData A client supplied pointer which is passed to the stream callback + function. It could for example, contain a pointer to instance data necessary + for processing the audio buffers. This parameter is ignored if streamCallback + is NULL. + + @return + Upon success Pa_OpenStream() returns paNoError and places a pointer to a + valid PaStream in the stream argument. The stream is inactive (stopped). + If a call to Pa_OpenStream() fails, a non-zero error code is returned (see + PaError for possible error codes) and the value of stream is invalid. + + @see PaStreamParameters, PaStreamCallback, Pa_ReadStream, Pa_WriteStream, + Pa_GetStreamReadAvailable, Pa_GetStreamWriteAvailable +*/ +PaError Pa_OpenStream( PaStream** stream, + const PaStreamParameters *inputParameters, + const PaStreamParameters *outputParameters, + double sampleRate, + unsigned long framesPerBuffer, + PaStreamFlags streamFlags, + PaStreamCallback *streamCallback, + void *userData ); + + +/** A simplified version of Pa_OpenStream() that opens the default input + and/or output devices. + + @param stream The address of a PaStream pointer which will receive + a pointer to the newly opened stream. + + @param numInputChannels The number of channels of sound that will be supplied + to the stream callback or returned by Pa_ReadStream. It can range from 1 to + the value of maxInputChannels in the PaDeviceInfo record for the default input + device. If 0 the stream is opened as an output-only stream. + + @param numOutputChannels The number of channels of sound to be delivered to the + stream callback or passed to Pa_WriteStream. It can range from 1 to the value + of maxOutputChannels in the PaDeviceInfo record for the default output dvice. + If 0 the stream is opened as an output-only stream. + + @param sampleFormat The sample format of both the input and output buffers + provided to the callback or passed to and from Pa_ReadStream and Pa_WriteStream. + sampleFormat may be any of the formats described by the PaSampleFormat + enumeration. + + @param sampleRate Same as Pa_OpenStream parameter of the same name. + @param framesPerBuffer Same as Pa_OpenStream parameter of the same name. + @param streamCallback Same as Pa_OpenStream parameter of the same name. + @param userData Same as Pa_OpenStream parameter of the same name. + + @return As for Pa_OpenStream + + @see Pa_OpenStream, PaStreamCallback +*/ +PaError Pa_OpenDefaultStream( PaStream** stream, + int numInputChannels, + int numOutputChannels, + PaSampleFormat sampleFormat, + double sampleRate, + unsigned long framesPerBuffer, + PaStreamCallback *streamCallback, + void *userData ); + + +/** Closes an audio stream. If the audio stream is active it + discards any pending buffers as if Pa_AbortStream() had been called. +*/ +PaError Pa_CloseStream( PaStream *stream ); + + +/** Functions of type PaStreamFinishedCallback are implemented by PortAudio + clients. They can be registered with a stream using the Pa_SetStreamFinishedCallback + function. Once registered they are called when the stream becomes inactive + (ie once a call to Pa_StopStream() will not block). + A stream will become inactive after the stream callback returns non-zero, + or when Pa_StopStream or Pa_AbortStream is called. For a stream providing audio + output, if the stream callback returns paComplete, or Pa_StopStream is called, + the stream finished callback will not be called until all generated sample data + has been played. + + @param userData The userData parameter supplied to Pa_OpenStream() + + @see Pa_SetStreamFinishedCallback +*/ +typedef void PaStreamFinishedCallback( void *userData ); + + +/** Register a stream finished callback function which will be called when the + stream becomes inactive. See the description of PaStreamFinishedCallback for + further details about when the callback will be called. + + @param stream a pointer to a PaStream that is in the stopped state - if the + stream is not stopped, the stream's finished callback will remain unchanged + and an error code will be returned. + + @param streamFinishedCallback a pointer to a function with the same signature + as PaStreamFinishedCallback, that will be called when the stream becomes + inactive. Passing NULL for this parameter will un-register a previously + registered stream finished callback function. + + @return on success returns paNoError, otherwise an error code indicating the cause + of the error. + + @see PaStreamFinishedCallback +*/ +PaError Pa_SetStreamFinishedCallback( PaStream *stream, PaStreamFinishedCallback* streamFinishedCallback ); + + +/** Commences audio processing. +*/ +PaError Pa_StartStream( PaStream *stream ); + + +/** Terminates audio processing. It waits until all pending + audio buffers have been played before it returns. +*/ +PaError Pa_StopStream( PaStream *stream ); + + +/** Terminates audio processing immediately without waiting for pending + buffers to complete. +*/ +PaError Pa_AbortStream( PaStream *stream ); + + +/** Determine whether the stream is stopped. + A stream is considered to be stopped prior to a successful call to + Pa_StartStream and after a successful call to Pa_StopStream or Pa_AbortStream. + If a stream callback returns a value other than paContinue the stream is NOT + considered to be stopped. + + @return Returns one (1) when the stream is stopped, zero (0) when + the stream is running or, a PaErrorCode (which are always negative) if + PortAudio is not initialized or an error is encountered. + + @see Pa_StopStream, Pa_AbortStream, Pa_IsStreamActive +*/ +PaError Pa_IsStreamStopped( PaStream *stream ); + + +/** Determine whether the stream is active. + A stream is active after a successful call to Pa_StartStream(), until it + becomes inactive either as a result of a call to Pa_StopStream() or + Pa_AbortStream(), or as a result of a return value other than paContinue from + the stream callback. In the latter case, the stream is considered inactive + after the last buffer has finished playing. + + @return Returns one (1) when the stream is active (ie playing or recording + audio), zero (0) when not playing or, a PaErrorCode (which are always negative) + if PortAudio is not initialized or an error is encountered. + + @see Pa_StopStream, Pa_AbortStream, Pa_IsStreamStopped +*/ +PaError Pa_IsStreamActive( PaStream *stream ); + + + +/** A structure containing unchanging information about an open stream. + @see Pa_GetStreamInfo +*/ + +typedef struct PaStreamInfo +{ + /** this is struct version 1 */ + int structVersion; + + /** The input latency of the stream in seconds. This value provides the most + accurate estimate of input latency available to the implementation. It may + differ significantly from the suggestedLatency value passed to Pa_OpenStream(). + The value of this field will be zero (0.) for output-only streams. + @see PaTime + */ + PaTime inputLatency; + + /** The output latency of the stream in seconds. This value provides the most + accurate estimate of output latency available to the implementation. It may + differ significantly from the suggestedLatency value passed to Pa_OpenStream(). + The value of this field will be zero (0.) for input-only streams. + @see PaTime + */ + PaTime outputLatency; + + /** The sample rate of the stream in Hertz (samples per second). In cases + where the hardware sample rate is inaccurate and PortAudio is aware of it, + the value of this field may be different from the sampleRate parameter + passed to Pa_OpenStream(). If information about the actual hardware sample + rate is not available, this field will have the same value as the sampleRate + parameter passed to Pa_OpenStream(). + */ + double sampleRate; + +} PaStreamInfo; + + +/** Retrieve a pointer to a PaStreamInfo structure containing information + about the specified stream. + @return A pointer to an immutable PaStreamInfo structure. If the stream + parameter invalid, or an error is encountered, the function returns NULL. + + @param stream A pointer to an open stream previously created with Pa_OpenStream. + + @note PortAudio manages the memory referenced by the returned pointer, + the client must not manipulate or free the memory. The pointer is only + guaranteed to be valid until the specified stream is closed. + + @see PaStreamInfo +*/ +const PaStreamInfo* Pa_GetStreamInfo( PaStream *stream ); + + +/** Determine the current time for the stream according to the same clock used + to generate buffer timestamps. This time may be used for syncronising other + events to the audio stream, for example synchronizing audio to MIDI. + + @return The stream's current time in seconds, or 0 if an error occurred. + + @see PaTime, PaStreamCallback +*/ +PaTime Pa_GetStreamTime( PaStream *stream ); + + +/** Retrieve CPU usage information for the specified stream. + The "CPU Load" is a fraction of total CPU time consumed by a callback stream's + audio processing routines including, but not limited to the client supplied + stream callback. This function does not work with blocking read/write streams. + + This function may be called from the stream callback function or the + application. + + @return + A floating point value, typically between 0.0 and 1.0, where 1.0 indicates + that the stream callback is consuming the maximum number of CPU cycles possible + to maintain real-time operation. A value of 0.5 would imply that PortAudio and + the stream callback was consuming roughly 50% of the available CPU time. The + return value may exceed 1.0. A value of 0.0 will always be returned for a + blocking read/write stream, or if an error occurrs. +*/ +double Pa_GetStreamCpuLoad( PaStream* stream ); + + +/** Read samples from an input stream. The function doesn't return until + the entire buffer has been filled - this may involve waiting for the operating + system to supply the data. + + @param stream A pointer to an open stream previously created with Pa_OpenStream. + + @param buffer A pointer to a buffer of sample frames. The buffer contains + samples in the format specified by the inputParameters->sampleFormat field + used to open the stream, and the number of channels specified by + inputParameters->numChannels. If non-interleaved samples were requested, + buffer is a pointer to the first element of an array of non-interleaved + buffer pointers, one for each channel. + + @param frames The number of frames to be read into buffer. This parameter + is not constrained to a specific range, however high performance applications + will want to match this parameter to the framesPerBuffer parameter used + when opening the stream. + + @return On success PaNoError will be returned, or PaInputOverflowed if input + data was discarded by PortAudio after the previous call and before this call. +*/ +PaError Pa_ReadStream( PaStream* stream, + void *buffer, + unsigned long frames ); + + +/** Write samples to an output stream. This function doesn't return until the + entire buffer has been consumed - this may involve waiting for the operating + system to consume the data. + + @param stream A pointer to an open stream previously created with Pa_OpenStream. + + @param buffer A pointer to a buffer of sample frames. The buffer contains + samples in the format specified by the outputParameters->sampleFormat field + used to open the stream, and the number of channels specified by + outputParameters->numChannels. If non-interleaved samples were requested, + buffer is a pointer to the first element of an array of non-interleaved + buffer pointers, one for each channel. + + @param frames The number of frames to be written from buffer. This parameter + is not constrained to a specific range, however high performance applications + will want to match this parameter to the framesPerBuffer parameter used + when opening the stream. + + @return On success PaNoError will be returned, or paOutputUnderflowed if + additional output data was inserted after the previous call and before this + call. +*/ +PaError Pa_WriteStream( PaStream* stream, + const void *buffer, + unsigned long frames ); + + +/** Retrieve the number of frames that can be read from the stream without + waiting. + + @return Returns a non-negative value representing the maximum number of frames + that can be read from the stream without blocking or busy waiting or, a + PaErrorCode (which are always negative) if PortAudio is not initialized or an + error is encountered. +*/ +signed long Pa_GetStreamReadAvailable( PaStream* stream ); + + +/** Retrieve the number of frames that can be written to the stream without + waiting. + + @return Returns a non-negative value representing the maximum number of frames + that can be written to the stream without blocking or busy waiting or, a + PaErrorCode (which are always negative) if PortAudio is not initialized or an + error is encountered. +*/ +signed long Pa_GetStreamWriteAvailable( PaStream* stream ); + + +/* Miscellaneous utilities */ + + +/** Retrieve the size of a given sample format in bytes. + + @return The size in bytes of a single sample in the specified format, + or paSampleFormatNotSupported if the format is not supported. +*/ +PaError Pa_GetSampleSize( PaSampleFormat format ); + + +/** Put the caller to sleep for at least 'msec' milliseconds. This function is + provided only as a convenience for authors of portable code (such as the tests + and examples in the PortAudio distribution.) + + The function may sleep longer than requested so don't rely on this for accurate + musical timing. +*/ +void Pa_Sleep( long msec ); + + + +#ifdef __cplusplus +} +#endif /* __cplusplus */ +#endif /* PORTAUDIO_H */ diff --git a/prcom.h b/prcom.h index d564a5d66..ea89ee776 100644 --- a/prcom.h +++ b/prcom.h @@ -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) diff --git a/ps.f b/ps.f index ff54ce245..dc6848816 100644 --- a/ps.f +++ b/ps.f @@ -1,23 +1,23 @@ - subroutine ps(dat,nfft,s) - - parameter (NMAX=16384+2) - parameter (NHMAX=NMAX/2-1) - real dat(nfft) - real s(NHMAX) - real x(NMAX) - complex c(0:NHMAX) - equivalence (x,c) - - nh=nfft/2 - do i=1,nfft - x(i)=dat(i)/128.0 !### Why 128 ?? - enddo - - call xfft(x,nfft) - fac=1.0/nfft - do i=1,nh - s(i)=fac*(real(c(i))**2 + aimag(c(i))**2) - enddo - - return - end + subroutine ps(dat,nfft,s) + + parameter (NMAX=16384+2) + parameter (NHMAX=NMAX/2-1) + real dat(nfft) + real s(NHMAX) + real x(NMAX) + complex c(0:NHMAX) + equivalence (x,c) + + nh=nfft/2 + do i=1,nfft + x(i)=dat(i)/128.0 !### Why 128 ?? + enddo + + call xfft(x,nfft) + fac=1.0/nfft + do i=1,nh + s(i)=fac*(real(c(i))**2 + aimag(c(i))**2) + enddo + + return + end diff --git a/resample.c b/resample.c index f45d1eb2f..26a2d8a52 100644 --- a/resample.c +++ b/resample.c @@ -1,7 +1,8 @@ #include #include -int resample_( float din[], float dout[], double *samfac, int *jz) +int resample_(float din[], int *jzin, int *conv_type, int *channels, + double *samfac, float dout[], int *jzout) { SRC_DATA src_data; int input_len; @@ -10,7 +11,7 @@ int resample_( float din[], float dout[], double *samfac, int *jz) double src_ratio; src_ratio=*samfac; - input_len=*jz; + input_len=*jzin; output_len=(int) (input_len*src_ratio); src_data.data_in=din; @@ -19,10 +20,7 @@ int resample_( float din[], float dout[], double *samfac, int *jz) src_data.input_frames=input_len; src_data.output_frames=output_len; - ierr=src_simple(&src_data,2,1); - *jz=output_len; - /* printf("%d %d %d %d %f\n",input_len,output_len,src_data.input_frames_used, - src_data.output_frames_gen,src_ratio); - */ + ierr=src_simple(&src_data,*conv_type,*channels); + *jzout=output_len; return ierr; } diff --git a/rfile2.f b/rfile2.f index 3270d3cc1..46eaf98ca 100644 --- a/rfile2.f +++ b/rfile2.f @@ -1,26 +1,26 @@ - subroutine rfile2(fname,buf,n,nr) - -C Write a wave file to disk. - - integer RMODE - parameter(RMODE=0) - integer*1 buf(n) - integer open,read,close - integer fd - character fname*80 - data iz/0/ !Silence g77 warning - - do i=80,1,-1 - if(fname(i:i).ne.' ') then - iz=i - go to 10 - endif - enddo - - 10 fname=fname(1:iz)//char(0) - fd=open(fname,RMODE) !Open file for reading - nr=read(fd,buf,n) - i=close(fd) - - return - end + subroutine rfile2(fname,buf,n,nr) + +C Write a wave file to disk. + + integer RMODE + parameter(RMODE=0) + integer*1 buf(n) + integer open,read,close + integer fd + character fname*80 + data iz/0/ !Silence g77 warning + + do i=80,1,-1 + if(fname(i:i).ne.' ') then + iz=i + go to 10 + endif + enddo + + 10 fname=fname(1:iz)//char(0) + fd=open(fname,RMODE) !Open file for reading + nr=read(fd,buf,n) + i=close(fd) + + return + end diff --git a/rs.h b/rs.h index 06cbe344f..6f1531467 100644 --- a/rs.h +++ b/rs.h @@ -1,35 +1,35 @@ -/* User include file for the Reed-Solomon codec - * Copyright 2002, Phil Karn KA9Q - * May be used under the terms of the GNU General Public License (GPL) - */ - -/* General purpose RS codec, 8-bit symbols */ -void encode_rs_char(void *rs,unsigned char *data,unsigned char *parity); -int decode_rs_char(void *rs,unsigned char *data,int *eras_pos, - int no_eras); -void *init_rs_char(int symsize,int gfpoly, - int fcr,int prim,int nroots, - int pad); -void free_rs_char(void *rs); - -/* General purpose RS codec, integer symbols */ -void encode_rs_int(void *rs,int *data,int *parity); -int decode_rs_int(void *rs,int *data,int *eras_pos,int no_eras); -void *init_rs_int(int symsize,int gfpoly,int fcr, - int prim,int nroots,int pad); -void free_rs_int(void *rs); - -/* CCSDS standard (255,223) RS codec with conventional (*not* dual-basis) - * symbol representation - */ -void encode_rs_8(unsigned char *data,unsigned char *parity,int pad); -int decode_rs_8(unsigned char *data,int *eras_pos,int no_eras,int pad); - -/* CCSDS standard (255,223) RS codec with dual-basis symbol representation */ -void encode_rs_ccsds(unsigned char *data,unsigned char *parity,int pad); -int decode_rs_ccsds(unsigned char *data,int *eras_pos,int no_eras,int pad); - -/* Tables to map from conventional->dual (Taltab) and - * dual->conventional (Tal1tab) bases - */ -extern unsigned char Taltab[],Tal1tab[]; +/* User include file for the Reed-Solomon codec + * Copyright 2002, Phil Karn KA9Q + * May be used under the terms of the GNU General Public License (GPL) + */ + +/* General purpose RS codec, 8-bit symbols */ +void encode_rs_char(void *rs,unsigned char *data,unsigned char *parity); +int decode_rs_char(void *rs,unsigned char *data,int *eras_pos, + int no_eras); +void *init_rs_char(int symsize,int gfpoly, + int fcr,int prim,int nroots, + int pad); +void free_rs_char(void *rs); + +/* General purpose RS codec, integer symbols */ +void encode_rs_int(void *rs,int *data,int *parity); +int decode_rs_int(void *rs,int *data,int *eras_pos,int no_eras); +void *init_rs_int(int symsize,int gfpoly,int fcr, + int prim,int nroots,int pad); +void free_rs_int(void *rs); + +/* CCSDS standard (255,223) RS codec with conventional (*not* dual-basis) + * symbol representation + */ +void encode_rs_8(unsigned char *data,unsigned char *parity,int pad); +int decode_rs_8(unsigned char *data,int *eras_pos,int no_eras,int pad); + +/* CCSDS standard (255,223) RS codec with dual-basis symbol representation */ +void encode_rs_ccsds(unsigned char *data,unsigned char *parity,int pad); +int decode_rs_ccsds(unsigned char *data,int *eras_pos,int no_eras,int pad); + +/* Tables to map from conventional->dual (Taltab) and + * dual->conventional (Tal1tab) bases + */ +extern unsigned char Taltab[],Tal1tab[]; diff --git a/runqqq.F90 b/runqqq.F90 index 9755b5d28..f392417dd 100644 --- a/runqqq.F90 +++ b/runqqq.F90 @@ -15,26 +15,3 @@ subroutine runqqq(fname,cmnd,iret) return end subroutine runqqq - -subroutine flushqqq(lu) - -#ifdef Win32 - use dfport -#endif - - call flush(lu) - - return -end subroutine flushqqq - -subroutine sleepqqq(n) -#ifdef Win32 - use dflib - call sleepqq(n) -#else - call usleep(n*1000) -#endif - - return - -end subroutine sleepqqq diff --git a/samplerate.h b/samplerate.h index 9232dc29d..a446fff8d 100644 --- a/samplerate.h +++ b/samplerate.h @@ -1,196 +1,196 @@ -/* -** Copyright (C) 2002-2004 Erik de Castro Lopo -** -** This program is free software; you can redistribute it and/or modify -** it under the terms of the GNU General Public License as published by -** the Free Software Foundation; either version 2 of the License, or -** (at your option) any later version. -** -** This program is distributed in the hope that it will be useful, -** but WITHOUT ANY WARRANTY; without even the implied warranty of -** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -** GNU General Public License for more details. -** -** You should have received a copy of the GNU General Public License -** along with this program; if not, write to the Free Software -** Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. -*/ - -/* -** API documentation is available here: -** http://www.mega-nerd.com/SRC/api.html -*/ - -#ifndef SAMPLERATE_H -#define SAMPLERATE_H - -#ifdef __cplusplus -extern "C" { -#endif /* __cplusplus */ - - -/* Opaque data type SRC_STATE. */ -typedef struct SRC_STATE_tag SRC_STATE ; - -/* SRC_DATA is used to pass data to src_simple() and src_process(). */ -typedef struct -{ float *data_in, *data_out ; - - long input_frames, output_frames ; - long input_frames_used, output_frames_gen ; - - int end_of_input ; - - double src_ratio ; -} SRC_DATA ; - -/* SRC_CB_DATA is used with callback based API. */ -typedef struct -{ long frames ; - float *data_in ; -} SRC_CB_DATA ; - -/* -** User supplied callback function type for use with src_callback_new() -** and src_callback_read(). First parameter is the same pointer that was -** passed into src_callback_new(). Second parameter is pointer to a -** pointer. The user supplied callback function must modify *data to -** point to the start of the user supplied float array. The user supplied -** function must return the number of frames that **data points to. -*/ - -typedef long (*src_callback_t) (void *cb_data, float **data) ; - -/* -** Standard initialisation function : return an anonymous pointer to the -** internal state of the converter. Choose a converter from the enums below. -** Error returned in *error. -*/ - -SRC_STATE* src_new (int converter_type, int channels, int *error) ; - -/* -** Initilisation for callback based API : return an anonymous pointer to the -** internal state of the converter. Choose a converter from the enums below. -** The cb_data pointer can point to any data or be set to NULL. Whatever the -** value, when processing, user supplied function "func" gets called with -** cb_data as first parameter. -*/ - -SRC_STATE* src_callback_new (src_callback_t func, int converter_type, int channels, - int *error, void* cb_data) ; - -/* -** Cleanup all internal allocations. -** Always returns NULL. -*/ - -SRC_STATE* src_delete (SRC_STATE *state) ; - -/* -** Standard processing function. -** Returns non zero on error. -*/ - -int src_process (SRC_STATE *state, SRC_DATA *data) ; - -/* -** Callback based processing function. Read up to frames worth of data from -** the converter int *data and return frames read or -1 on error. -*/ -long src_callback_read (SRC_STATE *state, double src_ratio, long frames, float *data) ; - -/* -** Simple interface for performing a single conversion from input buffer to -** output buffer at a fixed conversion ratio. -** Simple interface does not require initialisation as it can only operate on -** a single buffer worth of audio. -*/ - -int src_simple (SRC_DATA *data, int converter_type, int channels) ; - -/* -** This library contains a number of different sample rate converters, -** numbered 0 through N. -** -** Return a string giving either a name or a more full description of each -** sample rate converter or NULL if no sample rate converter exists for -** the given value. The converters are sequentially numbered from 0 to N. -*/ - -const char *src_get_name (int converter_type) ; -const char *src_get_description (int converter_type) ; -const char *src_get_version (void) ; - -/* -** Set a new SRC ratio. This allows step responses -** in the conversion ratio. -** Returns non zero on error. -*/ - -int src_set_ratio (SRC_STATE *state, double new_ratio) ; - -/* -** Reset the internal SRC state. -** Does not modify the quality settings. -** Does not free any memory allocations. -** Returns non zero on error. -*/ - -int src_reset (SRC_STATE *state) ; - -/* -** Return TRUE if ratio is a valid conversion ratio, FALSE -** otherwise. -*/ - -int src_is_valid_ratio (double ratio) ; - -/* -** Return an error number. -*/ - -int src_error (SRC_STATE *state) ; - -/* -** Convert the error number into a string. -*/ -const char* src_strerror (int error) ; - -/* -** The following enums can be used to set the interpolator type -** using the function src_set_converter(). -*/ - -enum -{ - SRC_SINC_BEST_QUALITY = 0, - SRC_SINC_MEDIUM_QUALITY = 1, - SRC_SINC_FASTEST = 2, - SRC_ZERO_ORDER_HOLD = 3, - SRC_LINEAR = 4 -} ; - -/* -** Extra helper functions for converting from short to float and -** back again. -*/ - -void src_short_to_float_array (const short *in, float *out, int len) ; -void src_float_to_short_array (const float *in, short *out, int len) ; - - -#ifdef __cplusplus -} /* extern "C" */ -#endif /* __cplusplus */ - -#endif /* SAMPLERATE_H */ - -/* -** Do not edit or modify anything in this comment block. -** The arch-tag line is a file identity tag for the GNU Arch -** revision control system. -** -** arch-tag: 5421ef3e-c898-4ec3-8671-ea03d943ee00 -*/ - +/* +** Copyright (C) 2002-2004 Erik de Castro Lopo +** +** This program is free software; you can redistribute it and/or modify +** it under the terms of the GNU General Public License as published by +** the Free Software Foundation; either version 2 of the License, or +** (at your option) any later version. +** +** This program is distributed in the hope that it will be useful, +** but WITHOUT ANY WARRANTY; without even the implied warranty of +** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +** GNU General Public License for more details. +** +** You should have received a copy of the GNU General Public License +** along with this program; if not, write to the Free Software +** Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. +*/ + +/* +** API documentation is available here: +** http://www.mega-nerd.com/SRC/api.html +*/ + +#ifndef SAMPLERATE_H +#define SAMPLERATE_H + +#ifdef __cplusplus +extern "C" { +#endif /* __cplusplus */ + + +/* Opaque data type SRC_STATE. */ +typedef struct SRC_STATE_tag SRC_STATE ; + +/* SRC_DATA is used to pass data to src_simple() and src_process(). */ +typedef struct +{ float *data_in, *data_out ; + + long input_frames, output_frames ; + long input_frames_used, output_frames_gen ; + + int end_of_input ; + + double src_ratio ; +} SRC_DATA ; + +/* SRC_CB_DATA is used with callback based API. */ +typedef struct +{ long frames ; + float *data_in ; +} SRC_CB_DATA ; + +/* +** User supplied callback function type for use with src_callback_new() +** and src_callback_read(). First parameter is the same pointer that was +** passed into src_callback_new(). Second parameter is pointer to a +** pointer. The user supplied callback function must modify *data to +** point to the start of the user supplied float array. The user supplied +** function must return the number of frames that **data points to. +*/ + +typedef long (*src_callback_t) (void *cb_data, float **data) ; + +/* +** Standard initialisation function : return an anonymous pointer to the +** internal state of the converter. Choose a converter from the enums below. +** Error returned in *error. +*/ + +SRC_STATE* src_new (int converter_type, int channels, int *error) ; + +/* +** Initilisation for callback based API : return an anonymous pointer to the +** internal state of the converter. Choose a converter from the enums below. +** The cb_data pointer can point to any data or be set to NULL. Whatever the +** value, when processing, user supplied function "func" gets called with +** cb_data as first parameter. +*/ + +SRC_STATE* src_callback_new (src_callback_t func, int converter_type, int channels, + int *error, void* cb_data) ; + +/* +** Cleanup all internal allocations. +** Always returns NULL. +*/ + +SRC_STATE* src_delete (SRC_STATE *state) ; + +/* +** Standard processing function. +** Returns non zero on error. +*/ + +int src_process (SRC_STATE *state, SRC_DATA *data) ; + +/* +** Callback based processing function. Read up to frames worth of data from +** the converter int *data and return frames read or -1 on error. +*/ +long src_callback_read (SRC_STATE *state, double src_ratio, long frames, float *data) ; + +/* +** Simple interface for performing a single conversion from input buffer to +** output buffer at a fixed conversion ratio. +** Simple interface does not require initialisation as it can only operate on +** a single buffer worth of audio. +*/ + +int src_simple (SRC_DATA *data, int converter_type, int channels) ; + +/* +** This library contains a number of different sample rate converters, +** numbered 0 through N. +** +** Return a string giving either a name or a more full description of each +** sample rate converter or NULL if no sample rate converter exists for +** the given value. The converters are sequentially numbered from 0 to N. +*/ + +const char *src_get_name (int converter_type) ; +const char *src_get_description (int converter_type) ; +const char *src_get_version (void) ; + +/* +** Set a new SRC ratio. This allows step responses +** in the conversion ratio. +** Returns non zero on error. +*/ + +int src_set_ratio (SRC_STATE *state, double new_ratio) ; + +/* +** Reset the internal SRC state. +** Does not modify the quality settings. +** Does not free any memory allocations. +** Returns non zero on error. +*/ + +int src_reset (SRC_STATE *state) ; + +/* +** Return TRUE if ratio is a valid conversion ratio, FALSE +** otherwise. +*/ + +int src_is_valid_ratio (double ratio) ; + +/* +** Return an error number. +*/ + +int src_error (SRC_STATE *state) ; + +/* +** Convert the error number into a string. +*/ +const char* src_strerror (int error) ; + +/* +** The following enums can be used to set the interpolator type +** using the function src_set_converter(). +*/ + +enum +{ + SRC_SINC_BEST_QUALITY = 0, + SRC_SINC_MEDIUM_QUALITY = 1, + SRC_SINC_FASTEST = 2, + SRC_ZERO_ORDER_HOLD = 3, + SRC_LINEAR = 4 +} ; + +/* +** Extra helper functions for converting from short to float and +** back again. +*/ + +void src_short_to_float_array (const short *in, float *out, int len) ; +void src_float_to_short_array (const float *in, short *out, int len) ; + + +#ifdef __cplusplus +} /* extern "C" */ +#endif /* __cplusplus */ + +#endif /* SAMPLERATE_H */ + +/* +** Do not edit or modify anything in this comment block. +** The arch-tag line is a file identity tag for the GNU Arch +** revision control system. +** +** arch-tag: 5421ef3e-c898-4ec3-8671-ea03d943ee00 +*/ + diff --git a/set.f b/set.f index e93740a8a..adb17c977 100644 --- a/set.f +++ b/set.f @@ -1,31 +1,31 @@ - subroutine set(a,y,n) - real y(n) - do i=1,n - y(i)=a - enddo - return - end - - subroutine move(x,y,n) - real x(n),y(n) - do i=1,n - y(i)=x(i) - enddo - return - end - - subroutine zero(x,n) - real x(n) - do i=1,n - x(i)=0.0 - enddo - return - end - - subroutine add(a,b,c,n) - real a(n),b(n),c(n) - do i=1,n - c(i)=a(i)+b(i) - enddo - return - end + subroutine set(a,y,n) + real y(n) + do i=1,n + y(i)=a + enddo + return + end + + subroutine move(x,y,n) + real x(n),y(n) + do i=1,n + y(i)=x(i) + enddo + return + end + + subroutine zero(x,n) + real x(n) + do i=1,n + x(i)=0.0 + enddo + return + end + + subroutine add(a,b,c,n) + real a(n),b(n),c(n) + do i=1,n + c(i)=a(i)+b(i) + enddo + return + end diff --git a/setup65.f b/setup65.f index 1f2860802..fb19184c8 100644 --- a/setup65.f +++ b/setup65.f @@ -1,106 +1,106 @@ - subroutine setup65 - -C Defines arrays related to the pseudo-random synchronizing pattern. -C Executed at program start. - - integer npra(135),nprc(126) - include 'prcom.h' - -C JT44 - data npra/ - + 1,1,1,0,1,0,0,0,0,1,1,1,0,0,1,1,0,0,0,0, - + 1,0,0,1,0,0,0,1,0,1,0,1,1,1,0,1,0,1,1,1, - + 1,0,0,1,0,0,1,0,1,1,1,0,0,1,1,1,0,0,0,0, - + 0,0,1,1,1,0,1,1,1,0,1,0,0,1,1,1,1,0,1,0, - + 1,0,0,1,0,1,0,0,0,0,0,0,1,0,1,0,1,0,1,0, - + 1,1,1,1,1,0,1,0,1,1,0,1,0,0,0,0,0,1,1,0, - + 1,1,1,0,1,1,0,1,1,0,1,0,1,1,0/ - -C JT65 - data nprc/ - + 1,0,0,1,1,0,0,0,1,1,1,1,1,1,0,1,0,1,0,0, - + 0,1,0,1,1,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1, - + 0,1,1,0,1,1,1,1,0,0,0,1,1,0,1,0,1,0,1,1, - + 0,0,1,1,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,1, - + 1,0,0,0,0,0,0,0,1,1,0,1,0,0,1,0,1,1,0,1, - + 0,1,0,1,0,0,1,1,0,0,1,0,0,1,0,0,0,0,1,1, - + 1,1,1,1,1,1/ - data mr2/0/ !Silence g77 warning - -C Put the appropriate pseudo-random sequence into pr - nsym=126 - do i=1,nsym - pr(i)=2*nprc(i)-1 - enddo - -C Determine locations of data and reference symbols - k=0 - mr1=0 - do i=1,nsym - if(pr(i).lt.0.0) then - k=k+1 - mdat(k)=i - else - mr2=i - if(mr1.eq.0) mr1=i - endif - enddo - nsig=k - -C Determine the reference symbols for each data symbol. - do k=1,nsig - m=mdat(k) - mref(k,1)=mr1 - do n=1,10 !Get ref symbol before data - if((m-n).gt.0) then - if (pr(m-n).gt.0.0) go to 10 - endif - enddo - go to 12 - 10 mref(k,1)=m-n - 12 mref(k,2)=mr2 - do n=1,10 !Get ref symbol after data - if((m+n).le.nsym) then - if (pr(m+n).gt.0.0) go to 20 - endif - enddo - go to 22 - 20 mref(k,2)=m+n - 22 enddo - -C Now do it all again, using opposite logic on pr(i) - k=0 - mr1=0 - do i=1,nsym - if(pr(i).gt.0.0) then - k=k+1 - mdat2(k)=i - else - mr2=i - if(mr1.eq.0) mr1=i - endif - enddo - nsig=k - - do k=1,nsig - m=mdat2(k) - mref2(k,1)=mr1 - do n=1,10 - if((m-n).gt.0) then - if (pr(m-n).lt.0.0) go to 110 - endif - enddo - go to 112 - 110 mref2(k,1)=m-n - 112 mref2(k,2)=mr2 - do n=1,10 - if((m+n).le.nsym) then - if (pr(m+n).lt.0.0) go to 120 - endif - enddo - go to 122 - 120 mref2(k,2)=m+n - 122 enddo - - return - end + subroutine setup65 + +C Defines arrays related to the pseudo-random synchronizing pattern. +C Executed at program start. + + integer npra(135),nprc(126) + include 'prcom.h' + +C JT44 + data npra/ + + 1,1,1,0,1,0,0,0,0,1,1,1,0,0,1,1,0,0,0,0, + + 1,0,0,1,0,0,0,1,0,1,0,1,1,1,0,1,0,1,1,1, + + 1,0,0,1,0,0,1,0,1,1,1,0,0,1,1,1,0,0,0,0, + + 0,0,1,1,1,0,1,1,1,0,1,0,0,1,1,1,1,0,1,0, + + 1,0,0,1,0,1,0,0,0,0,0,0,1,0,1,0,1,0,1,0, + + 1,1,1,1,1,0,1,0,1,1,0,1,0,0,0,0,0,1,1,0, + + 1,1,1,0,1,1,0,1,1,0,1,0,1,1,0/ + +C JT65 + data nprc/ + + 1,0,0,1,1,0,0,0,1,1,1,1,1,1,0,1,0,1,0,0, + + 0,1,0,1,1,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1, + + 0,1,1,0,1,1,1,1,0,0,0,1,1,0,1,0,1,0,1,1, + + 0,0,1,1,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,1, + + 1,0,0,0,0,0,0,0,1,1,0,1,0,0,1,0,1,1,0,1, + + 0,1,0,1,0,0,1,1,0,0,1,0,0,1,0,0,0,0,1,1, + + 1,1,1,1,1,1/ + data mr2/0/ !Silence g77 warning + +C Put the appropriate pseudo-random sequence into pr + nsym=126 + do i=1,nsym + pr(i)=2*nprc(i)-1 + enddo + +C Determine locations of data and reference symbols + k=0 + mr1=0 + do i=1,nsym + if(pr(i).lt.0.0) then + k=k+1 + mdat(k)=i + else + mr2=i + if(mr1.eq.0) mr1=i + endif + enddo + nsig=k + +C Determine the reference symbols for each data symbol. + do k=1,nsig + m=mdat(k) + mref(k,1)=mr1 + do n=1,10 !Get ref symbol before data + if((m-n).gt.0) then + if (pr(m-n).gt.0.0) go to 10 + endif + enddo + go to 12 + 10 mref(k,1)=m-n + 12 mref(k,2)=mr2 + do n=1,10 !Get ref symbol after data + if((m+n).le.nsym) then + if (pr(m+n).gt.0.0) go to 20 + endif + enddo + go to 22 + 20 mref(k,2)=m+n + 22 enddo + +C Now do it all again, using opposite logic on pr(i) + k=0 + mr1=0 + do i=1,nsym + if(pr(i).gt.0.0) then + k=k+1 + mdat2(k)=i + else + mr2=i + if(mr1.eq.0) mr1=i + endif + enddo + nsig=k + + do k=1,nsig + m=mdat2(k) + mref2(k,1)=mr1 + do n=1,10 + if((m-n).gt.0) then + if (pr(m-n).lt.0.0) go to 110 + endif + enddo + go to 112 + 110 mref2(k,1)=m-n + 112 mref2(k,2)=mr2 + do n=1,10 + if((m+n).le.nsym) then + if (pr(m+n).lt.0.0) go to 120 + endif + enddo + go to 122 + 120 mref2(k,2)=m+n + 122 enddo + + return + end diff --git a/short65.f b/short65.f index cbce6a8a6..8701afe8b 100644 --- a/short65.f +++ b/short65.f @@ -1,190 +1,190 @@ - subroutine short65(data,jz,NFreeze,MouseDF,DFTolerance, - + mode65,nspecialbest,nstest,dfsh,iderrbest,idriftbest, - + snrdb,ss1a,ss2a,nwsh,idfsh) - -C Checks to see if this might be a shorthand message. -C This is done before zapping, downsampling, or normal decoding. - - parameter (NP2=60*11025) !Size of data array - parameter (NFFT=16384) !FFT length - parameter (NH=NFFT/2) !Step size - parameter (MAXSTEPS=60*11025/NH) !Max # of steps - - real data(jz) - integer DFTolerance - real s2(NH,MAXSTEPS) !2d spectrum - real ss(NH,4) !Save spectra in four phase bins - real psavg(NH) - real sigmax(4) !Peak of spectrum at each phase - real ss1a(-224:224) !Lower magenta curve - real ss2a(-224:224) !Upper magenta curve - real ss1(-473:1784) !Lower magenta curve (temp) - real ss2(-473:1784) !Upper magenta curve (temp) - real ssavg(-11:11) - integer ipk(4) !Peak bin at each phase - save - - nspecialbest=0 !Default return value - nstest=0 - df=11025.0/NFFT - -C Do 16 k FFTs, stepped by 8k. (*** Maybe should step by 4k? ***) - call zero(psavg,NH) - nsteps=(jz-NH)/(4*NH) - nsteps=4*nsteps !Number of steps - do j=1,nsteps - k=(j-1)*NH + 1 - call ps(data(k),NFFT,s2(1,j)) !Get power spectra - if(mode65.eq.4) then - call smooth(s2(1,j),NH) - call smooth(s2(1,j),NH) - endif - call add(psavg,s2(1,j),psavg,NH) - enddo - - call flat1(psavg,s2,NH,nsteps,NH,MAXSTEPS) - - nfac=40*mode65 - dtstep=0.5/df - fac=dtstep/(60.0*df) - -C Define range of frequencies to be searched - fa=max(200.0,1270.46+MouseDF-600.0) - fb=min(4800.0,1270.46+MouseDF+600.0) - ia=fa/df - ib=fb/df + 4.1*nfac !Upper tone is above sync tone by 4*nfac*df Hz - if(NFreeze.eq.1) then - fa=max(200.0,1270.46+MouseDF-DFTolerance) - fb=min(4800.0,1270.46+MouseDF+DFTolerance) - endif - ia2=fa/df - ib2=fb/df + 4.1*nfac !Upper tone is above sync tone by 4*nfac*df Hz - if(ib2.gt.NH) ib2=NH - -C Find strongest line in each of the 4 phases, repeating for each drift rate. - sbest=0. - snrbest=0. - idz=6.0/df !Is this the right drift range? - do idrift=-idz,idz - drift=idrift*df*60.0/49.04 - call zero(ss,4*NH) !Clear the accumulating array - do j=1,nsteps - n=mod(j-1,4)+1 - k=nint((j-nsteps/2)*drift*fac) + ia - call add(ss(ia,n),s2(k,j),ss(ia,n),ib-ia+1) - enddo - - do n=1,4 - sigmax(n)=0. - do i=ia2,ib2 - sig=ss(i,n) - if(sig.ge.sigmax(n)) then - ipk(n)=i - sigmax(n)=sig - if(sig.ge.sbest) then - sbest=sig - nbest=n - fdotsh=drift - endif - endif - enddo - enddo - n2best=nbest+2 - if(n2best.gt.4) n2best=nbest-2 - xdf=min(ipk(nbest),ipk(n2best))*df - 1270.46 - if(NFreeze.eq.1 .and. abs(xdf-mousedf).gt.DFTolerance) goto 10 - - idiff=abs(ipk(nbest)-ipk(n2best)) - xk=float(idiff)/nfac - k=nint(xk) - iderr=nint((xk-k)*nfac) - nspecial=0 - maxerr=nint(0.008*abs(idiff) + 0.51) - if(abs(iderr).le.maxerr .and. k.ge.2 .and. k.le.4) nspecial=k - if(nspecial.gt.0) then - call getsnr(ss(ia2,nbest),ib2-ia2+1,snr1) - call getsnr(ss(ia2,n2best),ib2-ia2+1,snr2) - snr=0.5*(snr1+snr2) - if(snr.gt.snrbest) then - snrbest=snr - nspecialbest=nspecial - nstest=snr/2.0 - 2.0 !Threshold set here - if(nstest.lt.0) nstest=0 - if(nstest.gt.10) nstest=10 - dfsh=nint(xdf) - iderrbest=iderr - idriftbest=idrift - snrdb=db(snr) - db(2500.0/df) - db(sqrt(nsteps/4.0))+1.8 - n1=nbest - n2=n2best - ipk1=ipk(n1) - ipk2=ipk(n2) - endif - endif - if(nstest.eq.0) nspecial=0 - 10 enddo - - if(nstest.eq.0) nspecialbest=0 - df4=4.0*df - if(nstest.gt.0) then - - if(ipk1.gt.ipk2) then - ntmp=n1 - n1=n2 - n2=ntmp - ntmp=ipk1 - ipk1=ipk2 - ipk2=ntmp - endif - - call zero(ss1,2258) - call zero(ss2,2258) - do i=ia2,ib2,4 - f=df*i - k=nint((f-1270.46)/df4) - ss1(k)=0.3 * (ss(i-2,n1) + ss(i-1,n1) + ss(i,n1) + - + ss(i+1,n1) + ss(i+2,n1)) - ss2(k)=0.3 * (ss(i-2,n2) + ss(i-1,n2) + ss(i,n2) + - + ss(i+1,n2) + ss(i+2,n2)) - enddo - - kpk1=nint(0.25*ipk1-472.0) - kpk2=kpk1 + nspecial*mode65*10 - ssmax=0. - do i=-10,10 - ssavg(i)=ss1(kpk1+i) + ss2(kpk2+i) - if(ssavg(i).gt.ssmax) then - ssmax=ssavg(i) - itop=i - endif - enddo - base=0.25*(ssavg(-10)+ssavg(-9)+ssavg(9)+ssavg(10)) - shalf=0.5*(ssmax+base) - do k=1,8 - if(ssavg(itop-k).lt.shalf) go to 110 - enddo - k=8 - 110 x=(ssavg(itop-(k-1))-shalf)/(ssavg(itop-(k-1))-ssavg(itop-k)) - do k=1,8 - if(ssavg(itop+k).lt.shalf) go to 120 - enddo - k=8 - 120 x=x+(ssavg(itop+(k-1))-shalf)/(ssavg(itop+(k-1))-ssavg(itop+k)) - nwsh=nint(x*df4) - endif - -C See if orange/magenta curves need to be shifted: - idfsh=0 - if(mousedf.lt.-600) idfsh=-670 - if(mousedf.gt.600) idfsh=1000 - if(mousedf.gt.1600) idfsh=2000 - if(mousedf.gt.2600) idfsh=3000 - i0=nint(idfsh/df4) - - do i=-224,224 - ss1a(i)=ss1(i+i0) - ss2a(i)=ss2(i+i0) - enddo - - return - end + subroutine short65(data,jz,NFreeze,MouseDF,DFTolerance, + + mode65,nspecialbest,nstest,dfsh,iderrbest,idriftbest, + + snrdb,ss1a,ss2a,nwsh,idfsh) + +C Checks to see if this might be a shorthand message. +C This is done before zapping, downsampling, or normal decoding. + + parameter (NP2=60*11025) !Size of data array + parameter (NFFT=16384) !FFT length + parameter (NH=NFFT/2) !Step size + parameter (MAXSTEPS=60*11025/NH) !Max # of steps + + real data(jz) + integer DFTolerance + real s2(NH,MAXSTEPS) !2d spectrum + real ss(NH,4) !Save spectra in four phase bins + real psavg(NH) + real sigmax(4) !Peak of spectrum at each phase + real ss1a(-224:224) !Lower magenta curve + real ss2a(-224:224) !Upper magenta curve + real ss1(-473:1784) !Lower magenta curve (temp) + real ss2(-473:1784) !Upper magenta curve (temp) + real ssavg(-11:11) + integer ipk(4) !Peak bin at each phase + save + + nspecialbest=0 !Default return value + nstest=0 + df=11025.0/NFFT + +C Do 16 k FFTs, stepped by 8k. (*** Maybe should step by 4k? ***) + call zero(psavg,NH) + nsteps=(jz-NH)/(4*NH) + nsteps=4*nsteps !Number of steps + do j=1,nsteps + k=(j-1)*NH + 1 + call ps(data(k),NFFT,s2(1,j)) !Get power spectra + if(mode65.eq.4) then + call smooth(s2(1,j),NH) + call smooth(s2(1,j),NH) + endif + call add(psavg,s2(1,j),psavg,NH) + enddo + + call flat1(psavg,s2,NH,nsteps,NH,MAXSTEPS) + + nfac=40*mode65 + dtstep=0.5/df + fac=dtstep/(60.0*df) + +C Define range of frequencies to be searched + fa=max(200.0,1270.46+MouseDF-600.0) + fb=min(4800.0,1270.46+MouseDF+600.0) + ia=fa/df + ib=fb/df + 4.1*nfac !Upper tone is above sync tone by 4*nfac*df Hz + if(NFreeze.eq.1) then + fa=max(200.0,1270.46+MouseDF-DFTolerance) + fb=min(4800.0,1270.46+MouseDF+DFTolerance) + endif + ia2=fa/df + ib2=fb/df + 4.1*nfac !Upper tone is above sync tone by 4*nfac*df Hz + if(ib2.gt.NH) ib2=NH + +C Find strongest line in each of the 4 phases, repeating for each drift rate. + sbest=0. + snrbest=0. + idz=6.0/df !Is this the right drift range? + do idrift=-idz,idz + drift=idrift*df*60.0/49.04 + call zero(ss,4*NH) !Clear the accumulating array + do j=1,nsteps + n=mod(j-1,4)+1 + k=nint((j-nsteps/2)*drift*fac) + ia + call add(ss(ia,n),s2(k,j),ss(ia,n),ib-ia+1) + enddo + + do n=1,4 + sigmax(n)=0. + do i=ia2,ib2 + sig=ss(i,n) + if(sig.ge.sigmax(n)) then + ipk(n)=i + sigmax(n)=sig + if(sig.ge.sbest) then + sbest=sig + nbest=n + fdotsh=drift + endif + endif + enddo + enddo + n2best=nbest+2 + if(n2best.gt.4) n2best=nbest-2 + xdf=min(ipk(nbest),ipk(n2best))*df - 1270.46 + if(NFreeze.eq.1 .and. abs(xdf-mousedf).gt.DFTolerance) goto 10 + + idiff=abs(ipk(nbest)-ipk(n2best)) + xk=float(idiff)/nfac + k=nint(xk) + iderr=nint((xk-k)*nfac) + nspecial=0 + maxerr=nint(0.008*abs(idiff) + 0.51) + if(abs(iderr).le.maxerr .and. k.ge.2 .and. k.le.4) nspecial=k + if(nspecial.gt.0) then + call getsnr(ss(ia2,nbest),ib2-ia2+1,snr1) + call getsnr(ss(ia2,n2best),ib2-ia2+1,snr2) + snr=0.5*(snr1+snr2) + if(snr.gt.snrbest) then + snrbest=snr + nspecialbest=nspecial + nstest=snr/2.0 - 2.0 !Threshold set here + if(nstest.lt.0) nstest=0 + if(nstest.gt.10) nstest=10 + dfsh=nint(xdf) + iderrbest=iderr + idriftbest=idrift + snrdb=db(snr) - db(2500.0/df) - db(sqrt(nsteps/4.0))+1.8 + n1=nbest + n2=n2best + ipk1=ipk(n1) + ipk2=ipk(n2) + endif + endif + if(nstest.eq.0) nspecial=0 + 10 enddo + + if(nstest.eq.0) nspecialbest=0 + df4=4.0*df + if(nstest.gt.0) then + + if(ipk1.gt.ipk2) then + ntmp=n1 + n1=n2 + n2=ntmp + ntmp=ipk1 + ipk1=ipk2 + ipk2=ntmp + endif + + call zero(ss1,2258) + call zero(ss2,2258) + do i=ia2,ib2,4 + f=df*i + k=nint((f-1270.46)/df4) + ss1(k)=0.3 * (ss(i-2,n1) + ss(i-1,n1) + ss(i,n1) + + + ss(i+1,n1) + ss(i+2,n1)) + ss2(k)=0.3 * (ss(i-2,n2) + ss(i-1,n2) + ss(i,n2) + + + ss(i+1,n2) + ss(i+2,n2)) + enddo + + kpk1=nint(0.25*ipk1-472.0) + kpk2=kpk1 + nspecial*mode65*10 + ssmax=0. + do i=-10,10 + ssavg(i)=ss1(kpk1+i) + ss2(kpk2+i) + if(ssavg(i).gt.ssmax) then + ssmax=ssavg(i) + itop=i + endif + enddo + base=0.25*(ssavg(-10)+ssavg(-9)+ssavg(9)+ssavg(10)) + shalf=0.5*(ssmax+base) + do k=1,8 + if(ssavg(itop-k).lt.shalf) go to 110 + enddo + k=8 + 110 x=(ssavg(itop-(k-1))-shalf)/(ssavg(itop-(k-1))-ssavg(itop-k)) + do k=1,8 + if(ssavg(itop+k).lt.shalf) go to 120 + enddo + k=8 + 120 x=x+(ssavg(itop+(k-1))-shalf)/(ssavg(itop+(k-1))-ssavg(itop+k)) + nwsh=nint(x*df4) + endif + +C See if orange/magenta curves need to be shifted: + idfsh=0 + if(mousedf.lt.-600) idfsh=-670 + if(mousedf.gt.600) idfsh=1000 + if(mousedf.gt.1600) idfsh=2000 + if(mousedf.gt.2600) idfsh=3000 + i0=nint(idfsh/df4) + + do i=-224,224 + ss1a(i)=ss1(i+i0) + ss2a(i)=ss2(i+i0) + enddo + + return + end diff --git a/slope.f b/slope.f index c8f08bbaa..c14653a21 100644 --- a/slope.f +++ b/slope.f @@ -1,41 +1,41 @@ - subroutine slope(y,npts,xpk) - -C Remove best-fit slope from data in y(i). When fitting the straight line, -C ignore the peak around xpk +/- 2. - - real y(npts) - real x(100) - - do i=1,npts - x(i)=i - enddo - - sumw=0. - sumx=0. - sumy=0. - sumx2=0. - sumxy=0. - sumy2=0. - - do i=1,npts - if(abs(i-xpk).gt.2.0) then - sumw=sumw + 1.0 - sumx=sumx + x(i) - sumy=sumy + y(i) - sumx2=sumx2 + x(i)**2 - sumxy=sumxy + x(i)*y(i) - sumy2=sumy2 + y(i)**2 - endif - enddo - - delta=sumw*sumx2 - sumx**2 - a=(sumx2*sumy - sumx*sumxy) / delta - b=(sumw*sumxy - sumx*sumy) / delta - - do i=1,npts - y(i)=y(i)-(a + b*x(i)) - enddo - - return - end - + subroutine slope(y,npts,xpk) + +C Remove best-fit slope from data in y(i). When fitting the straight line, +C ignore the peak around xpk +/- 2. + + real y(npts) + real x(100) + + do i=1,npts + x(i)=i + enddo + + sumw=0. + sumx=0. + sumy=0. + sumx2=0. + sumxy=0. + sumy2=0. + + do i=1,npts + if(abs(i-xpk).gt.2.0) then + sumw=sumw + 1.0 + sumx=sumx + x(i) + sumy=sumy + y(i) + sumx2=sumx2 + x(i)**2 + sumxy=sumxy + x(i)*y(i) + sumy2=sumy2 + y(i)**2 + endif + enddo + + delta=sumw*sumx2 - sumx**2 + a=(sumx2*sumy - sumx*sumxy) / delta + b=(sumw*sumxy - sumx*sumy) / delta + + do i=1,npts + y(i)=y(i)-(a + b*x(i)) + enddo + + return + end + diff --git a/smooth.f b/smooth.f index 31522fbb6..899dc3594 100644 --- a/smooth.f +++ b/smooth.f @@ -1,13 +1,13 @@ - subroutine smooth(x,nz) - - real x(nz) - - x0=x(1) - do i=2,nz-1 - x1=x(i) - x(i)=0.5*x(i) + 0.25*(x0+x(i+1)) - x0=x1 - enddo - - return - end + subroutine smooth(x,nz) + + real x(nz) + + x0=x(1) + do i=2,nz-1 + x1=x(i) + x(i)=0.5*x(i) + 0.25*(x0+x(i+1)) + x0=x1 + enddo + + return + end diff --git a/sort.f b/sort.f index 7888b0cfd..41f18e3f8 100644 --- a/sort.f +++ b/sort.f @@ -1,4 +1,4 @@ - subroutine sort(n,arr) - call ssort(arr,tmp,n,1) - return - end + subroutine sort(n,arr) + call ssort(arr,tmp,n,1) + return + end diff --git a/spec2d65.f b/spec2d65.f index c1ec6b1aa..b58897512 100644 --- a/spec2d65.f +++ b/spec2d65.f @@ -1,90 +1,90 @@ - subroutine spec2d65(dat,jz,nsym,flip,istart,f0, - + ftrack,nafc,mode65,s2) - -C Computes the spectrum for each of 126 symbols. -C NB: At this point, istart, f0, and ftrack are supposedly known. -C The JT65 signal has Sync bin + 2 guard bins + 64 data bins = 67 bins. -C We add 5 extra bins at top and bottom for drift, making 77 bins in all. - - parameter (NMAX=2048) !Max length of FFTs - real dat(jz) !Raw data - real s2(77,126) !Spectra of all symbols - real s(77) - real ref(77) - real ps(77) - real x(NMAX) - real ftrack(126) - real*8 pha,dpha,twopi - complex cx(NMAX) -c complex work(NMAX) - include 'prcom.h' - equivalence (x,cx) - data twopi/6.28318530718d0/ - save - -C Peak up in frequency and time, and compute ftrack. - call ftpeak65(dat,jz,istart,f0,flip,pr,nafc,ftrack) - - nfft=2048/mode65 !Size of FFTs - dt=2.0/11025.0 - df=0.5*11025.0/nfft - call zero(ps,77) - k=istart-nfft - -C NB: this could be done starting with array c3, in ftpeak65, instead -C of the dat() array. Would save some time this way ... - - do j=1,nsym - call zero(s,77) - do m=1,mode65 - k=k+nfft - if(k.ge.1 .and. k.le.(jz-nfft)) then -C Mix sync tone down to f=5*df (==> bin 6 of array cx, after FFT) - dpha=twopi*dt*(f0 + ftrack(j) - 5.0*df) - pha=0.0 - do i=1,nfft - pha=pha+dpha - cx(i)=dat(k-1+i)*cmplx(cos(pha),-sin(pha)) - enddo - - call four2a(cx,nfft,1,-1,1) - do i=1,77 - s(i)=s(i) + real(cx(i))**2 + aimag(cx(i))**2 - enddo - - else - call zero(s,77) - endif - enddo - call move(s,s2(1,j),77) - call add(ps,s,ps,77) - enddo - -C Flatten the spectra by dividing through by the average of the -C "sync on" spectra, with the sync tone explicitly deleted. - nref=nsym/2 - do i=1,77 -C First we sum all the sync-on spectra: - ref(i)=0. - do j=1,nsym - if(flip*pr(j).gt.0.0) ref(i)=ref(i)+s2(i,j) - enddo - ref(i)=ref(i)/nref !Normalize - enddo -C Remove the sync tone itself: - base=0.25*(ref(1)+ref(2)+ref(10)+ref(11)) - do i=3,9 - ref(i)=base - enddo - -C Now flatten the spectra for all the data symbols: - do i=1,77 - fac=1.0/ref(i) - do j=1,nsym - s2(i,j)=fac*s2(i,j) - if(s2(i,j).eq.0.0) s2(i,j)=1.0 !### To fix problem in mfskprob - enddo - enddo - - return - end + subroutine spec2d65(dat,jz,nsym,flip,istart,f0, + + ftrack,nafc,mode65,s2) + +C Computes the spectrum for each of 126 symbols. +C NB: At this point, istart, f0, and ftrack are supposedly known. +C The JT65 signal has Sync bin + 2 guard bins + 64 data bins = 67 bins. +C We add 5 extra bins at top and bottom for drift, making 77 bins in all. + + parameter (NMAX=2048) !Max length of FFTs + real dat(jz) !Raw data + real s2(77,126) !Spectra of all symbols + real s(77) + real ref(77) + real ps(77) + real x(NMAX) + real ftrack(126) + real*8 pha,dpha,twopi + complex cx(NMAX) +c complex work(NMAX) + include 'prcom.h' + equivalence (x,cx) + data twopi/6.28318530718d0/ + save + +C Peak up in frequency and time, and compute ftrack. + call ftpeak65(dat,jz,istart,f0,flip,pr,nafc,ftrack) + + nfft=2048/mode65 !Size of FFTs + dt=2.0/11025.0 + df=0.5*11025.0/nfft + call zero(ps,77) + k=istart-nfft + +C NB: this could be done starting with array c3, in ftpeak65, instead +C of the dat() array. Would save some time this way ... + + do j=1,nsym + call zero(s,77) + do m=1,mode65 + k=k+nfft + if(k.ge.1 .and. k.le.(jz-nfft)) then +C Mix sync tone down to f=5*df (==> bin 6 of array cx, after FFT) + dpha=twopi*dt*(f0 + ftrack(j) - 5.0*df) + pha=0.0 + do i=1,nfft + pha=pha+dpha + cx(i)=dat(k-1+i)*cmplx(cos(pha),-sin(pha)) + enddo + + call four2a(cx,nfft,1,-1,1) + do i=1,77 + s(i)=s(i) + real(cx(i))**2 + aimag(cx(i))**2 + enddo + + else + call zero(s,77) + endif + enddo + call move(s,s2(1,j),77) + call add(ps,s,ps,77) + enddo + +C Flatten the spectra by dividing through by the average of the +C "sync on" spectra, with the sync tone explicitly deleted. + nref=nsym/2 + do i=1,77 +C First we sum all the sync-on spectra: + ref(i)=0. + do j=1,nsym + if(flip*pr(j).gt.0.0) ref(i)=ref(i)+s2(i,j) + enddo + ref(i)=ref(i)/nref !Normalize + enddo +C Remove the sync tone itself: + base=0.25*(ref(1)+ref(2)+ref(10)+ref(11)) + do i=3,9 + ref(i)=base + enddo + +C Now flatten the spectra for all the data symbols: + do i=1,77 + fac=1.0/ref(i) + do j=1,nsym + s2(i,j)=fac*s2(i,j) + if(s2(i,j).eq.0.0) s2(i,j)=1.0 !### To fix problem in mfskprob + enddo + enddo + + return + end diff --git a/ssort.f b/ssort.f index 972001e13..9025f8a9c 100644 --- a/ssort.f +++ b/ssort.f @@ -1,285 +1,285 @@ - subroutine ssort (x,y,n,kflag) -c***purpose sort an array and optionally make the same interchanges in -c an auxiliary array. the array may be sorted in increasing -c or decreasing order. a slightly modified quicksort -c algorithm is used. -c -c ssort sorts array x and optionally makes the same interchanges in -c array y. the array x may be sorted in increasing order or -c decreasing order. a slightly modified quicksort algorithm is used. -c -c description of parameters -c x - array of values to be sorted -c y - array to be (optionally) carried along -c n - number of values in array x to be sorted -c kflag - control parameter -c = 2 means sort x in increasing order and carry y along. -c = 1 means sort x in increasing order (ignoring y) -c = -1 means sort x in decreasing order (ignoring y) -c = -2 means sort x in decreasing order and carry y along. - - integer kflag, n - real x(n), y(n) - real r, t, tt, tty, ty - integer i, ij, j, k, kk, l, m, nn - integer il(21), iu(21) - - nn = n - if (nn .lt. 1) then - print*,'ssort: The number of sort elements is not positive.' - print*,'ssort: n = ',nn,' kflag = ',kflag - return - endif -c - kk = abs(kflag) - if (kk.ne.1 .and. kk.ne.2) then - print *, - + 'the sort control parameter, k, is not 2, 1, -1, or -2.' - return - endif -c -c alter array x to get decreasing order if needed -c - if (kflag .le. -1) then - do 10 i=1,nn - x(i) = -x(i) - 10 continue - endif -c - if (kk .eq. 2) go to 100 -c -c sort x only -c - m = 1 - i = 1 - j = nn - r = 0.375e0 -c - 20 if (i .eq. j) go to 60 - if (r .le. 0.5898437e0) then - r = r+3.90625e-2 - else - r = r-0.21875e0 - endif -c - 30 k = i -c -c select a central element of the array and save it in location t -c - ij = i + int((j-i)*r) - t = x(ij) -c -c if first element of array is greater than t, interchange with t -c - if (x(i) .gt. t) then - x(ij) = x(i) - x(i) = t - t = x(ij) - endif - l = j -c -c if last element of array is less than than t, interchange with t -c - if (x(j) .lt. t) then - x(ij) = x(j) - x(j) = t - t = x(ij) -c -c if first element of array is greater than t, interchange with t -c - if (x(i) .gt. t) then - x(ij) = x(i) - x(i) = t - t = x(ij) - endif - endif -c -c find an element in the second half of the array which is smaller -c than t -c - 40 l = l-1 - if (x(l) .gt. t) go to 40 -c -c find an element in the first half of the array which is greater -c than t -c - 50 k = k+1 - if (x(k) .lt. t) go to 50 -c -c interchange these elements -c - if (k .le. l) then - tt = x(l) - x(l) = x(k) - x(k) = tt - go to 40 - endif -c -c save upper and lower subscripts of the array yet to be sorted -c - if (l-i .gt. j-k) then - il(m) = i - iu(m) = l - i = k - m = m+1 - else - il(m) = k - iu(m) = j - j = l - m = m+1 - endif - go to 70 -c -c begin again on another portion of the unsorted array -c - 60 m = m-1 - if (m .eq. 0) go to 190 - i = il(m) - j = iu(m) -c - 70 if (j-i .ge. 1) go to 30 - if (i .eq. 1) go to 20 - i = i-1 -c - 80 i = i+1 - if (i .eq. j) go to 60 - t = x(i+1) - if (x(i) .le. t) go to 80 - k = i -c - 90 x(k+1) = x(k) - k = k-1 - if (t .lt. x(k)) go to 90 - x(k+1) = t - go to 80 -c -c sort x and carry y along -c - 100 m = 1 - i = 1 - j = nn - r = 0.375e0 -c - 110 if (i .eq. j) go to 150 - if (r .le. 0.5898437e0) then - r = r+3.90625e-2 - else - r = r-0.21875e0 - endif -c - 120 k = i -c -c select a central element of the array and save it in location t -c - ij = i + int((j-i)*r) - t = x(ij) - ty = y(ij) -c -c if first element of array is greater than t, interchange with t -c - if (x(i) .gt. t) then - x(ij) = x(i) - x(i) = t - t = x(ij) - y(ij) = y(i) - y(i) = ty - ty = y(ij) - endif - l = j -c -c if last element of array is less than t, interchange with t -c - if (x(j) .lt. t) then - x(ij) = x(j) - x(j) = t - t = x(ij) - y(ij) = y(j) - y(j) = ty - ty = y(ij) -c -c if first element of array is greater than t, interchange with t -c - if (x(i) .gt. t) then - x(ij) = x(i) - x(i) = t - t = x(ij) - y(ij) = y(i) - y(i) = ty - ty = y(ij) - endif - endif -c -c find an element in the second half of the array which is smaller -c than t -c - 130 l = l-1 - if (x(l) .gt. t) go to 130 -c -c find an element in the first half of the array which is greater -c than t -c - 140 k = k+1 - if (x(k) .lt. t) go to 140 -c -c interchange these elements -c - if (k .le. l) then - tt = x(l) - x(l) = x(k) - x(k) = tt - tty = y(l) - y(l) = y(k) - y(k) = tty - go to 130 - endif -c -c save upper and lower subscripts of the array yet to be sorted -c - if (l-i .gt. j-k) then - il(m) = i - iu(m) = l - i = k - m = m+1 - else - il(m) = k - iu(m) = j - j = l - m = m+1 - endif - go to 160 -c -c begin again on another portion of the unsorted array -c - 150 m = m-1 - if (m .eq. 0) go to 190 - i = il(m) - j = iu(m) -c - 160 if (j-i .ge. 1) go to 120 - if (i .eq. 1) go to 110 - i = i-1 -c - 170 i = i+1 - if (i .eq. j) go to 150 - t = x(i+1) - ty = y(i+1) - if (x(i) .le. t) go to 170 - k = i -c - 180 x(k+1) = x(k) - y(k+1) = y(k) - k = k-1 - if (t .lt. x(k)) go to 180 - x(k+1) = t - y(k+1) = ty - go to 170 -c -c clean up -c - 190 if (kflag .le. -1) then - do 200 i=1,nn - x(i) = -x(i) - 200 continue - endif - return - end + subroutine ssort (x,y,n,kflag) +c***purpose sort an array and optionally make the same interchanges in +c an auxiliary array. the array may be sorted in increasing +c or decreasing order. a slightly modified quicksort +c algorithm is used. +c +c ssort sorts array x and optionally makes the same interchanges in +c array y. the array x may be sorted in increasing order or +c decreasing order. a slightly modified quicksort algorithm is used. +c +c description of parameters +c x - array of values to be sorted +c y - array to be (optionally) carried along +c n - number of values in array x to be sorted +c kflag - control parameter +c = 2 means sort x in increasing order and carry y along. +c = 1 means sort x in increasing order (ignoring y) +c = -1 means sort x in decreasing order (ignoring y) +c = -2 means sort x in decreasing order and carry y along. + + integer kflag, n + real x(n), y(n) + real r, t, tt, tty, ty + integer i, ij, j, k, kk, l, m, nn + integer il(21), iu(21) + + nn = n + if (nn .lt. 1) then + print*,'ssort: The number of sort elements is not positive.' + print*,'ssort: n = ',nn,' kflag = ',kflag + return + endif +c + kk = abs(kflag) + if (kk.ne.1 .and. kk.ne.2) then + print *, + + 'the sort control parameter, k, is not 2, 1, -1, or -2.' + return + endif +c +c alter array x to get decreasing order if needed +c + if (kflag .le. -1) then + do 10 i=1,nn + x(i) = -x(i) + 10 continue + endif +c + if (kk .eq. 2) go to 100 +c +c sort x only +c + m = 1 + i = 1 + j = nn + r = 0.375e0 +c + 20 if (i .eq. j) go to 60 + if (r .le. 0.5898437e0) then + r = r+3.90625e-2 + else + r = r-0.21875e0 + endif +c + 30 k = i +c +c select a central element of the array and save it in location t +c + ij = i + int((j-i)*r) + t = x(ij) +c +c if first element of array is greater than t, interchange with t +c + if (x(i) .gt. t) then + x(ij) = x(i) + x(i) = t + t = x(ij) + endif + l = j +c +c if last element of array is less than than t, interchange with t +c + if (x(j) .lt. t) then + x(ij) = x(j) + x(j) = t + t = x(ij) +c +c if first element of array is greater than t, interchange with t +c + if (x(i) .gt. t) then + x(ij) = x(i) + x(i) = t + t = x(ij) + endif + endif +c +c find an element in the second half of the array which is smaller +c than t +c + 40 l = l-1 + if (x(l) .gt. t) go to 40 +c +c find an element in the first half of the array which is greater +c than t +c + 50 k = k+1 + if (x(k) .lt. t) go to 50 +c +c interchange these elements +c + if (k .le. l) then + tt = x(l) + x(l) = x(k) + x(k) = tt + go to 40 + endif +c +c save upper and lower subscripts of the array yet to be sorted +c + if (l-i .gt. j-k) then + il(m) = i + iu(m) = l + i = k + m = m+1 + else + il(m) = k + iu(m) = j + j = l + m = m+1 + endif + go to 70 +c +c begin again on another portion of the unsorted array +c + 60 m = m-1 + if (m .eq. 0) go to 190 + i = il(m) + j = iu(m) +c + 70 if (j-i .ge. 1) go to 30 + if (i .eq. 1) go to 20 + i = i-1 +c + 80 i = i+1 + if (i .eq. j) go to 60 + t = x(i+1) + if (x(i) .le. t) go to 80 + k = i +c + 90 x(k+1) = x(k) + k = k-1 + if (t .lt. x(k)) go to 90 + x(k+1) = t + go to 80 +c +c sort x and carry y along +c + 100 m = 1 + i = 1 + j = nn + r = 0.375e0 +c + 110 if (i .eq. j) go to 150 + if (r .le. 0.5898437e0) then + r = r+3.90625e-2 + else + r = r-0.21875e0 + endif +c + 120 k = i +c +c select a central element of the array and save it in location t +c + ij = i + int((j-i)*r) + t = x(ij) + ty = y(ij) +c +c if first element of array is greater than t, interchange with t +c + if (x(i) .gt. t) then + x(ij) = x(i) + x(i) = t + t = x(ij) + y(ij) = y(i) + y(i) = ty + ty = y(ij) + endif + l = j +c +c if last element of array is less than t, interchange with t +c + if (x(j) .lt. t) then + x(ij) = x(j) + x(j) = t + t = x(ij) + y(ij) = y(j) + y(j) = ty + ty = y(ij) +c +c if first element of array is greater than t, interchange with t +c + if (x(i) .gt. t) then + x(ij) = x(i) + x(i) = t + t = x(ij) + y(ij) = y(i) + y(i) = ty + ty = y(ij) + endif + endif +c +c find an element in the second half of the array which is smaller +c than t +c + 130 l = l-1 + if (x(l) .gt. t) go to 130 +c +c find an element in the first half of the array which is greater +c than t +c + 140 k = k+1 + if (x(k) .lt. t) go to 140 +c +c interchange these elements +c + if (k .le. l) then + tt = x(l) + x(l) = x(k) + x(k) = tt + tty = y(l) + y(l) = y(k) + y(k) = tty + go to 130 + endif +c +c save upper and lower subscripts of the array yet to be sorted +c + if (l-i .gt. j-k) then + il(m) = i + iu(m) = l + i = k + m = m+1 + else + il(m) = k + iu(m) = j + j = l + m = m+1 + endif + go to 160 +c +c begin again on another portion of the unsorted array +c + 150 m = m-1 + if (m .eq. 0) go to 190 + i = il(m) + j = iu(m) +c + 160 if (j-i .ge. 1) go to 120 + if (i .eq. 1) go to 110 + i = i-1 +c + 170 i = i+1 + if (i .eq. j) go to 150 + t = x(i+1) + ty = y(i+1) + if (x(i) .le. t) go to 170 + k = i +c + 180 x(k+1) = x(k) + y(k+1) = y(k) + k = k-1 + if (t .lt. x(k)) go to 180 + x(k+1) = t + y(k+1) = ty + go to 170 +c +c clean up +c + 190 if (kflag .le. -1) then + do 200 i=1,nn + x(i) = -x(i) + 200 continue + endif + return + end diff --git a/sun.f b/sun.f index e978aa00a..2e790be6a 100644 --- a/sun.f +++ b/sun.f @@ -1,84 +1,84 @@ - subroutine sun(y,m,DD,UT,lon,lat,RA,Dec,LST,Az,El,mjd) - - implicit none - - integer y !Year - integer m !Month - integer DD !Day - integer mjd !Modified Julian Date - real UT !UTC in hours - real RA,Dec !RA and Dec of sun - -C NB: Double caps here are single caps in the writeup. - -C Orbital elements of the Sun (also N=0, i=0, a=1): - real w !Argument of perihelion - real e !Eccentricity - real MM !Mean anomaly - real Ls !Mean longitude - -C Other standard variables: - real v !True anomaly - real EE !Eccentric anomaly - real ecl !Obliquity of the ecliptic - real d !Ephemeris time argument in days - real r !Distance to sun, AU - real xv,yv !x and y coords in ecliptic - real lonsun !Ecliptic long and lat of sun - real xs,ys !Ecliptic coords of sun (geocentric) - real xe,ye,ze !Equatorial coords of sun (geocentric) - real lon,lat - real GMST0,LST,HA - real xx,yy,zz - real xhor,yhor,zhor - real Az,El - - real rad - data rad/57.2957795/ - -C Time in days, with Jan 0, 2000 equal to 0.0: - d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + DD - 730530 + UT/24.0 - mjd=d + 51543 - ecl = 23.4393 - 3.563e-7 * d - -C Compute updated orbital elements for Sun: - w = 282.9404 + 4.70935e-5 * d - e = 0.016709 - 1.151e-9 * d - MM = mod(356.0470d0 + 0.9856002585d0 * d + 360000.d0,360.d0) - Ls = mod(w+MM+720.0,360.0) - - EE = MM + e*rad*sin(MM/rad) * (1.0 + e*cos(M/rad)) - EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.0 - e*cos(EE/rad)) - - xv = cos(EE/rad) - e - yv = sqrt(1.0-e*e) * sin(EE/rad) - v = rad*atan2(yv,xv) - r = sqrt(xv*xv + yv*yv) - lonsun = mod(v + w + 720.0,360.0) -C Ecliptic coordinates of sun (rectangular): - xs = r * cos(lonsun/rad) - ys = r * sin(lonsun/rad) - -C Equatorial coordinates of sun (rectangular): - xe = xs - ye = ys * cos(ecl/rad) - ze = ys * sin(ecl/rad) - -C RA and Dec in degrees: - RA = rad*atan2(ye,xe) - Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye)) - - GMST0 = (Ls + 180.0)/15.0 - LST = mod(GMST0+UT+lon/15.0+48.0,24.0) !LST in hours - HA = 15.0*LST - RA !HA in degrees - xx = cos(HA/rad)*cos(Dec/rad) - yy = sin(HA/rad)*cos(Dec/rad) - zz = sin(Dec/rad) - xhor = xx*sin(lat/rad) - zz*cos(lat/rad) - yhor = yy - zhor = xx*cos(lat/rad) + zz*sin(lat/rad) - Az = mod(rad*atan2(yhor,xhor) + 180.0 + 360.0,360.0) - El = rad*asin(zhor) - - return - end + subroutine sun(y,m,DD,UT,lon,lat,RA,Dec,LST,Az,El,mjd) + + implicit none + + integer y !Year + integer m !Month + integer DD !Day + integer mjd !Modified Julian Date + real UT !UTC in hours + real RA,Dec !RA and Dec of sun + +C NB: Double caps here are single caps in the writeup. + +C Orbital elements of the Sun (also N=0, i=0, a=1): + real w !Argument of perihelion + real e !Eccentricity + real MM !Mean anomaly + real Ls !Mean longitude + +C Other standard variables: + real v !True anomaly + real EE !Eccentric anomaly + real ecl !Obliquity of the ecliptic + real d !Ephemeris time argument in days + real r !Distance to sun, AU + real xv,yv !x and y coords in ecliptic + real lonsun !Ecliptic long and lat of sun + real xs,ys !Ecliptic coords of sun (geocentric) + real xe,ye,ze !Equatorial coords of sun (geocentric) + real lon,lat + real GMST0,LST,HA + real xx,yy,zz + real xhor,yhor,zhor + real Az,El + + real rad + data rad/57.2957795/ + +C Time in days, with Jan 0, 2000 equal to 0.0: + d=367*y - 7*(y+(m+9)/12)/4 + 275*m/9 + DD - 730530 + UT/24.0 + mjd=d + 51543 + ecl = 23.4393 - 3.563e-7 * d + +C Compute updated orbital elements for Sun: + w = 282.9404 + 4.70935e-5 * d + e = 0.016709 - 1.151e-9 * d + MM = mod(356.0470d0 + 0.9856002585d0 * d + 360000.d0,360.d0) + Ls = mod(w+MM+720.0,360.0) + + EE = MM + e*rad*sin(MM/rad) * (1.0 + e*cos(M/rad)) + EE = EE - (EE - e*rad*sin(EE/rad)-MM) / (1.0 - e*cos(EE/rad)) + + xv = cos(EE/rad) - e + yv = sqrt(1.0-e*e) * sin(EE/rad) + v = rad*atan2(yv,xv) + r = sqrt(xv*xv + yv*yv) + lonsun = mod(v + w + 720.0,360.0) +C Ecliptic coordinates of sun (rectangular): + xs = r * cos(lonsun/rad) + ys = r * sin(lonsun/rad) + +C Equatorial coordinates of sun (rectangular): + xe = xs + ye = ys * cos(ecl/rad) + ze = ys * sin(ecl/rad) + +C RA and Dec in degrees: + RA = rad*atan2(ye,xe) + Dec = rad*atan2(ze,sqrt(xe*xe + ye*ye)) + + GMST0 = (Ls + 180.0)/15.0 + LST = mod(GMST0+UT+lon/15.0+48.0,24.0) !LST in hours + HA = 15.0*LST - RA !HA in degrees + xx = cos(HA/rad)*cos(Dec/rad) + yy = sin(HA/rad)*cos(Dec/rad) + zz = sin(Dec/rad) + xhor = xx*sin(lat/rad) - zz*cos(lat/rad) + yhor = yy + zhor = xx*cos(lat/rad) + zz*sin(lat/rad) + Az = mod(rad*atan2(yhor,xhor) + 180.0 + 360.0,360.0) + El = rad*asin(zhor) + + return + end diff --git a/symspec.f b/symspec.f new file mode 100644 index 000000000..583032590 --- /dev/null +++ b/symspec.f @@ -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 diff --git a/toxyz.f b/toxyz.f index 9f75d5de1..e3fe52b7c 100644 --- a/toxyz.f +++ b/toxyz.f @@ -1,25 +1,25 @@ - subroutine toxyz(alpha,delta,r,vec) - - implicit real*8 (a-h,o-z) - real*8 vec(3) - - vec(1)=r*cos(delta)*cos(alpha) - vec(2)=r*cos(delta)*sin(alpha) - vec(3)=r*sin(delta) - - return - end - - subroutine fromxyz(vec,alpha,delta,r) - - implicit real*8 (a-h,o-z) - real*8 vec(3) - data twopi/6.283185307d0/ - - r=sqrt(vec(1)**2 + vec(2)**2 + vec(3)**2) - alpha=atan2(vec(2),vec(1)) - if(alpha.lt.0.d0) alpha=alpha+twopi - delta=asin(vec(3)/r) - - return - end + subroutine toxyz(alpha,delta,r,vec) + + implicit real*8 (a-h,o-z) + real*8 vec(3) + + vec(1)=r*cos(delta)*cos(alpha) + vec(2)=r*cos(delta)*sin(alpha) + vec(3)=r*sin(delta) + + return + end + + subroutine fromxyz(vec,alpha,delta,r) + + implicit real*8 (a-h,o-z) + real*8 vec(3) + data twopi/6.283185307d0/ + + r=sqrt(vec(1)**2 + vec(2)**2 + vec(3)**2) + alpha=atan2(vec(2),vec(1)) + if(alpha.lt.0.d0) alpha=alpha+twopi + delta=asin(vec(3)/r) + + return + end diff --git a/unpackcall.f b/unpackcall.f index 28247ab13..d239bc8c7 100644 --- a/unpackcall.f +++ b/unpackcall.f @@ -1,35 +1,35 @@ - subroutine unpackcall(ncall,word) - - character word*12,c*37 - - data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/ - - n=ncall - word='......' - if(n.ge.262177560) go to 999 !Plain text message ... - i=mod(n,27)+11 - word(6:6)=c(i:i) - n=n/27 - i=mod(n,27)+11 - word(5:5)=c(i:i) - n=n/27 - i=mod(n,27)+11 - word(4:4)=c(i:i) - n=n/27 - i=mod(n,10)+1 - word(3:3)=c(i:i) - n=n/10 - i=mod(n,36)+1 - word(2:2)=c(i:i) - n=n/36 - i=n+1 - word(1:1)=c(i:i) - do i=1,4 - if(word(i:i).ne.' ') go to 10 - enddo - go to 999 - 10 word=word(i:) - - 999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:) - return - end + subroutine unpackcall(ncall,word) + + character word*12,c*37 + + data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ '/ + + n=ncall + word='......' + if(n.ge.262177560) go to 999 !Plain text message ... + i=mod(n,27)+11 + word(6:6)=c(i:i) + n=n/27 + i=mod(n,27)+11 + word(5:5)=c(i:i) + n=n/27 + i=mod(n,27)+11 + word(4:4)=c(i:i) + n=n/27 + i=mod(n,10)+1 + word(3:3)=c(i:i) + n=n/10 + i=mod(n,36)+1 + word(2:2)=c(i:i) + n=n/36 + i=n+1 + word(1:1)=c(i:i) + do i=1,4 + if(word(i:i).ne.' ') go to 10 + enddo + go to 999 + 10 word=word(i:) + + 999 if(word(1:3).eq.'3D0') word='3DA0'//word(4:) + return + end diff --git a/unpackgrid.f b/unpackgrid.f index 0ecce2c74..6d605eade 100644 --- a/unpackgrid.f +++ b/unpackgrid.f @@ -1,32 +1,32 @@ - subroutine unpackgrid(ng,grid) - - parameter (NGBASE=180*180) - character grid*4,grid6*6 - - grid=' ' - if(ng.ge.32400) go to 10 - dlat=mod(ng,180)-90 - dlong=(ng/180)*2 - 180 + 2 - call deg2grid(dlong,dlat,grid6) - grid=grid6 - go to 100 - - 10 n=ng-NGBASE-1 - if(n.ge.1 .and.n.le.30) then - write(grid,1012) -n - 1012 format(i3.2) - else if(n.ge.31 .and.n.le.60) then - n=n-30 - write(grid,1022) -n - 1022 format('R',i3.2) - else if(n.eq.61) then - grid='RO' - else if(n.eq.62) then - grid='RRR' - else if(n.eq.63) then - grid='73' - endif - - 100 return - end - + subroutine unpackgrid(ng,grid) + + parameter (NGBASE=180*180) + character grid*4,grid6*6 + + grid=' ' + if(ng.ge.32400) go to 10 + dlat=mod(ng,180)-90 + dlong=(ng/180)*2 - 180 + 2 + call deg2grid(dlong,dlat,grid6) + grid=grid6 + go to 100 + + 10 n=ng-NGBASE-1 + if(n.ge.1 .and.n.le.30) then + write(grid,1012) -n + 1012 format(i3.2) + else if(n.ge.31 .and.n.le.60) then + n=n-30 + write(grid,1022) -n + 1022 format('R',i3.2) + else if(n.eq.61) then + grid='RO' + else if(n.eq.62) then + grid='RRR' + else if(n.eq.63) then + grid='73' + endif + + 100 return + end + diff --git a/unpackmsg.f b/unpackmsg.f index 81df6b783..7bf24cc94 100644 --- a/unpackmsg.f +++ b/unpackmsg.f @@ -1,89 +1,89 @@ - subroutine unpackmsg(dat,msg) - - parameter (NBASE=37*36*10*27*27*27) - parameter (NGBASE=180*180) - integer dat(12) - character c1*12,c2*12,grid*4,msg*22,grid6*6 - logical cqnnn - - cqnnn=.false. - nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+ - + ishft(dat(4),4) + iand(ishft(dat(5),-2),15) - - nc2=ishft(iand(dat(5),3),26) + ishft(dat(6),20) + - + ishft(dat(7),14) + ishft(dat(8),8) + ishft(dat(9),2) + - + iand(ishft(dat(10),-4),3) - - ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12) - - if(ng.gt.32768) then - call unpacktext(nc1,nc2,ng,msg) - go to 100 - endif - - if(nc1.lt.NBASE) then - call unpackcall(nc1,c1) - else - c1='......' - if(nc1.eq.NBASE+1) c1='CQ ' - if(nc1.eq.NBASE+2) c1='QRZ ' - nfreq=nc1-NBASE-3 - if(nfreq.ge.0 .and. nfreq.le.999) then - write(c1,1002) nfreq - 1002 format('CQ ',i3.3) - cqnnn=.true. - endif - endif - - if(nc2.lt.NBASE) then - call unpackcall(nc2,c2) - else - c2='......' - endif - - call unpackgrid(ng,grid) - grid6=grid//'ma' - call grid2k(grid6,k) - if(k.ge.1 .and. k.le.450) call getpfx2(k,c1) - if(k.ge.451 .and. k.le.900) call getpfx2(k,c2) - - i=index(c1,char(0)) - if(i.ge.3) c1=c1(1:i-1)//' ' - i=index(c2,char(0)) - if(i.ge.3) c2=c2(1:i-1)//' ' - - msg=' ' - j=0 - if(cqnnn) then - msg=c1//' ' - j=7 !### ??? ### - go to 10 - endif - - do i=1,12 - j=j+1 - msg(j:j)=c1(i:i) - if(c1(i:i).eq.' ') go to 10 - enddo - j=j+1 - msg(j:j)=' ' - - 10 do i=1,12 - if(j.le.21) j=j+1 - msg(j:j)=c2(i:i) - if(c2(i:i).eq.' ') go to 20 - enddo - j=j+1 - msg(j:j)=' ' - - 20 if(k.eq.0) then - do i=1,4 - if(j.le.21) j=j+1 - msg(j:j)=grid(i:i) - enddo - j=j+1 - msg(j:j)=' ' - endif - - 100 return - end + subroutine unpackmsg(dat,msg) + + parameter (NBASE=37*36*10*27*27*27) + parameter (NGBASE=180*180) + integer dat(12) + character c1*12,c2*12,grid*4,msg*22,grid6*6 + logical cqnnn + + cqnnn=.false. + nc1=ishft(dat(1),22) + ishft(dat(2),16) + ishft(dat(3),10)+ + + ishft(dat(4),4) + iand(ishft(dat(5),-2),15) + + nc2=ishft(iand(dat(5),3),26) + ishft(dat(6),20) + + + ishft(dat(7),14) + ishft(dat(8),8) + ishft(dat(9),2) + + + iand(ishft(dat(10),-4),3) + + ng=ishft(iand(dat(10),15),12) + ishft(dat(11),6) + dat(12) + + if(ng.gt.32768) then + call unpacktext(nc1,nc2,ng,msg) + go to 100 + endif + + if(nc1.lt.NBASE) then + call unpackcall(nc1,c1) + else + c1='......' + if(nc1.eq.NBASE+1) c1='CQ ' + if(nc1.eq.NBASE+2) c1='QRZ ' + nfreq=nc1-NBASE-3 + if(nfreq.ge.0 .and. nfreq.le.999) then + write(c1,1002) nfreq + 1002 format('CQ ',i3.3) + cqnnn=.true. + endif + endif + + if(nc2.lt.NBASE) then + call unpackcall(nc2,c2) + else + c2='......' + endif + + call unpackgrid(ng,grid) + grid6=grid//'ma' + call grid2k(grid6,k) + if(k.ge.1 .and. k.le.450) call getpfx2(k,c1) + if(k.ge.451 .and. k.le.900) call getpfx2(k,c2) + + i=index(c1,char(0)) + if(i.ge.3) c1=c1(1:i-1)//' ' + i=index(c2,char(0)) + if(i.ge.3) c2=c2(1:i-1)//' ' + + msg=' ' + j=0 + if(cqnnn) then + msg=c1//' ' + j=7 !### ??? ### + go to 10 + endif + + do i=1,12 + j=j+1 + msg(j:j)=c1(i:i) + if(c1(i:i).eq.' ') go to 10 + enddo + j=j+1 + msg(j:j)=' ' + + 10 do i=1,12 + if(j.le.21) j=j+1 + msg(j:j)=c2(i:i) + if(c2(i:i).eq.' ') go to 20 + enddo + j=j+1 + msg(j:j)=' ' + + 20 if(k.eq.0) then + do i=1,4 + if(j.le.21) j=j+1 + msg(j:j)=grid(i:i) + enddo + j=j+1 + msg(j:j)=' ' + endif + + 100 return + end diff --git a/unpacktext.f b/unpacktext.f index 0923e7eb1..54022226d 100644 --- a/unpacktext.f +++ b/unpacktext.f @@ -1,35 +1,35 @@ - subroutine unpacktext(nc1,nc2,nc3,msg) - - character*22 msg - character*44 c - data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ - - nc3=iand(nc3,32767) !Remove the "plain text" bit - if(iand(nc1,1).ne.0) nc3=nc3+32768 - nc1=nc1/2 - if(iand(nc2,1).ne.0) nc3=nc3+65536 - nc2=nc2/2 - - do i=5,1,-1 - j=mod(nc1,42)+1 - msg(i:i)=c(j:j) - nc1=nc1/42 - enddo - - do i=10,6,-1 - j=mod(nc2,42)+1 - msg(i:i)=c(j:j) - nc2=nc2/42 - enddo - - do i=13,11,-1 - j=mod(nc3,42)+1 - msg(i:i)=c(j:j) - nc3=nc3/42 - enddo - msg(14:22) = ' ' - - return - end - - + subroutine unpacktext(nc1,nc2,nc3,msg) + + character*22 msg + character*44 c + data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/ + + nc3=iand(nc3,32767) !Remove the "plain text" bit + if(iand(nc1,1).ne.0) nc3=nc3+32768 + nc1=nc1/2 + if(iand(nc2,1).ne.0) nc3=nc3+65536 + nc2=nc2/2 + + do i=5,1,-1 + j=mod(nc1,42)+1 + msg(i:i)=c(j:j) + nc1=nc1/42 + enddo + + do i=10,6,-1 + j=mod(nc2,42)+1 + msg(i:i)=c(j:j) + nc2=nc2/42 + enddo + + do i=13,11,-1 + j=mod(nc3,42)+1 + msg(i:i)=c(j:j) + nc3=nc3/42 + enddo + msg(14:22) = ' ' + + return + end + + diff --git a/wsjtgen.F90 b/wsjtgen.F90 index 068e58f39..427bbe50f 100644 --- a/wsjtgen.F90 +++ b/wsjtgen.F90 @@ -1,150 +1,150 @@ -subroutine wsjtgen - -! Compute the waveform to be transmitted. - -! Input: txmsg message to be transmitted, up to 28 characters -! samfacout fsample_out/11025.d0 - -! Output: iwave waveform data, i*2 format -! nwave number of samples -! sendingsh 0=normal; 1=shorthand (FSK441) or plain text (JT65) - - parameter (NMSGMAX=28) !Max characters per message - parameter (NSPD=25) !Samples per dit - parameter (NDPC=3) !Dits per character - parameter (NWMAX=661500) !Max length of waveform = 60*11025 - parameter (NTONES=4) !Number of FSK tones - - integer itone(84) - character msg*28,msgsent*22,idmsg*22 - real*8 freq,pha,dpha,twopi,dt - character testfile*27,tfile2*80 - logical lcwid - integer*2 icwid(110250),jwave(NWMAX) - - integer*1 hdr(44) - integer*2 nfmt2,nchan2,nbitsam2,nbytesam2 - character*4 ariff,awave,afmt,adata - common/hdr/ariff,lenfile,awave,afmt,lenfmt,nfmt2,nchan2, & - nsamrate,nbytesec,nbytesam2,nbitsam2,adata,ndata,jwave - equivalence (ariff,hdr) - - data twopi/6.28318530718d0/ - include 'gcom1.f90' - include 'gcom2.f90' - - fsample_out=11025.d0*samfacout - lcwid=.false. - if(idinterval.gt.0) then - n=(mod(int(tsec/60.d0),idinterval)) - if(n.eq.(1-txfirst)) lcwid=.true. - if(idinterval.eq.1) lcwid=.true. - endif - - msg=txmsg - ntxnow=ntxreq -! Convert all letters to upper case - do i=1,28 - if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') & - msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a')) - enddo - txmsg=msg - -! Find message length - do i=NMSGMAX,1,-1 - if(msg(i:i).ne.' ') go to 10 - enddo - i=1 -10 nmsg=i - nmsg0=nmsg - - if(msg(1:1).eq.'@') then - if(msg(2:2).eq.'/' .or. ichar(msg(2:2)).eq.92) then - txmsg=msg - testfile=msg(2:) -#ifdef Win32 - open(18,file=testfile,form='binary',status='old',err=12) - go to 14 -12 print*,'Cannot open test file ',msg(2:) - go to 999 -14 read(18) hdr - if(ndata.gt.NTxMax) ndata=NTxMax - call rfile(18,iwave,ndata,ierr) - close(18) - if(ierr.ne.0) print*,'Error reading test file ',msg(2:) - -#else - tfile2=testfile - call rfile2(tfile2,hdr,44+2*661500,nr) - if(nr.le.0) then - print*,'Error reading ',testfile - stop - endif - do i=1,ndata/2 - iwave(i)=jwave(i) - enddo -#endif - nwave=ndata/2 - do i=nwave,NTXMAX - iwave(i)=0 - enddo - sending=txmsg - sendingsh=2 - go to 999 - endif - -! Transmit a fixed tone at specified frequency - freq=1000.0 - if(msg(2:2).eq.'A' .or. msg(2:2).eq.'a') freq=882 - if(msg(2:2).eq.'B' .or. msg(2:2).eq.'b') freq=1323 - if(msg(2:2).eq.'C' .or. msg(2:2).eq.'c') freq=1764 - if(msg(2:2).eq.'D' .or. msg(2:2).eq.'d') freq=2205 - if(freq.eq.1000.0) then - read(msg(2:),*,err=1) freq - goto 2 -1 txmsg='@1000' - nmsg=5 - nmsg0=5 - endif -2 nwave=60*fsample_out - dpha=twopi*freq/fsample_out - do i=1,nwave - iwave(i)=32767.0*sin(i*dpha) - enddo - goto 900 - endif - - dt=1.d0/fsample_out - LTone=2 - -! We're in JT65 mode. - if(mode(5:5).eq.'A') mode65=1 - if(mode(5:5).eq.'B') mode65=2 - if(mode(5:5).eq.'C') mode65=4 - call gen65(msg,mode65,samfacout,iwave,nwave,sendingsh,msgsent) - - if(lcwid) then -! Generate and insert the CW ID. - wpm=25. - freqcw=800. - idmsg=MyCall//' ' - call gencwid(idmsg,wpm,freqcw,samfacout,icwid,ncwid) - k=nwave - do i=1,ncwid - k=k+1 - iwave(k)=icwid(i) - enddo - do i=1,2205 !Add 0.2 s of silence - k=k+1 - iwave(k)=0 - enddo - nwave=k - endif - -900 sending=txmsg - if(sendingsh.ne.1) sending=msgsent - nmsg=nmsg0 - -999 return -end subroutine wsjtgen - +subroutine wsjtgen + +! Compute the waveform to be transmitted. + +! Input: txmsg message to be transmitted, up to 28 characters +! samfacout fsample_out/11025.d0 + +! Output: iwave waveform data, i*2 format +! nwave number of samples +! sendingsh 0=normal; 1=shorthand (FSK441) or plain text (JT65) + + parameter (NMSGMAX=28) !Max characters per message + parameter (NSPD=25) !Samples per dit + parameter (NDPC=3) !Dits per character + parameter (NWMAX=661500) !Max length of waveform = 60*11025 + parameter (NTONES=4) !Number of FSK tones + + integer itone(84) + character msg*28,msgsent*22,idmsg*22 + real*8 freq,pha,dpha,twopi,dt + character testfile*27,tfile2*80 + logical lcwid + integer*2 icwid(110250),jwave(NWMAX) + + integer*1 hdr(44) + integer*2 nfmt2,nchan2,nbitsam2,nbytesam2 + character*4 ariff,awave,afmt,adata + common/hdr/ariff,lenfile,awave,afmt,lenfmt,nfmt2,nchan2, & + nsamrate,nbytesec,nbytesam2,nbitsam2,adata,ndata,jwave + equivalence (ariff,hdr) + + data twopi/6.28318530718d0/ + include 'gcom1.f90' + include 'gcom2.f90' + + fsample_out=11025.d0*samfacout + lcwid=.false. + if(idinterval.gt.0) then + n=(mod(int(tsec/60.d0),idinterval)) + if(n.eq.(1-txfirst)) lcwid=.true. + if(idinterval.eq.1) lcwid=.true. + endif + + msg=txmsg + ntxnow=ntxreq +! Convert all letters to upper case + do i=1,28 + if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') & + msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a')) + enddo + txmsg=msg + +! Find message length + do i=NMSGMAX,1,-1 + if(msg(i:i).ne.' ') go to 10 + enddo + i=1 +10 nmsg=i + nmsg0=nmsg + + if(msg(1:1).eq.'@') then + if(msg(2:2).eq.'/' .or. ichar(msg(2:2)).eq.92) then + txmsg=msg + testfile=msg(2:) +#ifdef Win32 + open(18,file=testfile,form='binary',status='old',err=12) + go to 14 +12 print*,'Cannot open test file ',msg(2:) + go to 999 +14 read(18) hdr + if(ndata.gt.NTxMax) ndata=NTxMax + call rfile(18,iwave,ndata,ierr) + close(18) + if(ierr.ne.0) print*,'Error reading test file ',msg(2:) + +#else + tfile2=testfile + call rfile2(tfile2,hdr,44+2*661500,nr) + if(nr.le.0) then + print*,'Error reading ',testfile + stop + endif + do i=1,ndata/2 + iwave(i)=jwave(i) + enddo +#endif + nwave=ndata/2 + do i=nwave,NTXMAX + iwave(i)=0 + enddo + sending=txmsg + sendingsh=2 + go to 999 + endif + +! Transmit a fixed tone at specified frequency + freq=1000.0 + if(msg(2:2).eq.'A' .or. msg(2:2).eq.'a') freq=882 + if(msg(2:2).eq.'B' .or. msg(2:2).eq.'b') freq=1323 + if(msg(2:2).eq.'C' .or. msg(2:2).eq.'c') freq=1764 + if(msg(2:2).eq.'D' .or. msg(2:2).eq.'d') freq=2205 + if(freq.eq.1000.0) then + read(msg(2:),*,err=1) freq + goto 2 +1 txmsg='@1000' + nmsg=5 + nmsg0=5 + endif +2 nwave=60*fsample_out + dpha=twopi*freq/fsample_out + do i=1,nwave + iwave(i)=32767.0*sin(i*dpha) + enddo + goto 900 + endif + + dt=1.d0/fsample_out + LTone=2 + +! We're in JT65 mode. + if(mode(5:5).eq.'A') mode65=1 + if(mode(5:5).eq.'B') mode65=2 + if(mode(5:5).eq.'C') mode65=4 + call gen65(msg,mode65,samfacout,iwave,nwave,sendingsh,msgsent) + + if(lcwid) then +! Generate and insert the CW ID. + wpm=25. + freqcw=800. + idmsg=MyCall//' ' + call gencwid(idmsg,wpm,freqcw,samfacout,icwid,ncwid) + k=nwave + do i=1,ncwid + k=k+1 + iwave(k)=icwid(i) + enddo + do i=1,2205 !Add 0.2 s of silence + k=k+1 + iwave(k)=0 + enddo + nwave=k + endif + +900 sending=txmsg + if(sendingsh.ne.1) sending=msgsent + nmsg=nmsg0 + +999 return +end subroutine wsjtgen + diff --git a/xcor.f b/xcor.f index b33b391ac..44c7c10c2 100644 --- a/xcor.f +++ b/xcor.f @@ -1,84 +1,84 @@ - subroutine xcor(s2,ipk,nsteps,nsym,lag1,lag2, - + ccf,ccf0,lagpk,flip,fdot) - -C Computes ccf of a row of s2 and the pseudo-random array pr. Returns -C peak of the CCF and the lag at which peak occurs. For JT65, the -C CCF peak may be either positive or negative, with negative implying -C the "OOO" message. - - parameter (NHMAX=1024) !Max length of power spectra - parameter (NSMAX=320) !Max number of half-symbol steps - real s2(NHMAX,NSMAX) !2d spectrum, stepped by half-symbols - real a(NSMAX),a2(NSMAX) - real ccf(-5:540) - include 'prcom.h' - common/clipcom/ nclip - data lagmin/0/ !Silence g77 warning - save - - df=11025.0/4096. - dtstep=0.5/df - fac=dtstep/(60.0*df) - - do j=1,nsteps - ii=nint((j-nsteps/2)*fdot*fac)+ipk - a(j)=s2(ii,j) - enddo - -C If requested, clip the spectrum that will be cross correlated. - nclip=0 !Turn it off - if(nclip.gt.0) then - call pctile(a,a2,nsteps,50,base) - alow=a2(nint(nsteps*0.16)) - ahigh=a2(nint(nsteps*0.84)) - rms=min(base-alow,ahigh-base) - clip=4.0-nclip - atop=base+clip*rms - abot=base-clip*rms - do i=1,nsteps - if(nclip.lt.4) then - a(i)=min(a(i),atop) - a(i)=max(a(i),abot) - else - if(a(i).ge.base) then - a(i)=1.0 - else - a(i)=-1.0 - endif - endif - enddo - endif - - ccfmax=0. - ccfmin=0. - do lag=lag1,lag2 - x=0. - do i=1,nsym - j=2*i-1+lag - if(j.ge.1 .and. j.le.nsteps) x=x+a(j)*pr(i) - enddo - ccf(lag)=2*x !The 2 is for plotting scale - if(ccf(lag).gt.ccfmax) then - ccfmax=ccf(lag) - lagpk=lag - endif - - if(ccf(lag).lt.ccfmin) then - ccfmin=ccf(lag) - lagmin=lag - endif - enddo - - ccf0=ccfmax - flip=1.0 - if(-ccfmin.gt.ccfmax) then - do lag=lag1,lag2 - ccf(lag)=-ccf(lag) - enddo - lagpk=lagmin - ccf0=-ccfmin - flip=-1.0 - endif - - return - end + subroutine xcor(s2,ipk,nsteps,nsym,lag1,lag2, + + ccf,ccf0,lagpk,flip,fdot) + +C Computes ccf of a row of s2 and the pseudo-random array pr. Returns +C peak of the CCF and the lag at which peak occurs. For JT65, the +C CCF peak may be either positive or negative, with negative implying +C the "OOO" message. + + parameter (NHMAX=1024) !Max length of power spectra + parameter (NSMAX=320) !Max number of half-symbol steps + real s2(NHMAX,NSMAX) !2d spectrum, stepped by half-symbols + real a(NSMAX),a2(NSMAX) + real ccf(-5:540) + include 'prcom.h' + common/clipcom/ nclip + data lagmin/0/ !Silence g77 warning + save + + df=11025.0/4096. + dtstep=0.5/df + fac=dtstep/(60.0*df) + + do j=1,nsteps + ii=nint((j-nsteps/2)*fdot*fac)+ipk + a(j)=s2(ii,j) + enddo + +C If requested, clip the spectrum that will be cross correlated. + nclip=0 !Turn it off + if(nclip.gt.0) then + call pctile(a,a2,nsteps,50,base) + alow=a2(nint(nsteps*0.16)) + ahigh=a2(nint(nsteps*0.84)) + rms=min(base-alow,ahigh-base) + clip=4.0-nclip + atop=base+clip*rms + abot=base-clip*rms + do i=1,nsteps + if(nclip.lt.4) then + a(i)=min(a(i),atop) + a(i)=max(a(i),abot) + else + if(a(i).ge.base) then + a(i)=1.0 + else + a(i)=-1.0 + endif + endif + enddo + endif + + ccfmax=0. + ccfmin=0. + do lag=lag1,lag2 + x=0. + do i=1,nsym + j=2*i-1+lag + if(j.ge.1 .and. j.le.nsteps) x=x+a(j)*pr(i) + enddo + ccf(lag)=2*x !The 2 is for plotting scale + if(ccf(lag).gt.ccfmax) then + ccfmax=ccf(lag) + lagpk=lag + endif + + if(ccf(lag).lt.ccfmin) then + ccfmin=ccf(lag) + lagmin=lag + endif + enddo + + ccf0=ccfmax + flip=1.0 + if(-ccfmin.gt.ccfmax) then + do lag=lag1,lag2 + ccf(lag)=-ccf(lag) + enddo + lagpk=lagmin + ccf0=-ccfmin + flip=-1.0 + endif + + return + end diff --git a/xfft.f b/xfft.f index 4a4040592..04684aa12 100644 --- a/xfft.f +++ b/xfft.f @@ -1,12 +1,12 @@ - subroutine xfft(x,nfft) - -C Real-to-complex FFT. - - real x(nfft) - -! call four2(x,nfft,1,-1,0) - call four2a(x,nfft,1,-1,0) - - return - end - + subroutine xfft(x,nfft) + +C Real-to-complex FFT. + + real x(nfft) + +! call four2(x,nfft,1,-1,0) + call four2a(x,nfft,1,-1,0) + + return + end + diff --git a/xfft2.f b/xfft2.f index 0eae674a5..2a7b05b20 100644 --- a/xfft2.f +++ b/xfft2.f @@ -1,184 +1,184 @@ - SUBROUTINE xfft2(DATA,NB) -c -c the cooley-tukey fast fourier transform in usasi basic fortran -c -C .. Scalar Arguments .. - INTEGER NB -C .. -C .. Array Arguments .. - REAL DATA(NB+2) -C .. -C .. Local Scalars .. - REAL DIFI,DIFR,RTHLF,SUMI,SUMR,T2I,T2R,T3I,T3R,T4I, - + T4R,TEMPI,TEMPR,THETA,TWOPI,U1I,U1R,U2I,U2R,U3I,U3R, - + U4I,U4R,W2I,W2R,W3I,W3R,WI,WR,WSTPI,WSTPR - INTEGER I,I2,IPAR,J,K1,K2,K3,K4,KDIF,KMIN, - + KSTEP,L,LMAX,M,MMAX,NH -C .. -C .. Intrinsic Functions .. - INTRINSIC COS,MAX0,REAL,SIN -C .. -C .. Data statements .. - DATA TWOPI/6.2831853071796/,RTHLF/0.70710678118655/ -c -c 1. real transform for the 1st dimension, n even. method-- -c transform a complex array of length n/2 whose real parts -c are the even numbered real values and whose imaginary parts -c are the odd numbered real values. separate and supply -c the second half by conjugate symmetry. -c - - NH = NB/2 -c -c shuffle data by bit reversal, since n=2**k. -c - J = 1 - DO 131 I2 = 1,NB,2 - IF (J-I2) 124,127,127 - 124 TEMPR = DATA(I2) - TEMPI = DATA(I2+1) - DATA(I2) = DATA(J) - DATA(I2+1) = DATA(J+1) - DATA(J) = TEMPR - DATA(J+1) = TEMPI - 127 M = NH - 128 IF (J-M) 130,130,129 - 129 J = J - M - M = M/2 - IF (M-2) 130,128,128 - 130 J = J + M - 131 CONTINUE - -c -c main loop for factors of two. perform fourier transforms of -c length four, with one of length two if needed. the twiddle factor -c w=exp(-2*pi*sqrt(-1)*m/(4*mmax)). check for w=-sqrt(-1) -c and repeat for w=w*(1-sqrt(-1))/sqrt(2). -c - IF (NB-2) 174,174,143 - 143 IPAR = NH - 144 IF (IPAR-2) 149,146,145 - 145 IPAR = IPAR/4 - GO TO 144 - - 146 DO 147 K1 = 1,NB,4 - K2 = K1 + 2 - TEMPR = DATA(K2) - TEMPI = DATA(K2+1) - DATA(K2) = DATA(K1) - TEMPR - DATA(K2+1) = DATA(K1+1) - TEMPI - DATA(K1) = DATA(K1) + TEMPR - DATA(K1+1) = DATA(K1+1) + TEMPI - 147 CONTINUE - 149 MMAX = 2 - 150 IF (MMAX-NH) 151,174,174 - 151 LMAX = MAX0(4,MMAX/2) - DO 173 L = 2,LMAX,4 - M = L - IF (MMAX-2) 156,156,152 - 152 THETA = -TWOPI*REAL(L)/REAL(4*MMAX) - WR = COS(THETA) - WI = SIN(THETA) - 155 W2R = WR*WR - WI*WI - W2I = 2.*WR*WI - W3R = W2R*WR - W2I*WI - W3I = W2R*WI + W2I*WR - 156 KMIN = 1 + IPAR*M - IF (MMAX-2) 157,157,158 - 157 KMIN = 1 - 158 KDIF = IPAR*MMAX - 159 KSTEP = 4*KDIF - IF (KSTEP-NB) 160,160,169 - 160 DO 168 K1 = KMIN,NB,KSTEP - K2 = K1 + KDIF - K3 = K2 + KDIF - K4 = K3 + KDIF - IF (MMAX-2) 161,161,164 - 161 U1R = DATA(K1) + DATA(K2) - U1I = DATA(K1+1) + DATA(K2+1) - U2R = DATA(K3) + DATA(K4) - U2I = DATA(K3+1) + DATA(K4+1) - U3R = DATA(K1) - DATA(K2) - U3I = DATA(K1+1) - DATA(K2+1) - U4R = DATA(K3+1) - DATA(K4+1) - U4I = DATA(K4) - DATA(K3) - GO TO 167 - - 164 T2R = W2R*DATA(K2) - W2I*DATA(K2+1) - T2I = W2R*DATA(K2+1) + W2I*DATA(K2) - T3R = WR*DATA(K3) - WI*DATA(K3+1) - T3I = WR*DATA(K3+1) + WI*DATA(K3) - T4R = W3R*DATA(K4) - W3I*DATA(K4+1) - T4I = W3R*DATA(K4+1) + W3I*DATA(K4) - U1R = DATA(K1) + T2R - U1I = DATA(K1+1) + T2I - U2R = T3R + T4R - U2I = T3I + T4I - U3R = DATA(K1) - T2R - U3I = DATA(K1+1) - T2I - U4R = T3I - T4I - U4I = T4R - T3R - - 167 DATA(K1) = U1R + U2R - DATA(K1+1) = U1I + U2I - DATA(K2) = U3R + U4R - DATA(K2+1) = U3I + U4I - DATA(K3) = U1R - U2R - DATA(K3+1) = U1I - U2I - DATA(K4) = U3R - U4R - DATA(K4+1) = U3I - U4I - 168 CONTINUE - KDIF = KSTEP - KMIN = 4*KMIN - 3 - GO TO 159 - - 169 M = M + LMAX - IF (M-MMAX) 170,170,173 - 170 TEMPR = WR - WR = (WR+WI)*RTHLF - WI = (WI-TEMPR)*RTHLF - GO TO 155 - - 173 CONTINUE - IPAR = 3 - IPAR - MMAX = MMAX + MMAX - GO TO 150 -c -c complete a real transform in the 1st dimension, n even, by con- -c jugate symmetries. -c - 174 THETA = -TWOPI/REAL(NB) - WSTPR = COS(THETA) - WSTPI = SIN(THETA) - WR = WSTPR - WI = WSTPI - I = 3 - J = NB - 1 - GO TO 207 - - 205 SUMR = (DATA(I)+DATA(J))/2. - SUMI = (DATA(I+1)+DATA(J+1))/2. - DIFR = (DATA(I)-DATA(J))/2. - DIFI = (DATA(I+1)-DATA(J+1))/2. - TEMPR = WR*SUMI + WI*DIFR - TEMPI = WI*SUMI - WR*DIFR - DATA(I) = SUMR + TEMPR - DATA(I+1) = DIFI + TEMPI - DATA(J) = SUMR - TEMPR - DATA(J+1) = -DIFI + TEMPI - I = I + 2 - J = J - 2 - TEMPR = WR - WR = WR*WSTPR - WI*WSTPI - WI = TEMPR*WSTPI + WI*WSTPR - 207 IF (I-J) 205,208,211 - 208 DATA(I+1) = -DATA(I+1) - - 211 DATA(NB+1) = DATA(1) - DATA(2) - DATA(NB+2) = 0. - - DATA(1) = DATA(1) + DATA(2) - DATA(2) = 0. - - RETURN - END + SUBROUTINE xfft2(DATA,NB) +c +c the cooley-tukey fast fourier transform in usasi basic fortran +c +C .. Scalar Arguments .. + INTEGER NB +C .. +C .. Array Arguments .. + REAL DATA(NB+2) +C .. +C .. Local Scalars .. + REAL DIFI,DIFR,RTHLF,SUMI,SUMR,T2I,T2R,T3I,T3R,T4I, + + T4R,TEMPI,TEMPR,THETA,TWOPI,U1I,U1R,U2I,U2R,U3I,U3R, + + U4I,U4R,W2I,W2R,W3I,W3R,WI,WR,WSTPI,WSTPR + INTEGER I,I2,IPAR,J,K1,K2,K3,K4,KDIF,KMIN, + + KSTEP,L,LMAX,M,MMAX,NH +C .. +C .. Intrinsic Functions .. + INTRINSIC COS,MAX0,REAL,SIN +C .. +C .. Data statements .. + DATA TWOPI/6.2831853071796/,RTHLF/0.70710678118655/ +c +c 1. real transform for the 1st dimension, n even. method-- +c transform a complex array of length n/2 whose real parts +c are the even numbered real values and whose imaginary parts +c are the odd numbered real values. separate and supply +c the second half by conjugate symmetry. +c + + NH = NB/2 +c +c shuffle data by bit reversal, since n=2**k. +c + J = 1 + DO 131 I2 = 1,NB,2 + IF (J-I2) 124,127,127 + 124 TEMPR = DATA(I2) + TEMPI = DATA(I2+1) + DATA(I2) = DATA(J) + DATA(I2+1) = DATA(J+1) + DATA(J) = TEMPR + DATA(J+1) = TEMPI + 127 M = NH + 128 IF (J-M) 130,130,129 + 129 J = J - M + M = M/2 + IF (M-2) 130,128,128 + 130 J = J + M + 131 CONTINUE + +c +c main loop for factors of two. perform fourier transforms of +c length four, with one of length two if needed. the twiddle factor +c w=exp(-2*pi*sqrt(-1)*m/(4*mmax)). check for w=-sqrt(-1) +c and repeat for w=w*(1-sqrt(-1))/sqrt(2). +c + IF (NB-2) 174,174,143 + 143 IPAR = NH + 144 IF (IPAR-2) 149,146,145 + 145 IPAR = IPAR/4 + GO TO 144 + + 146 DO 147 K1 = 1,NB,4 + K2 = K1 + 2 + TEMPR = DATA(K2) + TEMPI = DATA(K2+1) + DATA(K2) = DATA(K1) - TEMPR + DATA(K2+1) = DATA(K1+1) - TEMPI + DATA(K1) = DATA(K1) + TEMPR + DATA(K1+1) = DATA(K1+1) + TEMPI + 147 CONTINUE + 149 MMAX = 2 + 150 IF (MMAX-NH) 151,174,174 + 151 LMAX = MAX0(4,MMAX/2) + DO 173 L = 2,LMAX,4 + M = L + IF (MMAX-2) 156,156,152 + 152 THETA = -TWOPI*REAL(L)/REAL(4*MMAX) + WR = COS(THETA) + WI = SIN(THETA) + 155 W2R = WR*WR - WI*WI + W2I = 2.*WR*WI + W3R = W2R*WR - W2I*WI + W3I = W2R*WI + W2I*WR + 156 KMIN = 1 + IPAR*M + IF (MMAX-2) 157,157,158 + 157 KMIN = 1 + 158 KDIF = IPAR*MMAX + 159 KSTEP = 4*KDIF + IF (KSTEP-NB) 160,160,169 + 160 DO 168 K1 = KMIN,NB,KSTEP + K2 = K1 + KDIF + K3 = K2 + KDIF + K4 = K3 + KDIF + IF (MMAX-2) 161,161,164 + 161 U1R = DATA(K1) + DATA(K2) + U1I = DATA(K1+1) + DATA(K2+1) + U2R = DATA(K3) + DATA(K4) + U2I = DATA(K3+1) + DATA(K4+1) + U3R = DATA(K1) - DATA(K2) + U3I = DATA(K1+1) - DATA(K2+1) + U4R = DATA(K3+1) - DATA(K4+1) + U4I = DATA(K4) - DATA(K3) + GO TO 167 + + 164 T2R = W2R*DATA(K2) - W2I*DATA(K2+1) + T2I = W2R*DATA(K2+1) + W2I*DATA(K2) + T3R = WR*DATA(K3) - WI*DATA(K3+1) + T3I = WR*DATA(K3+1) + WI*DATA(K3) + T4R = W3R*DATA(K4) - W3I*DATA(K4+1) + T4I = W3R*DATA(K4+1) + W3I*DATA(K4) + U1R = DATA(K1) + T2R + U1I = DATA(K1+1) + T2I + U2R = T3R + T4R + U2I = T3I + T4I + U3R = DATA(K1) - T2R + U3I = DATA(K1+1) - T2I + U4R = T3I - T4I + U4I = T4R - T3R + + 167 DATA(K1) = U1R + U2R + DATA(K1+1) = U1I + U2I + DATA(K2) = U3R + U4R + DATA(K2+1) = U3I + U4I + DATA(K3) = U1R - U2R + DATA(K3+1) = U1I - U2I + DATA(K4) = U3R - U4R + DATA(K4+1) = U3I - U4I + 168 CONTINUE + KDIF = KSTEP + KMIN = 4*KMIN - 3 + GO TO 159 + + 169 M = M + LMAX + IF (M-MMAX) 170,170,173 + 170 TEMPR = WR + WR = (WR+WI)*RTHLF + WI = (WI-TEMPR)*RTHLF + GO TO 155 + + 173 CONTINUE + IPAR = 3 - IPAR + MMAX = MMAX + MMAX + GO TO 150 +c +c complete a real transform in the 1st dimension, n even, by con- +c jugate symmetries. +c + 174 THETA = -TWOPI/REAL(NB) + WSTPR = COS(THETA) + WSTPI = SIN(THETA) + WR = WSTPR + WI = WSTPI + I = 3 + J = NB - 1 + GO TO 207 + + 205 SUMR = (DATA(I)+DATA(J))/2. + SUMI = (DATA(I+1)+DATA(J+1))/2. + DIFR = (DATA(I)-DATA(J))/2. + DIFI = (DATA(I+1)-DATA(J+1))/2. + TEMPR = WR*SUMI + WI*DIFR + TEMPI = WI*SUMI - WR*DIFR + DATA(I) = SUMR + TEMPR + DATA(I+1) = DIFI + TEMPI + DATA(J) = SUMR - TEMPR + DATA(J+1) = -DIFI + TEMPI + I = I + 2 + J = J - 2 + TEMPR = WR + WR = WR*WSTPR - WI*WSTPI + WI = TEMPR*WSTPI + WI*WSTPR + 207 IF (I-J) 205,208,211 + 208 DATA(I+1) = -DATA(I+1) + + 211 DATA(NB+1) = DATA(1) - DATA(2) + DATA(NB+2) = 0. + + DATA(1) = DATA(1) + DATA(2) + DATA(2) = 0. + + RETURN + END