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" subroutine mmhcre(fid, name, sdim, mdim, mtype, desc, dtunit, stype, atype, aname, aunit, cret)
subroutine mfiope(fid, name, access, cret)
subroutine mficlo(fid, cret)
program usescase_medmesh_6
subroutine mficow(fid, cmt, cret)
subroutine mpfprw(fid, pname, psize, profil, cret)
subroutine mmhcpw(fid, name, numdt, numit, dt, stm, pname, swm, dim, n, coo, cret)
subroutine mfacre(fid, name, fname, fnum, ngro, gname, cret)
subroutine mmhypw(fid, name, numdt, numit, dt, entype, geotype, cmode, stmode, pname, swm, dim, n, con, cret)