1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
25
26 implicit none
27 include 'med.hf77'
28
29
30 integer cret
31 integer*8 fid
32
33
34 integer sdim, mdim
35
36 character*16 axname(2), unname(2)
37
38 character*64 mname, fyname, dtunit, finame
39
40 integer mtype, stype, grtype
41
42 integer fnum, ngro
43
44 character*80 gname
45
46 real*8 coords(30), dt
47 integer nnodes, ntria3, nquad4
48
49 integer tricon(24), quacon(16)
50
51 integer fanbrs(15)
52
53 character*200 cmt1, mdesc
54
55 parameter(sdim = 2, mdim = 2)
56 parameter(mname = "2D unstructured mesh")
57 parameter(fyname = "BOUNDARY_VERTICES")
58 parameter(dtunit = " ")
59 parameter(dt = 0.0d0)
60 parameter(finame = "UsesCase_MEDmesh_10.med")
61 parameter(gname = "MESH_BOUNDARY_VERTICES")
62 parameter(nnodes = 15, ntria3 = 8, nquad4 = 4)
63 parameter(cmt1 ="A 2D unstructured mesh : 15 nodes, 12 cells")
64 parameter(mtype=med_unstructured_mesh, stype=med_sort_dtit )
65 parameter(mdesc = "A 2D unstructured mesh")
66 parameter(grtype=med_cartesian_grid)
67
68 data axname /"x" ,"y" /
69 data unname /"cm","cm"/
70 data coords /2.,1., 7.,1., 12.,1., 17.,1., 22.,1.,
71 & 2.,6., 7.,6., 12.,6., 17.,6., 22.,6.,
72 & 2.,11., 7.,11., 12.,11., 17.,11., 22.,11./
73 data tricon /1,7,6, 2,7,1, 3,7,2, 8,7,3,
74 & 13,7,8, 12,7,13, 11,7,12, 6,7,11/
75 data quacon /3,4,9,8, 4,5,10,9,
76 & 15,14,9,10, 13,8,9,14/
77 data fanbrs /1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1/
78
79
80
81 call mfiope(fid,finame,med_acc_creat,cret)
82 if (cret .ne. 0 ) then
83 print *,'ERROR : file creation'
84 call efexit(-1)
85 endif
86
87
88
90 if (cret .ne. 0 ) then
91 print *,'ERROR : write file description'
92 call efexit(-1)
93 endif
94
95
96
97 call mmhcre(fid, mname, sdim, mdim, mtype, mdesc, dtunit,
98 & stype, grtype, axname, unname, cret)
99 if (cret .ne. 0 ) then
100 print *,'ERROR : mesh creation'
101 call efexit(-1)
102 endif
103
104
105
106
107 call mmhcow(fid,mname,med_no_dt,med_no_it,dt,
108 & med_full_interlace,nnodes,coords,cret)
109 if (cret .ne. 0 ) then
110 print *,'ERROR : write nodes coordinates description'
111 call efexit(-1)
112 endif
113
114
115
116 call mmhcyw(fid,mname,med_no_dt,med_no_it,dt,med_cell,
117 & med_tria3,med_nodal,med_full_interlace,
118 & ntria3,tricon,cret)
119 if (cret .ne. 0 ) then
120 print *,'ERROR : triangular cells connectivity'
121 call efexit(-1)
122 endif
123 call mmhcyw(fid,mname,med_no_dt,med_no_it,dt,med_cell,
124 & med_quad4,med_nodal,med_full_interlace,
125 & nquad4,quacon,cret)
126 if (cret .ne. 0 ) then
127 print *,'ERROR : quadrangular cells connectivity'
128 call efexit(-1)
129 endif
130
131
132
133 call mfacre(fid,mname,med_no_name,0,0,med_no_group,cret)
134 if (cret .ne. 0 ) then
135 print *,'ERROR : create family 0'
136 call efexit(-1)
137 endif
138
139
140
141
142 fnum = 1
143 ngro = 1
144 call mfacre(fid, mname, fyname, fnum, ngro, gname, cret)
145 if (cret .ne. 0 ) then
146 print *,'ERROR : create family 0'
147 call efexit(-1)
148 endif
149
150
151
152 call mmhfnw(fid, mname, med_no_dt, med_no_it, med_node, med_none,
153 & nnodes, fanbrs, cret)
154 if (cret .ne. 0 ) then
155 print *,'ERROR : nodes family numbers ...'
156 call efexit(-1)
157 endif
158
159
160
162 if (cret .ne. 0 ) then
163 print *,'ERROR : close file'
164 call efexit(-1)
165 endif
166
167
168
169 end
170
program usescase_medmesh_10
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 mmhcre(fid, name, sdim, mdim, mtype, desc, dtunit, stype, atype, aname, aunit, cret)
subroutine mmhcyw(fid, name, numdt, numit, dt, entype, geotype, cmode, swm, n, con, cret)
subroutine mmhfnw(fid, name, numdt, numit, entype, geotype, n, num, cret)
subroutine mmhcow(fid, name, numdt, numit, dt, swm, n, coo, cret)