MED fichier
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 
med_int32
int32_t med_int32
Definition: med.h:329
med_float64
double med_float64
Definition: med.h:323
test10
program test10
Definition: test10.f:24