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