1 : C FACGE2 SOURCE CHAT 05/01/12 23:55:27 5004 2 : SUBROUTINE FACGE2 (MYMOD,INFOEL,LRES,XDEC,IAXE,INOR,ICHFAC 3 : & ,EXTINC) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : *---------------------------------------------------------------------- 7 : * Calcul des facteurs de forme OPTION CACHE 2D-plan 8 : * SP APPELE PAR FFORME 9 : * entrée 10 : * MYMOD : objet modèle 11 : * INFOEL : segment décrivant la nature des éléments des maillages 12 : * LRES : parametre de resolution 13 : * XDEC : parametre de decoupage 14 : * IAXE : pointeur sur le chamtrio decrivant le plan de sym‚trie 15 : * INOR : paramŠtre de normalisation et impression 16 : * EXTINC : coefficient d'extinction si cavite absorbante 17 : * sortie 18 : * ICHFAC : chamelem facteur de forme 19 : *---------------------------------------------------------------------- 20 : -INC CCOPTIO 21 : -INC SMCOORD 22 : -INC SMELEME 23 : C 24 : C---------------------------------------------------------------------- 25 : C segment qui va contenir les coordonnées du plan de symétrie 26 : SEGMENT ,LISTEN 27 : INTEGER LECT(NBE) 28 : ENDSEGMENT 29 : POINTEUR IAXE.LISTEN 30 : 31 : C----------------------------------------------------------------------- 32 : SEGMENT SKRESO 33 : INTEGER KFC,NRES,KES,KIMP 34 : ENDSEGMENT 35 : C KFC : NOMBRE DE FACES H.C 36 : C NRES: RESOLUTION 37 : C KES : DIM ESPACE 38 : C KIMP: IMPRESSION 39 : C----------------------------------------------------------------------- 40 : SEGMENT SKFAC2 41 : INTEGER NUK(MS,MFACE),KPATCH(MFACE) 42 : INTEGER NCELL(MFACE) 43 : REAL*8 U(3,MFACE),S(MFACE) 44 : REAL*8 FF1(MFACE) 45 : ENDSEGMENT 46 : SEGMENT IPATCH 47 : REAL*8 GP(MSP,NPATCH),SP(NPATCH) 48 : ENDSEGMENT 49 : C 50 : C DESCRIPTION DES ELEMENTS 51 : C ------------------------ 52 : C MFACE : NOMBRE DE FACES 53 : C NUK : CONNECTIVITES 54 : C U : NORMALE UNITAIRE ET EQUATION DU PLAN DE L'ELEMENT 55 : C S : SURFACE 56 : C KVU : VISIBILITE A PRIORI 57 : C FF : FACTEURS DE FORME 58 : C FF1 : TRAVAIL 59 : C NCELL : NOMBRE TOTAL DE CELLULES VUES PAR UN POINT 60 : C KPATCH: POINTEUR SUR IPATCH 61 : C NPATCH: NOMBRE DE POINTS SUR L'ELEMENT (REDECOUPAGE) 62 : C GP : COORDONNEES DES POINTS 63 : C SP : ET SURFACES 64 : C----------------------------------------------------------------------- 65 : SEGMENT SHC2D 66 : INTEGER IR(NR),KA(NFC),IM(NFC,NFC) 67 : INTEGER KRO(NFC,NES),KSI(NFC,NES) 68 : REAL*8 V(NES,NR),G(NR) 69 : ENDSEGMENT 70 : 71 : C DESCRIPTION DU H.C DE PROJECTION 72 : C -------------------------------- 73 : C V : DIRECTION UNITAIRE DES CELLULES 74 : C G : FACTEUR DE FORME ASSOCIE 75 : C IR: CORRESPONDANCE 76 : C KRO , KSI : POUR LE CHANGEMENT DE REPERE 77 : C IM : REFERENCE 78 : C NR : RESOLUTION 79 : C NFC : NOMBRE DE FACES 80 : C----------------------------------------------------------------------- 81 : SEGMENT SKBUF2 82 : INTEGER NUMF(NFC,NOC,NR),NTYP(NFC,NR) 83 : REAL*8 ZB(NFC,NR),PSC(NFC,NR) 84 : ENDSEGMENT 85 : C 86 : C BUFFER ASSOCIE AU H.C 87 : C --------------------- 88 : C NUMF : INDICE DE LE DERNIERE FACE RENCONTREE 89 : C NTYP : TYPES ASSOCIES 90 : C ZB : PROFONDEUR 91 : C PSC : PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE) 92 : C----------------------------------------------------------------------- 93 : C FACTEURS DE FORME 94 : C NNBEL1 = NOMBRE DE LIGNES + 1 95 : C NBEL2 = NOMBRE DE COLONNES 96 : C LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES 97 : C 98 : SEGMENT IFACFO 99 : INTEGER LFACT(NNBEL1) 100 : ENDSEGMENT 101 : SEGMENT LFAC 102 : REAL*8 FACT(NBEL2) 103 : ENDSEGMENT 104 : POINTEUR PSUR.LFAC, PLIG.LFAC 105 : POINTEUR PCOL.LFAC 106 : C---------------------------------------------------------------------- 107 : SEGMENT STRAV 108 : REAL*8 U1(3),U2(3),O1(2) 109 : REAL*8 A1(2,2),A2(2,2) 110 : REAL*8 AA2(2,2),UU2(3),UA(2),UN(2) 111 : ENDSEGMENT 112 : C---------------------------------------------------------------------- 113 : *////// 114 : * Mise à jour de variables SKRESO 115 : SEGINI SKRESO 116 : KES = IDIM 117 : KIMP = IIMPI 118 : NRES = LRES 119 : KFC=4 120 : *////// 121 : SEGINI STRAV 122 : C 123 : C 124 : CNN-----AXE DE SYMETRIE-------------------------------------------------- 125 : IF (IAXE.NE.0) THEN 126 : SEGACT IAXE 127 : IF(IIMPI.GE.1) THEN 128 : WRITE(6,*) ' CALCUL AVEC AXE DE SYMETRIE ' 129 : ENDIF 130 : C Numéro des 2 points définissant l'axe 131 : IREF1 = (IDIM+1)*(IAXE.LECT(1)-1) 132 : IREF2 = (IDIM+1)*(IAXE.LECT(2)-1) 133 : C On garde un point ( UA ) et la normale ( UN ) 134 : UA(1) = XCOOR(IREF1+1) 135 : UA(2) = XCOOR(IREF1+2) 136 : UN(1) = UA(2) - XCOOR(IREF2+2) 137 : UN(2) = XCOOR(IREF2+1) - UA(1) 138 : DUN=DSQRT(UN(1)*UN(1)+UN(2)*UN(2)) 139 : IF (DUN.LT.1.E-5) THEN 140 : WRITE(6,*) ' LES POINTS DE L AXE SONT CONFONDUS ' 140 : CALL ARRET(0) 141 : RETURN 142 : ENDIF 143 : UN(1) = UN(1)/DUN 144 : UN(2) = UN(2)/DUN 145 : SEGDES IAXE 146 : ENDIF 147 : CNN------------------------------------------------------------------ 148 : NSOM = 2 149 : EPS = 1E-5 150 : 151 : C 152 : C>>> PREPARATION 153 : C 153 : CALL KALPR2(MYMOD,INFOEL,SKFAC2,SHC2D,XDEC,NELD,SKRESO) 154 : C 155 : C>>> INITIALISATION OBJET FACFOR 156 : C 157 : NBEL1 = NELD 158 : NNBEL1 = NELD+1 159 : NBEL2 = NELD 160 : SEGINI IFACFO 161 : 162 : DO 900 LS=1,NNBEL1 163 : SEGINI PLIG 164 : LFACT(LS) = PLIG 165 : SEGDES PLIG 166 : 900 CONTINUE 167 : 168 : PSUR = LFACT(NNBEL1) 169 : SEGACT PSUR*MOD 170 : SEGACT SKFAC2 171 : MFACE = NUK(/2) 172 : DO 910 K1 = 1,MFACE 173 : PSUR.FACT(K1) = PSUR.FACT(K1) + S(K1) 174 : 910 CONTINUE 175 : 176 : C ------------------------------------------------------------- 177 : C>>> CALCUL 178 : C 179 : SEGACT SHC2D,SKFAC2*MOD 180 : MFACE = NUK(/2) 181 : 182 : 183 : NR = IR(/1) 184 : NFC = KRO(/1) 185 : NOC = 4 186 : SEGINI SKBUF2 187 : 187 : CALL KFALIM(MFACE,K1D,K1F) 188 : DO 300 K1 = K1D,K1F 189 : 190 : PLIG = LFACT(K1) 191 : SEGACT PLIG*MOD 192 : 193 : DO 312 K=1,IDIM+1 194 : U1(K) = U(K,K1) 195 : 312 CONTINUE 196 : 197 : DO 201 ISS = 1,NSOM 198 : IREF = (IDIM+1)*(NUK(ISS,K1)-1) 199 : DO 202 K = 1,IDIM 200 : A1(K,ISS) = XCOOR(IREF+K) 201 : 202 CONTINUE 202 : 201 CONTINUE 203 : 203 : CALL KINPR2(U1,SHC2D,SKBUF2,SKRESO) 203 : CALL KVERI2(SHC2D,SKBUF2,SKRESO) 204 : 205 : IPATCH = KPATCH(K1) 206 : SEGACT IPATCH 207 : NPATCH = GP(/2) 208 : 208 : CALL KTYPKS(NPATCH,KS1D,KS1F) 209 : 210 : DO 310 KS1 = KS1D,KS1F 211 : 212 : DO 311 K=1,IDIM 213 : O1(K) = GP(K,KS1) 214 : 311 CONTINUE 215 : IF (IIMPI.GE.4) THEN 216 : WRITE(6,*) K1,KS1,' O1 ',(O1(I1),I1=1,IDIM) 217 : ENDIF 217 : CALL KINBU2(SKBUF2,SKRESO) 218 : C 219 : C FACES 220 : C ----- 221 : DO 400 K2 = 1,MFACE 222 : 223 : DO 412 K=1,IDIM+1 224 : U2(K) = U(K,K2) 225 : 412 CONTINUE 226 : 227 : DO 211 ISS = 1,NSOM 228 : IREF = (IDIM+1)*(NUK(ISS,K2)-1) 229 : DO 212 K = 1,IDIM 230 : A2(K,ISS) = XCOOR(IREF+K) 231 : 212 CONTINUE 232 : 211 CONTINUE 233 : 234 : CNNN-------SEQUENCE POUR LA FACE K2 DU MAILLAGE-------------- 235 : 235 : CALL KPRIOR(IDIM,NSOM,NSOM,A1,A2,U1,U2,KVU) 236 : 237 : IF (KVU.NE.0) THEN 238 : 239 : C = U2(IDIM+1) 240 : DO 401 IES = 1,IDIM 241 : C = C + U2(IES)*O1(IES) 242 : 401 CONTINUE 243 : IF (IIMPI.GE.4) WRITE(6,*) 'FACES ',K1,' ',K2,' KVU ',KVU 244 : 245 : IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN 245 : CALL KREMP2(K1,K2,O1,A2,C,U2,SHC2D,SKBUF2,SKRESO) 246 : ENDIF 247 : ENDIF 248 : CNNN------------------------------------------------------------- 249 : 250 : IF(IAXE.NE.0) THEN 251 : 252 : CNNN-------SEQUENCE POUR LA FACE SYMETRIQUE DE K2-------------------- 253 : C L'AXE DE SYMETRIE EST DEFINI PAR UN POINT UA 254 : C UNE NORMALE UNITAIRE 255 : C CALCUL DES SYMETRIQUES DE U2(NORMALE) ET A2(SOMMETS) 256 : C 257 : KES1 = IDIM + 1 257 : CALL KSYM(IDIM,KES1,A2,U2,AA2,UU2,UA,UN) 258 : 258 : CALL KPRIOR(IDIM,NSOM,NSOM,A1,AA2,U1,UU2,KVU) 259 : 260 : IF (KVU.NE.0) THEN 261 : 262 : C = UU2(IDIM+1) 263 : DO 403 IES = 1,IDIM 264 : C = C + UU2(IES)*O1(IES) 265 : 403 CONTINUE 266 : IF (IIMPI.GE.4) WRITE(6,*) 'FACES ',K1,' ',K2,' KVU ',KVU 267 : 268 : IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN 268 : CALL KREMP2(K1,K2,O1,AA2,C,UU2,SHC2D,SKBUF2,SKRESO) 269 : ENDIF 270 : ENDIF 271 : CNNN------------------------------------------------------------- 272 : ENDIF 273 : 274 : 400 CONTINUE 275 : C 276 : C>>> RECOMBINAISON 277 : C 278 : SSP1 = SP(KS1) 279 : 280 : C<< 281 : IF(EXTINC.LE.1D-3) THEN 281 : CALL KRCOM2(K1,SSP1,SHC2D,SKFAC2,SKBUF2,SKRESO) 282 : ELSE 282 : CALL KRCOA2(K1,SSP1,SHC2D,SKFAC2,SKBUF2,SKRESO,EXTINC) 283 : ENDIF 284 : C<< 285 : DO 920 K2 = 1,MFACE 286 : PLIG.FACT(K2) = PLIG.FACT(K2) + FF1(K2) 287 : 920 CONTINUE 288 : 289 : 310 CONTINUE 290 : SEGDES IPATCH 291 : SEGDES PLIG 292 : 293 : 300 CONTINUE 294 : 295 : C ------------------------------------------------------------- 296 : 297 : DO 500 K2=1,MFACE 298 : IPATCH=KPATCH(K2) 299 : SEGSUP IPATCH 300 : 500 CONTINUE 301 : SEGSUP SKFAC2 302 : 303 : SEGSUP SHC2D,SKBUF2 304 : C 305 : C>>> CALCUL DES BILANS, IMPRESSION, NORMALISATION 306 : C -------------------------------------------- 307 : 308 : LIMP=KIMP 309 : C<< 310 : IF(EXTINC.GT.1D-3) THEN 311 : INOR = 0 312 : ENDIF 313 : C<< 313 : CALL KFN(IFACFO,INOR,LIMP) 314 : C 315 : *////// 316 : IF(KIMP.GE.3) THEN 316 : CALL PRFACF(IFACFO) 317 : ENDIF 318 : *////// 319 : LTITR=1 319 : CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR) 320 : 321 : C Destruction de IFACFO après traduction 322 : SEGACT IFACFO 323 : NNBEL1 = LFACT(/1) 324 : DO 950 NN = 1,NNBEL1 325 : PLIG = LFACT(NN) 326 : SEGSUP PLIG 327 : 950 CONTINUE 328 : SEGSUP IFACFO 329 : 330 : SEGSUP STRAV, SKRESO 331 : 332 : RETURN 333 : END 334 : 335 : 336 :
© Cast3M 2003 - All rights reserved.
Disclaimer