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