MED fichier: f/2.3.2/test10.f

MED fichier

- Documentation MED
- Guides d'utilisation
- Guides de référence

f/2.3.2/test10.f
1 C* This file is part of MED.
2 C*
3 C* COPYRIGHT (C) 1999 - 2019 EDF R&D, CEA/DEN
4 C* MED is free software: you can redistribute it and/or modify
5 C* it under the terms of the GNU Lesser General Public License as published by
6 C* the Free Software Foundation, either version 3 of the License, or
7 C* (at your option) any later version.
8 C*
9 C* MED is distributed in the hope that it will be useful,
10 C* but WITHOUT ANY WARRANTY; without even the implied warranty of
11 C* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 C* GNU Lesser General Public License for more details.
13 C*
14 C* You should have received a copy of the GNU Lesser General Public License
15 C* along with MED. If not, see <http://www.gnu.org/licenses/>.
16 C*
17
18 C ******************************************************************************
19 C * - Nom du fichier : test10.f
20 C *
21 C * - Description : ecriture de champs de resultats MED
22 C *
23 C ******************************************************************************
24 program test10
25 C
26 implicit none
27 include 'med.hf'
28 C
29 integer*8 fid
30 integer ret,user_interlace,user_mode
31 real*8 a,b,p1,p2,dt
32
33 character*32 maa1,maa2,maa3
34 character*13 lien_maa2
35 C CHAMP N°1
36 character*32 nomcha1
37 character*16 comp1(2), unit1(2)
38 character*16 dtunit1, nounit
39 integer ncomp1
40 C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
41 integer ngauss1_1
42 character*32 gauss1_1
43 real*8 refcoo1(12), gscoo1_1(12), wg1_1(6)
44 integer nval1_1
45 real*8 valr1_1(1*6*2)
46 C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
47 integer ngauss1_2
48 character*32 gauss1_2
49 real*8 gscoo1_2(6), wg1_2(3)
50 integer nval1_2
51 real*8 valr1_2(2*3*2)
52 real*8 valr1_2p(2*3)
53 C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
54 integer ngauss1_3,nval1_3
55 real*8 valr1_3(2*3*2)
56 real*8 valr1_3p(2*2)
57
58 C CHAMP N°2
59 character*32 nomcha2
60 character*16 comp2(3), unit2(3)
61 integer ncomp2, nval2
62 integer valr2(5*3), valr2p(3*3)
63
64 C PROFILS UTILISES
65 character*32 nomprofil1
66 integer profil1(2) , profil2(3)
67
68 parameter(user_interlace = med_full_interlace)
69 parameter(user_mode = med_compact )
70 parameter( a=0.446948490915965d0, b=0.091576213509771d0 )
71 parameter( p1=0.11169079483905d0, p2=0.0549758718227661d0 )
72 C MAILLAGES
73 parameter( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
74 parameter( lien_maa2= "./testfoo.med" )
75 C CHAMP N°1
76 parameter( nomcha1 = "champ reel" )
77 parameter( ncomp1 = 2 )
78 parameter( dtunit1 = " ")
79 parameter( nounit = " ")
80 C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
81 parameter( gauss1_1 = "Model n1" )
82 parameter( ngauss1_1 = 6 )
83 C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
84 parameter( gauss1_2 = "Model n2" )
85 parameter( ngauss1_2 = 3 )
86 C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
87 parameter( ngauss1_3 = 6 )
88 parameter( nval1_3 = 6 )
89 C CHAMP N°2
90 parameter( nomcha2="champ entier")
91 parameter( ncomp2 = 3, nval2= 5 )
92 C PROFILS
93 parameter( nomprofil1 = "PROFIL(champ(1))" )
94
95
96 C CHAMP N°1
97 data comp1 /"comp1", "comp2"/
98 data unit1 /"unit1","unit2"/
99 C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
100 data nval1_1 / 1*6 /
101 data refcoo1 / -1.0,1.0, -1.0,-1.0, 1.0,-1.0, -1.0,0.0,
102 1 0.0,-1.0, 0.0,0.0 /
103 data valr1_1 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
104 1 20.0,21.0, 22.0,23.0/
105 C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
106 data valr1_2 / 0.0,1.0, 2.0,3.0, 10.0,11.0,
107 1 12.0,13.0, 20.0,21.0, 22.0,23.0 /
108 data valr1_2p / 12.0,13.0, 20.0,21.0, 22.0,23.0 /
109 C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
110 data valr1_3 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
111 1 20.0,21.0, 22.0,23.0 /
112 data valr1_3p / 2.0,3.0, 10.0,11.0 /
113 C CHAMP N°2
114 data comp2 /"comp1", "comp2", "comp3"/
115 data unit2 /"unit1","unit2", "unit3"/
116 data valr2 / 0,1,2, 10,11,12, 20,21,22, 30,31,32, 40,41,42 /
117 data valr2p / 0,1,2, 20,21,22, 40,41,42 /
118 C PROFILS
119 data profil1 /2,3/
120 data profil2 /1,3,5/
121
122 ret = 0
123
124 gscoo1_1(1) = 2*b-1
125 gscoo1_1(2) = 1-4*b
126 gscoo1_1(3) = 2*b-1
127 gscoo1_1(4) = 2*b-1
128 gscoo1_1(5) = 1-4*b
129 gscoo1_1(6) = 2*b-1
130 gscoo1_1(7) = 1-4*a
131 gscoo1_1(8) = 2*a-1
132 gscoo1_1(9) = 2*a-1
133 gscoo1_1(10) = 1-4*a
134 gscoo1_1(11) = 2*a-1
135 gscoo1_1(12) = 2*a-1
136
137 wg1_1(1) = 4*p2
138 wg1_1(2) = 4*p2
139 wg1_1(3) = 4*p2
140 wg1_1(4) = 4*p1
141 wg1_1(5) = 4*p1
142 wg1_1(6) = 4*p1
143
144 nval1_2 = 2*3
145 gscoo1_2(1) = -2.0d0/3
146 gscoo1_2(2) = 1.0d0/3
147 gscoo1_2(3) = -2.0d0/3
148 gscoo1_2(4) = -2.0d0/3
149 gscoo1_2(5) = 1.0d0/3
150 gscoo1_2(6) = -2.0d0/3
151
152 wg1_2(1) = 2.0d0/3
153 wg1_2(2) = 2.0d0/3
154 wg1_2(3) = 2.0d0/3
155
156 C ** ouverture du fichier **
157 call efouvr(fid,'test10.med',med_lecture_ecriture, ret)
158 if (ret .ne. 0 ) then
159 print *,'Erreur à l''ouverture du fichier : ','test10.med'
160 call efexit(-1)
161 endif
162
163 C ** creation du maillage maa1 de dimension 3 **
164 call efmaac(fid,maa1,3,med_non_structure,
165 1 "Maillage vide",ret)
166 if (ret .ne. 0 ) then
167 print *,'Erreur à la création du maillage : ', maa1
168 call efexit(-1)
169 endif
170
171 C ** creation du maillage maa3 de dimension 3 **
172 call efmaac(fid,maa3,3,med_non_structure,
173 1 "Maillage vide",ret)
174 if (ret .ne. 0 ) then
175 print *,'Erreur à la création du maillage : ', maa3
176 call efexit(-1)
177 endif
178
179
180 C ** creation du champ réel n°1 **
181 call efchac(fid,nomcha1,med_float64,comp1,unit1,ncomp1,ret)
182 if (ret .ne. 0 ) then
183 print *,'Erreur à la création du champ : ', nomcha1
184 ret = -1
185 endif
186
187 C ** creation du champ entier n°2 **
188 call efchac(fid,nomcha2,med_int32,comp2,unit2,ncomp2,ret)
189 if (ret .ne. 0 ) then
190 print *,'Erreur à la création du champ : ', nomcha2
191 ret = -1
192 endif
193
194 C ** creation du lien au fichier distant contenant maa2 **
195 call efliee(fid,lien_maa2,maa2,ret)
196 if (ret .ne. 0 ) then
197 print *,'Erreur à la création du lien : ', lien_maa2
198 ret = -1
199 endif
200
201 C ** creation de la localisation des points de Gauss modèle n°1 **
202 call efgaue(fid, med_tria6, refcoo1, user_interlace,
203 1 ngauss1_1, gscoo1_1, wg1_1, gauss1_1, ret)
204 if (ret .ne. 0 ) then
205 print *,'Erreur à la création du modèle n°1 : ', gauss1_1
206 ret = -1
207 endif
208
209 C ** creation de la localisation des points de Gauss modèle n°2 **
210 call efgaue(fid, med_tria6, refcoo1, user_interlace,
211 1 ngauss1_2, gscoo1_2, wg1_2, gauss1_2, ret)
212 if (ret .ne. 0 ) then
213 print *,'Erreur à la création du modèle n°2 : ', gauss1_2
214 ret = -1
215 endif
216
217
218 C ** Ecriture du champ n°1
219 C ** - enregistre uniquement la composante n°2 de valr1_1
220 C ** - pas de pas de temps, ni de numero d'ordre
221 dt = 0.0d0
222 call efchae(fid,maa1,nomcha1,valr1_1,user_interlace,nval1_1,
223 1 gauss1_1,2,med_nopfl,med_no_pflmod,
224 2 med_maille,med_tria6,
225 3 med_nopdt,dtunit1,dt,med_nonor,ret)
226 if (ret .ne. 0 ) then
227 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1'
228 ret = -1
229 endif
230
231 C ** Nouvelle Ecriture du champ reel en mode remplacement
232 C ** - complete le champ precedent en enregistrant les composantes 1
233 C ** - pas de pas de temps, ni de numero d'ordre
234 call efchae(fid,maa1,nomcha1,valr1_1,user_interlace,nval1_1,
235 1 gauss1_1,1,med_nopfl,med_no_pflmod,
236 2 med_maille,med_tria6,
237 3 med_nopdt,dtunit1,dt,med_nonor,ret)
238 if (ret .ne. 0 ) then
239 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2'
240 ret = -1
241 endif
242
243 C ** Ecriture sur le champ reel
244 C ** - De la 1ere composante du tableau valr1_2
245 C ** - Avec un pas de temps égal a 5.5
246 C ** - Pas de numero d'ordre
247 C ** - maa2 est distant
248 dt = 5.5d0
249 call efchae(fid,maa2,nomcha1,valr1_2,user_interlace,nval1_2,
250 1 gauss1_2,1,med_nopfl,med_no_pflmod,
251 2 med_maille,med_tria6,
252 3 1,"ms",dt,med_nonor,ret)
253 if (ret .ne. 0 ) then
254 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3'
255 ret = -1
256 endif
257
258 C ** Ecriture sur le champ reel
259 C ** - De la 2ere composante du tableau valr1_2
260 C ** - Avec un pas de temps égal a 5.5
261 C ** - Pas de numero d'ordre
262 C ** - maa1 est local
263 dt = 5.5d0
264 call efchae(fid,maa1,nomcha1,valr1_1,user_interlace,nval1_1,
265 1 gauss1_1,2,med_nopfl,med_no_pflmod,
266 2 med_maille,med_tria6,
267 3 1,"ms",dt,med_nonor,ret)
268 if (ret .ne. 0 ) then
269 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4'
270 ret = -1
271 endif
272
273
274 C ** Ecriture sur le champ reel
275 C ** - De la 1ere composante du tableau valr1_1
276 C ** - Avec un pas de temps égal a 5.5
277 C ** - Numero d'ordre egal a 2
278 C ** - maa3 est local
279 dt = 5.5d0
280 call efchae(fid,maa3,nomcha1,valr1_2,user_interlace,nval1_2,
281 1 gauss1_2,1,med_nopfl,med_no_pflmod,
282 2 med_maille,med_tria6,
283 3 1,"ms",dt,2,ret)
284 if (ret .ne. 0 ) then
285 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5'
286 ret = -1
287 endif
288
289 C ** Creation de profil
290 C ** - qui selectionne uniquement le 2e element du tableau valr1
291 call efpfle(fid,profil1,1,nomprofil1,ret)
292 if (ret .ne. 0 ) then
293 print *,'Erreur à la création du profil : ', nomprofil1
294 ret = -1
295 endif
296
297
298 C ** Ecriture du champ reel
299 C ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
300 C ** - Extrait a partir du profil de nom "profil1(1)"
301 C ** - Pas de temps = 5.6
302 C ** - Numero d'ordre = 2
303 dt = 5.6d0
304 call efchae(fid,maa1,nomcha1,valr1_3p,user_interlace,nval1_3,
305 1 med_nogauss,med_all,nomprofil1,user_mode,
306 2 med_maille,med_tria6,
307 3 2,"ms",dt,2,ret)
308 if (ret .ne. 0 ) then
309 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6'
310 ret = -1
311 endif
312
313 C ** Ecriture du champ reel
314 C ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
315 C ** - Extrait a partir du profil de nom "profil1(1)"
316 C ** - Pas de temps = 5.6
317 C ** - Numero d'ordre = 2
318 dt = 5.6d0
319 call efchae(fid,maa2,nomcha1,valr1_2p,user_interlace,nval1_2,
320 1 gauss1_2,med_all,nomprofil1,user_mode,
321 2 med_maille,med_tria6,
322 3 2,"ms",dt,2,ret)
323 if (ret .ne. 0 ) then
324 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7'
325 ret = -1
326 endif
327
328
329 C ** Ecriture du champ reel
330 C ** - 2e composante du 2e element du champ
331 C ** - Extrait a partir du profil de nom "profil1(1)"
332 C ** - Pas de temps = 5.7
333 C ** - Numero d'ordre = 2
334 dt = 5.7d0
335 call efchae(fid,maa1,nomcha1,valr1_3p,user_interlace,nval1_3,
336 1 med_nogauss,2,nomprofil1,user_mode,
337 2 med_maille,med_tria6,
338 3 3,"ms",dt,2,ret)
339 if (ret .ne. 0 ) then
340 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8'
341 ret = -1
342 endif
343
344
345 C ** Ecriture du champ entier n°2
346 C ** - 1ere composante des éléments de valr2
347 C ** - pas de pas de temps, ni de numero d'ordre
348 dt = 0.0d0
349 call efchae(fid,maa1,nomcha2,valr2,user_interlace,nval2,
350 1 med_nogauss,1,med_nopfl,med_no_pflmod,med_arete,
351 1 med_seg2,med_nopdt,nounit,dt,med_nonor,ret)
352 if (ret .ne. 0 ) then
353 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1'
354 ret = -1
355 endif
356
357 C ** Ecriture du champ entier n°2
358 C ** - 2ere composante des éléments de valr2
359 C ** - pas de pas de temps, ni de numero d'ordre
360 C ** - pour des raisons de complétude des tests on change
361 C ** le type d'élément (aucun sens phys.))
362 call efchae(fid,maa1,nomcha2,valr2,user_interlace,nval2,
363 1 med_nogauss,2,med_nopfl,med_no_pflmod,med_noeud,
364 1 0,med_nopdt,nounit,dt,med_nonor,ret)
365 if (ret .ne. 0 ) then
366 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2'
367 ret = -1
368 endif
369
370
371 C ** Ecriture du champ entier n°2
372 C ** - 3ere composante des éléments de valr2
373 C ** - pas de pas de temps, ni de numero d'ordre
374 C ** - pour des raisons de complétude des tests on change
375 C ** le type d'élément (aucun sens phys.))
376 call efchae(fid,maa1,nomcha2,valr2,user_interlace,nval2,
377 1 med_nogauss,3,med_nopfl,med_no_pflmod,med_face,
378 1 med_tria6,med_nopdt,nounit,dt,med_nonor,ret)
379 if (ret .ne. 0 ) then
380 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3'
381 ret = -1
382 endif
383
384 C ** Creation de profil
385 C ** - selectionne les elements 1,3,5 du tableau valr2
386 call efpfle(fid,profil2,3,"PROFIL(champ2)",ret)
387 if (ret .ne. 0 ) then
388 print *,'Erreur à l''écriture du profil : ',
389 1 'profil2(champ2)'
390 ret = -1
391 endif
392
393
394 C ** Ecriture du champ entier n°2
395 C ** - 3eme composante des éléments de valr2
396 C ** - pas de pas de temps, ni de numero d'ordre
397 C ** - profils
398 C ** - pour des raisons de complétude des tests on change
399 C ** le type d'élément (aucun sens phys.))
400 call efchae(fid,maa1,nomcha2,valr2p,user_interlace,nval2,
401 1 med_nogauss,3,"PROFIL(champ2)",user_mode,med_maille,
402 1 med_tria6,med_nopdt,nounit,dt,med_nonor,ret)
403 if (ret .ne. 0 ) then
404 print *,'Erreur à l''écriture du profil : ',
405 1 'profil2(champ2)'
406 ret = -1
407 endif
408
409 C ** Fermeture du fichier *
410 call efferm (fid,ret)
411 if (ret .ne. 0 ) then
412 print *,'Erreur à la fermeture du fichier : '
413 ret = -1
414 endif
415
416 print *,"Le code retour : ",ret
417 call efexit(ret)
418
419 end
420
421
422