1 : C KFNRFF SOURCE GOUNAND 07/07/05 21:15:26 5784 2 : SUBROUTINE KFNRFF(LRFVOL,JXCOPG, 3 : $ FNPG,DFNPG, 4 : $ IMPR,IRET) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : IMPLICIT INTEGER (I-N) 7 : C*********************************************************************** 8 : C NOM : KFNRFF 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 : LRFVOL, 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 LRFVOL.ELREF 63 : CBEGININCLUDE SMCHAEL 64 : SEGMENT MCHAEL 65 : POINTEUR IMACHE(N1).MELEME 66 : POINTEUR ICHEVA(N1).MCHEVA 67 : ENDSEGMENT 68 : SEGMENT MCHEVA 69 : REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM) 70 : ENDSEGMENT 71 : SEGMENT LCHEVA 72 : POINTEUR LISCHE(NBCHE).MCHEVA 73 : ENDSEGMENT 74 : CENDINCLUDE SMCHAEL 75 : POINTEUR JXCOPG.MCHEVA 76 : POINTEUR FNPG.MCHEVA 77 : POINTEUR DFNPG.MCHEVA 78 : -INC SMLENTI 79 : INTEGER JG 80 : POINTEUR IVTMP.MLENTI 81 : CBEGININCLUDE SMMREEL 82 : SEGMENT MMREEL 83 : REAL*8 MAT(JLIG,JCOL) 84 : ENDSEGMENT 85 : CENDINCLUDE SMMREEL 86 : POINTEUR PN.MMREEL 87 : POINTEUR PNM1.MMREEL 88 : POINTEUR ID.MMREEL 89 : * 90 : INTEGER IMPR,IRET 91 : * 92 : LOGICAL LLAHE,LCAST 93 : LOGICAL LCSTE,LLINE,LEGAL 94 : INTEGER NDFN 95 : REAL*8 DETPN 96 : * 97 : * Executable statements 98 : * 99 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans kfnrff' 100 : SEGACT LRFVOL 101 : * 102 : LCAST=(LRFVOL.NOMLRF.EQ.'H1D1PY5'.OR.LRFVOL.NOMLRF.EQ.'H1D2PY13' 103 : $ .OR.LRFVOL.NOMLRF.EQ.'H1D2PR15' 104 : $ .OR.LRFVOL.NOMLRF.EQ.'H1D2CU20') 105 : * 106 : NDIML=LRFVOL.ORDDER(/1) 107 : NBDDL=LRFVOL.ORDDER(/2) 108 : LLAHE=(LRFVOL.TYPEL.EQ.'LAGRANGE'.OR.LRFVOL.TYPEL.EQ.'HERMITE') 109 : * On fait un cas particulier aux éléments de Lagrange 110 : * à un ddl : dans ce cas-la, la fonction de forme 111 : * est constante et sa dérivée est nulle 112 : LCSTE=(LRFVOL.TYPEL.EQ.'LAGRANGE'.AND.NBDDL.EQ.1) 113 : * On fait un cas particulier aux éléments de Lagrange 114 : * linéaire (simplex) : dans ce cas-la, les dérivées des fonctions de 115 : * forme sont constantes 116 : LLINE=(LRFVOL.TYPEL.EQ.'LAGRANGE'.AND.NBDDL.EQ.(NDIML+1)) 117 : SEGDES LRFVOL 118 : * 119 : * On repique les éléments dans SHAPE 120 : * 121 : IF (LCAST) THEN 121 : CALL SH2FNF(LRFVOL,JXCOPG, 122 : $ FNPG,DFNPG, 123 : $ IMPR,IRET) 124 : IF (IRET.NE.0) GOTO 9999 125 : * 126 : * Astuce foireuse 127 : * 128 : ELSEIF (LCSTE) THEN 129 : NBLIG=1 130 : NBCOL=1 131 : N2LIG=1 132 : N2COL=1 133 : NBPOI=1 134 : NBELM=1 135 : SEGINI FNPG 136 : FNPG.VELCHE(1,1,1,1,1,1)=1.D0 137 : SEGDES FNPG 138 : NBLIG=1 139 : NBCOL=1 140 : N2LIG=1 141 : N2COL=NDIML 142 : NBPOI=1 143 : NBELM=1 144 : SEGINI DFNPG 145 : DO IDIML=1,NDIML 146 : DFNPG.VELCHE(1,1,1,IDIML,1,1)=0.D0 147 : ENDDO 148 : SEGDES DFNPG 149 : * Cas des éléments de Lagrange et Hermite 150 : ELSEIF (LLAHE) THEN 151 : * 152 : * Construisons la Matrice [PN] à l'aide de la base polynômiale : 153 : * et des coordonnées de noeuds d'approximation 154 : ** 154 : CALL CALPN(LRFVOL, 155 : $ PN, 156 : $ IMPR,IRET) 157 : IF (IRET.NE.0) GOTO 9999 158 : * 159 : * Inversons la Matrice [PN] 160 : * 161 : C SEGACT PN 162 : C JLIG=PN.MAT(/1) 163 : C JCOL=PN.MAT(/2) 164 : C xsom=0 165 : C do icol=1,jcol 166 : C do ilig=1,jlig 167 : C xsom=xsom+ABS(PN.MAT(ilig,icol)) 168 : C enddo 169 : C enddo 170 : C write(ioimp,*) 'xsom=',xsom 171 : 172 : 173 : SEGACT PN 174 : SEGINI,PNM1=PN 175 : NDFN=PN.MAT(/1) 176 : JG=NDFN 177 : SEGINI IVTMP 178 : IIMPR=1 179 : * IIMPR=5 179 : CALL IVMAT(NDFN,PN.MAT, 180 : $ IVTMP.LECT, 181 : $ PNM1.MAT,DETPN, 182 : $ IIMPR,IRET) 183 : IF (IRET.NE.0) GOTO 9999 184 : C* Vérif à la con 185 : C JLIG=NDFN 186 : C JCOL=NDFN 187 : C SEGINI ID 188 : C DO i = 1,NDFN 189 : C DO k = 1,NDFN 190 : C val = 0.D0 191 : C DO j = 1,NDFN 192 : C val = val + (PN.MAT(i,j)*PNM1.MAT(j,k)) 193 : C ENDDO 194 : C ID.MAT(i,k)=val 195 : C enddo 196 : C enddo 197 : C segprt,ID 198 : C xsom=0.D0 199 : C do icol=1,jcol 200 : C do ilig=1,jlig 201 : C xsom=xsom+ABS(ID.MAT(ilig,icol)) 202 : C enddo 203 : C enddo 204 : C write(ioimp,*) 'xsom=',xsom 205 : C write(ioimp,*) 'diagonale' 206 : C WRITE(IOIMP,*) (ID.MAT(I,I),I=1,NDFN) 207 : C xsom=0 208 : C do icol=1,jcol 209 : C do ilig=1,jlig 210 : C xsom=xsom+ABS(PNM1.MAT(ilig,icol)) 211 : C enddo 212 : C enddo 213 : C write(ioimp,*) 'xsom=',xsom 214 : SEGSUP IVTMP 215 : SEGSUP PN 216 : * 217 : * On peut maintenant calculer les valeurs des fonctions de forme 218 : * et leurs dérivées premières (par rapport aux coordonnées de l'espace 219 : * de référence) aux points de Gauss sur l'élément de référence 220 : * 221 : IIMPR=IMPR 221 : CALL NIF(LRFVOL,JXCOPG,PNM1, 222 : $ FNPG,DFNPG, 223 : $ IIMPR,IRET) 224 : IF (IRET.NE.0) GOTO 9999 225 : SEGSUP PNM1 226 : ELSE 227 : WRITE(IOIMP,*) 'Le type d''élément ',LRFVOL.TYPEL 228 : WRITE(IOIMP,*) 'n''est pas reconnu.' 229 : GOTO 9999 230 : ENDIF 231 : * 232 : * Astuce foireuse (mais on fait quand même des 233 : * vérifications) On ne la fait pas pour les intégrations de surface 234 : * 235 : C IF (LLINE) THEN 236 : C SEGACT DFNPG*MOD 237 : C NBPOGO=DFNPG.VELCHE(/5) 238 : C NBELFV=DFNPG.VELCHE(/6) 239 : C DO IDIML=1,NDIML 240 : C DO IDDL=1,NBDDL 241 : C VALDF=DFNPG.VELCHE(1,IDDL,1,IDIML,1,1) 242 : C DO IBELFV=2,NBELFV 243 : C DO IPOGO=2,NBPOGO 244 : C VALDF2=DFNPG.VELCHE(1,IDDL,1,IDIML,IPOGO,1) 245 : C LEGAL=(ABS(VALDF2-VALDF).LE.100.D0*XZPREC) 246 : C IF (.NOT.LEGAL) THEN 247 : C WRITE(IOIMP,*) 'Houston, on a un probleme' 248 : C* SEGPRT,DFNPG 249 : C GOTO 9999 250 : C ENDIF 251 : C ENDDO 252 : C ENDDO 253 : C ENDDO 254 : C ENDDO 255 : C NBLIG=1 256 : C NBCOL=NBDDL 257 : C N2LIG=1 258 : C N2COL=NDIML 259 : C NBPOI=1 260 : C NBELM=1 261 : C SEGADJ,DFNPG 262 : C SEGDES DFNPG 263 : C ENDIF 264 : * 265 : * Normal termination 266 : * 267 : IRET=0 268 : RETURN 269 : * 270 : * Error handling 271 : * 272 : 9999 CONTINUE 273 : IRET=1 274 : WRITE(IOIMP,*) 'An error was detected in subroutine kfnrff' 275 : RETURN 276 : * 277 : * End of subroutine KFNRFF 278 : * 279 : END 280 : 281 : 282 : 283 :
© Cast3M 2003 - All rights reserved.
Disclaimer