OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25optcd_e2s.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!|| i25optcd_e2s ../engine/source/interfaces/intsort/i25optcd_e2s.f
25!||--- called by ------------------------------------------------------
26!|| i25main_opt_tri ../engine/source/interfaces/intsort/i25main_opt_tri.F
27!||--- calls -----------------------------------------------------
28!|| int_checksum ../engine/share/modules/debug_mod.F
29!|| my_barrier ../engine/source/system/machine.F
30!|| sync_data ../engine/source/system/machine.F
31!||--- uses -----------------------------------------------------
32!|| debug_mod ../engine/share/modules/debug_mod.F
33!|| tri25ebox ../engine/share/modules/tri25ebox.F
34!|| tri7box ../engine/share/modules/tri7box.F
35!||====================================================================
36 SUBROUTINE i25optcd_e2s(CAND_M,CAND_S,X ,I_STOK,IRECT ,
37 2 NIN ,V ,GAP_M,IGAP ,ITASK ,
38 3 STF ,GAP_M_L,COUNT_REMSLVE,DRAD ,
39 4 IEDGE ,NEDGE ,LEDGE ,MVOISIN,NSV,
40 5 NRTM ,GAPE ,GAP_E_L,IGAP0,
41 6 STFE, S_STFE ,IFQ ,IFPEN,
42 7 CAND_FX,CAND_FY,CAND_FZ,DGAPLOAD)
43C============================================================================
44C M o d u l e s
45C-----------------------------------------------
46 USE tri7box
47 USE tri25ebox
48#ifdef WITH_ASSERT
49 USE debug_mod
50#endif
51C-----------------------------------------------
52C I m p l i c i t T y p e s
53C-----------------------------------------------
54#include "implicit_f.inc"
55#include "comlock.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"
60#include "assert.inc"
61#include "i25edge_c.inc"
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 INTEGER, INTENT(IN) :: S_STFE
66 INTEGER IRECT(4,*),CAND_M(*), CAND_S(*), IFPEN(*),
67 . I_STOK, NIN,IGAP ,ITASK, COUNT_REMSLVE(*),
68 . IEDGE, NEDGE, LEDGE(NLEDGE,*), MVOISIN(4,*), NSV(*), NRTM, IGAP0,IFQ
69 my_real , INTENT(IN) :: DGAPLOAD ,DRAD
70 my_real
71 . x(3,*),gap_m(*),v(3,*),stf(*),gap_m_l(*), gape(*), gap_e_l(*),
72 . stfe(s_stfe), cand_fx(4,*),cand_fy(4,*),cand_fz(4,*)
73
74C-----------------------------------------------
75C C o m m o n B l o c k s
76C-----------------------------------------------
77#include "task_c.inc"
78#include "com01_c.inc"
79#include "param_c.inc"
80#include "parit_c.inc"
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 INTEGER I , L, IE, JE, NN1, NN2, SOL_EDGE, SH_EDGE,
85 . NRTMFT, NRTMLT
86 my_real
87 . X1S,X2S,Y1S,Y2S,Z1S,Z2S,
88 . X1,X2,X3,X4,
89 . Y1,Y2,Y3,Y4,
90 . z1,z2,z3,z4,
91 .
92 .
93 .
94 . xmins,xmaxs,ymins,ymaxs,zmins,zmaxs,
95 . xminm,xmaxm,yminm,ymaxm,zminm,zmaxm,
96 .
97 . dxm,dym,dzm,
98 . gapvd,s
99 INTEGER MSEG,CT
100 my_real
101 . GAPV(MVSIZ)
102 INTEGER LIST(MVSIZ), LISTI(MVSIZ)
103 INTEGER IS,JS,LS,NLS,NLT,NSEG,NLF,II,NLS2
104 INTEGER N1(MVSIZ),N2(MVSIZ)
105 INTEGER SG, FIRST, LAST,COUNT_CAND
106 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGM
107 my_real,
108 . DIMENSION(:,:),ALLOCATABLE :: boxm
109 SAVE tagm,boxm
110 INTEGER :: J
111 INTEGER :: MY_SIZE
112 INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_REAL_CANDIDATE
113
114C-----------------------------------------------
115 sol_edge=iedge/10 ! solids
116 sh_edge =iedge-10*sol_edge ! shells
117C-----------------------------------------------
118 count_cand = 0
119 ct = 0
120 mseg = nvsiz
121 first = 1 + i_stok*itask / nthread
122 last = i_stok*(itask+1) / nthread
123 my_size = last - first + 1
124 ALLOCATE( list_real_candidate(my_size) )
125C-----------------------------------------------
126 IF(sol_edge/=0)THEN
127
128 IF(itask==0)THEN
129 ALLOCATE(tagm(nrtm),boxm(6,nrtm))
130 tagm(1:nrtm)=0
131 END IF
132
133 CALL my_barrier
134
135 DO i=first,last
136 l = cand_m(i)
137 IF(stf(l)/=zero)tagm(l)=1
138 END DO
139
140 CALL my_barrier
141
142 nrtmft=1 + nrtm*itask / nthread
143 nrtmlt=nrtm*(itask+1) / nthread
144
145 DO l=nrtmft,nrtmlt
146
147 boxm(1,l)= ep30
148 boxm(2,l)=-ep30
149 boxm(3,l)= ep30
150 boxm(4,l)=-ep30
151 boxm(5,l)= ep30
152 boxm(6,l)=-ep30
153
154 IF(tagm(l)/=0)THEN
155
156 x1=x(1,irect(1,l))
157 y1=x(2,irect(1,l))
158 z1=x(3,irect(1,l))
159 x2=x(1,irect(2,l))
160 y2=x(2,irect(2,l))
161 z2=x(3,irect(2,l))
162 x3=x(1,irect(3,l))
163 y3=x(2,irect(3,l))
164 z3=x(3,irect(3,l))
165 x4=x(1,irect(4,l))
166 y4=x(2,irect(4,l))
167 z4=x(3,irect(4,l))
168
169 xminm = min(x1,x2,x3,x4)
170 xmaxm = max(x1,x2,x3,x4)
171 dxm = em02*(xmaxm-xminm)
172 xminm = xminm-dxm
173 xmaxm = xmaxm+dxm
174
175 yminm = min(y1,y2,y3,y4)
176 ymaxm = max(y1,y2,y3,y4)
177 dym = em02*(ymaxm-yminm)
178 yminm = yminm-dym
179 ymaxm = ymaxm+dym
180
181 zminm = min(z1,z2,z3,z4)
182 zmaxm = max(z1,z2,z3,z4)
183 dzm = em02*(zmaxm-zminm)
184 zminm = zminm-dzm
185 zmaxm = zmaxm+dzm
186
187 boxm(1,l)=xminm
188 boxm(2,l)=xmaxm
189 boxm(3,l)=yminm
190 boxm(4,l)=ymaxm
191 boxm(5,l)=zminm
192 boxm(6,l)=zmaxm
193
194 END IF
195 END DO
196
197 CALL my_barrier
198
199 END IF ! IF(SOL_EDGE/0)THEN
200C-----
201 js = first-1
202 DO sg = first,last,mseg
203 nseg = min(mseg,last-js)
204C-----------------------------------------------
205C solid edges on main side
206C-----------------------------------------------
207 IF(nspmd>1) THEN
208C
209C Partage cand_n local / frontiere
210C
211 nls = 0
212 nls2 = nseg+1
213 DO is = 1, nseg
214 i=js+is
215 IF(cand_s(i)<=nedge)THEN
216
217 IF(sh_edge==1.AND.
218 . ledge(7,cand_s(i))/=1.AND.
219 . ledge(3,cand_s(i))/=0) cycle ! Shell edge is not a free edge
220 nls=nls+1
221 listi(nls)=is
222
223#ifdef WITH_ASSERT
224C Debug only
225 ids(1) = itab_debug(irect(1,cand_m(i)))
226 ids(2) = itab_debug(irect(2,cand_m(i)))
227 ids(3) = itab_debug(irect(3,cand_m(i)))
228 ids(4) = itab_debug(irect(4,cand_m(i)))
229 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,i)
230#endif
231
232 ELSE ! REMOTE
233 IF(sh_edge==1.AND.
234 . ledge_fie(nin)%P(e_type,cand_s(i)-nedge)/=1.AND.
235 . ledge_fie(nin)%P(e_right_seg,cand_s(i)-nedge)/=0) cycle ! Shell edge is not a free edge
236 nls2=nls2-1
237 assert(is <= mvsiz)
238 assert(is > 0)
239 listi(nls2) = is
240#ifdef WITH_ASSERT
241C Debug only
242 ids(1) = itab_debug(irect(1,cand_m(i)))
243 ids(2) = itab_debug(irect(2,cand_m(i)))
244 ids(3) = itab_debug(irect(3,cand_m(i)))
245 ids(4) = itab_debug(irect(4,cand_m(i)))
246 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge),i)
247#endif
248 ENDIF
249 ENDDO
250C LISTI(1:NLS) = Local
251C LISTI(NLS+1:NSEG) = REMOTE
252
253CC'LOCAL OF SPMD
254C#include "vectorize.inc"
255C DO LS = 1, NLS
256C IS = LISTI(LS)
257C I=JS+IS
258C IE=CAND_M(I) ! segment, zero gap
259C JE=CAND_S(I) ! edge
260C GAPV(IS)=GAPE(JE)
261C IF(SH_EDGE /= 0 .AND. IGAP0 /= 0) GAPV(IS)=TWO*GAPV(IS)
262C IF(IGAP==3)
263C . GAPV(IS)=MIN(GAPV(IS),GAP_M_L(IE)+GAP_E_L(JE))
264C GAPV(IS)=MAX(GAPV(IS),DRAD)
265C ENDDO
266
267 ELSE ! NSPMD == 1
268 nls = 0
269C Build LISTI
270 DO is=1,nseg
271 i=js+is
272 IF(sh_edge==1.AND.
273 . ledge(7,cand_s(i))/=1.AND.
274 . ledge(3,cand_s(i))/=0) cycle ! Shell edge is not a free edge
275
276
277#ifdef WITH_ASSERT
278 ids(1) = itab_debug(irect(1,cand_m(i)))
279 ids(2) = itab_debug(irect(2,cand_m(i)))
280 ids(3) = itab_debug(irect(3,cand_m(i)))
281 ids(4) = itab_debug(irect(4,cand_m(i)))
282 debug_e2e(int_checksum(ids,4,1)==d_em.AND.ledge(8,cand_s(i)) == d_es,i)
283#endif
284
285 nls=nls+1
286 listi(nls)=is
287 ENDDO
288 ENDIF ! END IF SPMD
289
290
291C========== LOCAL
292#include "vectorize.inc"
293 DO ls = 1, nls
294 is = listi(ls)
295 i=js+is
296 ie=cand_m(i) ! segment, zero gap
297 je=cand_s(i) ! edge
298 gapv(is)=gape(je)
299 IF(sh_edge /= 0 .AND. igap0 /= 0) gapv(is)=two*gapv(is)
300 IF(igap==3)
301 . gapv(is)=min(gapv(is),gap_m_l(ie)+gap_e_l(je))
302 gapv(is)=max(gapv(is)+dgapload,drad)
303 ENDDO
304
305C
306 nlf = 1
307 nlt = nls
308 nls = 0
309C ======== LOCAL TIRM 1
310 DO ls = nlf, nlt
311 is = listi(ls)
312 i = js + is
313C LEDGE(1) can be < 0 if:
314C - the edge it on a boundary between two domains
315C - The logal segment is broken
316 l = ledge(1,cand_s(i))
317 s = zero
318#ifdef WITH_ASSERT
319 ids(1) = itab_debug(irect(1,cand_m(i)))
320 ids(2) = itab_debug(irect(2,cand_m(i)))
321 ids(3) = itab_debug(irect(3,cand_m(i)))
322 ids(4) = itab_debug(irect(4,cand_m(i)))
323 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,l)
324 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,ledge(ledge_weight,cand_s(i)))
325#endif
326
327 IF( l > 0 ) THEN
328 s = stfe(cand_s(i))
329 ELSEIF (l < 0) THEN
330C Boundary edge, owned by ISPMD, but local segment broken
331C In that case, we assume that the segment on the
332C other side of the boundary is not broken
333 s = one
334C S = ZERO
335 ENDIF
336
337#ifdef WITH_ASSERT
338 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,s)
339#endif
340
341 IF (s/=zero) THEN
342 n1(is)= ledge(5,cand_s(i))
343 n2(is)= ledge(6,cand_s(i))
344 z1s=x(3,n1(is))
345 z2s=x(3,n2(is))
346 gapvd = gapv(is)
347 zmins = min(z1s,z2s)-gapvd
348 zmaxs = max(z1s,z2s)+gapvd
349 zminm = boxm(5,cand_m(i))
350 zmaxm = boxm(6,cand_m(i))
351 zminm = zminm-gapvd
352 zmaxm = zmaxm+gapvd
353#ifdef WITH_ASSERT
354 ids(1) = itab_debug(irect(1,cand_m(i)))
355 ids(2) = itab_debug(irect(2,cand_m(i)))
356 ids(3) = itab_debug(irect(3,cand_m(i)))
357 ids(4) = itab_debug(irect(4,cand_m(i)))
358 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,zmaxs)
359 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,zmins)
360 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,zmaxm)
361 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,zminm)
362#endif
363
364 IF (zmaxs>=zminm.AND.zmaxm>=zmins) THEN
365 nls=nls+1
366 list(nls)=is
367 ENDIF
368 ENDIF
369 ENDDO
370C
371 nlt=nls
372 nls=0
373C ======== LOCAL TIRM 2
374 DO ls=nlf,nlt
375 is=list(ls)
376 i=js+is
377 y1s=x(2,n1(is))
378 y2s=x(2,n2(is))
379 gapvd = gapv(is)
380 ymins = min(y1s,y2s)-gapvd
381 ymaxs = max(y1s,y2s)+gapvd
382 yminm = boxm(3,cand_m(i))
383 ymaxm = boxm(4,cand_m(i))
384 yminm = yminm-gapvd
385 ymaxm = ymaxm+gapvd
386#ifdef WITH_ASSERT
387 ids(1) = itab_debug(irect(1,cand_m(i)))
388 ids(2) = itab_debug(irect(2,cand_m(i)))
389 ids(3) = itab_debug(irect(3,cand_m(i)))
390 ids(4) = itab_debug(irect(4,cand_m(i)))
391 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,ymaxs)
392 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,ymins)
393 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,ymaxm)
394 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,yminm)
395#endif
396
397 IF (ymaxs>=yminm.AND.ymaxm>=ymins) THEN
398 nls=nls+1
399 list(nls)=is
400 ENDIF
401 ENDDO
402C
403 nlt = nls
404 nls=0
405C ======== LOCAL TIRM 3
406 DO ls=nlf,nlt
407 is=list(ls)
408 i=js+is
409 x1s=x(1,n1(is))
410 x2s=x(1,n2(is))
411 gapvd = gapv(is)
412 xmins = min(x1s,x2s)-gapvd
413 xmaxs = max(x1s,x2s)+gapvd
414 xminm = boxm(1,cand_m(i))
415 xmaxm = boxm(2,cand_m(i))
416 xminm = xminm-gapvd
417 xmaxm = xmaxm+gapvd
418#ifdef WITH_ASSERT
419 ids(1) = itab_debug(irect(1,cand_m(i)))
420 ids(2) = itab_debug(irect(2,cand_m(i)))
421 ids(3) = itab_debug(irect(3,cand_m(i)))
422 ids(4) = itab_debug(irect(4,cand_m(i)))
423 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,xmaxs)
424 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,xmins)
425 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,xmaxm)
426 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge(8,cand_s(i)) == d_es,xminm)
427#endif
428
429 IF (xmaxs>=xminm.AND.xmaxm>=xmins) THEN
430 cand_s(i) = -cand_s(i)
431 count_cand = count_cand+1
432 list_real_candidate(count_cand) = i
433 ENDIF
434 ENDDO
435C
436 IF(nspmd>1)THEN
437 nlf = nls2
438 nlt = nseg
439C ========= REMOTE
440 DO ls = nlf, nlt
441 is = listi(ls)
442 i=js+is
443 ie=cand_m(i)
444 gapv(is)=gapfie(nin)%P(cand_s(i)-nedge)
445 IF(sh_edge /= 0 .AND. igap0 /= 0) gapv(is)=two*gapv(is)
446
447 IF(igap==3)
448 . gapv(is)=min(gapv(is),gape_l_fie(nin)%P(cand_s(i)-nedge)+gap_m_l(ie))
449 gapv(is)=max(gapv(is)+dgapload,drad)
450 ENDDO
451C
452 nls=0
453C ========= REMOTE TRIM 1
454 DO ls = nlf, nlt
455C keep LISTI and LIST to optimize generated code (IA64)
456 is = listi(ls)
457 i=js+is
458 ii = cand_s(i)-nedge
459#ifdef WITH_ASSERT
460 ids(1) = itab_debug(irect(1,cand_m(i)))
461 ids(2) = itab_debug(irect(2,cand_m(i)))
462 ids(3) = itab_debug(irect(3,cand_m(i)))
463 ids(4) = itab_debug(irect(4,cand_m(i)))
464 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,stifie(nin)%P(ii))
465#endif
466
467 IF (stifie(nin)%P(ii)/=zero) THEN
468 nn1 = 2*(ii-1)+1
469 nn2 = 2*ii
470 z1s=xfie(nin)%P(3,nn1)
471 z2s=xfie(nin)%P(3,nn2)
472C L = LEDGE(1,CAND_M(I))
473C IF (STF(L)/=ZERO) THEN
474 gapvd = gapv(is)
475 zmins = min(z1s,z2s)-gapvd
476 zmaxs = max(z1s,z2s)+gapvd
477 zminm = boxm(5,cand_m(i))
478 zmaxm = boxm(6,cand_m(i))
479 zminm = zminm-gapvd
480 zmaxm = zmaxm+gapvd
481#ifdef WITH_ASSERT
482 ids(1) = itab_debug(irect(1,cand_m(i)))
483 ids(2) = itab_debug(irect(2,cand_m(i)))
484 ids(3) = itab_debug(irect(3,cand_m(i)))
485 ids(4) = itab_debug(irect(4,cand_m(i)))
486 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,zmaxs)
487 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,zmins)
488 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,zmaxm)
489 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,zminm)
490#endif
491
492 IF (zmaxs>=zminm.AND.zmaxm>=zmins) THEN
493 nls=nls+1
494 list(nls)=is
495 ENDIF
496C ENDIF
497 ENDIF
498 ENDDO
499C
500 nlf=1
501 nlt=nls
502 nls=0
503C ============= REMOTE TRIM 2
504 DO ls=nlf,nlt
505 is=list(ls)
506 i=js+is
507 ii = cand_s(i)-nedge
508 nn1 = 2*(ii-1)+1
509 nn2 = 2*ii
510 y1s=xfie(nin)%P(2,nn1)
511 y2s=xfie(nin)%P(2,nn2)
512
513
514 gapvd = gapv(is)
515 ymins = min(y1s,y2s)-gapvd
516 ymaxs = max(y1s,y2s)+gapvd
517 yminm = boxm(3,cand_m(i))
518 ymaxm = boxm(4,cand_m(i))
519 yminm = yminm-gapvd
520 ymaxm = ymaxm+gapvd
521
522#ifdef WITH_ASSERT
523 ids(1) = itab_debug(irect(1,cand_m(i)))
524 ids(2) = itab_debug(irect(2,cand_m(i)))
525 ids(3) = itab_debug(irect(3,cand_m(i)))
526 ids(4) = itab_debug(irect(4,cand_m(i)))
527 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,ymaxs)
528 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,ymins)
529 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,ymaxm)
530 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,yminm)
531#endif
532
533 IF (ymaxs>=yminm.AND.ymaxm>=ymins) THEN
534 nls=nls+1
535 list(nls)=is
536 ENDIF
537 ENDDO
538C ================ REMOTE TRIM 3
539 DO ls=nlf,nls
540 is=list(ls)
541 i=js+is
542 ii = cand_s(i)-nedge
543 nn1 = 2*(ii-1)+1
544 nn2 = 2*ii
545 x1s=xfie(nin)%P(1,nn1)
546 x2s=xfie(nin)%P(1,nn2)
547 gapvd = gapv(is)
548 xmins = min(x1s,x2s)-gapvd
549 xmaxs = max(x1s,x2s)+gapvd
550 xminm = boxm(1,cand_m(i))
551 xmaxm = boxm(2,cand_m(i))
552 xminm = xminm-gapvd
553 xmaxm = xmaxm+gapvd
554#ifdef WITH_ASSERT
555 ids(1) = itab_debug(irect(1,cand_m(i)))
556 ids(2) = itab_debug(irect(2,cand_m(i)))
557 ids(3) = itab_debug(irect(3,cand_m(i)))
558 ids(4) = itab_debug(irect(4,cand_m(i)))
559 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,xmaxs)
560 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,xmins)
561 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,xmaxm)
562 debug_e2e(int_checksum(ids,4,1)==d_em .AND. ledge_fie(nin)%P(e_global_id,cand_s(i)-nedge) == d_es,xminm)
563#endif
564
565 IF (xmaxs>=xminm.AND.xmaxm>=xmins) THEN
566
567 cand_s(i) = -cand_s(i)
568 count_cand = count_cand+1
569 ct = ct+1
570 list_real_candidate(count_cand) = i
571
572 ENDIF
573 ENDDO
574 CALL sync_data(nls2)
575 END IF
576 js = js + nseg
577 ENDDO
578 IF (ifq > 0) THEN
579#include "vectorize.inc"
580 DO j=1,count_cand
581 i = list_real_candidate(j)
582 IF(ifpen(i) == 0 ) THEN
583 cand_fx(1:4,i) = zero
584 cand_fy(1:4,i) = zero
585 cand_fz(1:4,i) = zero
586 ENDIF
587 ENDDO
588 DO i=first,last
589 ifpen(i) = 0
590 ENDDO
591 ENDIF
592C
593#include "lockon.inc"
594 lskyi_count=lskyi_count+count_cand*5
595 count_remslve(nin)=count_remslve(nin)+ct
596#include "lockoff.inc"
597
598C
599C
600 IF(sol_edge/=0)THEN
601
602 CALL my_barrier
603
604 IF(itask==0)DEALLOCATE(tagm,boxm)
605
606 END IF
607
608 DEALLOCATE( list_real_candidate )
609C
610 RETURN
611 END
612
sync_data
subroutine sync_data(ii)
Definition machine.F:383
i25optcd_e2s
subroutine i25optcd_e2s(cand_m, cand_s, x, i_stok, irect, nin, v, gap_m, igap, itask, stf, gap_m_l, count_remslve, drad, iedge, nedge, ledge, mvoisin, nsv, nrtm, gape, gap_e_l, igap0, stfe, s_stfe, ifq, ifpen, cand_fx, cand_fy, cand_fz, dgapload)
Definition i25optcd_e2s.F:43
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
debug_mod
Definition debug_mod.F:47
debug_mod::itab_debug
integer, dimension(:), allocatable itab_debug
User Node Identifiers.
Definition debug_mod.F:50
debug_mod::int_checksum
pure integer function int_checksum(a, siz1, siz2)
Definition debug_mod.F:170
tri25ebox::gape_l_fie
type(real_pointer), dimension(:), allocatable gape_l_fie
Definition tri25ebox.F:88
tri25ebox::ledge_fie
type(int_pointer2), dimension(:), allocatable ledge_fie
Definition tri25ebox.F:90
tri7box::gapfie
type(real_pointer), dimension(:), allocatable gapfie
Definition tri7box.F:449
tri7box::xfie
type(real_pointer2), dimension(:), allocatable xfie
Definition tri7box.F:459
tri7box::stifie
type(real_pointer), dimension(:), allocatable stifie
Definition tri7box.F:449
my_barrier
subroutine my_barrier
Definition machine.F:31