1 : C KFNREF SOURCE GOUNAND 06/03/06 21:16:48 5319 2 : SUBROUTINE KFNREF(MYLRF,MYPG, 3 : $ FNPG,DFNPG, 4 : $ IMPR,IRET) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : IMPLICIT INTEGER (I-N) 7 : C*********************************************************************** 8 : C NOM : KFNREF 9 : C PROJET : Noyau linéaire NLIN 10 : C DESCRIPTION : Calcul des fonctions de forme et de leurs 11 : C dérivées aux points de Gauss sur l'élément 12 : C de référence. 13 : C Le but avoué de ce sous-programme est d'effectuer 14 : C toutes les opérations de pré-traitement sur un élément 15 : C de référence donné. 16 : C 17 : C LANGAGE : ESOPE 18 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 19 : C mél : gounand@semt2.smts.cea.fr 20 : C*********************************************************************** 21 : C APPELES : CALPN, IVMAT, NI 22 : C APPELE PAR : KALPBG 23 : C*********************************************************************** 24 : C ENTREES : MYLRF, MYPG 25 : C ENTREES/SORTIES : - 26 : C SORTIES : FNPG, DFNPG 27 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 28 : C*********************************************************************** 29 : C VERSION : v1, 26/07/99, version initiale 30 : C HISTORIQUE : v1, 26/07/99, création 31 : C HISTORIQUE : v1.1 16/09/99, remaniement pour que la base polynômiale 32 : C puisse contenir des polynômes au lieu de 33 : C monômes exclusivement... 34 : C HISTORIQUE : v2, 10/05/00, modif. du segment ELREF 35 : C HISTORIQUE : v2.1 02/10/03 ajout d'astuces 36 : C HISTORIQUE : 37 : C*********************************************************************** 38 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 39 : C en cas de modification de ce sous-programme afin de faciliter 40 : C la maintenance ! 41 : C*********************************************************************** 42 : -INC CCOPTIO 43 : -INC CCREEL 44 : CBEGININCLUDE SELREF 45 : SEGMENT ELREF 46 : CHARACTER*(LNNOM) NOMLRF 47 : CHARACTER*(LNFORM) FORME 48 : CHARACTER*(LNTYPL) TYPEL 49 : CHARACTER*(LNESP) ESPACE 50 : INTEGER DEGRE 51 : REAL*8 XCONOD(NDIMEL,NBNOD) 52 : INTEGER NPQUAF(NBDDL) 53 : INTEGER NUMCMP(NBDDL) 54 : INTEGER QUENOD(NBDDL) 55 : INTEGER ORDDER(NDIMEL,NBDDL) 56 : POINTEUR MBPOLY.POLYNS 57 : ENDSEGMENT 58 : SEGMENT ELREFS 59 : POINTEUR LISEL(0).ELREF 60 : ENDSEGMENT 61 : CENDINCLUDE SELREF 62 : POINTEUR MYLRF.ELREF 63 : CBEGININCLUDE SPOGAU 64 : SEGMENT POGAU 65 : CHARACTER*(LNNPG) NOMPG 66 : CHARACTER*(LNTPG) TYPMPG 67 : CHARACTER*(LNFPG) FORLPG 68 : INTEGER NORDPG 69 : REAL*8 XCOPG(NDLPG,NBPG) 70 : REAL*8 XPOPG(NBPG) 71 : ENDSEGMENT 72 : SEGMENT POGAUS 73 : POINTEUR LISPG(0).POGAU 74 : ENDSEGMENT 75 : CENDINCLUDE SPOGAU 76 : POINTEUR MYPG.POGAU 77 : CBEGININCLUDE SMCHAEL 78 : SEGMENT MCHAEL 79 : POINTEUR IMACHE(N1).MELEME 80 : POINTEUR ICHEVA(N1).MCHEVA 81 : ENDSEGMENT 82 : SEGMENT MCHEVA 83 : REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM) 84 : ENDSEGMENT 85 : SEGMENT LCHEVA 86 : POINTEUR LISCHE(NBCHE).MCHEVA 87 : ENDSEGMENT 88 : CENDINCLUDE SMCHAEL 89 : POINTEUR FNPG.MCHEVA 90 : POINTEUR DFNPG.MCHEVA 91 : -INC SMLENTI 92 : INTEGER JG 93 : POINTEUR IVTMP.MLENTI 94 : CBEGININCLUDE SMMREEL 95 : SEGMENT MMREEL 96 : REAL*8 MAT(JLIG,JCOL) 97 : ENDSEGMENT 98 : CENDINCLUDE SMMREEL 99 : POINTEUR PN.MMREEL 100 : POINTEUR PNM1.MMREEL 101 : * 102 : INTEGER IMPR,IRET 103 : * 104 : LOGICAL LLAHE,LCAST 105 : LOGICAL LCSTE,LLINE,LEGAL 106 : INTEGER NDFN 107 : REAL*8 DETPN 108 : * 109 : * Executable statements 110 : * 111 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans kfnref' 112 : SEGACT MYLRF 113 : * 114 : LCAST=(MYLRF.NOMLRF.EQ.'H1D1PY5'.OR.MYLRF.NOMLRF.EQ.'H1D2PY13' 115 : $ .OR.MYLRF.NOMLRF.EQ.'H1D2PR15'.OR.MYLRF.NOMLRF.EQ.'H1D2CU20') 116 : * 117 : NDIML=MYLRF.ORDDER(/1) 118 : NBDDL=MYLRF.ORDDER(/2) 119 : LLAHE=(MYLRF.TYPEL.EQ.'LAGRANGE'.OR.MYLRF.TYPEL.EQ.'HERMITE') 120 : * On fait un cas particulier aux éléments de Lagrange 121 : * à un ddl : dans ce cas-la, la fonction de forme 122 : * est constante et sa dérivée est nulle 123 : LCSTE=(MYLRF.TYPEL.EQ.'LAGRANGE'.AND.NBDDL.EQ.1) 124 : * On fait un cas particulier aux éléments de Lagrange 125 : * linéaire (simplex) : dans ce cas-la, les dérivées des fonctions de 126 : * forme sont constantes 127 : LLINE=(MYLRF.TYPEL.EQ.'LAGRANGE'.AND.NBDDL.EQ.(NDIML+1)) 128 : SEGDES MYLRF 129 : * 130 : * On repique les éléments dans SHAPE 131 : * 132 : IF (LCAST) THEN 132 : CALL SH2FNR(MYLRF,MYPG, 133 : $ FNPG,DFNPG, 134 : $ IMPR,IRET) 135 : IF (IRET.NE.0) GOTO 9999 136 : * 137 : * Astuce foireuse 138 : * 139 : ELSEIF (LCSTE) THEN 140 : NBLIG=1 141 : NBCOL=1 142 : N2LIG=1 143 : N2COL=1 144 : NBPOI=1 145 : NBELM=1 146 : SEGINI FNPG 147 : FNPG.VELCHE(1,1,1,1,1,1)=1.D0 148 : SEGDES FNPG 149 : NBLIG=1 150 : NBCOL=1 151 : N2LIG=1 152 : N2COL=NDIML 153 : NBPOI=1 154 : NBELM=1 155 : SEGINI DFNPG 156 : DO IDIML=1,NDIML 157 : DFNPG.VELCHE(1,1,1,IDIML,1,1)=0.D0 158 : ENDDO 159 : SEGDES DFNPG 160 : * Cas des éléments de Lagrange et Hermite 161 : ELSEIF (LLAHE) THEN 162 : * 163 : * Construisons la Matrice [PN] à l'aide de la base polynômiale : 164 : * et des coordonnées de noeuds d'approximation 165 : ** 165 : CALL CALPN(MYLRF, 166 : $ PN, 167 : $ IMPR,IRET) 168 : IF (IRET.NE.0) GOTO 9999 169 : * 170 : * Inversons la Matrice [PN] 171 : * 172 : SEGACT PN 173 : SEGINI,PNM1=PN 174 : NDFN=PN.MAT(/1) 175 : JG=NDFN 176 : SEGINI IVTMP 177 : IIMPR=1 177 : CALL IVMAT(NDFN,PN.MAT, 178 : $ IVTMP.LECT, 179 : $ PNM1.MAT,DETPN, 180 : $ IIMPR,IRET) 181 : IF (IRET.NE.0) GOTO 9999 182 : SEGSUP IVTMP 183 : SEGSUP PN 184 : * 185 : * On peut maintenant calculer les valeurs des fonctions de forme 186 : * et leurs dérivées premières (par rapport aux coordonnées de l'espace 187 : * de référence) aux points de Gauss sur l'élément de référence 188 : * 188 : CALL NI(MYLRF,MYPG,PNM1, 189 : $ FNPG,DFNPG, 190 : $ IMPR,IRET) 191 : IF (IRET.NE.0) GOTO 9999 192 : SEGSUP PNM1 193 : ELSE 194 : WRITE(IOIMP,*) 'Le type d''élément ',MYLRF.TYPEL 195 : WRITE(IOIMP,*) 'n''est pas reconnu.' 196 : GOTO 9999 197 : ENDIF 198 : * 199 : * Astuce foireuse (mais on fait quand même des 200 : * vérifications) 201 : * 202 : IF (LLINE) THEN 203 : SEGACT DFNPG*MOD 204 : NBPOGO=DFNPG.VELCHE(/5) 205 : DO IDIML=1,NDIML 206 : DO IDDL=1,NBDDL 207 : VALDF=DFNPG.VELCHE(1,IDDL,1,IDIML,1,1) 208 : DO IPOGO=2,NBPOGO 209 : VALDF2=DFNPG.VELCHE(1,IDDL,1,IDIML,IPOGO,1) 210 : LEGAL=(ABS(VALDF2-VALDF).LE.100.D0*XZPREC) 211 : IF (.NOT.LEGAL) THEN 212 : WRITE(IOIMP,*) 'Houston, on a un probleme' 213 : * SEGPRT,DFNPG 214 : GOTO 9999 215 : ENDIF 216 : ENDDO 217 : ENDDO 218 : ENDDO 219 : NBLIG=1 220 : NBCOL=NBDDL 221 : N2LIG=1 222 : N2COL=NDIML 223 : NBPOI=1 224 : NBELM=1 225 : SEGADJ,DFNPG 226 : SEGDES DFNPG 227 : ENDIF 228 : * 229 : * Normal termination 230 : * 231 : IRET=0 232 : RETURN 233 : * 234 : * Error handling 235 : * 236 : 9999 CONTINUE 237 : IRET=1 238 : WRITE(IOIMP,*) 'An error was detected in subroutine kfnref' 239 : RETURN 240 : * 241 : * End of subroutine KFNREF 242 : * 243 : END 244 : 245 : 246 : 247 :
© Cast3M 2003 - All rights reserved.
Disclaimer