1 : C GAMT3 SOURCE CHAT 05/01/13 00:15:41 5004 2 : SUBROUTINE GAMT3(S,DS,R3,YUNG,GAMA,KERRE) 3 : C 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : -INC CCOPTIO 7 : C 8 : DIMENSION S(*),DS(*) 9 : RF=YUNG*YUNG*YUNG*1.D-24 10 : GAMRF=1.D-7 11 : C 12 : C*********************************************************************** 13 : C*********** CALCUL DES COEFICIENTS DE L EQUATION DU 3: DEGRE ********** 14 : C*********** AAA GAMA **3 + BBB GAMA **2 + CCC GAMA + DDD =0 *********** 15 : C*********************************************************************** 16 : C 17 : AA1=DS(1)*DS(2)*DS(3)+2.D0*DS(4)*DS(5)*DS(6) 18 : AA2=DS(1)*DS(5)*DS(5)+DS(2)*DS(6)*DS(6)+DS(3)*DS(4)*DS(4) 19 : AAA=AA1-AA2 20 : C 21 : BB1=DS(1)*DS(2)*R3+DS(2)*DS(3)*R3+DS(3)*DS(1)*R3 22 : BB2=DS(4)*DS(4)*R3+DS(5)*DS(5)*R3+DS(6)*DS(6)*R3 23 : BB3=S(1)*DS(5)*DS(5)+S(2)*DS(6)*DS(6)+S(3)*DS(4)*DS(4) 24 : BB4=S(1)*DS(2)*DS(3)+S(2)*DS(3)*DS(1)+S(3)*DS(1)*DS(2) 25 : BB5=S(4)*DS(5)*DS(6)+S(5)*DS(6)*DS(4)+S(6)*DS(4)*DS(5) 26 : BB6=S(4)*DS(4)*DS(3)+S(5)*DS(5)*DS(1)+S(6)*DS(6)*DS(2) 27 : BBB=-BB1+BB2-BB3+BB4+2.D0*BB5-2.D0*BB6 28 : C 29 : CC1=DS(1)*R3*R3+DS(2)*R3*R3+DS(3)*R3*R3 30 : CC2=S(1)*DS(2)*R3+S(2)*DS(3)*R3+S(3)*DS(1)*R3 31 : CC3=S(1)*DS(3)*R3+S(2)*DS(1)*R3+S(3)*DS(2)*R3 32 : CC4=S(4)*DS(4)*R3+S(5)*DS(5)*R3+S(6)*DS(6)*R3 33 : CC5=S(1)*S(2)*DS(3)+S(2)*S(3)*DS(1)+S(3)*S(1)*DS(2) 34 : CC6=S(4)*S(4)*DS(3)+S(5)*S(5)*DS(1)+S(6)*S(6)*DS(2) 35 : CC7=S(4)*S(5)*DS(6)+S(5)*S(6)*DS(4)+S(6)*S(4)*DS(5) 36 : CC8=S(1)*S(5)*DS(5)+S(2)*S(6)*DS(6)+S(3)*S(4)*DS(4) 37 : CCC=CC1-CC2-CC3+2.D0*CC4+CC5-CC6+2.D0*CC7-2.D0*CC8 38 : C 39 : DD1=-R3*R3*R3+S(1)*R3*R3+S(2)*R3*R3+S(3)*R3*R3 40 : DD2=S(4)*S(4)*R3+S(5)*S(5)*R3+S(6)*S(6)*R3 41 : DD3=S(1)*S(2)*R3+S(2)*S(3)*R3+S(3)*S(1)*R3 42 : DD4=S(1)*S(5)*S(5)+S(2)*S(6)*S(6)+S(3)*S(4)*S(4) 43 : DD5=S(1)*S(2)*S(3)+2.D0*S(4)*S(5)*S(6) 44 : DDD=DD1+DD2-DD3-DD4+DD5 45 : C 46 : IF(IIMPI.EQ.9) THEN 47 : WRITE(6,*) 'AA1',AA1 48 : WRITE(6,*) 'AA2',AA2 49 : WRITE(6,*) 'AAA',AAA 50 : WRITE(6,*) '***********************************************' 51 : C 52 : WRITE(6,*) 'BB1',BB1 53 : WRITE(6,*) 'BB2',BB2 54 : WRITE(6,*) 'BB3',BB3 55 : WRITE(6,*) 'BB4',BB4 56 : WRITE(6,*) 'BB5',BB5 57 : WRITE(6,*) 'BB6',BB6 58 : WRITE(6,*) 'BBB',BBB 59 : WRITE(6,*) '***********************************************' 60 : C 61 : WRITE(6,*) 'CC1',CC1 62 : WRITE(6,*) 'CC2',CC2 63 : WRITE(6,*) 'CC3',CC3 64 : WRITE(6,*) 'CC4',CC4 65 : WRITE(6,*) 'CC5',CC5 66 : WRITE(6,*) 'CC6',CC6 67 : WRITE(6,*) 'CC7',CC7 68 : WRITE(6,*) 'CC8',CC8 69 : WRITE(6,*) 'CCC',CCC 70 : WRITE(6,*) '***********************************************' 71 : C 72 : WRITE(6,*) 'DD1',DD1 73 : WRITE(6,*) 'DD2',DD2 74 : WRITE(6,*) 'DD3',DD3 75 : WRITE(6,*) 'DD4',DD4 76 : WRITE(6,*) 'DD5',DD5 77 : WRITE(6,*) 'DDD',DDD 78 : WRITE(6,*) '***********************************************' 79 : C 80 : ENDIF 81 : C 82 : IF(ABS(AAA).LT.RF) AAA=0.D0 83 : IF(ABS(BBB).LT.RF) BBB=0.D0 84 : IF(ABS(CCC).LT.RF) CCC=0.D0 85 : IF(ABS(DDD).LT.RF) DDD=0.D0 86 : C 87 : C*********************************************************************** 88 : C******* CALCUL DES RACINES REELLES DE L EQUATION DU 3: DEGRE ********** 89 : C*********************************************************************** 90 : C 90 : CALL RSEQ3D (AAA,BBB,CCC,DDD,YUNG,X1,X2,X3,KERRE) 91 : IF(KERRE.NE.0) RETURN 92 : C 93 : C*********************************************************************** 94 : C************** LA PLUS PETITE VALEUR DE GAMMA POSITIVE **************** 95 : C*********************************************************************** 96 : C 97 : IF(ABS(X1).LE.GAMRF) X1=0.D0 98 : IF(ABS(X2).LE.GAMRF) X2=0.D0 99 : IF(ABS(X3).LE.GAMRF) X3=0.D0 100 : IF(X1.LT.0.D0) X1=1.D0 101 : IF(X2.LT.0.D0) X2=1.D0 102 : IF(X3.LT.0.D0) X3=1.D0 103 : GAMA=MIN(X1,X2,X3) 104 : C 105 : RETURN 106 : END 107 :
© Cast3M 2003 - All rights reserved.
Disclaimer