1 : C KCHA2 SOURCE PV 09/03/12 21:26:00 6325 2 : C 3 : SUBROUTINE KCHA2(IPCHE,IPGEOM,IPCENT,IRET) 4 : C----------------------------------------------------------------------- 5 : C Transforme un MCHAML constant par élément en un CHPO de support CENTRE 6 : C----------------------------------------------------------------------- 7 : C 8 : C-------------------- 9 : C Paramètres Entrée : 10 : C-------------------- 11 : C 12 : C IPCHE : pointeur sur le champ par élément 13 : C Le champ n'a qu'une composante reelle 14 : C 15 : C IPGEOM : pointeur sur le maillage quaf ou de base (issu de la table domaine). 16 : C IPCENT : pointeur sur le maillage des points centres 17 : C (issu de la table domaine). 18 : C 19 : C------------------- 20 : C Paramètre Sortie : 21 : C------------------- 22 : C 23 : C IRET : pointeur sur le CHPO de support centre 24 : C 25 : C----------------------------------------------------------------------- 26 : C 27 : C Subroutine appelée par KCHA. 28 : C 29 : C----------------------------------------------------------------------- 30 : 31 : IMPLICIT INTEGER(I-N) 32 : IMPLICIT REAL*8 (A-H,O-Z) 33 : C 34 : C 35 : -INC CCOPTIO 36 : -INC SMCHAML 37 : -INC SMCHPOI 38 : -INC SMELEME 39 : 40 : SEGMENT ITRA 41 : * LTAB(IE,IP) : indice dans le chpocentre du point IE de la partition IP 42 : INTEGER LTAB(NBELM,NPAR) 43 : ENDSEGMENT 44 : SEGMENT JTRA 45 : * JTAB(IZ) : indice dans le chpocentre de départ des points pour le sous-maillage IZ 46 : * ZTAB(IP) : nb de noeuds de la partition IP 47 : * ITAB(IP) : pointeur sur sous-zone identifiée à la partition IP 48 : * KTAB(IP) : nb d'éléments de cette sous-zone 49 : * OTAB(IP) : numéro d'ordre de cette sous-zone dans IPGEOM 50 : INTEGER JTAB(NBS),ZTAB(NPAR) 51 : INTEGER ITAB(NPAR),KTAB(NPAR),OTAB(NPAR) 52 : ENDSEGMENT 53 : SEGMENT KTRA 54 : * MTAB(IC) : nom de la composante IC du chamelem 55 : * NTAB(IC,IP) : numéro, dans chaque partition IP, de la 56 : * sous-partition ayant pour composante la composante 57 : * IC de la première partition 58 : CHARACTER*8 MTAB(MCOM) 59 : INTEGER NTAB(NC,NPAR) 60 : ENDSEGMENT 61 : SEGMENT KSIPP 62 : INTEGER ISPT(NBEL3) 63 : ENDSEGMENT 64 : * 65 : * NBS : nombre de sous-zones du maillage 66 : * 67 : IPT1 = IPGEOM 68 : SEGACT IPT1 69 : NBO = IPT1.LISOUS(/1) 70 : IF(NBO.EQ.0) THEN 71 : NBS = 1 72 : ELSE 73 : NBS = NBO 74 : ENDIF 75 : * 76 : * NPAR : nombre de partitions du chamelem 77 : * 78 : MCHELM = IPCHE 79 : SEGACT MCHELM 80 : NPAR = IMACHE(/1) 81 : * 82 : * NBELM : nombre maximal d'éléments parmi toutes les partitions 83 : * 84 : NBELM = 0 85 : DO IP =1,NPAR 86 : IPT2 = IMACHE(IP) 87 : SEGACT IPT2 88 : NBEL = IPT2.NUM(/2) 89 : NP = IPT2.NUM(/1) 90 : NBELM = MAX(NBEL,NBELM) 91 : * IF(NBEL.GT.NBELM) THEN 92 : * NBELM = NBEL 93 : * ENDIF 94 : SEGDES IPT2 95 : ENDDO 96 : * 97 : * Initialisation des segments de travail 98 : * 99 : SEGINI ITRA 100 : SEGINI JTRA 101 : 102 : IF(NBO.EQ.0) THEN 103 : JTAB(1)=0 104 : ENDIF 105 : 106 : DO IO=2,NBS 107 : IPT3 = IPT1.LISOUS(IO-1) 108 : SEGACT IPT3 109 : NB = IPT3.NUM(/2) 110 : JTAB(IO)= JTAB(IO-1) + NB 111 : SEGDES IPT3 112 : ENDDO 113 : * 114 : * Correspondance des maillages des partitions du chamelem 115 : * avec les sous-maillages du maillage 116 : * 117 : 118 : * Test des nombres de noeuds par éléments 119 : DO IP=1,NPAR 120 : * pour chaque partition IP 121 : IPT2 = IMACHE(IP) 122 : SEGACT IPT2 123 : NP = IPT2.NUM(/1) 124 : ZTAB(IP)= IPT2.NUM(/2) 125 : DO IZ=1,NBS 126 : * pour chaque sous-maillage IZ 127 : IF(NBO.EQ.0)THEN 128 : IPT3 = IPT1 129 : ELSE 130 : IPT3 = IPT1.LISOUS(IZ) 131 : SEGACT IPT3 132 : ENDIF 133 : NP3 = IPT3.NUM(/1) 134 : IF(NP.EQ.NP3) THEN 135 : C On a trouve 2 sous-maillages ayant le meme nbre de noeuds 136 : C pour qu'ils puissent correspondre, ils doivent avoir 1 137 : C element commun 138 : NBEL3=IPT3.NUM(/2) 139 : ITEST=0 140 : DO 30 I0=1,NP 141 : I1=IPT2.NUM(I0,1) 142 : DO 20 I2=1,NBEL3 143 : DO 15 I3=1,NP3 144 : IF(IPT3.NUM(I3,I2).EQ.I1)THEN 145 : ITEST=ITEST+1 146 : GO TO 25 147 : ENDIF 148 : 15 CONTINUE 149 : 20 CONTINUE 150 : 25 CONTINUE 151 : 30 CONTINUE 152 : IF(ITEST.EQ.NP)THEN 153 : ITAB(IP)=IPT3 154 : KTAB(IP)=IPT3.NUM(/2) 155 : OTAB(IP)=IZ 156 : IF(NBO.GT.0)THEN 157 : SEGDES IPT3 158 : ENDIF 159 : GO TO 3 160 : ENDIF 161 : ENDIF 162 : ENDDO 163 : C On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou de 164 : C constituant correspondant à l'objet MODELE 164 : CALL ERREUR(472) 165 : RETURN 166 : 3 CONTINUE 167 : SEGDES IPT2 168 : ENDDO 169 : 170 : * Test des numéros de noeud 171 : C les tests qui suivent sont extremement long pour un gros maillage 172 : C on va affecter a chaque element un poids egal a la somme des numeros 173 : C de ses noeuds et on ne comparera les numeros de noeuds que pour les 174 : C elements qui auront le meme poids. 175 : DO IP =1,NPAR 176 : IPT2 = IMACHE(IP) 177 : SEGACT IPT2 178 : IPT4 = ITAB(IP) 179 : SEGACT IPT4 180 : NBEL2 = ZTAB(IP) 181 : NBEL3 = KTAB(IP) 182 : NP = IPT2.NUM(/1) 183 : C 184 : SEGINI KSIPP 185 : DO JE=1,NBEL3 186 : ISP2=0 187 : DO JP=1,NP 188 : ISP2=ISP2+IPT4.NUM(JP,JE) 189 : ENDDO 190 : ISPT(JE)=ISP2 191 : ENDDO 192 : 193 : C 194 : DO IE = 1,NBEL2 195 : IP1 = IPT2.NUM(1,IE) 196 : ISP1=0 197 : DO II=1,NP 198 : ISP1= ISP1+IPT2.NUM(II,IE) 199 : ENDDO 200 : DO JE = 1,NBEL3 201 : IF(ISPT(JE).EQ.ISP1) THEN 202 : DO JP=1,NP 203 : IP2=IPT4.NUM(JP,JE) 204 : IF(IP2.EQ.IP1) THEN 205 : ITEST = 1 206 : DO KP=1,NP-1 207 : JEE = JP+KP 208 : JEP = JEE / NP 209 : JEE = JEE - JEP * NP 210 : IF(JEE.EQ.0)THEN 211 : JEE = NP 212 : ENDIF 213 : KJ = IPT4.NUM(JEE,JE) 214 : KI = IPT2.NUM(KP+1,IE) 215 : IF(KJ.EQ.KI) THEN 216 : ITEST=ITEST+1 217 : ELSE 218 : GO TO 4 219 : ENDIF 220 : ENDDO 221 : IF(ITEST.EQ.NP) THEN 222 : LTAB(IE,IP)=JE+JTAB(OTAB(IP)) 223 : GO TO 5 224 : ENDIF 225 : 4 CONTINUE 226 : ENDIF 227 : ENDDO 228 : ENDIF 229 : ENDDO 230 : C On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou de 231 : C constituant correspondant à l'objet MODELE 231 : CALL ERREUR(472) 232 : RETURN 233 : 5 CONTINUE 234 : ENDDO 235 : SEGDES IPT2, IPT4 236 : SEGSUP KSIPP 237 : ENDDO 238 : * 239 : * NOMBRE DE COMPOSANTES MAXI PAR PARTITION 240 : * 241 : NC = 0 242 : DO IP =1,NPAR 243 : MCHAML = ICHAML(IP) 244 : SEGACT MCHAML 245 : DO IT = 1,TYPCHE(/2) 246 : IF(TYPCHE(IT)(1:8).EQ.'POINTEUR') THEN 247 : c Problème non prévu dans le s.p. %m1:8 contactez votre assistance 248 : MOTERR(1:8) = 'KCHA2 ' 248 : CALL ERREUR(349) 249 : RETURN 250 : ENDIF 251 : ENDDO 252 : IC = MCHAML.IELVAL(/1) 253 : NC = MAX(IC,NC) 254 : * IF(IC.GT.NC) THEN 255 : * NC = IC 256 : * ENDIF 257 : SEGDES MCHAML 258 : ENDDO 259 : MCOM = NC 260 : 261 : * Préparation du champ-point à plusieurs composantes 262 : SEGINI KTRA 263 : MCHAML = ICHAML(1) 264 : SEGACT MCHAML 265 : MC = MCHAML.IELVAL(/1) 266 : DO IC =1,MC 267 : MTAB(IC)=NOMCHE(IC) 268 : NTAB(IC,1)=IC 269 : ENDDO 270 : SEGDES MCHAML 271 : 272 : K=MC 273 : DO IP=2,NPAR 274 : MCHAML = ICHAML(IP) 275 : SEGACT MCHAML 276 : MC = MCHAML.IELVAL(/1) 277 : DO IC=1,MC 278 : DO JC=1,K 279 : IF(NOMCHE(IC).EQ.MTAB(JC))THEN 280 : NTAB(IC,IP)=JC 281 : GO TO 10 282 : ENDIF 283 : ENDDO 284 : K = K+1 285 : IF(MCOM.LT.K) THEN 286 : MCOM = K 287 : SEGADJ KTRA 288 : ENDIF 289 : MTAB(K)=NOMCHE(IC) 290 : NTAB(IC,IP)=K 291 : 10 CONTINUE 292 : ENDDO 293 : SEGDES MCHAML 294 : ENDDO 295 : * 296 : * Construction du champ-point 297 : * 298 : NSOUPO = 1 299 : NAT = 2 300 : SEGINI MCHPOI 301 : MTYPOI = ' ' 302 : MOCHDE = 'KCHA FECIT' 303 : JATTRI(1) = 2 304 : NC = MCOM 305 : SEGINI MSOUPO 306 : IPCHP(1) = MSOUPO 307 : IPT5 = IPCENT 308 : SEGACT IPT5 309 : N = IPT5.NUM(/2) 310 : SEGDES IPT5 311 : SEGINI MPOVAL 312 : IPOVAL = MPOVAL 313 : IGEOC = IPCENT 314 : IFOPOI = IFOCHE 315 : 316 : DO IC=1,MCOM 317 : NOCOMP(IC) = MTAB(IC)(1:4) 318 : *** NOHARN(IC)=INTAB(IC) 319 : *** REVOIR NHARM 320 : ENDDO 321 : 322 : DO IP=1,NPAR 323 : MCHAML= ICHAML(IP) 324 : SEGACT MCHAML 325 : N2 = MCHAML.IELVAL(/1) 326 : IPT4 = ITAB(IP) 327 : SEGACT IPT4 328 : MEL = ZTAB(IP) 329 : DO II=1,N2 330 : IC = NTAB(II,IP) 331 : MELVAL = MCHAML.IELVAL(II) 332 : SEGACT MELVAL 333 : NPT = VELCHE(/1) 334 : NEL = VELCHE(/2) 335 : IF(NPT.EQ.1 .AND. NEL.EQ.1) THEN 336 : * constance sur la sous-zone 337 : DO IE = 1,MEL 338 : JP = LTAB(IE,IP) 339 : VPOCHA(JP,IC) = VELCHE(1,1) 340 : ENDDO 341 : ENDIF 342 : IF(NPT.EQ.1 .AND. NEL.NE.1) THEN 343 : * cas classique 344 : DO IE = 1,MEL 345 : JP = LTAB(IE,IP) 346 : VPOCHA(JP,IC) = VELCHE(1,IE) 347 : ENDDO 348 : ENDIF 349 : IF(NPT.NE.1 .AND. NEL.NE.1) THEN 350 : * on n'a pas un chamelem aux centres 351 : * on fait la moyenne sur les valeurs aux différents points 352 : DO IE = 1,MEL 353 : JP = LTAB(IE,IP) 354 : VAL = 0.D0 355 : DO KP=1,NPT 356 : VAL = VAL + VELCHE(KP,IE) 357 : ENDDO 358 : VAL = VAL / NPT 359 : VPOCHA(JP,IC) = VAL 360 : ENDDO 361 : ENDIF 362 : SEGDES MELVAL 363 : ENDDO 364 : SEGDES MCHAML, IPT4 365 : ENDDO 366 : * 367 : * Fermeture des segments 368 : * 369 : SEGDES MPOVAL 370 : SEGDES MSOUPO 371 : SEGDES MCHPOI 372 : SEGDES IPT1 373 : SEGDES MCHELM 374 : SEGSUP ITRA,JTRA,KTRA 375 : 376 : IRET = MCHPOI 377 : RETURN 378 : END 379 : 380 : 381 : 382 : 383 : 384 : 385 : 386 : 387 : 388 :
© Cast3M 2003 - All rights reserved.
Disclaimer