Télécharger epsln2.eso

Retour à la liste

Numérotation des lignes :

  1. C EPSLN2 SOURCE FANDEUR 12/03/15 21:24:18 7312
  2.  
  3. SUBROUTINE EPSLN2(F,EPS,N)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. -INC CCOPTIO
  9.  
  10. DIMENSION F(*),EPS(*)
  11. DIMENSION C(3,3),S(3,3),D(3)
  12. *
  13. * Affichage du gradient de la transformation
  14. *
  15. IF (IIMPI.EQ.199) THEN
  16. WRITE(IOIMP,7771) N
  17. 7771 FORMAT(2X,'EPSLN2 - N=',I3/)
  18. N2=N*N
  19. WRITE(IOIMP,7772) (F(I),I=1,N2)
  20. 7772 FORMAT(2X,'F '/(3(1X,1PE12.5)))
  21. ENDIF
  22. *
  23. * REMPLISSAGE DE C = Ftrans.F
  24. *
  25. CALL ZERO(C,3,3)
  26. DO 1 I=1,N
  27. DO 1 J=1,N
  28. r_z=0.D0
  29. DO K=0,N-1
  30. KN=K*N
  31. r_z=r_z+F(KN+I)*F(KN+J)
  32. ENDDO
  33. C(I,J)=r_z
  34. 1 CONTINUE
  35. *
  36. IF (IIMPI.EQ.199) THEN
  37. WRITE(IOIMP,7702) ((C(I,J),J=1,N),I=1,N)
  38. ENDIF
  39. *
  40. * PETITE VERIFICATION DE LA SYMETRIE DE C
  41. *
  42. TOL=1.D-10
  43. DO 11 I=2,N
  44. DO 11 J=1,I-1
  45. IF(ABS(C(I,J)-C(J,I)).GE.TOL) THEN
  46. CALL ERREUR(26)
  47. RETURN
  48. ENDIF
  49. 11 CONTINUE
  50.  
  51. C*AV DO I=1,N
  52. C*AV C(I,I)=C(I,I) - 1.D0
  53. C*AV ENDDO
  54. *
  55. * Calcul des valeurs propres de C et des vecteurs propres
  56. *
  57. NLOC = N
  58. C* En modes 2D PLAN ou 2D AXI, on travaille sur une matrice 2x2 mais
  59. C* on verifie la nullite des termes en C(3,i), i = 1 a 2
  60. IF (IFOUR.LE.0) THEN
  61. IF (N.EQ.3) THEN
  62. NLOC = 2
  63. IF (ABS(C(3,1)+C(1,3)).GE.TOL) THEN
  64. CALL ERREUR(26)
  65. RETURN
  66. ELSE IF (ABS(C(3,2)+C(2,3)).GE.TOL) THEN
  67. CALL ERREUR(26)
  68. RETURN
  69. ENDIF
  70. ENDIF
  71. ENDIF
  72.  
  73. CALL JACOB3(C,NLOC,D,S)
  74.  
  75. IF (IIMPI.EQ.199) THEN
  76. WRITE(IOIMP,7701) (D(K),K=1,N)
  77. ENDIF
  78. *
  79. * Calcul de ln(U) = 1/2 ln(C) (valeurs propres)
  80. *
  81. DO 2 I=1,N
  82. D(I) = 0.5D0*LOG(D(I))
  83. C*AV D(I) = 0.5D0*LOG(1.D0+D(I))
  84. 2 CONTINUE
  85. *
  86. DO 3 I=1,N
  87. DO 3 J=1,N
  88. r_z=0.D0
  89. DO 31 K=1,N
  90. r_z = r_z + S(I,K)*D(K)*S(J,K)
  91. 31 CONTINUE
  92. C(I,J)=r_z
  93. 3 CONTINUE
  94. *
  95. IF(IIMPI.EQ.199) THEN
  96. WRITE(IOIMP,7701) (D(K),K=1,N)
  97. 7701 FORMAT(2X,' D '/(6(1X,1PE12.5)))
  98. WRITE(IOIMP,7702) ((C(I,J),J=1,N),I=1,N)
  99. 7702 FORMAT(2X,' C '/(3(1X,1PE12.5)))
  100. ENDIF
  101. *
  102. * RANGEMENT DANS EPS
  103. *
  104. IF (N.EQ.2) THEN
  105. EPS(1)=C(1,1)
  106. EPS(2)=C(2,2)
  107. EPS(3)=C(2,1)+C(1,2)
  108. EPS(4)=0.D0
  109. EPS(5)=0.D0
  110. EPS(6)=0.D0
  111. *
  112. ELSE IF (N.EQ.3) THEN
  113. *
  114. IF (IFOUR.EQ.1.OR.IFOUR.EQ.2) THEN
  115. EPS(1)=C(1,1)
  116. EPS(2)=C(2,2)
  117. EPS(3)=C(3,3)
  118. EPS(4)=C(2,1)+C(1,2)
  119. EPS(5)=C(3,1)+C(1,3)
  120. EPS(6)=C(3,2)+C(2,3)
  121. ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3) THEN
  122. EPS(1)=C(1,1)
  123. EPS(2)=C(2,2)
  124. EPS(3)=C(3,3)
  125. EPS(4)=C(2,1)+C(1,2)
  126. EPS(5)=0.D0
  127. EPS(6)=0.D0
  128. ELSE IF (IFOUR.EQ.-1) THEN
  129. IF (ABS(C(3,3)).GE.TOL) THEN
  130. CALL ERREUR(26)
  131. RETURN
  132. ENDIF
  133. EPS(1)=C(1,1)
  134. EPS(2)=C(2,2)
  135. EPS(3)=0.D0
  136. EPS(4)=C(2,1)+C(1,2)
  137. EPS(5)=0.D0
  138. EPS(6)=0.D0
  139. * Modes de calcul 1D
  140. ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  141. EPS(1)=C(1,1)
  142. IF (IFOUR.EQ.3) THEN
  143. IF (ABS(C(2,2)).GE.TOL.OR.ABS(C(3,3)).GE.TOL) THEN
  144. CALL ERREUR(26)
  145. RETURN
  146. ENDIF
  147. EPS(2)=0.D0
  148. EPS(3)=0.D0
  149. ELSE IF (IFOUR.EQ.5.OR.IFOUR.EQ.7) THEN
  150. IF (ABS(C(3,3)).GE.TOL) THEN
  151. CALL ERREUR(26)
  152. RETURN
  153. ENDIF
  154. EPS(2)=C(2,2)
  155. EPS(3)=0.D0
  156. ELSE IF (IFOUR.EQ.4.OR.IFOUR.EQ.9.OR.IFOUR.EQ.12) THEN
  157. IF (ABS(C(2,2)).GE.TOL) THEN
  158. CALL ERREUR(26)
  159. RETURN
  160. ENDIF
  161. EPS(2)=0.D0
  162. EPS(3)=C(3,3)
  163. ELSE
  164. EPS(2)=C(2,2)
  165. EPS(3)=C(3,3)
  166. ENDIF
  167. EPS(4)=0.D0
  168. EPS(5)=0.D0
  169. EPS(6)=0.D0
  170. ELSE
  171. CALL ERREUR(19)
  172. ENDIF
  173. *
  174. ELSE
  175. CALL ERREUR(19)
  176. ENDIF
  177. *
  178. IF (IIMPI.EQ.199) THEN
  179. WRITE(IOIMP,7730) (EPS(K),K=1,6)
  180. 7730 FORMAT(2X,'EPSLN2- EPS '/(3(1X,1PE12.5)))
  181. ENDIF
  182. *
  183. RETURN
  184. END
  185.  
  186.  
  187.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales