MED fichier: f/2.3.6/test10.f

MED fichier

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

f/2.3.6/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 CHAMP N°3
65 character*32 nomcha3
66 character*16 comp3(2), unit3(2)
67 integer ncomp3, nval3
68 integer valr3(5*4*2), valr3p(3*4*2)
69
70 C PROFILS UTILISES
71 character*32 nomprofil1
72 integer profil1(2) , profil2(3)
73
74 parameter(user_interlace = med_full_interlace)
75 parameter(user_mode = med_compact )
76 parameter( a=0.446948490915965d0, b=0.091576213509771d0 )
77 parameter( p1=0.11169079483905d0, p2=0.0549758718227661d0 )
78 C MAILLAGES
79 parameter( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
80 parameter( lien_maa2= "./testfoo.med" )
81 C CHAMP N°1
82 parameter( nomcha1 = "champ reel" )
83 parameter( ncomp1 = 2 )
84 parameter( dtunit1 = " ")
85 parameter( nounit = " ")
86 C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
87 parameter( gauss1_1 = "Model n1" )
88 parameter( ngauss1_1 = 6 )
89 C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
90 parameter( gauss1_2 = "Model n2" )
91 parameter( ngauss1_2 = 3 )
92 C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
93 parameter( ngauss1_3 = 6 )
94 parameter( nval1_3 = 6 )
95 C CHAMP N°2
96 parameter( nomcha2="champ entier")
97 parameter( ncomp2 = 3, nval2= 5 )
98 C CHAMP N°3
99 parameter( nomcha3="champ entier 3")
100 parameter( ncomp3 = 2, nval3= 5*4 )
101 C PROFILS
102 parameter( nomprofil1 = "PROFIL(champ(1))" )
103
104
105 C CHAMP N°1
106 data comp1 /"comp1", "comp2"/
107 data unit1 /"unit1","unit2"/
108 C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
109 data nval1_1 / 1*6 /
110 data refcoo1 / -1.0,1.0, -1.0,-1.0, 1.0,-1.0, -1.0,0.0,
111 1 0.0,-1.0, 0.0,0.0 /
112 data valr1_1 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
113 1 20.0,21.0, 22.0,23.0/
114 C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
115 data valr1_2 / 0.0,1.0, 2.0,3.0, 10.0,11.0,
116 1 12.0,13.0, 20.0,21.0, 22.0,23.0 /
117 data valr1_2p / 12.0,13.0, 20.0,21.0, 22.0,23.0 /
118 C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
119 data valr1_3 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
120 1 20.0,21.0, 22.0,23.0 /
121 data valr1_3p / 2.0,3.0, 10.0,11.0 /
122 C CHAMP N°2
123 data comp2 /"comp1", "comp2", "comp3"/
124 data unit2 /"unit1","unit2", "unit3"/
125 data valr2 / 0,1,2, 10,11,12, 20,21,22, 30,31,32, 40,41,42 /
126 data valr2p / 0,1,2, 20,21,22, 40,41,42 /
127 C CHAMP N°3
128 data comp3 /"comp1", "comp2"/
129 data unit3 /"unit1","unit2"/
130 data valr3 / 0,1, 10,11, 20,21, 30,31,
131 1 40,41, 50,51, 60,61, 70,71,
132 1 80,81, 90,91, 100,101, 110,111,
133 1 120,121, 130,131, 140,141, 150,151,
134 1 160,161, 170,171, 180,181, 190,191 /
135 data valr3p / 0,1, 10,11, 20,21, 30,31,
136 1 80,81, 90,91, 100,101, 110,111,
137 1 160,161, 170,171, 180,181, 190,191 /
138
139
140 C PROFILS
141 data profil1 /2,3/
142 data profil2 /1,3,5/
143
144 ret = 0
145
146 gscoo1_1(1) = 2*b-1
147 gscoo1_1(2) = 1-4*b
148 gscoo1_1(3) = 2*b-1
149 gscoo1_1(4) = 2*b-1
150 gscoo1_1(5) = 1-4*b
151 gscoo1_1(6) = 2*b-1
152 gscoo1_1(7) = 1-4*a
153 gscoo1_1(8) = 2*a-1
154 gscoo1_1(9) = 2*a-1
155 gscoo1_1(10) = 1-4*a
156 gscoo1_1(11) = 2*a-1
157 gscoo1_1(12) = 2*a-1
158
159 wg1_1(1) = 4*p2
160 wg1_1(2) = 4*p2
161 wg1_1(3) = 4*p2
162 wg1_1(4) = 4*p1
163 wg1_1(5) = 4*p1
164 wg1_1(6) = 4*p1
165
166 nval1_2 = 2*3
167 gscoo1_2(1) = -2.0d0/3
168 gscoo1_2(2) = 1.0d0/3
169 gscoo1_2(3) = -2.0d0/3
170 gscoo1_2(4) = -2.0d0/3
171 gscoo1_2(5) = 1.0d0/3
172 gscoo1_2(6) = -2.0d0/3
173
174 wg1_2(1) = 2.0d0/3
175 wg1_2(2) = 2.0d0/3
176 wg1_2(3) = 2.0d0/3
177
178 C ** ouverture du fichier **
179 call efouvr(fid,'test10.med',med_lecture_ecriture, ret)
180 if (ret .ne. 0 ) then
181 print *,'Erreur à l''ouverture du fichier : ','test10.med'
182 call efexit(-1)
183 endif
184
185 C ** creation du maillage maa1 de dimension 3 **
186 call efmaac(fid,maa1,3,med_non_structure,
187 1 "Maillage vide",ret)
188 if (ret .ne. 0 ) then
189 print *,'Erreur à la création du maillage : ', maa1
190 call efexit(-1)
191 endif
192
193 C ** creation du maillage maa3 de dimension 3 **
194 call efmaac(fid,maa3,3,med_non_structure,
195 1 "Maillage vide",ret)
196 if (ret .ne. 0 ) then
197 print *,'Erreur à la création du maillage : ', maa3
198 call efexit(-1)
199 endif
200
201
202 C ** creation du champ réel n°1 **
203 call efchac(fid,nomcha1,med_float64,comp1,unit1,ncomp1,ret)
204 if (ret .ne. 0 ) then
205 print *,'Erreur à la création du champ : ', nomcha1
206 call efexit(-1)
207 endif
208
209 C ** creation du champ entier n°2 **
210 call efchac(fid,nomcha2,med_int32,comp2,unit2,ncomp2,ret)
211 if (ret .ne. 0 ) then
212 print *,'Erreur à la création du champ : ', nomcha2
213 call efexit(-1)
214 endif
215
216 C ** creation du lien au fichier distant contenant maa2 **
217 call efliee(fid,lien_maa2,maa2,ret)
218 if (ret .ne. 0 ) then
219 print *,'Erreur à la création du lien : ', lien_maa2
220 call efexit(-1)
221 endif
222
223 C ** creation de la localisation des points de Gauss modèle n°1 **
224 call efgaue(fid, med_tria6, refcoo1, user_interlace,
225 1 ngauss1_1, gscoo1_1, wg1_1, gauss1_1, ret)
226 if (ret .ne. 0 ) then
227 print *,'Erreur à la création du modèle n°1 : ', gauss1_1
228 call efexit(-1)
229 endif
230
231 C ** creation de la localisation des points de Gauss modèle n°2 **
232 call efgaue(fid, med_tria6, refcoo1, user_interlace,
233 1 ngauss1_2, gscoo1_2, wg1_2, gauss1_2, ret)
234 if (ret .ne. 0 ) then
235 print *,'Erreur à la création du modèle n°2 : ', gauss1_2
236 call efexit(-1)
237 endif
238
239
240 C ** Ecriture du champ n°1
241 C ** - enregistre uniquement la composante n°2 de valr1_1
242 C ** - pas de pas de temps, ni de numero d'ordre
243 dt = 0.0d0
244 call efchae(fid,maa1,nomcha1,valr1_1,user_interlace,nval1_1,
245 1 gauss1_1,2,med_nopfl,med_no_pflmod,
246 2 med_maille,med_tria6,
247 3 med_nopdt,dtunit1,dt,med_nonor,ret)
248 if (ret .ne. 0 ) then
249 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1'
250 call efexit(-1)
251 endif
252
253 C ** Nouvelle Ecriture du champ reel en mode remplacement
254 C ** - complete le champ precedent en enregistrant les composantes 1
255 C ** - pas de pas de temps, ni de numero d'ordre
256 call efchae(fid,maa1,nomcha1,valr1_1,user_interlace,nval1_1,
257 1 gauss1_1,1,med_nopfl,med_no_pflmod,
258 2 med_maille,med_tria6,
259 3 med_nopdt,dtunit1,dt,med_nonor,ret)
260 if (ret .ne. 0 ) then
261 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2'
262 call efexit(-1)
263 endif
264
265 C ** Ecriture sur le champ reel
266 C ** - De la 1ere composante du tableau valr1_2
267 C ** - Avec un pas de temps égal a 5.5
268 C ** - Pas de numero d'ordre
269 C ** - maa2 est distant
270 dt = 5.5d0
271 call efchae(fid,maa2,nomcha1,valr1_2,user_interlace,nval1_2,
272 1 gauss1_2,1,med_nopfl,med_no_pflmod,
273 2 med_maille,med_tria6,
274 3 1,"ms",dt,med_nonor,ret)
275 if (ret .ne. 0 ) then
276 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3'
277 call efexit(-1)
278 endif
279
280 C ** Ecriture sur le champ reel
281 C ** - De la 2ere composante du tableau valr1_2
282 C ** - Avec un pas de temps égal a 5.5
283 C ** - Pas de numero d'ordre
284 C ** - maa1 est local
285 dt = 5.5d0
286 call efchae(fid,maa1,nomcha1,valr1_1,user_interlace,nval1_1,
287 1 gauss1_1,2,med_nopfl,med_no_pflmod,
288 2 med_maille,med_tria6,
289 3 1,"ms",dt,med_nonor,ret)
290 if (ret .ne. 0 ) then
291 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4'
292 call efexit(-1)
293 endif
294
295
296 C ** Ecriture sur le champ reel
297 C ** - De la 1ere composante du tableau valr1_1
298 C ** - Avec un pas de temps égal a 5.5
299 C ** - Numero d'ordre egal a 2
300 C ** - maa3 est local
301 dt = 5.5d0
302 call efchae(fid,maa3,nomcha1,valr1_2,user_interlace,nval1_2,
303 1 gauss1_2,1,med_nopfl,med_no_pflmod,
304 2 med_maille,med_tria6,
305 3 1,"ms",dt,2,ret)
306 if (ret .ne. 0 ) then
307 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5'
308 call efexit(-1)
309 endif
310
311 C ** Creation de profil
312 C ** - qui selectionne uniquement le 2e element du tableau valr1
313 call efpfle(fid,profil1,1,nomprofil1,ret)
314 if (ret .ne. 0 ) then
315 print *,'Erreur à la création du profil : ', nomprofil1
316 call efexit(-1)
317 endif
318
319
320 C ** Ecriture du champ reel
321 C ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
322 C ** - Extrait a partir du profil de nom "profil1(1)"
323 C ** - Pas de temps = 5.6
324 C ** - Numero d'ordre = 2
325 dt = 5.6d0
326 call efchae(fid,maa1,nomcha1,valr1_3p,user_interlace,nval1_3,
327 1 med_nogauss,med_all,nomprofil1,user_mode,
328 2 med_maille,med_tria6,
329 3 2,"ms",dt,2,ret)
330 if (ret .ne. 0 ) then
331 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6'
332 call efexit(-1)
333 endif
334
335 C ** Ecriture du champ reel
336 C ** - Toutes les composantes du 2e element de valr1_1 (MED_ALL)
337 C ** - Extrait a partir du profil de nom "profil1(1)"
338 C ** - Pas de temps = 5.6
339 C ** - Numero d'ordre = 2
340 dt = 5.6d0
341 call efchae(fid,maa2,nomcha1,valr1_2p,user_interlace,nval1_2,
342 1 gauss1_2,med_all,nomprofil1,user_mode,
343 2 med_maille,med_tria6,
344 3 2,"ms",dt,2,ret)
345 if (ret .ne. 0 ) then
346 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7'
347 call efexit(-1)
348 endif
349
350
351 C ** Ecriture du champ reel
352 C ** - 2e composante du 2e element du champ
353 C ** - Extrait a partir du profil de nom "profil1(1)"
354 C ** - Pas de temps = 5.7
355 C ** - Numero d'ordre = 2
356 dt = 5.7d0
357 call efchae(fid,maa1,nomcha1,valr1_3p,user_interlace,nval1_3,
358 1 med_nogauss,2,nomprofil1,user_mode,
359 2 med_maille,med_tria6,
360 3 3,"ms",dt,2,ret)
361 if (ret .ne. 0 ) then
362 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8'
363 call efexit(-1)
364 endif
365
366
367 C ** Ecriture du champ entier n°2
368 C ** - 1ere composante des éléments de valr2
369 C ** - pas de pas de temps, ni de numero d'ordre
370 dt = 0.0d0
371 call efchae(fid,maa1,nomcha2,valr2,user_interlace,nval2,
372 1 med_nogauss,1,med_nopfl,med_no_pflmod,med_arete,
373 1 med_seg2,med_nopdt,nounit,dt,med_nonor,ret)
374 if (ret .ne. 0 ) then
375 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1'
376 call efexit(-1)
377 endif
378
379 C ** Ecriture du champ entier n°2
380 C ** - 2ere composante des éléments de valr2
381 C ** - pas de pas de temps, ni de numero d'ordre
382 C ** - pour des raisons de complétude des tests on change
383 C ** le type d'élément (aucun sens phys.))
384 call efchae(fid,maa1,nomcha2,valr2,user_interlace,nval2,
385 1 med_nogauss,2,med_nopfl,med_no_pflmod,med_noeud,
386 1 0,med_nopdt,nounit,dt,med_nonor,ret)
387 if (ret .ne. 0 ) then
388 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2'
389 call efexit(-1)
390 endif
391
392
393 C ** Ecriture du champ entier n°2
394 C ** - 3ere composante des éléments de valr2
395 C ** - pas de pas de temps, ni de numero d'ordre
396 C ** - pour des raisons de complétude des tests on change
397 C ** le type d'élément (aucun sens phys.))
398 call efchae(fid,maa1,nomcha2,valr2,user_interlace,nval2,
399 1 med_nogauss,3,med_nopfl,med_no_pflmod,med_face,
400 1 med_tria6,med_nopdt,nounit,dt,med_nonor,ret)
401 if (ret .ne. 0 ) then
402 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3'
403 call efexit(-1)
404 endif
405
406 C ** Creation de profil
407 C ** - selectionne les elements 1,3,5 du tableau valr2
408 call efpfle(fid,profil2,3,"PROFIL(champ2)",ret)
409 if (ret .ne. 0 ) then
410 print *,'Erreur à l''écriture du profil : ',
411 1 'profil2(champ2)'
412 call efexit(-1)
413 endif
414
415
416 C ** Ecriture du champ entier n°2
417 C ** - 3eme composante des éléments de valr2
418 C ** - pas de pas de temps, ni de numero d'ordre
419 C ** - profils
420 C ** - pour des raisons de complétude des tests on change
421 C ** le type d'élément (aucun sens phys.))
422 call efchae(fid,maa1,nomcha2,valr2p,user_interlace,nval2,
423 1 med_nogauss,3,"PROFIL(champ2)",user_mode,med_maille,
424 1 med_tria6,med_nopdt,nounit,dt,med_nonor,ret)
425 if (ret .ne. 0 ) then
426 print *,'Erreur à l''écriture du profil : ',
427 1 'profil2(champ2)'
428 call efexit(-1)
429 endif
430
431 C ** creation du champ entier n°3 **
432 call efchac(fid,nomcha3,med_int32,comp3,unit3,ncomp3,ret)
433 if (ret .ne. 0 ) then
434 print *,'Erreur à la création du champ : ', nomcha3
435 call efexit(-1)
436 endif
437
438 C ** Ecriture du champ entier n°3
439 C ** - 1ere composante des éléments de valr3
440 C ** - pas de pas de temps, ni de numero d'ordre
441 C ** - pour des raisons de complétude des tests on change
442 C ** le type d'élément (aucun sens phys.))
443 call efchae(fid,maa1,nomcha3,valr3,user_interlace,nval3,
444 1 med_nogauss,1,med_nopfl,med_no_pflmod,med_noeud_maille,
445 1 med_quad4,med_nopdt,nounit,dt,med_nonor,ret)
446 if (ret .ne. 0 ) then
447 print *,'Erreur à l''écriture du champ : ', nomcha3,'et.1'
448 call efexit(-1)
449 endif
450
451 C ** Ecriture du champ entier n°3
452 C ** - les composantes des éléments de valr3
453 C ** - pas de pas de temps, ni de numero d'ordre
454 C ** - pour des raisons de complétude des tests on change
455 C ** le type d'élément (aucun sens phys.))
456 call efchae(fid,maa2,nomcha3,valr3,user_interlace,nval3,
457 1 med_nogauss,med_all,med_nopfl,med_no_pflmod,
458 1 med_noeud_maille,
459 1 med_quad4,med_nopdt,nounit,dt,med_nonor,ret)
460 if (ret .ne. 0 ) then
461 print *,'Erreur à l''écriture du champ : ', nomcha3,'et.2'
462 call efexit(-1)
463 endif
464
465 C ** Ecriture du champ entier n°3
466 C ** - les composantes des éléments de valr3
467 C ** - pas de pas de temps, ni de numero d'ordre
468 C ** - profils
469 C ** - pour des raisons de complétude des tests on change
470 C ** le type d'élément (aucun sens phys.))
471 call efchae(fid,maa3,nomcha3,valr3p,user_interlace,nval3,
472 1 med_nogauss,med_all,"PROFIL(champ2)",user_mode,
473 1 med_noeud_maille,
474 1 med_quad4,med_nopdt,nounit,dt,med_nonor,ret)
475 if (ret .ne. 0 ) then
476 print *,'Erreur à l''écriture du profil : ',
477 1 'profil2(champ2)'
478 call efexit(-1)
479 endif
480
481 C ** Fermeture du fichier *
482 call efferm (fid,ret)
483 if (ret .ne. 0 ) then
484 print *,'Erreur à la fermeture du fichier : '
485 ret = -1
486 endif
487
488 print *,"Le code retour : ",ret
489 call efexit(ret)
490
491 end
492
493
494