1 : C CREPG SOURCE GOUNAND 06/08/04 21:15:11 5520 2 : SUBROUTINE CREPG(IQUVOL,SFAVOL,METING,MYFALS,MYFPGS, 3 : $ JXCOPG,JXPOPG, 4 : $ IMPR,IRET) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : IMPLICIT INTEGER (I-N) 7 : C*********************************************************************** 8 : C NOM : CREPG 9 : C DESCRIPTION : Création des points de Gauss 10 : C pour des faces de l'élément de référence. 11 : C 12 : C 13 : C LANGAGE : ESOPE 14 : C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF) 15 : C mél : gounand@semt2.smts.cea.fr 16 : C*********************************************************************** 17 : C APPELES : 18 : C APPELES (E/S) : 19 : C APPELES (BLAS) : 20 : C APPELES (CALCUL) : 21 : C APPELE PAR : 22 : C*********************************************************************** 23 : C SYNTAXE GIBIANE : 24 : C ENTREES : 25 : C ENTREES/SORTIES : 26 : C SORTIES : 27 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 28 : C*********************************************************************** 29 : C VERSION : v1, 20/12/2002, version initiale 30 : C HISTORIQUE : v1, 20/12/2002, création 31 : C HISTORIQUE : 32 : C HISTORIQUE : 33 : C*********************************************************************** 34 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 35 : C en cas de modification de ce sous-programme afin de faciliter 36 : C la maintenance ! 37 : C*********************************************************************** 38 : -INC CCOPTIO 39 : -INC SMELEME 40 : POINTEUR SFAVOL.MELEME 41 : * 42 : CBEGININCLUDE SMCHAEL 43 : SEGMENT MCHAEL 44 : POINTEUR IMACHE(N1).MELEME 45 : POINTEUR ICHEVA(N1).MCHEVA 46 : ENDSEGMENT 47 : SEGMENT MCHEVA 48 : REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM) 49 : ENDSEGMENT 50 : SEGMENT LCHEVA 51 : POINTEUR LISCHE(NBCHE).MCHEVA 52 : ENDSEGMENT 53 : CENDINCLUDE SMCHAEL 54 : POINTEUR JCOOR.MCHEVA 55 : POINTEUR FFFAC.MCHEVA 56 : POINTEUR DFFFAC.MCHEVA 57 : POINTEUR JXCOPG.MCHEVA 58 : POINTEUR JXPOPG.MCHEVA 59 : INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM 60 : CBEGININCLUDE SELREF 61 : SEGMENT ELREF 62 : CHARACTER*(LNNOM) NOMLRF 63 : CHARACTER*(LNFORM) FORME 64 : CHARACTER*(LNTYPL) TYPEL 65 : CHARACTER*(LNESP) ESPACE 66 : INTEGER DEGRE 67 : REAL*8 XCONOD(NDIMEL,NBNOD) 68 : INTEGER NPQUAF(NBDDL) 69 : INTEGER NUMCMP(NBDDL) 70 : INTEGER QUENOD(NBDDL) 71 : INTEGER ORDDER(NDIMEL,NBDDL) 72 : POINTEUR MBPOLY.POLYNS 73 : ENDSEGMENT 74 : SEGMENT ELREFS 75 : POINTEUR LISEL(0).ELREF 76 : ENDSEGMENT 77 : CENDINCLUDE SELREF 78 : POINTEUR LRFFAC.ELREF 79 : CBEGININCLUDE SFALRF 80 : SEGMENT FALRF 81 : CHARACTER*(LNNFA) NOMFA 82 : INTEGER NUQUAF(NBLRF) 83 : POINTEUR ELEMF(NBLRF).ELREF 84 : ENDSEGMENT 85 : SEGMENT FALRFS 86 : POINTEUR LISFA(0).FALRF 87 : ENDSEGMENT 88 : CENDINCLUDE SFALRF 89 : POINTEUR MYFALS.FALRFS 90 : CBEGININCLUDE SPOGAU 91 : SEGMENT POGAU 92 : CHARACTER*(LNNPG) NOMPG 93 : CHARACTER*(LNTPG) TYPMPG 94 : CHARACTER*(LNFPG) FORLPG 95 : INTEGER NORDPG 96 : REAL*8 XCOPG(NDLPG,NBPG) 97 : REAL*8 XPOPG(NBPG) 98 : ENDSEGMENT 99 : SEGMENT POGAUS 100 : POINTEUR LISPG(0).POGAU 101 : ENDSEGMENT 102 : CENDINCLUDE SPOGAU 103 : POINTEUR PGFAC.POGAU 104 : CBEGININCLUDE SFAPG 105 : SEGMENT FAPG 106 : CHARACTER*(LNNFAP) NOMFAP 107 : INTEGER NBQUAF(NBMPG) 108 : POINTEUR MPOGAU(NBMPG).POGAU 109 : ENDSEGMENT 110 : SEGMENT FAPGS 111 : POINTEUR LISFPG(0).FAPG 112 : ENDSEGMENT 113 : CENDINCLUDE SFAPG 114 : POINTEUR MYFPGS.FAPGS 115 : CBEGININCLUDE SIQUAF 116 : SEGMENT IQUAF 117 : INTEGER NUMQUF 118 : REAL*8 XCONQR(NDIMQR,NBNOQR) 119 : INTEGER NUCENT 120 : POINTEUR LFACE.MELEME 121 : ENDSEGMENT 122 : SEGMENT IQUAFS 123 : POINTEUR LISQRF(NBQRF).IQUAF 124 : ENDSEGMENT 125 : CENDINCLUDE SIQUAF 126 : POINTEUR IQUVOL.IQUAF 127 : * 128 : INTEGER IMPR,IRET 129 : * 130 : INTEGER IBELFV,IBNOQR,IDDLFA,IDIMQR,IPGFAC,ITYFAC 131 : INTEGER NBELFV, NDDLFA,NDIMQR,NPGFAC 132 : REAL*8 VAL 133 : CHARACTER*4 METING,MYDIS2 134 : * 135 : * Executable statements 136 : * 137 : IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans crepg.eso' 138 : * 139 : * 1ere étape : on crée les degrés de liberté de la transformation 140 : * géométrique (cf. mkcoor.eso) 141 : * 142 : * On suppose que les transformations géométriques sur les 143 : * éléments de référence sont LINEAIRES. On suppose également que 144 : * le déterminant de la matrice jacobienne de la tranformation 145 : * face de référence -> face d'un élément volumique de référence 146 : * est CONSTANT => règle d'intégration numérique à 1 point de Gauss 147 : MYDIS2='LINE' 148 : * 149 : SEGACT IQUVOL 150 : NDIMQR=IQUVOL.XCONQR(/1) 151 : SEGACT SFAVOL 152 : ITYFAC=SFAVOL.ITYPEL 152 : CALL KEEF(ITYFAC,MYDIS2, 153 : $ MYFALS, 154 : $ LRFFAC, 155 : $ IMPR,IRET) 156 : IF (IRET.NE.0) GOTO 9999 157 : SEGACT LRFFAC 158 : NDDLFA=LRFFAC.NPQUAF(/1) 159 : NBELFV=SFAVOL.NUM(/2) 160 : NBLIG=1 161 : NBCOL=NDDLFA 162 : N2LIG=1 163 : N2COL=NDIMQR 164 : NBPOI=1 165 : NBELM=NBELFV 166 : SEGINI JCOOR 167 : DO IBELFV=1,NBELFV 168 : DO IDDLFA=1,NDDLFA 169 : IBNOQR=SFAVOL.NUM(LRFFAC.NPQUAF(IDDLFA),IBELFV) 170 : DO IDIMQR=1,NDIMQR 171 : JCOOR.VELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV)= 172 : $ IQUVOL.XCONQR(IDIMQR,IBNOQR) 173 : * write(ioimp,*) 'face=',IBELFV 174 : * write(ioimp,*) 'coord espace=',IDIMQR 175 : * write(ioimp,*) 'ddlfa=',IDDLFA 176 : * write(ioimp,*) 177 : * $ 'VALEUR=',JCOOR.VELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV) 178 : * write(ioimp,*) ' ' 179 : ENDDO 180 : ENDDO 181 : ENDDO 182 : SEGDES SFAVOL 183 : SEGDES IQUVOL 184 : * 185 : * 2ème étape : - on crée les fonctions de forme et leurs dérivées 186 : * pour la transformation géométrie face -> volume 187 : * - on récupère coordonnées et poids des points de 188 : * Gauss pour la méthode METING sur la face de 189 : * référence 190 : * - pour chaque face de l'élément de référence volumique 191 : * on construit les coordonnées des points de Gauss 192 : * attenant à l'aide de la transformation géométrique 193 : * 193 : CALL KEPG(ITYFAC,METING, 194 : $ MYFPGS, 195 : $ PGFAC, 196 : $ IMPR,IRET) 197 : IF (IRET.NE.0) GOTO 9999 198 : * 199 : * In KFNREF : SEGINI FFFAC 200 : * In KFNREF : SEGINI DFFFAC 201 : * 201 : CALL KFNREF(LRFFAC,PGFAC, 202 : $ FFFAC,DFFFAC, 203 : $ IMPR,IRET) 204 : IF (IRET.NE.0) GOTO 9999 205 : SEGDES LRFFAC 206 : C write(ioimp,*) 'Fonctions de formes sur la face' 206 : C CALL PRCHVA(FFFAC,6,IRET) 207 : IF (IRET.NE.0) GOTO 9999 208 : SEGACT FFFAC 209 : NPGFAC=FFFAC.VELCHE(/5) 210 : NBLIG=1 211 : NBCOL=1 212 : N2LIG=1 213 : N2COL=NDIMQR 214 : NBPOI=NPGFAC 215 : NBELM=NBELFV 216 : SEGINI JXCOPG 217 : DO IBELFV=1,NBELFV 218 : DO IPGFAC=1,NPGFAC 219 : DO IDIMQR=1,NDIMQR 220 : DO IDDLFA=1,NDDLFA 221 : VAL=JCOOR.VELCHE(1,IDDLFA,1,IDIMQR,1,IBELFV)* 222 : $ FFFAC.VELCHE(1,IDDLFA,1,1,IPGFAC,1) 223 : JXCOPG.VELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV)= 224 : $ JXCOPG.VELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV)+ 225 : $ VAL 226 : ENDDO 227 : * write(ioimp,*) 'face=',IBELFV 228 : * write(ioimp,*) 'no point gauss=',IPGFAC 229 : * write(ioimp,*) 'coord espace=',IDIMQR 230 : * write(ioimp,*) 231 : * $ 'VALEUR=',JXCOPG.VELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV) 232 : * write(ioimp,*) ' ' 233 : ENDDO 234 : ENDDO 235 : ENDDO 236 : SEGSUP JCOOR 237 : SEGDES JXCOPG 238 : * SEGDES FFFAC 239 : SEGSUP FFFAC 240 : SEGSUP DFFFAC 241 : * 242 : * 3ème étape : Poids 243 : * 244 : SEGACT PGFAC 245 : NBLIG=1 246 : NBCOL=1 247 : N2LIG=1 248 : N2COL=1 249 : NBPOI=NPGFAC 250 : NBELM=1 251 : SEGINI JXPOPG 252 : DO IPGFAC=1,NPGFAC 253 : JXPOPG.VELCHE(1,1,1,1,IPGFAC,1)= 254 : $ PGFAC.XPOPG(IPGFAC) 255 : *! $ JDTJAF.VELCHE(1,1,1,1,IPGFAC,IBELFV)* 256 : *! $ PGFAC.XPOPG(IPGFAC) 257 : ENDDO 258 : SEGDES JXPOPG 259 : SEGDES PGFAC 260 : * 261 : * Normal termination 262 : * 263 : IRET=0 264 : RETURN 265 : * 266 : * Format handling 267 : * 268 : * 269 : * Error handling 270 : * 271 : 9999 CONTINUE 272 : IRET=1 273 : WRITE(IOIMP,*) 'An error was detected in subroutine crepg' 274 : RETURN 275 : * 276 : * End of subroutine CREPG 277 : * 278 : END 279 : 280 :
© Cast3M 2003 - All rights reserved.
Disclaimer