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