Télécharger epsi2.eso

Retour à la liste

Numérotation des lignes :

  1. C EPSI2 SOURCE CB215821 19/07/30 21:16:03 10273
  2.  
  3. SUBROUTINE EPSI2(IPMAIL,IPMINT,MELE,IELE,
  4. & IVADEP,NBPTEL,LRE,NSTRS,LHOOK,
  5. & MFR,NDEP,IPORE,IREPS2,NBPGAU,IVAEPS,UZDPG,RYDPG,RXDPG,IIPDPG,
  6. & IDERI,ivamat,ivade2,mate,nmatt,cmate,ngra,noer,kerr)
  7.  
  8. C---------------------------------------------------------------------*
  9. C
  10. C calcul des deformations
  11. C
  12. C massif, poreux, joints poreux, incompressibles
  13. C---------------------------------------------------------------------*
  14. C *
  15. C entrees : *
  16. C ________ *
  17. C *
  18. C ipmail pointeur sur un segment meleme *
  19. C ipmint pointeur sur un segment minte *
  20. C mele numero de l'element fini *
  21. C iele numero geometrique de l'element *
  22. C nbpgau nombre de point d'integration pour la rigidite *
  23. C ivadep pointeur sur le chamelem de deplacements *
  24. C nbptel nombre de points par element *
  25. C lre nombre de ddl dans la matrice de rigidite *
  26. C nstrs nombre de composante de contraintes/deformations *
  27. C pour une matrice de hooke *
  28. C lhook dimension de la matrice de hooke *
  29. C mfr numero de la formulation de l'element fini *
  30. C ndep nombre de composantes de deplacements *
  31. C ipore nombre de fonctions de forme *
  32. C iresp2 flag pour indiquer si on veut les contraintes *
  33. C de piola-kirchhoff *
  34. C uzdpg = deformation au point nsdpge support de la *
  35. C rydpf = deformation plane generalisee *
  36. C rxdpg = *
  37. C *
  38. C sorties : *
  39. C ________ *
  40. C *
  41. C ivaeps pointeur sur un segment mptval contenant les *
  42. C les melvals de deformations *
  43. C---------------------------------------------------------------------*
  44. C Pour MEMOIRE : Si MELE element incompressible alors MFR = 31
  45. C---------------------------------------------------------------------*
  46.  
  47. IMPLICIT INTEGER(I-N)
  48. IMPLICIT REAL*8(A-H,O-Z)
  49.  
  50. -INC CCOPTIO
  51. -INC CCREEL
  52. -INC CCHAMP
  53. -INC CCGEOME
  54. -INC SMCHAML
  55. -INC SMCHPOI
  56. -INC SMELEME
  57. -INC SMCOORD
  58. -INC SMMODEL
  59. -INC SMINTE
  60. -INC SMLREEL
  61.  
  62. SEGMENT WRK1
  63. REAL*8 DDHOOK(NSTRS,NSTRS),XDDL(LRE),XSTRS(NSTRS)
  64. REAL*8 XE(3,NBBB),DDHOMU(NSTRS,NSTRS)
  65. REAL*8 SHPWRK(6,NBNO),BGENE(LHOOK,LRE)
  66. REAL*8 XE1(3,NBBB),XE2(3,NBBB),xstrs2(NSTRS)
  67. REAL*8 xjac(3,3),valmat(20)
  68. ENDSEGMENT
  69. SEGMENT WRK2
  70. REAL*8 BGR(NGRA,LRE),BB(2,NGRA),gradi(ngra),R(ngra),u(ngra)
  71. REAL*8 TENS(9),tentra(9),xddls2(lre)
  72. ENDSEGMENT
  73. C
  74. SEGMENT WRK3
  75. REAL*8 BPSS(3,3),XEL(3,NBBB)
  76. REAL*8 XNTH(LPP,LPP),XNTB(LPP,LPP),XNTT(LPP)
  77. ENDSEGMENT
  78. C
  79. SEGMENT WRK5
  80. REAL*8 XGENE(NSTN,LRN)
  81. ENDSEGMENT
  82. C
  83. SEGMENT NOTYPE
  84. CHARACTER*16 TYPE(NBTYPE)
  85. ENDSEGMENT
  86. C
  87. SEGMENT MPTVAL
  88. INTEGER IPOS(NS),NSOF(NS)
  89. INTEGER IVAL(NCOSOU)
  90. CHARACTER*16 TYVAL(NCOSOU)
  91. ENDSEGMENT
  92. C
  93. SEGMENT MTRACE
  94. REAL*8 TRACE(NBPTEL)
  95. ENDSEGMENT
  96.  
  97. CHARACTER*(NCONCH) CONM
  98. PARAMETER (NINF=3)
  99. DIMENSION A(4,60),BBX(3,60),UDPGE(3)
  100. INTEGER INFOS(NINF)
  101. CHARACTER*8 CMATE
  102.  
  103.  
  104. DIMENSION IN(6),JN(6),ITAB(3,3),PP(4,4)
  105. C
  106. DATA IN/1,2,3,1,1,2/
  107. DATA JN/1,2,3,2,3,3/
  108. C
  109. DATA ITAB(1,1),ITAB(1,2),ITAB(1,3)/1,4,5/
  110. DATA ITAB(2,1),ITAB(2,2),ITAB(2,3)/4,2,6/
  111. DATA ITAB(3,1),ITAB(3,2),ITAB(3,3)/5,6,3/
  112. C
  113.  
  114. kerr=0
  115. C Introduction du point autour duquel se fait le mouvement
  116. C de la section en defo plane generalisee
  117. C IIPDPG = numero du noeud/point support si defini pour le modele
  118. C NDPGE > 0 si prise en compte du point support
  119. IF (IIPDPG.GT.0) THEN
  120. IF (IFOUR.EQ.-3) THEN
  121. NDPGE=3
  122. UDPGE(1)=UZDPG
  123. UDPGE(2)=RYDPG
  124. UDPGE(3)=RXDPG
  125. C SEGACT,MCOORD
  126. IREF=(IIPDPG-1)*(IDIM+1)
  127. XDPGE=XCOOR(IREF+1)
  128. YDPGE=XCOOR(IREF+2)
  129. ELSE IF (IFOUR.EQ.11) THEN
  130. NDPGE=2
  131. UDPGE(1)=UZDPG
  132. UDPGE(2)=RXDPG
  133. UDPGE(3)=XZero
  134. XDPGE=XZero
  135. YDPGE=XZero
  136. ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR.
  137. & IFOUR.EQ.10 .OR. IFOUR.EQ.14) THEN
  138. NDPGE=1
  139. UDPGE(1)=UZDPG
  140. UDPGE(2)=XZero
  141. UDPGE(3)=XZero
  142. XDPGE=XZero
  143. YDPGE=XZero
  144. else
  145. write(ioimp,*) 'EPSI2 : ERREUR NDPGE'
  146. call erreur(5)
  147. return
  148. ENDIF
  149. ELSE
  150. NDPGE=0
  151. UDPGE(1)=UZDPG
  152. UDPGE(2)=XZero
  153. UDPGE(3)=XZero
  154. XDPGE=XZero
  155. YDPGE=XZero
  156. ENDIF
  157. C
  158.  
  159. MELEME=IPMAIL
  160. NBNN=NUM(/1)
  161. NBELEM=NUM(/2)
  162. C
  163. NHRM=NIFOUR
  164. MINTE=IPMINT
  165. NBBB=NBNN
  166. C
  167. C_______________________________________________________________________
  168. C
  169. C numero des etiquettes :
  170. C etiquettes de 1 a 98 pour traitement specifique a l element
  171. C dans la zone specifique a chaque element commencant par :
  172. C 5 continue
  173. C element 5 etiquettes 1005 2005 3005 4005 ...
  174. C 44 continue
  175. C element 44 etiquettes 1044 2044 3044 4044 ...
  176. C_______________________________________________________________________
  177. C
  178. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  179. 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  180. 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  181. 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,79,79,
  182. 4 79,79,79,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  183. 5 99,99,99,99,99,99,99,80,80,80, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  184. 6 4, 4),MELE
  185. C
  186. IF (MELE.EQ.183.OR.MELE.EQ.184.OR.
  187. . MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
  188. IF (MELE.GE.173.AND.MELE.LE.182) GOTO 173
  189. IF (MELE.GE.185.AND.MELE.LE.190) GOTO 185
  190. IF (MELE.EQ.273.OR.MELE.EQ.274) GOTO 4
  191. C
  192. GOTO 99
  193.  
  194. C_______________________________________________________________________
  195. C
  196. C elements massifs et elements incompressibles MECANIQUE
  197. C_______________________________________________________________________
  198. C
  199. 4 CONTINUE
  200. IF (MFR.EQ.71 .OR. MFR.EQ.73) GOTO 97173
  201. IF( ideri.le.2.or.ideri.eq.5 ) then
  202. C ideri le 2 est pour lineaire et quadratique et =5 pour utlisateur
  203.  
  204. C Elements massifs en FORMULATION 'MECANIQUE'
  205. C -------------------------------------------
  206. NBNO=NBNN
  207. NDDD=NDEP-NDPGE
  208. C
  209. C Donnees liees a l'element de reference
  210. C
  211. SEGACT MINTE
  212. C
  213. SEGINI,WRK1
  214. IF (Ideri.eq.2) SEGINI,MTRACE
  215. C
  216. C boucle sur les elements
  217. C
  218. DO 3004 IB=1,NBELEM
  219. C
  220. C on cherche les deplacements
  221. C
  222. MPTVAL=IVADEP
  223. IE=1
  224. DO 4004 IGAU=1,NBNN
  225. DO 4004 ICOMP=1,NDDD
  226. MELVAL=IVAL(ICOMP)
  227. IGMN=MIN(IGAU,VELCHE(/1))
  228. IBMN=MIN(IB ,VELCHE(/2))
  229. XDDL(IE)=VELCHE(IGMN,IBMN)
  230. IE=IE+1
  231. 4004 CONTINUE
  232. IF (NDPGE.GT.0) THEN
  233. DO i=1,NDPGE
  234. XDDL(IE)=UDPGE(i)
  235. IE=IE+1
  236. ENDDO
  237. ENDIF
  238. C
  239. C on cherche les coordonnees des noeuds de l element ib
  240. C
  241. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  242. if( ideri.eq.5) then
  243. C on se emet à mi-pas
  244. do iou=1,idim
  245. do iyu=1,nbnn
  246. XE(iou,iyu)= xe(iou,iyu) + xddl( iou+ (iyu-1)*nddd)/2.D0
  247. enddo
  248. enddo
  249. endif
  250. C
  251. C boucle sur les points de gauss
  252. C
  253. ISDJC=0
  254. C
  255. DO 5004 IGAU=1,NBPTEL
  256. C
  257. C
  258. C Calcul des coeff de modification de b-barre (elts incompres)
  259. C
  260. IF (MFR.EQ.31.and.igau.eq.1) THEN
  261. C= NOM : ICT3, ICQ4, ICT6, ICQ8, ICC8, ICT4, ICP6, IC20, IC10, IC15
  262. C= MELE : 69 , 70 , 71 , 72 , 73 , 74 , 75 , 76 , 77 , 78
  263. CALL BBCAL2(IB,IGAU,IDIM,NBPGAU,IVACAR,
  264. 1 POIGAU,QSIGAU,ETAGAU,DZEGAU,MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,
  265. 2 A,BBX,XE,SHPTOT,SHPWRK,BGENE,XDPGE,YDPGE,PP)
  266. ENDIF
  267. C
  268. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  269. 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,1.D0,XE,
  270. 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  271.  
  272. IF (DJAC.EQ.0.D0) THEN
  273. INTERR(1)=IB
  274. if (noer.eq.0) CALL ERREUR(259)
  275. kerr=259
  276. GOTO 9904
  277. ENDIF
  278. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  279.  
  280. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  281. IF (MFR.EQ.31) THEN
  282. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  283. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BBX,BGENE)
  284. ENDIF
  285. C
  286. CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  287. C
  288. C calcul des eps 2
  289. C
  290. IF (Ideri.eq.2)
  291. & CALL BST2(SHPWRK,XDDL,XE,NBNO,IFOUR,XSTRS,TRACE,
  292. & IGAU,XDPGE,YDPGE,UDPGE,NHRM)
  293. C
  294. C remplissage du segment contenant les deformations
  295. C
  296. MPTVAL=IVAEPS
  297. DO 7004 ICOMP=1,NSTRS
  298. MELVAL=IVAL(ICOMP)
  299. IBMN=MIN(IB,VELCHE(/2))
  300. VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  301. 7004 CONTINUE
  302. C
  303. 5004 CONTINUE
  304. C
  305. C fin de la boucle sur les points de gauss
  306. C
  307. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  308. if (noer.eq.1) then
  309. kerr=195
  310. else
  311. INTERR(1)=IB
  312. CALL ERREUR(195)
  313. endif
  314. GOTO 9904
  315. ENDIF
  316. C
  317. C correction sur la partie quadratique de la deformation dans le cas
  318. C des elements incompressibles
  319. C
  320. IF (Ideri.eq.2) THEN
  321. IF (MFR.EQ.31) THEN
  322. CALL BBST2(TRACE,NBPTEL,IFOUR,MELE,POIGAU,QSIGAU,
  323. & ETAGAU,DZEGAU,SHPTOT,NBNO,SHPWRK,XE,PP)
  324. L=2
  325. IF (IDIM.EQ.3 .OR. IFOUR.EQ.0) L=3
  326. DO 5005 ICOMP=1,L
  327. MELVAL=IVAL(ICOMP)
  328. IBMN=MIN(IB ,VELCHE(/2))
  329. DO 5006 IGAU=1,NBPTEL
  330. VELCHE(IGAU,IBMN)=VELCHE(IGAU,IBMN)+TRACE(IGAU)
  331. 5006 CONTINUE
  332. 5005 CONTINUE
  333. ENDIF
  334. ENDIF
  335.  
  336. 3004 CONTINUE
  337.  
  338. C
  339. C fin de la boucle sur les elements
  340. C
  341. 9904 CONTINUE
  342. SEGSUP WRK1
  343. IF (IREPS2.EQ.1) SEGSUP MTRACE
  344.  
  345. C cas de la dérivée de Truesdell
  346. elseif( ideri.eq.3) then
  347. NBNO=NBNN
  348. NDDD=NDEP-NDPGE
  349. SEGACT MINTE
  350. SEGINI,WRK1
  351. C IF (IREPS2.EQ.1) SEGINI,MTRACE
  352. C
  353. C boucle sur les elements
  354. C
  355. DO 34 IB=1,NBELEM
  356. C
  357. C on cherche les deplacements
  358. C
  359. MPTVAL=IVADEP
  360. IE=1
  361. DO 44 IGAU=1,NBNN
  362. DO 44 ICOMP=1,NDDD
  363. MELVAL=IVAL(ICOMP)
  364. IGMN=MIN(IGAU,VELCHE(/1))
  365. IBMN=MIN(IB ,VELCHE(/2))
  366. XDDL(IE)=VELCHE(IGMN,IBMN)
  367. IE=IE+1
  368. 44 CONTINUE
  369. IF (NDPGE.GT.0) THEN
  370. DO i=1,NDPGE
  371. XDDL(IE)=UDPGE(i)
  372. IE=IE+1
  373. ENDDO
  374. ENDIF
  375. C on cherche le max des variations des champs pour savoir s'il faut
  376. C appeler hookis plusieurs fois
  377. C
  378. nbgmat=0
  379. nelmat=0
  380. mptval=ivamat
  381. segact mptval
  382. DO IM=1,NMATT
  383. IF (IVAL(IM).NE.0) THEN
  384. MELVAL=IVAL(IM)
  385. nelmat=Max(nelmat ,VELCHE(/2))
  386. nbgmat=Max(nbgmat,VELCHE(/1))
  387. ENDIF
  388. ENDDO
  389. C
  390. C on cherche les coordonnees des noeuds de l element ib
  391. C
  392. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  393. C on ajoute aux coordonnées la moitié du deplacements pour faire
  394. C la configuration à mi-pas
  395. do iou=1,idim
  396. do iyu=1,nbnn
  397. XE(iou,iyu)= xe(iou,iyu) + xddl( iou+ (iyu-1)*nddd)/2.D0
  398. enddo
  399. enddo
  400. C
  401. C boucle sur les points de gauss
  402. C
  403. ISDJC=0
  404. C
  405.  
  406. DO 54 IGAU=1,NBPTEL
  407. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  408. 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,1.D0,XE,
  409. 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  410.  
  411. C
  412. IF (DJAC.EQ.0.D0) THEN
  413. INTERR(1)=IB
  414. if (noer.eq.0) CALL ERREUR(259)
  415. kerr=259
  416. GOTO 994
  417. ELSE IF (DJAC.LT.0.D0) THEN
  418. ISDJC=ISDJC+1
  419. ENDIF
  420. C
  421. C on cherche les matrices de Hooke
  422. C
  423. mptval=ivamat
  424. segact mptval
  425. DO 94 IM=1,NMATT
  426. IF (IVAL(IM).NE.0) THEN
  427. MELVAL=IVAL(IM)
  428. IBMN=MIN(IB ,VELCHE(/2))
  429. IGMN=MIN(IGAU,VELCHE(/1))
  430.  
  431. VALMAT(IM)=VELCHE(IGMN,IBMN)
  432. ELSE
  433. VALMAT(IM)=0.D0
  434. ENDIF
  435. 94 CONTINUE
  436. kcas=2
  437. if(nbgmat+nelmat.gt.2 . or . ib+igau.eq.2) then
  438. CALL HOOKIS(VALMAT,VALCAR,VAR,MFR,IB,IGAU,EXCEN,EPAIST,
  439. + INAT,MELE,NPINT,IFOUR,KCAS,NBGMAT,Nelmat,
  440. + S,SECT,LHOOK,DDHOMU,DDHOOK,
  441. + COBMA,XMOB,IRETOU)
  442. endif
  443. do iou=1,nstrs
  444. do iyu=1,nstrs
  445. ddhomu(iyu,iou)=ddhook(iyu,iou)
  446. enddo
  447. enddo
  448.  
  449. CALL DBST(BGENE,DDHomu,XDDL,LRE,NSTRS,XSTRS)
  450. C xstrs contient la contrainte on va faire pica xstrs zdep05
  451. DO 220 INO=1,NBNN
  452. DO 220 ID=1,IDIM
  453. XE1(ID,INO)=XE(ID,INO)
  454. XE2(ID,INO)=XE(ID,INO)-xddl( id+ (ino-1)*nddd)/2.D0
  455. 220 CONTINUE
  456. DO iou=1,3
  457. DO IYU=1,3
  458. XJAC(iou,iyu)=0.D0
  459. enddo
  460. enddo
  461. CALL ZERO(XJAC,3,3)
  462. CALL HPRIME(XE1,NBNN,IDIM,SHPtot,IGAU,SHpwrk,DJAC)
  463. C
  464. C CALCUL DE LA MATRICE F
  465. C
  466. DO 140 ID=1,NBNN
  467. DO 140 IE=1,IDIM
  468. DO 140 IF=1,IDIM
  469. XJAC(IE,IF)=SHpwrk(IF+1,ID)*XE2(IE,ID)+XJAC(IE,IF)
  470. 140 CONTINUE
  471. IF(IDIM.EQ.2) THEN
  472. XJAC(3,3)=1.D0
  473. IF(IFOUR.EQ.0) THEN
  474. C
  475. CC CAS AXISYMETRIQUE
  476. C
  477. R1=0.D0
  478. R2=0.D0
  479. DO 150 ID=1,NBNN
  480. R1=R1+SHpwrk(1,ID)*XE1(1,ID)
  481. R2=R2+SHpwrk(1,ID)*XE2(1,ID)
  482. 150 CONTINUE
  483. XJAC(3,3)=R2/(R1+1.D-20)
  484. ENDIF
  485. ENDIF
  486. CC CALCUL DE DETERMINANT DE F
  487. C
  488. IF(IDIM.EQ.2) THEN
  489. DETF=XJAC(1,1)*XJAC(2,2)-XJAC(1,2)*XJAC(2,1)
  490. DETF = DETF * XJAC (3,3)
  491. ENDIF
  492. IF(IDIM.EQ.3) THEN
  493. DETF=XJAC(1,1)*(XJAC(2,2)*XJAC(3,3)-XJAC(3,2)*XJAC(2,3))
  494. DETF=DETF-XJAC(2,1)*(XJAC(1,2)*XJAC(3,3)-XJAC(3,2)*XJAC(1,3))
  495. DETF=DETF+XJAC(3,1)*(XJAC(1,2)*XJAC(2,3)-XJAC(1,3)*XJAC(2,2))
  496. ENDIF
  497. DETF=1.D0/(DETF+1.D-20)
  498. C
  499. C CALCUL DES CONTRAINTES DE CAUCHY
  500. C
  501. DO 160 ID=1,NSTRS
  502. IND=IN(ID)
  503. JND=JN(ID)
  504. xstrs2(ID)=0.D0
  505. DO 170 IE=1,IDIM
  506. DO 170 IF=1,IDIM
  507. ICO=ITAB(IE,IF)
  508. XsTRS2(ID)=XsTRS(ICO)*XJAC(IND,IE)*XJAC(JND,IF)*DETF
  509. 1 +xstrs2(ID)
  510. 170 CONTINUE
  511. 160 CONTINUE
  512.  
  513. C
  514. C PEGON : ON NE FAIT PAS LA TRANSFORMATION SUR LA 3-EME COMPOSANTE
  515. C
  516. IF(IDIM.EQ.2) THEN
  517. xstrs2(3)=xstrs(3)*XJAC(3,3)*XJAC(3,3)*DETF
  518. ENDIF
  519. C fin du caldul de capi dans dans xstrs2 la contrainte de kirchoff
  520. C on continu en calculant epsi sur config initiale
  521. DO 221 INO=1,NBNN
  522. DO 221 ID=1,IDIM
  523. XE(ID,INO)=XE2(ID,INO)+xddl( id+ (ino-1)*nddd)/2.D0
  524. 221 CONTINUE
  525. C inversion loi de hook
  526. CALL INVALM(DDHOMU,LHOOK,LHOOK,KERRE,0.D0)
  527. DO 6000 I=1,LHOOK
  528. xstrs(I)=0.D0
  529. DO 60001 J=1,LHOOK
  530. xstrs(I)=xstrs(I)+DDHOMU(I,J)*xstrs2(J)
  531. 60001 CONTINUE
  532. 6000 CONTINUE
  533. C
  534. C remplissage du segment contenant les deformations
  535. C
  536. MPTVAL=IVAEPS
  537. DO 74 ICOMP=1,NSTRS
  538. MELVAL=IVAL(ICOMP)
  539. IBMN=MIN(IB,VELCHE(/2))
  540. VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  541. 74 CONTINUE
  542. 54 continue
  543.  
  544. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  545. if (noer.eq.1) then
  546. kerr=195
  547. else
  548. INTERR(1)=IB
  549. CALL ERREUR(195)
  550. GOTO 994
  551. endif
  552. ENDIF
  553. 34 CONTINUE
  554. 994 CONTINUE
  555. SEGSUP WRK1
  556. C fin du truesdell
  557. C debut du jaumann
  558. elseif(ideri.eq.4) then
  559. C==========================
  560. NBNO=NBNN
  561. C* NDDD=NDEP
  562. C* IF (IFOUR.EQ.-3) NDDD=NDEP-3
  563. NDDD=NDEP-NDPGE
  564. C
  565. C Donnees liees a l'element de reference
  566. C
  567. SEGACT MINTE
  568. C
  569. SEGINI,WRK1
  570. SEGINI,MTRACE
  571. segini wrk2
  572.  
  573. C boucle sur les elements
  574. C
  575. DO 394 IB=1,NBELEM
  576. C
  577. C on cherche les deplacements
  578. C
  579. MPTVAL=IVADEP
  580. IE=1
  581. DO 494 IGAU=1,NBNN
  582. DO 494 ICOMP=1,NDDD
  583. MELVAL=IVAL(ICOMP)
  584. IGMN=MIN(IGAU,VELCHE(/1))
  585. IBMN=MIN(IB ,VELCHE(/2))
  586. XDDL(IE)=VELCHE(IGMN,IBMN)
  587. IE=IE+1
  588. 494 CONTINUE
  589. IF (NDPGE.GT.0) THEN
  590. DO i=1,NDPGE
  591. XDDL(IE)=UDPGE(i)
  592. IE=IE+1
  593. ENDDO
  594. ENDIF
  595. C
  596. C on cherche les coordonnees des noeuds de l element ib
  597. C
  598. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  599. C
  600. C on se met sur la config à mi pas (XE) xe1 est la config initiale
  601. C
  602. do iou=1,idim
  603. do iyu=1,nbnn
  604. XE1(iou,iyu)= xe(iou,iyu)
  605. XE(iou,iyu)= xe(iou,iyu) + xddl( iou+ (iyu-1)*nddd)/2.D0
  606. enddo
  607. enddo
  608. C
  609. C boucle sur les points de gauss
  610. C
  611. ISDJC=0
  612. C
  613. DO 594 IGAU=1,NBPTEL
  614. C
  615. C
  616. C Calcul des coeff de modification de b-barre (elts incompres)
  617. C
  618. IF (MFR.EQ.31.and.igau.eq.1) THEN
  619. C= NOM : ICT3, ICQ4, ICT6, ICQ8, ICC8, ICT4, ICP6, IC20, IC10, IC15
  620. C= MELE : 69 , 70 , 71 , 72 , 73 , 74 , 75 , 76 , 77 , 78
  621. CALL BBCAL2(IB,IGAU,IDIM,NBPGAU,IVACAR,
  622. 1 POIGAU,QSIGAU,ETAGAU,DZEGAU,MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,
  623. 2 A,BBX,XE,SHPTOT,SHPWRK,BGENE,XDPGE,YDPGE,PP)
  624. ENDIF
  625. C
  626. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  627. 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,1.D0,XE,
  628. 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  629.  
  630. IF (DJAC.EQ.0.D0) THEN
  631. INTERR(1)=IB
  632. if (noer.eq.0) CALL ERREUR(259)
  633. kerr=259
  634. GOTO 9964
  635. ENDIF
  636. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  637.  
  638. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  639. IF (MFR.EQ.31) THEN
  640. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  641. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BBX,BGENE)
  642. ENDIF
  643. C
  644. CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  645. C dans xstrs on a les deformations II sur config mi pas
  646. C on va calculer grad u/2 puis decomposition polaire puis rtens
  647. C on retravaille sur config initiale
  648. xxzero=XZero
  649. iipdpg=0
  650. CALL BGRMAS(iGau,NOELE,NBNO,LRE,IFOUR,NGRA,NIFOUR,XE1,
  651. . xxzero,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  652. do iou=1,lre
  653. xddls2(iou)= 0.5D0 * xddl(iou)
  654. enddo
  655. CALL BGRDEP(BGR,NGRA,XDDLs2,LRE,GRADI)
  656. C on ajoute l'identité au gradient
  657. if(idim.eQ.2) then
  658. gradi(1)=gradi(1)+1.D0
  659. gradi(4)=gradi(4)+1.D0
  660. ELSE IF(IDIM.EQ.3) THEN
  661. gradi(1)=gradi(1)+1.D0
  662. gradi(5)=gradi(5)+1.D0
  663. gradi(9)=gradi(9)+1.D0
  664. ENDIF
  665.  
  666. CALL POLA2(gradi,R,U,IDIM)
  667. C fait le rtens Rt.A.R on utilise u pour mettre Rt
  668. C et on met le tenseur dans le tableau tens
  669. C attention vu le stockage R est en fait Rt
  670. if(idim.eq.2) then
  671. U(1)=r(1)
  672. u(2)=r(3)
  673. U(3)=R(2)
  674. u(4)=R(4)
  675. tens(1)=xstrs(1)
  676. tens(2)=xstrs(4)/2.d0
  677. tens(3)=xstrs(4)/2.D0
  678. tens(4)=xstrs(2)
  679.  
  680. elseif(idim.eq.3) then
  681. U(1)=r(1)
  682. u(2)=r(4)
  683. U(3)=R(7)
  684. u(4)=R(2)
  685. u(5)=r(5)
  686. u(6)=r(8)
  687. u(7)=r(3)
  688. u(8)=r(6)
  689. u(9)=r(9)
  690. tens(1)=xstrs(1)
  691. tens(2)=xstrs(4)/2.D0
  692. tens(3)=xstrs(5)/2.D0
  693. tens(4)=tens(2)
  694. tens(5)=xstrs(2)
  695. tens(6)=xstrs(6)/2.D0
  696. tens(7)=tens(3)
  697. tens(8)=tens(6)
  698. tens(9)=xstrs(3)
  699. else
  700. write(6,*)' idim est ni 2 ni 3 stop'
  701. stop
  702. endif
  703.  
  704. CALL MULMAT(tentra,tens,U,IDIM,IDIM,IDIM)
  705. CALL MULMAT(tens,R,Tentra,IDIM,IDIM,IDIM)
  706. C tens contient le nouveau tenseur on va remplir xstrs
  707. C en 2 D epzz ne change pas
  708. if(idim.eq.2) then
  709. xstrs(1)=tens(1)
  710. xstrs(2)=tens(4)
  711. xstrs(4)=tens(2)*2.D0
  712. else
  713. xstrs(1)=tens(1)
  714. xstrs(2)=tens(5)
  715. xstrs(3)=tens(9)
  716. xstrs(4)=tens(2)*2.D0
  717. xstrs(5)=tens(3)*2.D0
  718. xstrs(6)=tens(6)*2.D0
  719. endif
  720.  
  721. C
  722. C remplissage du segment contenant les deformations
  723. C
  724. MPTVAL=IVAEPS
  725. DO 794 ICOMP=1,NSTRS
  726. MELVAL=IVAL(ICOMP)
  727. IBMN=MIN(IB,VELCHE(/2))
  728. VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  729. 794 CONTINUE
  730. C
  731. 594 CONTINUE
  732. C
  733. C fin de la boucle sur les points de gauss
  734. C
  735. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  736. INTERR(1)=IB
  737. if (noer.eq.1) then
  738. kerr=195
  739. else
  740. CALL ERREUR(195)
  741. GOTO 9964
  742. endif
  743. ENDIF
  744.  
  745. 394 CONTINUE
  746.  
  747. C
  748. C fin de la boucle sur les elements
  749. C
  750. 9964 CONTINUE
  751. SEGSUP WRK1,wrk2,MTRACE
  752. endif
  753. C
  754. GOTO 510
  755.  
  756. C Elements massifs en FORMULATIONs 'ELECTROSTATIQUE' et 'DIFFUSION'
  757. C -----------------------------------------------------------------
  758. 97173 CONTINUE
  759. SEGACT,MINTE
  760. NBNO = NBNN
  761. NDDD = NDEP
  762. SEGINI,WRK1
  763. C-------------------------
  764. C Boucle sur les elements
  765. C-------------------------
  766. DO IEL = 1, NBELEM
  767. C - Recuperation des coordonnees des noeuds de l element IEL
  768. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  769. C - Recuperation des inconnues primales aux noeuds de l element IEL
  770. MPTVAL = IVADEP
  771. IE = 1
  772. DO IGAU = 1, NBNN
  773. DO ICOMP = 1, NDDD
  774. MELVAL = IVAL(ICOMP)
  775. IGMN = MIN(IGAU,VELCHE(/1))
  776. IEMN = MIN(IEL ,VELCHE(/2))
  777. XDDL(IE) = VELCHE(IGMN,IEMN)
  778. IE = IE+1
  779. ENDDO
  780. ENDDO
  781. C-- -- -- -- -- -- -- -- --
  782. C - Boucle sur les points de Gauss
  783. C-- -- -- -- -- -- -- -- --
  784. ISDJC=0
  785. DO IGAU = 1, NBPTEL
  786. C -- Calcul de la matrice B et du jacobien au point de Gauss IGAU
  787. IF (MFR.EQ.71) THEN
  788. CALL BELEC(XE,SHPTOT(1,1,IGAU),NBNN,LHOOK,-1,
  789. & SHPWRK,BGENE,DJAC)
  790. ELSE IF (MFR.EQ.73) THEN
  791. CALL BDIFF(XE,SHPTOT(1,1,IGAU),NBNN,LHOOK,-1,
  792. & SHPWRK,BGENE,DJAC)
  793. ENDIF
  794. IF (DJAC.EQ.0.D0) THEN
  795. INTERR(1) = IEL
  796. if (noer.eq.0) CALL ERREUR(259)
  797. kerr=259
  798. GOTO 98173
  799. ENDIF
  800. IF (DJAC.LT.0.D0) ISDJC = ISDJC+1
  801. CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  802. C -- Remplissage du segment contenant les "deformations" = -grad(.)
  803. MPTVAL = IVAEPS
  804. DO ICOMP = 1, NSTRS
  805. MELVAL = IVAL(ICOMP)
  806. IEMN = MIN(IEL,VELCHE(/2))
  807. VELCHE(IGAU,IEMN) = XSTRS(ICOMP)
  808. ENDDO
  809. C-- -- -- -- -- -- -- -- --
  810. ENDDO
  811. C-- -- -- -- -- -- -- -- --
  812. IF (ISDJC.NE.0 .AND. ISDJC.NE.NBPGAU) THEN
  813. INTERR(1) = IEL
  814. if (noer.eq.1) then
  815. kerr=195
  816. else
  817. CALL ERREUR(195)
  818. GOTO 98173
  819. endif
  820. ENDIF
  821. C-------------------------
  822. ENDDO
  823. C-------------------------
  824. 98173 CONTINUE
  825. SEGSUP,WRK1
  826. GOTO 510
  827.  
  828. C_______________________________________________________________________
  829. C
  830. C milieux poreux
  831. C_______________________________________________________________________
  832. C
  833. 79 CONTINUE
  834. C
  835. C pour ces elements nbbb = nombre de noeuds
  836. C nbno = nombre de fonctions de forme
  837. C
  838. NBNO=IPORE
  839. NSTN=1
  840. LRN=NBNO-NBBB
  841. LRB=LRE-LRN
  842. C
  843. SEGINI WRK1,WRK5
  844. C Initialisation de MTRACE necessaire mais inutilise pour ces elements
  845. IF (IREPS2.EQ.1) SEGINI MTRACE
  846. C
  847. DO 3079 IB=1,NBELEM
  848. C
  849. C on cherche les coordonnees des noeuds de l element ib
  850. C
  851. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  852. C
  853. C on cherche les deplacements
  854. C
  855. MPTVAL=IVADEP
  856. IE=1
  857. DO 4079 IGAU=1,NBNN
  858. DO 4079 ICOMP=1,NDEP-1
  859. MELVAL=IVAL(ICOMP)
  860. IGMN=MIN(IGAU,VELCHE(/1))
  861. IBMN=MIN(IB ,VELCHE(/2))
  862. XDDL(IE)=VELCHE(IGMN,IBMN)
  863. IE=IE+1
  864. 4079 CONTINUE
  865. C
  866. C puis les pressions
  867. C
  868. MELVAL=IVAL(NDEP)
  869. DO 4179 IGAU=1,LRN
  870. IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1)
  871. IGMN=MIN(IGAUSO,VELCHE(/1))
  872. IBMN=MIN(IB ,VELCHE(/2))
  873. XDDL(IE)=VELCHE(IGMN,IBMN)
  874. IE=IE+1
  875. 4179 CONTINUE
  876. C
  877. C boucle sur les points de gauss
  878. C
  879. ISDJC=0
  880. C
  881. DO 5079 IGAU=1,NBPTEL
  882. C
  883. CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  884. & 1.D0,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  885. C
  886. IF (DJAC.EQ.0.D0) THEN
  887. INTERR(1)=IB
  888. if (noer.eq.0) CALL ERREUR(259)
  889. kerr=259
  890. GOTO 9979
  891. ENDIF
  892. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  893. C
  894. CALL BST(BGENE,XDDL,LRE,LHOOK,XSTRS)
  895. C
  896. C calcul des eps 2
  897. C
  898. IF (IREPS2.EQ.1)
  899. & CALL BST2(SHPWRK,XDDL,XE,NBNN,IFOUR,XSTRS,TRACE,
  900. & IGAU,XDPGE,YDPGE,UDPGE,NHRM)
  901. C
  902. C calcul de la pression
  903. C
  904. XP=0.D0
  905. DO 4279 ID=1,LRN
  906. XP=XP+XGENE(1,ID)*XDDL(LRB+ID)
  907. 4279 CONTINUE
  908. XSTRS(NSTRS)=XP
  909. C
  910. C remplissage du segment contenant les deformations
  911. C
  912. MPTVAL=IVAEPS
  913. DO 7079 ICOMP=1,NSTRS
  914. MELVAL=IVAL(ICOMP)
  915. IGMN=MIN(IGAU,VELCHE(/1))
  916. IBMN=MIN(IB ,VELCHE(/2))
  917. VELCHE(IGMN,IBMN)=XSTRS(ICOMP)
  918. 7079 CONTINUE
  919. C
  920. 5079 CONTINUE
  921. C
  922. C fin de la boucle sur les points de gauss
  923. C
  924. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  925. INTERR(1)=IB
  926. if (noer.eq.1) then
  927. kerr=195
  928. else
  929. CALL ERREUR(195)
  930. GOTO 9979
  931. endif
  932. ENDIF
  933. C
  934. 3079 CONTINUE
  935. C
  936. C fin de la boucle sur les elements
  937. C
  938. 9979 CONTINUE
  939. SEGSUP WRK1,WRK5
  940. IF (IREPS2.EQ.1) SEGSUP MTRACE
  941. C
  942. GOTO 510
  943.  
  944. C_______________________________________________________________________
  945. C
  946. C milieux poreux - SUITE
  947. C_______________________________________________________________________
  948. C
  949. 173 CONTINUE
  950. C
  951. C pour ces elements nbbb = nombre de noeuds
  952. C nbno = nombre de fonctions de forme
  953. C
  954. IF (MELE.GE.173.AND.MELE.LE.177) THEN
  955. IDECAP = 2
  956. ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  957. IDECAP = 3
  958. ENDIF
  959. C
  960. NBNO=IPORE
  961. NSTN=IDECAP
  962. NSTB=4
  963. IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=6
  964. C
  965. LPP=NBNO-NBBB
  966. LRN=IDECAP*LPP
  967. LRB=LRE-LRN
  968. C
  969. SEGINI WRK1,WRK5
  970. C Initialise de MTRACE necessaire mais inutilise pour cet element
  971. IF (IREPS2.EQ.1) SEGINI MTRACE
  972. C
  973. DO 3173 IB=1,NBELEM
  974. C
  975. C on cherche les coordonnees des noeuds de l element ib
  976. C
  977. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  978. C
  979. C on cherche les deplacements
  980. C
  981. MPTVAL=IVADEP
  982. IE=1
  983. DO 4173 IGAU=1,NBNN
  984. DO 4173 ICOMP=1,NDEP-IDECAP
  985. MELVAL=IVAL(ICOMP)
  986. IGMN=MIN(IGAU,VELCHE(/1))
  987. IBMN=MIN(IB ,VELCHE(/2))
  988. XDDL(IE)=VELCHE(IGMN,IBMN)
  989. IE=IE+1
  990. 4173 CONTINUE
  991. C
  992. C puis les pressions
  993. C
  994. DO 4473 IPR = 1,IDECAP
  995. MELVAL=IVAL(NDEP-IDECAP+IPR)
  996. DO 4273 IGAU=1,LPP
  997. IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1)
  998. IGMN=MIN(IGAUSO,VELCHE(/1))
  999. IBMN=MIN(IB ,VELCHE(/2))
  1000. XDDL(IE)=VELCHE(IGMN,IBMN)
  1001. IE=IE+1
  1002. 4273 CONTINUE
  1003. 4473 CONTINUE
  1004. C
  1005. C boucle sur les points de gauss
  1006. C
  1007. ISDJC=0
  1008. C
  1009. DO 5173 IGAU=1,NBPTEL
  1010. C
  1011. CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  1012. & 1.D0,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  1013. C
  1014. IF (DJAC.EQ.0.D0) THEN
  1015. INTERR(1)=IB
  1016. if (noer.eq.0) CALL ERREUR(259)
  1017. kerr=259
  1018. GOTO 9173
  1019. ENDIF
  1020. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  1021. C
  1022. CALL BST(BGENE,XDDL,LRE,LHOOK,XSTRS)
  1023. C
  1024. C calcul des eps 2
  1025. C
  1026. IF (IREPS2.EQ.1)
  1027. & CALL BST2(SHPWRK,XDDL,XE,NBNN,IFOUR,XSTRS,TRACE,
  1028. & IGAU,XDPGE,YDPGE,UDPGE,NHRM)
  1029. C
  1030. C calcul des pressions
  1031. C
  1032. IE=LRB
  1033. DO 4673 IPR=1,IDECAP
  1034. XP=0.D0
  1035. IPR1=(IPR-1)*LPP
  1036. DO 4373 ID=1,LPP
  1037. IE=IE+1
  1038. XP=XP+XGENE(IPR,ID+IPR1)*XDDL(IE)
  1039. 4373 CONTINUE
  1040. XSTRS(NSTRS-IDECAP+IPR)=XP
  1041. 4673 CONTINUE
  1042. C
  1043. C remplissage du segment contenant les deformations
  1044. C
  1045. MPTVAL=IVAEPS
  1046. DO 7173 ICOMP=1,NSTRS
  1047. MELVAL=IVAL(ICOMP)
  1048. IGMN=MIN(IGAU,VELCHE(/1))
  1049. IBMN=MIN(IB ,VELCHE(/2))
  1050. VELCHE(IGMN,IBMN)=XSTRS(ICOMP)
  1051. 7173 CONTINUE
  1052. C
  1053. 5173 CONTINUE
  1054. C
  1055. C fin de la boucle sur les points de gauss
  1056. C
  1057. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1058. INTERR(1)=IB
  1059. if (noer.eq.1) then
  1060. kerr=195
  1061. else
  1062. CALL ERREUR(195)
  1063. GOTO 9173
  1064. endif
  1065. ENDIF
  1066. C
  1067. 3173 CONTINUE
  1068. C
  1069. C fin de la boucle sur les elements
  1070. C
  1071. 9173 CONTINUE
  1072. SEGSUP WRK1,WRK5
  1073. IF (IREPS2.EQ.1) SEGSUP MTRACE
  1074. C
  1075. GOTO 510
  1076.  
  1077. C_______________________________________________________________________
  1078. C
  1079. C joints poreux
  1080. C_______________________________________________________________________
  1081. C
  1082. 80 CONTINUE
  1083. C
  1084. C pour ces elements nbbb = nombre de noeuds
  1085. C nbno = nombre de fonctions de forme
  1086. C
  1087. NBNO=IPORE
  1088. NSTN=1
  1089. LRN=(NBNO-NBBB)*3/2
  1090. LPP = LRN
  1091. LRB=LRE-LRN
  1092. NFAC=(3*NBBB-NBNO)/2
  1093. C
  1094. SEGINI WRK1,WRK3,WRK5
  1095. C
  1096. DO 3080 IB=1,NBELEM
  1097. C
  1098. C on cherche d'abord les deplacements
  1099. C
  1100. MPTVAL=IVADEP
  1101. IE=1
  1102. DO 4180 IGAU=1,NFAC
  1103. DO 4280 ICOMP=1,NDEP-1
  1104. MELVAL=IVAL(ICOMP)
  1105. IGMN=MIN(IGAU,VELCHE(/1))
  1106. IBMN=MIN(IB ,VELCHE(/2))
  1107. XDDL(IE)=VELCHE(IGMN,IBMN)
  1108. IE=IE+1
  1109. 4280 CONTINUE
  1110. 4180 CONTINUE
  1111. C
  1112. C puis les pressions
  1113. C
  1114. MELVAL=IVAL(NDEP)
  1115. DO 4080 IGAU=1,NBNN
  1116. DO 4190 INSOM=1,NBSOM(IELE)
  1117. IF (IGAU.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 4191
  1118. 4190 CONTINUE
  1119. IF (IGAU.GT.NFAC) GO TO 4191
  1120. GO TO 4080
  1121. 4191 CONTINUE
  1122. IBMN=MIN(IB ,VELCHE(/2))
  1123. IGMN=MIN(IGAU,VELCHE(/1))
  1124. XDDL(IE)=VELCHE(IGMN,IBMN)
  1125. IE=IE+1
  1126. 4080 CONTINUE
  1127. C
  1128. C on cherche les coordonnees des noeuds de l element ib
  1129. C
  1130. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1131. C
  1132. C calcul des exes locaux et des coordonnees locales
  1133. C
  1134. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1135. C
  1136. CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE)
  1137. C
  1138. C boucle sur les points de gauss
  1139. C
  1140. ISDJC=0
  1141. C
  1142. DO 5080 IGAU=1,NBPTEL
  1143. C
  1144. CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1145. & SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  1146. C
  1147. IF (DJAC.EQ.0.D0) THEN
  1148. INTERR(1)=IB
  1149. if (noer.eq.0) CALL ERREUR(259)
  1150. kerr=259
  1151. GOTO 9980
  1152. ENDIF
  1153. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  1154. C
  1155. CALL BST(BGENE,XDDL,LRB,LHOOK,XSTRS)
  1156.  
  1157. C
  1158. C calcul de la pression
  1159. C
  1160. XP=0.D0
  1161. DO 4480 ID=1,LRN
  1162. XP=XP+XNTT(ID)*XGENE(1,ID)*XDDL(LRB+ID)
  1163. 4480 CONTINUE
  1164. XSTRS(NSTRS)=XP
  1165. C
  1166. C remplissage du segment contenant les deformations
  1167. C
  1168. MPTVAL=IVAEPS
  1169. DO 7080 ICOMP=1,NSTRS
  1170. MELVAL=IVAL(ICOMP)
  1171. IGMN=MIN(IGAU,VELCHE(/1))
  1172. IBMN=MIN(IB ,VELCHE(/2))
  1173. VELCHE(IGMN,IBMN)=XSTRS(ICOMP)
  1174. 7080 CONTINUE
  1175. C
  1176. 5080 CONTINUE
  1177. C
  1178. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1179. INTERR(1)=IB
  1180. if (noer.eq.1) then
  1181. kerr=195
  1182. else
  1183. CALL ERREUR(195)
  1184. GOTO 9980
  1185. endif
  1186. ENDIF
  1187. C
  1188. 3080 CONTINUE
  1189. C
  1190. 9980 CONTINUE
  1191. SEGSUP WRK1,WRK3,WRK5
  1192. C
  1193. GOTO 510
  1194.  
  1195.  
  1196. C_______________________________________________________________________
  1197. C
  1198. C joints poreux - SUITE
  1199. C_______________________________________________________________________
  1200. C
  1201. 185 CONTINUE
  1202. C
  1203. C pour ces elements nbbb = nombre de noeuds
  1204. C nbno = nombre de fonctions de forme
  1205. C
  1206. IF (MELE.GE.185.AND.MELE.LE.187) THEN
  1207. IDECAP = 2
  1208. ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  1209. IDECAP = 3
  1210. ENDIF
  1211.  
  1212. C
  1213. NBNO=IPORE
  1214. NSTN=IDECAP
  1215. NSTB=2
  1216. IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=3
  1217.  
  1218. C
  1219. LPP=(NBNO-NBBB)*3/2
  1220. LRN=IDECAP*LPP
  1221. LRB=LRE-LRN
  1222.  
  1223. NFAC=(3*NBBB-NBNO)/2
  1224. C
  1225. SEGINI WRK1,WRK3,WRK5
  1226. C
  1227. DO 3185 IB=1,NBELEM
  1228. C
  1229. C on cherche d'abord les deplacements
  1230. C
  1231. MPTVAL=IVADEP
  1232. IE=1
  1233. DO 4185 IGAU=1,NFAC
  1234. DO 4285 ICOMP=1,NDEP-IDECAP
  1235. MELVAL=IVAL(ICOMP)
  1236. IGMN=MIN(IGAU,VELCHE(/1))
  1237. IBMN=MIN(IB ,VELCHE(/2))
  1238. XDDL(IE)=VELCHE(IGMN,IBMN)
  1239. IE=IE+1
  1240. 4285 CONTINUE
  1241. 4185 CONTINUE
  1242. C
  1243. C puis les pressions
  1244. C
  1245. DO 4785 IPR=1,IDECAP
  1246. MELVAL=IVAL(NDEP-IDECAP+IPR)
  1247. DO 4085 IGAU=1,NBNN
  1248. DO 4195 INSOM=1,NBSOM(IELE)
  1249. IF (IGAU.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 4891
  1250. 4195 CONTINUE
  1251. IF (IGAU.GT.NFAC) GO TO 4891
  1252. GO TO 4085
  1253. 4891 CONTINUE
  1254. IBMN=MIN(IB ,VELCHE(/2))
  1255. IGMN=MIN(IGAU,VELCHE(/1))
  1256. XDDL(IE)=VELCHE(IGMN,IBMN)
  1257. IE=IE+1
  1258. 4085 CONTINUE
  1259. 4785 CONTINUE
  1260. C
  1261. C on cherche les coordonnees des noeuds de l element ib
  1262. C
  1263. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1264. C
  1265. C calcul des exes locaux et des coordonnees locales
  1266. C
  1267. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1268. C
  1269. CALL INTDEL(XNTH,XNTB,XNTT,LPP,MELE)
  1270. C
  1271. C boucle sur les points de gauss
  1272. C
  1273. ISDJC=0
  1274. C
  1275. DO 5185 IGAU=1,NBPTEL
  1276. C
  1277. CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1278. & SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  1279. C
  1280. IF (DJAC.EQ.0.D0) THEN
  1281. INTERR(1)=IB
  1282. if (noer.eq.0) CALL ERREUR(259)
  1283. kerr=259
  1284. GOTO 9985
  1285. ENDIF
  1286. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  1287. C
  1288. CALL BST(BGENE,XDDL,LRB,LHOOK,XSTRS)
  1289. C
  1290. C calcul de la pression
  1291. C
  1292. IE=LRB
  1293. DO 4985 IPR=1,IDECAP
  1294. XP=0.D0
  1295. IPR1=(IPR-1)*LPP
  1296. DO 4485 ID=1,LPP
  1297. IE=IE+1
  1298. XP=XP+XNTT(ID)*XGENE(IPR,ID+IPR1)*XDDL(IE)
  1299. 4485 CONTINUE
  1300. XSTRS(NSTRS-IDECAP+IPR)=XP
  1301. 4985 CONTINUE
  1302.  
  1303. C
  1304. C remplissage du segment contenant les deformations
  1305. C
  1306. MPTVAL=IVAEPS
  1307. DO 7185 ICOMP=1,NSTRS
  1308. MELVAL=IVAL(ICOMP)
  1309. IGMN=MIN(IGAU,VELCHE(/1))
  1310. IBMN=MIN(IB ,VELCHE(/2))
  1311. VELCHE(IGMN,IBMN)=XSTRS(ICOMP)
  1312. 7185 CONTINUE
  1313. C
  1314. 5185 CONTINUE
  1315. C
  1316. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1317. INTERR(1)=IB
  1318. if (noer.eq.1) then
  1319. kerr=195
  1320. else
  1321. CALL ERREUR(195)
  1322. GOTO 9985
  1323. endif
  1324. ENDIF
  1325. C
  1326. 3185 CONTINUE
  1327. C
  1328. 9985 CONTINUE
  1329. SEGSUP WRK1,WRK3,WRK5
  1330. C
  1331. GOTO 510
  1332.  
  1333. C____________________________________________________________________
  1334. 99 CONTINUE
  1335. MOTERR(1:4)=NOMTP(MELE)
  1336. MOTERR(9:12)='EPSI'
  1337. CALL ERREUR(86)
  1338.  
  1339. 510 CONTINUE
  1340. RETURN
  1341. END
  1342.  
  1343.  
  1344.  
  1345.  
  1346.  
  1347.  
  1348.  
  1349.  
  1350.  
  1351.  
  1352.  
  1353.  
  1354.  
  1355.  
  1356.  
  1357.  
  1358.  
  1359.  

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