Télécharger chang2.eso

Retour à la liste

Numérotation des lignes :

chang2
  1. C CHANG2 SOURCE BP208322 16/11/18 21:15:29 9177
  2. SUBROUTINE CHANG2(IPT1,ITY)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : CHANG2
  7. C DESCRIPTION : Change un maillage (éventuellement composite)
  8. C de QUAF en 'TRI3','TET4','QUA4','CUB8','PYR5'
  9. C
  10. C
  11. C LANGAGE : ESOPE
  12. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  13. C mél : gounand@semt2.smts.cea.fr
  14. C***********************************************************************
  15. C APPELES :
  16. C APPELES (E/S) :
  17. C APPELES (BLAS) :
  18. C APPELES (CALCUL) :
  19. C APPELE PAR :
  20. C***********************************************************************
  21. C SYNTAXE GIBIANE :
  22. C ENTREES :
  23. C ENTREES/SORTIES :
  24. C SORTIES :
  25. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  26. C***********************************************************************
  27. C VERSION : v1, 04/01/2007, version initiale
  28. C HISTORIQUE : v1, 04/01/2007, création
  29. C HISTORIQUE :
  30. C HISTORIQUE :
  31. C***********************************************************************
  32. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  33. C en cas de modification de ce sous-programme afin de faciliter
  34. C la maintenance !
  35. C***********************************************************************
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCGEOME
  40. -INC SMELEME
  41. *
  42. LOGICAL LCOMP,ltelq
  43. PARAMETER(NTYP2=5)
  44. CHARACTER*4 LTYP2(NTYP2),LTYPD2(NTYP2),LTYPD3(NTYP2),MTYP,MTYP2
  45. INTEGER S3S2(2,2),T7T3(3,4),T7Q4(4,3),Q9T3(3,8),Q9Q4(4,4)
  46. INTEGER T15T4(4,4),T15O6(6),O6T4(4,4),T15C8(8,4),T15T7(7,4)
  47. INTEGER P19H6(6,4),P19O6(6),H6T4(4,3),P19T7(7,4),P19Q9(9)
  48. INTEGER P21P6A(6,4),P21P6B(6,4),P6AT4(4,3),P6BT4(4,3)
  49. INTEGER P21C8(8,6),P21T7(7,2),P21Q9(9,3)
  50. INTEGER C27C8(8,8),C8T4(4,5),C27Q9(9,6)
  51. *
  52. DATA LTYP2 /'TRI3','TET4','QUA4','CUB8','PYR5'/
  53. DATA LTYPD2/'TRI3','TRI3','QUA4','QUA4','QUA4'/
  54. DATA LTYPD3/'TET4','TET4','CUB8','CUB8','PYR5'/
  55. * SEG3 -> 2 SEG2
  56. DATA S3S2/1,2 , 2,3/
  57. * TRI7 -> 4 TRI3
  58. DATA T7T3/1,2,6 , 2,3,4 , 6,4,5 , 2,4,6/
  59. * TRI7 -> 3 QUA4
  60. DATA T7Q4/1,2,7,6 , 2,3,4,7 , 7,4,5,6/
  61. * QUA9 -> 8 TRI3
  62. DATA Q9T3/1,2,9 , 2,3,9 , 3,4,9 , 4,5,9 ,
  63. $ 5,6,9 , 6,7,9 , 7,8,9 , 8,1,9/
  64. * QUA9 -> 4 QUA4
  65. DATA Q9Q4/1,2,9,8 , 2,3,4,9 , 9,4,5,6 , 8,9,6,7/
  66. * TE15 -> 4 TET4 + 1 OCT6
  67. DATA T15T4/1,2,6,7 , 2,3,4,8 , 4,5,6,9 , 7,8,9,10/
  68. DATA T15O6/7,2,4,9,8,6/
  69. * OCT6 -> 4 TET4
  70. DATA O6T4/1,2,6,5 , 2,3,6,5 , 3,4,6,5 , 4,1,6,5/
  71. * TE15 -> 4 CUB8
  72. DATA T15C8/1,2,11,6,7,12,15,14 , 2,3,4,11,12,8,13,15 ,
  73. $ 4,5,6,11,13,9,14,15 , 8,13,15,12,10,9,14,7/
  74. * TE15 -> 4 TRI7 (Les faces)
  75. DATA T15T7/1,7,10,8,3,2,12 , 3,8,10,9,5,4,13 ,
  76. $ 5,9,10,7,1,6,14 , 1,2,3,4,5,6,11/
  77. * PY19 -> 4 HEX6 + 1 OCT6
  78. DATA P19H6/1,2,3,14,9,10 , 3,4,5,14,10,11 ,
  79. $ 5,6,7,14,11,12 , 7,8,1,14,12,9/
  80. DATA P19O6/9,10,11,12,13,14/
  81. * HEX6 -> 3 TET4
  82. DATA H6T4/1,2,4,5 , 5,2,4,6 , 2,3,4,6/
  83. * PY19 -> 4 TRI7 (Les faces triangulaires)
  84. DATA P19T7/1,9,13,10,3,2,15 , 3,10,13,11,5,4,16 ,
  85. $ 5,11,13,12,7,6,17 , 7,12,13,9,1,8,18/
  86. * PY19 -> QUA9 (La face carrée)
  87. DATA P19Q9/1,2,3,4,5,6,7,8,14/
  88. * PR21 -> 4 PRI6 de type A
  89. DATA P21P6A/7,16,18,10,11,15 , 9,18,17,14,15,13 ,
  90. $ 7,18,16,1,6,2 , 9,17,18,5,4,6/
  91. * PR21 -> 4 PRI6 de type B
  92. DATA P21P6B/ 8,17,16,12,13,11 , 16,17,18,11,13,15 ,
  93. $ 8,16,17,3,2,4 , 2,4,6,16,17,18/
  94. Cbuggé $ 8,16,17,3,2,4 , 16,18,17,2,6,4/
  95. * PRI6 de type A -> 3 TET4
  96. DATA P6AT4/1,2,3,4 , 5,3,4,6 , 5,2,4,3/
  97. * PRI6 de type B -> 3 TET4
  98. DATA P6BT4/1,2,3,4 , 3,6,4,2 , 5,2,4,6/
  99. * PR21 -> 6 CUB8
  100. DATA P21C8/7,16,21,18,10,11,20,15 , 16,8,17,21,11,12,13,20 ,
  101. $ 21,17,9,18,20,13,14,15 , 1,2,19,6,7,16,21,18 ,
  102. $ 2,3,4,19,16,8,17,21 , 19,4,5,6,21,17,9,18/
  103. * PR21 -> 2 TRI7 (Les faces triangulaires)
  104. DATA P21T7/1,2,3,4,5,6,19 , 10,15,14,13,12,11,20/
  105. * PR21 -> 3 QUA9 (Les faces carrées)
  106. DATA P21Q9/10,11,12,8,3,2,1,7,16 , 12,13,14,9,5,4,3,8,17 ,
  107. $ 14,15,10,7,1,6,5,9,18/
  108. * CU27 -> 8 CUB8
  109. DATA C27C8/1,2,25,8,9,21,27,24 , 3,4,25,2,10,22,27,21 ,
  110. $ 5,6,25,4,11,23,27,22 , 7,8,25,6,12,24,27,23 ,
  111. $ 13,20,26,14,9,24,27,21 , 15,14,26,16,10,21,27,22 ,
  112. $ 17,16,26,18,11,22,27,23 , 19,18,26,20,12,23,27,24/
  113. * CUB8 -> 5 TET4
  114. DATA C8T4/1,2,3,6 , 3,4,1,8 , 1,6,8,5 , 6,3,8,7 , 8,6,1,3/
  115. * CU27 -> 6 QUA9 (Les faces carrées)
  116. DATA C27Q9/1,9,13,14,15,10,3,2,21 , 3,10,15,16,17,11,5,4,22 ,
  117. $ 5,11,17,18,19,12,7,6,23 , 7,12,19,20,13,9,1,8,24 ,
  118. $ 1,2,3,4,5,6,7,8,25 , 13,20,19,18,17,16,15,14,26/
  119. *
  120. * Executable statements
  121. *
  122. IMPR=0
  123. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans chang2.eso'
  124. * Numéro de l'élément à créer dans la numérotation de LTYP2
  125. CALL FIMOT2(NOMS(ITY),LTYP2,NTYP2,JTY,IMPR,IRET)
  126. IF (IRET.NE.0) GOTO 9999
  127. SEGACT IPT1
  128. NBSOUS=IPT1.LISOUS(/1)
  129. LCOMP=(NBSOUS.GE.1)
  130. IPT3=0
  131. *
  132. IF (NBSOUS.EQ.0) NBSOUS=1
  133. DO ISOUS=1,NBSOUS
  134. IF (LCOMP) THEN
  135. IPT2=IPT1.LISOUS(ISOUS)
  136. SEGACT IPT2
  137. ELSE
  138. IPT2=IPT1
  139. ENDIF
  140. ITYP=IPT2.ITYPEL
  141. MTYP=NOMS(ITYP)
  142. NBL=IPT2.NUM(/2)
  143. * NBN=IPT2.NUM(/1)
  144. IF (MTYP.EQ.'SEG3') THEN
  145. * Passage SEG3 -> 2 SEG2
  146. NBNN=2
  147. NBELEM=NBL*2
  148. NBSOUS=0
  149. NBREF=0
  150. SEGINI IPT4
  151. IPT4.ITYPEL=2
  152. IEL4=0
  153. DO IBL=1,NBL
  154. DO IL=1,2
  155. IEL4=IEL4+1
  156. DO IN=1,2
  157. IPT4.NUM(IN,IEL4)=IPT2.NUM(S3S2(IN,IL),IBL)
  158. ENDDO
  159. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  160. ENDDO
  161. ENDDO
  162. SEGDES IPT4
  163. ELSEIF (MTYP.EQ.'TRI7') THEN
  164. MTYP2=LTYPD2(JTY)
  165. IF (MTYP2.EQ.'TRI3') THEN
  166. * Passage TRI7 -> 4 TRI3
  167. NBNN=3
  168. NBELEM=NBL*4
  169. NBSOUS=0
  170. NBREF=0
  171. SEGINI IPT4
  172. IPT4.ITYPEL=4
  173. IEL4=0
  174. DO IBL=1,NBL
  175. DO IL=1,4
  176. IEL4=IEL4+1
  177. DO IN=1,3
  178. IPT4.NUM(IN,IEL4)=IPT2.NUM(T7T3(IN,IL),IBL)
  179. ENDDO
  180. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  181. ENDDO
  182. ENDDO
  183. SEGDES IPT4
  184. ELSEIF (MTYP2.EQ.'QUA4') THEN
  185. * Passage TRI7 -> 3 QUA4
  186. NBNN=4
  187. NBELEM=NBL*3
  188. NBSOUS=0
  189. NBREF=0
  190. SEGINI IPT4
  191. IPT4.ITYPEL=8
  192. IEL4=0
  193. DO IBL=1,NBL
  194. DO IL=1,3
  195. IEL4=IEL4+1
  196. DO IN=1,4
  197. IPT4.NUM(IN,IEL4)=IPT2.NUM(T7Q4(IN,IL),IBL)
  198. ENDDO
  199. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  200. ENDDO
  201. ENDDO
  202. SEGDES IPT4
  203. ELSE
  204. GOTO 9998
  205. ENDIF
  206. ELSEIF (MTYP.EQ.'QUA9') THEN
  207. MTYP2=LTYPD2(JTY)
  208. IF (MTYP2.EQ.'TRI3') THEN
  209. * Passage QUA9 -> 8 TRI3
  210. NBNN=3
  211. NBELEM=NBL*8
  212. NBSOUS=0
  213. NBREF=0
  214. SEGINI IPT4
  215. IPT4.ITYPEL=4
  216. IEL4=0
  217. DO IBL=1,NBL
  218. DO IL=1,8
  219. IEL4=IEL4+1
  220. DO IN=1,3
  221. IPT4.NUM(IN,IEL4)=IPT2.NUM(Q9T3(IN,IL),IBL)
  222. ENDDO
  223. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  224. ENDDO
  225. ENDDO
  226. SEGDES IPT4
  227. ELSEIF (MTYP2.EQ.'QUA4') THEN
  228. * Passage QUA9 -> 4 QUA4
  229. NBNN=4
  230. NBELEM=NBL*4
  231. NBSOUS=0
  232. NBREF=0
  233. SEGINI IPT4
  234. IPT4.ITYPEL=8
  235. IEL4=0
  236. DO IBL=1,NBL
  237. DO IL=1,4
  238. IEL4=IEL4+1
  239. DO IN=1,4
  240. IPT4.NUM(IN,IEL4)=IPT2.NUM(Q9Q4(IN,IL),IBL)
  241. ENDDO
  242. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  243. ENDDO
  244. ENDDO
  245. SEGDES IPT4
  246. ELSE
  247. GOTO 9998
  248. ENDIF
  249. ELSEIF (MTYP.EQ.'TE15') THEN
  250. MTYP2=LTYPD3(JTY)
  251. IF (MTYP2.EQ.'TET4') THEN
  252. * Passage TE15 -> 8 TET4
  253. NBNN=4
  254. NBELEM=NBL*8
  255. NBSOUS=0
  256. NBREF=0
  257. SEGINI IPT4
  258. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  259. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  260. CALL ERREUR(5)
  261. RETURN
  262. ENDIF
  263. IPT4.ITYPEL=ITYP2
  264. IEL4=0
  265. DO IBL=1,NBL
  266. * D'abord les 4TET4 des coins
  267. DO IL=1,4
  268. IEL4=IEL4+1
  269. DO IN=1,4
  270. IPT4.NUM(IN,IEL4)=IPT2.NUM(T15T4(IN,IL),IBL)
  271. ENDDO
  272. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  273. ENDDO
  274. * Puis l'octaèdre du milieu
  275. DO IL=1,4
  276. IEL4=IEL4+1
  277. DO IN=1,4
  278. IPT4.NUM(IN,IEL4)=
  279. $ IPT2.NUM(T15O6(O6T4(IN,IL)),IBL)
  280. ENDDO
  281. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  282. ENDDO
  283. ENDDO
  284. SEGDES IPT4
  285. ELSEIF (MTYP2.EQ.'CUB8') THEN
  286. * Passage TE15 -> 4 CUB8
  287. NBNN=8
  288. NBELEM=NBL*4
  289. NBSOUS=0
  290. NBREF=0
  291. SEGINI IPT4
  292. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  293. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  294. CALL ERREUR(5)
  295. RETURN
  296. ENDIF
  297. IPT4.ITYPEL=ITYP2
  298. IEL4=0
  299. DO IBL=1,NBL
  300. DO IL=1,4
  301. IEL4=IEL4+1
  302. DO IN=1,8
  303. IPT4.NUM(IN,IEL4)=IPT2.NUM(T15C8(IN,IL),IBL)
  304. ENDDO
  305. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  306. ENDDO
  307. ENDDO
  308. SEGDES IPT4
  309. ELSEIF (MTYP2.EQ.'PYR5') THEN
  310. * Passage TE15 -> 12 PYR5
  311. NBNN=5
  312. NBELEM=NBL*12
  313. NBSOUS=0
  314. NBREF=0
  315. SEGINI IPT4
  316. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  317. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  318. CALL ERREUR(5)
  319. RETURN
  320. ENDIF
  321. IPT4.ITYPEL=ITYP2
  322. IEL4=0
  323. DO IBL=1,NBL
  324. DO IL=1,4
  325. DO IL2=1,3
  326. IEL4=IEL4+1
  327. DO IN=1,4
  328. IPT4.NUM(IN,IEL4)=
  329. $ IPT2.NUM(T15T7(T7Q4(IN,IL2),IL),IBL)
  330. ENDDO
  331. IPT4.NUM(5,IEL4)=IPT2.NUM(15,IBL)
  332. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  333. ENDDO
  334. ENDDO
  335. ENDDO
  336. SEGDES IPT4
  337. ELSE
  338. GOTO 9998
  339. ENDIF
  340. ELSEIF (MTYP.EQ.'PY19') THEN
  341. MTYP2=LTYPD3(JTY)
  342. IF (MTYP2.EQ.'TET4') THEN
  343. * Passage PY19 -> 16 TET4
  344. NBNN=4
  345. NBELEM=NBL*16
  346. NBSOUS=0
  347. NBREF=0
  348. SEGINI IPT4
  349. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  350. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  351. CALL ERREUR(5)
  352. RETURN
  353. ENDIF
  354. IPT4.ITYPEL=ITYP2
  355. IEL4=0
  356. DO IBL=1,NBL
  357. * D'abord les 4 HEX6 des coins
  358. DO IL=1,4
  359. DO IL2=1,3
  360. IEL4=IEL4+1
  361. DO IN=1,4
  362. IPT4.NUM(IN,IEL4)=
  363. $ IPT2.NUM(P19H6(H6T4(IN,IL2),IL),IBL)
  364. ENDDO
  365. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  366. ENDDO
  367. ENDDO
  368. * Puis l'octaèdre du milieu
  369. DO IL=1,4
  370. IEL4=IEL4+1
  371. DO IN=1,4
  372. IPT4.NUM(IN,IEL4)=
  373. $ IPT2.NUM(P19O6(O6T4(IN,IL)),IBL)
  374. ENDDO
  375. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  376. ENDDO
  377. ENDDO
  378. SEGDES IPT4
  379. ELSEIF (MTYP2.EQ.'PYR5') THEN
  380. * Passage PY19 -> 16 PYR5
  381. NBNN=5
  382. NBELEM=NBL*16
  383. NBSOUS=0
  384. NBREF=0
  385. SEGINI IPT4
  386. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  387. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  388. CALL ERREUR(5)
  389. RETURN
  390. ENDIF
  391. IPT4.ITYPEL=ITYP2
  392. IEL4=0
  393. DO IBL=1,NBL
  394. * Les faces triangulaires
  395. DO IL=1,4
  396. DO IL2=1,3
  397. IEL4=IEL4+1
  398. DO IN=1,4
  399. IPT4.NUM(IN,IEL4)=
  400. $ IPT2.NUM(P19T7(T7Q4(IN,IL2),IL),IBL)
  401. ENDDO
  402. IPT4.NUM(5,IEL4)=IPT2.NUM(19,IBL)
  403. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  404. ENDDO
  405. ENDDO
  406. * La face carrée
  407. DO IL=1,4
  408. IEL4=IEL4+1
  409. DO IN=1,4
  410. IPT4.NUM(IN,IEL4)=
  411. $ IPT2.NUM(P19Q9(Q9Q4(IN,IL)),IBL)
  412. ENDDO
  413. IPT4.NUM(5,IEL4)=IPT2.NUM(19,IBL)
  414. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  415. ENDDO
  416. ENDDO
  417. SEGDES IPT4
  418. ELSE
  419. GOTO 9998
  420. ENDIF
  421. ELSEIF (MTYP.EQ.'PR21') THEN
  422. MTYP2=LTYPD3(JTY)
  423. IF (MTYP2.EQ.'TET4') THEN
  424. * Passage PR21 -> 24 TET4
  425. NBNN=4
  426. NBELEM=NBL*24
  427. NBSOUS=0
  428. NBREF=0
  429. SEGINI IPT4
  430. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  431. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  432. CALL ERREUR(5)
  433. RETURN
  434. ENDIF
  435. IPT4.ITYPEL=ITYP2
  436. IEL4=0
  437. DO IBL=1,NBL
  438. * D'abord les 4 PRI6 de type A
  439. DO IL=1,4
  440. DO IL2=1,3
  441. IEL4=IEL4+1
  442. DO IN=1,4
  443. IPT4.NUM(IN,IEL4)=
  444. $ IPT2.NUM(P21P6A(P6AT4(IN,IL2),IL),IBL)
  445. ENDDO
  446. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  447. ENDDO
  448. ENDDO
  449. * Puis les 4 PRI6 de type B
  450. DO IL=1,4
  451. DO IL2=1,3
  452. IEL4=IEL4+1
  453. DO IN=1,4
  454. IPT4.NUM(IN,IEL4)=
  455. $ IPT2.NUM(P21P6B(P6BT4(IN,IL2),IL),IBL)
  456. ENDDO
  457. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  458. ENDDO
  459. ENDDO
  460. ENDDO
  461. SEGDES IPT4
  462. ELSEIF (MTYP2.EQ.'CUB8') THEN
  463. * Passage PR21 -> 6 CUB8
  464. NBNN=8
  465. NBELEM=NBL*6
  466. NBSOUS=0
  467. NBREF=0
  468. SEGINI IPT4
  469. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  470. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  471. CALL ERREUR(5)
  472. RETURN
  473. ENDIF
  474. IPT4.ITYPEL=ITYP2
  475. IEL4=0
  476. DO IBL=1,NBL
  477. DO IL=1,6
  478. IEL4=IEL4+1
  479. DO IN=1,8
  480. IPT4.NUM(IN,IEL4)=IPT2.NUM(P21C8(IN,IL),IBL)
  481. ENDDO
  482. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  483. ENDDO
  484. ENDDO
  485. SEGDES IPT4
  486. ELSEIF (MTYP2.EQ.'PYR5') THEN
  487. * Passage PR21 -> 18 PYR5
  488. NBNN=5
  489. NBELEM=NBL*18
  490. NBSOUS=0
  491. NBREF=0
  492. SEGINI IPT4
  493. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  494. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  495. CALL ERREUR(5)
  496. RETURN
  497. ENDIF
  498. IPT4.ITYPEL=ITYP2
  499. IEL4=0
  500. DO IBL=1,NBL
  501. * Les faces triangulaires
  502. DO IL=1,2
  503. DO IL2=1,3
  504. IEL4=IEL4+1
  505. DO IN=1,4
  506. IPT4.NUM(IN,IEL4)=
  507. $ IPT2.NUM(P21T7(T7Q4(IN,IL2),IL),IBL)
  508. ENDDO
  509. IPT4.NUM(5,IEL4)=IPT2.NUM(21,IBL)
  510. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  511. ENDDO
  512. ENDDO
  513. * Les faces carrées
  514. DO IL=1,3
  515. DO IL2=1,4
  516. IEL4=IEL4+1
  517. DO IN=1,4
  518. IPT4.NUM(IN,IEL4)=
  519. $ IPT2.NUM(P21Q9(Q9Q4(IN,IL2),IL),IBL)
  520. ENDDO
  521. IPT4.NUM(5,IEL4)=IPT2.NUM(21,IBL)
  522. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  523. ENDDO
  524. ENDDO
  525. ENDDO
  526. SEGDES IPT4
  527. ELSE
  528. GOTO 9998
  529. ENDIF
  530. ELSEIF (MTYP.EQ.'CU27') THEN
  531. MTYP2=LTYPD3(JTY)
  532. IF (MTYP2.EQ.'TET4') THEN
  533. * Passage CU27 -> 40 TET4
  534. NBNN=4
  535. NBELEM=NBL*40
  536. NBSOUS=0
  537. NBREF=0
  538. SEGINI IPT4
  539. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  540. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  541. CALL ERREUR(5)
  542. RETURN
  543. ENDIF
  544. IPT4.ITYPEL=ITYP2
  545. IEL4=0
  546. DO IBL=1,NBL
  547. DO IL=1,8
  548. DO IL2=1,5
  549. IEL4=IEL4+1
  550. DO IN=1,4
  551. IPT4.NUM(IN,IEL4)=
  552. $ IPT2.NUM(C27C8(C8T4(IN,IL2),IL),IBL)
  553. ENDDO
  554. ENDDO
  555. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  556. ENDDO
  557. ENDDO
  558. SEGDES IPT4
  559. ELSEIF (MTYP2.EQ.'CUB8') THEN
  560. * Passage CU27 -> 8 CUB8
  561. NBNN=8
  562. NBELEM=NBL*8
  563. NBSOUS=0
  564. NBREF=0
  565. SEGINI IPT4
  566. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  567. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  568. CALL ERREUR(5)
  569. RETURN
  570. ENDIF
  571. IPT4.ITYPEL=ITYP2
  572. IEL4=0
  573. DO IBL=1,NBL
  574. DO IL=1,8
  575. IEL4=IEL4+1
  576. DO IN=1,8
  577. IPT4.NUM(IN,IEL4)=IPT2.NUM(C27C8(IN,IL),IBL)
  578. ENDDO
  579. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  580. ENDDO
  581. ENDDO
  582. SEGDES IPT4
  583. ELSEIF (MTYP2.EQ.'PYR5') THEN
  584. * Passage CU27 -> 24 PYR5
  585. NBNN=5
  586. NBELEM=NBL*24
  587. NBSOUS=0
  588. NBREF=0
  589. SEGINI IPT4
  590. CALL FIMOT2(MTYP2,NOMS,NOMBR,ITYP2,0,IRET)
  591. IF ((IRET.NE.0).OR.ITYP2.EQ.0) THEN
  592. CALL ERREUR(5)
  593. RETURN
  594. ENDIF
  595. IPT4.ITYPEL=ITYP2
  596. IEL4=0
  597. DO IBL=1,NBL
  598. DO IL=1,6
  599. DO IL2=1,4
  600. IEL4=IEL4+1
  601. DO IN=1,4
  602. IPT4.NUM(IN,IEL4)=
  603. $ IPT2.NUM(C27Q9(Q9Q4(IN,IL2),IL),IBL)
  604. ENDDO
  605. IPT4.NUM(5,IEL4)=IPT2.NUM(27,IBL)
  606. IPT4.ICOLOR(IEL4)=IPT2.ICOLOR(IBL)
  607. ENDDO
  608. ENDDO
  609. ENDDO
  610. SEGDES IPT4
  611. ELSE
  612. GOTO 9998
  613. ENDIF
  614. ELSE
  615. GOTO 9998
  616. ENDIF
  617. *
  618. IF (LCOMP) SEGDES IPT2
  619. IF (IPT3.EQ.0) THEN
  620. IPT3=IPT4
  621. ELSE
  622. ltelq=.false.
  623. CALL FUSE(IPT3,IPT4,IPT5,ltelq)
  624. IPT3=IPT5
  625. ENDIF
  626. *
  627. ENDDO
  628. SEGDES IPT1
  629. *
  630.  
  631. IPT1=IPT3
  632. *
  633. * Normal termination
  634. *
  635. IRET=0
  636. RETURN
  637. *
  638. * Format handling
  639. *
  640. *
  641. * Error handling
  642. *
  643. * 995 2
  644. *On ne sait pas changer des éléments %m1:4 en élément %m5:8
  645. 9998 CONTINUE
  646. MOTERR(1:4)=MTYP
  647. MOTERR(5:8)=NOMS(ITY)
  648. CALL ERREUR(995)
  649. RETURN
  650. 9999 CONTINUE
  651. IRET=1
  652. WRITE(IOIMP,*) 'An error was detected in subroutine chang2'
  653. RETURN
  654. *
  655. * End of subroutine CHANG2
  656. *
  657. END
  658.  
  659.  
  660.  
  661.  
  662.  
  663.  

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