Télécharger regene.eso

Retour à la liste

Numérotation des lignes :

  1. C REGENE SOURCE BP208322 16/11/18 21:20:47 9177
  2. SUBROUTINE REGENE ( IPTT )
  3. IMPLICIT INTEGER(I-N)
  4. -INC CCOPTIO
  5. -INC SMELEME
  6. -INC CCGEOME
  7. SEGMENT INOU(0)
  8. PARAMETER ( NKNE1=292)
  9. PARAMETER ( NKNE2=121)
  10. PARAMETER ( NKNEL=NKNE1+NKNE2)
  11. DIMENSION KNEL1(NKNE1),KNEL2(NKNE2),KNEL(NKNEL)
  12. EQUIVALENCE ( KNEL(1),kNEL1(1)),(KNEL(293),KNEL2(1))
  13. DIMENSION KST(26),KPS1(2,26),KS1(2,45),KPI1(45) ,KPS2(2,26)
  14. DIMENSION KSTT(6) ,KS2(2,38),KPI2(38)
  15. logical ltelq,FLNOVE
  16. C
  17. C KST DONNE LE SOUS TYPE , KPS1(1, ) DONNE LE NB DE SEGMENT A TESTER
  18. C KPS1(2, ) DONNE LA PLACE DANS LE TABLEAU KS1(KPS1(2,1) = 1)
  19. C KS1(2, ) DONNE LES SEGMENTS A TESTER,KPI1(NKS1) SI NEGATIF DIT OU SE
  20. C METTRE DANS KNEL POUR FABRIQUER LE NOUVEL ELEMENT SI POSITIF DIT OU S
  21. C POSITIONNER DANS KPS2 POUR TESTS COMPLEMENTAIRES
  22. C
  23. c CREATION : ???
  24. C #2204 chat, 1996/07/01 : regeneration des prismes en tetra et pyramides
  25. c # bp, 2013/02/05 : SEG2->POI1 + ajout commentaires + ajout verif
  26. c
  27. c rem : tout n'est pas possible, car on peut obtenir des polygones et
  28. c polyhedres inconnu dans castem (ex.1 : qua4 avec 1 point sur l'axe
  29. c + volu rota -> on obtient un polyhedre à 7 noeuds // ex.2: pri6 avec
  30. c seulement noeud 1 = noeud 2 -> polyhedre à 5 noeuds avec 2 faces tri3
  31. c et 2 faces qua4)
  32. c
  33. C rappel de numgeo : ITYPEL=
  34. c 1 POI1, 2 SEG2, 3 SEG3, 4 TRI3, 5 TRI4, 6 TRI6, 7 TRI7,
  35. c 8 QUA4, 9 QUA5, 10 QUA8, 11 QUA9, 12 RAC2, 13 RAC3,
  36. c 14 CUB8, 15 CU20, 16 PRI6, 17 PR15, 18 LIA3, 19 LIA4, 20 LIA6, 21 LIA8,
  37. c 22 MULT, 23 TET4, 24 TE10, 25 PYR5, 26 PY13, ...
  38.  
  39. C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
  40. DATA KST/0,1,2,2,2,3,3,4,4,6 ,6 , 0, 0,16,17,-1,-4,
  41. # 0,0,0,0,0,0,0,0,0/
  42. DATA KSTT/2,23,25,2,24,26/
  43. C 1 2 3 4 5 6 7 8 9 10 11 12 13
  44. DATA KPS1/0,0,1,45,2,33,3,1,3,1,3,4,3,4,4,7,4,7,4,11,4,11,0,0,0,0,
  45. C 14 15 16 17 18 19 20 21 22 23 24 25 26
  46. # 9,15,9,24,5,35,5,40,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
  47. c 1 4 7 11
  48. DATA KS1/1,2,1,3,2,3, 1,3,1,5,3,5, 1,2,1,4,2,3,3,4, 1,3,1,7,3,5,
  49. c 15 24
  50. # 5,7, 1,2,1,4,1,5,2,3,2,6,3,4,3,7,5,6,5,8, 1,3,1,7,1,13,3,5,3,15,
  51. c 33 35 40
  52. # 5,7,5,17,13,15,13,19, 1,2,2,3, 1,2,4,5,1,4,2,5,3,6, 1,3,10,12,
  53. c 45
  54. # 1,10,3,12,5,14, 1,2/
  55. c 1 4 7 11
  56. DATA KPI1/-1, -3, -3, -5, -8, -8,-11, -14, -11, -14, -17, -23,
  57. c 15 24 33
  58. # -29, -35 ,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18, -1,-3,
  59. c 35 40 45
  60. # 19,20,21,22,-319,23,24,25,26,-400, -413/
  61. c 1 ... ... 9
  62. DATA KPS2/2,1,2,3,2,5,1,7,1,8,1,9,1,10,1,11,1,12,
  63. c 10 ... ... 18
  64. # 2,13,2,15,2,17,1,19,1,20,1,21,1,22,1,23,1,24,
  65. c 19 ... 22
  66. # 1,25,1,26,3,27,2,30,
  67. c 23 ... 26
  68. # 1,32,1,33,3,34,2,37/
  69. c 1 2 3 4 5 6 7 8 9
  70. DATA KS2/4,3,5,6, 2,3,5,8, 4,8,2,6, 6,7,3,7,7,8,4,8,7,8,6,7,
  71. c 10 11 12 13 14 15 16 17 18
  72. # 7,5,13,15,3,5,13,19,7,19,3,15,15,17,5,17,17,19,7,19,17,19,15,17,
  73. c 19 20 21 22 23 24 25 26
  74. # 1,3,4,6,2,5,3,6,0,0,3,6,0,0,1,5,10,14,3,12,5,14,0,0,5,14,0,0/
  75. c 1 2 3 4 5 6 7 8 9
  76. DATA KPI2/-41 ,-47, -53,-59, -65,-71, -77,-83,-89,-95,-101,-107,
  77. c 10 11 12 13 14 15 16 17 18
  78. # -113,-128,-143,-158,-173,-188,-203,-218,-233,-248,-263,-278,
  79. c 19 20 21 22 23 24 25
  80. # -293,-297,-301,-305,-309,-297,-314,-324,-334,-344,-354,
  81. c 26
  82. # -374,-364,-387/
  83. DATA KNEL1/1,3, 1,2, 1,4,5, 1,2,3, 1,3,4, 1,2,3, 1,4,5,6,7,8,
  84. # 1,2,3,4,5,6, 1,2,3,6,7,8 ,1,2,3,4,7,8,
  85. # 1,6,5,3,7,8, 1,3,4,5,7,8, 1,8,5,2,7,6, 1,2,3,5,6,7,
  86. # 1,6,2,4,7,3, 1,4,8,2,3,7, 1,2,4,5,6,8, 1,5,2,4,8,3,
  87. # 1,2,3,5,6,7, 1,4,5,2,3,6, 1,5,2,4,7,3, 1,4,8,2,3,6,
  88. # 1,10,15,14,13,9,8,16,20,7,11,17,18,19,12,
  89. # 1,4,5,6,7,8,9,11,12,13,16,17,18,19,20,
  90. # 1,12,19,20,13,9,2,18,14,3,11,17,16,15,10,
  91. # 1,2,3,4,5,6,9,10,11,13,14,15,16,17,18,
  92. # 1,14,15,10,3,2,8,16,4,7,18,17,11,5,6,
  93. # 1,8,7,12,19,20,2,6,18,3,4,5,11,17,16,
  94. # 1,2,3,6,7,8,9,10,12,13,14,15,18,19,20,
  95. # 1,9,13,14,15,2,8,20,16,7,12,19,18,17,6,
  96. # 1,2,3,4,5,8,9,10,11,13,14,15,16,17,20,
  97. # 1,8,7,20,13,9,2,6,14,3,4,5,16,15,10,
  98. # 1,9,13,10,3,2,8,20,4,7,12,19,11,5,6,
  99. # 1,8,7,12,19,9,2,6,18,3,4,5,11,17,10/
  100. DATA KNEL2/4,6,5,1, 1,2,3,4, 1,2,3,6, 1,2,3,5,
  101. # 2,3,6,5,1, 1,3,6,4,2, 1,2,5,4,3,
  102. # 10,15,14,13,12,11,7,9,8,1, 1,2,3,4,5,6,7,8,9,10,
  103. # 1,2,3,4,5,6,15,13,9,14, 1,2,3,4,5,6,11,8,13,12,
  104. # 1,2,3,4,5,6,7,11,15,10,
  105. # 3,4,5,9,14,13,12,8,2,6,15,11,1, 1,6,5,9,14,15,10,7,2,4,13,11,3,
  106. # 1,2,3,8,12,11,10,7,6,4,13,15,5,
  107. # 1/
  108. c bp : ajout possibilite de verifier
  109. IVERI=0
  110. CALL LIRMOT('VERI',1,IVERI,0)
  111. FLNOVE=(IVERI.eq.0)
  112. C DEBUT PROGRAMME
  113. IPT1=IPTT
  114. SEGACT IPT1
  115. MELEME=IPT1
  116. NBSO=LISOUS(/1)
  117. SEGINI INOU
  118. NBREF=0
  119. NBSOUS=0
  120. DO 1 II= 1,MAX(1,NBSO)
  121. IF (NBSO.NE.0) THEN
  122. MELEME=IPT1.LISOUS(II)
  123. SEGACT MELEME
  124. ENDIF
  125. IPT7=0
  126. IF(IIMPI.NE.0) WRITE(IOIMP,500) ITYPEL,KST(ITYPEL)
  127. 500 FORMAT(' ITYPEL KST(ITYPEL) ',2I5)
  128. IF(KST(ITYPEL).EQ.0) INOU(**)=MELEME
  129. IF(KST(ITYPEL).EQ.0) GO TO 1000
  130. IA= KPS1(1,ITYPEL)
  131. NBELEM=NUM(/2)
  132. NBNN=NUM(/1)
  133. SEGINI IPT2
  134. IF( KST(ITYPEL).GT.0) THEN
  135. NBNN=NBNNE(KST(ITYPEL))
  136. SEGINI IPT3
  137. IPT3.ITYPEL=KST(ITYPEL)
  138. ELSE
  139. IPO = -KST(ITYPEL)
  140. NPO = KSTT(IPO)
  141. NBNN = NBNNE( KSTT(IPO + 1))
  142. SEGINI IPT3
  143. IPT3.ITYPEL=KSTT(IPO + 1)
  144. NBNN = NBNNE ( KSTT(IPO+2))
  145. SEGINI IPT7
  146. IPT7.ITYPEL=KSTT(IPO + 2)
  147. IF( NPO . GT . 2) THEN
  148. CALL ERREUR(19)
  149. RETURN
  150. ENDIF
  151. ENDIF
  152. IF(IIMPI.NE.0) WRITE(IOIMP,501) IA,NBNN
  153. 501 FORMAT(' NB DE SEGMENT A TESTER,NB NOEUD DU SOUS TYPE',2I5)
  154. IPT2.ITYPEL=ITYPEL
  155. IEL2=0
  156. IEL3=0
  157. IEL7=0
  158. C==== BOUCLE SUR LES ELEMENTS ========
  159. DO 3 JJ=1,NBELEM
  160. IB=KPS1(2,ITYPEL) -1
  161. DO 4 J=1,IA
  162. IB=IB+1
  163. IF(IIMPI.GE.5) WRITE(IOIMP,*) 'ON TESTE ',KS1(1,IB),KS1(2,IB)
  164. IF( NUM(KS1(1,IB),JJ) .NE. NUM(KS1(2,IB),JJ) ) GO TO 4
  165. C ** ON A TROUVER UNE EGALITE DE NOEUD. FAUT-IL FAIRE D'AUTRES TESTS
  166. C
  167. IT1=KPI1(IB)
  168. IF(IT1.LT.0) GO TO 100
  169. C TESTS COMPLEMENTAIRES
  170. IC=KPS2(1,IT1)
  171. ID=KPS2(2,IT1)-1
  172. DO 5 K=1,IC
  173. ID=ID+1
  174. IF(IIMPI.GE.5) WRITE(IOIMP,*) 'on teste ',KS2(1,ID),KS2(2,ID)
  175. IF(KS2(1,ID).EQ.0) GO TO 51
  176. IF( NUM(KS2(1,ID),JJ) .NE. NUM(KS2(2,ID),JJ) ) GO TO 5
  177. 51 CONTINUE
  178. IT2=KPI2(ID)
  179. IF(IT2.LT.0) IT1=IT2
  180. IF(IT2.LT.0) GO TO 100
  181. 5 CONTINUE
  182. C UN POINT DOUBLE MAIS PAS LES TESTS COMPLEMENTAIRES
  183. INTERR(1)=JJ
  184. CALL ERREUR(-303)
  185. 4 CONTINUE
  186. IF(IIMPI.NE.0) WRITE(IOIMP,502) JJ
  187. 502 FORMAT(' ELEM NUMERO ' ,I5,' PAS CHANGE ')
  188. C PAS DE PTS DOUBLE ON RECOPIE
  189. IEL2=IEL2+1
  190. DO 6 L=1,NUM(/1)
  191. IPT2.NUM(L,IEL2)=NUM(L,JJ)
  192. c bp : ajout verif
  193. if(FLNOVE) goto 6
  194. if(L.le.1) goto 6
  195. do 62 L2=1,(L-1)
  196. if(IPT2.NUM(L2,IEL2).ne.IPT2.NUM(L,IEL2)) goto 62
  197. WRITE(IOIMP,*) 'Cas non prevu pour le maillage',IPT2
  198. INTERR(1)=IEL2
  199. CALL ERREUR(-303)
  200. 62 continue
  201. 6 CONTINUE
  202. IPT2.ICOLOR(IEL2)=ICOLOR(JJ)
  203. GO TO 3
  204. 100 CONTINUE
  205. IPT5=IPT3
  206. IEL3=IEL3+1
  207. IEL5=IEL3
  208. c cas particulier ou on a le choix entre 2 type d elements
  209. c ex : PRI6 -> TET4 ou PYR5
  210. IF( IPT7.NE.0) THEN
  211. IF(IT1.EQ.-309.OR.IT1.EQ.-314.OR.IT1.EQ.-319.OR.IT1.EQ.-374
  212. # .OR.IT1.EQ.-387.OR.IT1.EQ.-400) THEN
  213. IPT5=IPT7
  214. IEL3=IEL3-1
  215. IEL7=IEL7+1
  216. IEL5=IEL7
  217. ENDIF
  218. ENDIF
  219. IPT5.ICOLOR(IEL5)=ICOLOR(JJ)
  220. IT1=-IT1
  221. IF(IIMPI.NE.0) WRITE(IOIMP,503) JJ
  222. 503 FORMAT(' ELEM NUMERO ' ,I5,' CHANGER ')
  223. DO 101 L=1,IPT5.NUM(/1)
  224. IPT5.NUM(L,IEL5)=NUM(KNEL(IT1),JJ)
  225. IT1=IT1+1
  226. c bp : ajout verif
  227. if(FLNOVE) goto 101
  228. if(L.le.1) goto 101
  229. do 102 L2=1,(L-1)
  230. if(IPT5.NUM(L2,IEL5).ne.IPT5.NUM(L,IEL5)) goto 102
  231. WRITE(IOIMP,*) 'Cas non prevu pour le maillage',IPT5
  232. INTERR(1)=IEL5
  233. CALL ERREUR(-303)
  234. 102 continue
  235. 101 CONTINUE
  236. 3 CONTINUE
  237. C==== FIN DE BOUCLE SUR LES ELEMENTS ========
  238. C
  239. C ** ON REGARDE SI IPT2 ET IPT3 EXISTE VRAIMENT PUIS ON LES RECREE
  240. C ** A LA BONNE DIMENSION
  241. C
  242. IF(IEL2.EQ.0) GO TO 10
  243. IF(IEL2.EQ.NUM(/2)) THEN
  244. INOU(**)=MELEME
  245. SEGSUP IPT2,IPT3
  246. IF(IPT7.NE.0) SEGSUP IPT7
  247. GO TO 1000
  248. ELSE
  249. NBNN=IPT2.NUM(/1)
  250. NBELEM=IEL2
  251. SEGINI IPT4
  252. DO 11 K=1,IEL2
  253. IPT4.ICOLOR(K)=IPT2.ICOLOR(K)
  254. DO 11 L=1,NBNN
  255. IPT4.NUM(L,K)=IPT2.NUM(L,K)
  256. 11 CONTINUE
  257. IPT4.ITYPEL=IPT2.ITYPEL
  258. SEGSUP IPT2
  259. INOU(**)=IPT4
  260. SEGDES IPT4
  261. ENDIF
  262. 10 CONTINUE
  263. IF(IEL3.EQ.NUM(/2)) THEN
  264. INOU(**)=IPT3
  265. SEGDES IPT3
  266. SEGSUP IPT2
  267. IF(IPT7.NE.0) SEGSUP IPT7
  268. GO TO 1000
  269. ELSE
  270. NBNN=IPT3.NUM(/1)
  271. NBELEM=IEL3
  272. SEGINI IPT4
  273. DO 12 K=1,NBELEM
  274. IPT4.ICOLOR(K)=IPT3.ICOLOR(K)
  275. DO 12 L=1,NBNN
  276. IPT4.NUM(L,K)=IPT3.NUM(L,K)
  277. 12 CONTINUE
  278. IPT4.ITYPEL=IPT3.ITYPEL
  279. SEGSUP IPT3
  280. SEGDES IPT4
  281. IF(IEL3.NE.0) INOU(**)=IPT4
  282. ENDIF
  283. IF(IEL7.EQ.NUM(/2)) THEN
  284. INOU(**)=IPT7
  285. SEGDES IPT7
  286. SEGSUP IPT3
  287. SEGSUP IPT2
  288. GO TO 1000
  289. ELSE
  290. C# MC 03/11/97 : on passe ici avec IPT7=0 dans kp2_test.dgibi
  291. IF(IPT7.NE.0) THEN
  292. NBNN=IPT7.NUM(/1)
  293. NBELEM=IEL7
  294. SEGINI IPT4
  295. DO 13 K=1,NBELEM
  296. IPT4.ICOLOR(K)=IPT7.ICOLOR(K)
  297. DO 13 L=1,NBNN
  298. IPT4.NUM(L,K)=IPT7.NUM(L,K)
  299. 13 CONTINUE
  300. IPT4.ITYPEL=IPT7.ITYPEL
  301. SEGSUP IPT7
  302. SEGDES IPT4
  303. IF(IEL7.NE.0)INOU(**)=IPT4
  304. ENDIF
  305. ENDIF
  306.  
  307. 1000 CONTINUE
  308. IF(NBSO.NE.0) SEGDES MELEME
  309. 1 CONTINUE
  310. II=INOU(/1)
  311. IF(II.EQ.0) THEN
  312. IRETOU=IPT1
  313. GO TO 15
  314. ENDIF
  315. IRETOU=INOU(1)
  316. IF(II.EQ.1) GO TO 15
  317. DO 16 J=2,II
  318. INN=INOU(J)
  319. ltelq=.false.
  320. CALL FUSE( IRETOU,INN,IPT5,ltelq)
  321. IRETOU=IPT5
  322. 16 CONTINUE
  323. 15 CONTINUE
  324. IPTT=IRETOU
  325. RETURN
  326. END
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.  
  336.  
  337.  
  338.  
  339.  

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