1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
26
27 implicit none
28 include 'med.hf77'
29
30
31 integer cret
32 integer*8 fid
33
34
35 character (MED_NAME_SIZE) mname
36 character (MED_NAME_SIZE) fname
37 character (MED_COMMENT_SIZE) cmt1,mdesc
38 integer sdim, mdim
39
40 character (MED_SNAME_SIZE) axname(2)
41
42 character (MED_SNAME_SIZE) unname(2)
43 real*8 inicoo(30)
44 integer nnodes, ntria3, nquad4
45
46 integer triacy(24)
47
48 integer quadcy(16)
49
50 real*8 nwcos1(6)
51
52 character (MED_NAME_SIZE) prof1n
53
54 integer profi1(3)
55
56 integer pro1sz
57
58 real*8 nwcos2(6)
59
60 character (MED_NAME_SIZE) prof2n
61
62 integer profi2(3)
63
64 integer pro2sz
65
66 parameter(fname = "UsesCase_MEDmesh_6.med")
67 parameter(cmt1 = "A 2D unstructured mesh : 15 nodes, 12 cells")
68 parameter(mdesc = "A 2D unstructured mesh")
69 parameter(mname="2D unstructured mesh")
70 parameter(sdim=2, mdim=2)
71 parameter(nnodes=15,ntria3=8,nquad4=4)
72
73 data axname /"x", "y"/
74 data unname /"cm", "cm"/
75 data inicoo /2.,1., 7.,1., 12.,1., 17.,1., 22.,1.,
76 & 2.,6., 7.,6., 12.,6., 17.,6., 22.,6.,
77 & 2.,11.,7.,11.,12.,11.,17.,11., 22.,11./
78 data triacy /1,7,6, 2,7,1, 3,7,2, 8,7,3,
79 & 13,7,8, 12,7,13, 11,7,12, 6,7,11/
80 data quadcy /3,4,9,8, 4,5,10,9,
81 & 15,14,9,10, 13,8,9,14/
82
83
84 data nwcos1 /12.,15., 17.,15., 22.,15./
85 parameter(prof1n="UPPER_QUAD4_PROFILE")
86 data profi1 /13, 14, 15/
87 parameter(pro1sz=3)
88
89
90 data nwcos2 /12.,10., 17.,10., 22.,10./
91 parameter(prof2n="MIDDLE_QUAD4_PROFILE")
92 data profi2 /8, 9, 10/
93 parameter(pro2sz=3)
94
95
96 call mfiope(fid,fname,med_acc_creat,cret)
97 if (cret .ne. 0 ) then
98 print *,"ERROR : file creation"
99 call efexit(-1)
100 endif
101
102
103 call mficow(fid,cmt1,cret)
104 if (cret .ne. 0 ) then
105 print *,"ERROR : write file description"
106 call efexit(-1)
107 endif
108
109
110 call mpfprw(fid,prof1n,pro1sz,profi1,cret)
111 if (cret .ne. 0 ) then
112 print *,"ERROR : create profile"
113 call efexit(-1)
114 endif
115
116
117 call mpfprw(fid,prof2n,pro2sz,profi2,cret)
118 if (cret .ne. 0 ) then
119 print *,"ERROR : create profile"
120 call efexit(-1)
121 endif
122
123
124 call mmhcre(fid, mname, sdim, mdim, med_unstructured_mesh, mdesc,
125 & "", med_sort_dtit, med_cartesian, axname, unname, cret)
126 if (cret .ne. 0 ) then
127 print *,"ERROR : mesh creation"
128 call efexit(-1)
129 endif
130
131
132
133
134 call mmhcpw(fid, mname, med_no_dt, med_no_it, 0.0d0,
135 & med_compact_stmode, med_no_profile,
136 & med_full_interlace, med_all_constituent,
137 & nnodes, inicoo, cret)
138 if (cret .ne. 0 ) then
139 print *,"ERROR : nodes coordinates"
140 call efexit(-1)
141 endif
142
143
144
145 call mmhypw(fid, mname, med_no_dt, med_no_it, 0.0d0,
146 & med_cell, med_tria3, med_nodal,
147 & med_compact_stmode, med_no_profile,
148 & med_full_interlace, med_all_constituent,
149 & ntria3, triacy, cret)
150 if (cret .ne. 0 ) then
151 print *,"ERROR : triangular cells connectivity"
152 call efexit(-1)
153 endif
154
155
156 call mmhypw(fid, mname, med_no_dt, med_no_it, 0.0d0,
157 & med_cell, med_quad4, med_nodal,
158 & med_compact_stmode, med_no_profile,
159 & med_full_interlace, med_all_constituent,
160 & nquad4, quadcy, cret)
161 if (cret .ne. 0 ) then
162 print *,"ERROR : quadrangular cells connectivity"
163 call efexit(-1)
164 endif
165
166
167
168
169
170
171 call mmhcpw(fid, mname, 1, 1, 5.5d0,
172 & med_compact_stmode, prof1n,
173 & med_full_interlace, med_all_constituent,
174 & nnodes, nwcos1, cret)
175 if (cret .ne. 0 ) then
176 print *,"ERROR : nodes coordinates"
177 call efexit(-1)
178 endif
179
180
181
182 call mmhcpw(fid, mname, 2, 1, 8.9d0,
183 & med_compact_stmode, prof2n,
184 & med_full_interlace, med_all_constituent,
185 & nnodes, nwcos2, cret)
186 if (cret .ne. 0 ) then
187 print *,"ERROR : nodes coordinates"
188 call efexit(-1)
189 endif
190
191
192
193 call mfacre(fid, mname,med_no_name, 0, 0, med_no_group, cret)
194 if (cret .ne. 0 ) then
195 print *,"ERROR : create family 0"
196 call efexit(-1)
197 endif
198
199
200
202 if (cret .ne. 0 ) then
203 print *,"ERROR : close file"
204 call efexit(-1)
205 endif
206
207
208 end
209
program usescase_medmesh_6
subroutine mfacre(fid, name, fname, fnum, ngro, gname, cret)
Cette routine permet la création d'une famille portant sur les entités d'un maillage.
subroutine mfiope(fid, name, access, cret)
Ouverture d'un fichier MED.
subroutine mficow(fid, cmt, cret)
Ecriture d'un descripteur dans un fichier MED.
subroutine mficlo(fid, cret)
Fermeture d'un fichier MED.
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.
subroutine mmhcpw(fid, name, numdt, numit, dt, stm, pname, swm, dim, n, coo, cret)
subroutine mmhypw(fid, name, numdt, numit, dt, entype, geotype, cmode, stmode, pname, swm, dim, n, con, cret)
subroutine mpfprw(fid, pname, psize, profil, cret)