Télécharger jaucau.eso

Retour à la liste

Numérotation des lignes :

  1. C JAUCAU SOURCE AM 18/06/06 21:15:01 9834
  2.  
  3. SUBROUTINE JAUCAU (NBNN,tab1,Ncoele,NBPTEL,SHPTOT,XE1,XE2,
  4. & SHPWRK,tab,MWRK6,LHOOK,
  5. & KCAS,mwrk5,LADIM,mele,iipdpg)
  6.  
  7. implicit real*8(a-h,o-z)
  8. implicit integer (i-n)
  9.  
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13.  
  14. SEGMENT MWRK5
  15. REAL*8 BGR(NGRA,LRE),BB(2,NGRA),gradi(ngra),R(ngra),u(ngra)
  16. REAL*8 TENS(9),tentra(9),xddls2(lre)
  17. ENDSEGMENT
  18. *
  19. SEGMENT MWRK6
  20. INTEGER ITRES1(NBPTEL)
  21. REAL*8 PRODDI(NBPTEL,LHOO2),PRODDO(NBPTEL,LHOO2)
  22. REAL*8 DDHOOK(LHOOK,LHOOK),DDHOMU(LHOOK,LHOOK)
  23. REAL*8 VEC(LHOOK),VEC2(LHOOK)
  24. ENDSEGMENT
  25. *
  26. dimension xe1(3,*),xe2(3,*)
  27. dimension shpwrk(6,*),shptot(6,NBNN,*)
  28. dimension tab(nbptel,*),tab1(nbptel,*)
  29. DIMENSION IDD(3),RM(6,6),SM(6,6)
  30.  
  31. C
  32. PARAMETER (RAC2 = 1.414213562373090 D0)
  33. C
  34. DATA IDD/2,3,1/
  35. C
  36. xxzero=0.d0
  37. if (kcas.eq.2) then
  38. xxr=2.0d0
  39. uxr=0.5d0
  40. else
  41. xxr=1.d0
  42. uxr=1.D0
  43. endif
  44.  
  45. C
  46. C MISE A ZERO DES CONTRAINTES OU DES DEFORMATIONS
  47. C
  48. DO 50 IB=1,NCOELE
  49. DO 50 IA=1,NBPTEL
  50. TAB(IA,IB)=0.D0
  51. 50 CONTINUE
  52. DO i = 1, 9
  53. TENS(i) = xxZero
  54. ENDDO
  55.  
  56. ngra=gradi(/1)
  57. lre=xddls2(/1)
  58. NHRM=NIFOUR
  59.  
  60. C Calcul de l'increment de deplacement
  61. ia=0
  62. do iou=1,NBNN
  63. do iyu=1, idim
  64. ia=ia+1
  65. xddls2(ia)= XE2(iyu,iou) - xe1(iyu,iou)
  66. enddo
  67. enddo
  68. C - MODES DE CALCUL EN DEFORMATIONS "PLANES" GENERALISEES
  69. IF (IDIM.EQ.3) THEN
  70. C RIEN FAIRE !
  71. C CAS 2D :
  72. ELSE IF (IDIM.EQ.2) THEN
  73. CC CAS 2D PLAN DEFO GENE
  74. C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(3,1) (cf. PIOCAP)
  75. IF (IFOUR.EQ.-3) THEN
  76. IA = IA + 1
  77. xddls2(ia)= XE2(3,1)
  78. ENDIF
  79. C CAS 1D :
  80. ELSE IF (IDIM.EQ.1) THEN
  81. CCC CAS 1D PLAN
  82. IF (IFOUR.GE.3 .AND. IFOUR.LE.11) THEN
  83. C Rq : "Deplacement" UY du PTGENE est stocke dans XE2(2,1) (cf. PIOCAP)
  84. IF (IFOUR.EQ.7 .OR. IFOUR.EQ.8 .OR. IFOUR.EQ.11) THEN
  85. IA = IA + 1
  86. xddls2(ia)= XE2(2,1)
  87. ENDIF
  88. C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(3,1) (cf. PIOCAP)
  89. c* IF (IFOUR.EQ.9 .OR. IFOUR.EQ.10 .OR. IFOUR.EQ.11) THEN
  90. IF (IFOUR.GE.9) THEN
  91. IA = IA + 1
  92. xddls2(ia)= XE2(3,1)
  93. ENDIF
  94. CCC CAS 1D AXIS
  95. C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(2,1) (cf. PIOCAP)
  96. ELSE IF (IFOUR.EQ.14) THEN
  97. IA = IA + 1
  98. xddls2(ia)= XE2(2,1)
  99. ENDIF
  100. ENDIF
  101.  
  102. C Boucle sur les points d'intergration de l'element :
  103. do 51 igau=1,nbptel
  104.  
  105. C Calcul du gradient du deplacment
  106. CALL BGRMAS(iGau,mele,nbnn,LRE,IFOUR,NGRA,NHRM,XE1,
  107. & xXZero,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  108. CALL BGRDEP(BGR,NGRA,XDDLs2,LRE,GRADI)
  109.  
  110. C Calcul de F
  111. IF (LADIM.EQ.3) THEN
  112. gradi(1)=gradi(1)+1.D0
  113. gradi(5)=gradi(5)+1.D0
  114. gradi(9)=gradi(9)+1.D0
  115. C* ELSE if (LADIM.EQ.2) then
  116. ELSE
  117. gradi(1)=gradi(1)+1.D0
  118. gradi(4)=gradi(4)+1.D0
  119. ENDIF
  120.  
  121. CALL POLA2(gradi,R,U,LADIM)
  122.  
  123. *
  124. GO TO (500,500,700),KCAS
  125. *
  126. *
  127. * KCAS=1 OU 2 CAS DES CONTRAINTES OU DES DEFORMATIONS
  128. * ----------------------------------------------------
  129. *
  130. 500 CONTINUE
  131.  
  132. * fait le rtens R.A.Rt on utilise u pour mettre Rt
  133. * et on met le tenseur dans le tableau tens
  134. * attention, vu le stockage R est en fait Rt
  135. if (LAdim.eq.2) then
  136. U(1)=r(1)
  137. u(2)=r(3)
  138. U(3)=R(2)
  139. u(4)=R(4)
  140. tens(1)=tab1(igau,1)
  141. tens(2)=tab1(igau,4)*uxr
  142. tens(3)=tens(2)
  143. tens(4)=tab1(igau,2)
  144. c* else if (LAdim.eq.3) then
  145. else
  146. U(1)=r(1)
  147. u(2)=r(4)
  148. U(3)=R(7)
  149. u(4)=R(2)
  150. u(5)=r(5)
  151. u(6)=r(8)
  152. u(7)=r(3)
  153. u(8)=r(6)
  154. u(9)=r(9)
  155. tens(1)=tab1(igau,1)
  156. tens(5)=tab1(igau,2)
  157. tens(9)=tab1(igau,3)
  158. IF (IFOUR.EQ.1.OR.IFOUR.EQ.2) THEN
  159. tens(2)=tab1(igau,4)*uxr
  160. tens(3)=tab1(igau,5)*uxr
  161. tens(4)=tens(2)
  162. tens(6)=tab1(igau,6)*uxr
  163. tens(7)=tens(3)
  164. tens(8)=tens(6)
  165. ELSE IF (IFOUR.LE.0) THEN
  166. c* ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3
  167. c* & IFOUR.EQ.-1) THEN
  168. tens(2)=tab1(igau,4)*uxr
  169. * tens(3)=xxzero
  170. tens(4)=tens(2)
  171. * tens(6)=xxzero
  172. * tens(7)=tens(3)
  173. * tens(8)=tens(6)
  174. * tens(9)=tab1(igau,3)=xxzero pour IFOUR=-1
  175. * Modes de calcul 1D
  176. c ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  177. * tens(2)=xxzero
  178. * tens(3)=xxzero
  179. * tens(4)=tens(2)
  180. * tens(6)=xxzero
  181. * tens(7)=tens(3)
  182. * tens(8)=tens(6)
  183. ELSE
  184. CALL ERREUR(19)
  185. RETURN
  186. ENDIF
  187. endif
  188. CALL MULMAT(tentra,tens,R,LADIM,LADIM,LADIM)
  189. CALL MULMAT(tens,U,Tentra,LADIM,LADIM,LADIM)
  190. if(ladim.eq.2) then
  191. tab(igau,1)=tens(1)
  192. tab(igau,2)=tens(4)
  193. tab(igau,4)=tens(2)*xxr
  194. tab(igau,3)=tab1(igau,3)
  195. else
  196. tab(igau,1)=tens(1)
  197. tab(igau,2)=tens(5)
  198. tab(igau,3)=tens(9)
  199. IF (IFOUR.EQ.1.OR.IFOUR.EQ.2) THEN
  200. tab(igau,4)=tens(2)*xxr
  201. tab(igau,5)=tens(3)*xxr
  202. tab(igau,6)=tens(6)*xxr
  203. ELSE IF (IFOUR.LE.0) THEN
  204. c* ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3
  205. c* & IFOUR.EQ.-1) THEN
  206. tab(igau,4)=tens(2)*xxr
  207. * Modes de calcul 1D
  208. c* ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  209. ENDIF
  210. endif
  211. *
  212. GO TO 130
  213.  
  214. C
  215. C KCAS=3 CAS DE LA MATRICE DE HOOKE
  216. C ----------------------------------
  217. C
  218. 700 CONTINUE
  219. C
  220. IJ=1
  221. FACJ=1.
  222. DO 710 JJ=1,LHOOK
  223. IF(JJ.GT.3) FACJ=RAC2
  224. DO 710 II=1,LHOOK
  225. IF(II.GT.3) THEN
  226. FACI=RAC2
  227. ELSE
  228. FACI=1.
  229. ENDIF
  230. DDHOOK(II,JJ)=PRODDI(IGAU,IJ)*FACJ*FACI
  231. IJ=IJ+1
  232. 710 CONTINUE
  233. *
  234. IF(LADIM.EQ.2) THEN
  235.  
  236. CALL ZERO(RM,6,6)
  237. DO I=1,LADIM
  238. IN=(I-1)*LADIM
  239. DO J=1,LADIM
  240. JJ =IN + J
  241. RM(I,J)=R(JJ)*R(JJ)
  242. ENDDO
  243. RM(I,4)=RAC2*R(2*I-1)*R(2*I)
  244. RM(4,I)=RAC2*R(I)*R(I+LADIM)
  245. ENDDO
  246. RM(3,3)=1.
  247. RM(4,4)=R(1)*R(4)+R(2)*R(3)
  248.  
  249. ELSE IF (LADIM.EQ.3) THEN
  250.  
  251. DO I=1,LADIM
  252. IN=(I-1)*LADIM
  253. IP=(IDD(I)-1)*LADIM
  254. DO J=1,LADIM
  255. JJ =IN + J
  256. J2 =IN + IDD(J)
  257. J3 =IP + J
  258. RM(I,J)=R(JJ)*R(JJ)
  259. RM(I,J+LADIM)=RAC2*R(JJ)*R(J2)
  260. RM(I+LADIM,J)=RAC2*R(JJ)*R(J3)
  261. RM(I+LADIM,J+LADIM)=R(JJ)*R(IDD(J)+IP)+R(IDD(J)+IN)*R(J3)
  262. ENDDO
  263. ENDDO
  264.  
  265. ENDIF
  266.  
  267. *
  268. DO I=1,LHOOK
  269. DO J=1,LHOOK
  270. SM(I,J)=0.
  271. DO K=1,LHOOK
  272. SM(I,J)=SM(I,J)+DDHOOK(I,K)*RM(K,J)
  273. ENDDO
  274. ENDDO
  275. ENDDO
  276. *
  277. DO I=1,LHOOK
  278. DO J=1,LHOOK
  279. DDHOMU(I,J)=0.
  280. DO K=1,LHOOK
  281. DDHOMU(I,J)=DDHOMU(I,J)+RM(K,I)*SM(K,J)
  282. ENDDO
  283. ENDDO
  284. ENDDO
  285. *
  286. IJ=1
  287. FACJ=1.
  288. DO 780 JJ=1,LHOOK
  289. IF(JJ.GT.3) FACJ=RAC2
  290. DO 780 II=1,LHOOK
  291. IF(II.GT.3) THEN
  292. FACI=RAC2
  293. ELSE
  294. FACI=1.
  295. ENDIF
  296. PRODDO(IGAU,IJ)=DDHOMU(II,JJ)/FACJ/FACI
  297. IJ=IJ+1
  298. 780 CONTINUE
  299. *
  300. *
  301. 130 CONTINUE
  302.  
  303. 51 CONTINUE
  304.  
  305. RETURN
  306. END
  307.  
  308.  
  309.  
  310.  

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