1 : C NI SOURCE GOUNAND 05/12/21 21:34:26 5281
2 : SUBROUTINE NI(MYLRF,MYPG,PNM1,
3 : $ FNPG,DFNPG,
4 : $ IMPR,IRET)
5 : IMPLICIT INTEGER(I-N)
6 : IMPLICIT REAL*8 (A-H,O-Z)
7 : C***********************************************************************
8 : C NOM : NI
9 : C PROJET : Noyau linéaire NLIN
10 : C DESCRIPTION : Calcul des valeurs des fonctions de forme et des
11 : C valeurs de leurs dérivées premières aux points de Gauss.
12 : C
13 : C On utilise la relation (produit) suivante :
14 : C
15 : C < Ni (point) > = < Pi (point) > [Pn]^{-1}
16 : C
17 : C avec (cf. CALPN) :
18 : C [PN] = ( P1(ksi1) ..... Pn(ksi1))
19 : C ( ... ..... ... )
20 : C ( P1(ksin) ..... Pn(ksin))
21 : C n = nb. ddl sur l'élément (NDFN)
22 : C ksii = coords. du ieme noeud d'approximation
23 : C dans l'espace de référence (de dimension
24 : C NDIML)
25 : C Pi = ieme polynome d'interpolation sur
26 : C l'élément de référence.
27 : C Ni = ieme fonction nodale d'interpolation sur
28 : C l'élément de référence.
29 : C point= point quelconque sur l'élément de référence
30 : C (donc en particulier les points de Gauss)
31 : C LANGAGE : Esope
32 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
33 : C mél : gounand@semt2.smts.cea.fr
34 : C***********************************************************************
35 : C APPELES : VALPOL
36 : C APPELE PAR : KFNREF
37 : C***********************************************************************
38 : C ENTREES : MYLRF, MYPG, PNM1
39 : C ENTREES/SORTIES : -
40 : C SORTIES : FNPG, DFNPG
41 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
42 : C***********************************************************************
43 : C VERSION : v1, 16/09/99, version initiale
44 : C HISTORIQUE : v1, 16/09/99, création
45 : C HISTORIQUE : v2, 10/05/00, modif. du segment ELREF
46 : C HISTORIQUE :
47 : C HISTORIQUE :
48 : C***********************************************************************
49 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
50 : C en cas de modification de ce sous-programme afin de faciliter
51 : C la maintenance !
52 : C***********************************************************************
53 : -INC CCOPTIO
54 : CBEGININCLUDE SPOGAU
55 : SEGMENT POGAU
56 : CHARACTER*(LNNPG) NOMPG
57 : CHARACTER*(LNTPG) TYPMPG
58 : CHARACTER*(LNFPG) FORLPG
59 : INTEGER NORDPG
60 : REAL*8 XCOPG(NDLPG,NBPG)
61 : REAL*8 XPOPG(NBPG)
62 : ENDSEGMENT
63 : SEGMENT POGAUS
64 : POINTEUR LISPG(0).POGAU
65 : ENDSEGMENT
66 : CENDINCLUDE SPOGAU
67 : POINTEUR MYPG.POGAU
68 : CBEGININCLUDE SELREF
69 : SEGMENT ELREF
70 : CHARACTER*(LNNOM) NOMLRF
71 : CHARACTER*(LNFORM) FORME
72 : CHARACTER*(LNTYPL) TYPEL
73 : CHARACTER*(LNESP) ESPACE
74 : INTEGER DEGRE
75 : REAL*8 XCONOD(NDIMEL,NBNOD)
76 : INTEGER NPQUAF(NBDDL)
77 : INTEGER NUMCMP(NBDDL)
78 : INTEGER QUENOD(NBDDL)
79 : INTEGER ORDDER(NDIMEL,NBDDL)
80 : POINTEUR MBPOLY.POLYNS
81 : ENDSEGMENT
82 : SEGMENT ELREFS
83 : POINTEUR LISEL(0).ELREF
84 : ENDSEGMENT
85 : CENDINCLUDE SELREF
86 : POINTEUR MYLRF.ELREF
87 : CBEGININCLUDE SPOLYNO
88 : SEGMENT POLYNO
89 : REAL*8 COEMON(NBMON)
90 : INTEGER EXPMON(NDIML,NBMON)
91 : ENDSEGMENT
92 : SEGMENT POLYNS
93 : POINTEUR LIPOLY(NBPOLY).POLYNO
94 : ENDSEGMENT
95 : CENDINCLUDE SPOLYNO
96 : POINTEUR MYBPOL.POLYNS
97 : POINTEUR MYPOLY.POLYNO
98 : CBEGININCLUDE SMMREEL
99 : SEGMENT MMREEL
100 : REAL*8 MAT(JLIG,JCOL)
101 : ENDSEGMENT
102 : CENDINCLUDE SMMREEL
103 : POINTEUR PNM1.MMREEL
104 : -INC SMLENTI
105 : INTEGER JG
106 : POINTEUR ORDER1.MLENTI
107 : -INC SMLREEL
108 : POINTEUR VECTPI.MLREEL
109 : CBEGININCLUDE SMCHAEL
110 : SEGMENT MCHAEL
111 : POINTEUR IMACHE(N1).MELEME
112 : POINTEUR ICHEVA(N1).MCHEVA
113 : ENDSEGMENT
114 : SEGMENT MCHEVA
115 : REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
116 : ENDSEGMENT
117 : SEGMENT LCHEVA
118 : POINTEUR LISCHE(NBCHE).MCHEVA
119 : ENDSEGMENT
120 : CENDINCLUDE SMCHAEL
121 : INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
122 : POINTEUR FNPG.MCHEVA
123 : POINTEUR DFNPG.MCHEVA
124 : *
125 : INTEGER IMPR,IRET
126 : *
127 : * Fonction Blas (produit scalaire)
128 : *
129 : REAL*8 DDOT
130 : *
131 : INTEGER NBMONO
132 : INTEGER NDIML,NDPG,NBFN
133 : INTEGER INDIML,JNDIML,INDPG,INBFN
134 : *
135 : * Executable statements
136 : *
137 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ni'
138 : *
139 : * Initialisations
140 : *
141 : SEGACT MYPG
142 : NDIML=MYPG.XCOPG(/1)
143 : NDPG=MYPG.XCOPG(/2)
144 : SEGACT MYLRF
145 : MYBPOL=MYLRF.MBPOLY
146 : SEGDES MYLRF
147 : SEGACT MYBPOL
148 : SEGACT MYBPOL.LIPOLY(*)
149 : NBFN=MYBPOL.LIPOLY(/1)
150 : SEGACT PNM1
151 : JG=NDIML
152 : SEGINI ORDER1
153 : JG=NBFN
154 : SEGINI VECTPI
155 : *
156 : * On calcule les valeurs des fonctions de forme aux points de Gauss
157 : *
158 : NBLIG=1
159 : NBCOL=NBFN
160 : N2LIG=1
161 : N2COL=1
162 : NBPOI=NDPG
163 : NBELM=1
164 : SEGINI FNPG
165 : DO 1 INDIML=1,NDIML
166 : ORDER1.LECT(INDIML)=0
167 : 1 CONTINUE
168 : DO 3 INDPG=1,NDPG
169 : * Calcul de < P (pg) > = < P1(pg) ... Pnbfn(pg) > où pg est le
170 : * INDPGieme point de Gauss
171 : DO 32 INBFN=1,NBFN
172 : MYPOLY=MYBPOL.LIPOLY(INBFN)
173 : NBMONO=MYPOLY.EXPMON(/2)
173 : CALL VALPOL(NDIML,NBMONO,
174 : $ MYPG.XCOPG(1,INDPG),
175 : $ MYPOLY.COEMON,MYPOLY.EXPMON,
176 : $ ORDER1.LECT,
177 : $ VECTPI.PROG(INBFN),
178 : $ IMPR,IRET)
179 : IF (IRET.NE.0) GOTO 9999
180 : 32 CONTINUE
181 : * On calcule : < N (pg) > = < P (pg) > [Pn]^{-1}
182 : DO 34 INBFN=1,NBFN
183 : FNPG.VELCHE(1,INBFN,1,1,INDPG,1)=
184 : $ DDOT(NBFN,VECTPI.PROG,1,PNM1.MAT(1,INBFN),1)
185 : 34 CONTINUE
186 : 3 CONTINUE
187 : IF (IMPR.GT.3) THEN
188 : WRITE(IOIMP,*) 'Ordre de dérivation / coordonnée de réf. :'
189 : WRITE(IOIMP,4003) (ORDER1.LECT(INDIML),INDIML=1,NDIML)
190 : DO 5 INDPG=1,NDPG
191 : WRITE(IOIMP,*) 'Noeud de coordonnées :'
192 : WRITE(IOIMP,4004) (MYPG.XCOPG(INDIML,INDPG),
193 : $ INDIML=1,NDIML)
194 : WRITE(IOIMP,*) 'FNPG.VELCHE(nb.fns.forme) :'
195 : WRITE(IOIMP,4004) (FNPG.VELCHE(1,INBFN,1,1,INDPG,1),
196 : $ INBFN=1,NBFN)
197 : 5 CONTINUE
198 : ENDIF
199 : SEGDES FNPG
200 : *
201 : * On calcule les valeurs des dérivées premières des fonctions
202 : * de forme aux points de Gauss
203 : *
204 : NBLIG=1
205 : NBCOL=NBFN
206 : N2LIG=1
207 : N2COL=NDIML
208 : NBPOI=NDPG
209 : NBELM=1
210 : SEGINI DFNPG
211 : IF (IRET.NE.0) GOTO 9999
212 : DO 7 INDIML=1,NDIML
213 : DO 72 JNDIML=1,NDIML
214 : IF (JNDIML.EQ.INDIML) THEN
215 : ORDER1.LECT(JNDIML)=1
216 : ELSE
217 : ORDER1.LECT(JNDIML)=0
218 : ENDIF
219 : 72 CONTINUE
220 : DO 74 INDPG=1,NDPG
221 : DO 742 INBFN=1,NBFN
222 : * Calcul de < dP/dksi_indiml (pg) > où pg est le
223 : * INDPGieme point de Gauss
224 : MYPOLY=MYBPOL.LIPOLY(INBFN)
225 : NBMONO=MYPOLY.EXPMON(/2)
225 : CALL VALPOL(NDIML,NBMONO,
226 : $ MYPG.XCOPG(1,INDPG),
227 : $ MYPOLY.COEMON,MYPOLY.EXPMON,
228 : $ ORDER1.LECT,
229 : $ VECTPI.PROG(INBFN),
230 : $ IMPR,IRET)
231 : IF (IRET.NE.0) GOTO 9999
232 : 742 CONTINUE
233 : * On calcule : < dN/dksi_indiml (pg) > = < dP/dksi_indiml (pg) > [Pn]^{-1}
234 : DO 744 INBFN=1,NBFN
235 : DFNPG.VELCHE(1,INBFN,1,INDIML,INDPG,1)=
236 : $ DDOT(NBFN,VECTPI.PROG,1,PNM1.MAT(1,INBFN),1)
237 : 744 CONTINUE
238 : 74 CONTINUE
239 : IF (IMPR.GT.3) THEN
240 : WRITE(IOIMP,*)
241 : $ 'Ordre de dérivation / coordonnée de réf. :'
242 : WRITE(IOIMP,4003) (ORDER1.LECT(JNDIML),JNDIML=1,NDIML)
243 : DO 76 INDPG=1,NDPG
244 : WRITE(IOIMP,*) 'Noeud de coordonnées :'
245 : WRITE(IOIMP,4004) (MYPG.XCOPG(JNDIML,INDPG),
246 : $ JNDIML=1,NDIML)
247 : WRITE(IOIMP,*) 'DFNPG.VELCHE(nb.fns.forme) :'
248 : WRITE(IOIMP,4004)
249 : $ (DFNPG.VELCHE(1,INBFN,1,INDIML,INDPG,1),
250 : $ INBFN=1,NBFN)
251 : 76 CONTINUE
252 : ENDIF
253 : 7 CONTINUE
254 : SEGDES DFNPG
255 : SEGSUP VECTPI
256 : SEGSUP ORDER1
257 : SEGDES PNM1
258 : SEGDES MYBPOL.LIPOLY(*)
259 : SEGDES MYBPOL
260 : SEGDES MYPG
261 : *
262 : * Normal termination
263 : *
264 : IRET=0
265 : RETURN
266 : *
267 : * Format handling
268 : *
269 : 4003 FORMAT (2X,6(1X,I3))
270 : 4004 FORMAT (2X,6(1X,1PE13.5))
271 : *
272 : * Error handling
273 : *
274 : 9999 CONTINUE
275 : IRET=1
276 : WRITE(IOIMP,*) 'An error was detected in subroutine ni'
277 : RETURN
278 : *
279 : * End of subroutine NI
280 : *
281 : END
282 :
283 :
284 :
285 :
© Cast3M 2003 - All rights reserved.
Disclaimer