Télécharger barsou.eso

Retour à la liste

Numérotation des lignes :

  1. C BARSOU SOURCE CHAT 11/04/14 21:15:10 6942
  2. SUBROUTINE BARSOU
  3. *------------------------------------------------------------------------*
  4. * Operateur BARSOU : Déplacement des noeuds milieu au quart *
  5. * *
  6. * MELEME (e/s) : Pointeur sur un MELEME (TRI6 ou QUA 8) *
  7. * IPOIN (e) : Pointe de fissure *
  8. * ou IPT3 (e) : Ligne de fissure dans le cas 3D massif *
  9. *------------------------------------------------------------------------*
  10.  
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8 (A-H,O-Z)
  13. *
  14. -INC CCOPTIO
  15. -INC SMELEME
  16. -INC SMCOORD
  17. *
  18. *------------------------------------------------------------------------*
  19. * Déclaration des segments temporaires nécessaires au traitement *
  20. *------------------------------------------------------------------------*
  21. * Segment des noeuds à déplacer *
  22. SEGMENT, PTDEP
  23. INTEGER TPOIM(N), TPFIS(N), TPOIE(N)
  24. ENDSEGMENT
  25. POINTEUR IPTDP.PTDEP
  26. * Segment des noeuds milieu de la ligne de fissures *
  27. SEGMENT, PTMIL
  28. INTEGER TLFMI(N)
  29. ENDSEGMENT
  30. * Segment des pointes de fissure (pas de noeuds milieu) *
  31. SEGMENT, PTFIS
  32. INTEGER TLFPT(N)
  33. ENDSEGMENT
  34. * Segment des élements contenant des noeuds à déplacer *
  35. SEGMENT, ELMDP
  36. INTEGER TSOUS(N), TELMM(N), TPFIM(N), TTYPL(N), TNUPF(N)
  37. ENDSEGMENT
  38. *
  39. *------------------------------------------------------------------------*
  40. * Autres déclarations *
  41. *------------------------------------------------------------------------*
  42. REAL*8 V1(3), V2(3), V3(3), TDIST(20)
  43. INTEGER TMRAN(4), TERAN(4)
  44. INTEGER TMP15(14,3), TEP15(14,3), TMC20(19,3), TEC20(19,3)
  45. INTEGER TMP13(13,4), TEP13(13,4), TMT10(10,3), TET10(14,3)
  46. INTEGER TMQU8(7,2), TEQU8(7,2), TMTR6(5,2), TETR6(5,2)
  47. DATA TMP15(1,1), TMP15(1,2), TMP15(1,3), TMP15(3,1), TMP15(3,2),
  48. # TMP15(3,3), TMP15(5,1), TMP15(5,2), TMP15(5,3), TMP15(10,1),
  49. # TMP15(10,2), TMP15(10,3), TMP15(12,1), TMP15(12,2), TMP15(12,3),
  50. # TMP15(14,1), TMP15(14,2), TMP15(14,3)
  51. # /2,6,7,2,4,8,4,6,9,7,11,15,8,11,13,9,13,15/
  52. DATA TEP15(1,1), TEP15(1,2), TEP15(1,3), TEP15(3,1), TEP15(3,2),
  53. # TEP15(3,3), TEP15(5,1), TEP15(5,2), TEP15(5,3), TEP15(10,1),
  54. # TEP15(10,2), TEP15(10,3), TEP15(12,1), TEP15(12,2), TEP15(12,3),
  55. # TEP15(14,1), TEP15(14,2), TEP15(14,3)
  56. # /3,5,10,1,5,12,3,1,14,1,12,14,3,10,14,5,12,10/
  57. DATA TMC20(1,1), TMC20(1,2), TMC20(1,3), TMC20(3,1), TMC20(3,2),
  58. # TMC20(3,3), TMC20(5,1), TMC20(5,2), TMC20(5,3), TMC20(7,1),
  59. # TMC20(7,2), TMC20(7,3), TMC20(13,1), TMC20(13,2), TMC20(13,3),
  60. # TMC20(15,1), TMC20(15,2), TMC20(15,3), TMC20(17,1), TMC20(17,2),
  61. # TMC20(17,3), TMC20(19,1), TMC20(19,2), TMC20(19,3)
  62. # /2,8,9,2,4,10,4,6,11,6,8,12,9,14,20,14,16,10,11,16,18,12,18,20/
  63. DATA TEC20(1,1), TEC20(1,2), TEC20(1,3), TEC20(3,1), TEC20(3,2),
  64. # TEC20(3,3), TEC20(5,1), TEC20(5,2), TEC20(5,3), TEC20(7,1),
  65. # TEC20(7,2), TEC20(7,3), TEC20(13,1), TEC20(13,2), TEC20(13,3),
  66. # TEC20(15,1), TEC20(15,2), TEC20(15,3), TEC20(17,1), TEC20(17,2),
  67. # TEC20(17,3), TEC20(19,1), TEC20(19,2), TEC20(19,3)
  68. # /3,7,13,1,5,15,3,7,17,5,1,19,1,15,19,13,17,3,5,15,19,7,17,13/
  69. DATA TMP13(1,1), TMP13(1,2), TMP13(1,3), TMP13(3,1), TMP13(3,2),
  70. # TMP13(3,3), TMP13(5,1), TMP13(5,2), TMP13(5,3), TMP13(7,1),
  71. # TMP13(7,2), TMP13(7,3), TMP13(13,1), TMP13(13,2), TMP13(13,3),
  72. # TMP13(13,4)
  73. # /2,8,9,2,4,10,4,6,11,6,8,12,9,10,11,12/
  74. DATA TEP13(1,1), TEP13(1,2), TEP13(1,3), TEP13(3,1), TEP13(3,2),
  75. # TEP13(3,3), TEP13(5,1), TEP13(5,2), TEP13(5,3), TEP13(7,1),
  76. # TEP13(7,2), TEP13(7,3), TEP13(13,1), TEP13(13,2), TEP13(13,3),
  77. # TEP13(13,4)
  78. # /3,7,10,1,5,13,3,7,13,5,1,13,1,3,5,7/
  79. DATA TMT10(1,1), TMT10(1,2), TMT10(1,3), TMT10(3,1), TMT10(3,2),
  80. # TMT10(3,3), TMT10(5,1), TMT10(5,2), TMT10(5,3), TMT10(10,1),
  81. # TMT10(10,2), TMT10(10,3)
  82. # /2,6,7,2,4,8,4,6,9,7,8,9/
  83. DATA TET10(1,1), TET10(1,2), TET10(1,3), TET10(3,1), TET10(3,2),
  84. # TET10(3,3), TET10(5,1), TET10(5,2), TET10(5,3), TET10(10,1),
  85. # TET10(10,2), TET10(10,3)
  86. # /3,5,10,1,5,10,3,1,10,1,3,5/
  87. DATA TMQU8(1,1), TMQU8(1,2), TMQU8(3,1), TMQU8(3,2), TMQU8(5,1),
  88. # TMQU8(5,2), TMQU8(7,1), TMQU8(7,2)
  89. # /2,8,2,4,4,6,6,8/
  90. DATA TEQU8(1,1), TEQU8(1,2), TEQU8(3,1), TEQU8(3,2), TEQU8(5,1),
  91. # TEQU8(5,2), TEQU8(7,1), TEQU8(7,2)
  92. # /3,7,1,5,3,7,5,1/
  93. DATA TMTR6(1,1), TMTR6(1,2), TMTR6(3,1), TMTR6(3,2), TMTR6(5,1),
  94. # TMTR6(5,2)
  95. # /2,6,2,4,4,6/
  96. DATA TETR6(1,1), TETR6(1,2), TETR6(3,1), TETR6(3,2), TETR6(5,1),
  97. # TETR6(5,2)
  98. # /3,5,1,5,3,1/
  99. *
  100. *------------------------------------------------------------------------*
  101. * Récupération du maillage et de la pointe *
  102. * ou de la ligne de fissure *
  103. *------------------------------------------------------------------------*
  104. CALL LIROBJ('MAILLAGE', MELEME, 1, IRETOU)
  105. IF (IERR .NE. 0) RETURN
  106. IF (IRETOU .EQ. 0) RETURN
  107. CALL LIRREE(ALPHA, 0, IRETOU)
  108. IF (IERR .NE. 0) RETURN
  109. IF (IRETOU .EQ. 0) THEN
  110. ALPHA = 0.495
  111. ELSE
  112. IF (IIMPI.EQ.1) WRITE (*,*) 'REEL LU...'
  113. ENDIF
  114. IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET MAILLAGE LU...'
  115. CALL LIROBJ('MAILLAGE', IPT3, 0, IRETOU)
  116. IF (IERR .NE. 0) RETURN
  117. SEGACT, MCOORD*MOD
  118. IF (IRETOU .EQ. 0) THEN
  119. CALL LIROBJ('POINT', IPOIN, 1, IRETOU)
  120. IF (IERR .NE. 0) RETURN
  121. IF (IRETOU .EQ. 0) RETURN
  122. IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET POINT LU...'
  123. N = 1
  124. SEGINI, PTFIS
  125. TLFPT(1) = IPOIN
  126. IF (IIMPI.EQ.1) THEN
  127. WRITE (*,*) ' Noeud de fissure : ', IPOIN
  128. ENDIF
  129. SEGDES, PTFIS
  130. N = 0
  131. SEGINI, PTMIL
  132. SEGDES, PTMIL
  133. ELSE
  134. IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET MAILLAGE LU...'
  135. N = 0
  136. SEGINI, PTFIS
  137. SEGDES, PTFIS
  138. N = 0
  139. SEGINI, PTMIL
  140. SEGDES, PTMIL
  141. SEGACT, IPT3
  142. IPT2 = IPT3
  143. IP = 0
  144. IF (IIMPI.EQ.1) WRITE (*,*) 'BOUCLE SUR LE MAILLAGE...'
  145. *----------POUR CHAQUE SOUS-ENSEMBLE
  146. DO 13 IS = 1, MAX(1, IPT3.LISOUS(/1))
  147. IF (IPT3.LISOUS(/1) .NE. 0) THEN
  148. IPT2 = IPT3.LISOUS(IS)
  149. SEGACT, IPT2
  150. ENDIF
  151. IF (IIMPI.EQ.1) THEN
  152. WRITE (*,*) 'OBJET MAILLAGE DE TYPE ', IPT2.ITYPEL
  153. ENDIF
  154. DO 12 IE = 1, IPT2.NUM(/2)
  155. SEGACT, PTMIL
  156. N = TLFMI(/1) + 1
  157. SEGADJ, PTMIL
  158. TLFMI(N) = IPT2.NUM(2, IE)
  159. IF (IIMPI .EQ. 1) THEN
  160. WRITE (*,*) ' Point milieu-fissure ',TLFMI(N)
  161. ENDIF
  162. SEGDES, PTMIL
  163. SEGACT, PTFIS
  164. IF (IP .EQ. 0) THEN
  165. IP = 1
  166. N = 1
  167. SEGADJ, PTFIS
  168. TLFPT(1) = IPT2.NUM(1, IE)
  169. IF (IIMPI .EQ. 1) THEN
  170. WRITE (*,*) ' Point fissure ',TLFPT(N)
  171. ENDIF
  172. ENDIF
  173. N = TLFPT(/1) + 1
  174. SEGADJ, PTFIS
  175. TLFPT(N) = IPT2.NUM(3, IE)
  176. IF (IIMPI .EQ. 1) THEN
  177. WRITE (*,*) ' Point fissure ',TLFPT(N)
  178. ENDIF
  179. SEGDES, PTFIS
  180. 12 CONTINUE
  181. IF (IPT3.LISOUS(/1).NE.0) SEGDES, IPT2
  182. 13 CONTINUE
  183. SEGDES, IPT3
  184. ENDIF
  185. *------------------------------------------------------------------------*
  186. * Récupération des éléments contenant des noeuds à déplacer *
  187. *------------------------------------------------------------------------*
  188. IF (IIMPI.EQ.1) WRITE (*,*) 'RECUPERATION DES ELEMENTS'
  189. IK = 0
  190. N = 0
  191. SEGINI, ELMDP
  192. SEGDES, ELMDP
  193. SEGACT, PTFIS
  194. INP = TLFPT(/1)
  195. DO 5 IP = 1, INP
  196. IPOIN = TLFPT(IP)
  197. *----------ON CHERCHE LES ELEMENTS CONTENANT LA POINTE DE FISSURE
  198. SEGACT, MELEME
  199. IPT1 = MELEME
  200. DO 2 IS=1, MAX(1, MELEME.LISOUS(/1))
  201. IF (MELEME.LISOUS(/1).NE.0) THEN
  202. IPT1 = MELEME.LISOUS(IS)
  203. SEGACT IPT1
  204. ENDIF
  205. DO 3 IE = 1, IPT1.NUM(/2)
  206. DO 4 IN = 1, IPT1.NUM(/1)
  207. IF (IPT1.NUM(IN, IE) .EQ. IPOIN) THEN
  208. *----------------------ON A TROUVE UN ELEMENT QUI CONTIENT LA POINTE
  209. SEGACT, ELMDP
  210. IF (TELMM(/1) .EQ. 0) THEN
  211. IK = IK + 1
  212. N = TELMM(/1) + 1
  213. SEGADJ, ELMDP
  214. TELMM(N) = IE
  215. TTYPL(N) = IPT1.ITYPEL
  216. TPFIM(N) = TLFPT(IP)
  217. TNUPF(N) = IN
  218. IF (MELEME.LISOUS(/1).NE.0) THEN
  219. TSOUS(N) = IS
  220. ELSE
  221. TSOUS(N) = 0
  222. ENDIF
  223. IF (IIMPI.EQ.1) THEN
  224. WRITE (*,*) ' Element : ',IE,' dans ',TSOUS(N)
  225. WRITE (*,*) ' fissure : ',TPFIM(N)
  226. ENDIF
  227. ELSE
  228. II = 1
  229. 6 IF(TELMM(II).NE.IE.OR.TSOUS(II).NE.IS.OR.TPFIM(II).NE.IPOIN) THEN
  230. II = II + 1
  231. IF (II .LE. TELMM(/1)) GOTO 6
  232. IK = IK + 1
  233. N = TELMM(/1) + 1
  234. SEGADJ, ELMDP
  235. TELMM(N) = IE
  236. TTYPL(N) = IPT1.ITYPEL
  237. TPFIM(N) = TLFPT(IP)
  238. TNUPF(N) = IN
  239. IF (MELEME.LISOUS(/1).NE.0) THEN
  240. TSOUS(N) = IS
  241. ELSE
  242. TSOUS(N) = 0
  243. ENDIF
  244. IF (IIMPI.EQ.1) THEN
  245. WRITE (*,*) ' Element : ',IE,' dans ',TSOUS(N)
  246. WRITE (*,*) ' fissure : ',TPFIM(N)
  247. ENDIF
  248. ENDIF
  249. ENDIF
  250. SEGDES, ELMDP
  251. ENDIF
  252. 4 CONTINUE
  253. 3 CONTINUE
  254. IF (LISOUS(/1).NE.0) SEGDES, IPT1
  255. 2 CONTINUE
  256. SEGDES, MELEME
  257. 5 CONTINUE
  258. SEGDES, PTFIS
  259. *------------------------------------------------------------------------*
  260. * Récupération des noeuds à déplacer *
  261. *------------------------------------------------------------------------*
  262. N = 0
  263. IF (IIMPI.EQ.1) WRITE (*,*) 'RECUPERATION DES NOEUDS'
  264. SEGINI, PTDEP
  265. SEGDES, PTDEP
  266. SEGACT, MELEME
  267. IPT1 = MELEME
  268. SEGACT, ELMDP
  269. SEGACT, PTDEP
  270. IK = 0
  271. *-------POUR CHAQUE ELEMENT SELECTIONNE PRECEDEMMENT
  272. IF (IIMPI.EQ.1) WRITE (*,*) ' ',TELMM(/1),' Elements à étudier'
  273. DO 20 IE = 1, ELMDP.TELMM(/1)
  274. IEFI = ELMDP.TNUPF(IE)
  275. IF (ELMDP.TTYPL(IE).EQ.6) THEN
  276. IF (IIMPI.EQ.1) WRITE (*,*) ' Element TRI6 # ', IE
  277. INBNO = 6
  278. GOTO 21
  279. ENDIF
  280. IF (ELMDP.TTYPL(IE).EQ.10) THEN
  281. IF (IIMPI.EQ.1) WRITE (*,*) ' Element QUA8 # ', IE
  282. INBNO = 8
  283. GOTO 22
  284. ENDIF
  285. IF (ELMDP.TTYPL(IE).EQ.15) THEN
  286. IF (IIMPI.EQ.1) WRITE (*,*) ' Element CU20 # ', IE
  287. INBNO = 20
  288. GOTO 23
  289. ENDIF
  290. IF (ELMDP.TTYPL(IE).EQ.17) THEN
  291. IF (IIMPI.EQ.1) WRITE (*,*) ' Element PR15 # ', IE
  292. INBNO = 15
  293. GOTO 24
  294. ENDIF
  295. IF (ELMDP.TTYPL(IE).EQ.24) THEN
  296. IF (IIMPI.EQ.1) WRITE (*,*) ' Element TE10 # ', IE
  297. INBNO = 10
  298. GOTO 25
  299. ENDIF
  300. IF (ELMDP.TTYPL(IE).EQ.26) THEN
  301. IF (IIMPI.EQ.1) WRITE (*,*) ' Element PY13 # ', IE
  302. INBNO = 13
  303. GOTO 26
  304. ENDIF
  305. GOTO 20
  306. 21 CONTINUE
  307. ***--------CAS DES ELEMENTS TRI6
  308. IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  309. SEGACT, IPT1
  310. NPMI = 2
  311. DO 211 IM = 1, NPMI
  312. TMRAN(IM) = TMTR6(IEFI, IM)
  313. TERAN(IM) = TETR6(IEFI, IM)
  314. 211 CONTINUE
  315. GOTO 200
  316. 22 CONTINUE
  317. ***--------CAS DES ELEMENTS QUA8
  318. IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  319. SEGACT, IPT1
  320. NPMI = 2
  321. DO 212 IM = 1, NPMI
  322. TMRAN(IM) = TMQU8(IEFI, IM)
  323. TERAN(IM) = TEQU8(IEFI, IM)
  324. 212 CONTINUE
  325. GOTO 200
  326. 23 CONTINUE
  327. ***--------CAS DES ELEMENTS CU20
  328. IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  329. SEGACT, IPT1
  330. NPMI = 3
  331. DO 213 IM = 1, NPMI
  332. TMRAN(IM) = TMC20(IEFI, IM)
  333. TERAN(IM) = TEC20(IEFI, IM)
  334. 213 CONTINUE
  335. GOTO 200
  336. 24 CONTINUE
  337. ***--------CAS DES ELEMENTS PR15
  338. IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  339. SEGACT, IPT1
  340. NPMI = 3
  341. DO 214 IM = 1, NPMI
  342. TMRAN(IM) = TMP15(IEFI, IM)
  343. TERAN(IM) = TEP15(IEFI, IM)
  344. 214 CONTINUE
  345. GOTO 200
  346. 25 CONTINUE
  347. ***--------CAS DES ELEMENTS TE10
  348. IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  349. SEGACT, IPT1
  350. NPMI = 3
  351. DO 215 IM = 1, NPMI
  352. TMRAN(IM) = TMT10(IEFI, IM)
  353. TERAN(IM) = TET10(IEFI, IM)
  354. 215 CONTINUE
  355. GOTO 200
  356. 26 CONTINUE
  357. ***--------CAS DES ELEMENTS PY13
  358. IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  359. SEGACT, IPT1
  360. IF (IEFI .EQ. 13) THEN
  361. NPMI = 4
  362. ELSE
  363. NPMI = 3
  364. ENDIF
  365. DO 216 IM = 1, NPMI
  366. TMRAN(IM) = TMP13(IEFI, IM)
  367. TERAN(IM) = TEP13(IEFI, IM)
  368. 216 CONTINUE
  369. ***--------RANGEMENT DES POINTS MILIEUX ET DES POINTS EXTREMITES
  370. 200 CONTINUE
  371. IF (IK .EQ. 0) THEN
  372. DO 220 IM = 1, NPMI
  373. IK = IK + 1
  374. N = IK
  375. SEGADJ, PTDEP
  376. PTDEP.TPOIM(N) = IPT1.NUM(TMRAN(IM), TELMM(IE))
  377. PTDEP.TPOIE(N) = IPT1.NUM(TERAN(IM), TELMM(IE))
  378. PTDEP.TPFIS(N) = ELMDP.TPFIM(IE)
  379. IF (IIMPI .EQ. 1) THEN
  380. WRITE (*,*) 'POINT MILIEU : ', PTDEP.TPOIM(N)
  381. WRITE (*,*) ' Point extremite : ', PTDEP.TPOIE(N)
  382. WRITE (*,*) ' Point fissure : ', PTDEP.TPFIS(N)
  383. ENDIF
  384. 220 CONTINUE
  385. ELSE
  386. DO 230 IM = 1, NPMI
  387. II = 1
  388. 240 IF (PTDEP.TPOIM(II).NE.IPT1.NUM(TMRAN(IM),TELMM(IE))) THEN
  389. IF (II .LE. IK) THEN
  390. II = II + 1
  391. GOTO 240
  392. ELSE
  393. IK = IK + 1
  394. N = PTDEP.TPOIM(/1) + 1
  395. SEGADJ, PTDEP
  396. PTDEP.TPOIM(N) = IPT1.NUM(TMRAN(IM), TELMM(IE))
  397. PTDEP.TPOIE(N) = IPT1.NUM(TERAN(IM), TELMM(IE))
  398. PTDEP.TPFIS(N) = ELMDP.TPFIM(IE)
  399. IF (IIMPI .EQ. 1) THEN
  400. WRITE (*,*) 'POINT MILIEU : ', PTDEP.TPOIM(N)
  401. WRITE (*,*) ' Point extremite : ', PTDEP.TPOIE(N)
  402. WRITE (*,*) ' Point fissure : ', PTDEP.TPFIS(N)
  403. ENDIF
  404. ENDIF
  405. ENDIF
  406. 230 CONTINUE
  407. ENDIF
  408. SEGDES, IPT1
  409. 20 CONTINUE
  410. SEGDES, PTDEP
  411. SEGDES, ELMDP
  412. SEGDES, MELEME
  413. *
  414. *------------------------------------------------------------------------*
  415. * Epuration du tableau contenant les noeuds milieu *
  416. *------------------------------------------------------------------------*
  417. SEGACT, PTDEP
  418. N = 1
  419. SEGINI, IPTDP
  420. IPTDP.TPOIM(1) = PTDEP.TPOIM(1)
  421. IPTDP.TPFIS(1) = PTDEP.TPFIS(1)
  422. IPTDP.TPOIE(1) = PTDEP.TPOIE(1)
  423. DO 50, IP = 2, PTDEP.TPOIM(/1)
  424. II = 1
  425. 51 IF (IPTDP.TPOIM(II) .NE. PTDEP.TPFIS(IP)) THEN
  426. II = II + 1
  427. IF (II .LE. IPTDP.TPOIM(/1)) GOTO 51
  428. N = IPTDP.TPOIM(/1) + 1
  429. SEGADJ, IPTDP
  430. IPTDP.TPOIM(N) = PTDEP.TPOIM(IP)
  431. IPTDP.TPFIS(N) = PTDEP.TPFIS(IP)
  432. IPTDP.TPOIE(N) = PTDEP.TPOIE(IP)
  433. ENDIF
  434. 50 CONTINUE
  435. SEGDES, IPTDP
  436. SEGDES, PTDEP
  437. *------------------------------------------------------------------------*
  438. * Déplacement des noeuds milieu *
  439. *------------------------------------------------------------------------*
  440. *
  441. SEGACT, IPTDP
  442. SEGACT, PTMIL
  443. DO 40, IP = 1, IPTDP.TPOIM(/1)
  444. IF (PTMIL.TLFMI(/1) .EQ. 0) GOTO 42
  445. II = 1
  446. 41 IF (TLFMI(II) .NE. IPTDP.TPOIM(IP)) THEN
  447. II = II + 1
  448. IF (II .LE. TLFMI(/1)) GOTO 41
  449. GOTO 42
  450. ELSE
  451. GOTO 40
  452. ENDIF
  453. 42 IF (IIMPI.EQ.1) THEN
  454. WRITE (*,*) 'Point milieu : ', IPTDP.TPOIM(IP)
  455. WRITE (*,*) ' Point fissure : ', IPTDP.TPFIS(IP)
  456. WRITE (*,*) ' Point extreme : ', IPTDP.TPOIE(IP)
  457. ENDIF
  458. ALPE = 0.5*(ALPHA - 1.)*ALPHA
  459. ALPM = (1. - ALPHA)*(ALPHA + 1)
  460. ALPF = 0.5*ALPHA*(ALPHA + 1.)
  461. IRPF = (IDIM + 1)*(IPTDP.TPFIS(IP) - 1)
  462. IRPM = (IDIM + 1)*(IPTDP.TPOIM(IP) - 1)
  463. IRPE = (IDIM + 1)*(IPTDP.TPOIE(IP) - 1)
  464. DO 43 IC = 1, IDIM
  465. XCOOR(IRPM + IC) = ALPF*XCOOR(IRPF + IC) +
  466. # ALPM*XCOOR(IRPM + IC) + ALPE*XCOOR(IRPE + IC)
  467. 43 CONTINUE
  468. 40 CONTINUE
  469. IF (IIMPI.EQ.1) THEN
  470. WRITE (*,*) IPTDP.TPOIM(/1), ' noeuds déplacés.'
  471. ENDIF
  472. SEGDES, IPTDP
  473. SEGDES, PTMIL
  474. *------------------------------------------------------------------------*
  475. * Suppression des segments temporaires *
  476. *------------------------------------------------------------------------*
  477. SEGSUP, IPTDP
  478. SEGSUP, PTDEP
  479. SEGSUP, PTMIL
  480. SEGSUP, PTFIS
  481. SEGSUP, ELMDP
  482. *
  483. RETURN
  484. END
  485.  
  486.  
  487.  
  488.  
  489.  
  490.  
  491.  

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