1
2
3
4
5
6
7
8
9
10
11
12
13 #define ERROR(rval) if (0 .ne. rval) call exit(1)
14
15 program pushparmeshintomoab
16
17 use iso_c_binding
18 implicit none
19
20 #include "moab/MOABConfig.h"
21 #ifdef MOAB_HAVE_MPI
22 # include "mpif.h"
23 # include "iMeshP_f.h"
24 #else
25 # include "iMesh_f.h"
26 #endif
27
28
29
30 imesh_instance imesh
31
32
33 integer numv, nume, nvpere
34 parameter(numv = 8)
35 parameter(nume = 6)
36 parameter(nvpere = 4)
37
38 ibase_entityhandle, pointer :: ents(:), verts(:)
39 ibase_entitysethandle root_set
40 TYPE(c_ptr) :: vertsptr, entsptr
41
42 real*8 coords(0:3*numv-1)
43 integer iconn(0:4*nume-1), gids(0:numv-1)
44
45
46 integer lgids(0:numv-1), lconn(0:4*nume-1)
47 real*8 lcoords(0:3*numv-1)
48 integer lnumv, lvids(0:numv-1), gvids(0:numv-1)
49 integer lvpe, ltp
50 integer ic, ie, iv, istart, iend, ierr, indv, lnume, rank, sz
51
52 #ifdef MOAB_HAVE_MPI
53
54 imeshp_partitionhandle imeshp
55
56 #endif
57
58
59
60 data coords / &
61 -1., -1., -1, 1., -1., -1., 1., 1., -1., -1., 1., -1., &
62 -1., -1., 1, 1., -1., 1., 1., 1., 1., -1., 1., 1. /
63
64
65 data iconn / &
66 0, 1, 5, 4, &
67 1, 2, 6, 5, &
68 2, 3, 7, 6, &
69 3, 0, 4, 7, &
70 0, 3, 2, 1, &
71 4, 5, 6, 7 /
72
73 data lvpe /4/
74 data ltp / imesh_quadrilateral /
75
76
77 do iv = 0, numv-1
78 lgids(iv) = iv+1
79 end do
80
81 #ifdef MOAB_HAVE_MPI
82
83 call mpi_init(ierr)
84 call mpi_comm_size(mpi_comm_world, sz, ierr)
85 call mpi_comm_rank(mpi_comm_world, rank, ierr)
86 error(ierr)
87
88 lnume = nume / sz
89 istart = rank * lnume
90 iend = istart + lnume - 1
91 if (rank .eq. sz-1) then
92 iend = nume-1
93 lnume = iend - istart + 1
94 endif
95
96
97
98 do iv = 0, numv-1
99 lvids(iv) = -1
100 end do
101 lnumv = -1
102 do ie = istart, iend
103 do iv = 0, lvpe-1
104 indv = iconn(lvpe*ie + iv)
105 if (lvids(indv) .eq. -1) then
106 lnumv = lnumv + 1
107 do ic = 0, 2
108 lcoords(3*lnumv+ic) = coords(3*indv+ic)
109 end do
110 lvids(indv) = lnumv
111 gvids(lnumv) = 1+indv
112 end if
113 lconn(lvpe*(ie-istart)+iv) = lvids(indv)
114 end do
115 end do
116
117 lnumv = lnumv + 1
118
119
120 imesh = 0
121 imeshp = 0
122 call create_mesh(imesh, imeshp, mpi_comm_world, lnumv, lnume, gvids, lvpe, ltp, lcoords, lconn, &
123 vertsptr, entsptr, ierr)
124 error(ierr)
125 call c_f_pointer(vertsptr, verts, [lnumv])
126 call c_f_pointer(entsptr, ents, [lnume])
127
128
129 call imesh_getrootset(%VAL(imesh), root_set, ierr)
130 error(ierr)
131 iv = 0
132 ie = 0
133 call imeshp_getnumoftypeall(%VAL(imesh), %VAL(imeshp), %VAL(root_set), %VAL(ibase_vertex), iv, ierr)
134 error(ierr)
135 call imeshp_getnumoftypeall(%VAL(imesh), %VAL(imeshp), %VAL(root_set), %VAL(ibase_face), ie, ierr)
136 error(ierr)
137 if (rank .eq. 0) then
138 write(0,*) "Number of vertices = ", iv
139 write(0,*) "Number of entities = ", ie
140 endif
141
142
143
144 call mpi_finalize(ierr)
145 #else
146 write(0, *) "compile with MPI for better experience\n"
147 #endif
148 stop
149 end program pushparmeshintomoab
150
151 #ifdef MOAB_HAVE_MPI
152 subroutine create_mesh( &
153
154 imesh, imeshp, &
155
156 comm, numv, nume, vgids, nvpe, tp, posn, iconn, &
157
158 vertsPtr, entsPtr, ierr)
159
160
161
162
163
164
165
166
167
168 use iso_c_binding
169 implicit none
170
171 # include "iMeshP_f.h"
172 # include "mpif.h"
173
174
175 imesh_instance imesh
176 TYPE(c_ptr) :: vertsptr, entsptr
177 integer numv, nume, nvpe, vgids(0:*), iconn(0:*), ierr, tp
178 real*8 posn(0:*)
179 #ifdef MOAB_HAVE_MPI
180 imeshp_partitionhandle imeshp
181 integer comm
182 #endif
183
184
185 integer comm_sz, comm_rank, numa, numo, iv, ie
186 TYPE(c_ptr) :: statsptr
187 integer, allocatable, target :: stats(:)
188 ibase_taghandle tagh
189 integer i
190 ibase_entityhandle, pointer :: verts(:), ents(:)
191 ibase_entityhandle, allocatable :: conn(:)
192 ibase_entitysethandle root_set
193 ibase_entitysethandle file_set
194 #ifdef MOAB_HAVE_MPI
195 ibase_handle_t mpi_comm_c
196 TYPE(c_ptr) :: partsptr
197 imeshp_parthandle, pointer :: parts(:)
198 imeshp_parthandle part
199 integer partsa, partso
200 character (len=10) filename
201 #endif
202
203
204 if (imesh .eq. 0) then
205 call imesh_newmesh("MOAB", imesh, ierr)
206 end if
207
208 #ifdef MOAB_HAVE_MPI
209 if (imeshp .eq. 0) then
210 call imeshp_getcommunicator(%VAL(imesh), mpi_comm_world, mpi_comm_c, ierr)
211 error(ierr)
212 call imeshp_createpartitionall(%VAL(imesh), %VAL(mpi_comm_c), imeshp, ierr)
213 error(ierr)
214 call imeshp_createpart(%VAL(imesh), %VAL(imeshp), part, ierr)
215 error(ierr)
216 else
217 partsa = 0
218 call imeshp_getlocalparts(%VAL(imesh), %VAL(imeshp), partsptr, partsa, partso, ierr)
219 error(ierr)
220 call c_f_pointer(partsptr, parts, [partso])
221 part = parts(1)
222 end if
223 call mpi_comm_rank(comm, comm_rank, ierr)
224 error(ierr)
225 call mpi_comm_size(comm, comm_sz, ierr)
226 error(ierr)
227 #endif
228
229
230 numa = 0
231 call imesh_createvtxarr(%VAL(imesh), %VAL(numv), %VAL(ibase_interleaved), posn, %VAL(3*numv), &
232 vertsptr, numa, numo, ierr)
233 error(ierr)
234
235
236 allocate (conn(0:nvpe*nume-1))
237 call c_f_pointer(vertsptr, verts, [numv])
238 do i = 0, nvpe*nume-1
239 conn(i) = verts(1+iconn(i))
240 end do
241
242 numa = 0
243 allocate(stats(0:nume-1))
244 statsptr = c_loc(stats(0))
245 call imesh_createentarr(%VAL(imesh), %VAL(tp), conn, %VAL(nvpe*nume), &
246 entsptr, numa, numo, statsptr, numa, numo, ierr)
247 deallocate(stats)
248 deallocate(conn)
249
250 #ifdef MOAB_HAVE_MPI
251
252
253
254 call c_f_pointer(entsptr, ents, [numo])
255 call imesh_addentarrtoset(%VAL(imesh), ents, %VAL(numo), %VAL(part), ierr)
256 error(ierr)
257
258 call imesh_gettaghandle(%VAL(imesh), "GLOBAL_ID", tagh, ierr, %VAL(9))
259 if (ibase_success .ne. ierr) then
260
261 call imesh_createtag(%VAL(imesh), "GLOBAL_ID", %VAL(ibase_integer), tagh, ierr)
262 error(ierr)
263 end if
264 call imesh_setintarrdata(%VAL(imesh), verts, %VAL(numv), %VAL(tagh), vgids, %VAL(numv), ierr)
265 error(ierr)
266
267 call imeshp_syncmeshall(%VAL(imesh), %VAL(imeshp), ierr)
268 error(ierr)
269
270 call imeshp_createghostentsall(%VAL(imesh), %VAL(imeshp), %VAL(2), %VAL(1), %VAL(1), %VAL(0), ierr)
271 error(ierr)
272
273 #endif
274
275 return
276 end subroutine create_mesh
277 #endif