1 : C FACCVX SOURCE CHAT 11/03/16 21:21:59 6902 2 : SUBROUTINE FACCVX(MYMOD,INFOEL,NGAUSS,ICHFAC) 3 : C_______________________________________________________________________ 4 : C Calcul des facteurs de forme en 2D-plan et 3D pour une geometrie 5 : C convexe 6 : C Pas de coques avec l'option convexe 7 : C Traitement des quadratiques en se ramenant a des elements 8 : C lineaires 'enveloppe' 9 : C_______________________________________________________________________ 10 : C Arguments : 11 : C in : MYMOD : objet MMODEL contenant la geometrie 12 : C in : NGAUSS : nombre de points de Gauss en 3D (INTEGER ) 13 : C out: ICHFAC : objet MCHAML contenant les facteurs de forme 14 : C_______________________________________________________________________ 15 : C 16 : IMPLICIT INTEGER(I-N) 17 : IMPLICIT REAL*8 (A-H,O-Z) 18 : -INC CCOPTIO 19 : -INC SMMODEL 20 : -INC SMELEME 21 : -INC SMCOORD 22 : POINTEUR MYMOD.MMODEL 23 : POINTEUR ISSMA.MELEME , ISSMB.MELEME 24 : C_______________________________________________________________________ 25 : C FACTEURS DE FORME 26 : C NNBEL1 = NOMBRE DE LIGNES + 1 27 : C NBEL2 = NOMBRE DE COLONNES 28 : C LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES 29 : C 30 : SEGMENT IFACFO 31 : INTEGER LFACT(NNBEL1) 32 : ENDSEGMENT 33 : SEGMENT LFAC 34 : REAL*8 FACT(NBEL2) 35 : ENDSEGMENT 36 : POINTEUR PSUR.LFAC, PLIG.LFAC 37 : POINTEUR PCOL.LFAC 38 : C_______________________________________________________________________ 39 : SEGMENT,INFOEL 40 : LOGICAL KCOQ(N1), KQUAD(N1) 41 : ENDSEGMENT 42 : C_______________________________________________________________________ 43 : C structures nécessaires aux arguments de sous-programmes 44 : SEGMENT PMATG 45 : REAL*8 G(11,10) 46 : ENDSEGMENT 47 : SEGMENT PTRA23 48 : INTEGER NYA(5),NYB(5) 49 : REAL*8 AM(IDIM,5),BM(IDIM,5),UA(IDIM+1),UB(IDIM+1) 50 : ENDSEGMENT 51 : LOGICAL MALEUR 52 : LOGICAL ICOQ 53 : C_______________________________________________________________________ 54 : C 55 : KIMP=IIMPI 56 : MALEUR = .FALSE. 57 : EDIS = 0.00001 58 : C... elements quadratiques 59 : NSPA1=1 60 : NSPA2=1 61 : 62 : IF (INFOEL.EQ.0) THEN 63 : ICOQ= .FALSE. 64 : ELSE 65 : ICOQ= .TRUE. 66 : SEGACT INFOEL 67 : ENDIF 68 : 69 : SEGACT MYMOD 70 : C 71 : C Calcul du nombre de faces NFACE et activation de maillages 72 : C 73 : SEGACT MYMOD 74 : N1 = MYMOD.KMODEL(/1) 75 : NFACE = 0 76 : DO 10 ITYP=1,N1 77 : IMODEL = MYMOD.KMODEL(ITYP) 78 : SEGACT IMODEL 79 : IPT1 = IMAMOD 80 : SEGACT IPT1 81 : NEL = IPT1.NUM(/2) 82 : NFACE = NFACE + NEL 83 : 10 CONTINUE 84 : C 85 : C>>> INITIALISATION OBJET FACFOR 86 : C --------------------------- 87 : C 88 : NNBEL1=NFACE+1 89 : NBEL2=NFACE 90 : SEGINI IFACFO 91 : DO 900 LS=1,NNBEL1 92 : SEGINI PLIG 93 : LFACT(LS)=PLIG 94 : SEGACT PLIG*MOD 95 : 900 CONTINUE 96 : PSUR = LFACT(NNBEL1) 97 : SEGACT PSUR*MOD 98 : 99 : C ------------------------------------------------------------- 100 : C 101 : IF (IDIM.EQ.3) THEN 102 : SEGINI ,PMATG 102 : CALL MATG(G) 103 : ENDIF 104 : SEGINI ,PTRA23 105 : C 106 : C 107 : NELTA=0 108 : DO NSMA=1,N1 109 : C ---------------------------------------------------------- 110 : C On boucle sur les sous-objets MAILLAGE -> NSMA 111 : C 112 : NSPA1=1 113 : IF (ICOQ.AND.KQUAD(NSMA)) NSPA1=2 114 : 115 : IMODE1 = MYMOD.KMODEL(NSMA) 116 : ISSMA = IMODE1.IMAMOD 117 : 118 : NSGEO1= ISSMA.NUM(/1) 119 : C** NAM = ISSMA.NUM(/1) 120 : IF (IDIM.EQ.2) THEN 121 : NAM=2 122 : ELSE 123 : NAM=NSGEO1 124 : IF (ICOQ.AND.KQUAD(NSMA)) NAM=NSGEO1/2 125 : ENDIF 126 : 127 : NNELMA = ISSMA.NUM(/2) 128 : C 129 : DO NELMA=1,NNELMA 130 : C ------------------------------------------------------ 131 : KA = NELMA + NELTA 132 : PLIG = LFACT(KA) 133 : 134 : C On boucle sur les éléments de NSMA -> NELMA 135 : C 136 : C Remplissage du tableau AM 137 : DO I=1, NSGEO1, NSPA1 138 : LS=I 139 : IF (ICOQ.AND.KQUAD(NSMA)) LS=(I+1)/2 140 : C On boucle sur les noeuds de NELMA 141 : IG = ISSMA.NUM(I,NELMA) 142 : C** NYA(I) = IG 143 : NYA(LS) = IG 144 : IREF = (IDIM+1)*(IG-1) 145 : IF(IIMPI.GE.4) WRITE(3,*) ' NELMA I ',NELMA,I 146 : DO K=1,IDIM 147 : C** AM(K,I)=XCOOR(IREF+K) 148 : AM(K,LS)=XCOOR(IREF+K) 149 : ENDDO 150 : IF(IIMPI.GE.4) WRITE(3,*) ' AM ',(AM(K,LS),K=1,IDIM) 151 : ENDDO 152 : C 153 : C 154 : C Calcul de la normale->UA et de la surface->SA 155 : C ( SS ne sert pas ) 156 : IF (IDIM.EQ.3) THEN 156 : CALL KNORM(IDIM,AM,NAM,UA,SA) 157 : ELSE 157 : CALL KNORM2(IDIM,AM,NAM,UA,SA) 158 : ENDIF 159 : C 160 : PSUR.FACT(KA) = SA 161 : C 162 : IF (IIMPI.GE.4) THEN 163 : WRITE (6,*) 'SURFACE DE L ELEMENT',NELMA,' : ',SA 164 : WRITE (6,*) 'normale ',(UA(K),K=1,IDIM) 165 : ENDIF 166 : C 167 : NELTB=0 168 : DO NSMB=1,N1 169 : C ---------------------------------------------------- 170 : C On boucle sur les sous-objets MAILLAGE -> NSMB 171 : 172 : NSPA2=1 173 : IF (ICOQ.AND.KQUAD(NSMB)) NSPA2=2 174 : 175 : IMODE2 = MYMOD.KMODEL(NSMB) 176 : ISSMB = IMODE2.IMAMOD 177 : 178 : NSGEO2 = ISSMB.NUM(/1) 179 : C** NBM = ISSMB.NUM(/1) 180 : IF (IDIM.EQ.2) THEN 181 : NBM=2 182 : ELSE 183 : NBM=NSGEO2 184 : IF (ICOQ.AND.KQUAD(NSMB)) NBM=NSGEO2/2 185 : ENDIF 186 : NNELMB = ISSMB.NUM(/2) 187 : C 188 : DO NELMB=1,NNELMB 189 : C ------------------------------------------------- 190 : KB = NELMB + NELTB 191 : 192 : 193 : C On boucle sur les éléments de NSMB -> NELMB 194 : C 195 : C ****On regarde si l'on ne traite pas le même élément 196 : IF ((NSMA.EQ.NSMB).AND.(NELMA.EQ.NELMB)) THEN 197 : FF = 0.D0 198 : ELSE 199 : DO I=1, NSGEO2, NSPA2 200 : LS=I 201 : IF (ICOQ.AND.KQUAD(NSMB)) LS=(I+1)/2 202 : C On boucle sur les noeuds de NELMB 203 : C 204 : IG = ISSMB.NUM(I,NELMB) 205 : C** NYB(I) = IG 206 : NYB(LS) = IG 207 : IREF = (IDIM+1)*(IG-1) 208 : IF(IIMPI.GE.4) WRITE(6,*) ' NELMB I ',NELMB,I 209 : DO K=1,IDIM 210 : C** BM(K,I)=XCOOR(IREF+K) 211 : BM(K,LS)=XCOOR(IREF+K) 212 : ENDDO 213 : IF(IIMPI.GE.4) WRITE(6,*) ' BM ',(BM(K,LS),K=1,IDIM) 214 : C 215 : ENDDO 216 : C 217 : C *****Calcul de la normale à NELMB -> UB 218 : IF (IDIM.EQ.3) THEN 218 : CALL KNORM(IDIM,BM,NBM,UB,SS) 219 : ELSE 219 : CALL KNORM2(IDIM,BM,NBM,UB,SS) 220 : ENDIF 221 : C 222 : C 223 : PS = 0.D0 224 : DO K=1,IDIM 225 : PS = PS + UA(K)*UB(K) 226 : ENDDO 227 : C 228 : IF (PS.LT.(0.995)) THEN 229 : IF (IDIM.EQ.3) THEN 229 : CALL CAL2S3(G,NAM,AM,NBM,BM,NGAUSS,FF,NYA,NYB,EDIS) 230 : ELSE 230 : CALL CAL2S2(NAM,AM,NBM,BM,FF) 231 : ENDIF 232 : C 233 : IF (FF.LT.1.D-6) THEN 234 : MALEUR = .TRUE. 235 : C** GOTO 60 236 : ENDIF 237 : C 238 : FF = FF/SA 239 : ELSE 240 : FF = 0.D0 241 : ENDIF 242 : PLIG.FACT(KB) = FF 243 : C 244 : ENDIF 245 : C 246 : ENDDO 247 : C fin NELMB ---------------------------------------- 248 : NELTB=NELTB+NNELMB 249 : C 250 : ENDDO 251 : C fin NSMB -------------------------------------------- 252 : C 253 : ENDDO 254 : C fin NELMA --------------------------------------------- 255 : NELTA=NELTA+NNELMA 256 : C 257 : ENDDO 258 : C fin NSMA ------------------------------------------------- 259 : C 260 : C 261 : SEGSUP PTRA23 262 : IF (IDIM.EQ.3) THEN 263 : SEGSUP PMATG 264 : ENDIF 265 : C 266 : 267 : 60 CONTINUE 268 : IF (MALEUR.EQV..TRUE.) THEN 269 : WRITE (6,*) 'verifiez l orientation des elements' 270 : ENDIF 271 : 272 : C 273 : C>>> CACUL DES BILANS ET IMPRESSION (pas de normalisation en convexe) 274 : C ------------------------------ 275 : INOR=0 275 : CALL KFN(IFACFO,INOR,KIMP) 276 : 277 : C Traduction puis suppression de IFACFO 278 : 279 : IF (KIMP.GE.3) THEN 279 : CALL PRFACF(IFACFO) 280 : ENDIF 281 : 282 : DO 920 ITYP = 1,N1 283 : IMODEL = MYMOD.KMODEL(ITYP) 284 : SEGACT IMODEL 285 : IPT1 = IMAMOD 286 : SEGDES IPT1 287 : SEGDES IMODEL 288 : 920 CONTINUE 289 : SEGDES MYMOD 290 : 291 : LTITR=1 292 : INFOEL=0 292 : CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR) 293 : 294 : SEGACT IFACFO 295 : DO 930 LS=1,NNBEL1 296 : PLIG=LFACT(LS) 297 : SEGSUP PLIG 298 : 930 CONTINUE 299 : PSUR = LFACT(NNBEL1) 300 : SEGSUP IFACFO 301 : 302 : RETURN 303 : END 304 : 305 : 306 : 307 : 308 : 309 : 310 : 311 : 312 :
© Cast3M 2003 - All rights reserved.
Disclaimer