1 : C REGENE SOURCE BP208322 13/02/05 21:15:07 7693 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 109 : CALL LIRMOT('VERI',1,IVERI,0) 110 : FLNOVE=(IVERI.eq.0) 111 : C DEBUT PROGRAMME 112 : IPT1=IPTT 113 : SEGACT IPT1 114 : MELEME=IPT1 115 : NBSO=LISOUS(/1) 116 : SEGINI INOU 117 : NBREF=0 118 : NBSOUS=0 119 : DO 1 II= 1,MAX(1,NBSO) 120 : IF (NBSO.NE.0) THEN 121 : MELEME=IPT1.LISOUS(II) 122 : SEGACT MELEME 123 : ENDIF 124 : IPT7=0 125 : IF(IIMPI.NE.0) WRITE(IOIMP,500) ITYPEL,KST(ITYPEL) 126 : 500 FORMAT(' ITYPEL KST(ITYPEL) ',2I5) 127 : IF(KST(ITYPEL).EQ.0) INOU(**)=MELEME 128 : IF(KST(ITYPEL).EQ.0) GO TO 1000 129 : IA= KPS1(1,ITYPEL) 130 : NBELEM=NUM(/2) 131 : NBNN=NUM(/1) 132 : SEGINI IPT2 133 : IF( KST(ITYPEL).GT.0) THEN 134 : NBNN=NBNNE(KST(ITYPEL)) 135 : SEGINI IPT3 136 : IPT3.ITYPEL=KST(ITYPEL) 137 : ELSE 138 : IPO = -KST(ITYPEL) 139 : NPO = KSTT(IPO) 140 : NBNN = NBNNE( KSTT(IPO + 1)) 141 : SEGINI IPT3 142 : IPT3.ITYPEL=KSTT(IPO + 1) 143 : NBNN = NBNNE ( KSTT(IPO+2)) 144 : SEGINI IPT7 145 : IPT7.ITYPEL=KSTT(IPO + 2) 146 : IF( NPO . GT . 2) THEN 146 : CALL ERREUR(19) 147 : RETURN 148 : ENDIF 149 : ENDIF 150 : IF(IIMPI.NE.0) WRITE(IOIMP,501) IA,NBNN 151 : 501 FORMAT(' NB DE SEGMENT A TESTER,NB NOEUD DU SOUS TYPE',2I5) 152 : IPT2.ITYPEL=ITYPEL 153 : IEL2=0 154 : IEL3=0 155 : IEL7=0 156 : C==== BOUCLE SUR LES ELEMENTS ======== 157 : DO 3 JJ=1,NBELEM 158 : IB=KPS1(2,ITYPEL) -1 159 : DO 4 J=1,IA 160 : IB=IB+1 161 : IF(IIMPI.GE.5) WRITE(IOIMP,*) 'ON TESTE ',KS1(1,IB),KS1(2,IB) 162 : IF( NUM(KS1(1,IB),JJ) .NE. NUM(KS1(2,IB),JJ) ) GO TO 4 163 : C ** ON A TROUVER UNE EGALITE DE NOEUD. FAUT-IL FAIRE D'AUTRES TESTS 164 : C 165 : IT1=KPI1(IB) 166 : IF(IT1.LT.0) GO TO 100 167 : C TESTS COMPLEMENTAIRES 168 : IC=KPS2(1,IT1) 169 : ID=KPS2(2,IT1)-1 170 : DO 5 K=1,IC 171 : ID=ID+1 172 : IF(IIMPI.GE.5) WRITE(IOIMP,*) 'on teste ',KS2(1,ID),KS2(2,ID) 173 : IF(KS2(1,ID).EQ.0) GO TO 51 174 : IF( NUM(KS2(1,ID),JJ) .NE. NUM(KS2(2,ID),JJ) ) GO TO 5 175 : 51 CONTINUE 176 : IT2=KPI2(ID) 177 : IF(IT2.LT.0) IT1=IT2 178 : IF(IT2.LT.0) GO TO 100 179 : 5 CONTINUE 180 : C UN POINT DOUBLE MAIS PAS LES TESTS COMPLEMENTAIRES 181 : INTERR(1)=JJ 181 : CALL ERREUR(-303) 182 : 4 CONTINUE 183 : IF(IIMPI.NE.0) WRITE(IOIMP,502) JJ 184 : 502 FORMAT(' ELEM NUMERO ' ,I5,' PAS CHANGE ') 185 : C PAS DE PTS DOUBLE ON RECOPIE 186 : IEL2=IEL2+1 187 : DO 6 L=1,NUM(/1) 188 : IPT2.NUM(L,IEL2)=NUM(L,JJ) 189 : c bp : ajout verif 190 : if(FLNOVE) goto 6 191 : if(L.le.1) goto 6 192 : do 62 L2=1,(L-1) 193 : if(IPT2.NUM(L2,IEL2).ne.IPT2.NUM(L,IEL2)) goto 62 194 : WRITE(IOIMP,*) 'Cas non prevu pour le maillage',IPT2 195 : INTERR(1)=IEL2 195 : CALL ERREUR(-303) 196 : 62 continue 197 : 6 CONTINUE 198 : IPT2.ICOLOR(IEL2)=ICOLOR(JJ) 199 : GO TO 3 200 : 100 CONTINUE 201 : IPT5=IPT3 202 : IEL3=IEL3+1 203 : IEL5=IEL3 204 : c cas particulier ou on a le choix entre 2 type d elements 205 : c ex : PRI6 -> TET4 ou PYR5 206 : IF( IPT7.NE.0) THEN 207 : IF(IT1.EQ.-309.OR.IT1.EQ.-314.OR.IT1.EQ.-319.OR.IT1.EQ.-374 208 : # .OR.IT1.EQ.-387.OR.IT1.EQ.-400) THEN 209 : IPT5=IPT7 210 : IEL3=IEL3-1 211 : IEL7=IEL7+1 212 : IEL5=IEL7 213 : ENDIF 214 : ENDIF 215 : IPT5.ICOLOR(IEL5)=ICOLOR(JJ) 216 : IT1=-IT1 217 : IF(IIMPI.NE.0) WRITE(IOIMP,503) JJ 218 : 503 FORMAT(' ELEM NUMERO ' ,I5,' CHANGER ') 219 : DO 101 L=1,IPT5.NUM(/1) 220 : IPT5.NUM(L,IEL5)=NUM(KNEL(IT1),JJ) 221 : IT1=IT1+1 222 : c bp : ajout verif 223 : if(FLNOVE) goto 101 224 : if(L.le.1) goto 101 225 : do 102 L2=1,(L-1) 226 : if(IPT5.NUM(L2,IEL5).ne.IPT5.NUM(L,IEL5)) goto 102 227 : WRITE(IOIMP,*) 'Cas non prevu pour le maillage',IPT5 228 : INTERR(1)=IEL5 228 : CALL ERREUR(-303) 229 : 102 continue 230 : 101 CONTINUE 231 : 3 CONTINUE 232 : C==== FIN DE BOUCLE SUR LES ELEMENTS ======== 233 : C 234 : C ** ON REGARDE SI IPT2 ET IPT3 EXISTE VRAIMENT PUIS ON LES RECREE 235 : C ** A LA BONNE DIMENSION 236 : C 237 : IF(IEL2.EQ.0) GO TO 10 238 : IF(IEL2.EQ.NUM(/2)) THEN 239 : INOU(**)=MELEME 240 : SEGSUP IPT2,IPT3 241 : IF(IPT7.NE.0) SEGSUP IPT7 242 : GO TO 1000 243 : ELSE 244 : NBNN=IPT2.NUM(/1) 245 : NBELEM=IEL2 246 : SEGINI IPT4 247 : DO 11 K=1,IEL2 248 : IPT4.ICOLOR(K)=IPT2.ICOLOR(K) 249 : DO 11 L=1,NBNN 250 : IPT4.NUM(L,K)=IPT2.NUM(L,K) 251 : 11 CONTINUE 252 : IPT4.ITYPEL=IPT2.ITYPEL 253 : SEGSUP IPT2 254 : INOU(**)=IPT4 255 : SEGDES IPT4 256 : ENDIF 257 : 10 CONTINUE 258 : IF(IEL3.EQ.NUM(/2)) THEN 259 : INOU(**)=IPT3 260 : SEGDES IPT3 261 : SEGSUP IPT2 262 : IF(IPT7.NE.0) SEGSUP IPT7 263 : GO TO 1000 264 : ELSE 265 : NBNN=IPT3.NUM(/1) 266 : NBELEM=IEL3 267 : SEGINI IPT4 268 : DO 12 K=1,NBELEM 269 : IPT4.ICOLOR(K)=IPT3.ICOLOR(K) 270 : DO 12 L=1,NBNN 271 : IPT4.NUM(L,K)=IPT3.NUM(L,K) 272 : 12 CONTINUE 273 : IPT4.ITYPEL=IPT3.ITYPEL 274 : SEGSUP IPT3 275 : SEGDES IPT4 276 : IF(IEL3.NE.0) INOU(**)=IPT4 277 : ENDIF 278 : IF(IEL7.EQ.NUM(/2)) THEN 279 : INOU(**)=IPT7 280 : SEGDES IPT7 281 : SEGSUP IPT3 282 : SEGSUP IPT2 283 : GO TO 1000 284 : ELSE 285 : C# MC 03/11/97 : on passe ici avec IPT7=0 dans kp2_test.dgibi 286 : IF(IPT7.NE.0) THEN 287 : NBNN=IPT7.NUM(/1) 288 : NBELEM=IEL7 289 : SEGINI IPT4 290 : DO 13 K=1,NBELEM 291 : IPT4.ICOLOR(K)=IPT7.ICOLOR(K) 292 : DO 13 L=1,NBNN 293 : IPT4.NUM(L,K)=IPT7.NUM(L,K) 294 : 13 CONTINUE 295 : IPT4.ITYPEL=IPT7.ITYPEL 296 : SEGSUP IPT7 297 : SEGDES IPT4 298 : IF(IEL7.NE.0)INOU(**)=IPT4 299 : ENDIF 300 : ENDIF 301 : 302 : 1000 CONTINUE 303 : IF(NBSO.NE.0) SEGDES MELEME 304 : 1 CONTINUE 305 : II=INOU(/1) 306 : IF(II.EQ.0) THEN 307 : IRETOU=IPT1 308 : GO TO 15 309 : ENDIF 310 : IRETOU=INOU(1) 311 : IF(II.EQ.1) GO TO 15 312 : DO 16 J=2,II 313 : INN=INOU(J) 314 : ltelq=.false. 314 : CALL FUSE( IRETOU,INN,IPT5,ltelq) 315 : IRETOU=IPT5 316 : 16 CONTINUE 317 : 15 CONTINUE 318 : IPTT=IRETOU 319 : RETURN 320 : END 321 : 322 : 323 : 324 : 325 : 326 : 327 : 328 : 329 : 330 :
© Cast3M 2003 - All rights reserved.
Disclaimer