OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
bigbox.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!|| bigbox ../starter/source/model/box/bigbox.F
25!||--- calls -----------------------------------------------------
26!|| ancmsg ../starter/source/output/message/message.F
27!|| boxbox ../starter/source/model/box/boxbox.F
28!|| boxtagn ../starter/source/model/box/bigbox.F
29!||--- uses -----------------------------------------------------
30!|| format_mod ../starter/share/modules1/format_mod.F90
31!|| message_mod ../starter/share/message_module/message_mod.F
32!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
33!||====================================================================
34 SUBROUTINE bigbox(X ,FLAG,NNOD ,
35 . SKEW,IGS ,ISKN ,ITABM1,IBOX ,
36 . ID ,IBUFBOX,IADB ,TITR,KEY,NN,
37 . IBOXMAX,IGRNOD)
38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE groupdef_mod
42 USE optiondef_mod
43 USE message_mod
44 USE names_and_titles_mod , ONLY : nchartitle, ncharfield
45 USE format_mod , ONLY : fmt_i
46 USE reader_old_mod , ONLY : line, irec
47C-----------------------------------------------
48C I m p l i c i t T y p e s
49C-----------------------------------------------
50#include "implicit_f.inc"
51C-----------------------------------------------
52C C o m m o n B l o c k s
53C-----------------------------------------------
54#include "com04_c.inc"
55#include "scr17_c.inc"
56#include "units_c.inc"
57#include "param_c.inc"
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER FLAG,NNOD,
62 . IGS,ISKN(LISKN,*),ITABM1(*),
63 . ID,IBUFBOX(*),IADB,NN,IBOXMAX
64 my_real
65 . x(3,*),skew(lskew,*)
66 CHARACTER(LEN=NCHARTITLE) :: TITR
67 CHARACTER(LEN=NCHARFIELD) :: KEY
68 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
69 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
70C-----------------------------------------------
71C L o c a l V a r i a b l e s
72C-----------------------------------------------
73 INTEGER I,J,K,N,ISU,JREC,IDB,NBOX,BOXTYPE,IADBOX,
74 . ICOUNT,ITER,FLAGG,INBOX,BOXNODS,IADISU
75 CHARACTER BOX*3
76 LOGICAL BOOL
77C-----------------------------------------------
78 DO i=1,nbbox
79 ibox(i)%NBLEVELS = 0
80 ibox(i)%LEVEL = 1
81 ibox(i)%ACTIBOX = 0
82 IF(ibox(i)%NBOXBOX > 0)THEN
83 ibox(i)%NBLEVELS = -1
84 ibox(i)%LEVEL = 0
85 END IF
86C
87 ibox(i)%BOXIAD = 0
88 END DO
89C-------
90 jrec=irec+1
91 READ(iin,rec=jrec,err=999,fmt='(A)')line
92 READ(line,err=999,fmt=fmt_i) idb
93C-------
94C get box de box ID'S dans grnod:
95C-------
96 isu = 0
97 DO i=1,nbbox
98 IF(idb == ibox(i)%ID) isu=i
99 END DO
100C---
101 IF(isu > 0)THEN
102 nbox = ibox(isu)%NBOXBOX
103C super box activated:
104 ibox(isu)%ACTIBOX = 1
105 ELSE
106 IF(flag == 0)THEN
107 CALL ancmsg(msgid=794,
108 . msgtype=msgerror,
109 . anmode=aninfo,
110 . i1=id,
111 . c1=titr,
112 . i2=idb)
113 END IF
114 END IF
115C---
116C simple box dans grnod:
117C---
118 bool = .false.
119 IF(isu>0)THEN
120 IF(ibox(isu)%NBLEVELS == 0 .AND. ibox(isu)%LEVEL == 1) THEN
121 IF(nbox == 0)THEN
122 CALL boxtagn(x ,ibufbox,skew,iadb,ibox,isu ,flag,iboxmax)
123 bool =.true.
124 END IF
125 END IF
126 ENDIF
127C---
128C READ LEVELS OF BOXES ==> "SUBLEVEL DONE"
129C---
130 IF(.NOT.bool)THEN
131 icount = 1
132 iter = 0
133 DO WHILE (icount == 1)
134 iter = iter + 1
135 flagg = 0
136C--- count next level
137 CALL boxbox(ibox ,skew ,
138 . flagg ,icount,iter ,ibufbox,
139 . x ,iadb ,id ,titr ,
140 . key ,flag ,iboxmax)
141C--- fill next level
142 flagg = 1
143 CALL boxbox(ibox ,skew ,
144 . flagg ,icount,iter ,ibufbox,
145 . x ,iadb ,id ,titr ,
146 . key ,flag ,iboxmax)
147C---
148 ENDDO
149 ENDIF
150C---
151C tag group nodes in main-box:
152C---
153 IF(isu > 0)THEN
154 IF(flag == 0)THEN
155 boxnods = ibox(isu)%NENTITY ! nodes of main box
156 nnod = boxnods
157 ELSE IF(flag == 1)THEN
158 boxnods = ibox(isu)%NENTITY ! nodes of main box
159 iadisu = ibox(isu)%BOXIAD ! addresses of nodes in main box
160 nnod = boxnods
161 DO i=1,boxnods
162 n=ibufbox(iadisu+i-1)
163 nn = nn + 1
164 igrnod(igs)%ENTITY(nn) = n
165 END DO
166 END IF
167 END IF
168C--------------
169 RETURN
170 999 CALL freerr(1)
171 RETURN
172 END
173!||====================================================================
174!|| boxtagn ../starter/source/model/box/bigbox.F
175!||--- called by ------------------------------------------------------
176!|| bigbox ../starter/source/model/box/bigbox.F
177!|| boxbox ../starter/source/model/box/boxbox.F
178!|| hm_bigbox ../starter/source/model/box/hm_bigbox.F
179!||--- calls -----------------------------------------------------
180!|| checkcyl ../starter/source/model/box/rdbox.F
181!|| checkpara ../starter/source/model/box/rdbox.F
182!|| checksphere ../starter/source/model/box/rdbox.F
183!||--- uses -----------------------------------------------------
184!|| message_mod ../starter/share/message_module/message_mod.F
185!||====================================================================
186 SUBROUTINE boxtagn(X ,IBUFBOX,SKEW,IADB,
187 . IBOX,ISU ,FLAG,IBOXMAX)
188C-----------------------------------------------
189C M o d u l e s
190C-----------------------------------------------
191 USE my_alloc_mod
192 USE message_mod
193 USE optiondef_mod
194C-----------------------------------------------
195C I m p l i c i t T y p e s
196C-----------------------------------------------
197#include "implicit_f.inc"
198C-----------------------------------------------
199C C o m m o n B l o c k s
200C-----------------------------------------------
201#include "com04_c.inc"
202#include "param_c.inc"
203C-----------------------------------------------
204C D u m m y A r g u m e n t s
205C-----------------------------------------------
206 INTEGER IBUFBOX(*),IADB,ISU,FLAG,IBOXMAX
207 my_real
208 . X(3,*),SKEW(LSKEW,*)
209 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
210C-----------------------------------------------
211C L o c a l V a r i a b l e s
212C-----------------------------------------------
213 INTEGER I,J,K,OK,ISK,IDBX,BOXNOD,BOXNOD_L,
214 . IADB0,JAD,ITYPE
215 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGN
216 my_real
217 . xp1,yp1,zp1,xp2,yp2,zp2,diam,nodinb(3)
218C-----------------------------------------------
219 ok = 0
220 boxnod = 0
221 iadb0 = iadb
222 ALLOCATE( tagn(numnod) )
223!$OMP PARALLEL DO SCHEDULE(guided)
224 DO i=1,numnod
225 tagn(i) = 0
226 ENDDO
227!$OMP END PARALLEL DO
228C-------
229 idbx = ibox(isu)%ID
230 isk = ibox(isu)%ISKBOX
231 itype= ibox(isu)%TYPE
232 diam = ibox(isu)%DIAM
233 xp1 = ibox(isu)%X1
234 yp1 = ibox(isu)%Y1
235 zp1 = ibox(isu)%Z1
236 xp2 = ibox(isu)%X2
237 yp2 = ibox(isu)%Y2
238 zp2 = ibox(isu)%Z2
239C
240 IF(idbx/=0)THEN
241!$OMP PARALLEL PRIVATE(OK,NODINB,BOXNOD_L)
242 boxnod_l = 0
243!$OMP DO SCHEDULE(guided)
244 DO i=1,numnod
245 ok = 0
246 nodinb(1) = x(1,i)
247 nodinb(2) = x(2,i)
248 nodinb(3) = x(3,i)
249 IF(itype == 1)THEN ! 'RECTA'
250 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
251 . isk,nodinb,skew,ok)
252 ELSE IF(itype == 2)THEN ! 'CYLIN'
253 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
254 . nodinb , diam, ok )
255 ELSE IF(itype == 3)THEN ! 'SPHER'
256 CALL checksphere(xp1, yp1, zp1, nodinb, diam, ok)
257 END IF
258C
259C tag nodes dans box:
260C
261 IF(ok == 1)THEN
262 IF(tagn(i) == 0)THEN
263 boxnod_l=boxnod_l+1
264 tagn(i) = 1
265 END IF
266 END IF
267 END DO
268!$OMP END DO
269
270!$OMP ATOMIC
271 boxnod = boxnod + boxnod_l
272!$OMP END PARALLEL
273C
274 ibox(isu)%NENTITY = boxnod
275 ibox(isu)%BOXIAD = iadb0
276 END IF
277C---------------
278 IF (flag == 0) THEN
279 DO i=1,numnod
280 IF(tagn(i) == 1)THEN
281 iadb = iadb + 1
282 END IF
283 END DO
284 ELSEIF (flag == 1) THEN
285 DO i=1,numnod
286 IF(tagn(i) == 1)THEN
287 ibufbox(iadb) = i
288 iadb = iadb + 1
289 END IF
290 END DO
291 ENDIF
292 DEALLOCATE( tagn )
293C---------------
294 RETURN
295 END
296!||====================================================================
297!|| boxassem1 ../starter/source/model/box/bigbox.F
298!||--- called by ------------------------------------------------------
299!|| boxbox ../starter/source/model/box/boxbox.F
300!||--- uses -----------------------------------------------------
301!|| message_mod ../starter/share/message_module/message_mod.F
302!||====================================================================
303 SUBROUTINE boxassem1(IBOX,IBUFBOX,IB,IADB,FLAG)
304C-----------------------------------------------
305C M o d u l e s
306C-----------------------------------------------
307 USE message_mod
308 USE optiondef_mod
309C-----------------------------------------------
310C I m p l i c i t T y p e s
311C-----------------------------------------------
312#include "implicit_f.inc"
313C-----------------------------------------------
314C C o m m o n B l o c k s
315C-----------------------------------------------
316#include "com04_c.inc"
317C-----------------------------------------------
318C D u m m y A r g u m e n t s
319C-----------------------------------------------
320 INTEGER IBUFBOX(*),IB,IADB,FLAG
321 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
322C-----------------------------------------------
323C L o c a l V a r i a b l e s
324C-----------------------------------------------
325 INTEGER I,J,K,N,TAGPOS(NUMNOD),TAGNEG(NUMNOD),
326 . TAGN(NUMNOD),BOXNOD,IADB0,IADBOX,IDBX,NBOX,
327 . JAD,IBS,BOXNODS
328C-----------------------------------------------
329 tagpos(1:numnod) = 0
330 tagneg(1:numnod) = 0
331 tagn(1:numnod) = 0
332C
333C assembly of sub-lelevs:
334C
335C---------------
336 boxnod = 0
337 iadb0 = iadb
338 nbox = ibox(ib)%NBOXBOX
339 boxnods = 0
340C
341 IF (flag == 0) THEN
342 DO k=1,nbox
343 j = ibox(ib)%IBOXBOX(k)
344 ibs = abs(j)
345 idbx = ibox(ibs)%ID
346 IF (idbx /= 0) boxnods = boxnods + ibox(ibs)%NENTITY ! nodes of sub-box
347 ENDDO
348 iadb = iadb + boxnods
349C
350 ibox(ib)%NENTITY=boxnods
351 ibox(ib)%BOXIAD=iadb0
352 IF (ibox(ib)%ACTIBOX == 0) ibox(ib)%ACTIBOX = 1
353 ELSEIF (flag == 1) THEN
354C---
355C tag nodes of positive boxes:
356C---
357 DO k=1,nbox
358 j = ibox(ib)%IBOXBOX(k)
359 ibs = abs(j)
360 idbx = ibox(ibs)%ID
361 boxnods = ibox(ibs)%NENTITY ! nodes of sub-box
362 jad = ibox(ibs)%BOXIAD ! address of nodes
363C---
364 IF(idbx/=0 .and. j > 0)THEN
365 DO i=1,boxnods
366 n = ibufbox(jad+i-1)
367 IF(tagpos(n) == 0)THEN
368 tagpos(n) = 1
369 END IF
370 END DO
371 END IF
372 END DO
373C---
374C tag nodes of negative boxes:
375C---
376 DO k=1,nbox
377 j = ibox(ib)%IBOXBOX(k)
378 ibs = abs(j)
379 idbx = ibox(ibs)%ID
380 boxnods = ibox(ibs)%NENTITY ! nodes of sub-box
381 jad = ibox(ibs)%BOXIAD ! address of nodes
382C---
383 IF(idbx/=0 .and. j < 0)THEN
384 DO i=1,boxnods
385 n = ibufbox(jad+i-1)
386 IF(tagneg(n) == 0)THEN
387 tagneg(n) = 1
388 END IF
389 END DO
390 END IF
391 END DO
392C----------------
393C final combination (+/-) assembly in sublevel:
394C----------------
395 DO i=1,numnod
396 IF(tagpos(i) > 0 .and. tagneg(i) == 0)tagn(i) = 1
397 END DO
398C
399 DO i=1,numnod
400 IF(tagn(i) == 1)THEN
401 boxnod=boxnod+1
402 END IF
403 END DO
404 ibox(ib)%NENTITY=boxnod
405 ibox(ib)%BOXIAD=iadb0
406 IF(ibox(ib)%ACTIBOX == 0) ibox(ib)%ACTIBOX = 1
407C
408C final tag of nodes within box:
409C
410 DO i=1,numnod
411 IF(tagn(i) == 1)THEN
412 ibufbox(iadb) = i
413 iadb = iadb + 1
414 END IF
415 END DO
416 ENDIF ! IF(FLAG == 0)
417C------------
418 RETURN
419 END
420!||====================================================================
421!|| boxassem2 ../starter/source/model/box/bigbox.F
422!||--- called by ------------------------------------------------------
423!|| boxbox2 ../starter/source/model/box/boxbox.F
424!||--- uses -----------------------------------------------------
425!|| message_mod ../starter/share/message_module/message_mod.F
426!||====================================================================
427 SUBROUTINE boxassem2(IBOX,IBUFBOX,IB,IADB,NUMEL,FLAG,IBOXMAX)
428C-----------------------------------------------
429C M o d u l e s
430C-----------------------------------------------
431 USE message_mod
432 USE optiondef_mod
433C-----------------------------------------------
434C I m p l i c i t T y p e s
435C-----------------------------------------------
436#include "implicit_f.inc"
437C-----------------------------------------------
438C C o m m o n B l o c k s
439C-----------------------------------------------
440#include "com04_c.inc"
441C-----------------------------------------------
442C D u m m y A r g u m e n t s
443C-----------------------------------------------
444 INTEGER IB,NUMEL,FLAG,IBOXMAX,IADB,IBUFBOX(*)
445 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
446C-----------------------------------------------
447C L o c a l V a r i a b l e s
448C-----------------------------------------------
449 INTEGER I,J,JJ,K,N,TAGPOS(NUMEL),TAGNEG(NUMEL),
450 . TAGN(NUMEL),IADB0,IADBOX,IDBX,NBOX,JAD,IBS,
451 . BOXELE0,BOXELE
452C-----------------------------------------------
453 tagpos(1:numel) = 0
454 tagneg(1:numel) = 0
455 tagn(1:numel) = 0
456C
457C assembly of sub-lelevs:
458C
459C---------------
460 boxele = 0
461 iadb0 = iadb
462 nbox = ibox(ib)%NBOXBOX
463C
464 boxele0 = 0
465 IF (flag == 0) THEN
466 DO k=1,nbox
467 j = ibox(ib)%IBOXBOX(k)
468 ibs = abs(j)
469 idbx = ibox(ibs)%ID
470 IF (idbx /= 0) boxele0 = boxele0 + ibox(ibs)%NENTITY ! elements of sub-box
471 ENDDO
472 iadb = iadb + boxele0
473C
474 ibox(ib)%NENTITY=boxele0
475 ibox(ib)%BOXIAD=iadb0 ! address of elements
476 IF (ibox(ib)%ACTIBOX == 0) ibox(ib)%ACTIBOX = 1
477 ELSEIF (flag == 1) THEN
478C---
479C tag elements of positive boxes:
480C---
481 DO k=1,nbox
482 j = ibox(ib)%IBOXBOX(k)
483 ibs = abs(j)
484 idbx = ibox(ibs)%ID
485 boxele0 = ibox(ibs)%NENTITY ! elements of sub-box
486 jad = ibox(ibs)%BOXIAD ! address of nodes
487C---
488 IF(idbx/=0 .and. j > 0)THEN
489 DO i=1,boxele0
490 jj = ibufbox(jad+i-1)
491 IF(tagpos(jj) == 0)THEN
492 tagpos(jj) = 1
493 END IF
494 END DO
495 END IF
496 END DO
497C---
498C tag elements of negative boxes:
499C---
500 DO k=1,nbox
501 j = ibox(ib)%IBOXBOX(k)
502 ibs = abs(j)
503 idbx = ibox(ibs)%ID
504 boxele0 = ibox(ibs)%NENTITY ! elements of sub-box
505 jad = ibox(ibs)%BOXIAD ! address of nodes
506C---
507 IF(idbx/=0 .and. j < 0)THEN
508 DO i=1,boxele0
509 jj = ibufbox(jad+i-1)
510 IF(tagneg(jj) == 0)THEN
511 tagneg(jj) = 1
512 END IF
513 END DO
514 END IF
515 END DO
516C----------------
517C final combination (+/-) assembly in sublevel:
518C----------------
519 DO i=1,numel
520 IF(tagpos(i) > 0 .and. tagneg(i) == 0)tagn(i) = 1
521 END DO
522C
523 DO i=1,numel
524 IF(tagn(i) == 1)THEN
525 boxele=boxele+1
526 END IF
527 END DO
528 ibox(ib)%NENTITY=boxele
529 ibox(ib)%BOXIAD=iadb0
530 IF(ibox(ib)%ACTIBOX == 0) ibox(ib)%ACTIBOX = 1
531C
532C final tag of elements within box:
533C
534 DO i=1,numel
535 IF(tagn(i) == 1)THEN
536 ibufbox(iadb) = i
537 iadb = iadb + 1
538 END IF
539 END DO
540 ENDIF ! IF (FLAG == 0) THEN
541C------------
542 RETURN
543 END
544!||====================================================================
545!|| boxassem3 ../starter/source/model/box/bigbox.F
546!||--- called by ------------------------------------------------------
547!|| boxboxs ../starter/source/model/box/boxbox.F
548!||--- uses -----------------------------------------------------
549!|| message_mod ../starter/share/message_module/message_mod.F
550!||====================================================================
551 SUBROUTINE boxassem3(IBOX,IBUFBOX,IB ,IADB ,NUMEL ,
552 . NIX ,IX ,NIX1 ,NIX2,ISURF0,IELTYP,
553 . FLAG ,IEXT)
554C-----------------------------------------------
555C M o d u l e s
556C-----------------------------------------------
557 USE message_mod
558 USE optiondef_mod
559C-----------------------------------------------
560C I m p l i c i t T y p e s
561C-----------------------------------------------
562#include "implicit_f.inc"
563C-----------------------------------------------
564C C o m m o n B l o c k s
565C-----------------------------------------------
566#include "com04_c.inc"
567C-----------------------------------------------
568C D u m m y A r g u m e n t s
569C-----------------------------------------------
570 INTEGER IBUFBOX(*),IB,IADB,
571 . NUMEL,NIX,IX(NIX,*),NIX1,NIX2,ISURF0,IELTYP,
572 . FLAG,IEXT
573 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
574C-----------------------------------------------
575C L o c a l V a r i a b l e s
576C-----------------------------------------------
577 INTEGER I,J,JJ,K,N,TAGPOS(NUMEL),TAGNEG(NUMEL),
578 . TAGN(NUMEL),IADB0,IADBOX,IDBX,NBOX,
579 . jad,ibs,boxseg0,boxseg,dif_nix,kad,pos_iext
580C-----------------------------------------------
581 dif_nix = 6
582 IF (isurf0 == 0) dif_nix = 4
583!
584 pos_iext = 0
585 IF (iext > 0) THEN
586 dif_nix = dif_nix + 1
587 pos_iext = 1
588 ENDIF
589C
590 tagpos(1:numel) = 0
591 tagneg(1:numel) = 0
592 tagn(1:numel) = 0
593C
594C assembly of sub-lelevs:
595C
596C---------------
597 boxseg = 0
598 iadb0 = iadb
599 nbox = ibox(ib)%NBOXBOX
600C
601 boxseg0 = 0
602 IF (flag == 0) THEN
603 DO k=1,nbox
604 j = ibox(ib)%IBOXBOX(k)
605 ibs = abs(j)
606 idbx = ibox(ibs)%ID
607 IF (idbx /= 0)
608 . boxseg0 = boxseg0 + ibox(ibs)%NENTITY ! seg of sub-box
609 ENDDO
610C
611 IF (isurf0 == 0) THEN ! seg line
612 iadb = iadb + boxseg0*4
613 IF(iext > 0) iadb = iadb + boxseg0
614 ELSEIF (isurf0 == 1) THEN ! seg surf
615 iadb = iadb + boxseg0*6
616 IF(iext > 0) iadb = iadb + boxseg0
617 ENDIF
618C
619 ibox(ib)%NENTITY=boxseg0
620 ibox(ib)%BOXIAD=iadb0
621 IF (ibox(ib)%ACTIBOX == 0) ibox(ib)%ACTIBOX = 1
622 ELSEIF (flag == 1) THEN
623C---
624C tag elements (for line defining) of positive boxes:
625C---
626 DO k=1,nbox
627 j = ibox(ib)%IBOXBOX(k)
628 ibs = abs(j)
629 idbx = ibox(ibs)%ID
630 boxseg0 = ibox(ibs)%NENTITY ! elements of sub-box
631 jad = ibox(ibs)%BOXIAD ! address of elements
632C---
633 IF(idbx/=0 .and. j > 0)THEN
634 DO i=1,boxseg0
635!! JJ = IBUFBOX(JAD+DIF_NIX-1) ! tag element
636 kad = jad - 1 + dif_nix - pos_iext
637 jj = ibufbox(kad) ! tag element
638! JJ = IBOX(IBS)%ENTITY(I)
639 jad = jad + dif_nix
640 IF(tagpos(jj) == 0)THEN
641 tagpos(jj) = 1
642 END IF
643 END DO
644 END IF
645 END DO
646C---
647C tag elements (for line defining) of negative boxes:
648C---
649 DO k=1,nbox
650 j = ibox(ib)%IBOXBOX(k)
651 ibs = abs(j)
652 idbx = ibox(ibs)%ID
653 boxseg0 = ibox(ibs)%NENTITY ! elements of sub-box
654 jad = ibox(ibs)%BOXIAD ! address of elements
655C---
656 IF(idbx/=0 .and. j < 0)THEN
657 DO i=1,boxseg0
658!! JJ = IBUFBOX(JAD+DIF_NIX-1) ! tag element
659 kad = jad - 1 + dif_nix - pos_iext
660 jj = ibufbox(kad) ! tag element
661 jad = jad + dif_nix
662 IF(tagneg(jj) == 0)THEN
663 tagneg(jj) = 1
664 END IF
665 END DO
666 END IF
667 END DO
668C----------------
669C final combination (+/-) assembly in sublevel:
670C----------------
671 DO i=1,numel
672 IF(tagpos(i) > 0 .and. tagneg(i) == 0)tagn(i) = 1
673 END DO
674C
675 DO i=1,numel
676 IF(tagn(i) == 1)THEN
677 boxseg=boxseg+1
678 END IF
679 END DO
680 ibox(ib)%NENTITY=boxseg
681 ibox(ib)%BOXIAD=iadb0
682 IF(ibox(ib)%ACTIBOX == 0) ibox(ib)%ACTIBOX = 1
683C
684C final tag of lines within box:
685C
686 DO i=1,numel
687 IF(tagn(i) == 1)THEN
688 IF(isurf0 == 1)THEN
689 DO k=nix1,nix2
690 ibufbox(iadb) = ix(k,i)
691 iadb = iadb + 1
692 ENDDO
693 ELSE
694 ibufbox(iadb) = ix(nix1,i)
695 iadb = iadb + 1
696 ibufbox(iadb) = ix(nix2,i)
697 iadb = iadb + 1
698 END IF
699 IF(ieltyp == 7)THEN
700 ibufbox(iadb) = ibufbox(iadb-1)
701 iadb = iadb + 1
702 END IF
703 ibufbox(iadb)=ieltyp
704 iadb = iadb + 1
705 ibufbox(iadb)=i
706 iadb = iadb + 1
707!
708 IF (iext > 0) THEN
709 ibufbox(iadb)=iext
710 iadb = iadb + 1
711 ENDIF
712 END IF
713 END DO
714 ENDIF ! IF (FLAG == 0) THEN
715C------------
716 RETURN
717 END
718!||====================================================================
719!|| boxassem4 ../starter/source/model/box/bigbox.F
720!||--- called by ------------------------------------------------------
721!|| elstagboxbox ../starter/source/model/box/boxbox.F
722!||--- calls -----------------------------------------------------
723!|| iface ../starter/source/ale/ale3d/iface.F
724!||--- uses -----------------------------------------------------
725!|| message_mod ../starter/share/message_module/message_mod.F
726!||====================================================================
727 SUBROUTINE boxassem4(IBOX,IBUFBOX,IB,IADB,FLAG,IEXT_SET)
728C-----------------------------------------------
729C M o d u l e s
730C-----------------------------------------------
731 USE message_mod
732 USE optiondef_mod
733C-----------------------------------------------
734C I m p l i c i t T y p e s
735C-----------------------------------------------
736#include "implicit_f.inc"
737C-----------------------------------------------
738C C o m m o n B l o c k s
739C-----------------------------------------------
740#include "com04_c.inc"
741#include "param_c.inc"
742C-----------------------------------------------
743C D u m m y A r g u m e n t s
744C-----------------------------------------------
745 INTEGER IBUFBOX(*),IB,IADB,FLAG,IEXT_SET
746 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
747C-----------------------------------------------
748C L o c a l V a r i a b l e s
749C-----------------------------------------------
750 INTEGER I,J,JJ,K,N,JJ_OLD,IADB0,IADBOX,IDBX,NBOX,IS,IIS,r,
751 . jad,ibs,boxseg0,boxseg,dif_nix,
752 . nod(4),nold(4),fac,nfac,idel,jface,
753 . nface,pos_iext,kad
754 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: ELFACE
755 INTEGER, DIMENSION(:,:), ALLOCATABLE :: TAGFACES, POSFACE, NEGFACE
756 INTEGER, DIMENSION(:), ALLOCATABLE :: TAG8, TAG10, IFACE
757C-----------------------------------------------
758
759 ALLOCATE(ELFACE(4,16,NUMELS),TAGFACES(16,NUMELS))
760 ALLOCATE(posface(16,numels),negface(16,numels))
761 ALLOCATE(tag8(numels),tag10(numels),iface(numels))
762
763 dif_nix = nisx
764 pos_iext = 0
765 IF (iext_set > 0) THEN
766 dif_nix = dif_nix + 1 ! for IEXT_SET
767 pos_iext = 1
768 ENDIF
769C
770 DO i=1,numels
771 iface(i) = 0
772 DO j=1,16
773 elface(1,j,i) = 0
774 elface(2,j,i) = 0
775 elface(3,j,i) = 0
776 elface(4,j,i) = 0
777C
778 tagfaces(j,i) = 0
779 posface(j,i) = 0
780 negface(j,i) = 0
781 END DO
782 END DO
783C
784 DO i=1,numels8
785 tag8(i) = 1
786 END DO
787C
788 DO i=1,numels10
789 j = i+numels8
790 tag10(j) = 1
791 END DO
792C-----------------------
793C assembly of sub-lelevs:
794C-----------------------
795 boxseg = 0
796 iadb0 = iadb
797 nbox = ibox(ib)%NBOXBOX
798C
799 boxseg0 = 0
800 IF (flag == 0) THEN
801 DO k=1,nbox
802 j = ibox(ib)%IBOXBOX(k)
803 ibs = abs(j)
804 idbx = ibox(ibs)%ID
805 IF (idbx /= 0) boxseg0 = boxseg0 + ibox(ibs)%NENTITY ! faces of sub-box
806 iadb = iadb + boxseg0
807C
808 DO j=1,numels
809 nface = 4
810 IF(tag10(j) == 1) nface = 16
811 DO is=1,nface
812 iadb = iadb + 6
813 IF (iext_set > 0) iadb = iadb + 1 ! for IEXT_SET
814 ENDDO
815 ENDDO
816 ENDDO ! DO K=1,NBOX
817C
818 ibox(ib)%NENTITY=boxseg0
819 ibox(ib)%SURFIAD=iadb0
820 IF (ibox(ib)%ACTIBOX == 0) ibox(ib)%ACTIBOX = 1
821 ELSEIF (flag == 1) THEN
822C---------------
823C solide 8 + 10
824C---------------
825C---
826C tag elements of positive boxes:
827C---
828 DO k=1,nbox
829 j = ibox(ib)%IBOXBOX(k)
830 ibs = abs(j)
831 idbx = ibox(ibs)%ID
832 boxseg0 = ibox(ibs)%NENTITY ! faces of sub-box
833 jad = ibox(ibs)%SURFIAD ! address of faces
834C---
835 IF(idbx/=0 .and. j > 0)THEN
836 DO i=1,boxseg0
837!! JJ = IBUFBOX(JAD+DIF_NIX-1) ! tag element
838 kad = jad - 1 + dif_nix - pos_iext
839 jj = ibufbox(kad) ! tag element
840 nod(1) = ibufbox(jad)
841 nod(2) = ibufbox(jad+1)
842 nod(3) = ibufbox(jad+2)
843 nod(4) = ibufbox(jad+3)
844C
845 nface = 4
846 IF(tag10(jj) == 1) nface = 16
847 fac = 0
848 idel = 0
849 DO r=1,4
850 IF(nod(r) > 0) fac = fac + 1
851 END DO
852C---
853 IF(k > 1)THEN
854 DO iis=1,nface ! loop over double faces
855 nfac = 0
856 nold(1) = elface(1,iis,jj)
857 nold(2) = elface(2,iis,jj)
858 nold(3) = elface(3,iis,jj)
859 nold(4) = elface(4,iis,jj)
860C
861 DO r=1,4
862 IF(nold(r) > 0 .and. nold(r)==nod(r))
863 . nfac = nfac + 1
864 END DO
865C
866 IF(fac == 4 .and. nfac == 4)THEN
867 idel = 1
868 EXIT
869 END IF
870 END DO
871 END IF
872C---
873 IF(idel /= 1)THEN
874C---
875C fill work box faces
876C
877 iface(jj) = iface(jj) + 1
878 is = iface(jj)
879 posface(is,jj) = 1
880C
881 IF(elface(1,is,jj) == 0)
882 . elface(1,is,jj) = ibufbox(jad)
883 IF(elface(2,is,jj) == 0)
884 . elface(2,is,jj) = ibufbox(jad+1)
885 IF(elface(3,is,jj) == 0)
886 . elface(3,is,jj) = ibufbox(jad+2)
887 IF(elface(4,is,jj) == 0)
888 . elface(4,is,jj) = ibufbox(jad+3)
889C---
890 ENDIF
891 jad = jad + dif_nix
892 END DO
893 END IF
894 END DO
895C---
896C tag elements of negative boxes:
897C---
898 DO k=1,nbox
899 j = ibox(ib)%IBOXBOX(k)
900 ibs = abs(j)
901 idbx = ibox(ibs)%ID
902 boxseg0 = ibox(ibs)%NENTITY ! faces of sub-box
903 jad = ibox(ibs)%SURFIAD ! address of faces
904C---
905 IF(idbx/=0 .and. j < 0)THEN
906 DO i=1,boxseg0
907!! JJ = IBUFBOX(JAD+DIF_NIX-1) ! tag element
908 kad = jad - 1 + dif_nix - pos_iext
909 jj = ibufbox(kad) ! tag element
910 nod(1) = ibufbox(jad)
911 nod(2) = ibufbox(jad+1)
912 nod(3) = ibufbox(jad+2)
913 nod(4) = ibufbox(jad+3)
914C
915 nface = 4
916 IF(tag10(jj) == 1) nface = 16
917 fac = 0
918 idel = 1
919 jface = 0
920C
921 DO r=1,4
922 IF(nod(r) > 0) fac = fac + 1
923 END DO
924C---
925C IF(K > 1)THEN
926 DO iis=1,nface ! loop over double faces
927 nfac = 0
928 nold(1) = elface(1,iis,jj)
929 nold(2) = elface(2,iis,jj)
930 nold(3) = elface(3,iis,jj)
931 nold(4) = elface(4,iis,jj)
932C
933 DO r=1,4
934 IF(nold(r) > 0 .and. nold(r)==nod(r))
935 . nfac = nfac + 1
936 END DO
937C
938 IF(fac == 4 .and. nfac == 4)THEN
939 idel = 0
940 jface = iis
941 EXIT
942 END IF
943 END DO
944C END IF
945C---
946 IF(idel /= 1)THEN
947C---
948C
949C fill work box faces
950C
951 is = jface
952 negface(is,jj) = 1 ! negative faces
953C---
954 ENDIF
955 jad = jad + dif_nix
956 END DO
957 END IF
958 END DO
959C----------------
960C final combination (+/-) assembly in sublevel:
961C----------------
962 DO j=1,numels
963 nface = 4
964 IF(tag10(jj) == 1) nface = 16
965 DO is=1,nface
966 IF(posface(is,j)>0 .and. negface(is,j)==0)THEN
967 tagfaces(is,j)=1
968 boxseg = boxseg + 1
969 END IF
970 END DO
971 END DO
972C
973C---count lines within BOX
974C
975 DO j=1,numels
976 nface = 4
977 IF(tag10(jj) == 1) nface = 16
978 DO is=1,nface
979 IF(tagfaces(is,j) == 1)THEN
980 ibufbox(iadb) = elface(1,is,j)
981 iadb = iadb + 1
982 ibufbox(iadb) = elface(2,is,j)
983 iadb = iadb + 1
984 ibufbox(iadb) = elface(3,is,j)
985 iadb = iadb + 1
986 ibufbox(iadb) = elface(4,is,j)
987 iadb = iadb + 1
988C
989 ibufbox(iadb)=1 ! IELTYP
990 iadb = iadb + 1
991 ibufbox(iadb)=j
992 iadb = iadb + 1
993 IF (iext_set > 0) THEN
994 ibufbox(iadb) = iext_set
995 iadb = iadb + 1
996 ENDIF
997 END IF
998 END DO
999 END DO
1000C---------------
1001 40 CONTINUE
1002C---
1003 ibox(ib)%NENTITY=boxseg
1004 ibox(ib)%SURFIAD=iadb0
1005 IF(ibox(ib)%ACTIBOX == 0) ibox(ib)%ACTIBOX = 1
1006C---
1007 ENDIF ! IF (FLAG == 0)
1008 DEALLOCATE(elface,tagfaces)
1009 DEALLOCATE(posface,negface)
1010 DEALLOCATE(tag8,tag10,iface)
1011
1012C---------------
1013 RETURN
1014 END
1015!||====================================================================
1016!|| boxtage ../starter/source/model/box/bigbox.F
1017!||--- called by ------------------------------------------------------
1018!|| bigbox2 ../starter/source/model/box/bigbox.F
1019!|| boxbox2 ../starter/source/model/box/boxbox.F
1020!|| hm_bigbox2 ../starter/source/model/box/hm_bigbox2.F
1021!||--- calls -----------------------------------------------------
1022!|| checkcyl ../starter/source/model/box/rdbox.F
1023!|| checkpara ../starter/source/model/box/rdbox.F
1024!|| checksphere ../starter/source/model/box/rdbox.F
1025!||--- uses -----------------------------------------------------
1026!|| message_mod ../starter/share/message_module/message_mod.F
1027!||====================================================================
1028 SUBROUTINE boxtage(X ,SKEW ,IBOX ,
1029 . ISU ,BOXTYPE,IX ,NIX ,
1030 . NIX1 ,IPARTE ,IPART ,KLEVTREE,ELTREE,
1031 . KELTREE,NUMEL ,NADMESH,FLAG ,IBOXMAX,
1032 . IADB,IBUFBOX)
1033C-----------------------------------------------
1034C M o d u l e s
1035C-----------------------------------------------
1036 USE message_mod
1037 USE optiondef_mod
1038C-----------------------------------------------
1039C I m p l i c i t T y p e s
1040C-----------------------------------------------
1041#include "implicit_f.inc"
1042C-----------------------------------------------
1043C C o m m o n B l o c k s
1044C-----------------------------------------------
1045#include "com04_c.inc"
1046#include "scr17_c.inc"
1047#include "param_c.inc"
1048C-----------------------------------------------
1049C D u m m y A r g u m e n t s
1050C-----------------------------------------------
1051 INTEGER ISU,BOXTYPE,
1052 . NIX,IX(NIX,*),NIX1,IPARTE(*),IPART(LIPART1,*),
1053 . KLEVTREE,KELTREE,ELTREE(KELTREE,*),NUMEL,
1054 . NADMESH,FLAG,IBOXMAX,IADB,IBUFBOX(*)
1055 my_real
1056 . X(3,*),SKEW(LSKEW,*)
1057 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
1058C-----------------------------------------------
1059C L o c a l V a r i a b l e s
1060C-----------------------------------------------
1061 INTEGER I,J,JJ,K,OK,OK1,ISK,IDBX,NELBOX,TAGELEM(NUMEL),
1062 . JAD,IP,NLEV,MY_LEV,ITYPE,IE,IADB0
1063C
1064 my_real
1065 . xp1,yp1,zp1,xp2,yp2,zp2,diam,nodinb(3)
1066C-----------------------------------------------
1067! IE = 0
1068 ok = 0
1069 ok1 = 0
1070 nelbox = 0
1071 iadb0 = iadb
1072 tagelem(1:numel) = 0
1073C-------
1074 idbx = ibox(isu)%ID
1075 isk = ibox(isu)%ISKBOX
1076 itype= ibox(isu)%TYPE
1077 diam = ibox(isu)%DIAM
1078 xp1 = ibox(isu)%X1
1079 yp1 = ibox(isu)%Y1
1080 zp1 = ibox(isu)%Z1
1081 xp2 = ibox(isu)%X2
1082 yp2 = ibox(isu)%Y2
1083 zp2 = ibox(isu)%Z2
1084C--------------------------------
1085 IF(idbx/=0)THEN
1086C---
1087 IF(nadmesh==0)THEN
1088 IF (boxtype == 2) THEN
1089 DO jj=1,numel
1090 ok=0
1091 DO k=2,nix1+1
1092 i=ix(k,jj)
1093 nodinb(1) = x(1,i)
1094 nodinb(2) = x(2,i)
1095 nodinb(3) = x(3,i)
1096 IF(itype == 1)THEN ! 'RECTA'
1097 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1098 . isk,nodinb,skew,ok)
1099 ELSE IF(itype == 2)THEN ! 'CYLIN'
1100 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1101 . nodinb , diam, ok )
1102 ELSE IF(itype == 3)THEN ! 'SPHER'
1103 CALL checksphere(xp1, yp1, zp1, nodinb, diam, ok)
1104 END IF
1105 ENDDO
1106 IF (ok == 1) THEN
1107 IF(tagelem(jj) == 0)THEN
1108 nelbox=nelbox+1
1109 tagelem(jj) = 1
1110 END IF
1111 ENDIF
1112 ENDDO
1113 ELSE IF(boxtype == 1)THEN
1114 DO jj=1,numel
1115 ok1=0
1116 DO k=2,nix1+1
1117 ok=0
1118 i=ix(k,jj)
1119 nodinb(1) = x(1,i)
1120 nodinb(2) = x(2,i)
1121 nodinb(3) = x(3,i)
1122 IF(itype == 1)THEN ! 'RECTA'
1123 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1124 . isk,nodinb,skew,ok)
1125 ELSE IF(itype == 2)THEN ! 'CYLIN'
1126 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1127 . nodinb , diam, ok )
1128 ELSE IF(itype == 3)THEN ! 'SPHER'
1129 CALL checksphere(xp1, yp1, zp1, nodinb, diam, ok)
1130 END IF
1131 IF(ok == 1) ok1 = ok1 + 1
1132 ENDDO
1133 IF (ok1 == nix1) THEN
1134 IF(tagelem(jj) == 0)THEN
1135 nelbox=nelbox+1
1136 tagelem(jj) = 1
1137 END IF
1138 ENDIF
1139 ENDDO
1140 ENDIF
1141 ELSE ! NADMESH /=0
1142 IF (boxtype == 2) THEN
1143 DO jj=1,numel
1144 ok=0
1145 DO k=2,nix1+1
1146 i=ix(k,jj)
1147 nodinb(1) = x(1,i)
1148 nodinb(2) = x(2,i)
1149 nodinb(3) = x(3,i)
1150 IF(itype == 1)THEN ! 'RECTA'
1151 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1152 . isk,nodinb,skew,ok)
1153 ELSE IF(itype == 2)THEN ! 'CYLIN'
1154 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1155 . nodinb , diam, ok )
1156 ELSE IF(itype == 3)THEN ! 'SPHER'
1157 CALL checksphere(xp1, yp1, zp1, nodinb, diam, ok)
1158 END IF
1159 ENDDO
1160 IF (ok == 1) THEN
1161 ip=iparte(jj)
1162 nlev =ipart(10,ip)
1163 my_lev=eltree(klevtree,jj)
1164 IF(my_lev < 0) my_lev=-(my_lev+1)
1165 IF(my_lev==nlev)THEN
1166 IF(tagelem(jj) == 0)THEN
1167 nelbox=nelbox+1
1168 tagelem(jj) = 1
1169 END IF
1170 ENDIF
1171 ENDIF
1172 ENDDO
1173 ELSE IF(boxtype == 1)THEN
1174 DO jj=1,numel
1175 ok1=0
1176 DO k=2,nix1+1
1177 ok=0
1178 i=ix(k,jj)
1179 nodinb(1) = x(1,i)
1180 nodinb(2) = x(2,i)
1181 nodinb(3) = x(3,i)
1182 IF(itype == 1)THEN ! 'RECTA'
1183 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1184 . isk,nodinb,skew,ok)
1185 ELSE IF(itype == 2)THEN ! 'CYLIN'
1186 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1187 . nodinb , diam, ok )
1188 ELSE IF(itype == 3)THEN ! 'SPHER'
1189 CALL checksphere(xp1, yp1, zp1, nodinb, diam, ok)
1190 END IF
1191 IF(ok == 1) ok1 = ok1 + 1
1192 ENDDO
1193 IF (ok1 == nix1) THEN
1194 ip=iparte(jj)
1195 nlev =ipart(10,ip)
1196 my_lev=eltree(klevtree,jj)
1197 IF(my_lev < 0) my_lev=-(my_lev+1)
1198 IF(my_lev==nlev)THEN
1199 IF(tagelem(jj) == 0)THEN
1200 nelbox=nelbox+1
1201 tagelem(jj) = 1
1202 END IF
1203 ENDIF
1204 ENDIF
1205 ENDDO
1206 ENDIF
1207 END IF
1208 ibox(isu)%NENTITY = nelbox
1209 ibox(isu)%BOXIAD=iadb0
1210 END IF
1211C--------------------------------
1212 IF (flag == 0) THEN
1213 DO i=1,numel
1214 IF(tagelem(i) == 1)THEN
1215 iadb = iadb + 1
1216 END IF
1217 END DO
1218 ELSEIF (flag == 1 .AND. nelbox > 0) THEN
1219 DO i=1,numel
1220 IF(tagelem(i) == 1)THEN
1221 ibufbox(iadb) = i
1222 iadb = iadb + 1
1223 END IF
1224 END DO
1225 ENDIF
1226C----------------
1227 RETURN
1228 END
1229!||====================================================================
1230!|| bigbox2 ../starter/source/model/box/bigbox.F
1231!||--- calls -----------------------------------------------------
1232!|| ancmsg ../starter/source/output/message/message.F
1233!|| boxbox2 ../starter/source/model/box/boxbox.F
1234!|| boxtage ../starter/source/model/box/bigbox.F
1235!||--- uses -----------------------------------------------------
1236!|| format_mod ../starter/share/modules1/format_mod.F90
1237!|| message_mod ../starter/share/message_module/message_mod.f
1238!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
1239!||====================================================================
1240 SUBROUTINE bigbox2(X ,FLAG ,NEL ,
1241 . SKEW ,IGS ,ISKN ,ITABM1,IBOX ,
1242 . ID ,NADMESH,NIX ,IX ,NIX1 ,NUMEL ,
1243 . IPARTE ,IPART ,KLEVTREE,ELTREE,KELTREE,BUFTMP,
1244 . KEY ,TITR ,MES ,IGRELEM,NGRELE ,NN ,
1245 . IADB ,IBOXMAX,IBUFBOX)
1246C-----------------------------------------------
1247C M o d u l e s
1248C-----------------------------------------------
1249 USE message_mod
1250 USE groupdef_mod
1251 USE optiondef_mod
1252 USE format_mod , ONLY : fmt_i
1253 USE reader_old_mod , ONLY : line, irec
1254C-----------------------------------------------
1255C I m p l i c i t T y p e s
1256C-----------------------------------------------
1257#include "implicit_f.inc"
1258C-----------------------------------------------
1259C C o m m o n B l o c k s
1260C-----------------------------------------------
1261#include "com04_c.inc"
1262#include "scr17_c.inc"
1263#include "units_c.inc"
1264#include "param_c.inc"
1265C-----------------------------------------------
1266C D u m m y A r g u m e n t s
1267C-----------------------------------------------
1268 INTEGER JREC,FLAG,NEL,IGS,
1269 . ISKN(LISKN,*),ITABM1(*),ID,NADMESH,
1270 . NIX,IX(NIX,*),NIX1,NUMEL,IPARTE(*),IPART(LIPART1,*),
1271 . KLEVTREE,KELTREE,ELTREE(KELTREE,*),
1272 . BUFTMP(NUMEL*5),NGRELE,NN,IBOXMAX,IADB,IBUFBOX(*)
1273 my_real X(3,*),SKEW(LSKEW,*)
1274 CHARACTER KEY*4,MES*40
1275 CHARACTER(LEN=NCHARTITLE) :: TITR
1276C-----------------------------------------------
1277 TYPE (GROUP_), DIMENSION(NGRELE) :: IGRELEM
1278 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
1279C-----------------------------------------------
1280C L o c a l V a r i a b l e s
1281C-----------------------------------------------
1282 INTEGER I,J,ISU,IDB,ISK,TAGN(NUMEL),BOXTYPE,
1283 . negbox,tagneg(numel),tagpos(numel),
1284 . nbox,boxele,icount,iter,flagg,iadisu
1285 my_real
1286 . xp1,yp1,zp1,xp2,yp2,zp2,diam,nodinb(3)
1287 CHARACTER BOX*3
1288 LOGICAL BOOL
1289C-----------------------------------------------
1290 DO i=1,nbbox
1291 ibox(i)%NBLEVELS = 0
1292 ibox(i)%LEVEL = 1
1293 ibox(i)%ACTIBOX = 0
1294 IF(ibox(i)%NBOXBOX > 0)THEN
1295 ibox(i)%NBLEVELS = -1
1296 ibox(i)%LEVEL = 0
1297 END IF
1298C
1299 ibox(i)%BOXIAD = 0
1300 END DO
1301C-------
1302 jrec=irec+1
1303 READ(iin,rec=jrec,err=999,fmt='(A)')line
1304 READ(line,err=999,fmt=fmt_i) idb
1305 IF(key == 'BOX')THEN
1306 boxtype = 1
1307 ELSE IF(key == 'BOX2')THEN
1308 boxtype = 2
1309 END IF
1310C-------
1311C get box de box ID'S dans grshel:
1312C-------
1313 isu = 0
1314 DO i=1,nbbox
1315 IF(idb == ibox(i)%ID) THEN
1316 isu=i
1317 EXIT
1318 ENDIF
1319 END DO
1320C---
1321 IF(isu > 0)THEN
1322 nbox = ibox(isu)%NBOXBOX
1323C super box activated:
1324 ibox(isu)%ACTIBOX = 1
1325 ELSE
1326 IF(flag == 0)THEN
1327 CALL ancmsg(msgid=798,
1328 . msgtype=msgerror,
1329 . anmode=aninfo,
1330 . i1=id,
1331 . c1=titr,
1332 . i2=idb)
1333 END IF
1334 END IF
1335C---
1336C simple box dans grshel:
1337C---
1338 bool = .false.
1339 IF(isu>0)THEN
1340 IF(ibox(isu)%NBLEVELS == 0 .AND. ibox(isu)%LEVEL == 1) THEN
1341 IF (nbox == 0) THEN ! simple box (no sub box)
1342 CALL boxtage(x ,skew ,ibox ,
1343 . isu ,boxtype,ix ,nix ,
1344 . nix1 ,iparte ,ipart ,klevtree,eltree,
1345 . keltree,numel ,nadmesh,flag ,iboxmax,
1346 . iadb ,ibufbox)
1347 bool = .true.
1348 END IF
1349 END IF
1350 ENDIF
1351C---
1352C READ LEVELS OF BOXES ==> "SUBLEVEL DONE"
1353C---
1354 IF(.NOT. bool)THEN
1355 icount = 1
1356 iter = 0
1357 DO WHILE (icount == 1)
1358 iter = iter + 1
1359 flagg = 0
1360C--- count next level
1361 CALL boxbox2(ibox ,skew ,
1362 . flagg ,icount,iter ,boxtype,
1363 . x ,ix ,flag ,iboxmax,
1364 . nix ,nix1 ,iparte ,ipart ,
1365 . klevtree,eltree,keltree ,numel ,
1366 . nadmesh ,id ,titr ,mes ,
1367 . iadb ,ibufbox)
1368C--- fill next level
1369 flagg = 1
1370 CALL boxbox2(ibox ,skew ,
1371 . flagg ,icount ,iter ,boxtype,
1372 . x ,ix ,flag ,iboxmax,
1373 . nix ,nix1 ,iparte ,ipart ,
1374 . klevtree,eltree ,keltree ,numel ,
1375 . nadmesh ,id ,titr ,mes ,
1376 . iadb ,ibufbox)
1377C---
1378 ENDDO
1379 ENDIF
1380
1381C---
1382C tag group elements in main-box:
1383C---
1384 IF(isu > 0)THEN
1385 IF(flag == 0)THEN
1386 boxele = ibox(isu)%NENTITY ! elements of main box
1387 nel = boxele
1388 ELSE IF(flag == 1)THEN
1389 boxele = ibox(isu)%NENTITY ! elements of main box
1390 iadisu = ibox(isu)%BOXIAD ! addresses of elements in main box
1391 nel = boxele
1392 DO i=1,boxele
1393 j=ibufbox(iadisu+i-1)
1394 nn = nn + 1
1395 igrelem(igs)%ENTITY(nn) = j
1396 END DO
1397 END IF
1398 END IF
1399C----------
1400 RETURN
1401 999 CALL freerr(1)
1402 RETURN
1403 END
1404!||====================================================================
1405!|| box_surf_sh ../starter/source/model/box/bigbox.F
1406!||--- called by ------------------------------------------------------
1407!|| bigsbox ../starter/source/model/box/bigbox.F
1408!|| boxboxs ../starter/source/model/box/boxbox.F
1409!|| hm_bigsbox ../starter/source/groups/hm_bigsbox.F
1410!||--- calls -----------------------------------------------------
1411!|| checkcyl ../starter/source/model/box/rdbox.F
1412!|| checkpara ../starter/source/model/box/rdbox.F
1413!|| checksphere ../starter/source/model/box/rdbox.F
1414!||--- uses -----------------------------------------------------
1415!|| message_mod ../starter/share/message_module/message_mod.F
1416!||====================================================================
1417 SUBROUTINE box_surf_sh(X ,IBUFBOX,SKEW ,IADB ,BOXTYPE,
1418 . IBOX ,ISU ,NUMEL ,NIX ,IX ,
1419 . NIX1 ,NIX2 ,ISURF0,IELTYP ,FLAG ,
1420 . TAGSHELLBOX ,IEXT )
1421C-----------------------------------------------
1422C M o d u l e s
1423C-----------------------------------------------
1424 USE message_mod
1425 USE optiondef_mod
1426C-----------------------------------------------
1427C I m p l i c i t T y p e s
1428C-----------------------------------------------
1429#include "implicit_f.inc"
1430C-----------------------------------------------
1431C C o m m o n B l o c k s
1432C-----------------------------------------------
1433#include "com04_c.inc"
1434#include "param_c.inc"
1435C-----------------------------------------------
1436C D u m m y A r g u m e n t s
1437C-----------------------------------------------
1438 INTEGER IBUFBOX(*),IADB,NUMEL,BOXTYPE,ISURF0,IELTYP,
1439 . ISU,NIX,IX(NIX,*),NIX1,NIX2,
1440 . FLAG , TAGSHELLBOX(*),IEXT
1441 my_real
1442 . x(3,*),skew(lskew,*)
1443 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
1444C-----------------------------------------------
1445C L o c a l V a r i a b l e s
1446C-----------------------------------------------
1447 INTEGER I,J,JJ,K,OK,OK1,ISK,IDBX,BOXSEG,
1448 . IADB0,JAD,ITYPE,DIF_NIX
1449C
1450 my_real
1451 . XP1,YP1,ZP1,XP2,YP2,ZP2,DIAM,NODINB(3)
1452C-----------------------------------------------
1453 DIF_NIX = nix2 - nix1 + 1
1454 IF(isurf0 == 0) dif_nix = nix1
1455C
1456 ok = 0
1457 boxseg = 0
1458 iadb0 = iadb
1459 tagshellbox(1:numel) = 0
1460C-------
1461 idbx = ibox(isu)%ID
1462 isk = ibox(isu)%ISKBOX
1463 itype= ibox(isu)%TYPE
1464 diam = ibox(isu)%DIAM
1465 xp1 = ibox(isu)%X1
1466 yp1 = ibox(isu)%Y1
1467 zp1 = ibox(isu)%Z1
1468 xp2 = ibox(isu)%X2
1469 yp2 = ibox(isu)%Y2
1470 zp2 = ibox(isu)%Z2
1471C
1472 IF(idbx/=0)THEN
1473 IF (boxtype == 2) THEN
1474 DO jj=1,numel
1475 ok=0
1476 DO k=nix1,nix2
1477 i=ix(k,jj)
1478 nodinb(1) = x(1,i)
1479 nodinb(2) = x(2,i)
1480 nodinb(3) = x(3,i)
1481 IF(itype == 1)THEN ! 'RECTA'
1482 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1483 . isk,nodinb,skew,ok)
1484 ELSE IF(itype == 2)THEN ! 'CYLIN'
1485 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1486 . nodinb , diam, ok )
1487 ELSE IF(itype == 3)THEN ! 'SPHER'
1488 CALL checksphere(xp1,yp1,zp1,nodinb,diam,ok)
1489 END IF
1490 ENDDO
1491 IF (ok == 1) THEN
1492 IF(tagshellbox(jj) == 0)THEN
1493 boxseg=boxseg+1
1494 tagshellbox(jj) = 1
1495 END IF
1496 ENDIF
1497 ENDDO
1498 ELSE IF (boxtype == 1) THEN
1499 DO jj=1,numel
1500 ok1=0
1501 DO k=nix1,nix2
1502 ok=0
1503 i=ix(k,jj)
1504 nodinb(1) = x(1,i)
1505 nodinb(2) = x(2,i)
1506 nodinb(3) = x(3,i)
1507 IF(itype == 1)THEN ! 'RECTA'
1508 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1509 . isk,nodinb,skew,ok)
1510 ELSE IF(itype == 2)THEN ! 'CYLIN'
1511 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1512 . nodinb , diam, ok )
1513 ELSE IF(itype == 3)THEN ! 'SPHER'
1514 CALL checksphere(xp1,yp1,zp1,nodinb,diam,ok)
1515 END IF
1516 IF(ok == 1) ok1 = ok1 + 1
1517 ENDDO
1518 IF (ok1 == dif_nix) THEN
1519 IF(tagshellbox(jj) == 0)THEN
1520 boxseg=boxseg+1
1521 tagshellbox(jj) = 1
1522 END IF
1523 ENDIF
1524 ENDDO
1525 ENDIF
1526 ibox(isu)%NENTITY = boxseg
1527 ibox(isu)%BOXIAD = iadb0
1528 END IF
1529C
1530C---count lines within BOX
1531C
1532 IF (flag == 0) THEN
1533 IF(idbx/=0)THEN
1534 DO i=1,numel
1535 IF(tagshellbox(i) == 1)THEN
1536 IF(isurf0 == 1)THEN
1537 DO k=nix1,nix2
1538cc IBUFBOX(IADB) = IX(K,I)
1539 iadb = iadb + 1
1540 ENDDO
1541 ELSE
1542cc IBUFBOX(IADB) = IX(NIX1,I)
1543 iadb = iadb + 1
1544cc IBUFBOX(IADB) = IX(NIX2,I)
1545 iadb = iadb + 1
1546C
1547 END IF
1548 IF(ieltyp == 7)THEN
1549cc IBUFBOX(IADB) = IBUFBOX(IADB-1)
1550 iadb = iadb + 1
1551 END IF
1552cc IBUFBOX(IADB)=IELTYP
1553 iadb = iadb + 1
1554cc IBUFBOX(IADB)=I
1555 iadb = iadb + 1
1556cc
1557 IF (iext > 0) THEN
1558cc IBUFBOX(IADB) = IEXT
1559 iadb = iadb + 1
1560 ENDIF
1561 END IF
1562 END DO
1563C
1564 ENDIF
1565 ELSEIF (flag == 1 .AND. boxseg > 0) THEN
1566 DO i=1,numel
1567 IF(tagshellbox(i) == 1)THEN
1568 IF(isurf0 == 1)THEN
1569 DO k=nix1,nix2
1570 ibufbox(iadb) = ix(k,i)
1571 iadb = iadb + 1
1572 ENDDO
1573 ELSE
1574 ibufbox(iadb) = ix(nix1,i)
1575 iadb = iadb + 1
1576 ibufbox(iadb) = ix(nix2,i)
1577 iadb = iadb + 1
1578C
1579 END IF
1580 IF(ieltyp == 7)THEN
1581 ibufbox(iadb) = ibufbox(iadb-1)
1582 iadb = iadb + 1
1583 END IF
1584 ibufbox(iadb)=ieltyp
1585 iadb = iadb + 1
1586 ibufbox(iadb)=i
1587 iadb = iadb + 1
1588 IF (iext > 0) THEN
1589 ibufbox(iadb) = iext
1590 iadb = iadb + 1
1591 ENDIF
1592 END IF
1593 END DO
1594 ENDIF ! IF (FLAG == 0)
1595C---------------
1596 RETURN
1597 END
1598!||====================================================================
1599!|| bigsbox ../starter/source/model/box/bigbox.F
1600!||--- calls -----------------------------------------------------
1601!|| ancmsg ../starter/source/output/message/message.F
1602!|| box_surf_sh ../starter/source/model/box/bigbox.F
1603!|| boxboxs ../starter/source/model/box/boxbox.F
1604!||--- uses -----------------------------------------------------
1605!|| format_mod ../starter/share/modules1/format_mod.F90
1606!|| message_mod ../starter/share/message_module/message_mod.F
1607!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
1608!||====================================================================
1609 SUBROUTINE bigsbox(NUMEL ,IX ,NIX ,NIX1 ,NIX2,IELTYP,
1610 . X , NSEG ,FLAG,SKEW ,
1611 . ISKN ,ISURF0 ,ITABM1 ,IBOX,
1612 . ID ,IBUFBOX,ISURFLIN,IADB,KEY ,
1613 . SBUFBOX,TITR ,MESS ,TAGSHELLBOX,
1614 . NN )
1615C-----------------------------------------------
1616C M o d u l e s
1617C-----------------------------------------------
1618 USE message_mod
1619 USE groupdef_mod
1620 USE optiondef_mod
1621 USE format_mod , ONLY : fmt_i
1622 USE reader_old_mod , ONLY : line, irec
1623C-----------------------------------------------
1624C I m p l i c i t T y p e s
1625C-----------------------------------------------
1626#include "implicit_f.inc"
1627C-----------------------------------------------
1628C C o m m o n B l o c k s
1629C-----------------------------------------------
1630#include "com04_c.inc"
1631#include "param_c.inc"
1632#include "scr17_c.inc"
1633#include "units_c.inc"
1634C-----------------------------------------------
1635C D u m m y A r g u m e n t s
1636C-----------------------------------------------
1637 INTEGER NIX,IX(NIX,*),NIX1,NIX2,NUMEL,IELTYP,
1638 . NSEG,FLAG,ISKN(LISKN,*),ISURF0,
1639 . ITABM1(*),IBUFBOX(*),
1640 . IADB,SBUFBOX,TAGSHELLBOX(*),NN
1641 my_real x(3,*),skew(lskew,*)
1642 CHARACTER KEY*4,MESS*40
1643 CHARACTER(LEN=NCHARTITLE) :: TITR
1644C-----------------------------------------------
1645 TYPE (SURF_) :: ISURFLIN
1646 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
1647C-----------------------------------------------
1648C L o c a l V a r i a b l e s
1649C-----------------------------------------------
1650 INTEGER I,JJ,K,K1,J,JREC,ISK,BOXTYPE,ISU,TAGN(NUMEL),
1651 . ITYPE,IADBOX,IDB,NBOX,ID,IDBX,BOXSEG,IADISU,
1652 . ICOUNT,ITER,FLAGG,NIXEL
1653 MY_REAL DIAM,XP1,YP1,ZP1,XP2,YP2,ZP2,NODINB(3)
1654 CHARACTER BOX*3
1655 LOGICAL BOOL
1656C=======================================================================
1657 DO I=1,nbbox
1658 ibox(i)%NBLEVELS = 0
1659 ibox(i)%LEVEL = 1
1660 ibox(i)%ACTIBOX = 0
1661 IF(ibox(i)%NBOXBOX > 0)THEN
1662 ibox(i)%NBLEVELS = -1
1663 ibox(i)%LEVEL = 0
1664 END IF
1665C
1666 ibox(i)%BOXIAD = 0
1667 END DO
1668C-------
1669 jrec=irec+1
1670 READ(iin,rec=jrec,err=999,fmt='(A)')line
1671 READ(line,err=999,fmt=fmt_i) idb
1672 IF(key == 'BOX')THEN
1673 boxtype = 1
1674 ELSE IF(key == 'BOX2')THEN
1675 boxtype = 2
1676 END IF
1677C-------
1678C get box de box ID'S dans LINE :
1679C-------
1680 isu = 0
1681 DO i=1,nbbox
1682 IF(idb == ibox(i)%ID) isu=i
1683 END DO
1684C---
1685 IF(isu > 0)THEN
1686 nbox = ibox(isu)%NBOXBOX
1687C super box activated:
1688 ibox(isu)%ACTIBOX = 1
1689 ELSE
1690 IF(flag == 0)THEN
1691 IF(isurf0 == 0)THEN
1692 CALL ancmsg(msgid=799,
1693 . msgtype=msgerror,
1694 . anmode=aninfo,
1695 . i1=id,
1696 . c1=titr,
1697 . i2=idb)
1698 ELSE IF(isurf0 == 1)THEN
1699 CALL ancmsg(msgid=800,
1700 . msgtype=msgerror,
1701 . anmode=aninfo,
1702 . i1=id,
1703 . c1=titr,
1704 . i2=idb)
1705 END IF
1706 END IF
1707 END IF
1708C---
1709C simple box dans /LINE :
1710C---
1711 bool=.false.
1712 IF(isu>0)THEN
1713 IF(ibox(isu)%NBLEVELS == 0 .AND. ibox(isu)%LEVEL == 1) THEN
1714 IF(nbox == 0)THEN
1715 CALL box_surf_sh(x ,ibufbox,skew ,iadb ,boxtype,
1716 . ibox ,isu ,numel ,nix ,ix ,
1717 . nix1 ,nix2 ,isurf0,ieltyp ,flag ,
1718 . tagshellbox,0 )
1719 bool=.true.
1720 END IF
1721 END IF
1722 ENDIF
1723C---
1724C READ LEVELS OF BOXES ==> "SUBLEVEL DONE"
1725C---
1726 IF(.NOT.bool)THEN
1727 icount = 1
1728 iter = 0
1729 DO WHILE (icount == 1)
1730 iter = iter + 1
1731 flagg = 0
1732C--- count next level
1733 CALL boxboxs(ibox ,skew ,flagg ,icount ,iter ,
1734 . boxtype ,ibufbox ,x ,iadb ,ix ,
1735 . nix ,nix1 ,nix2 ,numel ,isurf0 ,
1736 . ieltyp ,id ,titr ,mess ,flag ,
1737 . tagshellbox,0 )
1738 IF (iadb>sbufbox .OR. iadb<0)
1739 . CALL ancmsg(msgid=1007, msgtype=msgerror,anmode=anstop)
1740C--- fill next level
1741 flagg = 1
1742 CALL boxboxs(ibox ,skew ,flagg ,icount ,iter ,
1743 . boxtype ,ibufbox ,x ,iadb ,ix ,
1744 . nix ,nix1 ,nix2 ,numel ,isurf0 ,
1745 . ieltyp ,id ,titr ,mess ,flag ,
1746 . tagshellbox,0 )
1747C---
1748 ENDDO
1749 ENDIF
1750C---
1751C tag lines (ou surfaces) in main-box:
1752C---
1753C---count lines within BOX
1754 IF(isu > 0)THEN
1755C
1756 IF(flag == 0)THEN
1757 boxseg = ibox(isu)%NENTITY ! segments of main box
1758 nseg = nseg + boxseg
1759 ELSE IF(flag == 1)THEN
1760 boxseg = ibox(isu)%NENTITY ! segments of main box
1761 iadisu = ibox(isu)%BOXIAD ! addresses of segments in main box
1762 nseg = nseg + boxseg
1763 DO i=1,boxseg
1764 nn = nn + 1
1765 IF(isurf0 == 1)THEN ! surfaces
1766 DO k=nix1,nix2
1767 j=ibufbox(iadisu+k-2)
1768 isurflin%NODES(nn,k-1) = j
1769 ENDDO
1770 iadisu = iadisu + nix2 - 1
1771 ELSE ! lines
1772C--------------------
1773 j=ibufbox(iadisu)
1774 isurflin%NODES(nn,1) = j
1775 iadisu = iadisu + 1
1776C--------------------
1777 j=ibufbox(iadisu)
1778 isurflin%NODES(nn,2) = j
1779 iadisu = iadisu + 1
1780 END IF
1781C--------------------
1782 IF(ieltyp == 7)THEN
1783 j=ibufbox(iadisu)
1784 isurflin%NODES(nn,4) =
1785 . isurflin%NODES(nn,3)
1786 iadisu = iadisu + 1
1787 END IF
1788C--------------------
1789 j=ibufbox(iadisu)
1790 isurflin%ELTYP(nn)= j
1791 iadisu = iadisu + 1
1792C--------------------
1793 j=ibufbox(iadisu)
1794 isurflin%ELEM(nn) = j
1795 iadisu = iadisu + 1
1796C--------------------
1797 END DO
1798 END IF ! IF(FLAG == 0)
1799 END IF ! IF(ISU > 0)
1800C-----------
1801 RETURN
1802 999 CALL freerr(1)
1803 RETURN
1804 END
1805C
1806!||====================================================================
1807!|| elstagbox ../starter/source/model/box/bigbox.F
1808!||--- called by ------------------------------------------------------
1809!|| elstagboxbox ../starter/source/model/box/boxbox.F
1810!|| sboxboxsurf ../starter/source/model/box/bigbox.F
1811!||--- calls -----------------------------------------------------
1812!|| checkcyl ../starter/source/model/box/rdbox.F
1813!|| checkpara ../starter/source/model/box/rdbox.F
1814!|| checksphere ../starter/source/model/box/rdbox.F
1815!||--- uses -----------------------------------------------------
1816!||====================================================================
1817 SUBROUTINE elstagbox(IXS ,ELSTAG ,X ,SKEW ,BOXTYPE,
1818 . ISU ,IBOX )
1819C-----------------------------------------------
1820C M o d u l e s
1821C-----------------------------------------------
1822 USE optiondef_mod
1823C-----------------------------------------------
1824C I m p l i c i t T y p e s
1825C-----------------------------------------------
1826#include "implicit_f.inc"
1827C-----------------------------------------------
1828C C o m m o n B l o c k s
1829C-----------------------------------------------
1830#include "com04_c.inc"
1831#include "param_c.inc"
1832C-----------------------------------------------
1833C D u m m y A r g u m e n t s
1834C-----------------------------------------------
1835 INTEGER IXS(NIXS,*),ELSTAG(*),BOXTYPE,ISU
1836 MY_REAL
1837 . X(3,*),SKEW(LSKEW,*)
1838 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
1839C-----------------------------------------------
1840C L o c a l V a r i a b l e s
1841C-----------------------------------------------
1842 INTEGER JJ,JS,K,J,OK,OK1,IDBX,ITYPE,ISK,
1843 . FACES(4,6),PWR(7)
1844 MY_REAL
1845 . XP1,YP1,ZP1,XP2,YP2,ZP2,DIAM,NODINB(3)
1846 DATA faces/4,3,2,1,
1847 . 5,6,7,8,
1848 . 1,2,6,5,
1849 . 3,4,8,7,
1850 . 2,3,7,6,
1851 . 1,5,8,4/
1852 DATA pwr/1,2,4,8,16,32,64/
1853C=======================================================================
1854 ok = 0
1855 ok1 = 0
1856C-------
1857 idbx = ibox(isu)%ID
1858 isk = ibox(isu)%ISKBOX
1859 itype= ibox(isu)%TYPE
1860 diam = ibox(isu)%DIAM
1861 xp1 = ibox(isu)%X1
1862 yp1 = ibox(isu)%Y1
1863 zp1 = ibox(isu)%Z1
1864 xp2 = ibox(isu)%X2
1865 yp2 = ibox(isu)%Y2
1866 zp2 = ibox(isu)%Z2
1867C-------
1868 IF(idbx/=0)THEN
1869C---
1870 IF (boxtype == 2) THEN
1871 DO js=1,numels
1872 elstag(js)=0
1873 DO jj=1,6
1874 DO k=1,4
1875 ok=0
1876 j=ixs(faces(k,jj)+1,js)
1877 nodinb(1) = x(1,j)
1878 nodinb(2) = x(2,j)
1879 nodinb(3) = x(3,j)
1880 IF(itype == 1)THEN ! 'RECTA'
1881 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1882 . isk,nodinb,skew,ok)
1883 ELSE IF(itype == 2)THEN ! 'CYLIN'
1884 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1885 . nodinb , diam, ok )
1886 ELSE IF(itype == 3)THEN ! 'SPHER'
1887 CALL checksphere(xp1,yp1,zp1,nodinb,diam,ok)
1888 END IF
1889 IF (ok == 1) THEN
1890 elstag(js)=elstag(js)+pwr(jj)
1891 EXIT
1892 END IF
1893 ENDDO
1894 ENDDO
1895 ENDDO
1896C---
1897 ELSE IF (boxtype == 1) THEN
1898 DO js=1,numels
1899 elstag(js)=0
1900 DO jj=1,6
1901 ok1=0
1902 DO k=1,4
1903 ok=0
1904 j=ixs(faces(k,jj)+1,js)
1905 nodinb(1) = x(1,j)
1906 nodinb(2) = x(2,j)
1907 nodinb(3) = x(3,j)
1908 IF(itype == 1)THEN ! 'RECTA'
1909 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1910 . isk,nodinb,skew,ok)
1911 ELSE IF(itype == 2)THEN ! 'CYLIN'
1912 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1913 . nodinb , diam, ok )
1914 ELSE IF(itype == 3)THEN ! 'SPHER'
1915 CALL checksphere(xp1,yp1,zp1,nodinb,diam,ok)
1916 END IF
1917 IF(ok == 1) ok1 = ok1 + 1
1918 ENDDO
1919 IF (ok1 == 4) THEN
1920 elstag(js)=elstag(js)+pwr(jj)
1921 ENDIF
1922 ENDDO
1923 ENDDO
1924 ENDIF
1925 ENDIF
1926C-----------
1927 RETURN
1928 999 CALL freerr(1)
1929 RETURN
1930 END
1931!||====================================================================
1932!|| sboxboxsurf ../starter/source/model/box/bigbox.F
1933!||--- called by ------------------------------------------------------
1934!|| hm_read_surf ../starter/source/groups/hm_read_surf.F
1935!||--- calls -----------------------------------------------------
1936!|| ancmsg ../starter/source/output/message/message.F
1937!|| boxbufill ../starter/source/model/box/bigbox.F
1938!|| elstagbox ../starter/source/model/box/bigbox.F
1939!|| elstagboxbox ../starter/source/model/box/boxbox.F
1940!|| facebox ../starter/source/model/box/bigbox.F
1941!|| hm_get_int_array_index ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
1942!||--- uses -----------------------------------------------------
1943!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
1944!|| message_mod ../starter/share/message_module/message_mod.F
1945!|| submodel_mod ../starter/share/modules1/submodel_mod.F
1946!||====================================================================
1947 SUBROUTINE sboxboxsurf(IXS ,X ,NSEG,
1948 . KNOD2ELS,NOD2ELS,IEXT ,FLAG,
1949 . IXS10 ,IXS16 ,IXS20,SKEW ,IBOX,
1950 . ID ,IBUFBOX,IADB ,KEY ,
1951 . SBUFBOX ,TITR ,KNOD2ELC,NOD2ELC,IXC,
1952 . TAGSHELLBOXC,KNOD2ELTG,NOD2ELTG,IXTG ,
1953 . TAGSHELLBOXG,IGRSURF,NN,NSEG0,LSUBMODEL)
1954C-----------------------------------------------
1955C M o d u l e s
1956C-----------------------------------------------
1957 USE message_mod
1958 USE groupdef_mod
1959 USE optiondef_mod
1960 USE hm_option_read_mod
1961 USE submodel_mod
1962C-----------------------------------------------
1963C I m p l i c i t T y p e s
1964C-----------------------------------------------
1965#include "implicit_f.inc"
1966C-----------------------------------------------
1967C C o m m o n B l o c k s
1968C-----------------------------------------------
1969#include "com04_c.inc"
1970#include "param_c.inc"
1971C-----------------------------------------------
1972C D u m m y A r g u m e n t s
1973C-----------------------------------------------
1974 INTEGER IXS(NIXS,*),NSEG,KNOD2ELS(*),
1975 . NOD2ELS(*),IEXT,FLAG,IXS10(6,*),
1976 . IXS16(8,*),IXS20(12,*),ID,IBUFBOX(*),
1977 . knod2elc(*),nod2elc(*),ixc(nixc,*),tagshellboxc(*),
1978 . knod2eltg(*),nod2eltg(*),ixtg(nixtg,*) ,tagshellboxg(*),
1979 . iadb,sbufbox,nn,nseg0
1980 my_real
1981 . x(3,*),skew(lskew,*)
1982 CHARACTER KEY*4
1983 CHARACTER(LEN=NCHARTITLE) :: TITR
1984 TYPE (SURF_) :: IGRSURF
1985 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
1986 TYPE(SUBMODEL_DATA) LSUBMODEL(NSUBMOD)
1987C-----------------------------------------------
1988C L o c a l V a r i a b l e s
1989C-----------------------------------------------
1990 INTEGER I,JREC,IDB,BOXTYPE,ISU,ICOUNT,ITER,FLAGG,
1991 . boxseg,iadisu,elstag(numels)
1992 CHARACTER BOX*3
1993 LOGICAL BOOL,IS_AVAILABLE,IS_ENCRYPTED
1994C-----------------------------------------------
1995 DO I=1,nbbox
1996 ibox(i)%NBLEVELS = 0
1997 ibox(i)%LEVEL = 1
1998 ibox(i)%ACTIBOX = 0
1999 IF(ibox(i)%NBOXBOX > 0)THEN
2000 ibox(i)%NBLEVELS = -1
2001 ibox(i)%LEVEL = 0
2002 END IF
2003C
2004 ibox(i)%SURFIAD = 0 ! used for temporary storage
2005 END DO
2006C-------
2007 CALL hm_get_int_array_index('ids',idb,1,is_available,lsubmodel)
2008 IF(key == 'BOX')THEN
2009 boxtype = 1
2010 ELSE IF(key == 'BOX2')THEN
2011 boxtype = 2
2012 END IF
2013C-------
2014C get box de box ID'S dans SURF:
2015C-------
2016 isu = 0
2017 DO i=1,nbbox
2018 IF(idb == ibox(i)%ID) isu=i
2019 END DO
2020C---
2021 IF(isu <= 0)THEN
2022 IF(flag == 0)THEN
2023 CALL ancmsg(msgid=800,
2024 . msgtype=msgerror,
2025 . anmode=aninfo,
2026 . i1=id,
2027 . c1=titr,
2028 . i2=idb)
2029 END IF
2030 END IF
2031C---
2032C tag surfaces from solids within a simple box:
2033C---
2034 bool = .false.
2035 IF(isu>0)THEN
2036 IF(ibox(isu)%NBLEVELS == 0 .AND. ibox(isu)%LEVEL == 1)THEN
2037 IF(ibox(isu)%NBOXBOX == 0)THEN
2038C---
2039C tag faces of solids within box
2040C---
2041 CALL elstagbox(ixs ,elstag ,x ,skew ,boxtype,isu ,ibox )
2042C---
2043C fill tmp "IBUFBOX" for taged faces
2044C---
2045 CALL facebox(ixs ,x ,knod2els ,nod2els,iext ,
2046 . flag ,ixs10 ,ixs16 ,ixs20 ,skew ,
2047 . ibox ,elstag ,ibufbox ,iadb ,isu ,
2048 . id ,titr ,knod2elc ,nod2elc,ixc ,
2049 . tagshellboxc ,knod2eltg ,nod2eltg ,ixtg ,tagshellboxg,
2050 . 0 )
2051 IF (iadb>sbufbox .OR. iadb<0) CALL ancmsg(msgid=1007, msgtype=msgerror,anmode=anstop)
2052 bool = .true.
2053 END IF
2054 END IF
2055 ENDIF
2056C---
2057C READ LEVELS OF BOXES ==> "SUBLEVEL DONE"
2058C---
2059C---
2060C fill tmp "IBUFBOX" for taged faces
2061C---
2062 IF(.NOT. bool)THEN
2063 icount = 1
2064 iter = 0
2065 DO WHILE (icount == 1)
2066 iter = iter + 1
2067 flagg = 0
2068C--- count next level
2069 CALL elstagboxbox(
2070 . ibox ,skew ,flagg ,icount ,iter ,
2071 . boxtype ,ibufbox ,x ,iadb ,ixs ,
2072 . knod2els ,nod2els ,iext ,flag ,ixs10 ,
2073 . ixs16 ,ixs20 ,elstag ,id ,titr ,
2074 . knod2elc ,nod2elc ,ixc ,tagshellboxc,knod2eltg,
2075 . nod2eltg ,ixtg ,tagshellboxg,0 )
2076 IF (iadb>sbufbox .OR. iadb<0)
2077 . CALL ancmsg(msgid=1007, msgtype=msgerror,anmode=anstop)
2078C--- fill next level
2079 flagg = 1
2080 CALL elstagboxbox(
2081 . ibox ,skew ,flagg ,icount ,iter ,
2082 . boxtype ,ibufbox ,x ,iadb ,ixs ,
2083 . knod2els ,nod2els ,iext ,flag ,ixs10 ,
2084 . ixs16 ,ixs20 ,elstag ,id ,titr ,
2085 . knod2elc ,nod2elc ,ixc ,tagshellboxc,knod2eltg,
2086 . nod2eltg ,ixtg ,tagshellboxg,0 )
2087 ENDDO
2088 ENDIF
2089
2090C--------------------------
2091C
2092C fill final - IBUFSSG - for taged faces
2093C
2094 IF(isu > 0)THEN
2095 boxseg = ibox(isu)%NENTITY ! nb of surfaces in main box (/box/box)
2096 iadisu = ibox(isu)%SURFIAD ! addresses of surfaces in main box
2097 IF(flag == 0)THEN
2098 nseg=nseg+boxseg
2099 ELSE IF(flag == 1)THEN
2100 nseg=nseg+boxseg
2101 DO i=1,boxseg
2102 nn = nn + 1
2103 CALL boxbufill(iadisu,ibufbox,igrsurf%NODES,nn,nseg0,
2104 . igrsurf%ELTYP,igrsurf%ELEM)
2105 END DO
2106 END IF
2107 END IF
2108C--------------------------
2109 RETURN
2110 999 CALL freerr(1)
2111 RETURN
2112 END
2113!||====================================================================
2114!|| facebox ../starter/source/model/box/bigbox.f
2115!||--- called by ------------------------------------------------------
2116!|| elstagboxbox ../starter/source/model/box/boxbox.F
2117!|| sboxboxsurf ../starter/source/model/box/bigbox.f
2118!||--- calls -----------------------------------------------------
2119!|| ancmsg ../starter/source/output/message/message.F
2120!|| ssurf10tmp ../starter/source/model/box/bigbox.F
2121!||--- uses -----------------------------------------------------
2122!|| message_mod ../starter/share/message_module/message_mod.F
2123!||====================================================================
2124 SUBROUTINE facebox(IXS ,X ,KNOD2ELS ,NOD2ELS,IEXT ,
2125 . FLAG ,IXS10 ,IXS16 ,IXS20 ,SKEW ,
2126 . IBOX ,ELSTAG ,IBUFBOX ,IADB ,ISU ,
2127 . ID ,TITR ,KNOD2ELC ,NOD2ELC,IXC ,
2128 . TAGSHELLBOXC,KNOD2ELTG,NOD2ELTG ,IXTG ,TAGSHELLBOXG,
2129 . IEXT_SET )
2130C-----------------------------------------------
2131C M o d u l e s
2132C-----------------------------------------------
2133 USE message_mod
2134 USE optiondef_mod
2135 USE names_and_titles_mod , ONLY : nchartitle
2136C-----------------------------------------------
2137C I m p l i c i t T y p e s
2138C-----------------------------------------------
2139#include "implicit_f.inc"
2140C-----------------------------------------------
2141C C o m m o n B l o c k s
2142C-----------------------------------------------
2143#include "com04_c.inc"
2144#include "param_c.inc"
2145C-----------------------------------------------
2146C D u m m y A r g u m e n t s
2147C-----------------------------------------------
2148 INTEGER ID,IEXT_SET
2149 INTEGER IXS(NIXS,*),KNOD2ELS(*),
2150 . NOD2ELS(*),IEXT,FLAG,IXS10(6,*),IXS16(8,*),
2151 . IXS20(12,*),IBUFBOX(*),IADB,ISU,ELSTAG(*),
2152 . KNOD2ELC(*),NOD2ELC(*),IXC(NIXC,*),TAGSHELLBOXC(*),KNOD2ELTG(*),
2153 . NOD2ELTG(*),IXTG(NIXTG,*),TAGSHELLBOXG(*)
2154 MY_REAL
2155 . X(3,*),SKEW(LSKEW,*)
2156 CHARACTER(LEN=NCHARTITLE)::TITR
2157C-----------------------------------------------
2158 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
2159C-----------------------------------------------
2160C L o c a l V a r i a b l e s
2161C-----------------------------------------------
2162 INTEGER I,N,J,K,JS,KS,II,JJ,K1,K2,LL,FACE(4),FC10(3),NN,KK,I1,
2163 . NI(4),NS(4),MI(4),MS(4),NMIN,MMIN,NF,MF,IPERM,N1,N2,
2164 . BOXSEG,IADB0,NNS,ISHEL
2165 INTEGER NODTAG(NUMNOD),FASTAG(NUMELS)
2166 INTEGER FACES(4,6),PWR(7),FACES10(3,6)
2167 DATA FACES/4,3,2,1,
2168 . 5,6,7,8,
2169 . 1,2,6,5,
2170 . 3,4,8,7,
2171 . 2,3,7,6,
2172 . 1,5,8,4/
2173 DATA faces10/0,0,0,
2174 . 0,0,0,
2175 . 3,6,4,
2176 . 5,6,2,
2177 . 1,2,3,
2178 . 4,5,1/
2179 DATA pwr/1,2,4,8,16,32,64/
2180 CHARACTER BOX*3
2181C-----------------------------------------------
2182 BOXSEG = 0
2183 iadb0 = iadb
2184C---
2185C fill tmp "IBUFBOX" for taged faces
2186C---
2187C-------------------------
2188 IF(iext==0)THEN
2189 DO js=1,numels
2190 IF(elstag(js)/=0)THEN
2191 CALL ancmsg(msgid=802,
2192 . msgtype=msgerror,
2193 . anmode=aninfo,
2194 . i1=id,
2195 . c1=titr)
2196 END IF
2197 ENDDO
2198 ENDIF
2199C-------------------------
2200C
2201 fastag=0
2202C
2203 IF(iext==1)THEN
2204C--------------------------
2205C External surface only
2206C--------------------------
2207 DO js=1,numels8+numels10
2208 DO jj=1,6
2209 IF(mod(elstag(js),pwr(jj+1))/pwr(jj)==0)cycle
2210 DO ii=1,4
2211 ns(ii)=ixs(faces(ii,jj)+1,js)
2212 END DO
2213C
2214C keep only 1 occurrence of each node (triangles, degenerated cases...)
2215C
2216 DO k1=1,3
2217 DO k2=k1+1,4
2218 IF(ns(k2)==ns(k1))ns(k2)=0
2219 END DO
2220 END DO
2221 nf=0
2222 DO k1=1,4
2223 n1=ns(k1)
2224 IF(n1/=0)THEN
2225 nf=nf+1
2226 ns(nf)=n1
2227 END IF
2228 END DO
2229 IF(nf < 3)cycle
2230C
2231C permute
2232C
2233 nmin=ns(1)
2234 DO ii=2,nf
2235 nmin=min(nmin,ns(ii))
2236 END DO
2237 DO iperm=1,nf
2238 IF(nmin==ns(iperm).AND.
2239 . ns(mod(iperm,nf)+1)/=ns(iperm))THEN
2240 DO ii=1,nf
2241 ni(ii)=ns(mod(ii+iperm-2,nf)+1)
2242 END DO
2243 EXIT
2244 END IF
2245 END DO
2246C
2247C looks for an elt sharing the face.
2248C
2249 DO k=knod2els(ni(1))+1,knod2els(ni(1)+1)
2250 ks=nod2els(k)
2251 IF(ks==js .OR. ks > numels8+numels10 .OR.
2252 . elstag(ks)==0) cycle
2253 DO ii=1,nf
2254 nodtag(ni(ii))=0
2255 END DO
2256 DO ii=1,8
2257 nodtag(ixs(ii+1,ks))=1
2258 END DO
2259 nn=0
2260 DO ii=1,nf
2261 nn=nn+nodtag(ni(ii))
2262 END DO
2263 IF(nn==nf)THEN
2264 DO kk=1,6
2265 DO ii=1,4
2266 ms(ii)=ixs(faces(ii,kk)+1,ks)
2267 END DO
2268C
2269C keep only 1 occurrence of each node (triangles, degenerated cases...)
2270C
2271 DO k1=1,3
2272 DO k2=k1+1,4
2273 IF(ms(k2)==ms(k1))ms(k2)=0
2274 END DO
2275 END DO
2276 mf=0
2277 DO k1=1,4
2278 n1=ms(k1)
2279 IF(n1/=0)THEN
2280 mf=mf+1
2281 ms(mf)=n1
2282 END IF
2283 END DO
2284 IF(mf /= nf)cycle
2285C
2286C permute
2287C
2288 mmin=ms(1)
2289 DO ii=2,mf
2290 mmin=min(mmin,ms(ii))
2291 END DO
2292 DO iperm=1,mf
2293 IF(mmin==ms(iperm).AND.
2294 . ms(mod(iperm,mf)+1)/=ms(iperm))THEN
2295 DO ii=1,mf
2296 mi(ii)=ms(mod(ii+iperm-2,mf)+1)
2297 END DO
2298 EXIT
2299 END IF
2300 END DO
2301 IF(mi(1)==ni(1).AND.mi(nf)==ni(2))THEN
2302C FACTAG(JS) moins face jj
2303 fastag(js)=fastag(js)+pwr(jj)
2304 GO TO 100
2305 END IF
2306 END DO
2307 END IF
2308 END DO
2309 100 CONTINUE
2310 END DO
2311 END DO
2312 END IF
2313C--------------------------
2314C
2315C--------------------------
2316 DO js=1,numels8
2317 IF(elstag(js)>0)THEN
2318 DO jj=1,6
2319 IF(mod(elstag(js),pwr(jj+1))/pwr(jj)/=0 .AND.
2320 . mod(fastag(js),pwr(jj+1))/pwr(jj)==0)THEN
2321C
2322C still needs to filter degenerated faces
2323C
2324 DO k1=1,4
2325 i1 =faces(k1,jj)+1
2326 face(k1)=ixs(i1,js)
2327 END DO
2328 DO k1=1,4
2329 n1=face(k1)
2330 DO k2=1,4
2331 IF(k2/=k1)THEN
2332 n2=face(k2)
2333 IF(n2==n1)face(k2)=0
2334 END IF
2335 END DO
2336 END DO
2337 nn=0
2338 DO k1=1,4
2339 n1=face(k1)
2340 IF(n1/=0)THEN
2341 nn=nn+1
2342 face(nn)=n1
2343 END IF
2344 END DO
2345
2346
2347C--- find shells SURF/BOX/BOX/EXT
2348
2349C
2350C count faces within the box:
2351C
2352 IF(flag == 0 .and. nn == 3) THEN
2353 ks = 0
2354 ishel = 0
2355 DO k=knod2eltg(face(1))+1,knod2eltg(face(1)+1)
2356 ks=nod2eltg(k)
2357 ishel = 0
2358 DO i=1,3
2359 DO j=1,3
2360 IF(face(i) == ixtg(j+1,ks)) ishel = ishel + 1
2361 ENDDO
2362 ENDDO
2363 IF (ishel == 3)EXIT
2364 ks = 0
2365 ENDDO
2366 IF(ks == 0)THEN
2367 boxseg=boxseg+1
2368 iadb = iadb + 6
2369 IF (iext_set > 0) iadb = iadb + 1
2370 ELSEIF(tagshellboxg(ks)==0) THEN
2371 boxseg=boxseg+1
2372 iadb = iadb + 6
2373 IF (iext_set > 0) iadb = iadb + 1
2374 ENDIF
2375 ELSEIF(flag == 0 .and. nn == 4) THEN
2376 ks = 0
2377 ishel = 0
2378 DO k=knod2elc(face(1))+1,knod2elc(face(1)+1)
2379 ks=nod2elc(k)
2380 ishel = 0
2381 DO i=1,4
2382 DO j=1,4
2383 IF(face(i) == ixc(j+1,ks)) ishel = ishel + 1
2384 ENDDO
2385 ENDDO
2386 IF (ishel == 4)EXIT
2387 ks = 0
2388 ENDDO
2389 IF(ks == 0)THEN
2390 boxseg=boxseg+1
2391 iadb = iadb + 6
2392 IF (iext_set > 0) iadb = iadb + 1
2393 ELSEIF(tagshellboxc(ks)==0) THEN
2394 boxseg=boxseg+1
2395 iadb = iadb + 6
2396 IF (iext_set > 0) iadb = iadb + 1
2397 ENDIF
2398 ELSEIF(nn==3)THEN
2399 ks = 0
2400 ishel = 0
2401 DO k=knod2eltg(face(1))+1,knod2eltg(face(1)+1)
2402 ks=nod2eltg(k)
2403 ishel = 0
2404 DO i=1,3
2405 DO j=1,3
2406 IF(face(i) == ixtg(j+1,ks)) ishel = ishel + 1
2407 ENDDO
2408 ENDDO
2409 IF (ishel == 3)EXIT
2410 ks = 0
2411 ENDDO
2412 IF(ks == 0)THEN
2413 boxseg=boxseg+1
2414 CALL ssurf10tmp(face(1),face(2),face(3),face(3),
2415 . iadb,js,ibufbox,iext_set)
2416 ELSEIF(tagshellboxg(ks)==0) THEN
2417 boxseg=boxseg+1
2418 CALL ssurf10tmp(face(1),face(2),face(3),face(3),
2419 . iadb,js,ibufbox,iext_set)
2420 ENDIF
2421 ELSEIF(nn==4)THEN
2422 ks = 0
2423 ishel = 0
2424 DO k=knod2elc(face(1))+1,knod2elc(face(1)+1)
2425 ks=nod2elc(k)
2426 ishel = 0
2427 DO i=1,4
2428 DO j=1,4
2429 IF(face(i) == ixc(j+1,ks)) ishel = ishel + 1
2430 ENDDO
2431 ENDDO
2432 IF (ishel == 4)EXIT
2433 ks = 0
2434 ENDDO
2435 IF(ks == 0)THEN
2436 boxseg=boxseg+1
2437 CALL ssurf10tmp(face(1),face(2),face(3),face(4),
2438 . iadb,js,ibufbox,iext_set)
2439 ELSEIF(tagshellboxc(ks)==0) THEN
2440 boxseg=boxseg+1
2441 CALL ssurf10tmp(face(1),face(2),face(3),face(4),
2442 . iadb,js,ibufbox,iext_set)
2443
2444 ENDIF
2445 END IF
2446C---
2447 END IF
2448 END DO
2449 ENDIF
2450 ENDDO
2451C--------------------------
2452C
2453C--------------------------
2454 DO j=1,numels10
2455 js = j+numels8
2456 IF(elstag(js)>0)THEN
2457 DO jj=3,6
2458 IF(mod(elstag(js),pwr(jj+1))/pwr(jj)/=0 .AND.
2459 . mod(fastag(js),pwr(jj+1))/pwr(jj)==0)THEN
2460C
2461C still needs to filter degenerated faces
2462C
2463 DO k1=1,4
2464 face(k1)=ixs(faces(k1,jj)+1,js)
2465 END DO
2466 DO k1=1,3
2467 DO k2=k1+1,4
2468 IF(face(k2) == face(k1)) face(k2)=0
2469 END DO
2470 END DO
2471 nn=0
2472 DO k1=1,4
2473 IF(face(k1) /= 0)THEN
2474 nn=nn+1
2475 face(nn)=face(k1)
2476 END IF
2477 END DO
2478C
2479 IF(nn == 3)THEN
2480 nns=1
2481 fc10(1)=ixs10(faces10(1,jj),j)
2482 fc10(2)=ixs10(faces10(2,jj),j)
2483 fc10(3)=ixs10(faces10(3,jj),j)
2484 IF(fc10(1) /= 0)nns=nns+1
2485 IF(fc10(2) /= 0)nns=nns+1
2486 IF(fc10(3) /= 0)nns=nns+1
2487C
2488C count faces within the box:
2489C
2490 IF(nns == 3)nns=2
2491 boxseg=boxseg+nns
2492 IF(nns == 4)THEN
2493c 4 triangles
2494C
2495 IF (flag == 0)THEN
2496 iadb = iadb + 24
2497 IF (iext_set > 0) iadb = iadb + 4
2498 ELSEIF (flag == 1) THEN
2499 CALL ssurf10tmp(face(1),fc10(1),fc10(3),fc10(3),
2500 . iadb,js,ibufbox,iext_set)
2501 CALL ssurf10tmp(face(2),fc10(2),fc10(1),fc10(1),
2502 . iadb,js,ibufbox,iext_set)
2503 CALL ssurf10tmp(face(3),fc10(3),fc10(2),fc10(2),
2504 . iadb,js,ibufbox,iext_set)
2505 CALL ssurf10tmp(fc10(1),fc10(2),fc10(3),fc10(3),
2506 . iadb,js,ibufbox,iext_set)
2507 ENDIF ! IF (FLAG == 0)
2508 ELSEIF(nns == 3)THEN
2509c 1 quadrangle, 1 triangle
2510C
2511 IF (flag == 0)THEN
2512 iadb = iadb + 12
2513 IF (iext_set > 0) iadb = iadb + 2
2514 ELSEIF (flag == 1) THEN
2515 IF(fc10(1) == 0)THEN
2516 CALL ssurf10tmp(face(1),face(2),fc10(2),fc10(3),
2517 . iadb,js,ibufbox,iext_set)
2518 CALL ssurf10tmp(face(3),fc10(3),fc10(2),fc10(2),
2519 . iadb,js,ibufbox,iext_set)
2520 ELSEIF(fc10(2) == 0)THEN
2521 CALL ssurf10tmp(face(2),face(3),fc10(3),fc10(1),
2522 . iadb,js,ibufbox,iext_set)
2523 CALL ssurf10tmp(face(1),fc10(1),fc10(3),fc10(3),
2524 . iadb,js,ibufbox,iext_set)
2525 ELSEIF(fc10(3) == 0)THEN
2526 CALL ssurf10tmp(face(3),face(1),fc10(1),fc10(2),
2527 . iadb,js,ibufbox,iext_set)
2528 CALL ssurf10tmp(face(2),fc10(2),fc10(1),fc10(1),
2529 . iadb,js,ibufbox,iext_set)
2530 ENDIF
2531 ENDIF ! IF (FLAG == 0)
2532 ELSEIF(nns == 2)THEN
2533c 2 triangles
2534C
2535 IF (flag == 0)THEN
2536 iadb = iadb + 12
2537 IF (iext_set > 0) iadb = iadb + 2
2538 ELSEIF (flag == 1) THEN
2539 IF(fc10(1) /= 0)THEN
2540 CALL ssurf10tmp(face(3),face(1),fc10(1),fc10(1),
2541 . iadb,js,ibufbox,iext_set)
2542 CALL ssurf10tmp(face(2),face(3),fc10(1),fc10(1),
2543 . iadb,js,ibufbox,iext_set)
2544 ELSEIF(fc10(2) /= 0)THEN
2545 CALL ssurf10tmp(face(1),face(2),fc10(2),fc10(2),
2546 . iadb,js,ibufbox,iext_set)
2547 CALL ssurf10tmp(face(3),face(1),fc10(2),fc10(2),
2548 . iadb,js,ibufbox,iext_set)
2549 ELSEIF(fc10(3) /= 0)THEN
2550 CALL ssurf10tmp(face(2),face(3),fc10(3),fc10(3),
2551 . iadb,js,ibufbox,iext_set)
2552 CALL ssurf10tmp(face(1),face(2),fc10(3),fc10(3),
2553 . iadb,js,ibufbox,iext_set)
2554 ENDIF
2555 ENDIF ! IF (FLAG == 0)
2556 ELSEIF(nns == 1)THEN
2557c 1 triangle
2558C
2559 IF (flag == 0)THEN
2560 iadb = iadb + 6
2561 IF (iext_set > 0) iadb = iadb + 1
2562 ELSEIF (flag == 1) THEN
2563 CALL ssurf10tmp(face(1),face(2),face(3),face(3),
2564 . iadb,js,ibufbox,iext_set)
2565 ENDIF ! IF (FLAG == 0)
2566 END IF
2567 END IF
2568 END IF
2569 END DO
2570 ENDIF
2571 ENDDO
2572C
2573cc IF (FLAG == 0) IADB = IADB + BOXSEG
2574C--------------------------
2575 IF(isu>0)THEN
2576 IF(ibox(isu)%ID > 0)THEN
2577 ibox(isu)%NENTITY=boxseg
2578 ibox(isu)%SURFIAD=iadb0
2579 END IF
2580 ENDIF
2581C--------------------------
2582C
2583 RETURN
2584 999 CALL freerr(1)
2585 RETURN
2586 END
2587!||====================================================================
2588!|| boxbufill ../starter/source/model/box/bigbox.F
2589!||--- called by ------------------------------------------------------
2590!|| sboxboxsurf ../starter/source/model/box/bigbox.F
2591!||====================================================================
2592 SUBROUTINE boxbufill(IADISU,IBUFBOX,SURF_NODES,NN,NSEG0,
2593 . SURF_ELTYP,SURF_ELEM)
2594C-----------------------------------------------
2595C I m p l i c i t T y p e s
2596C-----------------------------------------------
2597#include "implicit_f.inc"
2598C-----------------------------------------------
2599 INTEGER J,IADISU,IBUFBOX(*),NN,NSEG0,SURF_NODES(NSEG0,4),
2600 . SURF_ELTYP(NSEG0),SURF_ELEM(NSEG0)
2601C---------------------------------
2602 j=ibufbox(iadisu) ! N1
2603 iadisu=iadisu+1
2604 surf_nodes(nn,1) = j
2605C
2606 j=ibufbox(iadisu) ! N2
2607 iadisu=iadisu+1
2608 surf_nodes(nn,2) = j
2609C
2610 j=ibufbox(iadisu) ! N3
2611 iadisu=iadisu+1
2612 surf_nodes(nn,3) = j
2613C
2614 j=ibufbox(iadisu) ! N4
2615 iadisu=iadisu+1
2616 surf_nodes(nn,4) = j
2617C
2618 j=ibufbox(iadisu) ! IELTYP
2619 iadisu=iadisu+1
2620 surf_eltyp(nn) = j
2621C
2622 j=ibufbox(iadisu) ! JS - element id
2623 iadisu=iadisu+1
2624 surf_elem(nn) = j
2625C
2626 RETURN
2627 END
2628!||====================================================================
2629!|| ssurf10tmp ../starter/source/model/box/bigbox.F
2630!||--- called by ------------------------------------------------------
2631!|| facebox ../starter/source/model/box/bigbox.F
2632!||====================================================================
2633 SUBROUTINE ssurf10tmp(N1,N2,N3,N4,IAD,JS,IBUFBOX,IEXT_SET)
2634C-----------------------------------------------
2635C I m p l i c i t T y p e s
2636C-----------------------------------------------
2637#include "implicit_f.inc"
2638C-----------------------------------------------
2639C D u m m y A r g u m e n t s
2640C-----------------------------------------------
2641 INTEGER N1,N2,N3,N4,IAD,JS,IBUFBOX(*),IEXT_SET
2642C-----------------------------------------------
2643 ibufbox(iad)=n1
2644 iad=iad+1
2645 ibufbox(iad)=n2
2646 iad=iad+1
2647 ibufbox(iad)=n3
2648 iad=iad+1
2649 ibufbox(iad)=n4
2650 iad=iad+1
2651 ibufbox(iad)=1
2652 iad=iad+1
2653 ibufbox(iad)=js
2654 iad=iad+1
2655!
2656 IF (iext_set > 0) THEN
2657 ibufbox(iad) = 2 ! IEXT = 2 (all - need for /LINE/SURF)
2658 iad=iad+1
2659 ENDIF
2660!---
2661 RETURN
2662 END
boxassem4
subroutine boxassem4(ibox, ibufbox, ib, iadb, flag, iext_set)
Definition bigbox.F:728
facebox
subroutine facebox(ixs, x, knod2els, nod2els, iext, flag, ixs10, ixs16, ixs20, skew, ibox, elstag, ibufbox, iadb, isu, id, titr, knod2elc, nod2elc, ixc, tagshellboxc, knod2eltg, nod2eltg, ixtg, tagshellboxg, iext_set)
Definition bigbox.F:2130
sboxboxsurf
subroutine sboxboxsurf(ixs, x, nseg, knod2els, nod2els, iext, flag, ixs10, ixs16, ixs20, skew, ibox, id, ibufbox, iadb, key, sbufbox, titr, knod2elc, nod2elc, ixc, tagshellboxc, knod2eltg, nod2eltg, ixtg, tagshellboxg, igrsurf, nn, nseg0, lsubmodel)
Definition bigbox.F:1954
bigbox
subroutine bigbox(x, flag, nnod, skew, igs, iskn, itabm1, ibox, id, ibufbox, iadb, titr, key, nn, iboxmax, igrnod)
Definition bigbox.F:38
boxtagn
subroutine boxtagn(x, ibufbox, skew, iadb, ibox, isu, flag, iboxmax)
Definition bigbox.F:188
boxtage
subroutine boxtage(x, skew, ibox, isu, boxtype, ix, nix, nix1, iparte, ipart, klevtree, eltree, keltree, numel, nadmesh, flag, iboxmax, iadb, ibufbox)
Definition bigbox.F:1033
boxassem1
subroutine boxassem1(ibox, ibufbox, ib, iadb, flag)
Definition bigbox.F:304
boxassem2
subroutine boxassem2(ibox, ibufbox, ib, iadb, numel, flag, iboxmax)
Definition bigbox.F:428
ssurf10tmp
subroutine ssurf10tmp(n1, n2, n3, n4, iad, js, ibufbox, iext_set)
Definition bigbox.F:2634
boxassem3
subroutine boxassem3(ibox, ibufbox, ib, iadb, numel, nix, ix, nix1, nix2, isurf0, ieltyp, flag, iext)
Definition bigbox.F:554
elstagbox
subroutine elstagbox(ixs, elstag, x, skew, boxtype, isu, ibox)
Definition bigbox.F:1819
box_surf_sh
subroutine box_surf_sh(x, ibufbox, skew, iadb, boxtype, ibox, isu, numel, nix, ix, nix1, nix2, isurf0, ieltyp, flag, tagshellbox, iext)
Definition bigbox.F:1421
bigsbox
subroutine bigsbox(numel, ix, nix, nix1, nix2, ieltyp, x, nseg, flag, skew, iskn, isurf0, itabm1, ibox, id, ibufbox, isurflin, iadb, key, sbufbox, titr, mess, tagshellbox, nn)
Definition bigbox.F:1615
boxbufill
subroutine boxbufill(iadisu, ibufbox, surf_nodes, nn, nseg0, surf_eltyp, surf_elem)
Definition bigbox.F:2594
bigbox2
subroutine bigbox2(x, flag, nel, skew, igs, iskn, itabm1, ibox, id, nadmesh, nix, ix, nix1, numel, iparte, ipart, klevtree, eltree, keltree, buftmp, key, titr, mes, igrelem, ngrele, nn, iadb, iboxmax, ibufbox)
Definition bigbox.F:1246
boxbox2
subroutine boxbox2(ibox, skew, flagg, icount, iter, boxtype, x, ix, flag, iboxmax, nix, nix1, iparte, ipart, klevtree, eltree, keltree, numel, nadmesh, id, titr, mes, iadb, ibufbox)
Definition boxbox.F:181
boxboxs
subroutine boxboxs(ibox, skew, flagg, icount, iter, boxtype, ibufbox, x, iadb, ix, nix, nix1, nix2, numel, isurf0, ieltyp, id, titr, mess, flag, tagshellbox, iext)
Definition boxbox.F:326
elstagboxbox
subroutine elstagboxbox(ibox, skew, flagg, icount, iter, boxtype, ibufbox, x, iadb, ixs, knod2els, nod2els, iext, flag, ixs10, ixs16, ixs20, elstag, id, titr, knod2elc, nod2elc, ixc, tagshellboxc, knod2eltg, nod2eltg, ixtg, tagshellboxg, iext_set)
Definition boxbox.F:472
boxbox
subroutine boxbox(ibox, skew, flagg, icount, iter, ibufbox, x, iadb, id, titr, key, flag, iboxmax)
Definition boxbox.F:39
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
min
#define min(a, b)
Definition macros.h:20
groupdef_mod
Definition groupdef_mod.F:662
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1005
optiondef_mod
Definition optiondef_mod.F:90
submodel_mod
Definition submodel_mod.F:712
checkcyl
subroutine checkcyl(xp1, yp1, zp1, xp2, yp2, zp2, nodin, d, ok)
Definition rdbox.F:229
checkpara
subroutine checkpara(xp1, yp1, zp1, xp2, yp2, zp2, isk, nodin, skew, ok)
Definition rdbox.F:39
checksphere
subroutine checksphere(xp, yp, zp, nodin, d, ok)
Definition rdbox.F:347
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
freerr
subroutine freerr(it)
Definition freform.F:506
starter
program starter
Definition starter.F:39