SUBROUTINE sinfit( d n, i y, qnd, o ave,var,amp,pha,prcvar,neff,ir) IMPLICIT NONE INTEGER nmax, kmax, kkmax PARAMETER (nmax=366,kmax=6,kkmax=2*kmax+1) INTEGER n,neff,ir REAL*4 y(n),qnd,ave,var,amp(kmax),pha(kmax),prcvar(kmax) * INTEGER j,k,kk,kk2 REAL*8 alpha(kkmax,kkmax),beta(kkmax),eps,t(nmax),tcycle,pi, & f(kkmax),yy,dpha,totvar * pi = 4.0d0*atan(1.0d0) DO j = 1, n t(j) = j END DO tcycle = n * eps = 1.0e-6 * DO kk = 1, kkmax beta(kk) = 0.0d0 DO kk2 = 1, kkmax alpha(kk,kk2) = 0.0d0 END DO END DO * neff = 0 DO j = 1, n IF (y(j) .NE. qnd) THEN neff = neff+1 f( 1 ) = 1.0d0 DO k = 1, kmax f(2*k ) = cos(2*pi*k*t(j)/tcycle) f(2*k+1) = sin(2*pi*k*t(j)/tcycle) END DO DO kk = 1, kkmax beta(kk) = beta(kk)+y(j)*f(kk) DO kk2 = 1, kkmax alpha(kk,kk2) = alpha(kk,kk2) + f(kk)*f(kk2) END DO END DO END IF END DO * IF (neff .EQ. 0) THEN ave = qnd var = qnd DO kk = 1, kkmax amp (kk) = qnd pha (kk) = qnd prcvar(kk) = qnd END DO *--------------- RETURN *--------------- END IF * CALL gauss ( kkmax, alpha, beta, eps, ir ) IF ( ir .NE. 0 ) THEN *** WRITE (0,*) 'Matrix singular in GAUSS, ir =',ir neff = -neff ave = qnd var = qnd DO kk = 1, kkmax amp (kk) = qnd pha (kk) = qnd prcvar(kk) = qnd END DO *--------------- RETURN *--------------- ELSE yy = 0.0d0 DO j = 1, n IF (y(j) .NE. qnd) THEN yy = yy + (y(j)-beta(1))**2 END IF END DO totvar = yy / neff var = totvar ave = beta( 1) * DO k = 1, kmax amp(k) = sqrt( beta(2*k)**2 + beta(2*k+1)**2 ) IF (amp(k) .EQ. 0.0) THEN pha(k) = 0.0 ELSE dpha = atan2( beta(2*k+1), beta(2*k) ) IF (dpha .LT. 0.0d0) dpha = dpha + 2*pi dpha = dpha * tcycle/k / (2*pi) pha(k) = dpha END IF yy = 0.0d0 DO j = 1, n IF (y(j) .NE. qnd) THEN yy = yy + ( beta(2*k) *cos(2*pi*k*t(j)/tcycle) & + beta(2*k+1)*sin(2*pi*k*t(j)/tcycle) & ) **2 END IF END DO yy = yy / neff IF (totvar .GT. 0.0d0) THEN prcvar(k) = yy / totvar * 100.0d0 ELSE prcvar(k) = 0.0d0 END IF END DO END IF RETURN END