Télécharger genjo3.eso

Retour à la liste

Numérotation des lignes :

  1. C GENJO3 SOURCE BP208322 16/11/18 21:17:21 9177
  2. SUBROUTINE GENJO3
  3. C--------------------------------------------------------------------
  4. C
  5. C MAIL1 = GENJ MAIL2 FLOT1;
  6. C
  7. C MAIL1 : MAILLAGE DE JOT3 OU JOI4
  8. C MAIL2 : MAILLAGE DE CUB8, PRI6, PYR5 ET/OU TET4
  9. C FLOT1 : TOLERANCE
  10. C
  11. C Pierre Pegon/JRC Ispra
  12. C--------------------------------------------------------------------
  13. IMPLICIT INTEGER(I-N)
  14. IMPLICIT REAL*8 (A-H,O-Z)
  15. C
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. -INC SMCOORD
  19. -INC CCGEOME
  20. -INC SMLENTI
  21. -INC SMLREEL
  22. C
  23. SEGMENT,JO4GEN
  24. INTEGER P4(4,NCOT4)
  25. INTEGER SZ4(NCOT4), NELM4(NCOT4)
  26. INTEGER FLA4(NCOT4)
  27. ENDSEGMENT
  28. POINTEUR JO4GE1.JO4GEN
  29. C
  30. SEGMENT,JO3GEN
  31. INTEGER P3(3,NCOT3)
  32. INTEGER SZ3(NCOT3), NELM3(NCOT3)
  33. INTEGER FLA3(NCOT3)
  34. ENDSEGMENT
  35. POINTEUR JO3GE1.JO3GEN
  36. C
  37. LOGICAL GENTST
  38. DIMENSION FAC1(3,4),FAC2(3,4),BAR1(3),BAR2(3)
  39. C
  40. IF(IIMPI.EQ.1790)THEN
  41. WRITE(IOIMP,*)'GENJO3: On entre dans la subroutine'
  42. ENDIF
  43. C
  44. CALL LIROBJ('MAILLAGE',IPT1,1,IRET)
  45. IF(IERR.NE.0) RETURN
  46. CALL LIRREE(XTOL,1,IRET)
  47. IF(IERR.NE.0) RETURN
  48. XTOL2=XTOL**2
  49. C
  50. C VERIFICATION DE LA DIMENSION
  51. C
  52. IF (IDIM.NE.3)THEN
  53. WRITE(IOIMP,*)'GENJO3: on n"est pas en 3D'
  54. RETURN
  55. ENDIF
  56. C
  57. C VERIFICATION DES TYPES D'ELEMENT (POUR LE MOMENT CUB8, PRI6,
  58. C PYR5 ET TET4)
  59. C ET CALCUL DU NOMBRE DE COTES
  60. C
  61. NCOT4=0
  62. NCOT3=0
  63. SEGACT,IPT1
  64. NBSOUS=IPT1.LISOUS(/1)
  65. DO IE1=1,MAX(NBSOUS,1)
  66. IF(NBSOUS.EQ.0)THEN
  67. MELEME=IPT1
  68. ELSE
  69. MELEME=IPT1.LISOUS(IE1)
  70. SEGACT,MELEME
  71. ENDIF
  72. ILC=ITYPEL
  73. IF(ILC.NE.14.AND.ILC.NE.16.AND.ILC.NE.23.AND.ILC.NE.25)THEN
  74. WRITE(IOIMP,*)'GENJO3: type d"element incorrect'
  75. SEGDES,MELEME*NOMOD
  76. RETURN
  77. ELSE
  78. NBELEM=ICOLOR(/1)
  79. IF(ILC.EQ.23)THEN
  80. NCOT3=NCOT3+4*NBELEM
  81. ELSEIF(ILC.EQ.14)THEN
  82. NCOT4=NCOT4+6*NBELEM
  83. ELSEIF(ILC.EQ.16)THEN
  84. NCOT3=NCOT3+2*NBELEM
  85. NCOT4=NCOT4+3*NBELEM
  86. ELSEIF(ILC.EQ.25)THEN
  87. NCOT3=NCOT3+4*NBELEM
  88. NCOT4=NCOT4+ NBELEM
  89. ENDIF
  90. ENDIF
  91. SEGDES,MELEME*NOMOD
  92. ENDDO
  93. C
  94. IF(IIMPI.EQ.1790)THEN
  95. WRITE(IOIMP,*)'GENJO3: fin verification'
  96. ENDIF
  97. C
  98. C REMPLISSAGE DU SEGMENT DES COTES
  99. C
  100. SEGACT,IPT1
  101. SEGINI,JO3GEN,JO4GEN
  102. IJOI3=0
  103. IJOI4=0
  104. DO IE1=1,MAX(NBSOUS,1)
  105. IF(NBSOUS.EQ.0)THEN
  106. MELEME=IPT1
  107. ELSE
  108. MELEME=IPT1.LISOUS(IE1)
  109. SEGACT,MELEME
  110. ENDIF
  111. ILC=ITYPEL
  112. NBELEM=ICOLOR(/1)
  113. DO IE2=1,NBELEM
  114. IF(ILC.EQ.23)THEN
  115. CALL GF2323(P3,SZ3,NELM3,FLA3, IJOI3,3,
  116. > NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  117. ELSEIF(ILC.EQ.14)THEN
  118. CALL GF1424(P4,SZ4,NELM4,FLA4, IJOI4,4,
  119. > NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  120. ELSEIF(ILC.EQ.16)THEN
  121. CALL GF1623(P3,SZ3,NELM3,FLA3, IJOI3,3,
  122. > NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  123. CALL GF1624(P4,SZ4,NELM4,FLA4, IJOI4,4,
  124. > NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  125. ELSEIF(ILC.EQ.25)THEN
  126. CALL GF2523(P3,SZ3,NELM3,FLA3, IJOI3,3,
  127. > NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  128. CALL GF2524(P4,SZ4,NELM4,FLA4, IJOI4,4,
  129. > NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
  130. ENDIF
  131. ENDDO
  132. ENDDO
  133. C
  134. IF(IIMPI.EQ.1790)THEN
  135. WRITE(IOIMP,*)'GENJO3: fin remplissage'
  136. ENDIF
  137. C
  138. C ELIMINATION DES DOUBLONS A NOEUDS IDENTIQUES
  139. C
  140. IF(NCOT3.GT.0)THEN
  141. JG=NCOT3
  142. SEGINI,MLENTI,MLENT1
  143. DO IE1=1,NCOT3
  144. LECT(IE1)=IE1
  145. MLENT1.LECT(IE1)=FLA3(IE1)
  146. ENDDO
  147. CALL GENOR2(MLENT1.LECT,LECT,NCOT3)
  148. IF(IIMPI.EQ.1790)THEN
  149. WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
  150. ENDIF
  151. IFI=MLENT1.LECT(1)
  152. DO IE1=2,NCOT3
  153. IFF=MLENT1.LECT(IE1)
  154. IF(IFI.EQ.IFF)THEN
  155. JE1=LECT(IE1-1)
  156. IF(FLA3(JE1).NE.0)THEN
  157. DO IE2=IE1,NCOT3
  158. IFFF=MLENT1.LECT(IE2)
  159. IF(IFI.NE.IFFF)GOTO 30
  160. JE2=LECT(IE2)
  161. IF(FLA3(JE2).NE.0)THEN
  162. IF(GENTST(P3(1,JE1),P3(1,JE2),3))THEN
  163. FLA3(JE1)=0
  164. FLA3(JE2)=0
  165. GOTO 30
  166. ENDIF
  167. ENDIF
  168. ENDDO
  169. ENDIF
  170. ENDIF
  171. 30 IFI=IFF
  172. ENDDO
  173. SEGSUP,MLENTI,MLENT1
  174. ENDIF
  175. C
  176. IF(NCOT4.GT.0)THEN
  177. JG=NCOT4
  178. SEGINI,MLENTI,MLENT1
  179. DO IE1=1,NCOT4
  180. LECT(IE1)=IE1
  181. MLENT1.LECT(IE1)=FLA4(IE1)
  182. ENDDO
  183. CALL GENOR2(MLENT1.LECT,LECT,NCOT4)
  184. IF(IIMPI.EQ.1790)THEN
  185. WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
  186. ENDIF
  187. IFI=MLENT1.LECT(1)
  188. DO IE1=2,NCOT4
  189. IFF=MLENT1.LECT(IE1)
  190. IF(IFI.EQ.IFF)THEN
  191. JE1=LECT(IE1-1)
  192. IF(FLA4(JE1).NE.0)THEN
  193. DO IE2=IE1,NCOT4
  194. IFFF=MLENT1.LECT(IE2)
  195. IF(IFI.NE.IFFF)GOTO 40
  196. JE2=LECT(IE2)
  197. IF(FLA4(JE2).NE.0)THEN
  198. IF(GENTST(P4(1,JE1),P4(1,JE2),4))THEN
  199. FLA4(JE1)=0
  200. FLA4(JE2)=0
  201. GOTO 40
  202. ENDIF
  203. ENDIF
  204. ENDDO
  205. ENDIF
  206. ENDIF
  207. 40 IFI=IFF
  208. ENDDO
  209. SEGSUP,MLENTI,MLENT1
  210. ENDIF
  211. C
  212. IF(IIMPI.EQ.1790)THEN
  213. WRITE(IOIMP,*)'GENJO3: fin elimination des doublons'
  214. ENDIF
  215. C
  216. C CONCATENATION DES LISTES
  217. C
  218. IF (NCOT3.GT.0)THEN
  219. NNCOT3=NCOT3
  220. NCOT3=0
  221. DO IE1=1,NNCOT3
  222. IF(FLA3(IE1).NE.0)NCOT3=NCOT3+1
  223. ENDDO
  224. SEGINI,JO3GE1
  225. JE1=0
  226. DO IE1=1,NNCOT3
  227. IF(FLA3(IE1).NE.0)THEN
  228. JE1=JE1+1
  229. DO IE2=1,IDIM
  230. JO3GE1.P3(IE2,JE1)=P3(IE2,IE1)
  231. ENDDO
  232. JO3GE1.SZ3(JE1)=SZ3(IE1)
  233. JO3GE1.NELM3(JE1)=NELM3(IE1)
  234. JO3GE1.FLA3(JE1)=0
  235. ENDIF
  236. ENDDO
  237. SEGSUP,JO3GEN
  238. JO3GEN=JO3GE1
  239. ENDIF
  240. C
  241. IF (NCOT4.GT.0)THEN
  242. NNCOT4=NCOT4
  243. NCOT4=0
  244. DO IE1=1,NNCOT4
  245. IF(FLA4(IE1).NE.0)NCOT4=NCOT4+1
  246. ENDDO
  247. SEGINI,JO4GE1
  248. JE1=0
  249. DO IE1=1,NNCOT4
  250. IF(FLA4(IE1).NE.0)THEN
  251. JE1=JE1+1
  252. DO IE2=1,4
  253. JO4GE1.P4(IE2,JE1)=P4(IE2,IE1)
  254. ENDDO
  255. JO4GE1.SZ4(JE1)=SZ4(IE1)
  256. JO4GE1.NELM4(JE1)=NELM4(IE1)
  257. JO4GE1.FLA4(JE1)=0
  258. ENDIF
  259. ENDDO
  260. SEGSUP,JO4GEN
  261. JO4GEN=JO4GE1
  262. ENDIF
  263. C
  264. IF(IIMPI.EQ.1790)THEN
  265. WRITE(IOIMP,*)'GENJO3: fin concatenation'
  266. ENDIF
  267. C
  268. C DETERMINATION DES SEGMENTS AVEC VIS-A-VIS
  269. C
  270. IRET=0
  271. IF(NCOT3.GT.1)THEN
  272. JG=NCOT3
  273. SEGINI,MLENTI,MLREEL
  274. DO IE1=1,NCOT3
  275. LECT(IE1)=IE1
  276. DO IE2=1,IDIM
  277. BAR1(IE2)=0.D0
  278. ENDDO
  279. DO IE2=1,3
  280. IPR1=(IDIM+1)*(P3(IE2,IE1)-1)
  281. DO IE3=1,IDIM
  282. BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3)
  283. ENDDO
  284. ENDDO
  285. PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/3
  286. ENDDO
  287. CALL GENOS2(PROG,LECT,NCOT3&'4;
  288. IF(IIMPI.EQ.1790)THEN
  289. WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
  290. ENDIF
  291. XFI=PROG(1)
  292. DO IE1=2,NCOT3
  293. XFF=PROG(IE1)
  294. IF(ABS(XFI-XFF).LT.XTOL)THEN
  295. JE1=LECT(IE1-1)
  296. IF(FLA3(JE1).EQ.0)THEN
  297. DO IE2=1,IDIM
  298. BAR1(IE2)=0.D0
  299. ENDDO
  300. DO IE2=1,3
  301. IPR1=(IDIM+1)*(P3(IE2,JE1)-1)
  302. DO IE3=1,IDIM
  303. FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
  304. BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2)
  305. ENDDO
  306. ENDDO
  307. DO IE2=IE1,NCOT3
  308. XFFF=PROG(IE2)
  309. IF(ABS(XFI-XFFF).GE.XTOL)GOTO 31
  310. JE2=LECT(IE2)
  311. IF(FLA3(JE2).EQ.0)THEN
  312. DO IE3=1,IDIM
  313. BAR2(IE3)=0.D0
  314. ENDDO
  315. DO IE3=1,3
  316. IPR2=(IDIM+1)*(P3(IE3,JE2)-1)
  317. DO IE4=1,IDIM
  318. FAC2(IE4,IE3)=XCOOR(IPR2+IE4)
  319. BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3)
  320. ENDDO
  321. ENDDO
  322. DIS12=0.D0
  323. DO IE3=1,IDIM
  324. DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2
  325. ENDDO
  326. DIS12=DIS12/9
  327. IF(DIS12.LT.XTOL2)THEN
  328. FLA3(JE1)=JE2
  329. FLA3(JE2)=JE1
  330. CALL GENRD1(FAC1,FAC2,P3(1,JE2),3,XTOL2,IRET)
  331. IF(IRET.NE.0)GOTO 9999
  332. GOTO 31
  333. ENDIF
  334. ENDIF
  335. ENDDO
  336. ENDIF
  337. ENDIF
  338. 31 XFI=XFF
  339. ENDDO
  340. SEGSUP,MLREEL,MLENTI
  341. ENDIF
  342. C
  343. IRET=0
  344. IF(NCOT4.GT.1)THEN
  345. JG=NCOT4
  346. SEGINI,MLENTI,MLREEL
  347. DO IE1=1,NCOT4
  348. LECT(IE1)=IE1
  349. DO IE2=1,IDIM
  350. BAR1(IE2)=0.D0
  351. ENDDO
  352. DO IE2=1,4
  353. IPR1=(IDIM+1)*(P4(IE2,IE1)-1)
  354. DO IE3=1,IDIM
  355. BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3)
  356. ENDDO
  357. ENDDO
  358. PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/4
  359. ENDDO
  360. CALL GENOS2(PROG,LECT,NCOT4)
  361. IF(IIMPI.EQ.1790)THEN
  362. WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
  363. ENDIF
  364. XFI=PROG(1)
  365. DO IE1=2,NCOT4
  366. XFF=PROG(IE1)
  367. IF(ABS(XFI-XFF).LT.XTOL)THEN
  368. JE1=LECT(IE1-1)
  369. IF(FLA4(JE1).EQ.0)THEN
  370. DO IE2=1,IDIM
  371. BAR1(IE2)=0.D0
  372. ENDDO
  373. DO IE2=1,4
  374. IPR1=(IDIM+1)*(P4(IE2,JE1)-1)
  375. DO IE3=1,IDIM
  376. FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
  377. BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2)
  378. ENDDO
  379. ENDDO
  380. DO IE2=IE1,NCOT4
  381. XFFF=PROG(IE2)
  382. IF(ABS(XFI-XFFF).GE.XTOL)GOTO 41
  383. JE2=LECT(IE2)
  384. IF(FLA4(JE2).EQ.0)THEN
  385. DO IE3=1,IDIM
  386. BAR2(IE3)=0.D0
  387. ENDDO
  388. DO IE3=1,4
  389. IPR2=(IDIM+1)*(P4(IE3,JE2)-1)
  390. DO IE4=1,IDIM
  391. FAC2(IE4,IE3)=XCOOR(IPR2+IE4)
  392. BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3)
  393. ENDDO
  394. ENDDO
  395. DIS12=0.D0
  396. DO IE3=1,IDIM
  397. DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2
  398. ENDDO
  399. DIS12=DIS12/16
  400. IF(DIS12.LT.XTOL2)THEN
  401. FLA4(JE1)=JE2
  402. FLA4(JE2)=JE1
  403. CALL GENRD1(FAC1,FAC2,P4(1,JE2),4,XTOL2,IRET)
  404. IF(IRET.NE.0)GOTO 9999
  405. GOTO 41
  406. ENDIF
  407. ENDIF
  408. ENDDO
  409. ENDIF
  410. ENDIF
  411. 41 XFI=XFF
  412. ENDDO
  413. SEGSUP,MLREEL,MLENTI
  414. ENDIF
  415. C
  416. IF(IIMPI.EQ.1790)THEN
  417. WRITE(IOIMP,*)'GENJO3: fin determination des vis-a-vis'
  418. ENDIF
  419. C
  420. C CREATION DU/DES MAILLAGE(S) DE JOINT
  421. C
  422. NBREF=0
  423. NBSOUS=0
  424. NBELEM=0
  425. DO IE1=1,NCOT3
  426. IF(FLA3(IE1).NE.0)NBELEM=NBELEM+1
  427. ENDDO
  428. NBELEM=NBELEM/2
  429. IF(NBELEM.NE.0)THEN
  430. NBNN=6
  431. SEGINI,MELEME
  432. ITYPEL=18
  433. DO IE1=1,NBELEM
  434. ICOLOR(IE1)=0
  435. ENDDO
  436. IPT3=MELEME
  437. ELSE
  438. IPT3=0
  439. ENDIF
  440. C
  441. NBELEM=0
  442. DO IE1=1,NCOT4
  443. IF(FLA4(IE1).NE.0)NBELEM=NBELEM+1
  444. ENDDO
  445. NBELEM=NBELEM/2
  446. IF(NBELEM.NE.0)THEN
  447. NBNN=8
  448. SEGINI,MELEME
  449. ITYPEL=19
  450. DO IE1=1,NBELEM
  451. ICOLOR(IE1)=0
  452. ENDDO
  453. IPT4=MELEME
  454. ELSE
  455. IPT4=0
  456. ENDIF
  457. C
  458. IF(IPT3*IPT4.EQ.0)THEN
  459. IF(IPT3.EQ.0.AND.IPT4.EQ.0)THEN
  460. WRITE(IOIMP,*)'GENJO3: aucun joint cree'
  461. GOTO 9999
  462. ELSEIF(IPT3.NE.0)THEN
  463. IPT2=IPT3
  464. ELSE
  465. IPT2=IPT4
  466. ENDIF
  467. ELSE
  468. NBSOUS=2
  469. NBNN=0
  470. NBELEM=0
  471. SEGINI,MELEME
  472. LISOUS(1)=IPT3
  473. LISOUS(2)=IPT4
  474. IPT2=MELEME
  475. SEGDES,MELEME
  476. ENDIF
  477. C
  478. IF(IIMPI.EQ.1790)THEN
  479. WRITE(IOIMP,*)'GENJO3: fin creation maillage'
  480. ENDIF
  481. C
  482. C GENERATION DU/DES MAILLAGE(S) DE JOINT
  483. C
  484. IF(IPT3.NE.0)THEN
  485. IELEM=0
  486. DO IE1=1,NCOT3
  487. IF(FLA3(IE1).NE.0)THEN
  488. IELEM=IELEM+1
  489. *
  490. * premier barycentre
  491. *
  492. DO IE2=1,IDIM
  493. BAR1(IE2)=0.D0
  494. ENDDO
  495. IF(SZ3(IE1).EQ.0)THEN
  496. MELEME=IPT1
  497. ELSE
  498. MELEME=IPT1.LISOUS(SZ3(IE1))
  499. ENDIF
  500. NBNN=NUM(/1)
  501. DO IE3=1,NBNN
  502. IPDUM=(IDIM+1)*(NUM(IE3,NELM3(IE1))-1)
  503. DO IE4=1,IDIM
  504. BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4)
  505. ENDDO
  506. ENDDO
  507. DO IE2=1,IDIM
  508. BAR1(IE2)=BAR1(IE2)/NBNN
  509. ENDDO
  510. *
  511. * Chargement de la premiere face
  512. *
  513. DO IE2=1,3
  514. IPR1=(IDIM+1)*(P3(IE2,IE1)-1)
  515. DO IE3=1,IDIM
  516. FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
  517. ENDDO
  518. ENDDO
  519. *
  520. * second barycentre
  521. *
  522. JE1=FLA3(IE1)
  523. DO IE2=1,IDIM
  524. BAR2(IE2)=0.D0
  525. ENDDO
  526. IF(SZ3(JE1).EQ.0)THEN
  527. MELEME=IPT1
  528. ELSE
  529. MELEME=IPT1.LISOUS(SZ3(JE1))
  530. ENDIF
  531. NBNN=NUM(/1)
  532. DO IE3=1,NBNN
  533. IPDUM=(IDIM+1)*(NUM(IE3,NELM3(JE1))-1)
  534. DO IE4=1,IDIM
  535. BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4)
  536. ENDDO
  537. ENDDO
  538. DO IE2=1,IDIM
  539. BAR2(IE2)=BAR2(IE2)/NBNN
  540. ENDDO
  541. *
  542. * Chargement de la seconde face
  543. *
  544. DO IE2=1,3
  545. IPR1=(IDIM+1)*(P3(IE2,JE1)-1)
  546. DO IE3=1,IDIM
  547. FAC2(IE3,IE2)=XCOOR(IPR1+IE3)
  548. ENDDO
  549. ENDDO
  550. *
  551. * On ordonne correctement les points
  552. *
  553. CALL GENRD2(FAC1,BAR1,P3(1,IE1),BAR2,P3(1,JE1),3,TOL)
  554. *
  555. * On charge le joint
  556. *
  557. DO IE2=1,3
  558. IPT3.NUM(IE2 ,IELEM)=P3(IE2,IE1)
  559. IPT3.NUM(IE2+3,IELEM)=P3(IE2,JE1)
  560. ENDDO
  561. *
  562. * on efface les 2 cotes
  563. *
  564. FLA3(IE1)=0
  565. FLA3(JE1)=0
  566. ENDIF
  567. ENDDO
  568. SEGDES,IPT3
  569. ENDIF
  570. C
  571. IF(IPT4.NE.0)THEN
  572. IELEM=0
  573. DO IE1=1,NCOT4
  574. IF(FLA4(IE1).NE.0)THEN
  575. IELEM=IELEM+1
  576. *
  577. * premier barycentre
  578. *
  579. DO IE2=1,IDIM
  580. BAR1(IE2)=0.D0
  581. ENDDO
  582. IF(SZ4(IE1).EQ.0)THEN
  583. MELEME=IPT1
  584. ELSE
  585. MELEME=IPT1.LISOUS(SZ4(IE1))
  586. ENDIF
  587. NBNN=NUM(/1)
  588. DO IE3=1,NBNN
  589. IPDUM=(IDIM+1)*(NUM(IE3,NELM4(IE1))-1)
  590. DO IE4=1,IDIM
  591. BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4)
  592. ENDDO
  593. ENDDO
  594. DO IE2=1,IDIM
  595. BAR1(IE2)=BAR1(IE2)/NBNN
  596. ENDDO
  597. *
  598. * Chargement de la premiere face
  599. *
  600. DO IE2=1,4
  601. IPR1=(IDIM+1)*(P4(IE2,IE1)-1)
  602. DO IE3=1,IDIM
  603. FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
  604. ENDDO
  605. ENDDO
  606. *
  607. * second barycentre
  608. *
  609. JE1=FLA4(IE1)
  610. DO IE2=1,IDIM
  611. BAR2(IE2)=0.D0
  612. ENDDO
  613. IF(SZ4(JE1).EQ.0)THEN
  614. MELEME=IPT1
  615. ELSE
  616. MELEME=IPT1.LISOUS(SZ4(JE1))
  617. ENDIF
  618. NBNN=NUM(/1)
  619. DO IE3=1,NBNN
  620. IPDUM=(IDIM+1)*(NUM(IE3,NELM4(JE1))-1)
  621. DO IE4=1,IDIM
  622. BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4)
  623. ENDDO
  624. ENDDO
  625. DO IE2=1,IDIM
  626. BAR2(IE2)=BAR2(IE2)/NBNN
  627. ENDDO
  628. *
  629. * Chargement de la seconde face
  630. *
  631. DO IE2=1,4
  632. IPR1=(IDIM+1)*(P4(IE2,JE1)-1)
  633. DO IE3=1,IDIM
  634. FAC2(IE3,IE2)=XCOOR(IPR1+IE3)
  635. ENDDO
  636. ENDDO
  637. *
  638. * On ordonne correctement les points
  639. *
  640. CALL GENRD2(FAC1,BAR1,P4(1,IE1),BAR2,P4(1,JE1),4,TOL)
  641. *
  642. * On charge le joint
  643. *
  644. DO IE2=1,4
  645. IPT4.NUM(IE2 ,IELEM)=P4(IE2,IE1)
  646. IPT4.NUM(IE2+4,IELEM)=P4(IE2,JE1)
  647. ENDDO
  648. *
  649. * on efface les 2 cotes
  650. *
  651. FLA4(IE1)=0
  652. FLA4(JE1)=0
  653. ENDIF
  654. ENDDO
  655. SEGDES,IPT4
  656. ENDIF
  657. C
  658. IF(IIMPI.EQ.1790)THEN
  659. WRITE(IOIMP,*)'GENJO3: fin chargement maillage'
  660. ENDIF
  661. C
  662. C DESTRUCTION, DESACTIVATION ET RETOUR A GIBIANE
  663. C
  664. CALL ECROBJ('MAILLAGE',IPT2)
  665. C
  666. 9999 SEGSUP,JO3GEN,JO4GEN
  667. C
  668. NBSOUS=IPT1.LISOUS(/1)
  669. DO IE1=1,MAX(NBSOUS,1)
  670. IF(NBSOUS.EQ.0)THEN
  671. MELEME=IPT1
  672. ELSE
  673. MELEME=IPT1.LISOUS(IE1)
  674. ENDIF
  675. SEGDES,MELEME*NOMOD
  676. ENDDO
  677. C
  678. RETURN
  679. END
  680.  
  681.  
  682.  
  683.  
  684.  
  685.  
  686.  
  687.  

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