C SJJCOI SOURCE BP208322 09/09/09 21:15:10 6495 C SUBROUTINE SJjCOi(A,b,c,N,th) C IMPLICIT REAL*8(A-H,o-Z) IMPLICIT INTEGER(I-N) dimension a(N,*),b(n,*),c(n,*) C C * SEGACT ,IPK1*MOD C do 200 j=1,n-1 do 250 i=j+1,n CF1=SQRT (ABS(A(i,j)**2/(A(i,i)*A(j,j)))) CF2=SQRT (ABS(b(i,j)**2/(b(i,i)*b(j,j)))) IF((CF1.GT.TH).OR.(CF2.GT.TH)) THEN XKBII=A(I,I)*B(I,J)-B(I,I)*A(I,J) XKBJJ=A(J,J)*B(I,J)-B(J,J)*A(I,J) XKB=A(I,I)*B(J,J)-B(I,I)*A(J,J) IF (XKB.NE.0.D0) THEN X=XKB/2+(XKB/ABS(XKB))*SQRT(ABS((XKB/2)**2+XKBII*XKBJJ)) ELSE X=SQRT(XKBII*XKBJJ) ENDIF * bp (septembre 2009): on ajoute le cas ou X = 0 IF (X.NE.0.D0) THEN GAMMA=-XKBII/X ALPHA=XKBJJ/X ELSE GAMMA=-(A(I,J)/A(J,J)) ALPHA=0.D0 ENDIF DO 100 L=1,N C xK1= A(I,L) xK2=A(J,L) A(I,L)=xK1+GAMMA*xK2 A(J,L)=ALPHA*xK1+xK2 C 100 CONTINUE C DO 150 L=1,N xK1=A(L,I) xK2=A(L,J) A(L,I)=xK1+GAMMA*xK2 A(L,J)=ALPHA*xK1+xK2 150 CONTINUE DO 101 L=1,N C xK1= b(I,L) xK2=b(J,L) b(I,L)=xK1+GAMMA*xK2 b(J,L)=ALPHA*xK1+xK2 C 101 CONTINUE C DO 151 L=1,N xK1=b(L,I) xK2=b(L,J) b(L,I)=xK1+GAMMA*xK2 b(L,J)=ALPHA*xK1+xK2 151 CONTINUE DO 102 L=1,N xK1=c(L,I) xK2=c(L,J) c(L,I)=xK1+GAMMA*xK2 c(L,J)=ALPHA*xK1+xK2 102 CONTINUE endif 250 continue 200 continue * SEGDES ,IPK1 RETURN END