Télécharger epsix.eso

Retour à la liste

Numérotation des lignes :

  1. C EPSIX SOURCE CB215821 19/08/20 21:17:08 10287
  2. subroutine EPSIX (IMODEL,IREPS2,IVADEP,IVAEPS,
  3. & UZDPG,RYDPG,RXDPG,IIPDPG,IRETER)
  4. c
  5. C PROCEDURE UTILISEE DANS LE CAS D'ELEMENTS XFEM
  6. c POUR LE CALCUL DE la deformation
  7. C
  8. C*********************************************************
  9. C PARTIE DECLARATIVE
  10. C*********************************************************
  11. C
  12. IMPLICIT REAL*8(A-H,O-Z)
  13. C
  14. PARAMETER (NDDLMAX=30,NBNIMAX=10)
  15. C
  16. PARAMETER (NBENRMAX=5)
  17. DIMENSION MLRE(NBENRMAX+1)
  18. C
  19. -INC CCOPTIO
  20. -INC SMCOORD
  21. -INC SMMODEL
  22. -INC SMCHAML
  23. -INC SMINTE
  24. -INC SMELEME
  25. -INC SMLREEL
  26. C
  27. POINTEUR MCHEX1.MCHELM,MINT1.MINTE,MINT2.MINTE
  28. C
  29. C Segment (type LISTENTI) contenant les informations sur un element
  30. SEGMENT INFO
  31. INTEGER INFELL(JG)
  32. ENDSEGMENT
  33. c
  34. SEGMENT WRK1
  35. REAL*8 XE(3,NBBB)
  36. REAL*8 XDDL(LRE),XSTRS(LHOOK)
  37. ENDSEGMENT
  38. c
  39. SEGMENT WRK2
  40. REAL*8 SHPWRK(6,NBNO),BGENE(LHOOK,LRE)
  41. c REAL*8 LV7WRK(NBENRMA2,2,6,NBNO)
  42. REAL*8 LV7WRK(NBENRMA2,2,6,NBBB)
  43. ENDSEGMENT
  44. C
  45. SEGMENT MPTVAL
  46. INTEGER IPOS(NS),NSOF(NS)
  47. INTEGER IVAL(NCOSOU)
  48. CHARACTER*16 TYVAL(NCOSOU)
  49. ENDSEGMENT
  50. C
  51. SEGMENT MRACC
  52. INTEGER TLREEL(NBENRMA2,NBI)
  53. ENDSEGMENT
  54. C
  55. SEGMENT MTRACE
  56. REAL*8 TRACE(NBPTEL)
  57. ENDSEGMENT
  58. DIMENSION UDPGE(3)
  59. C
  60. C write (*,*) '############################'
  61. C write (*,*) '##### DEBUT DE EPSIX #####'
  62. C write (*,*) '############################'
  63. C
  64. C*********************************************************
  65. c Introduction du point autour duquel se fait le mouvement
  66. c de la section en defo plane generalisee
  67. C*********************************************************
  68. C IIPDPG > 0 (argument) si noeud/point support defini dans le modele
  69. C NDPGE > 0 si besoin de calcul avec point support
  70. IF (IIPDPG.GT.0) THEN
  71. IF (IFOUR.EQ.-3) THEN
  72. NDPGE=3
  73. UDPGE(1)=UZDPG
  74. UDPGE(2)=RYDPG
  75. UDPGE(3)=RXDPG
  76. C SEGACT,MCOORD
  77. IREF=(IIPDPG-1)*(IDIM+1)
  78. XDPGE=XCOOR(IREF+1)
  79. YDPGE=XCOOR(IREF+2)
  80. C* ELSE IF (IFOUR.EQ.11) THEN
  81. C* NDPGE=2
  82. C* UDPGE(1)=UZDPG
  83. C* UDPGE(2)=RXDPG
  84. C* UDPGE(3)=0.D0
  85. C* XDPGE=0.D0
  86. C* YDPGE=0.D0
  87. C* ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR.
  88. C* & IFOUR.EQ.10 .OR. IFOUR.EQ.14) THEN
  89. C* NDPGE=1
  90. C* UDPGE(1)=UZDPG
  91. C* UDPGE(2)=0.D0
  92. C* UDPGE(3)=0.D0
  93. C* XDPGE=0.D0
  94. C* YDPGE=0.D0
  95. else
  96. write(ioimp,*) 'EPSI4 : erreur NDPGE'
  97. call erreur(5)
  98. return
  99. ENDIF
  100. ELSE
  101. NDPGE=0
  102. UDPGE(1)=0.D0
  103. UDPGE(2)=0.D0
  104. UDPGE(3)=0.D0
  105. XDPGE=0.D0
  106. YDPGE=0.D0
  107. ENDIF
  108. C
  109. C
  110. C*********************************************************
  111. c
  112. C RECUPERATION + ACTIVATIONS + VALEURS UTILES
  113. c
  114. C*********************************************************
  115. C SEGACT MMODEL,IMODEL deja activé dans epsi1
  116. c
  117. C++++ Activation au cas ou ++++++++++++++++++++++++++++++
  118. SEGACT MCOORD
  119.  
  120. C++++ Recup + Activation de la geometrie ++++++++++++++++
  121. MELEME= IMAMOD
  122. c SEGACT MELEME deja activé dans epsi1
  123.  
  124.  
  125. C++++ RECUP DES INFOS EF ++++++++++++++++++++++++++++++++
  126. c + OBTENUES PAR ELQUOI DANS RIGI1 PENDANT PHASE 1
  127. C segment INFO deja actif dans RIGI1
  128. c + rigi1 n appelle pas elquoi, c'est modeli qui l'a fait
  129. c mais du coup, on na pas de segment minte
  130. c (car depend de si pt de g pour rigi, pour sigma....)
  131. c c'est + simple de rappeler elquoi ici
  132. MELE = NEFMOD
  133. call elquoi(MELE,0,3,IPINF,IMODEL)
  134. INFO = IPINF
  135. c MELE = INFELL(1)
  136. c NBPGA2= INFELL(2)
  137. c NBPGAU= INFELL(3)
  138. c NBPGAU= INFELL(4)
  139. c ICARA = INFELL(5)
  140. NGAU1 = INFELL(6)
  141. c LW = INFELL(7)
  142. LRE = INFELL(9)
  143. LHOOK = INFELL(10)
  144. MINT1 = INFELL(11)
  145. segact,MINT1
  146. MINT2 = INFELL(12)
  147. if(MINT2.ne.0) segact,MINT2
  148. MFR = INFELL(13)
  149. IELE = INFELL(14)
  150. NDDL = INFELL(15)
  151. NSTRS = INFELL(16)
  152. c write(6,*)'-> EPSIX infell',(infell(iou),iou=1,16)
  153.  
  154. c + AUTRES INFOS
  155. C nbre de noeuds par element
  156. NBNN1 = NUM(/1)
  157. C nbre d elements
  158. NBEL1 = NUM(/2)
  159.  
  160. c REM: pour se passer du dimensionnement du nbre d'enrichissement dans
  161. c elquoi et le realiser localement , on pourrait ecrire:
  162. c LRE = NDDLMAX*NBNN1
  163. c NDDL= NDDLMAX
  164.  
  165. C sous decoupage et points de Gauss de l element geometrique de base
  166. if(MELE.eq.263.or.mele.eq.264) then
  167. NGAU2 = MINT2.POIGAU(/1)
  168. endif
  169. C write(*,*) 'dim de MINT2=6,',(MINT2.SHPTOT(/2)),(MINT2.SHPTOT(/3))
  170. C write(*,*) 'MINT2',(MINT2.QSIGAU(iou),iou=1,NGAU)
  171.  
  172.  
  173. c nbre maxi de fonction de forme par noeud (fonction std comprise)
  174. c NBNI = NDDL/IDIM inutile!
  175.  
  176.  
  177. C++++ Recup des infos d enrichissement +++++++++++++++++++
  178. c recup du MCHEX1 d'enrichissement
  179. NOBMO1 = IVAMOD(/1)
  180. if(NOBMO1.ne.0) then
  181. do iobmo1=1,NOBMO1
  182. if((TYMODE(iobmo1)).eq.'MCHAML') then
  183. MCHEX1 = IVAMOD(iobmo1)
  184. segact,MCHEX1
  185. if((MCHEX1.TITCHE).eq.'ENRICHIS') then
  186. MCHAM1 = MCHEX1.ICHAML(1)
  187. segact,MCHAM1
  188. goto 1000
  189. endif
  190. endif
  191. enddo
  192. write(*,*) 'Le modele est vide (absence d enrichissement)'
  193. * return
  194. else
  195. write(*,*) 'Il n y a pas de MCHEML enrichissement dans le Modele'
  196. * return
  197. endif
  198.  
  199. 1000 continue
  200. c niveau d enrichissement(s) du modele (ddls std u exclus)
  201. c NBENR1= 0 si std, 1 si H seul, 2 si H+F1, 3 si H+F1+F2, etc...
  202. if(NOBMO1.ne.0) then
  203. NBENR1= MCHAM1.IELVAL(/1)
  204. else
  205. NBENR1 = 0
  206. endif
  207. c write(*,*) 'niveau d enrichissement(s) du modele',NBENR1
  208. c
  209. C
  210. C
  211. C*********************************************************
  212. C INITIALISATIONS...
  213. C*********************************************************
  214. IRETER = 0
  215. c
  216. c preparation des tables avec:
  217.  
  218. if(NBENR1.ne.0) then
  219. do ienr=1,NBENR1
  220. c -le nombre d'inconnues de chaque sous-zone
  221. c determinee depuis le nombre de fonction de forme
  222. c ienr= 1: U+H(1+1=2), 2: U+H+F1(2+4=6), 3: U+H+F1+F2(6+4=10)
  223. nbniJ = 2 + ((ienr-1)*4)
  224. MLRE(1+ienr) = IDIM*NBNN1*nbniJ
  225. enddo
  226. endif
  227. C Tables + longues car 1er indice correspond au fontion de forme std
  228. MLRE(1) = IDIM*NBNN1*1
  229.  
  230. if(NBENR1.lt.(NBENRMAX+1)) then
  231. do ienr=(NBENR1+1),(NBENRMAX)
  232. MLRE(1+ienr) = 0
  233. enddo
  234. endif
  235. c
  236. c ...DU SEGMENT WRK1
  237. NBENRMA2 = NBENRMAX
  238. NBBB = NBNN1
  239. SEGINI,WRK1
  240.  
  241. c ...DU SEGMENT WRK2
  242. c NBNO = NBNI
  243. NBNO = LRE/IDIM
  244. SEGINI,WRK2
  245. C
  246. c ...DU SEGMENT MRACC
  247. NBENRMA2 = NBENRMAX
  248. NBI = NBNN1
  249. segini,MRACC
  250. C
  251. C du nombre d erreur sur le noms de composantes
  252. NBERR1=0
  253.  
  254.  
  255.  
  256. C*********************************************************
  257. C
  258. C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> BOUCLE SUR LES ELEMENTS
  259. C
  260. DO 2000 J=1,NBEL1
  261. c write(*,*) '==================================='
  262. c write(*,*) '========= EF',J,' /NBEL1 ========='
  263. C
  264. C
  265. C*********************************************************
  266. C POUR CHAQUE ELEMENT, ...
  267. C*********************************************************
  268. C
  269. C++++ ON RECUPERE LES COORDONNEES DES NOEUDS DE L ELEMENT
  270. CALL DOXE(XCOOR,IDIM,NBNN1,NUM,J,XE)
  271. C
  272. c
  273. C++++ NBENRJ = niveau d enrichissement de l element ++++
  274. C =0 si EF std =1 si U+H =2 si U+H+F1 =3 si U+H+F1+F2
  275. NBENRJ=0
  276. if(NBENR1.ne.0) then
  277. do IENR=1,NBENR1
  278. MELVA1 = MCHAM1.IELVAL(IENR)
  279. segact,MELVA1
  280. do I=1,NBNN1
  281. mlree1 = MELVA1.IELCHE(I,J)
  282. C on en profite pour remplir MRACC table de raccourcis pour cet element
  283. TLREEL(IENR,I) = mlree1
  284. if(mlree1.ne.0) then
  285. NBENRJ = max(NBENRJ,IENR)
  286. C et on active la listreel
  287. segact,mlree1
  288. endif
  289. enddo
  290. enddo
  291. endif
  292. if(NBENRMA2.gt.NBENR1) then
  293. do IENR2=(NBENR1+1),NBENRMA2
  294. do I=1,NBNN1
  295. TLREEL(IENR2,I) = 0
  296. enddo
  297. enddo
  298. endif
  299. C
  300. c
  301. c++++ quelques indices pour dimensionner au plus juste
  302. c nbre total de ddl de l'élément considéré
  303. NLIGRD = MLRE(1+NBENRJ)
  304. NLIGRP = MLRE(1+NBENRJ)
  305. c nbre fonction de forme=((Ni_std+Ni_enrichi)*nbnoeud)=Ninconnues/idim
  306. NBNI = (MLRE(1+NBENRJ)) / IDIM
  307.  
  308. C write(*,*) 'EF',J,' NBENRJ=',NBENRJ,
  309. C &'donc',NLIGRD,' ddls et ',NBNI,' fonctions de forme'
  310. c
  311. C
  312. C++++ ON CALCULE XDDL ++++
  313. MPTVAL = IVADEP
  314. NCOSOU = IVAL(/1)
  315. C
  316. INITOT = 0
  317. C-->> BOUCLE SUR LES niveaux d'ENRICHISSEMENTS (0:U 1:A 2:BCDE1 3:BCDE2)
  318. DO IENR=0,NBENRJ
  319. *nbre de fonction(s) de ce niveau d'enrichissement (=1 si std ou H, =4 pour F1,2,...)
  320. if(IENR .le. 1) then
  321. NBNIENR = 1
  322. else
  323. NBNIENR = 4
  324. endif
  325. C---->> BOUCLE SUR LES fonctions de forme de ce type d'enrichissement
  326. DO INI=1,NBNIENR
  327. INITOT = INITOT + 1
  328. C------>> BOUCLE SUR LA DIMENSION
  329. DO 2220 KDIM=1,IDIM
  330. ICOMP = (INITOT-1)*IDIM + KDIM
  331.  
  332. c --cas ou on n'a pas trouvé assez de composantes--
  333. if(ICOMP.GT.NCOSOU) GOTO 2221
  334.  
  335. MELVAL = IVAL(ICOMP)
  336. c --cas ou on a pas trouvé cette composante dans cette zone du
  337. c chpoint solution devenu mchaml --
  338. if(MELVAL.eq.0)then
  339. c Avait on besoin de cette composante?
  340. c oui, si c'est une composante obligatoire
  341. if(IENR.eq.0) goto 2991
  342. c oui, si l'un des noeuds est enrichi
  343. do I=1,NBNN1
  344. if(TLREEL(IENR,I).ne.0) goto 2991
  345. enddo
  346. c non, si c'est facultatif et qu'on n'est pas enrichi -> on saute
  347. goto 2220
  348. c ->AVERTISSEMENT puis on saute
  349. 2991 NBERR1=NBERR1+1
  350. if(IIMPI.lt.1) goto 2220
  351. c write(IOIMP,*) 'PB OPERATEUR EPSI :'
  352. write(IOIMP,991) ICOMP,IENR,INI,KDIM
  353. 991 format(2X,'ABSENCE DANS LE CHPOINT DEPLACEMENT DE LA ',I3,
  354. $ 'ieme COMPOSANTE (enrichissement',I3,
  355. $ ', fonction',I3,', direction ',I3,
  356. $ ') NECESSAIRE POUR L UN DES NOEUDS SUIVANTS :')
  357. write(IOIMP,*)' noeuds :',(NUM(iou,J),iou=1,NBNN1)
  358. goto 2220
  359. endif
  360.  
  361. C---------->> BOUCLE SUR LES NOEUDS
  362. DO I=1,NBNN1
  363. IQ = ((INITOT-1)*NBNN1*IDIM) + ((I-1)*IDIM) + KDIM
  364. XDDL(IQ) = VELCHE(I,J)
  365. ENDDO
  366.  
  367. 2220 CONTINUE
  368. ENDDO
  369. ENDDO
  370.  
  371. c --cas normal (toutes les composantes souhaitees etaient presentes)--
  372. GOTO 2223
  373.  
  374. c --cas ou on n'a pas trouvé assez de composantes--
  375. 2221 CONTINUE
  376. if (IIMPI.ge.1) then
  377. WRITE(IOIMP,2222) J,NCOSOU,ICOMP
  378. 2222 FORMAT(2X,'ATTENTION : ELEMENT ',I6,
  379. & ' LE CHAMP DE DEPLACEMENT CONTIENT ',I3,' COMPOSANTES',
  380. & ' PAR NOEUD AU LIEU DE ',I3,' ATTENDUES')
  381. endif
  382. NDDL=NCOSOU*NBNN1
  383. NBENRJ=IENR
  384.  
  385. 2223 CONTINUE
  386. c --cas ou on a une ou des erreurs--
  387. IF (NBERR1.gt.0.and.J.eq.NBEL1) THEN
  388. write(IOIMP,*) 'OPERATEUR GRAD : ABSENCE DANS LE CHPOINT ',
  389. & 'DEPLACEMENT DE CERTAINES INCONNUES ATTENDUES PAR LE MODELE'
  390. ENDIF
  391. c
  392. c rem: il serait probablement interessant au niveau du tems cpu
  393. c d'utiliser moins de pts de Gauss lorsque l element est élastique
  394. c On pourrait par ex. utiliser MINT2 = infell(12) qui contient
  395. c le segment d'integration de l'EF std (QUA4 par ex.)
  396. * if((NBENRJ.eq.0).and.(MINT2.ne.0)) then
  397. * MINTE = MINT2
  398. * NBPGAU= NGAU2
  399. * else
  400. MINTE = MINT1
  401. NBPGAU= NGAU1
  402. * endif
  403. c
  404. c pour les def quadratiques
  405. ISDJC=0
  406. NBPTEL=NBPGAU
  407. IF (IREPS2.EQ.1) SEGINI MTRACE
  408. c
  409. C
  410. C*********************************************************
  411. C
  412. C>>>>>>>>>> BOUCLE SUR LES POINTS DE GAUSS
  413. C
  414. DO 2500 KGAU=1,NBPGAU
  415. C
  416. C*********************************************************
  417. C Initialisation à 0
  418. C*********************************************************
  419.  
  420. c ZERO ne serait-il pas facultatif?
  421. CALL ZERO(SHPWRK,6,NBNO)
  422. C
  423. i6zz = 3
  424. IF (IDIM.EQ.3) i6zz = 4
  425. C
  426. c do ienr7=1,NBENRMAX
  427. do ienr7=1,NBENRJ
  428. do inod7=1,NBNN1
  429. c do i6=1,6
  430. do i6=1,i6zz
  431. LV7WRK(ienr7,1,i6,inod7) = 0.D0
  432. LV7WRK(ienr7,2,i6,inod7) = 0.D0
  433. enddo
  434. enddo
  435. enddo
  436.  
  437.  
  438. c*********************************************************
  439. c Calcul des fonction de forme std dans repere local
  440. c*********************************************************
  441.  
  442. ccccc BOUCLE SUR LES NOEUDS ccccccccccccccccccccccccccccc
  443. c (et donc sur les Ni std)
  444. DO 2510 I=1,NBNN1
  445.  
  446. C++++ Calcul des Ni std
  447. c (rappel: 1:Ni 2:Ni,qsi 3:Ni,eta avec i=1,4)
  448. SHPWRK(1,I) = SHPTOT(1,I,KGAU)
  449. SHPWRK(2,I) = SHPTOT(2,I,KGAU)
  450. SHPWRK(3,I) = SHPTOT(3,I,KGAU)
  451. IF (IDIM.EQ.3) SHPWRK(4,I) = SHPTOT(4,I,KGAU)
  452.  
  453. 2510 CONTINUE
  454. ccccc fin de BOUCLE SUR LES NOEUDS ccccccccccccccccccccccc
  455.  
  456.  
  457.  
  458. c*********************************************************
  459. c Passage des fonctions de forme std dans repere global
  460. c*********************************************************
  461.  
  462. C++++ CALCUL DES Ni,x Ni,y (i=1,4) + CALCUL DE det(J)
  463. CALL JACOBI(XE,SHPWRK,IDIM,NBNN1,DJAC)
  464. c if(J.eq.1.and.KGAU.eq.1)
  465. c &write(*,*) 'Ni(i=1,4)=',(SHPWRK(1,iou),iou=1,NBNN1)
  466.  
  467. c*********************************************************
  468. c Si on est pas du tout enrichi on peut sauter une grosse partie
  469. c*********************************************************
  470. if(NBENRJ.eq.0) goto 2999
  471.  
  472. c*********************************************************
  473. c Calcul des level set + leurs derivees dans repere global
  474. c*********************************************************
  475.  
  476. ccccc BOUCLE SUR LES enrichissements ccccccccccccccccccc
  477. do 2520 ienr=1,NBENRJ
  478.  
  479. c MELVA1=MCHAM1.IELVAL(IENR)
  480. c segact,MELVA1
  481.  
  482. ccccc BOUCLE SUR LES NOEUDS ccccccccccccccccccccccccccc
  483. DO 2521 I=1,NBNN1
  484.  
  485. C++++ Le I eme noeud est-il ienr-enrichi?
  486. mlree1= TLREEL(IENR,I)
  487. if(mlree1.eq.0) goto 2521
  488.  
  489.  
  490. c Calcul du repere local de fissure(=PSI,PHI)
  491. c (rappel: 1,1:psi 1,2:phi 2,1 psi,x ...etc...)
  492. do 2522 inode=1,NBNN1
  493. c pour le H-enrichissement, on n a pas gardé PSI (inutile)
  494. if(ienr.ne.1) then
  495. c valeur de PSI au inode^ieme noeud
  496. xpsi1 = mlree1.PROG(inode)
  497. c qu on multiplie par la valeur de Ni^std au pt de G considéré
  498. LV7WRK(ienr,1,1,I)= LV7WRK(ienr,1,1,I)
  499. & + (SHPWRK(1,inode)*xpsi1)
  500. LV7WRK(ienr,1,2,I)= LV7WRK(ienr,1,2,I)
  501. & + (SHPWRK(2,inode)*xpsi1)
  502. LV7WRK(ienr,1,3,I)= LV7WRK(ienr,1,3,I)
  503. & + (SHPWRK(3,inode)*xpsi1)
  504. IF (IDIM.EQ.3) LV7WRK(ienr,1,4,I)= LV7WRK(ienr,1,4,I)
  505. & + (SHPWRK(4,inode)*xpsi1)
  506. c valeur de PHI au inode^ieme noeud
  507. xphi1 = mlree1.PROG(NBNN1+inode)
  508. else
  509. xphi1 = mlree1.PROG(inode)
  510. endif
  511. LV7WRK(ienr,2,1,I)= LV7WRK(ienr,2,1,I)
  512. & + (SHPWRK(1,inode)*xphi1)
  513. LV7WRK(ienr,2,2,I)= LV7WRK(ienr,2,2,I)
  514. & + (SHPWRK(2,inode)*xphi1)
  515. LV7WRK(ienr,2,3,I)= LV7WRK(ienr,2,3,I)
  516. & + (SHPWRK(3,inode)*xphi1)
  517. IF (IDIM.EQ.3) LV7WRK(ienr,2,4,I)= LV7WRK(ienr,2,4,I)
  518. & + (SHPWRK(4,inode)*xphi1)
  519. 2522 continue
  520.  
  521. 2521 continue
  522. ccccc fin de BOUCLE SUR LES NOEUDS ccccccccccccccccccccccc
  523.  
  524.  
  525. 2520 CONTINUE
  526. ccccc fin de BOUCLE SUR LES enrichissements cccccccccccccccc
  527.  
  528. c on a construit
  529. C LV7WRK(ienr, PSI/PHI, valeur/deriveeparqsi/pareta, iNOEUD)
  530.  
  531.  
  532. c*********************************************************
  533. c Ajout des fonctions de forme d enrichissement
  534. c + leurs derivees dans repere global
  535. c*********************************************************
  536. CALL SHAPX(MELE,LV7WRK,NBENRMAX,NBENRJ,TLREEL,SHPWRK,IRET)
  537.  
  538.  
  539. c retour a la partie commune aux EF enrichi et non enrichi
  540. 2999 continue
  541.  
  542. C*********************************************************
  543. C CALCUL DE B'
  544. C*********************************************************
  545. c ZERO ne serait-il pas facultatif?
  546. c call ZERO(BGENE,LHOOK,NLIGRP)
  547. KB=1
  548. C boucle sur tous les Ni
  549. DO 3001 II=1,NBNI
  550.  
  551. BGENE(1,KB) = SHPWRK(2,II)
  552. BGENE(2,KB+1) = SHPWRK(3,II)
  553. BGENE(4,KB) = SHPWRK(3,II)
  554. BGENE(4,KB+1) = SHPWRK(2,II)
  555.  
  556. IF(IDIM.EQ.3) THEN
  557. BGENE(3,KB+2)=SHPWRK(4,II)
  558. BGENE(5,KB)=SHPWRK(4,II)
  559. BGENE(5,KB+2)=SHPWRK(2,II)
  560. BGENE(6,KB+1)=SHPWRK(4,II)
  561. BGENE(6,KB+2)=SHPWRK(3,II)
  562. ENDIF
  563.  
  564. KB = KB + IDIM
  565.  
  566. 3001 CONTINUE
  567. C
  568. c if(J.eq.5.and.KGAU.eq.1) then
  569. c if(KGAU.eq.1) then
  570. c write(*,*) 'BGENE(1,..)=',(BGENE(1,iou),iou=1,2*NBNI)
  571. c write(*,*) 'BGENE(2,..)=',(BGENE(2,iou),iou=1,2*NBNI)
  572. c write(*,*) 'BGENE(6,..)=',(BGENE(6,iou),iou=1,2*NBNI)
  573. c endif
  574. c endif
  575.  
  576.  
  577. c
  578.  
  579. C*********************************************************
  580. C CALCUL DE B.q'
  581. C*********************************************************
  582.  
  583. C APPEL A LA PROCEDURE DE CALCUL
  584. CALL BST(BGENE,XDDL,(NBNI*IDIM),LHOOK,XSTRS)
  585. c
  586. c cas de la priâe en compte des termes quadratiques
  587. IF (IREPS2.EQ.1)
  588. & CALL BST2(SHPWRK,XDDL,XE,NBNI,IFOUR,XSTRS,TRACE,KGAU,
  589. & XDPGE,YDPGE,UDPGE,NIFOUR)
  590.  
  591. C*********************************************************
  592. C ECRITURE DES DIFFERENTES COMPOSANTES DES DEFORMATIONS
  593. C*********************************************************
  594. MPTVAL = IVAEPS
  595. DO 7000 ICOMP=1,LHOOK
  596. MELVAL = IVAL(ICOMP)
  597. VELCHE(KGAU,J) = XSTRS(ICOMP)
  598. 7000 CONTINUE
  599. C if(KGAU.eq.1) then
  600. C write(*,*) J,KGAU,'EPSI(..)=',(XSTRS(iou),iou=1,LHOOK)
  601. C endif
  602. c
  603. c
  604. 2500 CONTINUE
  605. C FIN DE BOUCLE SUR LES POINTS DE GAUSS <<<<<<<<<<<<<<
  606. C
  607.  
  608. *
  609. c quelques suppressions
  610. c (ici element non-incompressible=> pas besoin de MTRACE (cf epsi2)
  611. IF (IREPS2.EQ.1) THEN
  612. SEGSUP MTRACE
  613. ENDIF
  614.  
  615. c
  616. c
  617. 2000 CONTINUE
  618. C FIN DE BOUCLE SUR LES ELEMENTS <<<<<<<<<<<<<<<<<<<<<
  619. c
  620. c
  621.  
  622. C*********************************************************
  623. C SUPPRESSION ET DESACTIVATION DE SEGMENTS
  624. C*********************************************************
  625. C
  626. SEGSUP,WRK1,WRK2
  627. SEGSUP,MRACC
  628.  
  629. END
  630.  
  631.  
  632.  

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