1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
25
26 implicit none
27 include 'med.hf'
28
29 integer*8 fid
30 integer ret,USER_INTERLACE,USER_MODE
31 integer FTYPECHA
32 real*8 a,b,p1,p2,dt
33
34 character*64 maa1,maa2,maa3
35 character*13 lien_maa2
36 character*16 nomcoo(3)
37 character*16 unicoo(3)
38
39 character*64 nomcha1
40 character*16 comp1(2), unit1(2)
41 character*16 dtunit1, nounit
42 integer ncomp1
43
44 integer ngauss1_1
45 character*64 gauss1_1
46 real*8 refcoo1(12), gscoo1_1(12), wg1_1(6)
47 integer nval1_1, nent1_1
48 real*8 valr1_1(1*6*2)
49
50 integer ngauss1_2
51 character*64 gauss1_2
52 real*8 gscoo1_2(6), wg1_2(3)
53 integer nval1_2, nent1_2
54 real*8 valr1_2(2*3*2)
55 real*8 valr1_2p(2*3)
56
57 integer ngauss1_3,nval1_3, nent1_3
58 real*8 valr1_3(2*3*2)
59 real*8 valr1_3p(2*2)
60
61
62 character*64 nomcha2
63 character*16 comp2(3), unit2(3)
64 integer ncomp2, nval2
65 integer valr2(5*3), valr2p(3*3)
66
67
68 character*64 nomcha3
69 character*16 comp3(2), unit3(2)
70 integer ncomp3, nval3, nent3
71 integer valr3(5*4*2), valr3p(3*4*2)
72
73
74 character*64 nomprofil1
75 integer profil1(2) , profil2(3)
76
77 parameter(user_interlace = med_full_interlace)
78 parameter(user_mode = med_compact_stmode )
80 parameter( a=0.446948490915965d0, b=0.091576213509771d0 )
81 parameter( p1=0.11169079483905d0, p2=0.0549758718227661d0 )
82
83 parameter( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
84 parameter( lien_maa2= "./testfoo.med" )
85
86 parameter( nomcha1 = "champ reel" )
87 parameter( ncomp1 = 2 )
88 parameter( dtunit1 = " ")
89 parameter( nounit = " ")
90
91 parameter( gauss1_1 = "Model n1" )
92 parameter( ngauss1_1 = 6 )
93
94 parameter( gauss1_2 = "Model n2" )
95 parameter( ngauss1_2 = 3 )
96
97 parameter( ngauss1_3 = 6 )
98 parameter( nval1_3 = 6 )
99
100 parameter( nomcha2="champ entier")
101 parameter( ncomp2 = 3, nval2= 5 )
102
103 parameter( nomcha3="champ entier 3")
104 parameter( ncomp3 = 2, nval3= 5*4 )
105
106 parameter( nomprofil1 = "PROFIL(champ(1))" )
107
108
109
110 data comp1 /"comp1", "comp2"/
111 data unit1 /"unit1","unit2"/
112
113 data nval1_1 / 1*6 /
114 data nent1_1 / 1 /
115 data refcoo1 / -1.0,1.0, -1.0,-1.0, 1.0,-1.0, -1.0,0.0,
116 1 0.0,-1.0, 0.0,0.0 /
117 data valr1_1 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
118 1 20.0,21.0, 22.0,23.0/
119
120 data nent1_2 / 2 /
121 data valr1_2 / 0.0,1.0, 2.0,3.0, 10.0,11.0,
122 1 12.0,13.0, 20.0,21.0, 22.0,23.0 /
123 data valr1_2p / 12.0,13.0, 20.0,21.0, 22.0,23.0 /
124
125 data nent1_3 / 6 /
126 data valr1_3 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
127 1 20.0,21.0, 22.0,23.0 /
128 data valr1_3p / 2.0,3.0, 10.0,11.0 /
129
130 data comp2 /"comp1", "comp2", "comp3"/
131 data unit2 /"unit1","unit2", "unit3"/
132 data valr2 / 0,1,2, 10,11,12, 20,21,22, 30,31,32, 40,41,42 /
133 data valr2p / 0,1,2, 20,21,22, 40,41,42 /
134
135 data nent3 / 5 /
136 data comp3 /"comp1", "comp2"/
137 data unit3 /"unit1","unit2"/
138 data valr3 / 0,1, 10,11, 20,21, 30,31,
139 1 40,41, 50,51, 60,61, 70,71,
140 1 80,81, 90,91, 100,101, 110,111,
141 1 120,121, 130,131, 140,141, 150,151,
142 1 160,161, 170,171, 180,181, 190,191 /
143 data valr3p / 0,1, 10,11, 20,21, 30,31,
144 1 80,81, 90,91, 100,101, 110,111,
145 1 160,161, 170,171, 180,181, 190,191 /
146
147
148
149 data profil1 /2,3/
150 data profil2 /1,3,5/
151
152 data nomcoo /"x","y","z"/, unicoo /"cm","cm","cm"/
153
154 ret = 0
155
156 gscoo1_1(1) = 2*b-1
157 gscoo1_1(2) = 1-4*b
158 gscoo1_1(3) = 2*b-1
159 gscoo1_1(4) = 2*b-1
160 gscoo1_1(5) = 1-4*b
161 gscoo1_1(6) = 2*b-1
162 gscoo1_1(7) = 1-4*a
163 gscoo1_1(8) = 2*a-1
164 gscoo1_1(9) = 2*a-1
165 gscoo1_1(10) = 1-4*a
166 gscoo1_1(11) = 2*a-1
167 gscoo1_1(12) = 2*a-1
168
169 wg1_1(1) = 4*p2
170 wg1_1(2) = 4*p2
171 wg1_1(3) = 4*p2
172 wg1_1(4) = 4*p1
173 wg1_1(5) = 4*p1
174 wg1_1(6) = 4*p1
175
176 nval1_2 = 2*3
177 gscoo1_2(1) = -2.0d0/3
178 gscoo1_2(2) = 1.0d0/3
179 gscoo1_2(3) = -2.0d0/3
180 gscoo1_2(4) = -2.0d0/3
181 gscoo1_2(5) = 1.0d0/3
182 gscoo1_2(6) = -2.0d0/3
183
184 wg1_2(1) = 2.0d0/3
185 wg1_2(2) = 2.0d0/3
186 wg1_2(3) = 2.0d0/3
187
188
189 call mfivop(fid,
'test10f.med', med_acc_rdwr,
190 & med_major_num, med_minor_num, med_release_num, ret)
191 print *,ret
192 if (ret .ne. 0 ) then
193 print *,'Erreur à l''ouverture du fichier : ','test10.med'
194 call efexit(-1)
195 endif
196
197
199 & med_unstructured_mesh,'Maillage vide',
200 & "",med_sort_dtit,med_cartesian,nomcoo,unicoo,ret)
201 print *,ret
202 if (ret .ne. 0 ) then
203 print *,'Erreur à la création du maillage : ', maa1
204 call efexit(-1)
205 endif
206
207
209 & med_unstructured_mesh,'Maillage vide',
210 & "",med_sort_dtit,med_cartesian,nomcoo,unicoo,ret)
211 print *,ret
212 if (ret .ne. 0 ) then
213 print *,'Erreur à la création du maillage : ', maa3
214 call efexit(-1)
215 endif
216
217
218
219 call mfdcre(fid,nomcha1,ftypecha,ncomp1,comp1,unit1,
220 & dtunit1,maa1,ret)
221 print *,ret
222 if (ret .ne. 0 ) then
223 print *,'Erreur à la création du champ : ', nomcha1
224 call efexit(-1)
225 endif
226
227
229 & dtunit1,maa1,ret)
230 print *,ret
231 if (ret .ne. 0 ) then
232 print *,'Erreur à la création du champ : ', nomcha2
233 call efexit(-1)
234 endif
235
236
237 call mlnliw(fid,maa2,lien_maa2,ret)
238 print *,ret
239 if (ret .ne. 0 ) then
240 print *,'Erreur à la création du lien : ', lien_maa2
241 call efexit(-1)
242 endif
243
244
245
246 call mlclow(fid,gauss1_1,med_tria6,2,refcoo1,user_interlace,
247 & ngauss1_1,gscoo1_1, wg1_1,med_no_interpolation,
248 & med_no_mesh_support, ret)
249 print *,ret
250 if (ret .ne. 0 ) then
251 print *,'Erreur à la création du modèle n°1 : ', gauss1_1
252 call efexit(-1)
253 endif
254
255
256 call mlclow(fid,gauss1_2,med_tria6,2,refcoo1,user_interlace,
257 & ngauss1_2,gscoo1_2, wg1_2,med_no_interpolation,
258 & med_no_mesh_support, ret)
259 print *,ret
260 if (ret .ne. 0 ) then
261 print *,'Erreur à la création du modèle n°2 : ', gauss1_2
262 call efexit(-1)
263 endif
264
265
266
267
268
269 dt = 0.0
270 call mfdrpw(fid,nomcha1,med_no_dt,med_no_it,dt,med_cell,
271 & med_tria6,user_mode,med_allentities_profile,
272 & gauss1_1,user_interlace,2,nent1_1,valr1_1,ret)
273 print *,ret
274 if (ret .ne. 0 ) then
275 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.1'
276 call efexit(-1)
277 endif
278
279
280
281
282 call mfdrpw(fid,nomcha1,med_no_dt,med_no_it,dt,med_cell,
283 & med_tria6,user_mode,med_allentities_profile,
284 & gauss1_1,user_interlace,1,nent1_1,valr1_1,ret)
285 print *,ret
286 if (ret .ne. 0 ) then
287 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.2'
288 call efexit(-1)
289 endif
290
291
292
293
294
295
296 dt = 5.5
297 call mfdrpw(fid,nomcha1,1,med_no_it,dt,med_cell,med_tria6,
298 & user_mode,med_allentities_profile,gauss1_2,
299 & user_interlace,1,nent1_2,valr1_2,ret)
300 print *,ret
301 if (ret .ne. 0 ) then
302 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.3'
303 call efexit(-1)
304 endif
305
306
307
308
309
310
311 call mfdrpw(fid,nomcha1,1,med_no_it,dt,med_cell,med_tria6,
312 & user_mode,med_allentities_profile,gauss1_2,
313 & user_interlace,2,nent1_2,valr1_2,ret)
314 print *,ret
315 if (ret .ne. 0 ) then
316 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.4'
317 call efexit(-1)
318 endif
319
320
321
322
323
324
325 call mfdrpw(fid,nomcha1,1,2,dt,med_cell,med_tria6,
326 & user_mode,med_allentities_profile,gauss1_1,
327 & user_interlace,1,nent1_1,valr1_1,ret)
328 print *,ret
329 if (ret .ne. 0 ) then
330 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.5'
331 call efexit(-1)
332 endif
333
334
335
336 call mpfprw(fid,nomprofil1,1,profil1,ret)
337 print *,ret
338 if (ret .ne. 0 ) then
339 print *,'Erreur à la création du profil : ', nomprofil1
340 call efexit(-1)
341 endif
342
343
344
345
346
347
348
349 dt = 5.6
350 call mfdrpw(fid,nomcha1,2,2,dt,med_cell,med_tria6,
351 & user_mode, nomprofil1, med_no_localization,
352 & user_interlace,med_all_constituent,
353 & nval1_3,valr1_3p,ret)
354 print *,ret
355 if (ret .ne. 0 ) then
356 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.6'
357 call efexit(-1)
358 endif
359
360
361
362
363
364
365 call mfdrpw(fid,nomcha1,2,2,dt,med_cell,med_tria6,
366 & user_mode, nomprofil1, gauss1_2,
367 & user_interlace,med_all_constituent,
368 & nent1_2,valr1_2p,ret)
369 print *,ret
370 if (ret .ne. 0 ) then
371 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.7'
372 call efexit(-1)
373 endif
374
375
376
377
378
379
380
381 dt = 5.7
382 call mfdrpw(fid,nomcha1,3,2,dt,med_cell,med_tria6,
383 & user_mode, nomprofil1, med_no_localization,
384 & user_interlace,2,
385 & nent1_3,valr1_3p,ret)
386 print *,ret
387 if (ret .ne. 0 ) then
388 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8a'
389 call efexit(-1)
390 endif
391
392
393
394
395
396
397 dt = 5.7
398 call mfdrpw(fid,nomcha1,3,2,dt,med_cell,med_tria6,
399 & user_mode, nomprofil1, med_no_localization,
400 & user_interlace,1,
401 & nent1_3,valr1_3p,ret)
402 print *,ret
403 if (ret .ne. 0 ) then
404 print *,'Erreur à l''écriture du champ : ', nomcha1,'et.8b'
405 call efexit(-1)
406 endif
407
408
409
410
411
412 dt = 0.0
413 call mfdivw(fid,nomcha2,med_no_dt,med_no_it,dt,
414 & med_descending_edge,med_seg2,user_interlace,
415 & 1,nval2,valr2,ret)
416 print *,ret
417 if (ret .ne. 0 ) then
418 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.1'
419 call efexit(-1)
420 endif
421
422
423
424
425
426
427 call mfdivw(fid,nomcha2,med_no_dt,med_no_it,dt,
428 & med_node,med_none,user_interlace,
429 & 2,nval2,valr2,ret)
430 print *,ret
431 if (ret .ne. 0 ) then
432 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.2'
433 call efexit(-1)
434 endif
435
436
437
438
439
440
441
442 call mfdivw(fid,nomcha2,med_no_dt,med_no_it,dt,
443 & med_descending_face,med_tria6,user_interlace,
444 & 3,nval2,valr2,ret)
445 print *,ret
446 if (ret .ne. 0 ) then
447 print *,'Erreur à l''écriture du champ : ', nomcha2,'et.3'
448 call efexit(-1)
449 endif
450
451
452
453 call mpfprw(fid,
"PROFIL(champ2)",3,profil2,ret)
454 print *,ret
455 if (ret .ne. 0 ) then
456 print *,'Erreur à l''écriture du profil : ',
457 1 'profil2(champ2)'
458 call efexit(-1)
459 endif
460
461
462
463
464
465
466
467
468 call mfdipw(fid,nomcha2,med_no_dt,med_no_it,dt,
469 & med_cell,med_tria6,user_mode,"PROFIL(champ2)",
470 & med_no_localization,user_interlace,3,
471 & nval2,valr2p,ret)
472 print *,ret
473 if (ret .ne. 0 ) then
474 print *,'Erreur à l''écriture du profil : ',
475 1 'profil2(champ2)'
476 call efexit(-1)
477 endif
478
479
481 & dtunit1,maa1,ret)
482 print *,ret
483 if (ret .ne. 0 ) then
484 print *,'Erreur à la création du champ : ', nomcha3
485 call efexit(-1)
486 endif
487
488
489
490
491
492
493 call mfdivw(fid,nomcha3,med_no_dt,med_no_it,dt,
494 & med_cell,med_quad4,user_interlace,
495 & 1,nval3,valr3,ret)
496 print *,ret
497 if (ret .ne. 0 ) then
498 print *,'Erreur à l''écriture du champ : ', nomcha3,'et.1'
499 call efexit(-1)
500 endif
501
502
503
504
505
506
507 call mfdivw(fid,nomcha3,med_no_dt,med_no_it,dt,
508 & med_node_element,med_quad4,user_interlace,
509 & med_all_constituent,nent3,valr3,ret)
510 print *,ret
511 if (ret .ne. 0 ) then
512 print *,'Erreur à l''écriture du champ : ', nomcha3,'et.2'
513 call efexit(-1)
514 endif
515
516
517
518
519
520
521
522
523
524
525
526 call mfdipw(fid,nomcha3,med_no_dt,med_no_it,dt,
527 & med_node_element,med_quad4,user_mode,
528 & "PROFIL(champ2)",med_no_localization,
529 & user_interlace,med_all_constituent,
530 & nent3,valr3p,ret)
531 print *,ret
532 if (ret .ne. 0 ) then
533 print *,'Erreur à l''écriture du profil : ',
534 1 'profil2(champ2)'
535 call efexit(-1)
536 endif
537
538
540 if (ret .ne. 0 ) then
541 print *,'Erreur à la fermeture du fichier : '
542 ret = -1
543 endif
544
545 print *,"Le code retour : ",ret
546 call efexit(ret)
547
548 end
549
550
551
subroutine mfdcre(fid, fname, ftype, ncomp, cname, cunit, dtunit, mname, cret)
Cette fonction crée un champ dans un fichier.
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
subroutine mfivop(fid, name, access, major, minor, rel, cret)
Ouverture d'un fichier MED en indiquant la version du modèle à utiliser en cas de création d'un nouve...
subroutine mlnliw(fid, mname, lname, cret)
Cette routine permet d'écrire un lien dans un fichier MED.
subroutine mmhcre(fid, name, sdim, mdim, mtype, desc, dtunit, stype, atype, aname, aunit, cret)
Cette routine permet de créer un maillage dans un fichier.
subroutine mfdrpw(fid, fname, numdt, numit, dt, etype, gtype, stm, pname, lname, swm, cs, n, val, cret)
subroutine mfdipw(fid, fname, numdt, numit, dt, etype, gtype, stm, pname, lname, swm, cs, n, val, cret)
subroutine mfdivw(fid, fname, numdt, numit, dt, etype, gtype, swm, cs, n, val, cret)
subroutine mlclow(fid, lname, gtype, sdim, ecoo, swm, nip, ipcoo, wght, giname, isname, cret)
subroutine mpfprw(fid, pname, psize, profil, cret)