38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
92
93
94
95#include "implicit_f.inc"
96#include "comlock.inc"
97
98
99
100#include "task_c.inc"
101#include "subvolumes.inc"
102
103 INTERFACE
104 FUNCTION i22chk(
105 1 SECtype, Nbits, Npqts)
106 INTEGER :: Nbits, Npqts
107 CHARACTER*(*) :: SECtype
108 LOGICAL :: I22CHK
109 END FUNCTION i22chk
110 END INTERFACE
111
112
113
114 INTEGER :: IXS(NIXS,*), ITASK, NIN, BUFBRIC(*)
116 . x(3,*)
117
118
119
120 INTEGER I, J, JJ, K, L,S, NE, POS, IAD,NBCUT, Icode, Idble, IB
121 INTEGER I_12BITS, PQTS(4), NPQTS, NBITS, SOM, I_bits(12)
122 INTEGER NBF, NBL, ID, N, id1, id2
123 INTEGER NFACE, NEDGE
124 INTEGER :: MAXSOM
125 INTEGER D, M
126 INTEGER,POINTER,DIMENSION(:) :: pCODE, pTAG, pGnod
127 CHARACTER*14,DIMENSION(:),POINTER ::pSEC
128 LOGICAL LTag(18)
129 CHARACTER*14 :: dbKEY1, dbKEY2
130 integer idb1(0:ncandb), idb2(0:ncandb)
131 INTEGER :: tagTETRA(S_TETRA),tagPENTA(S_PENTA),tagPOLY3(S_POLY3),
132 . taghexae(s_hexae),tagpoly4(s_poly4)
133 INTEGER :: MultICODE(S22_MAX), MultIDBLE(S22_MAX)
134 CHARACTER*14 :: MultiSECtype(S22_MAX)
135 INTEGER :: (S22_MAX)
136 LOGICAL :: bool1, bool2
137 INTEGER :: BasedOnUsedNodes
138 INTEGER :: UsedNodes, Gnod
139 INTEGER :: SecTypeList(0:106)
140 INTEGER :: LIST(106), LIST_FIX(8),LIST_VAR(106)
141 INTEGER :: SizeL , SizeLFIX ,SizeLVAR
142 INTEGER :: NINTP , TAB(12)
143 INTEGER :: RESULT(8)
144 LOGICAL :: bFOUND, debug_outp
145 INTEGER :: CODE, brickID, bAND, IE, Iremoved
147 LOGICAL :: db_WRITE
148
149
150
151 list_fix(1:8) = 0
152 tagtetra=0
153 tagpenta=0
154 tagpoly3=0
155 taghexae=0
156 tagpoly4=0
157
158
159
160
161 nbf = 1+itask*
nb/nthread
162 nbl = (itask+1)*
nb/nthread
163
164 DO i=nbf,nbl
165
166
167
168
170 1 i , icode , idble, nbits, npqts,
171 2 idb1(i), idb2(i), nin )
177 END DO
178
179
180
181
182
183
184
185
186 debug_outp = .false.
189 do ib=nbf,nbl
192 debug_outp=.true.
193 exit
194 endif
195 enddo
197 debug_outp = .true.
198 endif
199 endif
200 if(itask==0.AND.debug_outp)then
201 print *, ""
202 print *, " |----------
i22ident.f-----------|
"
203 print *, " | identification intersection |"
204 print *, " |-------------------------------|"
205 end if
206
207
208 DO I=NBF,NBL
209 !===================================================================
210 ! 3 Potential Polyhedron Detection : stored in SecTypeList in [1,106]
211 !===================================================================
212 Iremoved = 0
213 10 CONTINUE
214 IB = I
215 SecTypeList(:) = 0
216 UsedNodes = 0
217 K = 1 !numero plan intersection pour %SECtype
218 ICODE=BRICK_LIST(NIN,I)%ICODE
219 IDBLE=BRICK_LIST(NIN,I)%IDBLE
220 NBITS=BRICK_LIST(NIN,I)%Nbits
221 NPQTS=BRICK_LIST(NIN,I)%Npqts
222 BRICK_LIST(NIN,I)%Sectype(1:8) = '--------------'
223
224
225 !-----------------------------------------------------------------------!
226 ! Listing all potential polyhedron !
227 !-----------------------------------------------------------------------!
228
229 IF(NBITS<3)GOTO 50 !sous-variete de dim 1
230 !------------------------!
231 ! TETRA !
232 !------------------------!
233 D = D_TETRA
234 M = M_TETRA
235 S = S_TETRA
236 N = N_TETRA
237 pCODE => bCODE(D:D+S-1) !bincode
238 pSEC => StrCODE(D:D+S-1) !sectype
239 DO J=1,S
240 IF( IAND(ICODE,pCODE(J))==pCODE(J) )THEN
241 SecTypeList(K) = D+J-1
242 K = K+1
243 END IF
244 END DO
245.AND..OR. IF(NBITS==3(NPQTS==1NPQTS==3))GOTO 50 !pas d'autre intersection
246 !------------------------!
247 ! PENTA !
248 !------------------------!
249.AND. IF(NBITS>=4NPQTS>=3)THEN
250 D = D_PENTA
251 M = M_PENTA
252 S = S_PENTA
253 N = N_PENTA
254 pCODE => bCODE(D:D+S-1) !bincode
255 pSEC => StrCODE(D:D+S-1) !sectype
256 DO J=1,S
257 IF( IAND(ICODE,pCODE(J))==pCODE(J) )THEN
258 SecTypeList(K) = D+J-1 !code_id in [1,106]
259 K = K+1
260 END IF
261 END DO
262 !------------------------!
263 ! POLY3 !
264 !------------------------!
265 IF(NBITS>=5)THEN !NPQTS>=3 deja verifie
266 D = D_POLY3
267 S = S_POLY3
268 M = M_POLY3
269 N = N_POLY3
270 pCODE => bCODE(D:D+S-1) !bincode
271 pSEC => StrCODE(D:D+S-1) !sectype
272 DO J=1,S
273 IF( IAND(ICODE,pCODE(J))==pCODE(J) )THEN
274 SecTypeList(K) = D+J-1 !code_id in [1,106]
275 K = K+1
276 END IF
277 END DO
278 END IF
279 !------------------------!
280 ! HEXAE !
281 !------------------------!
282 IF(NPQTS==4)THEN !NBIT>=4 deja verifie
283 D = D_HEXAE
284 M = M_HEXAE
285 S = S_HEXAE * M
286 N = N_HEXAE
287 pCODE => bCODE(D:D+S-1) !bincode
288 pSEC => StrCODE(D:D+S-1) !sectype
289 DO J=1,S
290 IF( IAND(ICODE,pCODE(J))==pCODE(J) )THEN
291 SecTypeList(K) = D+J-1 !code_id in [1,106]
292 K = K+1
293 END IF
294 END DO
295 END IF
296 !------------------------!
297 ! POLY4 !
298 !------------------------!
299 IF(NBITS>=6)THEN !NPQTS>=3 deja verifie
300 D = D_POLY4
301 M = M_POLY4
302 S = S_POLY4 * M
303 N = N_POLY4
304 pCODE => bCODE(D:D+S-1)
305 pSEC => StrCODE(D:D+S-1)
306 DO J=1,S
307 IF( IAND(ICODE,pCODE(J))==pCODE(J) )THEN
308 SecTypeList(K) = D+J-1 !code_id in [1,106]
309 K = K+1
310 END IF
311 END DO
312 END IF !(NBITS>=6)
313 !------------------------!
314 ! POLY4A !
315 !------------------------!
316 IF(NBITS>=6)THEN !NPQTS>=3 deja verifie
317 D = D_POLY4A
318 M = M_POLY4A
319 S = S_POLY4A * M
320 N = N_POLY4A
321 pCODE => bCODE(D:D+S-1)
322 pSEC => StrCODE(D:D+S-1)
323 DO J=1,S
324 IF( IAND(ICODE,pCODE(J))==pCODE(J) )THEN
325 SecTypeList(K) = D+J-1 !code_id in [1,106]
326 K = K+1
327 END IF
328 END DO
329 END IF !(NBITS>=6)
330 !------------------------!
331 ! POLY4B !
332 !------------------------!
333 IF(NBITS>=6)THEN !NPQTS>=3 deja verifie
334 D = D_POLY4B
335 M = M_POLY4B
336 S = S_POLY4B * M
337 N = N_POLY4B
338 pCODE => bCODE(D:D+S-1)
339 pSEC => StrCODE(D:D+S-1)
340 DO J=1,S
341 IF( IAND(ICODE,pCODE(J))==pCODE(J) )THEN
342 SecTypeList(K) = D+J-1 !code_id in [1,106]
343 K = K+1
344 END IF
345 END DO
346 END IF !(NBITS>=6)
347 !------------------------!
348 ! POLYC !
349 !------------------------!
350.AND. ! IF(NBITS>=5 IDBLE>0)THEN !NPQTS>=3 deja verifie
351 ! D = D_POLYC
352 ! M = M_POLYC
353 ! S = S_POLYC * M
354 ! N = N_POLYC
355 ! pCODE => bCODE(D:D+S-1)
356 ! pSEC => StrCODE(D:D+S-1)
357 ! DO J=1,S
358 ! bAND = IAND(ICODE,pCODE(J))
359 ! bool1 = bAND==pCODE(J)
360 ! IF( bool1 )THEN
361 ! IF(BTEST(IDBLE,12-IABS(Gcorner(5,D+J-1))))THEN
362 ! SecTypeList(K) = D+J-1 !code_id in [1,106]
363 ! K = K+1
364 ! ENDIF
365 ! END IF
366 ! END DO
367 ! END IF !(NBITS>=6)
368.AND. END IF !(NBITS>=4NPQTS>=3)
369
370 50 CONTINUE
371 SecTypeList(0) = K - 1 !number of potential combination
372 SizeL = SecTypeList(0)
373
374
375
376
377
378
379 DO K=1,SecTypeList(0)
380 J = SecTypeList(K)
381 LIST(K) = J
382 ENDDO
383
384
385.AND.! if(itask==0debug_outp)then
386.or.! if(ibug22_ident==-1 ibug22_ident==ixs(11,brick_list(nin,ib)%id))then
387! print *, " cell
id * :
",IXS(11,BRICK_LIST(NIN,I)%ID)
388! write (*,FMT='(A,I12,A,12L1,A,I12,A,12L1)') , "icode =",ICODE," ", (BTEST(ICODE,12-K),K=1,12),
389! . " idble=", IDBLE, " ",(BTEST(IDBLE,12-K),K=1,12)
390! do K=1,SecTypeList(0)
391! J = SecTypeList(K)
392! print *, J, StrCODE(J)
393! enddo
394! endif
395! endif
396
397
398 IF(SecTypeList(0)==0)CYCLE !next IB
399 IF(ICODE==0)CYCLE !next IB
400
401
402
403
404
405
406! TAB(1:12) = (/(BTEST(IDBLE,12-J),J=1,12)/)
407! NINTP = NBITS + (SUM(IABS(TAB)))
408 NINTP = NBITS + POPCNT(IDBLE)
409
410 LIST_VAR(1:SizeL) = LIST(1:SizeL)
411 SizeLVAR = SizeL
412 SizeLFIX = 0
413
414 RESULT(:) = 0
415 bFOUND = .FALSE.
416
417 !db
418 brickID = IXS(11,BRICK_LIST(NIN,I)%ID)
419 db_WRITE = .FALSE.
420
421 IF(SIZEL==1)THEN
422 IF(ICODE/=IDBLE)THEN
423 IF(IDBLE == 0)THEN
424 RESULT(1) = LIST(1)
425 RESULT(2) = 0
426 bFOUND = .TRUE.
427 ELSE
428 print *, "**warning inter22 : unused intersection points
for this element
",brickID
429 db_WRITE = .TRUE.
430 RESULT(1) = LIST(1)
431 RESULT(2) = 0
432 bFOUND = .TRUE.
433 ENDIF
434 ELSE
435 !ICODE/=IDBLE
436 RESULT(1) = LIST(1)
437 RESULT(2) = LIST(1)
438 bFOUND = .TRUE.
439 ENDIF
440.AND..AND..OR..AND. ELSEIF(SIZEL==2 ((LIST(1)>=45LIST(1)<=49) (LIST(1)>=51LIST(1)<=57)))THEN !sigle hexae or poly4
441 IF(LIST(2) == LIST(1)+1)THEN
442 IF( ICODE==IDBLE )THEN
443 bFOUND = .TRUE.
444 RESULT(1:2) = LIST(1:2)
445 RESULT(3) = 0
446 ELSEIF(IDBLE==0)THEN
447 bFOUND = .TRUE.
448 RESULT(1) = LIST(1)
449 RESULT(2) = 0
450 ELSE
451 print *, "**warning inter22 : unused intersection points
for this element
",brickID
452 db_WRITE = .TRUE.
453 ENDIF
454 ENDIF
455 ELSE!IF(ICODE/=IDBLE)THEN !including twice the same polyhedron (now it takes automatically the complmentary since previous ChangeList)
456 CALL INT22LISTCOMBI(ITASK,LIST_FIX,SizeLFIX,LIST_VAR,SizeLVAR,NINTP,ICODE,IDBLE,0,RESULT,bFOUND)
457.NOT..AND. if((bFOUND)SIZEL==1)then
458 bFOUND = .TRUE.
459 RESULT(1) = LIST(1)
460 RESULT(2) = 0
461.NOT..AND. elseif((bFOUND)SIZEL>1)then
462 ! if( GetPolyhedraType(LIST(1)) /= GetPolyhedraType(LIST(2)) )then
463 !!!!!!!print *, " *** warning inter22 : simplifying intersection",brickID
464 bFOUND = .TRUE.
465 RESULT(1) = LIST( MAXLOC(LIST(1:SIZEL),1) )
466 RESULT(2) = 0
467 !CALL ARRET(2)
468 ! else
469 ! CALL REMOVE_DOUBLE_INTP(
470 ! 1 IXS, X, ITASK, NIN, BUFBRIC,
471 ! 2 IB )
472 ! print *, " cell
id exiting removing double
interp:
",IXS(11,BRICK_LIST(NIN,I)%ID)
473 ! Iremoved = Iremoved +1
474 ! IF(Iremoved<=1)GOTO 10
475 ! endif
476 endif
477 ENDIF
478
479.EQV. IF(db_WRITE .TRUE.)THEN
480 !!------output intersection points!!
481 !print *, " ",IXS(11,brick_list(nin,i)%id)
482 DO J=1,12
483 IAD = (I-1)*12+J
484 NBCUT = EDGE_LIST(NIN,IAD)%NBCUT
485 DO K=1,NBCUT
486 !on ecrit les coordonnees des intersections aux edges
487 CUTCOOR = EDGE_LIST(NIN,IAD)%CUTCOOR(K)
488 POINT(1:3) = X(1:3, EDGE_LIST(NIN,IAD)%NODE(1) ) + CUTCOOR * (EDGE_LIST(NIN,IAD)%VECTOR(1:3))
489 END DO ! (DO K=1,NBCUT <=> NBCUT>0)
490 ENDDO
491 !!---------------
492 ENDIF
493
494 IF(bFOUND)THEN
495
496.AND. !if(itask==0debug_outp)then
497.or. ! if(ibug22_ident==-1 ibug22_ident==ixs(11,brick_list(nin,ib)%id))print *, " final"
498.or. ! if(ibug22_ident==-1 ibug22_ident==ixs(11,brick_list(nin,ib)%id))print *, "result(1:8)=",RESULT(1:8)
499 !endif
500 J = 1
501 CODE = RESULT(J)
502 DO WHILE(CODE/=0)
503 BRICK_LIST(NIN,I)%SecID_Cell(J) = CODE
504 BRICK_LIST(NIN,I)%SECTYPE(J) = StrCODE(IABS(CODE))
505 J = J + 1
506 IF(J==9)EXIT
507 CODE = RESULT(J)
508 ENDDO
509 BRICK_LIST(NIN,I)%NBCUT = J-1
510 ELSE
511.AND. ! if(itask==0debug_outp)then
512.or..and. ! if(ibug22_ident==-1 ibug22_ident==ixs(11,brick_list(nin,ib)%id) icode/=0)print *,
513 ! . " no intersection detected"
514 ! endif
515 ENDIF
516.AND. ! if(itask==0debug_outp) then
517.or. ! if(ibug22_ident==-1 ibug22_ident==ixs(11,brick_list(nin,ib)%id)) then
518 ! print *, ""
519 ! print *, ""
520 ! print *, ""
521 ! endif
522 ! endif
523
524
525
526
527 !done in i22subol.F
528
529
530
531 END DO !I=NBF,NBL
532
533
534
535
536 CALL MY_BARRIER !pour affichage complet dans lordre par itask 0
537
538 if(debug_outp)then
539.or. if(ibug22_ident==-1 ibug22_ident==ixs(11,brick_list(nin,ib)%id))then
540
541 !idb1(i) is dependent on ITASK, cannot loop on I=1,NB
542
543 call my_barrier
544 if(itask==0)then
545 do I=NBF,NBL
546 ICODE=BRICK_LIST(NIN,I)%ICODE
547 NBITS=BRICK_LIST(NIN,I)%Nbits
548 NPQTS=BRICK_LIST(NIN,I)%Npqts
549 print *, " cell
id -:
",IXS(11,BRICK_LIST(NIN,I)%ID)
550 WRITE(*,FMT='(A20,I10,A4,I10)') " edges add from ",idb1(i)," to ",idb2(i)
551 WRITE(*,FMT='(A11,I4,A20,I2,A1,I1,A1)') " icode=", ICODE, " (nbits,npqts) = (", NBITS,",",NPQTS,")"
552 WRITE(*,FMT='(A11,I4,A20,I2,A1,I1,A1)') " idble=", IDBLE
553 WRITE(*,FMT='(A,I1)') " num planes=" , BRICK_LIST(NIN,I)%NBCUT
554 do j=1,BRICK_LIST(NIN,I)%NBCUT
555 dbKEY1(:)=BRICK_LIST(NIN,I)%SECTYPE(j)
556 if(dbKEY1(1:1)=='-') then
557 WRITE(*,FMT='(A)') " --> none"
558 else
559 WRITE(*,FMT='(A,A)') " -->",dbKEY1(1:14)
560 end if
561 enddo
562 end do
563 endif
564 call my_barrier
565 if(itask==1)then
566 do I=NBF,NBL
567 ICODE=BRICK_LIST(NIN,I)%ICODE
568 NBITS=BRICK_LIST(NIN,I)%Nbits
569 NPQTS=BRICK_LIST(NIN,I)%Npqts
570 print *, " brique
id -:
",IXS(11,BRICK_LIST(NIN,I)%ID)
571 WRITE(*,FMT='(A20,I10,A4,I10)') " edges add from ",idb1(i)," to ",idb2(i)
572 WRITE(*,FMT='(A11,I4,A20,I2,A1,I1,A1)') " icode=", ICODE, " (nbits,npqts) = (", NBITS,",",NPQTS,")"
573 WRITE(*,FMT='(A,I1)') " num planes=" , BRICK_LIST(NIN,I)%NBCUT
574 do j=1,BRICK_LIST(NIN,I)%NBCUT
575 dbKEY1(:)=BRICK_LIST(NIN,I)%SECTYPE(j)
576 if(dbKEY1(1:1)=='-') then
577 WRITE(*,FMT='(A)') " --> none"
578 else
579 WRITE(*,FMT='(A,A)') " -->",dbKEY1(1:14)
580 end if
581 enddo
582 end do
583 endif
584 ! call my_barrier
585 ! if(itask==2)then
586 ! endif
587 ! ...
588 end if
589 endif
590
591
592
593
594
595
596
597
598 RETURN
599
subroutine i22ident(ixs, x, itask, nin, bufbric)
subroutine i22gbit(iad, icode, idble, nbits, npqts, idb1, idb2, nin)
subroutine interp(tf, tt, npoint, f, tg)
for(i8=*sizetab-1;i8 >=0;i8--)
type(brick_entity), dimension(:,:), allocatable, target brick_list