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