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