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