1 : C FLUCOQ SOURCE BP208322 13/07/30 21:15:01 7809 2 : 3 : C======================================================================= 4 : C= F L U C O Q = 5 : C= ----------- = 6 : C= = 7 : C= Fonction : = 8 : C= ---------- = 9 : C= Calcul des flux nodaux equivalents a une condition de FLUX IMPOSE = 10 : C= pour des elements de type COQUE = 11 : C= Sous-programme appele par FLUX2 (flux2.eso) = 12 : C= = 13 : C= Parametres : (E)=Entree (S)=Sortie = 14 : C= ------------ = 15 : C= IPMODE (E) Pointeur sur le segment MMODEL = 16 : C= IPGEOM (E) Objet MAILLAGE support de IPCHPO = 17 : C= IPCHPO (E) Pointeur sur le CHPOINT (ou le MCHAML) de flux = 18 : C= imposes aux noeuds de la structure = 19 : C= (champ variable ou constant) = 20 : C= NUMPOI (E) Vaut -1 si le flux impose est normal a la surface, = 21 : C= sinon pointeur sur un POINT correspondant a la = 22 : C= direction du flux (par rapport au repere global) = 23 : C= MOCOMP (E) Nom de la composante du champ de flux equivalents = 24 : C= MLMOTX (E) Pointeur MLMOTS de la liste des composantes de = 25 : C= IPCHPO associees aux 3 directions x,y,z. = 26 : C= IPFLUX (S) Pointeur sur le champ des flux nodaux equivalents = 27 : C= = 28 : C= Variables locales : = 29 : C= ------------------- = 30 : C= ITGEOM Pointeur sur un MAILLAGE elementaire COQUE = 31 : C= IPENVE Pointeur sur l'enveloppe d'un maillage COQUE = 32 : C= IPGEOM Pointeur sur un MAILLAGE elementaire du CHPOINT = 33 : C= IPOGEO Pointeur sur un MAILLAGE commun au CHPOINT et au COQUE = 34 : C= = 35 : C======================================================================= 36 : 37 : SUBROUTINE FLUCOQ (IPMODE,IPGEOM,IPCHPO,NUMPOI,NOMCQ,MLMOTX, 38 : & IPFLUX) 39 : 40 : IMPLICIT INTEGER(I-N) 41 : IMPLICIT REAL*8 (A-H,O-Z) 42 : 43 : -INC CCOPTIO 44 : -INC CCHAMP 45 : -INC CCREEL 46 : -INC SMCHAML 47 : -INC SMCHPOI 48 : -INC SMMODEL 49 : -INC SMELEME 50 : -INC SMCOORD 51 : -INC SMLMOTS 52 : 53 : CHARACTER*(*) NOMCQ 54 : 55 : PARAMETER (XUn=1.) 56 : 57 : DIMENSION IVAL(4) 58 : CHARACTER*4 IMOT1,IMOT2 59 : 60 : C= Activation du MMODEL 61 : MMODEL=IPMODE 62 : SEGACT,MMODEL 63 : NSOU=KMODEL(/1) 64 : C= Activation de MLMOTX si defini 65 : IF (MLMOTX.NE.0) THEN 66 : MLMOTS=MLMOTX 67 : SEGACT,MLMOTS 68 : NINC = MOTS(/2) 69 : ENDIF 70 : 71 : C BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE 72 : C ============================================= 73 : idimp1=IDIM+1 74 : IRRT=0 75 : IFOI=0 76 : DO ISOU=1,NSOU 77 : 78 : IPCHEL=0 79 : 80 : IMODEL=KMODEL(ISOU) 81 : SEGACT,IMODEL 82 : ITGEOM=IMAMOD 83 : NEF=NEFMOD 84 : 85 : IPENVE=ITGEOM 86 : 87 : * ON RECUPERE LES MAILLAGES ELEMENTAIRES DE L'ENVELOPPE 88 : * APPUYES STRICTEMENT SUR LE CHPOINT DE FLUX 88 : CALL ECROBJ('MAILLAGE',IPGEOM) 88 : CALL ECRCHA('STRI') 88 : CALL ECRCHA('APPU') 88 : CALL ECROBJ('MAILLAGE',IPENVE) 88 : CALL EXTREL(IRR,0,i) 89 : 90 : * IL Y A DES MAILLAGES COMMUNS AU CHPOINT ET A L'ENVELOPPE 91 : IF (IRR.EQ.0) THEN 91 : CALL LIROBJ('MAILLAGE',IPOGEO,1,IRET) 92 : IF (IERR.NE.0) GOTO 8 93 : * ON DESIRE CONNAITRE LES CARACTERISTIQUES DE CES MAILLAGES 94 : IPT3=IPOGEO 95 : SEGACT,IPT3 96 : NSOU3=IPT3.LISOUS(/1) 97 : IF (NSOU3.EQ.0) THEN 98 : NBN2=IPT3.NUM(/1) 99 : ENDIF 100 : 101 : * BOUCLE SUR LES ZONES DE CET OBJET GEOMETRIQUE 102 : DO IMAIL=1,MAX(1,NSOU3) 103 : IF (NSOU3.NE.0) THEN 104 : IPT2=IPT3.LISOUS(IMAIL) 105 : SEGACT,IPT2 106 : IPOGEO=IPT2 107 : NBN2=IPT2.NUM(/1) 108 : SEGDES,IPT2 109 : ENDIF 110 : * RECHERCHE DE LA FORMULATION DES (SUR)FACES 111 : NEFACE=NUMGEO(NEF) 112 : * RECUPERATION DES CARACTERISTIQUES D'INTEGRATION 112 : CALL TSHAPE(NEFACE,'GAUSS',IPINTE) 113 : * ECHEC DANS L'ACQUISITION DES CARACTERISTIQUES D'INTEGRATION 114 : IF (IERR.NE.0) THEN 115 : SEGDES,IPT3 116 : GOTO 8 117 : ENDIF 118 : 119 : * ON GENERE UN CHAMELEM ELEMENTAIRE DE FLUX 120 : * A PARTIR DU MAILLAGE ELEMENTAIRE DE POINTEUR IPOGEO 121 : * ET DU CHPOINT 122 : if (IPCHPO.gt.0) then 122 : CALL CHAME1(IPOGEO,0,IPCHPO,' ',ICHELF,6) 123 : else 124 : *ou ET DU MCHAML 125 : ICHE = -1*IPCHPO 125 : CALL REDUIC(ICHE,IPOGEO,ICHELF) 126 : endif 127 : MCHEL1=ICHELF 128 : IF (IERR.NE.0) THEN 129 : SEGDES,IPT3 130 : GOTO 8 131 : ENDIF 132 : SEGACT,MCHEL1 133 : MCHAM1=MCHEL1.ICHAML(1) 134 : SEGDES,MCHEL1 135 : SEGACT,MCHAM1 136 : NBCOMP=MCHAM1.IELVAL(/1) 137 : IF (NBCOMP.EQ.1) THEN 138 : IPFLOD=MCHAM1.IELVAL(1) 139 : SEGDES,MCHAM1 140 : ELSE 141 : C POUR CHAQUE ELEMENT, 142 : C ON DETERMINE UN VECTEUR DIRIGE VERS L INTERIEUR DU MASSIF 143 : C A PARTIR D UN POINT DE LA FACE ET DU CENTRE DE GRAVITE DU MASSIF 144 : C ON COPIE LE CHAMP EN AJOUTANT UNE COMPOSANTE 145 : IF (MLMOTX.EQ.0) THEN 146 : MOTERR(1:8)='LISTMOTS' 146 : CALL ERREUR(37) 147 : RETURN 148 : ENDIF 149 : MLMOTS=MLMOTX 150 : SEGACT,MLMOTS 151 : NINC=MOTS(/2) 152 : IF (NINC.NE.IDIM) THEN 152 : CALL ERREUR(21) 153 : SEGDES,MLMOTS 154 : GOTO 8 155 : ENDIF 156 : MELVAL=MCHAM1.IELVAL(1) 157 : SEGACT,MELVAL 158 : N1PTEL=VELCHE(/1) 159 : N1EL=VELCHE(/2) 160 : SEGDES,MELVAL 161 : N2PTEL=0 162 : N2EL=0 163 : NBCOMP=IDIM 164 : N2=NBCOMP+IDIM 165 : SEGINI,MCHAML 166 : IPFLOD=MCHAML 167 : DO I=1,N2 168 : SEGINI,MELVAL 169 : IELVAL(I)=MELVAL 170 : SEGDES,MELVAL 171 : ENDDO 172 : DO I=1,NINC 173 : IMOT1=MOTS(i) 174 : DO J=1,NINC 175 : IMOT2=MCHAM1.NOMCHE(J) 176 : IF (IMOT1.EQ.IMOT2) IVAL(I)=J 177 : ENDDO 178 : ENDDO 179 : SEGDES,MLMOTS 180 : DO I=1,NBCOMP 181 : MELVA1=MCHAM1.IELVAL(IVAL(I)) 182 : MELVAL=IELVAL(I) 183 : SEGACT,MELVAL*MOD,MELVA1 184 : DO j=1,N1EL 185 : DO k=1,N1PTEL 186 : VELCHE(k,j)=MELVA1.VELCHE(k,j) 187 : ENDDO 188 : ENDDO 189 : SEGDES,MELVA1 190 : ENDDO 191 : C activation des composantes supplementaires 192 : DO i=NBCOMP+1,N2 193 : MELVAL=IELVAL(i) 194 : SEGACT,MELVAL*MOD 195 : ENDDO 196 : NBPTE1=N1PTEL 197 : NEL1=N1EL 198 : SEGDES,MCHAM1 199 : NUMPOI=1 200 : MELEME=IPOGEO 201 : IPT1=ITGEOM 202 : SEGACT,MELEME,IPT1 203 : NBMA1=NUM(/1) 204 : DO IEF=1,NUM(/2) 205 : DO IEM=1,IPT1.NUM(/2) 206 : JNE=0 207 : DO INM=1,IPT1.NUM(/1) 208 : DO INF=1,NBMA1 209 : IF (IPT1.NUM(INM,IEM).EQ.NUM(INF,IEF)) JNE=JNE+1 210 : ENDDO 211 : ENDDO 212 : IF (JNE.EQ.NBMA1) GOTO 170 213 : ENDDO 214 : SEGDES,IPT1,MELEME 215 : DO j=1,N2 216 : MELVAL=IELVAL(j) 217 : SEGSUP,MELVAL 218 : ENDDO 219 : SEGDES,MCHAML 220 : SEGSUP,IPT3 221 : GOTO 8 222 : C CDG element de "volume" 223 : C CDG de la "face" 224 : C Calcul de la normale interieure (stocker dans MCHAML) 225 : 170 NBM=IPT1.NUM(/1) 226 : IF (IDIM.EQ.2) THEN 227 : XG=XZero 228 : YG=XZero 229 : DO INM=1,NBM 230 : IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1 231 : XG=XG+XCOOR(IREFM+1) 232 : YG=YG+XCOOR(IREFM+2) 233 : ENDDO 234 : XG=XG/NBM 235 : YG=YG/NBM 236 : XK=XZero 237 : YK=XZero 238 : DO INF=1,NBMA1 239 : IREFF=(NUM(INF,IEF)-1)*idimp1 240 : XK=XK+XCOOR(IREFF+1) 241 : YK=YK+XCOOR(IREFF+2) 242 : ENDDO 243 : XK=XK/NBMA1 244 : YK=YK/NBMA1 245 : V1=XG-XK 246 : V2=YG-YK 247 : VN=SQRT(V1*V1+V2*V2) 248 : V1=V1/VN 249 : V2=V2/VN 250 : DO INF=1,NBMA1 251 : MELVAL=IELVAL(NBCOMP+1) 252 : VELCHE(INF,IEF)=V1 253 : MELVAL=IELVAL(NBCOMP+2) 254 : VELCHE(INF,IEF)=V2 255 : ENDDO 256 : ELSE IF (IDIM.EQ.3) THEN 257 : XG=XZero 258 : YG=XZero 259 : ZG=XZero 260 : DO INM=1,NBM 261 : IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1 262 : XG=XG+XCOOR(IREFM+1) 263 : YG=YG+XCOOR(IREFM+2) 264 : ZG=ZG+XCOOR(IREFM+3) 265 : ENDDO 266 : XG=XG/NBM 267 : YG=YG/NBM 268 : ZG=ZG/NBM 269 : XK=XZero 270 : YK=XZero 271 : ZK=XZero 272 : DO INF=1,NBMA1 273 : IREFF=(NUM(INF,IEF)-1)*idimp1 274 : XK=XK+XCOOR(IREFF+1) 275 : YK=YK+XCOOR(IREFF+2) 276 : ZK=ZK+XCOOR(IREFF+3) 277 : ENDDO 278 : XK=XK/NBMA1 279 : YK=YK/NBMA1 280 : ZK=ZK/NBMA1 281 : V1=XG-XK 282 : V2=YG-YK 283 : V3=ZG-ZK 284 : VN=SQRT(V1*V1+V2*V2+V3*V3) 285 : V1=V1/VN 286 : V2=V2/VN 287 : V3=V3/VN 288 : DO INF=1,NBMA1 289 : MELVAL=IELVAL(NBCOMP+1) 290 : VELCHE(INF,IEF)=V1 291 : MELVAL=IELVAL(NBCOMP+2) 292 : VELCHE(INF,IEF)=V2 293 : MELVAL=IELVAL(NBCOMP+3) 294 : VELCHE(INF,IEF)=V3 295 : ENDDO 296 : ELSE IF (IDIM.EQ.1) THEN 297 : XG=XZero 298 : DO INM=1,NBM 299 : IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1 300 : XG=XG+XCOOR(IREFM+1) 301 : ENDDO 302 : XG=XG/NBM 303 : XK=XZero 304 : DO INF=1,NBMA1 305 : IREFF=(NUM(INF,IEF)-1)*idimp1 306 : XK=XK+XCOOR(IREFF+1) 307 : ENDDO 308 : XK=XK/NBMA1 309 : V1=XG-XK 310 : V1=V1/ABS(V1) 311 : DO INF=1,NBMA1 312 : MELVAL=IELVAL(NBCOMP+1) 313 : VELCHE(INF,IEF)=V1 314 : ENDDO 315 : ENDIF 316 : ENDDO 317 : DO j=1,IDIM 318 : MELVAL=IELVAL(NBCOMP+j) 319 : SEGDES,MELVAL 320 : ENDDO 321 : SEGDES,MCHAML 322 : SEGDES,IPT1,MELEME 323 : ENDIF 324 : * CHAMELEM ELEMENTAIRE DES FLUX NODAUX EQUIVALENTS 325 : L1=7 326 : N1=1 327 : N3=1 328 : SEGINI,MCHELM 329 : IPCHEL=MCHELM 330 : TITCHE='CHALEUR' 331 : IFOCHE=IFOUR 332 : INFCHE(1,1)=0 333 : IMACHE(1)=IPOGEO 334 : N2=1 335 : SEGINI,MCHAML 336 : ICHAML(1)=MCHAML 337 : NOMCHE(1)='FLUX' 338 : TYPCHE(1)='REAL*8' 339 : * CALCUL DES FLUX NODAUX EQUIVALENTS 340 : * FACES ASSOCIEES SEG2 OU SEG3 341 : IF (NEFACE.EQ.2.OR.NEFACE.EQ.3) THEN 341 : CALL FLUMA2(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ) 342 : * FACES ASSOCIEES TRI3,TRI6,QUA4 OU QUA8 343 : ELSE IF (NEFACE.EQ. 4.OR.NEFACE.EQ.6.OR.NEFACE.EQ.8.OR. 344 : . NEFACE.EQ.10) THEN 344 : CALL FLUMA3(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ) 345 : * FACES ASSOCIEES POI1 346 : ELSE IF (NEFACE.EQ.45) THEN 346 : CALL FLUMA1(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ) 347 : ENDIF 348 : IF (NUMPOI.EQ.1) THEN 349 : MCHAM2=IPFLOD 350 : SEGACT,MCHAM2 351 : DO i=1,MCHAM2.IELVAL(/1) 352 : MELVAL=MCHAM2.IELVAL(i) 353 : SEGSUP,MELVAL 354 : ENDDO 355 : SEGSUP,MCHAM2 356 : ENDIF 357 : IF (IERR.NE.0) THEN 358 : SEGDES,IPT3 359 : SEGSUP,MCHAML,MCHELM 360 : GOTO 8 361 : ENDIF 362 : IELVAL(1)=IPFLEQ 363 : SEGDES,MCHAML,MCHELM 364 : * ON TRANSFORME LE CHAMELEM EN CHPOINT 364 : CALL CHAMPO(IPCHEL,0,IPCH1,IDUM) 365 : MCHPOI=IPCH1 366 : SEGACT,MCHPOI 367 : DO i=1,IPCHP(/1) 368 : MSOUPO=IPCHP(i) 369 : SEGACT,MSOUPO*MOD 370 : NOCOMP(1)=nomcq 371 : SEGDES,MSOUPO 372 : ENDDO 373 : SEGDES,MCHPOI 373 : CALL DTCHEL(IPCHEL) 374 : * ON REGROUPE,LE CAS ECHEANT,LES DIFFERENTS CHPOINTS 375 : IF ((ISOU-IRRT).GT.1.OR.IMAIL.GT.1) THEN 375 : CALL ADCHPO(IPCH1,IPFLUX,IRET,XUn,XUn) 376 : IF (IRET.EQ.0) GOTO 8 376 : C* CALL ECRCHA('GEOM') 376 : CALL DTCHPO(IPCH1) 376 : C* CALL ECRCHA('GEOM') 376 : CALL DTCHPO(IPFLUX) 377 : IPFLUX=IRET 378 : ELSE 379 : IPFLUX=IPCH1 380 : ENDIF 381 : ENDDO 382 : SEGDES,IPT3 383 : * ON N'A PAS TROUVE DE MAILLAGE COMMUN A CETTE PARTIE DE 384 : * L'ENVELOPPE ET DU CHPOINT 385 : ELSE IF (IRR.EQ.1) THEN 386 : IRRT=IRRT+1 387 : ENDIF 388 : ENDDO 389 : 390 : * IL N'EXISTE PAS D'ELEMENTS COMMUNS AU CHPOINT DES FLUX NODAUX 391 : * ET A L'ENVELOPPE DU MASSIF 391 : IF (IRRT.EQ.NSOU) CALL ERREUR(408) 392 : 393 : 8 DO i=1,IFOI 394 : IMODEL=KMODEL(i) 395 : SEGDES,IMODEL 396 : ENDDO 397 : SEGDES,MMODEL 398 : 399 : RETURN 400 : END 401 : 402 : 403 : 404 :
© Cast3M 2003 - All rights reserved.
Disclaimer