MED fichier
f/test34.f
1 C* This file is part of MED.
2 C*
3 C* COPYRIGHT (C) 1999 - 2025 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 : test34.f
20 C *
21 C * - Description : Tests d'existences des descriptions des objets med ayant
22 C * créés une description par l'API de création de l'objet
23 C *
24 C ******************************************************************************
25  program test34
26 C
27  implicit none
28  include 'med.hf'
29 C
30  integer*8 fid
31  integer ret,USER_INTERLACE,USER_MODE
32  integer FTYPECHA
33  real*8 a,b,p1,p2,dt
34 
35  character*64 maa1,maa2,maa3
36  character*13 lien_maa2
37  character*16 nomcoo(3)
38  character*16 unicoo(3)
39 C CHAMP N°1
40  character*64 nomcha1
41  character*16 comp1(2), unit1(2)
42  character*16 dtunit1, nounit
43  integer ncomp1
44 C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
45  integer ngauss1_1
46  character*64 gauss1_1
47  real*8 refcoo1(12), gscoo1_1(12), wg1_1(6)
48  integer nval1_1, nent1_1
49  real*8 valr1_1(1*6*2)
50 C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
51  integer ngauss1_2
52  character*64 gauss1_2
53  real*8 gscoo1_2(6), wg1_2(3)
54  integer nval1_2, nent1_2
55  real*8 valr1_2(2*3*2)
56  real*8 valr1_2p(2*3)
57 C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
58  integer ngauss1_3,nval1_3, nent1_3
59  real*8 valr1_3(2*3*2)
60  real*8 valr1_3p(2*2)
61 
62 C CHAMP N°2
63  character*64 nomcha2
64  character*16 comp2(3), unit2(3)
65  integer ncomp2, nval2
66  integer valr2(5*3), valr2p(3*3)
67 
68 C CHAMP N°3
69  character*64 nomcha3
70  character*16 comp3(2), unit3(2)
71  integer ncomp3, nval3, nent3
72  integer valr3(5*4*2), valr3p(3*4*2)
73 
74 C PROFILS UTILISES
75  character*64 nomprofil1
76  integer profil1(2) , profil2(3)
77 
78 C DESCRIPTIONS UTILISES
79  character*200 des0,des1,des2
80 
81  integer oexist, dexist
82 
83 C MAILLAGE SUPPORT
84  character*64 smname1
85  integer sdim1,mdim1
86  parameter(sdim1=2, mdim1=2)
87  parameter(smname1 = "supportMesh1")
88 
89 C ELEMENT DE STRUCTURE
90  integer mtype1
91 
92  parameter( a=0.446948490915965d0, b=0.091576213509771d0 )
93  parameter( p1=0.11169079483905d0, p2=0.0549758718227661d0 )
94 C MAILLAGES
95  parameter( maa1 = "maa1", maa2 = "maa2", maa3 = "maa3" )
96  parameter( lien_maa2= "./testfoo.med" )
97 C CHAMP N°1
98  parameter( nomcha1 = "champ reel" )
99  parameter( ncomp1 = 2 )
100  parameter( dtunit1 = " ")
101  parameter( nounit = " ")
102 C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
103  parameter( gauss1_1 = "Model n1" )
104  parameter( ngauss1_1 = 6 )
105 C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
106  parameter( gauss1_2 = "Model n2" )
107  parameter( ngauss1_2 = 3 )
108 C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
109  parameter( ngauss1_3 = 6 )
110  parameter( nval1_3 = 6 )
111 C CHAMP N°2
112  parameter( nomcha2="champ entier")
113  parameter( ncomp2 = 3, nval2= 5 )
114 C CHAMP N°3
115  parameter( nomcha3="champ entier 3")
116  parameter( ncomp3 = 2, nval3= 5*4 )
117 C PROFILS
118  parameter( nomprofil1 = "PROFIL(champ(1))" )
119 
120 C CHAMP N°1
121  data comp1 /"comp1", "comp2"/
122  data unit1 /"unit1","unit2"/
123 C MODEL N°1 DE LOC. DES PTS DE GAUSS PR CHAMP1
124  data nval1_1 / 1*6 /
125  data nent1_1 / 1 /
126  data refcoo1 / -1.0,1.0, -1.0,-1.0, 1.0,-1.0, -1.0,0.0,
127  1 0.0,-1.0, 0.0,0.0 /
128  data valr1_1 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
129  1 20.0,21.0, 22.0,23.0/
130 C MODEL N°2 DE LOC. DES PTS DE GAUSS PR CHAMP1
131  data nent1_2 / 2 /
132  data valr1_2 / 0.0,1.0, 2.0,3.0, 10.0,11.0,
133  1 12.0,13.0, 20.0,21.0, 22.0,23.0 /
134  data valr1_2p / 12.0,13.0, 20.0,21.0, 22.0,23.0 /
135 C MODEL N°3 DE LOC. DES PTS DE GAUSS PR CHAMP1
136  data nent1_3 / 6 /
137  data valr1_3 / 0.0,1.0, 2.0,3.0, 10.0,11.0, 12.0,13.0,
138  1 20.0,21.0, 22.0,23.0 /
139  data valr1_3p / 2.0,3.0, 10.0,11.0 /
140 C CHAMP N°2
141  data comp2 /"comp1", "comp2", "comp3"/
142  data unit2 /"unit1","unit2", "unit3"/
143  data valr2 / 0,1,2, 10,11,12, 20,21,22, 30,31,32, 40,41,42 /
144  data valr2p / 0,1,2, 20,21,22, 40,41,42 /
145 C CHAMP N°3
146  data nent3 / 5 /
147  data comp3 /"comp1", "comp2"/
148  data unit3 /"unit1","unit2"/
149  data valr3 / 0,1, 10,11, 20,21, 30,31,
150  1 40,41, 50,51, 60,61, 70,71,
151  1 80,81, 90,91, 100,101, 110,111,
152  1 120,121, 130,131, 140,141, 150,151,
153  1 160,161, 170,171, 180,181, 190,191 /
154  data valr3p / 0,1, 10,11, 20,21, 30,31,
155  1 80,81, 90,91, 100,101, 110,111,
156  1 160,161, 170,171, 180,181, 190,191 /
157 
158 
159 C PROFILS
160  data profil1 /2,3/
161  data profil2 /1,3,5/
162 
163  data nomcoo /"x","y","z"/, unicoo /"cm","cm","cm"/
164 
165  ret = 0
166 
167  gscoo1_1(1) = 2*b-1
168  gscoo1_1(2) = 1-4*b
169  gscoo1_1(3) = 2*b-1
170  gscoo1_1(4) = 2*b-1
171  gscoo1_1(5) = 1-4*b
172  gscoo1_1(6) = 2*b-1
173  gscoo1_1(7) = 1-4*a
174  gscoo1_1(8) = 2*a-1
175  gscoo1_1(9) = 2*a-1
176  gscoo1_1(10) = 1-4*a
177  gscoo1_1(11) = 2*a-1
178  gscoo1_1(12) = 2*a-1
179 
180  wg1_1(1) = 4*p2
181  wg1_1(2) = 4*p2
182  wg1_1(3) = 4*p2
183  wg1_1(4) = 4*p1
184  wg1_1(5) = 4*p1
185  wg1_1(6) = 4*p1
186 
187  nval1_2 = 2*3
188  gscoo1_2(1) = -2.0d0/3
189  gscoo1_2(2) = 1.0d0/3
190  gscoo1_2(3) = -2.0d0/3
191  gscoo1_2(4) = -2.0d0/3
192  gscoo1_2(5) = 1.0d0/3
193  gscoo1_2(6) = -2.0d0/3
194 
195  wg1_2(1) = 2.0d0/3
196  wg1_2(2) = 2.0d0/3
197  wg1_2(3) = 2.0d0/3
198 
199  des0 = "un maillage pour test34"
200  des1 = "++UN MAILLAGE POUR TEST34++"
201  des2 = ""
202 
203 C ** ouverture du fichier **
204  call mfiope(fid,'test34.med', med_acc_rdwr, ret)
205  print *,ret
206  if (ret .ne. 0 ) then
207  print *,'Erreur à l''ouverture du fichier : ','test34.med'
208  call efexit(-1)
209  endif
210 
211 
212 C ** Si le fichier test34.med a déjà été généré par test34 **
213  call mfioex(fid, med_mesh, maa1, oexist, ret)
214  print *,ret
215  if (ret .ne. 0 ) then
216  print *,'Erreur inattendue de test d''existence du maillage'
217  endif
218  print *,"Maillage maa1 existe : ",oexist
219  if (oexist .eq. med_true) then
220  call mfiodx(fid, med_mesh, maa1, dexist, ret)
221  if (ret .ne. 0 ) then
222  print *,'Erreur inattendue de test d''existence d''une',
223  & ' description maillage'
224  endif
225  if (dexist .eq. med_false) then
226  print *,'Erreur d''absence anormale de la description',
227  & ' du maillage : ',maa1
228  endif
229  endif
230 
231 C ** creation du maillage maa1 de dimension 3 **
232  call mmhcre(fid,maa1,3,3,
233  & med_unstructured_mesh,des0,
234  & "",med_sort_dtit,med_cartesian,nomcoo,unicoo,ret)
235  print *,ret
236  if (ret .ne. 0 ) then
237  print *,'Erreur à la création du maillage : ', maa1
238  call efexit(-1)
239  endif
240 
241  call mfiodx(fid, med_mesh, maa1, dexist, ret)
242  if (ret .ne. 0 ) then
243  print *,'Erreur inattendue de test d''existence d''une',
244  & ' description maillage'
245  endif
246  if (dexist .ne. med_true) then
247  print *,'Erreur d''absence anormale de la description',
248  & ' du maillage : ',maa1
249  else
250  call mfiodr(fid, med_mesh, maa1, des2, ret)
251  print *,'description2 : ',des2
252  endif
253 
254  call mfiodw(fid, med_mesh, maa1, des1, ret)
255  if (ret .ne. 0 ) then
256  print *,'Erreur inattendue d''écriture de la',
257  & ' description du maillage'
258  endif
259 
260 
261 C ** creation du champ réel n°1 **
262  call mfdcre(fid,nomcha1,med_int,ncomp1,comp1,unit1,
263  & dtunit1,maa1,ret)
264  print *,ret
265  if (ret .ne. 0 ) then
266  print *,'Erreur à la création du champ : ', nomcha1
267  endif
268  des1="un champ pour test34"
269  call mfiodw(fid, med_field, nomcha1, des1, ret)
270  if (ret .ne. 0 ) then
271  print *,'Erreur inattendue d''écriture de la',
272  & ' description de champ',nomcha1
273  endif
274 
275 C ** support mesh creation : 2D
276  call msmcre(fid,smname1,sdim1,mdim1,
277  & 'un maillage support pour test34',
278  & med_cartesian, nomcoo, unicoo, ret)
279  print *,'Support mesh creation : 2D space dimension',ret
280  if (ret .ne. 0 ) then
281  print *,'ERROR : support mesh creation'
282  endif
283 
284  call mfiodx(fid, med_mesh_support, smname1, dexist, ret)
285  if (ret .ne. 0 ) then
286  print *,'Erreur inattendue de test d''existence d''une',
287  & ' description de maillage support'
288  endif
289  if (dexist .ne. med_true) then
290  print *,'Erreur d''absence anormale de la description',
291  & ' du maillage support: ',smname1
292  else
293  call mfiodr(fid, med_mesh_support, smname1, des2, ret)
294  print *,'description2 : ',des2
295  endif
296 
297  call mfiodw(fid, med_mesh_support, smname1,
298  & '++un maillage support pour test34++', ret)
299  if (ret .ne. 0 ) then
300  print *,'Erreur inattendue d''écriture de la',
301  & ' description du maillage support'
302  endif
303 
304 C ** creation d'un modèle d'éléments de structure **
305  call msecre(fid,med_particle_name, 3, med_no_meshname,med_none
306  & ,med_none, mtype1, ret)
307  if (ret .ne. 0 ) then
308  print *,'Erreur inattendue d''écriture de l''',
309  & ' élément de structure'
310  endif
311  call mfiodw(fid, med_elstruct, med_particle_name,
312  & '++un élément de structure pour test34++', ret)
313  if (ret .ne. 0 ) then
314  print *,'Erreur inattendue d''écriture de la',
315  & ' description de l''élément de structure'
316  endif
317 
318 
319 C ** creation de la localisation des points de Gauss modèle n°1 **
320  call mlclow(fid,gauss1_1,med_tria6,2,refcoo1,med_full_interlace,
321  & ngauss1_1,gscoo1_1, wg1_1,med_no_interpolation,
322  & med_no_mesh_support, ret)
323  print *,ret
324  if (ret .ne. 0 ) then
325  print *,'Erreur à la création du modèle n°1 : ', gauss1_1
326  call efexit(-1)
327  endif
328  des1="une localisation de points d'intégration pour test34"
329  call mfiodw(fid, med_localization, gauss1_1,
330  & des1, ret)
331  if (ret .ne. 0 ) then
332  print *,'Erreur inattendue d''écriture de la',
333  & ' description de la localisation : ',gauss1_1
334  endif
335 
336 
337 C ** Creation de profil
338 C ** - qui selectionne uniquement le 2e element du tableau valr1
339  call mpfprw(fid,nomprofil1,1,profil1,ret)
340  print *,ret
341  if (ret .ne. 0 ) then
342  print *,'Erreur à la création du profil : ', nomprofil1
343  call efexit(-1)
344  endif
345  des1='un profil de champ pour test34'
346  call mfiodw(fid, med_profile, nomprofil1,
347  & des1, ret)
348  if (ret .ne. 0 ) then
349  print *,'Erreur inattendue d''écriture de la',
350  & ' description de profil : ',nomprofil1
351  endif
352 
353 
354 C ** Fermeture du fichier *
355  call mficlo(fid,ret)
356  if (ret .ne. 0 ) then
357  print *,'Erreur à la fermeture du fichier : '
358  ret = -1
359  endif
360 
361  print *,"Le code retour : ",ret
362  call efexit(ret)
363 
364  end
365 
366 
367 
test34
program test34
Definition: test34.f:25
mfdcre
subroutine mfdcre(fid, fname, ftype, ncomp, cname, cunit, dtunit, mname, cret)
Cette fonction crée un champ dans un fichier.
Definition: medfield.f:22
msmcre
subroutine msmcre(fid, maa, sdim, mdim, des, atype, aname, aunit, cret)
Cette routine permet de créer un maillage support.
Definition: medsupport.f:20
med_int
int med_int
Definition: med.h:361
mfiope
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
Definition: medfile.f:42
mfioex
subroutine mfioex(fid, class, oname, oexist, cret)
Interroge le fichier fid pour tester l'existence de l'objet objectname de type med_class.
Definition: medfile.f:227
mfiodr
subroutine mfiodr(fid, class, oname, desc, cret)
Lit une description associée à l'objet objectname de type med_class dans le fichier fid .
Definition: medfile.f:276
mfiodx
subroutine mfiodx(fid, class, oname, dexist, cret)
Interroge le fichier fid pour tester l'existence d'une description associée à l'objet objectname de t...
Definition: medfile.f:243
mfiodw
subroutine mfiodw(fid, class, oname, desc, cret)
Ecrit une description associée à l'objet objectname de type med_class dans le fichier fid .
Definition: medfile.f:259
mpfprw
subroutine mpfprw(fid, pname, psize, profil, cret)
Cette routine permet d'écrire un profil dans un fichier MED.
Definition: medprofile.f:21
mlclow
subroutine mlclow(fid, lname, gtype, sdim, ecoo, swm, nip, ipcoo, wght, giname, isname, cret)
Cette routine permet l'écriture d'une localisation localizationname de points d'intégration dans/auto...
Definition: medlocalization.f:22
mmhcre
subroutine mmhcre(fid, name, sdim, mdim, mtype, desc, dtunit, stype, atype, aname, aunit, cret)
Cette routine permet de créer un maillage dans un fichier.
Definition: medmesh.f:20
msecre
subroutine msecre(fid, mname, mdim, smname, setype, sgtype, etype, cret)
Cette routine permet de créer un nouveau modèle d'éléments de structure dans un fichier MED.
Definition: medstructelement.f:20
mficlo
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
Definition: medfile.f:82
Généré le Jeudi 6 Novembre 2025 14:24:56 pour MED fichier par   doxygen 1.8.16