OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25trivox1.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| i25trivox1 ../starter/source/interfaces/inter3d1/i25trivox1.F
25!||--- called by ------------------------------------------------------
26!|| i25buc_vox1 ../starter/source/interfaces/inter3d1/i25buc_vox1.F
27!||--- calls -----------------------------------------------------
28!|| i25sto ../starter/source/interfaces/inter3d1/i25sto.F
29!||--- uses -----------------------------------------------------
30!|| tri7box ../starter/share/modules1/tri7box.F
31!||====================================================================
32 SUBROUTINE i25trivox1(
33 1 NSN ,IRECT ,X ,
34 2 STFN ,XYZM ,NSV ,II_STOK ,
35 3 ESHIFT ,BGAPSMX ,
36 4 VOXEL ,NBX ,NBY ,NBZ ,NRTM ,
37 5 GAP_S ,GAP_M ,MARGE ,
38 6 NBINFLG,MBINFLG ,ILEV ,MSEGTYP ,
39 7 IGAP ,GAP_S_L ,GAP_M_L,EDGE_L2 ,LEDGMAX ,
40 8 KREMNODE,REMNODE,
41 9 IPARTS ,NPARTNS ,LPARTNS ,IELEM ,ICODE ,
42 A ISKEW ,DRAD, IS_LARGE_NODE, LARGE_NODE ,
43 B NB_LARGE_NODES,DGAPLOAD,NRTMT,FLAG_REMOVED_NODE,
44 C IELEM_M,LOCAL_NEXT_NOD,IIX,IIY,IIZ,
45 D intbuf_tab,ipari,nin)
46C============================================================================
47C M o d u l e s
48C-----------------------------------------------
49 USE tri7box
50 use array_mod
51 use intbufdef_mod
52C-----------------------------------------------
53C I m p l i c i t T y p e s
54C-----------------------------------------------
55#include "implicit_f.inc"
56C-----------------------------------------------
57C G l o b a l P a r a m e t e r s
58C-----------------------------------------------
59#include "mvsiz_p.inc"
60c parameter setting the size for the vector (orig version is 128)
61 INTEGER NVECSZ
62 parameter(nvecsz = mvsiz)
63C-----------------------------------------------
64C C o m m o n B l o c k s
65C-----------------------------------------------
66#include "com04_c.inc"
67#include "param_c.inc"
68C-----------------------------------------------
69C ROLE DE LA ROUTINE:
70C ===================
71C CLASSE LES NOEUDS DANS DES BOITES
72C RECHERCHE POUR CHAQUE FACETTE DES BOITES CONCERNES
73C RECHERCHE DES CANDIDATS
74C-----------------------------------------------
75C D u m m y A r g u m e n t s
76C
77C NOM DESCRIPTION E/S
78C
79C IRECT(4,*) TABLEAU DES CONEC FACETTES E
80C X(3,*) COORDONNEES NODALES E
81C NSV NOS SYSTEMES DES NOEUDS E
82C XMAX plus grande abcisse existante E
83C XMAX plus grande ordonn. existante E
84C XMAX plus grande cote existante E
85C I_STOK niveau de stockage des couples
86C candidats impact E/S
87C CAND_N boites resultats noeuds
88C CAND_E adresses des boites resultat elements
89C
90C PROV_N CAND_N provisoire (variable static dans i7tri)
91C PROV_E CAND_E provisoire (variable static dans i7tri)
92
93C VOXEL(ix,iy,iz) contient le numero local du premier noeud de
94C la boite
95C LOCAL_NEXT_NOD(i) noeud suivant dans la meme boite (si /= 0)
96C LAST_NOD(i) dernier noeud dans la meme boite (si /= 0)
97C utilise uniquement pour aller directement du premier
98C noeud au dernier
99C-----------------------------------------------
100C D u m m y A r g u m e n t s
101C-----------------------------------------------
102 INTEGER ESHIFT,NSN,NRTM,IGAP,
103 . NBX,NBY,NBZ,
104 . NSV(*),
105 . IRECT(4,*), VOXEL(NBX+2,NBY+2,NBZ+2),II_STOK,
106 . NBINFLG(*),MBINFLG(*),ILEV,MSEGTYP(*),
107 . KREMNODE(*),REMNODE(*),
108 . IPARTS(*), NPARTNS(*), LPARTNS(*), ICODE(*), ISKEW(*)
109 LOGICAL, INTENT(in) :: FLAG_REMOVED_NODE !< flag to remove some S node from the list of candidates
110C REAL
111 my_real
112 . X(3,*),XYZM(6),STFN(*),GAP_S(*),GAP_M(*),
113 . GAP_S_L(*),GAP_M_L(*), EDGE_L2(*)
114 my_real
115 . ledgmax, marge, bgapsmx
116 my_real , INTENT(IN) :: drad, dgapload
117 INTEGER :: LARGE_NODE(NSN) ! list of nodes that have large research distance wrt solids
118 INTEGER :: IS_LARGE_NODE(NSN) ! tag nodes that have large research distance wrt solids
119 INTEGER :: NB_LARGE_NODES
120 INTEGER , INTENT(IN) :: NRTMT
121 INTEGER , INTENT(IN) :: IELEM_M(2,NRTM), IELEM(NRTM)
122 integer, intent(in) :: nin !< interface index
123 INTEGER, dimension(nsn), intent(inout) :: IIX,IIY,IIZ,LOCAL_NEXT_NOD
124 integer, dimension(npari), intent(inout) :: ipari !< interface data
125 type(intbuf_struct_), intent(inout) :: intbuf_tab !< interface data
126C-----------------------------------------------
127C L o c a l V a r i a b l e s
128C-----------------------------------------------
129 INTEGER I,J,
130 . nn,ne,k,l,j_stok,jj,
131 . prov_n(mvsiz),prov_e(mvsiz),
132 . m,iem,ipm,ips
133C REAL
134 my_real
135 . xs,ys,zs,sx,sy,sz,s2,
136 . xmin, xmax,ymin, ymax,zmin, zmax,
137 . xx1,xx2,xx3,xx4,yy1,yy2,yy3,yy4,zz1,zz2,zz3,zz4,
138 . d1x,d1y,d1z,d2x,d2y,d2z,dd1,dd2,d2,a2
139C
140 INTEGER, DIMENSION(:), ALLOCATABLE :: LAST_NOD
141 INTEGER IX,IY,IZ,M1,M2,M3,M4,
142 . ix1,iy1,iz1,ix2,iy2,iz2
143 my_real
144 . xminb,yminb,zminb,xmaxb,ymaxb,zmaxb,
145 . xmine,ymine,zmine,xmaxe,ymaxe,zmaxe,aaa
146 INTEGER FIRST,LAST
147 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGNOD
148
149 integer , external :: omp_get_thread_num,omp_get_num_threads
150 integer :: itask,nthreads
151 integer :: my_old_size,my_address
152 integer :: local_i_stok,multimp
153 integer :: local_cand_n_size,local_cand_e_size
154
155 integer, dimension(:), allocatable, save :: cand_n_size,cand_e_size
156 integer, dimension(:), allocatable, save :: address_cand_n,address_cand_e
157 type(array_type_int_1d) :: local_cand_n
158 type(array_type_int_1d) :: local_cand_e
159
160 integer :: my_size,mode
161 integer, dimension(:), allocatable :: my_index
162 integer, dimension(:,:), allocatable :: sort_array,save_array
163 integer, dimension(70000) :: work
164C-----------------------------------------------
165 ! allocation of local arrays
166 itask = omp_get_thread_num()
167 nthreads = omp_get_num_threads()
168 local_cand_n_size = size(intbuf_tab%cand_n) / nthreads + 1
169 local_cand_e_size = size(intbuf_tab%cand_e) / nthreads + 1
170 local_i_stok = 0
171 local_cand_n%size_int_array_1d = local_cand_n_size
172 local_cand_e%size_int_array_1d = local_cand_e_size
173 call alloc_1d_array(local_cand_n)
174 call alloc_1d_array(local_cand_e)
175
176 xmin = xyzm(1)
177 ymin = xyzm(2)
178 zmin = xyzm(3)
179 xmax = xyzm(4)
180 ymax = xyzm(5)
181 zmax = xyzm(6)
182
183 xminb = xmin
184 yminb = ymin
185 zminb = zmin
186 xmaxb = xmax
187 ymaxb = ymax
188 zmaxb = zmax
189
190!$OMP MASTER
191 allocate( cand_n_size(nthreads+1),cand_e_size(nthreads+1) )
192 allocate( address_cand_n(nthreads+1),address_cand_e(nthreads+1) )
193 cand_n_size(1:nthreads+1) = 0
194 cand_e_size(1:nthreads+1) = 0
195 address_cand_n(1:nthreads+1) = 0
196 address_cand_e(1:nthreads+1) = 0
197 ALLOCATE(last_nod(nsn))
198C
199C Phase initiale de construction de BPE et BPN deplacee de I7BUCE => I7TRI
200C
201
202C=======================================================================
203C 1 mise des noeuds dans les boites
204C=======================================================================
205 DO i=1,nsn
206 iix(i)=0
207 iiy(i)=0
208 iiz(i)=0
209 IF(stfn(i) == zero)cycle
210 j=nsv(i)
211C Optimisation // recherche les noeuds compris dans xmin xmax des
212C elements du processeur
213 IF(x(1,j) < xmin) cycle
214 IF(x(1,j) > xmax) cycle
215 IF(x(2,j) < ymin) cycle
216 IF(x(2,j) > ymax) cycle
217 IF(x(3,j) < zmin) cycle
218 IF(x(3,j) > zmax) cycle
219
220 iix(i)=int(nbx*(x(1,j)-xminb)/(xmaxb-xminb))
221 iiy(i)=int(nby*(x(2,j)-yminb)/(ymaxb-yminb))
222 iiz(i)=int(nbz*(x(3,j)-zminb)/(zmaxb-zminb))
223
224 iix(i)=max(1,2+min(nbx,iix(i)))
225 iiy(i)=max(1,2+min(nby,iiy(i)))
226 iiz(i)=max(1,2+min(nbz,iiz(i)))
227
228 first = voxel(iix(i),iiy(i),iiz(i))
229 IF(first == 0)THEN
230c empty cell
231 voxel(iix(i),iiy(i),iiz(i)) = i ! first
232 local_next_nod(i) = 0 ! last one
233 last_nod(i) = 0 ! no last
234 ELSEIF(last_nod(first) == 0)THEN
235c cell containing one node
236c add as next node
237 local_next_nod(first) = i ! next
238 last_nod(first) = i ! last
239 local_next_nod(i) = 0 ! last one
240 ELSE
241c
242c jump to the last node of the cell
243 last = last_nod(first) ! last node in this voxel
244 local_next_nod(last) = i ! next
245 last_nod(first) = i ! last
246 local_next_nod(i) = 0 ! last one
247 ENDIF
248 ENDDO
249!$OMP END MASTER
250
251!$OMP BARRIER
252
253C=======================================================================
254C 2 recherche des boites concernant chaque facette
255C et creation des candidats
256C=======================================================================
257 ALLOCATE( tagnod(numnod) )
258 tagnod(1:numnod) = 0
259C-----------------------------------------------
260 j_stok = 0
261!$OMP DO SCHEDULE(guided)
262 DO ne=1,nrtm
263 IF(ielem_m(2,ne) /=0) cycle
264
265c
266c il est possible d'ameliorer l'algo en decoupant la facette
267c en 2(4,3,6,9...) si la facette est grande devant AAA et inclinee
268
269 m1 = irect(1,ne)
270 m2 = irect(2,ne)
271 m3 = irect(3,ne)
272 m4 = irect(4,ne)
273
274 IF(flag_removed_node)THEN
275 k = kremnode(ne)+1
276 l = kremnode(ne+1)
277 DO m=k,l
278 tagnod(remnode(m)) = 1
279 ENDDO
280 ENDIF
281
282 IF (msegtyp(ne)==0 .OR. msegtyp(ne)>nrtmt)THEN
283 ! LEDGMAX /=0 <=> INACTI=5 or -1 and IDDLEVEL=1 !
284 aaa = max(marge+max(bgapsmx+gap_m(ne)+dgapload,drad),ledgmax+bgapsmx+gap_m(ne)+dgapload)
285 ELSE
286 aaa = marge+max(bgapsmx+gap_m(ne)+dgapload,drad)
287 END IF
288
289
290 xx1=x(1,m1)
291 xx2=x(1,m2)
292 xx3=x(1,m3)
293 xx4=x(1,m4)
294 xmaxe=max(xx1,xx2,xx3,xx4)
295 xmine=min(xx1,xx2,xx3,xx4)
296
297 yy1=x(2,m1)
298 yy2=x(2,m2)
299 yy3=x(2,m3)
300 yy4=x(2,m4)
301 ymaxe=max(yy1,yy2,yy3,yy4)
302 ymine=min(yy1,yy2,yy3,yy4)
303
304 zz1=x(3,m1)
305 zz2=x(3,m2)
306 zz3=x(3,m3)
307 zz4=x(3,m4)
308 zmaxe=max(zz1,zz2,zz3,zz4)
309 zmine=min(zz1,zz2,zz3,zz4)
310
311
312c calcul de la surface (pour elimination future de candidats)
313
314 sx = (yy3-yy1)*(zz4-zz2) - (zz3-zz1)*(yy4-yy2)
315 sy = (zz3-zz1)*(xx4-xx2) - (xx3-xx1)*(zz4-zz2)
316 sz = (xx3-xx1)*(yy4-yy2) - (yy3-yy1)*(xx4-xx2)
317 s2 = sx*sx + sy*sy + sz*sz
318
319c indice des voxels occupes par la facette
320
321 ix1=int(nbx*(xmine-aaa-xminb)/(xmaxb-xminb))
322 iy1=int(nby*(ymine-aaa-yminb)/(ymaxb-yminb))
323 iz1=int(nbz*(zmine-aaa-zminb)/(zmaxb-zminb))
324
325 ix1=max(1,2+min(nbx,ix1))
326 iy1=max(1,2+min(nby,iy1))
327 iz1=max(1,2+min(nbz,iz1))
328
329 ix2=int(nbx*(xmaxe+aaa-xminb)/(xmaxb-xminb))
330 iy2=int(nby*(ymaxe+aaa-yminb)/(ymaxb-yminb))
331 iz2=int(nbz*(zmaxe+aaa-zminb)/(zmaxb-zminb))
332
333 ix2=max(1,2+min(nbx,ix2))
334 iy2=max(1,2+min(nby,iy2))
335 iz2=max(1,2+min(nbz,iz2))
336
337 IF (msegtyp(ne)==0 .OR. msegtyp(ne)>nrtmt)THEN
338C Check for "large" nodes separately
339C if the current segment belongs to a solid or a coating shell
340 DO i = 1, nb_large_nodes
341 jj = large_node(i)
342 nn=nsv(jj)
343 IF(nn == m1)GOTO 400
344 IF(nn == m2)GOTO 400
345 IF(nn == m3)GOTO 400
346 IF(nn == m4)GOTO 400
347 IF(tagnod(nn) == 1)GOTO 400
348
349 xs = x(1,nn)
350 ys = x(2,nn)
351 zs = x(3,nn)
352c PMAX_GAP is a global overestimate penetration
353c NEED to communicate in SPMD
354c VMAXDT is a local overestimate of relative incremental displacement
355c NO need to communicate in SPMD
356
357 aaa = max(marge+max(gap_s(jj)+gap_m(ne)+dgapload,drad)+dgapload,edge_l2(jj)+gap_s(jj)+gap_m(ne)+dgapload)
358 IF(xs<=xmine-aaa)GOTO 400
359 IF(xs>=xmaxe+aaa)GOTO 400
360 IF(ys<=ymine-aaa)GOTO 400
361 IF(ys>=ymaxe+aaa)GOTO 400
362 IF(zs<=zmine-aaa)GOTO 400
363 IF(zs>=zmaxe+aaa)GOTO 400
364
365 iem=ielem(ne)
366 IF(iem/=0)THEN
367 ipm=iparts(iem)
368 ips=0
369 DO j=npartns(jj)+1,npartns(jj+1)
370 IF(lpartns(j)==ipm)THEN
371 ips=ipm
372 END IF
373 END DO
374 IF(ipm==ips) GOTO 400
375 END IF
376c END IF
377 d1x = xs - xx1
378 d1y = ys - yy1
379 d1z = zs - zz1
380 d2x = xs - xx2
381 d2y = ys - yy2
382 d2z = zs - zz2
383 dd1 = d1x*sx+d1y*sy+d1z*sz
384 dd2 = d2x*sx+d2y*sy+d2z*sz
385 IF(dd1*dd2 > zero)THEN
386 d2 = min(dd1*dd1,dd2*dd2)
387 a2 = aaa*aaa*s2
388 IF(d2 > a2)GOTO 400
389 ENDIF
390 j_stok = j_stok + 1
391 prov_n(j_stok) = jj
392 prov_e(j_stok) = ne
393 IF(j_stok == nvsiz)THEN
394 CALL i25sto(
395 1 nvsiz ,irect ,x ,nsv ,local_i_stok,
396 2 local_cand_n,local_cand_e ,marge ,
397 3 prov_n ,prov_e,eshift,nsn ,
398 4 nrtm ,gap_s ,gap_m ,nbinflg ,mbinflg,
399 5 ilev,msegtyp,igap ,gap_s_l,
400 6 gap_m_l,edge_l2,icode,iskew,drad ,
401 7 dgapload,nrtmt)
402 j_stok = 0
403 ENDIF
404 400 CONTINUE
405 ENDDO ! WHILE(JJ /= 0)
406 ENDIF ! solid or coating shell
407
408 DO iz = iz1,iz2
409 DO iy = iy1,iy2
410 DO ix = ix1,ix2
411
412cc nbpelem = nbpelem + 1
413
414 jj = voxel(ix,iy,iz)
415
416 DO WHILE(jj /= 0)
417
418cc nnpelem = nnpelem + 1
419
420 nn=nsv(jj)
421 IF(nn == m1)GOTO 300
422 IF(nn == m2)GOTO 300
423 IF(nn == m3)GOTO 300
424 IF(nn == m4)GOTO 300
425 IF(tagnod(nn) == 1)GOTO 300
426
427 xs = x(1,nn)
428 ys = x(2,nn)
429 zs = x(3,nn)
430c PMAX_GAP is a global overestimate penetration
431c NEED to communicate in SPMD
432c VMAXDT is a local overestimate of relative incremental displacement
433c NO need to communicate in SPMD
434
435 IF (msegtyp(ne)==0 .OR. msegtyp(ne)>nrtmt)THEN
436 IF(is_large_node(jj)==1) GOTO 300 ! node already checked before
437 ! LEDGMAX /=0 <=> INACTI=5 or -1 and IDDLEVEL=1 !
438 aaa = max(marge+max(gap_s(jj)+gap_m(ne)+dgapload,drad),edge_l2(jj)+gap_s(jj)+gap_m(ne)+dgapload)
439 ELSE
440 aaa = marge+max(gap_s(jj)+gap_m(ne)+dgapload,drad)
441 END IF
442
443 IF(xs<=xmine-aaa)GOTO 300
444 IF(xs>=xmaxe+aaa)GOTO 300
445 IF(ys<=ymine-aaa)GOTO 300
446 IF(ys>=ymaxe+aaa)GOTO 300
447 IF(zs<=zmine-aaa)GOTO 300
448 IF(zs>=zmaxe+aaa)GOTO 300
449
450 iem=ielem(ne)
451 IF(iem/=0)THEN
452 ipm=iparts(iem)
453 ips=0
454 DO j=npartns(jj)+1,npartns(jj+1)
455 IF(lpartns(j)==ipm)THEN
456 ips=ipm
457 END IF
458 END DO
459
460 IF(ipm==ips) GOTO 300
461 END IF
462c END IF
463
464c sousestimation de la distance**2 pour elimination de candidats
465
466cc nnr0pelem = nnr0pelem + 1
467
468 d1x = xs - xx1
469 d1y = ys - yy1
470 d1z = zs - zz1
471 d2x = xs - xx2
472 d2y = ys - yy2
473 d2z = zs - zz2
474 dd1 = d1x*sx+d1y*sy+d1z*sz
475 dd2 = d2x*sx+d2y*sy+d2z*sz
476 IF(dd1*dd2 > zero)THEN
477 d2 = min(dd1*dd1,dd2*dd2)
478 a2 = aaa*aaa*s2
479 IF(d2 > a2)GOTO 300
480 ENDIF
481
482 j_stok = j_stok + 1
483 prov_n(j_stok) = jj
484 prov_e(j_stok) = ne
485 IF(j_stok == nvsiz)THEN
486
487 CALL i25sto(
488 1 nvsiz ,irect ,x ,nsv ,local_i_stok,
489 2 local_cand_n,local_cand_e ,marge ,
490 3 prov_n ,prov_e,eshift,nsn ,
491 4 nrtm ,gap_s ,gap_m ,nbinflg ,mbinflg,
492 5 ilev,msegtyp,igap ,gap_s_l,
493 6 gap_m_l,edge_l2,icode,iskew,drad ,
494 7 dgapload,nrtmt)
495 j_stok = 0
496 ENDIF
497
498 300 CONTINUE
499
500 jj = local_next_nod(jj)
501
502 ENDDO ! WHILE(JJ /= 0)
503
504 ENDDO
505 ENDDO
506 ENDDO
507
508 IF(flag_removed_node)THEN
509 k = kremnode(ne)+1
510 l = kremnode(ne+1)
511 DO m=k,l
512 tagnod(remnode(m)) = 0
513 ENDDO
514 ENDIF
515
516 ENDDO
517!$OMP END DO
518
519!$OMP BARRIER
520C-------------------------------------------------------------------------
521C FIN DU TRI
522C-------------------------------------------------------------------------
523 IF(j_stok/=0)CALL i25sto(
524 1 j_stok,irect ,x ,nsv ,local_i_stok,
525 2 local_cand_n,local_cand_e ,marge ,
526 3 prov_n ,prov_e,eshift,nsn ,
527 4 nrtm ,gap_s ,gap_m ,nbinflg ,mbinflg,
528 5 ilev,msegtyp,igap ,gap_s_l,
529 6 gap_m_l,edge_l2,icode,iskew,drad ,
530 7 dgapload,nrtmt)
531C 4 remise a zero des noeuds dans les boites
532C=======================================================================
533 ! save the local number of candidates
534 cand_n_size(itask+1) = local_i_stok
535 cand_e_size(itask+1) = local_i_stok
536!$OMP BARRIER
537
538!$OMP SINGLE
539 ! compute the address for each threads & the total number of candidates
540 address_cand_n(1) = 0
541 address_cand_e(1) = 0
542 ! ------------
543 do i=1,nthreads
544 address_cand_n(i+1) = cand_n_size(i) + address_cand_n(i)
545 address_cand_e(i+1) = cand_e_size(i) + address_cand_e(i)
546
547 cand_n_size(nthreads+1) = cand_n_size(nthreads+1) + cand_n_size(i)
548 cand_e_size(nthreads+1) = cand_e_size(nthreads+1) + cand_e_size(i)
549 enddo
550 ! ------------
551
552 ! ------------
553 ! check the size of global cand_n & cand_e
554 my_old_size = ipari(18)*ipari(23)
555 if(cand_n_size(nthreads+1) > my_old_size) then ! total number of candidates > size of cand_n/e --> need to extend the 2 arrays
556 multimp = cand_n_size(nthreads+1)/ipari(18) + 1
557 call upgrade_multimp(nin,multimp,intbuf_tab)
558 endif
559 ii_stok = cand_n_size(nthreads+1) ! total number of cand_n/cand_e
560 ! ------------
561!$OMP END SINGLE
562
563 ! ------------
564 my_address = address_cand_n(itask+1) ! get the address for each thread
565 intbuf_tab%cand_n(my_address+1:my_address+local_i_stok) = local_cand_n%int_array_1d(1:local_i_stok) ! save the cand_n into the global array
566 my_address = address_cand_e(itask+1) ! get the address for each thread
567 intbuf_tab%cand_e(my_address+1:my_address+local_i_stok) = local_cand_e%int_array_1d(1:local_i_stok) ! save the cand_e into the global array
568 ! ------------
569
570 call dealloc_1d_array(local_cand_n)
571 call dealloc_1d_array(local_cand_e)
572
573!$OMP BARRIER
574
575
576
577
578 ! Sort the candidates to ensure the same domain decomposition
579!$OMP SINGLE
580 ! ------------
581 my_size = cand_n_size(nthreads+1)
582 allocate(my_index(2*my_size))
583 allocate(sort_array(2,my_size))
584 allocate(save_array(2,my_size))
585
586 my_address = address_cand_n(1) ! get the address of the first pair of candidate
587 sort_array(1,1:my_size) = intbuf_tab%cand_n(my_address+1:my_address+my_size)
588 my_address = address_cand_e(1) ! get the address of the first pair of candidate
589 sort_array(2,1:my_size) = intbuf_tab%cand_e(my_address+1:my_address+my_size)
590 do i=1,my_size
591 my_index(i) = i
592 enddo
593 save_array(1:2,1:my_size) = sort_array(1:2,1:my_size)
594 mode = 0
595
596 call my_orders( mode,work,sort_array,my_index,my_size,2)
597 my_address = address_cand_n(1) ! get the address of the first pair of candidate
598 do i=1,my_size
599 intbuf_tab%cand_n(my_address+i) = save_array(1,my_index(i))
600 enddo
601 my_address = address_cand_e(1) ! get the address of the first pair of candidate
602 do i=1,my_size
603 intbuf_tab%cand_e(my_address+i) = save_array(2,my_index(i))
604 enddo
605 deallocate(my_index)
606 deallocate(sort_array)
607 deallocate(save_array)
608 ! ------------
609!$OMP END SINGLE
610
611
612!$OMP DO SCHEDULE(guided)
613 DO i=1,nsn
614 IF(iix(i)/=0)THEN
615 voxel(iix(i),iiy(i),iiz(i))=0
616 ENDIF
617 ENDDO
618!$OMP END DO
619C
620!$OMP MASTER
621 DEALLOCATE(last_nod)
622 deallocate( cand_n_size,cand_e_size )
623 deallocate( address_cand_n,address_cand_e )
624!$OMP END MASTER
625 DEALLOCATE(tagnod)
626
627
628 RETURN
629 END
630
i25trivox1
subroutine i25trivox1(nsn, irect, x, stfn, xyzm, nsv, ii_stok, eshift, bgapsmx, voxel, nbx, nby, nbz, nrtm, gap_s, gap_m, marge, nbinflg, mbinflg, ilev, msegtyp, igap, gap_s_l, gap_m_l, edge_l2, ledgmax, kremnode, remnode, iparts, npartns, lpartns, ielem, icode, iskew, drad, is_large_node, large_node, nb_large_nodes, dgapload, nrtmt, flag_removed_node, ielem_m, local_next_nod, iix, iiy, iiz, intbuf_tab, ipari, nin)
Definition i25trivox1.F:46
array_mod::alloc_1d_array
Definition array_mod.F:95
array_mod::dealloc_1d_array
Definition array_mod.F:99
ymax
subroutine ymax(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition law100_upd.F:272
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
array_mod
Definition array_mod.F:51
i25sto
subroutine i25sto(j_stok, irect, x, nsv, local_i_stok, local_cand_n, local_cand_e, marge, prov_n, prov_e, eshift, nsn, nrtm, gap_s, gap_m, nbinflg, mbinflg, ilev, msegtyp, igap, gap_s_l, gap_m_l, edge_l2, icode, iskew, drad, dgapload, nrtmt)
Definition i25sto.F:42
upgrade_multimp
subroutine upgrade_multimp(ni, multimp_parameter, intbuf_tab)
Definition upgrade_multimp.F:48