SUBROUTINE ORTHO (N,M,SIGMA,PHI,IRMAX,SIGMAF,VFC,NPC,INDEX, # V,SUMD,ICMAX,F,W,D,ALPHA,C,SUMC,SC2,STDP) C 00415**4 C NAME ORTHO 00416**4 C 00417**4 C TYPE SUBROUTINE 00418**4 C 00419**4 C PURPOSE TO ORTHOGONALIZE A MATRIX PHI USING THE GRAM-SCHMIDT 00420**4 C ORTHOGONALIZATION PROCEDURE 00421**4 C 00422**4 C EXTERNAL ROUTINES * NONE * 00423**4 C 00424**4 C VARIABLES USED PHI , W, SIGMA , F 00425**4 C 00426**4 C VARIABLES RETURN SIGMAF , SUMC , SUMD , 00427**4 C C , D , NPC , VFC 00428**4 C 00429**4 C PARAMETERS PHI - AN N BY M MATRIX CONTAINING THE BASE FUNCTIONS00430**4 C EVALUATED AT EACH OBSERVATION POINT (OPTIONAL 00431**4 C CAN BE A FUNCTION SUBPROGRAM INSTEAD) 00432**4 C N - NUMBER OF OBSERVATION POINTS 00433**4 C M - NUMBER OF BASE FUNCTIONS 00434**4 C IRMAX - DECLARED ROW DIMENSION OF PHI AT C CALLING PROGRAM 00436**4 C F - VECTOR OF FUNCTIONAL VALUES 00437**4 C W - VECTOR OF WEIGHTS 00438**4 C INDEX - TEST OPTION FOR STATISTICALLY SIGNIFICANT 00439**4 C FOURIER COEFFICIENTS 00440**4 C 0 - NO TEST PERFORMED 00441**4 C 1 - COEF. TESTED AGAINST ITS STD. DEV. 00442**4 C 2 - COEF. TESTED AGAINST TWO TIMES ITS S.D. 00443**4 C 3 - COEF. TESTED AGAINST THREE TIMES ITS S.D. 00444**4 C SIGMA - A PRIORI VARIANCE FACTOR 00445**4 C 00446**4 C C - FOURIER COEFFICIENTS OF THE 00447**4 C ORTHOGONALIZED MATRIX 00448**4 C D - ORIGINAL COEFFICIENTS OF PHI 00449**4 C SUMC - ASSOCIATED COVARIANCE MATRIX OF C 00450**4 C SUMD - ASSOCIATED COVARIANCE MATRIX OF D 00451**4 C ICMAX - DECLARED ROW DIMENSION OF 'SUMD' C IN CALLING PROGRAM C V - VECTOR OF RESIDUALS 00452**4 C NPC - NUMBER OF COEFFICIENTS OF THE ORIGINAL 00453**4 C POLYNOMIAL RECOVERED FROM THE STATISTICALLY 00454**4 C TESTED FOURIER COEFFICIENTS 00455**4 C VFC - A POSTERIORI VARIANCE FACTOR OF 00456**4 C THE ORIGINAL POLYNOMIAL 00457**4 C 00458**4 DOUBLE PRECISION SIGMA,PHI,SIGMAF,VFC,V,SUMD,F,W,D,ALPHA,C, & SUMC,SC2,STDP,PN,V2,SC1,SC3,SC4,DABS,DSQRT, & DFLOAT,PINDEX,P DIMENSION ALPHA(IRMAX,1),W(N),F(N),C(M),D(M),SUMD(ICMAX,1), # SC2(N),V(N),STDP(M),PHI(IRMAX,1),SUMC(M) C 00463**2 C 00464**4 K=1 00465**4 ALPHA(M,M)=1.D0 00466**4 C 00467**4 10 DO 3 J=K,M 00468**4 IF(J.NE.K) GO TO 6 00469**4 ALPHA(K,K)=1.D0 00470**4 GO TO 3 00471**4 6 SC1=0.D0 00472**4 SC2(K)=0.D0 00473**4 SC3=0.D0 00474**4 C 00475**4 DO 2 I=1,N 00476**4 P=PHI(I,K) 00477**4 IF(K.EQ.1) GO TO 4 00478**4 K1=K-1 00479**4 C 00480**4 DO 5 J1=1,K1 00481**4 5 P=P+ALPHA(J1,K)*PHI(I,J1) 00482**4 4 SC1=SC1+W(I)*PHI(I,J)*P 00483**4 SC3=SC3+F(I)*W(I)*P 00484**4 2 SC2(K)=SC2(K)+W(I)*P**2 00485**4 ALPHA(J,K)=-SC1/SC2(K) 00486**4 ALPHA(K,J)=ALPHA(J,K) 00487**4 3 CONTINUE 00488**4 C 00489**4 C(K)=SC3/SC2(K) 00490**4 K=K+1 00491**4 IF(M.EQ.2) GO TO 34 00492**4 IF(K.LT.3) GO TO 10 00493**4 C 00494**4 JK=K-1 00495**4 9 JL=K 00496**4 JK=JK-1 00497**4 JJ=K-JK-1 00498**4 C 00499**4 DO 8 LM=1,JJ 00500**4 JL=JL-1 00501**4 8 ALPHA(JK,K)=ALPHA(JK,K)+ALPHA(JK,JL)*ALPHA(K,JL) 00502**4 C 00503**4 IF(JK.NE.1) GO TO 9 00504**4 IF(K.LT.M) GO TO 10 00505**4 C 00506**4 34 SC2(K)=0.D0 00507**4 SC3=0.D0 00508**4 C 00509**4 DO 7 I=1,N 00510**4 P=PHI(I,K) 00511**4 K1=K-1 00512**4 DO 1 J=1,K1 00513**4 1 P=P+ALPHA(J,K)*PHI(I,J) 00514**4 C 00515**4 SC2(K)=SC2(K)+W(I)*P**2 00516**4 7 SC3=SC3+F(I)*W(I)*P 00517**4 C(K)=SC3/SC2(K) 00518**4 C 00519**4 IDEKT=1 00520**4 ICOUNT=0 00521**4 1000 CONTINUE 00522**4 C 00523**4 DO 13 I=1,M 00524**4 D(I)=C(I) 00525**4 IF(I.EQ.M) GO TO 13 00526**4 II=I+1 00527**4 C 00528**4 DO 14 J=II,M 00529**4 14 D(I)=D(I)+ALPHA(I,J)*C(J) 00530**4 13 CONTINUE 00531**4 C 00532**4 DO 15 I=1,M 00533**4 DO 15 J=1,M 00534**4 15 SUMD(I,J)=0.D0 00535**4 C 00536**4 SC4=0.D0 00537**4 DO 22 I=1,N 00538**4 PN=0.D0 00539**4 DO 21 J=1,M 00540**4 21 PN=PN+D(J)*PHI(I,J) 00541**4 V(I)=F(I)-PN 00542**4 V2=V(I)**2 00543**4 22 SC4=SC4+V2*W(I) 00544**4 C 00545**4 SIGMAF=SC4/(N-M+ICOUNT)*SIGMA 00546**4 VFC=SIGMAF 00547**4 IF(IDEKT.EQ.2) VFC=SC4/(N-NPC)*SIGMA 00548**4 IF(INDEX.EQ.0) NPC=M 00549**4 DO 28 I=1,M 00550**4 SUMC(I)=SIGMAF/SC2(I) 00551**4 IF(IDEKT.EQ.1) GO TO 28 00552**4 IF(C(I).EQ.0D0) SUMC(I)=0D0 00553**4 28 CONTINUE 00554**4 DO 23 I=1,M 00555**4 DO 23 J=1,I 00556**4 DO 23 K=J,I 00557**4 23 SUMD(J,K)=SUMD(J,K)+ALPHA(J,I)*ALPHA(K,I)*SUMC(I) 00558**4 C 00559**4 DO 24 I=1,M 00560**4 IT=I+1 00561**4 IF(IT.GT.M) GO TO 30 00562**4 DO 24 J=IT,M 00563**4 24 SUMD(J,I)=SUMD(I,J) 00564**4 C 00565**4 C OPTIONAL CHECK FOR STATISTICALLY SIGNIFICANT FOURIER COEFFICIENTS 00566**4 C 00567**4 30 CONTINUE 00568**4 C 00569**4 IF(INDEX.EQ.0) GO TO 40 00570**4 IF(IDEKT.EQ.2) GO TO 40 00571**4 PINDEX=DFLOAT(INDEX) 00572**4 C 00573**4 DO 31 I=1,M 00574**4 STDP(I)=PINDEX*DSQRT(SUMC(I)) 00575**4 IF(DABS(C(I)).LT.STDP(I)) GO TO 32 00576**4 GO TO 31 00577**4 32 C(I)=0D0 00578**4 ICOUNT=ICOUNT+1 00579**4 SUMC(I)=0D0 00580**4 31 CONTINUE 00581**4 C 00582**4 NPC=0 00583**4 DO 33 I=1,M 00584**4 IF(C(I).NE.0D0) NPC=I 00585**4 33 CONTINUE 00586**4 IDEKT=2 00587**4 GO TO 1000 00588**4 40 RETURN 00589**4 END 00590**4