1 : C FACGEN SOURCE CHAT 06/08/24 21:34:13 5529 2 : SUBROUTINE FACGEN (MYMOD,INFOEL,LRES,XDEC,IAXE,INOR,ICHFAC 3 : & ,EXTINC) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : C---------------------------------------------------------------------- 7 : C 03/96 l'hemicube est defini dans le repere local a la face "1" 8 : C 9 : C Calcul des facteurs de forme OPTION CACHE 3D 10 : C SP APPELE PAR FACFOR 11 : C entree: 12 : C MYMOD : objet modèle 13 : C INFOEL : segment décrivant la nature des éléments des maillages 14 : C LRES : parametre de resolution 15 : C XDEC : parametre de decoupage 16 : C IAXE : pointeur sur le LISTEN contenant les pointeurs des 17 : C points definissant le plan de symetrie 18 : C INOR : parametre de normalisation et impression 19 : C sortie: 20 : C ICHFAC : chamelem facteur de forme 21 : C---------------------------------------------------------------------- 22 : -INC CCOPTIO 23 : -INC SMCOORD 24 : POINTEUR MYMOD.MMODEL 25 : -INC TFFOR3D 26 : C-------------------------------------------------------------- 27 : C FACTEURS DE FORME 28 : C NNBEL1 = NOMBRE DE LIGNES + 1 29 : C NBEL2 = NOMBRE DE COLONNES 30 : C LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES 31 : C 32 : SEGMENT IFACFO 33 : INTEGER LFACT(NNBEL1) 34 : ENDSEGMENT 35 : SEGMENT LFAC 36 : REAL*8 FACT(NBEL2) 37 : ENDSEGMENT 38 : POINTEUR PSUR.LFAC, PLIG.LFAC 39 : POINTEUR PCOL.LFAC 40 : C-------------------------------------------------------------- 41 : SEGMENT SPROGP 42 : INTEGER MKF(MPT),MICOO(2,MPT) 43 : REAL*8 MXR(3,MPT) 44 : ENDSEGMENT 45 : C-------------------------------------------------------------- 46 : SEGMENT SKCEL 47 : INTEGER KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC) 48 : REAL*8 RMAX 49 : ENDSEGMENT 50 : C-------------------------------------------------------------- 51 : C segment qui va contenir les coordonnées du plan de symétrie 52 : SEGMENT ,LISTEN 53 : INTEGER LECT(NBE) 54 : ENDSEGMENT 55 : POINTEUR IAXE.LISTEN 56 : C-------------------------------------------------------------- 57 : C 58 : DIMENSION U1(4),U2(4) 59 : DIMENSION O1(3) 60 : DIMENSION A1(3,3),A2(3,3) 61 : DIMENSION UA(3),UN(3),UU2(4),AA2(3,3) 62 : C** changement de repere 63 : DIMENSION HCM(3,3),OH(3),AH1(3,3),UH1(4) 64 : DIMENSION AH2(3,3),UH2(4),AAH2(3,3),UUH2(4) 65 : C** 66 : C 67 : C-------------------------------------------------------------- 68 : C 69 : * Definition du common CKRESO 70 : KFC=6 71 : NRES = LRES 72 : KES = IDIM 73 : KIMP = IIMPI 74 : NSOM=3 75 : 76 : C 77 : C-----PLAN DE SYMETRIE----------------------------------------------- 78 : IF (IAXE.NE.0) THEN 79 : C A partir des trois points definissant le plan , on va garder 80 : C une normale et le premier point 81 : SEGACT IAXE 82 : IF (IIMPI.GE.1) THEN 83 : WRITE(6,*) ' CALCUL AVEC PLAN DE SYMETRIE ' 84 : ENDIF 85 : DO 100 IP= 1,NSOM 86 : C On boucle sur les points 87 : IREF = (IDIM+1)*(IAXE.LECT(IP)-1) 88 : DO 101 IIES= 1,IDIM 89 : C On boucle sur les coordonnées 90 : A1(IIES,IP) = XCOOR(IREF+IIES) 91 : C (boucle : pas de défaut de page pour un tableau 3*3 de réels) 92 : 101 CONTINUE 93 : 100 CONTINUE 94 : SEGDES IAXE 94 : CALL KNORM(IDIM,A1,IDIM,U1,SSS) 95 : DO 102 IIES = 1,IDIM 96 : UA(IIES) = A1(IIES,1) 97 : UN(IIES) = U1(IIES) 98 : 102 CONTINUE 99 : IF(KIMP.GE.2) THEN 100 : WRITE(6,*) ' plan de symetrie ' 101 : WRITE(6,*) ' point ',(UA(I),I=1,IDIM) 102 : WRITE(6,*) ' normale ',(UN(I),I=1,IDIM) 103 : ENDIF 104 : ENDIF 105 : 106 : C-----PLAN DE SYMETRIE----------------------------------------------- 107 : 108 : EPS = 1D-5 109 : C 110 : C 111 : C>>> PREPARATION 112 : C 112 : CALL KALPRE(MYMOD,INFOEL,SKFACE,XDEC,NELD) 113 : C 114 : C>>> INITIALISATION DES OBJETS DE TRAVAIL 115 : C 116 : 117 : NBEL1 = NELD 118 : NNBEL1 = NELD+1 119 : NBEL2 = NELD 120 : SEGINI IFACFO 121 : 122 : DO 900 LS=1,NNBEL1 123 : SEGINI PLIG 124 : LFACT(LS) = PLIG 125 : SEGDES PLIG 126 : 900 CONTINUE 127 : 128 : PSUR = LFACT(NNBEL1) 129 : SEGACT PSUR*MOD 130 : 131 : SEGACT SKFACE*MOD 132 : MFACE = NUK(/2) 133 : DO 910 K1 = 1,MFACE 134 : I1 = KCORR(K1) 135 : PSUR.FACT(I1) = PSUR.FACT(I1) + S(K1) 136 : 910 CONTINUE 137 : 138 : NR=NRES 139 : NES=KES 140 : NFC=KFC 141 : SEGINI SHC3D 142 : IF(KIMP.GE.2) THEN 143 : WRITE(6,*) ' SHC3D ',SHC3D 144 : ENDIF 144 : CALL KCACUB(NES,NR,G,V,NFC,KRO,KSI,IR) 144 : CALL KHCDAT(NR,KA,IM) 145 : 146 : NSTAC = NR*NR 147 : SEGINI SKCEL 148 : 149 : NFC = KRO(/1) 150 : NOC = 8 151 : RMAX = 0.9 152 : SEGINI SKBUFF 153 : 154 : MPT = 3 155 : SEGINI SPROGP 156 : 157 : NSE = 3 158 : NIMAX = 10*NR 159 : NSCEL = NIMAX 160 : SEGINI SPROJA 161 : 162 : C CALCUL 163 : C ------ 164 : 164 : CALL KFALIM(MFACE,K1D,K1F) 165 : DO 300 K1 = K1D,K1F 166 : 167 : I1 = KCORR(K1) 168 : IF (IIMPI.GE.4) WRITE(6,*) 'La facette',K1, 169 : # 'appartient à l élmt',I1 170 : PLIG = LFACT(I1) 171 : SEGACT PLIG*MOD 172 : 173 : SREL = S(K1)/PSUR.FACT(I1) 174 : 175 : DO 312 K=1,IDIM+1 176 : U1(K) = U(K,K1) 177 : 312 CONTINUE 178 : 179 : DO 201 ISS = 1,NSOM 180 : IREF = (IDIM+1)*(NUK(ISS,K1)-1) 181 : DO 202 K = 1,IDIM 182 : A1(K,ISS) = XCOOR(IREF+K) 183 : 202 CONTINUE 184 : 201 CONTINUE 185 : 186 : C** repere local a l'HC 187 : 187 : CALL KREPER(IDIM,NSOM,U1,A1,HCM) 188 : 189 : IPATCH = KPATCH(K1) 190 : SEGACT IPATCH 191 : 192 : NPATCH = GP(/2) 193 : 193 : CALL KTYPKS(NPATCH,KS1D,KS1F) 194 : DO 310 KS1 = KS1D,KS1F 195 : IF (IIMPI.GE.4) WRITE(6,*) ' K1 KS1 NPATCH ',K1,KS1,NPATCH 196 : 197 : DO 311 K=1,IDIM 198 : O1(K) = GP(K,KS1) 199 : 311 CONTINUE 200 : IF (IIMPI.GE.4) WRITE(6,*) K1, 201 : # KS1,' O1 ',(O1(I1),I1=1,IDIM) 202 : 202 : CALL KINBUF(SKBUFF) 203 : C 204 : C O1 est le point de vue sur la surface 1 205 : 206 : C coordonnées dans le repere local 207 : OH(1)=0.D0 208 : OH(2)=0.D0 209 : OH(3)=0.D0 210 : 210 : CALL KCHREP(IDIM,NSOM,O1,A1,U1,AH1,UH1,HCM) 211 : 211 : CALL KINPRO(UH1,SHC3D,SKBUFF) 212 : 212 : CALL KVERIF(SHC3D,SKBUFF) 213 : 214 : C 2eme boucle sur les faces 215 : C ------------------------- 216 : C RAPPEL: 217 : C CAS TRAITES KVU = 1 : TRAITEMENT COMMUN 218 : C KVU = 2 ET KSIG..=1 ----------------- 219 : C 220 : DO 400 K2 = 1,MFACE 221 : 222 : IF(KIMP.GE.4) THEN 223 : write(6,*) 224 : write(6,*) ' K1 K2 ',K1,K2 225 : ENDIF 226 : C 227 : DO 412 K=1,IDIM+1 228 : U2(K) = U(K,K2) 229 : 412 CONTINUE 230 : 231 : DO 211 ISS = 1,NSOM 232 : IREF = (IDIM+1)*(NUK(ISS,K2)-1) 233 : DO 212 K = 1,IDIM 234 : A2(K,ISS) = XCOOR(IREF+K) 235 : 212 CONTINUE 236 : 211 CONTINUE 237 : 238 : C coordonnées dans le repere local 238 : CALL KCHREP(IDIM,NSOM,O1,A2,U2,AH2,UH2,HCM) 239 : 240 : 241 : CNNN------SEQUENCE POUR LA FACE K2--------------------------------- 242 : C 243 : C>>> VISIBILITE A PRIORI 244 : C 244 : C** CALL KPRIOR(IDIM,NSOM,NSOM,A1,A2,U1,U2,KVU) 244 : CALL KPRIOR(IDIM,NSOM,NSOM,AH1,AH2,UH1,UH2,KVU) 245 : C 246 : IF (KVU.NE.0) THEN 247 : C** C = U2(IDIM+1) 248 : C = UH2(IDIM+1) 249 : C DO 401 IIES = 1,IDIM 250 : C** C = C + U2(IIES)*O1(IIES) 251 : C inutile C = C + UH2(IIES)*OH(IIES) 252 : C401 CONTINUE 253 : 254 : IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN 254 : C** CALL KPROJF(O1,A2,K1,K2,C,U2,SHC3D,SKCEL,SKBUFF,SPROGA,SPROGP) 254 : CALL KPROJF(OH,AH2,K1,K2,C,UH2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP) 255 : 256 : ENDIF 257 : 258 : ENDIF 259 : 260 : CNNN--FIN SEQUENCE POUR LA FACE K2--------------------------------- 261 : C 262 : IF (IAXE.NE.0) THEN 263 : 264 : CNNN------SEQUENCE POUR LA FACE SYMETRIQUE DE K2 ------------------ 265 : C LE PLAN SE SYMETRIE EST DEFINI PAR UN POINT UA 266 : C UNE NORMALE UNITAIRE UN 267 : C CALCUL DES SYMETRIQUES DE U2 ET A2(SOMMETS) 268 : C 269 : KES1 = IDIM + 1 269 : CALL KSYM(IDIM,KES1,A2,U2,AA2,UU2,UA,UN) 270 : 271 : C coordonnées dans le repere local 271 : CALL KCHREP(IDIM,NSOM,O1,AA2,UU2,AAH2,UUH2,HCM) 272 : 272 : C** CALL KPRIOR(IDIM,NSOM,NSOM,A1,AA2,U1,UU2,KVU) 272 : CALL KPRIOR(IDIM,NSOM,NSOM,AH1,AAH2,UH1,UUH2,KVU) 273 : 274 : IF (KVU.NE.0) THEN 275 : C** C = UU2(IDIM+1) 276 : C = UUH2(IDIM+1) 277 : CC DO 402 IIES = 1,IDIM 278 : C** C = C + UU2(IIES)*O1(IIES) 279 : C inutile C = C + UUH2(IIES)*OH(IIES) 280 : C402 CONTINUE 281 : 282 : IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN 282 : C** CALL KPROJF(O1,AA2,K1,K2,C,UU2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP) 282 : CALL KPROJF(OH,AAH2,K1,K2,C,UUH2 283 : & ,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP) 284 : ENDIF 285 : 286 : ENDIF 287 : 288 : CNNN--FIN SEQUENCE POUR LA FACE SYMETRIQUE DE K2------------------- 289 : 290 : ENDIF 291 : 400 CONTINUE 292 : C 293 : C>>> RECOMBINAISON 294 : C 295 : SSP1 = SP(KS1) 295 : CALL KRCOMB(K1,SSP1,SHC3D,SKFACE,SKBUFF,EXTINC) 296 : 297 : IF (K1F.NE.MFACE) THEN 298 : FFFT = 0.D0 299 : DO 420 K2=1,MFACE 300 : FFFT = FFFT + FF1(K2) 301 : 420 CONTINUE 302 : WRITE(6,*) ' ' 303 : WRITE(6,*) ' FIJ RELATIF A LA FACE (TRI3) ',K1,' SOMME ',FFFT 303 : CALL UTPRIM(FF1,MFACE) 304 : ENDIF 305 : 306 : DO 920 K2 = 1,MFACE 307 : I2 = KCORR(K2) 308 : PLIG.FACT(I2) = PLIG.FACT(I2) + FF1(K2)*SREL 309 : 920 CONTINUE 310 : 311 : 310 CONTINUE 312 : 313 : SEGDES PLIG 314 : SEGDES IPATCH 315 : 300 CONTINUE 316 : C 317 : C ------------------------------------------------------------- 318 : C 319 : SEGDES IFACFO 320 : SEGDES PSUR 321 : C 322 : SEGSUP ,SHC3D,SKCEL,SKBUFF 323 : SEGSUP ,SPROGP,SPROJA 324 : SEGSUP SKFACE 325 : C 325 : IF (K1D.NE.1.AND.K1F.NE.MFACE) CALL ARRET(0) 326 : C 327 : C>>> NORMALISATION ET SYMETRISATION 328 : C ------------------------------ 329 : 330 : IF(EXTINC.GT.1D-3) THEN 331 : INOR=0 332 : ENDIF 333 : 333 : CALL KFN(IFACFO,INOR,KIMP) 334 : 335 : IF(KIMP.GE.3) THEN 335 : CALL PRFACF(IFACFO) 336 : ENDIF 337 : C 338 : C 339 : C>>> TRADUCTION 340 : C ---------- 341 : LTITR=1 341 : CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR) 342 : C 343 : C Destruction de IFACFO après traduction 344 : SEGACT IFACFO 345 : NNBEL1 = LFACT(/1) 346 : DO 950 NN = 1,NNBEL1 347 : PLIG = LFACT(NN) 348 : SEGSUP PLIG 349 : 950 CONTINUE 350 : SEGSUP IFACFO 351 : 352 : RETURN 353 : END 354 : 355 : 356 : 357 :
© Cast3M 2003 - All rights reserved.
Disclaimer