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

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