Sources Esope | Cast3M

sjjcoi
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