1 : C EXTFAC SOURCE GOUNAND 06/08/04 21:15:36 5520 2 : SUBROUTINE EXTFAC(CGEOM3,CSGEO3,MYQRFS, 3 : $ CGEOME,FACTIV, 4 : $ IMPR,IRET) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : IMPLICIT INTEGER (I-N) 7 : C*********************************************************************** 8 : C NOM : EXTFAC 9 : C DESCRIPTION : On extrait de CGEOM3 les éléments qui ont au moins une 10 : C face appartenant à CSGEO3 et un objet MELEME détourné 11 : C contenant les faces actives. 12 : C 13 : C 14 : C 15 : C LANGAGE : ESOPE 16 : C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF) 17 : C mél : gounand@semt2.smts.cea.fr 18 : C*********************************************************************** 19 : C APPELES : 20 : C APPELES (E/S) : 21 : C APPELES (BLAS) : 22 : C APPELES (CALCUL) : 23 : C APPELE PAR : 24 : C*********************************************************************** 25 : C SYNTAXE GIBIANE : 26 : C ENTREES : 27 : C ENTREES/SORTIES : 28 : C SORTIES : 29 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 30 : C*********************************************************************** 31 : C VERSION : v1, 17/12/2002, version initiale 32 : C HISTORIQUE : v1, 17/12/2002, création 33 : C HISTORIQUE : 34 : C HISTORIQUE : 35 : C*********************************************************************** 36 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 37 : C en cas de modification de ce sous-programme afin de faciliter 38 : C la maintenance ! 39 : C*********************************************************************** 40 : -INC CCOPTIO 41 : -INC SMCOORD 42 : -INC SMELEME 43 : POINTEUR CGEOM3.MELEME,SCGEO3.MELEME 44 : POINTEUR CSGEO3.MELEME,SCSGE3.MELEME 45 : POINTEUR CGEOME.MELEME,SCGEOM.MELEME 46 : POINTEUR FACVOL.MELEME,SFAVOL.MELEME 47 : INTEGER NBNN,NBELEM,NBSOUS,NBREF 48 : * Segment à moi 49 : SEGMENT VOLTIV 50 : POINTEUR IVOLTI(NBSOUV).SVOLTI 51 : ENDSEGMENT 52 : SEGMENT SVOLTI 53 : LOGICAL LVOLTI(NBELEV) 54 : ENDSEGMENT 55 : CBEGININCLUDE SFACTIV 56 : SEGMENT FACTIV 57 : POINTEUR IFACTI(NBSOUV).SFACTI 58 : ENDSEGMENT 59 : SEGMENT SFACTI 60 : POINTEUR ISFACT(NBSOFV).SSFACT 61 : ENDSEGMENT 62 : SEGMENT SSFACT 63 : LOGICAL LFACTI(NBELFV,NBELEV) 64 : ENDSEGMENT 65 : CENDINCLUDE SFACTIV 66 : INTEGER NBSOUV,NBSOFV,NBELEV 67 : CBEGININCLUDE SMLLOGI 68 : SEGMENT MLLOGI 69 : LOGICAL LOGI(JG) 70 : ENDSEGMENT 71 : CENDINCLUDE SMLLOGI 72 : POINTEUR KRSURF.MLLOGI 73 : INTEGER JG 74 : CBEGININCLUDE SIQUAF 75 : SEGMENT IQUAF 76 : INTEGER NUMQUF 77 : REAL*8 XCONQR(NDIMQR,NBNOQR) 78 : INTEGER NUCENT 79 : POINTEUR LFACE.MELEME 80 : ENDSEGMENT 81 : SEGMENT IQUAFS 82 : POINTEUR LISQRF(NBQRF).IQUAF 83 : ENDSEGMENT 84 : CENDINCLUDE SIQUAF 85 : POINTEUR MYQRFS.IQUAFS 86 : POINTEUR IQUVOL.IQUAF 87 : POINTEUR IQUFAC.IQUAF 88 : * 89 : INTEGER IMPR,IRET 90 : * 91 : INTEGER NBSOUF,NBELEF 92 : INTEGER IBSOUF,IBELEF,IBSOUV,IBELEV 93 : INTEGER NBELFV,NBNNV,NBELVA 94 : INTEGER IBSOFV,IBELFV,IBNNV,IBELVA 95 : INTEGER NUCFAC,NGLFAC,NPLFAC,NPCFAC 96 : INTEGER ITYVOL,ITYFAC 97 : LOGICAL LFOUND 98 : 99 : 100 : * 101 : * Executable statements 102 : * 103 : IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans extfac.eso' 104 : * 105 : * On construit KRSURF : KRSURF(i) = VRAI si i est un numéro global 106 : * du centre d'un élément de CSGEO3 (point face) 107 : * 108 : JG=XCOOR(/1)/(IDIM+1) 109 : SEGINI,KRSURF 110 : SEGACT CSGEO3 111 : NBSOUF=CSGEO3.LISOUS(/1) 112 : DO IBSOUF=1,NBSOUF 113 : SCSGE3=CSGEO3.LISOUS(IBSOUF) 114 : SEGACT SCSGE3 115 : ITYFAC=SCSGE3.ITYPEL 115 : CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET) 116 : IF (IRET.NE.0) GOTO 9999 117 : SEGACT IQUFAC 118 : NUCFAC=IQUFAC.NUCENT 119 : SEGDES IQUFAC 120 : NBELEF=SCSGE3.NUM(/2) 121 : DO IBELEF=1,NBELEF 122 : NGLFAC=SCSGE3.NUM(NUCFAC,IBELEF) 123 : KRSURF.LOGI(NGLFAC)=.TRUE. 124 : ENDDO 125 : SEGDES SCSGE3 126 : ENDDO 127 : SEGDES CSGEO3 128 : * segprt,krsurf 129 : * 130 : * On parcourt l'objet maillage CGEOM3 en notant les éléments ayant 131 : * au moins une face active LVOLTI(IBELEV)=.TRUE. 132 : * 133 : SEGACT CGEOM3 134 : NBSOUV=CGEOM3.LISOUS(/1) 135 : SEGINI,VOLTIV 136 : DO IBSOUV=1,NBSOUV 137 : SCGEO3=CGEOM3.LISOUS(IBSOUV) 138 : SEGACT SCGEO3 139 : NBELEV=SCGEO3.NUM(/2) 140 : SEGINI,SVOLTI 141 : ITYVOL=SCGEO3.ITYPEL 141 : CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET) 142 : IF (IRET.NE.0) GOTO 9999 143 : SEGACT IQUVOL 144 : FACVOL=IQUVOL.LFACE 145 : SEGDES IQUVOL 146 : SEGACT FACVOL 147 : NBSOFV=FACVOL.LISOUS(/1) 148 : DO IBSOFV=1,NBSOFV 149 : SFAVOL=FACVOL.LISOUS(IBSOFV) 150 : * segprt,sfavol 151 : SEGACT SFAVOL 152 : ITYFAC=SFAVOL.ITYPEL 152 : CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET) 153 : IF (IRET.NE.0) GOTO 9999 154 : SEGACT IQUFAC 155 : NUCFAC=IQUFAC.NUCENT 156 : SEGDES IQUFAC 157 : NBELFV=SFAVOL.NUM(/2) 158 : DO IBELEV=1,NBELEV 159 : LFOUND=.FALSE. 160 : DO IBELFV=1,NBELFV 161 : NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV) 162 : NPCFAC=SCGEO3.NUM(NPLFAC,IBELEV) 163 : * Write(ioimp,*) 'nplfac=',nplfac,' npcfac=',npcfac 164 : LFOUND=LFOUND.OR.KRSURF.LOGI(NPCFAC) 165 : ENDDO 166 : SVOLTI.LVOLTI(IBELEV)=LFOUND.OR.SVOLTI.LVOLTI(IBELEV) 167 : ENDDO 168 : SEGDES,SFAVOL 169 : ENDDO 170 : SEGDES,SVOLTI 171 : * SEGPRT,SVOLTI 172 : VOLTIV.IVOLTI(IBSOUV)=SVOLTI 173 : SEGDES FACVOL 174 : SEGDES SCGEO3 175 : ENDDO 176 : SEGDES VOLTIV 177 : SEGDES CGEOM3 178 : * 179 : * On construit l'objet maillage CGEOME contenant uniquement 180 : * les éléments ayant au moins une face active 181 : * 182 : SEGACT CGEOM3 183 : NBSOUV=CGEOM3.LISOUS(/1) 184 : NBNN=0 185 : NBELEM=0 186 : NBSOUS=NBSOUV 187 : NBREF=0 188 : SEGINI CGEOME 189 : SEGACT VOLTIV 190 : IBSOV2=0 191 : DO IBSOUV=1,NBSOUV 192 : SCGEO3=CGEOM3.LISOUS(IBSOUV) 193 : SEGACT SCGEO3 194 : NBNNV=SCGEO3.NUM(/1) 195 : NBELEV=SCGEO3.NUM(/2) 196 : SVOLTI=VOLTIV.IVOLTI(IBSOUV) 197 : SEGACT SVOLTI 198 : * Trouver le nombre d'éléments actifs dans ce maillage élémentaire 199 : NBELVA=0 200 : DO IBELEV=1,NBELEV 201 : IF (SVOLTI.LVOLTI(IBELEV)) THEN 202 : NBELVA=NBELVA+1 203 : ENDIF 204 : ENDDO 205 : IF (NBELVA.GT.0) THEN 206 : NBNN=NBNNV 207 : NBELEM=NBELVA 208 : NBSOUS=0 209 : NBREF=0 210 : SEGINI,SCGEOM 211 : SCGEOM.ITYPEL=SCGEO3.ITYPEL 212 : IBELVA=0 213 : DO IBELEV=1,NBELEV 214 : IF (SVOLTI.LVOLTI(IBELEV)) THEN 215 : IBELVA=IBELVA+1 216 : DO IBNNV=1,NBNNV 217 : SCGEOM.NUM(IBNNV,IBELVA)=SCGEO3.NUM(IBNNV,IBELEV) 218 : ENDDO 219 : ENDIF 220 : ENDDO 221 : SEGDES,SCGEOM 222 : IBSOV2=IBSOV2+1 223 : CGEOME.LISOUS(IBSOV2)=SCGEOM 224 : ENDIF 225 : *DEBUG SEGPRT,SVOLTI 226 : SEGSUP SVOLTI 227 : SEGDES SCGEO3 228 : ENDDO 229 : *DEBUG SEGPRT,VOLTIV 230 : SEGSUP VOLTIV 231 : NBNN=0 232 : NBELEM=0 233 : NBSOUS=IBSOV2 234 : NBREF=0 235 : SEGADJ,CGEOME 236 : SEGDES CGEOME 237 : SEGDES CGEOM3 237 : *DEBUG CALL ECROBJ('MAILLAGE',CGEOME) 237 : *DEBUG CALL PRLIST 237 : *DEBUG CALL ECROBJ('MAILLAGE',CGEOM3) 237 : *DEBUG CALL PRLIST 238 : * 239 : * On parcourt l'objet maillage CGEOME en notant les faces actives des 240 : * éléments LFACTI(IBFAVO,IBELEV)=.TRUE. 241 : * 242 : SEGACT CGEOME 243 : NBSOUV=CGEOME.LISOUS(/1) 244 : SEGINI,FACTIV 245 : DO IBSOUV=1,NBSOUV 246 : SCGEOM=CGEOME.LISOUS(IBSOUV) 247 : SEGACT SCGEOM 248 : ITYVOL=SCGEOM.ITYPEL 248 : CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET) 249 : IF (IRET.NE.0) GOTO 9999 250 : SEGACT IQUVOL 251 : FACVOL=IQUVOL.LFACE 252 : SEGDES IQUVOL 253 : SEGACT FACVOL 254 : NBSOFV=FACVOL.LISOUS(/1) 255 : SEGINI,SFACTI 256 : DO IBSOFV=1,NBSOFV 257 : SFAVOL=FACVOL.LISOUS(IBSOFV) 258 : SEGACT SFAVOL 259 : ITYFAC=SFAVOL.ITYPEL 259 : CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET) 260 : IF (IRET.NE.0) GOTO 9999 261 : SEGACT IQUFAC 262 : NUCFAC=IQUFAC.NUCENT 263 : SEGDES IQUFAC 264 : NBELFV=SFAVOL.NUM(/2) 265 : NBELEV=SCGEOM.NUM(/2) 266 : SEGINI SSFACT 267 : DO IBELEV=1,NBELEV 268 : DO IBELFV=1,NBELFV 269 : NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV) 270 : NPCFAC=SCGEOM.NUM(NPLFAC,IBELEV) 271 : SSFACT.LFACTI(IBELFV,IBELEV)=KRSURF.LOGI(NPCFAC) 272 : ENDDO 273 : ENDDO 274 : SEGDES SSFACT 275 : * SEGPRT,SSFACT 276 : SFACTI.ISFACT(IBSOFV)=SSFACT 277 : SEGDES SFAVOL 278 : ENDDO 279 : SEGDES SFACTI 280 : * SEGPRT,SFACTI 281 : FACTIV.IFACTI(IBSOUV)=SFACTI 282 : SEGDES FACVOL 283 : SEGDES SCGEOM 284 : ENDDO 285 : SEGDES FACTIV 286 : * SEGPRT,FACTIV 287 : SEGDES CGEOME 288 : SEGSUP,KRSURF 289 : * 290 : * Normal termination 291 : * 292 : IRET=0 293 : RETURN 294 : * 295 : * Format handling 296 : * 297 : * 298 : * Error handling 299 : * 300 : 9999 CONTINUE 301 : IRET=1 302 : WRITE(IOIMP,*) 'An error was detected in subroutine extfac' 303 : RETURN 304 : * 305 : * End of subroutine EXTFAC 306 : * 307 : END 308 : 309 :
© Cast3M 2003 - All rights reserved.
Disclaimer