C VECT SOURCE CB215821 17/11/30 21:17:25 9639 SUBROUTINE VECT(TENS,VAL,VP,P,S,TAMP) C====================================================================== C C SOUS PROGRAMME DE CALCUL C POUR C TENSEUR DE DEFORMATION C C VERSION 1.0 C ----------- C C C CALCUL DE : C C 1- Valeurs et vecteurs propres C 2- Tenseur Q C C====================================================================== C C CREATION : F.CORMERY C E.N.S.M.A - LMPM C JUILLET 1993 C C====================================================================== IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C********************************************************************** C DIMENSIONS ET DATA C********************************************************************** C CC DIMENSION TENS(6),VP(3) C N9 N15 CC * ,P(3,3),S(6), C N24 CC * VAL(3,3),TAMP(3,3) C DIMENSION TENS(*),VP(*) * ,P(3,*),S(*), * VAL(3,*),TAMP(3,*) DATA ZERO/0.D0/,UN/1.D0/, * PRECIS/1.D-08/,DPRECS/1.D-08/ C---------------------------------------------------------------------- AMAX1(X,Y,Z,U,V,W)= MAX(X,Y,Z,U,V,W) C------------------ MT=10 C********************************************************************** C INITIALISATION C********************************************************************** * DO 5 J=1,6 * DO 6 K=1,6 * P(J,K)=ZERO * Q(J,K)=ZERO * QPLUS(J,K)=ZERO *6 CONTINUE 5 CONTINUE DO 55 J=1,3 DO 55 K=1,3 55 P(J,K)=ZERO C---------------------------------------------------------------------- C********************************************************************** C NORMALISATION DU TENSEUR A C********************************************************************** C C---------------------------------------------------------------------- C Trouver la valeur max de TENS(I) C---------------------------------------------------------------------- DO 3 I=1,6 S(I)=ABS(TENS(I)) 3 CONTINUE C-------------- TMAX=AMAX1(S(1),S(2),S(3),S(4),S(5),S(6)) IF(TMAX.EQ.0.D0)TMAX=UN C---------------------------------------------------------------------- C Normaliser a un la composante de TENS(I) la plus grande C---------------------------------------------------------------------- DO 4 I=1,6 TENS(I)=TENS(I)/TMAX IF(ABS(TENS(I)).LE.1E-15) TENS(I)=0.D0 4 CONTINUE C------------------------ cas axes principaux ------------------------- NN=0 DO 234 IV=4,6 IF(ABS(TENS(IV)).LE.1E-15) NN=NN+1 234 CONTINUE IF(NN.EQ.3)THEN VP(1)=TENS(1) VP(2)=TENS(2) VP(3)=TENS(3) DO 235 I=1,3 P(I,1)=0 P(I,2)=0 P(I,3)=0 P(I,I)=1 235 CONTINUE goto 98 ENDIF C*********************************************************************** C CALCUL DES VALEURS PROPRES C*********************************************************************** CALL VALPRP(TENS(1),TENS(2),TENS(3),TENS(6),TENS(4),TENS(5), * VP(1),VP(2),VP(3)) C*********************************************************************** C CALCUL DES VECTEURS PROPRES C*********************************************************************** IM=2 IF(ABS(VP(1)-VP(2)).LT.1E-8)THEN VP(1)=VP(3) VP(2)=VP(2) VP(3)=VP(2) IM=2 ENDIF IF(ABS(VP(1)-VP(3)).LT.1E-8)THEN VP(1)=VP(2) VP(2)=VP(3) IM=2 ENDIF IF(ABS(VP(2)-VP(3)).LT.1E-8)THEN IM=2 ENDIF C---------------------------------------------------------------------- IMM=0 C---------------------------------------------------------------------- DO 10 I=1,IM C------------------- SDET1=(TENS(2)-VP(I))*(TENS(3)-VP(I))-TENS(4)**2 SDET2=(TENS(1)-VP(I))*(TENS(3)-VP(I))-TENS(5)**2 SDET3=(TENS(1)-VP(I))*(TENS(2)-VP(I))-TENS(6)**2 SDET4=TENS(6)*(TENS(3)-VP(I))-TENS(4)*TENS(5) SDET5=-TENS(5)*(TENS(2)-VP(I))+TENS(6)*TENS(4) SDET6=TENS(4)*(TENS(1)-VP(I))-TENS(6)*TENS(5) C---------------------------------------------------------------------- C WRITE(10,*)'MINEURS :' C WRITE(10,*)SDET1,SDET2,SDET3,SDET4,SDET5,SDET6 C---------------------------------------------------------------------- IF (ABS(SDET1).GT.DPRECS) THEN P(I,1)=UN P(I,2)=((-TENS(6)*(TENS(3)-VP(I)))+TENS(4)*TENS(5))/SDET1 P(I,3)=((-TENS(5)*(TENS(2)-VP(I)))+TENS(4)*TENS(6))/SDET1 GOTO 96 C------------------- ENDIF IF (ABS(SDET2).GT.DPRECS) THEN P(I,2)=UN P(I,1)=((-TENS(6)*(TENS(3)-VP(I)))+TENS(4)*TENS(5))/SDET2 P(I,3)=((-TENS(4)*(TENS(1)-VP(I)))+TENS(5)*TENS(6))/SDET2 GOTO 96 C------------------- ENDIF IF (ABS(SDET3).GT.DPRECS) THEN P(I,3)=UN P(I,1)=((-TENS(5)*(TENS(2)-VP(I)))+TENS(4)*TENS(6))/SDET3 P(I,2)=((-TENS(4)*(TENS(1)-VP(I)))+TENS(5)*TENS(6))/SDET3 GOTO 96 C-------------------- ENDIF IF (ABS(SDET4).GT.DPRECS) THEN P(I,1)=UN P(I,2)=((-(TENS(3)-vp(i))*(TENS(1)-VP(I)))+TENS(5)**2)/SDET4 P(I,3)=((TENS(4)*(TENS(1)-VP(I)))-TENS(5)*TENS(6))/SDET4 GOTO 96 C-------------------- ENDIF IF (ABS(SDET5).GT.DPRECS) THEN P(I,1)=(-(tens(4)**2)+(tens(2)-vp(i)))/sdet5 P(I,2)=(-tens(6)*(tens(3)-vp(i))+tens(5)*tens(4))/sdet5 P(I,3)=1 GOTO 96 C-------------------- ENDIF IF (ABS(SDET6).GT.DPRECS) THEN P(I,3)=UN P(I,1)=((-TENS(5)*TENS(4))+(TENS(3)-vp(i))*TENS(6))/SDET6 P(I,2)=((-(TENS(3)-vp(i))*(TENS(1)-VP(I)))+TENS(5)**2)/SDET6 ENDIF C----------------------------------------------------------------------- SSDET1=TENS(1)-VP(I) SSDET2=TENS(2)-VP(I) SSDET3=TENS(3)-VP(I) C-------------------CAS PARTICULIERS------------------------------------ IF (ABS(SSDET1).LE.PRECIS) THEN P(I,1)=1 P(I,2)=0 P(I,3)=0 GOTO 96 ENDIF IF (ABS(SSDET2).LE.PRECIS) THEN P(I,1)=0 P(I,2)=1 P(I,3)=0 GOTO 96 ENDIF IF (ABS(SSDET3).LE.PRECIS) THEN P(I,1)=0 P(I,2)=0 P(I,3)=1 GOTO 96 ENDIF IF (ABS(SSDET1).GT.PRECIS) THEN P(I,1)=-(TENS(6)+TENS(5))/SSDET1 P(I,2)=1 P(I,3)=1 C------------------- GOTO 96 ENDIF IF (ABS(SSDET2).GT.PRECIS) THEN P(I,1)=1 P(I,2)=-(TENS(6)+TENS(4))/SSDET2 P(I,3)=1 GOTO 96 C------------------- ENDIF IF (ABS(SSDET3).GT.PRECIS) THEN P(I,1)=1 P(I,2)=1 P(I,3)=-(TENS(5)+TENS(4))/SSDET3 GOTO 96 ENDIF C----------------------------------------------------------------------- WRITE(MT,*)'ERREUR DANS VPROP.FOR' WRITE(MT,1010) 1010 FORMAT(1X,'TENSEUR A SYM. D ORDRE 2 :', * /1X,'--------------------------'/) WRITE(MT,1001)TENS(1),TENS(6),TENS(5) 1001 FORMAT(15X,'* ',3e20.7,' *') WRITE(MT,1002)TENS(6),TENS(2),TENS(4) 1002 FORMAT(15X,'* ',3e20.7,' *') WRITE(MT,1003)TENS(5),TENS(4),TENS(3) 1003 FORMAT(15X,'* ',3e20.7,' *'/) STOP C----------------------------------------------------------------------- 96 CONTINUE C----------------------------------------------------------------------- 10 CONTINUE 98 CONTINUE IF(IM.EQ.2)THEN P(3,1)=P(1,2)*P(2,3)-P(1,3)*P(2,2) P(3,2)=P(1,3)*P(2,1)-P(1,1)*P(2,3) P(3,3)=P(1,1)*P(2,2)-P(1,2)*P(2,1) ENDIF C------------------------------------------------------------------------ C On verifie que la base formee est bien directe C------------------------------------------------------------------------ DIR=P(3,1)*(P(1,2)*P(2,3)-P(1,3)*P(2,2))+ * P(3,2)*(P(1,3)*P(2,1)-P(1,1)*P(2,3))+ * P(3,3)*(P(1,1)*P(2,2)-P(1,2)*P(2,1)) IF(DIR.LT.ZERO)THEN DO 12 J=1,3 TAMP1=VP(2) VP(2)=VP(1) VP(1)=TAMP1 TAMP(1,J)=P(1,J) P(1,J)=P(2,J) P(2,J)=TAMP(1,J) 12 CONTINUE ENDIF C------------------------------------------------------------------------ C Normalisation des vecteurs propres C------------------------------------------------------------------------ DO 11 J=1,5 DO 11 I=1,3 IF(ABS(P(I,1)).LT.1.E-15)P(I,1)=0.D0 IF(ABS(P(I,2)).LT.1.E-15)P(I,2)=0.D0 IF(ABS(P(I,3)).LT.1.E-15)P(I,3)=0.D0 RAC=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) P(I,1)=P(I,1)/RAC P(I,2)=P(I,2)/RAC P(I,3)=P(I,3)/RAC 11 CONTINUE C----------------------------------------------------------------------- C Multiplication par le facteur de normalisation C----------------------------------------------------------------------- DO 110 I=1,6 TENS(I)=TENS(I)*TMAX 110 CONTINUE C----------------------------------------------------------------------- DO 341 I=1,3 DO 341 J=1,3 VAL(I,J)=P(I,J) 341 CONTINUE DO 342 I=1,3 VP(I)=VP(I)*tmax 342 CONTINUE C------------------------------------------------------------------------- RETURN END C-----------------------------------------------------------------------