34 character (MED_NAME_SIZE) mname
35 character (MED_NAME_SIZE) fname
36 character (MED_COMMENT_SIZE) cmt1,mdesc
39 character (MED_SNAME_SIZE) axname(2)
41 character (MED_SNAME_SIZE) unname(2)
43 integer nnodes, ntria3, nquad4
51 character (MED_NAME_SIZE) prof1n
59 character (MED_NAME_SIZE) prof2n
65 parameter(fname =
"UsesCase_MEDmesh_6.med")
66 parameter(cmt1 =
"A 2D unstructured mesh : 15 nodes, 12 cells")
67 parameter(mdesc =
"A 2D unstructured mesh")
68 parameter(mname=
"2D unstructured mesh")
69 parameter(sdim=2, mdim=2)
70 parameter(nnodes=15,ntria3=8,nquad4=4)
72 data axname /
"x",
"y"/
73 data unname /
"cm",
"cm"/
74 data inicoo /2.,1., 7.,1., 12.,1., 17.,1., 22.,1.,
75 & 2.,6., 7.,6., 12.,6., 17.,6., 22.,6.,
76 & 2.,11.,7.,11.,12.,11.,17.,11., 22.,11./
77 data triacy /1,7,6, 2,7,1, 3,7,2, 8,7,3,
78 & 13,7,8, 12,7,13, 11,7,12, 6,7,11/
79 data quadcy /3,4,9,8, 4,5,10,9,
80 & 15,14,9,10, 13,8,9,14/
83 data nwcos1 /12.,15., 17.,15., 22.,15./
84 parameter(prof1n=
"UPPER_QUAD4_PROFILE")
85 data profi1 /13, 14, 15/
89 data nwcos2 /12.,10., 17.,10., 22.,10./
90 parameter(prof2n=
"MIDDLE_QUAD4_PROFILE")
91 data profi2 /8, 9, 10/
95 call mfiope(fid,fname,med_acc_creat,cret)
96 if (cret .ne. 0 )
then 97 print *,
"ERROR : file creation" 102 call mficow(fid,cmt1,cret)
103 if (cret .ne. 0 )
then 104 print *,
"ERROR : write file description" 109 call mpfprw(fid,prof1n,pro1sz,profi1,cret)
110 if (cret .ne. 0 )
then 111 print *,
"ERROR : create profile" 116 call mpfprw(fid,prof2n,pro2sz,profi2,cret)
117 if (cret .ne. 0 )
then 118 print *,
"ERROR : create profile" 123 call mmhcre(fid, mname, sdim, mdim, med_unstructured_mesh, mdesc,
124 &
"", med_sort_dtit, med_cartesian, axname, unname, cret)
125 if (cret .ne. 0 )
then 126 print *,
"ERROR : mesh creation" 133 call mmhcpw(fid, mname, med_no_dt, med_no_it, 0.0d0,
134 & med_compact_stmode, med_no_profile,
135 & med_full_interlace, med_all_constituent,
136 & nnodes, inicoo, cret)
137 if (cret .ne. 0 )
then 138 print *,
"ERROR : nodes coordinates" 144 call mmhypw(fid, mname, med_no_dt, med_no_it, 0.0d0,
145 & med_cell, med_tria3, med_nodal,
146 & med_compact_stmode, med_no_profile,
147 & med_full_interlace, med_all_constituent,
148 & ntria3, triacy, cret)
149 if (cret .ne. 0 )
then 150 print *,
"ERROR : triangular cells connectivity" 155 call mmhypw(fid, mname, med_no_dt, med_no_it, 0.0d0,
156 & med_cell, med_quad4, med_nodal,
157 & med_compact_stmode, med_no_profile,
158 & med_full_interlace, med_all_constituent,
159 & nquad4, quadcy, cret)
160 if (cret .ne. 0 )
then 161 print *,
"ERROR : quadrangular cells connectivity" 170 call mmhcpw(fid, mname, 1, 1, 5.5d0,
171 & med_compact_stmode, prof1n,
172 & med_full_interlace, med_all_constituent,
173 & nnodes, nwcos1, cret)
174 if (cret .ne. 0 )
then 175 print *,
"ERROR : nodes coordinates" 181 call mmhcpw(fid, mname, 2, 1, 8.9d0,
182 & med_compact_stmode, prof2n,
183 & med_full_interlace, med_all_constituent,
184 & nnodes, nwcos2, cret)
185 if (cret .ne. 0 )
then 186 print *,
"ERROR : nodes coordinates" 192 call mfacre(fid, mname,med_no_name, 0, 0, med_no_group, cret)
193 if (cret .ne. 0 )
then 194 print *,
"ERROR : create family 0" 201 if (cret .ne. 0 )
then 202 print *,
"ERROR : close file" program usescase_medmesh_6
subroutine mficlo(fid, cret)
subroutine mficow(fid, cmt, cret)
subroutine mmhcpw(fid, name, numdt, numit, dt, stm, pname, swm, dim, n, coo, cret)
subroutine mpfprw(fid, pname, psize, profil, 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 mfacre(fid, name, fname, fnum, ngro, gname, cret)
subroutine mfiope(fid, name, access, cret)