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

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