35 character (MED_NAME_SIZE) mname
36 character (MED_NAME_SIZE) fname
37 character (MED_COMMENT_SIZE) cmt1,mdesc
40 character (MED_SNAME_SIZE) axname(2)
42 character (MED_SNAME_SIZE) unname(2)
44 integer nnodes, ntria3, nquad4
52 character (MED_NAME_SIZE) prof1n
60 character (MED_NAME_SIZE) prof2n
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)
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/
84 data nwcos1 /12.,15., 17.,15., 22.,15./
85 parameter(prof1n=
"UPPER_QUAD4_PROFILE")
86 data profi1 /13, 14, 15/
90 data nwcos2 /12.,10., 17.,10., 22.,10./
91 parameter(prof2n=
"MIDDLE_QUAD4_PROFILE")
92 data profi2 /8, 9, 10/
96 call mfiope(fid,fname,med_acc_creat,cret)
97 if (cret .ne. 0 )
then
98 print *,
"ERROR : file creation"
103 call mficow(fid,cmt1,cret)
104 if (cret .ne. 0 )
then
105 print *,
"ERROR : write file description"
110 call mpfprw(fid,prof1n,pro1sz,profi1,cret)
111 if (cret .ne. 0 )
then
112 print *,
"ERROR : create profile"
117 call mpfprw(fid,prof2n,pro2sz,profi2,cret)
118 if (cret .ne. 0 )
then
119 print *,
"ERROR : create profile"
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"
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"
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"
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"
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"
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"
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"
202 if (cret .ne. 0 )
then
203 print *,
"ERROR : close file"
program usescase_medmesh_6
subroutine mfacre(fid, name, fname, fnum, ngro, gname, cret)
subroutine mfiope(fid, name, access, cret)
subroutine mficow(fid, cmt, cret)
subroutine mficlo(fid, cret)
subroutine mmhcpw(fid, name, numdt, numit, dt, stm, pname, swm, dim, n, coo, cret)
subroutine mmhcre(fid, name, sdim, mdim, mtype, desc, dtunit, stype, atype, aname, aunit, 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)