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 from box ID'S in 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 in 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 in 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 from box ID'S in 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 in 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 from box ID'S in 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 in /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 (or 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
1823 use element_mod , only : nixs
1824C-----------------------------------------------
1825C I m p l i c i t T y p e s
1826C-----------------------------------------------
1827#include "implicit_f.inc"
1828C-----------------------------------------------
1829C C o m m o n B l o c k s
1830C-----------------------------------------------
1831#include "com04_c.inc"
1832#include "param_c.inc"
1833C-----------------------------------------------
1834C D u m m y A r g u m e n t s
1835C-----------------------------------------------
1836 INTEGER IXS(NIXS,*),ELSTAG(*),BOXTYPE,ISU
1837 MY_REAL
1838 . X(3,*),SKEW(LSKEW,*)
1839 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
1840C-----------------------------------------------
1841C L o c a l V a r i a b l e s
1842C-----------------------------------------------
1843 INTEGER JJ,JS,K,J,OK,OK1,IDBX,ITYPE,ISK,
1844 . FACES(4,6),PWR(7)
1845 MY_REAL
1846 . xp1,yp1,zp1,xp2,yp2,zp2,diam,nodinb(3)
1847 DATA faces/4,3,2,1,
1848 . 5,6,7,8,
1849 . 1,2,6,5,
1850 . 3,4,8,7,
1851 . 2,3,7,6,
1852 . 1,5,8,4/
1853 DATA pwr/1,2,4,8,16,32,64/
1854C=======================================================================
1855 ok = 0
1856 ok1 = 0
1857C-------
1858 idbx = ibox(isu)%ID
1859 isk = ibox(isu)%ISKBOX
1860 itype= ibox(isu)%TYPE
1861 diam = ibox(isu)%DIAM
1862 xp1 = ibox(isu)%X1
1863 yp1 = ibox(isu)%Y1
1864 zp1 = ibox(isu)%Z1
1865 xp2 = ibox(isu)%X2
1866 yp2 = ibox(isu)%Y2
1867 zp2 = ibox(isu)%Z2
1868C-------
1869 IF(idbx/=0)THEN
1870C---
1871 IF (boxtype == 2) THEN
1872 DO js=1,numels
1873 elstag(js)=0
1874 DO jj=1,6
1875 DO k=1,4
1876 ok=0
1877 j=ixs(faces(k,jj)+1,js)
1878 nodinb(1) = x(1,j)
1879 nodinb(2) = x(2,j)
1880 nodinb(3) = x(3,j)
1881 IF(itype == 1)THEN ! 'RECTA'
1882 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1883 . isk,nodinb,skew,ok)
1884 ELSE IF(itype == 2)THEN ! 'CYLIN'
1885 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1886 . nodinb , diam, ok )
1887 ELSE IF(itype == 3)THEN ! 'SPHER'
1888 CALL checksphere(xp1,yp1,zp1,nodinb,diam,ok)
1889 END IF
1890 IF (ok == 1) THEN
1891 elstag(js)=elstag(js)+pwr(jj)
1892 EXIT
1893 END IF
1894 ENDDO
1895 ENDDO
1896 ENDDO
1897C---
1898 ELSE IF (boxtype == 1) THEN
1899 DO js=1,numels
1900 elstag(js)=0
1901 DO jj=1,6
1902 ok1=0
1903 DO k=1,4
1904 ok=0
1905 j=ixs(faces(k,jj)+1,js)
1906 nodinb(1) = x(1,j)
1907 nodinb(2) = x(2,j)
1908 nodinb(3) = x(3,j)
1909 IF(itype == 1)THEN ! 'RECTA'
1910 CALL checkpara(xp1,yp1,zp1,xp2,yp2,zp2,
1911 . isk,nodinb,skew,ok)
1912 ELSE IF(itype == 2)THEN ! 'CYLIN'
1913 CALL checkcyl(xp1, yp1, zp1 , xp2, yp2, zp2,
1914 . nodinb , diam, ok )
1915 ELSE IF(itype == 3)THEN ! 'SPHER'
1916 CALL checksphere(xp1,yp1,zp1,nodinb,diam,ok)
1917 END IF
1918 IF(ok == 1) ok1 = ok1 + 1
1919 ENDDO
1920 IF (ok1 == 4) THEN
1921 elstag(js)=elstag(js)+pwr(jj)
1922 ENDIF
1923 ENDDO
1924 ENDDO
1925 ENDIF
1926 ENDIF
1927C-----------
1928 RETURN
1929 999 CALL freerr(1)
1930 RETURN
1931 END
1932!||====================================================================
1933!|| sboxboxsurf ../starter/source/model/box/bigbox.F
1934!||--- called by ------------------------------------------------------
1935!|| hm_read_surf ../starter/source/groups/hm_read_surf.F
1936!||--- calls -----------------------------------------------------
1937!|| ancmsg ../starter/source/output/message/message.F
1938!|| boxbufill ../starter/source/model/box/bigbox.F
1939!|| elstagbox ../starter/source/model/box/bigbox.F
1940!|| elstagboxbox ../starter/source/model/box/boxbox.F
1941!|| facebox ../starter/source/model/box/bigbox.F
1942!|| hm_get_int_array_index ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
1943!||--- uses -----------------------------------------------------
1944!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
1945!|| message_mod ../starter/share/message_module/message_mod.F
1946!|| submodel_mod ../starter/share/modules1/submodel_mod.F
1947!||====================================================================
1948 SUBROUTINE sboxboxsurf(IXS ,X ,NSEG,
1949 . KNOD2ELS,NOD2ELS,IEXT ,FLAG,
1950 . IXS10 ,IXS16 ,IXS20,SKEW ,IBOX,
1951 . ID ,IBUFBOX,IADB ,KEY ,
1952 . SBUFBOX ,TITR ,KNOD2ELC,NOD2ELC,IXC,
1953 . TAGSHELLBOXC,KNOD2ELTG,NOD2ELTG,IXTG ,
1954 . TAGSHELLBOXG,IGRSURF,NN,NSEG0,LSUBMODEL)
1955C-----------------------------------------------
1956C M o d u l e s
1957C-----------------------------------------------
1958 USE message_mod
1959 USE groupdef_mod
1960 USE optiondef_mod
1961 USE hm_option_read_mod
1962 USE submodel_mod
1963 use element_mod , only : nixs,nixc,nixtg
1964C-----------------------------------------------
1965C I m p l i c i t T y p e s
1966C-----------------------------------------------
1967#include "implicit_f.inc"
1968C-----------------------------------------------
1969C C o m m o n B l o c k s
1970C-----------------------------------------------
1971#include "com04_c.inc"
1972#include "param_c.inc"
1973C-----------------------------------------------
1974C D u m m y A r g u m e n t s
1975C-----------------------------------------------
1976 INTEGER IXS(NIXS,*),NSEG,KNOD2ELS(*),
1977 . NOD2ELS(*),IEXT,FLAG,IXS10(6,*),
1978 . ixs16(8,*),ixs20(12,*),id,ibufbox(*),
1979 . knod2elc(*),nod2elc(*),ixc(nixc,*),tagshellboxc(*),
1980 . knod2eltg(*),nod2eltg(*),ixtg(nixtg,*) ,tagshellboxg(*),
1981 . iadb,sbufbox,nn,nseg0
1982 my_real
1983 . x(3,*),skew(lskew,*)
1984 CHARACTER KEY*4
1985 CHARACTER(LEN=NCHARTITLE) :: TITR
1986 TYPE (SURF_) :: IGRSURF
1987 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
1988 TYPE(submodel_data) LSUBMODEL(NSUBMOD)
1989C-----------------------------------------------
1990C L o c a l V a r i a b l e s
1991C-----------------------------------------------
1992 INTEGER I,JREC,IDB,BOXTYPE,ISU,ICOUNT,ITER,FLAGG,
1993 . boxseg,iadisu,elstag(numels)
1994 CHARACTER BOX*3
1995 LOGICAL BOOL,IS_AVAILABLE,IS_ENCRYPTED
1996C-----------------------------------------------
1997 DO I=1,nbbox
1998 ibox(i)%NBLEVELS = 0
1999 ibox(i)%LEVEL = 1
2000 ibox(i)%ACTIBOX = 0
2001 IF(ibox(i)%NBOXBOX > 0)THEN
2002 ibox(i)%NBLEVELS = -1
2003 ibox(i)%LEVEL = 0
2004 END IF
2005C
2006 ibox(i)%SURFIAD = 0 ! used for temporary storage
2007 END DO
2008C-------
2009 CALL hm_get_int_array_index('ids',idb,1,is_available,lsubmodel)
2010 IF(key == 'BOX')THEN
2011 boxtype = 1
2012 ELSE IF(key == 'BOX2')THEN
2013 boxtype = 2
2014 END IF
2015C-------
2016C get box from box ID'S in SURF:
2017C-------
2018 isu = 0
2019 DO i=1,nbbox
2020 IF(idb == ibox(i)%ID) isu=i
2021 END DO
2022C---
2023 IF(isu <= 0)THEN
2024 IF(flag == 0)THEN
2025 CALL ancmsg(msgid=800,
2026 . msgtype=msgerror,
2027 . anmode=aninfo,
2028 . i1=id,
2029 . c1=titr,
2030 . i2=idb)
2031 END IF
2032 END IF
2033C---
2034C tag surfaces from solids within a simple box:
2035C---
2036 bool = .false.
2037 IF(isu>0)THEN
2038 IF(ibox(isu)%NBLEVELS == 0 .AND. ibox(isu)%LEVEL == 1)THEN
2039 IF(ibox(isu)%NBOXBOX == 0)THEN
2040C---
2041C tag faces of solids within box
2042C---
2043 CALL elstagbox(ixs ,elstag ,x ,skew ,boxtype,isu ,ibox )
2044C---
2045C fill tmp "IBUFBOX" for taged faces
2046C---
2047 CALL facebox(ixs ,x ,knod2els ,nod2els,iext ,
2048 . flag ,ixs10 ,ixs16 ,ixs20 ,skew ,
2049 . ibox ,elstag ,ibufbox ,iadb ,isu ,
2050 . id ,titr ,knod2elc ,nod2elc,ixc ,
2051 . tagshellboxc ,knod2eltg ,nod2eltg ,ixtg ,tagshellboxg,
2052 . 0 )
2053 IF (iadb>sbufbox .OR. iadb<0) CALL ancmsg(msgid=1007, msgtype=msgerror,anmode=anstop)
2054 bool = .true.
2055 END IF
2056 END IF
2057 ENDIF
2058C---
2059C READ LEVELS OF BOXES ==> "SUBLEVEL DONE"
2060C---
2061C---
2062C fill tmp "IBUFBOX" for taged faces
2063C---
2064 IF(.NOT. bool)THEN
2065 icount = 1
2066 iter = 0
2067 DO WHILE (icount == 1)
2068 iter = iter + 1
2069 flagg = 0
2070C--- count next level
2071 CALL elstagboxbox(
2072 . ibox ,skew ,flagg ,icount ,iter ,
2073 . boxtype ,ibufbox ,x ,iadb ,ixs ,
2074 . knod2els ,nod2els ,iext ,flag ,ixs10 ,
2075 . ixs16 ,ixs20 ,elstag ,id ,titr ,
2076 . knod2elc ,nod2elc ,ixc ,tagshellboxc,knod2eltg,
2077 . nod2eltg ,ixtg ,tagshellboxg,0 )
2078 IF (iadb>sbufbox .OR. iadb<0)
2079 . CALL ancmsg(msgid=1007, msgtype=msgerror,anmode=anstop)
2080C--- fill next level
2081 flagg = 1
2082 CALL elstagboxbox(
2083 . ibox ,skew ,flagg ,icount ,iter ,
2084 . boxtype ,ibufbox ,x ,iadb ,ixs ,
2085 . knod2els ,nod2els ,iext ,flag ,ixs10 ,
2086 . ixs16 ,ixs20 ,elstag ,id ,titr ,
2087 . knod2elc ,nod2elc ,ixc ,tagshellboxc,knod2eltg,
2088 . nod2eltg ,ixtg ,tagshellboxg,0 )
2089 ENDDO
2090 ENDIF
2091
2092C--------------------------
2093C
2094C fill final - IBUFSSG - for taged faces
2095C
2096 IF(isu > 0)THEN
2097 boxseg = ibox(isu)%NENTITY ! nb of surfaces in main box (/box/box)
2098 iadisu = ibox(isu)%SURFIAD ! addresses of surfaces in main box
2099 IF(flag == 0)THEN
2100 nseg=nseg+boxseg
2101 ELSE IF(flag == 1)THEN
2102 nseg=nseg+boxseg
2103 DO i=1,boxseg
2104 nn = nn + 1
2105 CALL boxbufill(iadisu,ibufbox,igrsurf%NODES,nn,nseg0,
2106 . igrsurf%ELTYP,igrsurf%ELEM)
2107 END DO
2108 END IF
2109 END IF
2110C--------------------------
2111 RETURN
2112 999 CALL freerr(1)
2113 RETURN
2114 END
2115!||====================================================================
2116!|| facebox ../starter/source/model/box/bigbox.F
2117!||--- called by ------------------------------------------------------
2118!|| elstagboxbox ../starter/source/model/box/boxbox.F
2119!|| sboxboxsurf ../starter/source/model/box/bigbox.F
2120!||--- calls -----------------------------------------------------
2121!|| ancmsg ../starter/source/output/message/message.F
2122!|| ssurf10tmp ../starter/source/model/box/bigbox.F
2123!||--- uses -----------------------------------------------------
2124!|| message_mod ../starter/share/message_module/message_mod.F
2125!||====================================================================
2126 SUBROUTINE facebox(IXS ,X ,KNOD2ELS ,NOD2ELS,IEXT ,
2127 . FLAG ,IXS10 ,IXS16 ,IXS20 ,SKEW ,
2128 . IBOX ,ELSTAG ,IBUFBOX ,IADB ,ISU ,
2129 . ID ,TITR ,KNOD2ELC ,NOD2ELC,IXC ,
2130 . TAGSHELLBOXC,KNOD2ELTG,NOD2ELTG ,IXTG ,TAGSHELLBOXG,
2131 . IEXT_SET )
2132C-----------------------------------------------
2133C M o d u l e s
2134C-----------------------------------------------
2135 USE message_mod
2136 USE optiondef_mod
2137 USE names_and_titles_mod , ONLY : nchartitle
2138 use element_mod , only : nixs,nixc,nixtg
2139C-----------------------------------------------
2140C I m p l i c i t T y p e s
2141C-----------------------------------------------
2142#include "implicit_f.inc"
2143C-----------------------------------------------
2144C C o m m o n B l o c k s
2145C-----------------------------------------------
2146#include "com04_c.inc"
2147#include "param_c.inc"
2148C-----------------------------------------------
2149C D u m m y A r g u m e n t s
2150C-----------------------------------------------
2151 INTEGER ID,IEXT_SET
2152 INTEGER IXS(NIXS,*),KNOD2ELS(*),
2153 . NOD2ELS(*),IEXT,FLAG,IXS10(6,*),IXS16(8,*),
2154 . IXS20(12,*),IBUFBOX(*),IADB,ISU,ELSTAG(*),
2155 . KNOD2ELC(*),NOD2ELC(*),IXC(NIXC,*),TAGSHELLBOXC(*),KNOD2ELTG(*),
2156 . NOD2ELTG(*),IXTG(NIXTG,*),TAGSHELLBOXG(*)
2157 MY_REAL
2158 . X(3,*),SKEW(LSKEW,*)
2159 CHARACTER(LEN=NCHARTITLE)::TITR
2160C-----------------------------------------------
2161 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
2162C-----------------------------------------------
2163C L o c a l V a r i a b l e s
2164C-----------------------------------------------
2165 INTEGER I,N,J,K,JS,KS,II,JJ,K1,K2,LL,FACE(4),FC10(3),NN,KK,I1,
2166 . NI(4),NS(4),MI(4),MS(4),NMIN,MMIN,NF,MF,IPERM,N1,N2,
2167 . BOXSEG,IADB0,NNS,ISHEL
2168 INTEGER NODTAG(NUMNOD),FASTAG(NUMELS)
2169 INTEGER FACES(4,6),PWR(7),FACES10(3,6)
2170 DATA faces/4,3,2,1,
2171 . 5,6,7,8,
2172 . 1,2,6,5,
2173 . 3,4,8,7,
2174 . 2,3,7,6,
2175 . 1,5,8,4/
2176 DATA faces10/0,0,0,
2177 . 0,0,0,
2178 . 3,6,4,
2179 . 5,6,2,
2180 . 1,2,3,
2181 . 4,5,1/
2182 DATA pwr/1,2,4,8,16,32,64/
2183 CHARACTER BOX*3
2184C-----------------------------------------------
2185 BOXSEG = 0
2186 iadb0 = iadb
2187C---
2188C fill tmp "IBUFBOX" for taged faces
2189C---
2190C-------------------------
2191 IF(iext==0)THEN
2192 DO js=1,numels
2193 IF(elstag(js)/=0)THEN
2194 CALL ancmsg(msgid=802,
2195 . msgtype=msgerror,
2196 . anmode=aninfo,
2197 . i1=id,
2198 . c1=titr)
2199 END IF
2200 ENDDO
2201 ENDIF
2202C-------------------------
2203C
2204 fastag=0
2205C
2206 IF(iext==1)THEN
2207C--------------------------
2208C External surface only
2209C--------------------------
2210 DO js=1,numels8+numels10
2211 DO jj=1,6
2212 IF(mod(elstag(js),pwr(jj+1))/pwr(jj)==0)cycle
2213 DO ii=1,4
2214 ns(ii)=ixs(faces(ii,jj)+1,js)
2215 END DO
2216C
2217C keep only 1 occurrence of each node (triangles, degenerated cases...)
2218C
2219 DO k1=1,3
2220 DO k2=k1+1,4
2221 IF(ns(k2)==ns(k1))ns(k2)=0
2222 END DO
2223 END DO
2224 nf=0
2225 DO k1=1,4
2226 n1=ns(k1)
2227 IF(n1/=0)THEN
2228 nf=nf+1
2229 ns(nf)=n1
2230 END IF
2231 END DO
2232 IF(nf < 3)cycle
2233C
2234C permute
2235C
2236 nmin=ns(1)
2237 DO ii=2,nf
2238 nmin=min(nmin,ns(ii))
2239 END DO
2240 DO iperm=1,nf
2241 IF(nmin==ns(iperm).AND.
2242 . ns(mod(iperm,nf)+1)/=ns(iperm))THEN
2243 DO ii=1,nf
2244 ni(ii)=ns(mod(ii+iperm-2,nf)+1)
2245 END DO
2246 EXIT
2247 END IF
2248 END DO
2249C
2250C looks for an elt sharing the face.
2251C
2252 DO k=knod2els(ni(1))+1,knod2els(ni(1)+1)
2253 ks=nod2els(k)
2254 IF(ks==js .OR. ks > numels8+numels10 .OR.
2255 . elstag(ks)==0) cycle
2256 DO ii=1,nf
2257 nodtag(ni(ii))=0
2258 END DO
2259 DO ii=1,8
2260 nodtag(ixs(ii+1,ks))=1
2261 END DO
2262 nn=0
2263 DO ii=1,nf
2264 nn=nn+nodtag(ni(ii))
2265 END DO
2266 IF(nn==nf)THEN
2267 DO kk=1,6
2268 DO ii=1,4
2269 ms(ii)=ixs(faces(ii,kk)+1,ks)
2270 END DO
2271C
2272C keep only 1 occurrence of each node (triangles, degenerated cases...)
2273C
2274 DO k1=1,3
2275 DO k2=k1+1,4
2276 IF(ms(k2)==ms(k1))ms(k2)=0
2277 END DO
2278 END DO
2279 mf=0
2280 DO k1=1,4
2281 n1=ms(k1)
2282 IF(n1/=0)THEN
2283 mf=mf+1
2284 ms(mf)=n1
2285 END IF
2286 END DO
2287 IF(mf /= nf)cycle
2288C
2289C permute
2290C
2291 mmin=ms(1)
2292 DO ii=2,mf
2293 mmin=min(mmin,ms(ii))
2294 END DO
2295 DO iperm=1,mf
2296 IF(mmin==ms(iperm).AND.
2297 . ms(mod(iperm,mf)+1)/=ms(iperm))THEN
2298 DO ii=1,mf
2299 mi(ii)=ms(mod(ii+iperm-2,mf)+1)
2300 END DO
2301 EXIT
2302 END IF
2303 END DO
2304 IF(mi(1)==ni(1).AND.mi(nf)==ni(2))THEN
2305C Factag (JS) Less Face JJ
2306 fastag(js)=fastag(js)+pwr(jj)
2307 GO TO 100
2308 END IF
2309 END DO
2310 END IF
2311 END DO
2312 100 CONTINUE
2313 END DO
2314 END DO
2315 END IF
2316C--------------------------
2317C
2318C--------------------------
2319 DO js=1,numels8
2320 IF(elstag(js)>0)THEN
2321 DO jj=1,6
2322 IF(mod(elstag(js),pwr(jj+1))/pwr(jj)/=0 .AND.
2323 . mod(fastag(js),pwr(jj+1))/pwr(jj)==0)THEN
2324C
2325C still needs to filter degenerated faces
2326C
2327 DO k1=1,4
2328 i1 =faces(k1,jj)+1
2329 face(k1)=ixs(i1,js)
2330 END DO
2331 DO k1=1,4
2332 n1=face(k1)
2333 DO k2=1,4
2334 IF(k2/=k1)THEN
2335 n2=face(k2)
2336 IF(n2==n1)face(k2)=0
2337 END IF
2338 END DO
2339 END DO
2340 nn=0
2341 DO k1=1,4
2342 n1=face(k1)
2343 IF(n1/=0)THEN
2344 nn=nn+1
2345 face(nn)=n1
2346 END IF
2347 END DO
2348
2349
2350C--- find shells SURF/BOX/BOX/EXT
2351
2352C
2353C count faces within the box:
2354C
2355 IF(flag == 0 .and. nn == 3) THEN
2356 ks = 0
2357 ishel = 0
2358 DO k=knod2eltg(face(1))+1,knod2eltg(face(1)+1)
2359 ks=nod2eltg(k)
2360 ishel = 0
2361 DO i=1,3
2362 DO j=1,3
2363 IF(face(i) == ixtg(j+1,ks)) ishel = ishel + 1
2364 ENDDO
2365 ENDDO
2366 IF (ishel == 3)EXIT
2367 ks = 0
2368 ENDDO
2369 IF(ks == 0)THEN
2370 boxseg=boxseg+1
2371 iadb = iadb + 6
2372 IF (iext_set > 0) iadb = iadb + 1
2373 ELSEIF(tagshellboxg(ks)==0) THEN
2374 boxseg=boxseg+1
2375 iadb = iadb + 6
2376 IF (iext_set > 0) iadb = iadb + 1
2377 ENDIF
2378 ELSEIF(flag == 0 .and. nn == 4) THEN
2379 ks = 0
2380 ishel = 0
2381 DO k=knod2elc(face(1))+1,knod2elc(face(1)+1)
2382 ks=nod2elc(k)
2383 ishel = 0
2384 DO i=1,4
2385 DO j=1,4
2386 IF(face(i) == ixc(j+1,ks)) ishel = ishel + 1
2387 ENDDO
2388 ENDDO
2389 IF (ishel == 4)EXIT
2390 ks = 0
2391 ENDDO
2392 IF(ks == 0)THEN
2393 boxseg=boxseg+1
2394 iadb = iadb + 6
2395 IF (iext_set > 0) iadb = iadb + 1
2396 ELSEIF(tagshellboxc(ks)==0) THEN
2397 boxseg=boxseg+1
2398 iadb = iadb + 6
2399 IF (iext_set > 0) iadb = iadb + 1
2400 ENDIF
2401 ELSEIF(nn==3)THEN
2402 ks = 0
2403 ishel = 0
2404 DO k=knod2eltg(face(1))+1,knod2eltg(face(1)+1)
2405 ks=nod2eltg(k)
2406 ishel = 0
2407 DO i=1,3
2408 DO j=1,3
2409 IF(face(i) == ixtg(j+1,ks)) ishel = ishel + 1
2410 ENDDO
2411 ENDDO
2412 IF (ishel == 3)EXIT
2413 ks = 0
2414 ENDDO
2415 IF(ks == 0)THEN
2416 boxseg=boxseg+1
2417 CALL ssurf10tmp(face(1),face(2),face(3),face(3),
2418 . iadb,js,ibufbox,iext_set)
2419 ELSEIF(tagshellboxg(ks)==0) THEN
2420 boxseg=boxseg+1
2421 CALL ssurf10tmp(face(1),face(2),face(3),face(3),
2422 . iadb,js,ibufbox,iext_set)
2423 ENDIF
2424 ELSEIF(nn==4)THEN
2425 ks = 0
2426 ishel = 0
2427 DO k=knod2elc(face(1))+1,knod2elc(face(1)+1)
2428 ks=nod2elc(k)
2429 ishel = 0
2430 DO i=1,4
2431 DO j=1,4
2432 IF(face(i) == ixc(j+1,ks)) ishel = ishel + 1
2433 ENDDO
2434 ENDDO
2435 IF (ishel == 4)EXIT
2436 ks = 0
2437 ENDDO
2438 IF(ks == 0)THEN
2439 boxseg=boxseg+1
2440 CALL ssurf10tmp(face(1),face(2),face(3),face(4),
2441 . iadb,js,ibufbox,iext_set)
2442 ELSEIF(tagshellboxc(ks)==0) THEN
2443 boxseg=boxseg+1
2444 CALL ssurf10tmp(face(1),face(2),face(3),face(4),
2445 . iadb,js,ibufbox,iext_set)
2446
2447 ENDIF
2448 END IF
2449C---
2450 END IF
2451 END DO
2452 ENDIF
2453 ENDDO
2454C--------------------------
2455C
2456C--------------------------
2457 DO j=1,numels10
2458 js = j+numels8
2459 IF(elstag(js)>0)THEN
2460 DO jj=3,6
2461 IF(mod(elstag(js),pwr(jj+1))/pwr(jj)/=0 .AND.
2462 . mod(fastag(js),pwr(jj+1))/pwr(jj)==0)THEN
2463C
2464C still needs to filter degenerated faces
2465C
2466 DO k1=1,4
2467 face(k1)=ixs(faces(k1,jj)+1,js)
2468 END DO
2469 DO k1=1,3
2470 DO k2=k1+1,4
2471 IF(face(k2) == face(k1)) face(k2)=0
2472 END DO
2473 END DO
2474 nn=0
2475 DO k1=1,4
2476 IF(face(k1) /= 0)THEN
2477 nn=nn+1
2478 face(nn)=face(k1)
2479 END IF
2480 END DO
2481C
2482 IF(nn == 3)THEN
2483 nns=1
2484 fc10(1)=ixs10(faces10(1,jj),j)
2485 fc10(2)=ixs10(faces10(2,jj),j)
2486 fc10(3)=ixs10(faces10(3,jj),j)
2487 IF(fc10(1) /= 0)nns=nns+1
2488 IF(fc10(2) /= 0)nns=nns+1
2489 IF(fc10(3) /= 0)nns=nns+1
2490C
2491C count faces within the box:
2492C
2493 IF(nns == 3)nns=2
2494 boxseg=boxseg+nns
2495 IF(nns == 4)THEN
2496c 4 triangles
2497C
2498 IF (flag == 0)THEN
2499 iadb = iadb + 24
2500 IF (iext_set > 0) iadb = iadb + 4
2501 ELSEIF (flag == 1) THEN
2502 CALL ssurf10tmp(face(1),fc10(1),fc10(3),fc10(3),
2503 . iadb,js,ibufbox,iext_set)
2504 CALL ssurf10tmp(face(2),fc10(2),fc10(1),fc10(1),
2505 . iadb,js,ibufbox,iext_set)
2506 CALL ssurf10tmp(face(3),fc10(3),fc10(2),fc10(2),
2507 . iadb,js,ibufbox,iext_set)
2508 CALL ssurf10tmp(fc10(1),fc10(2),fc10(3),fc10(3),
2509 . iadb,js,ibufbox,iext_set)
2510 ENDIF ! IF (FLAG == 0)
2511 ELSEIF(nns == 3)THEN
2512c 1 quadrangle, 1 triangle
2513C
2514 IF (flag == 0)THEN
2515 iadb = iadb + 12
2516 IF (iext_set > 0) iadb = iadb + 2
2517 ELSEIF (flag == 1) THEN
2518 IF(fc10(1) == 0)THEN
2519 CALL ssurf10tmp(face(1),face(2),fc10(2),fc10(3),
2520 . iadb,js,ibufbox,iext_set)
2521 CALL ssurf10tmp(face(3),fc10(3),fc10(2),fc10(2),
2522 . iadb,js,ibufbox,iext_set)
2523 ELSEIF(fc10(2) == 0)THEN
2524 CALL ssurf10tmp(face(2),face(3),fc10(3),fc10(1),
2525 . iadb,js,ibufbox,iext_set)
2526 CALL ssurf10tmp(face(1),fc10(1),fc10(3),fc10(3),
2527 . iadb,js,ibufbox,iext_set)
2528 ELSEIF(fc10(3) == 0)THEN
2529 CALL ssurf10tmp(face(3),face(1),fc10(1),fc10(2),
2530 . iadb,js,ibufbox,iext_set)
2531 CALL ssurf10tmp(face(2),fc10(2),fc10(1),fc10(1),
2532 . iadb,js,ibufbox,iext_set)
2533 ENDIF
2534 ENDIF ! IF (FLAG == 0)
2535 ELSEIF(nns == 2)THEN
2536c 2 triangles
2537C
2538 IF (flag == 0)THEN
2539 iadb = iadb + 12
2540 IF (iext_set > 0) iadb = iadb + 2
2541 ELSEIF (flag == 1) THEN
2542 IF(fc10(1) /= 0)THEN
2543 CALL ssurf10tmp(face(3),face(1),fc10(1),fc10(1),
2544 . iadb,js,ibufbox,iext_set)
2545 CALL ssurf10tmp(face(2),face(3),fc10(1),fc10(1),
2546 . iadb,js,ibufbox,iext_set)
2547 ELSEIF(fc10(2) /= 0)THEN
2548 CALL ssurf10tmp(face(1),face(2),fc10(2),fc10(2),
2549 . iadb,js,ibufbox,iext_set)
2550 CALL ssurf10tmp(face(3),face(1),fc10(2),fc10(2),
2551 . iadb,js,ibufbox,iext_set)
2552 ELSEIF(fc10(3) /= 0)THEN
2553 CALL ssurf10tmp(face(2),face(3),fc10(3),fc10(3),
2554 . iadb,js,ibufbox,iext_set)
2555 CALL ssurf10tmp(face(1),face(2),fc10(3),fc10(3),
2556 . iadb,js,ibufbox,iext_set)
2557 ENDIF
2558 ENDIF ! IF (FLAG == 0)
2559 ELSEIF(nns == 1)THEN
2560c 1 triangle
2561C
2562 IF (flag == 0)THEN
2563 iadb = iadb + 6
2564 IF (iext_set > 0) iadb = iadb + 1
2565 ELSEIF (flag == 1) THEN
2566 CALL ssurf10tmp(face(1),face(2),face(3),face(3),
2567 . iadb,js,ibufbox,iext_set)
2568 ENDIF ! IF (FLAG == 0)
2569 END IF
2570 END IF
2571 END IF
2572 END DO
2573 ENDIF
2574 ENDDO
2575C
2576cc IF (FLAG == 0) IADB = IADB + BOXSEG
2577C--------------------------
2578 IF(isu>0)THEN
2579 IF(ibox(isu)%ID > 0)THEN
2580 ibox(isu)%NENTITY=boxseg
2581 ibox(isu)%SURFIAD=iadb0
2582 END IF
2583 ENDIF
2584C--------------------------
2585C
2586 RETURN
2587 999 CALL freerr(1)
2588 RETURN
2589 END
2590!||====================================================================
2591!|| boxbufill ../starter/source/model/box/bigbox.F
2592!||--- called by ------------------------------------------------------
2593!|| sboxboxsurf ../starter/source/model/box/bigbox.F
2594!||====================================================================
2595 SUBROUTINE boxbufill(IADISU,IBUFBOX,SURF_NODES,NN,NSEG0,
2596 . SURF_ELTYP,SURF_ELEM)
2597C-----------------------------------------------
2598C I m p l i c i t T y p e s
2599C-----------------------------------------------
2600#include "implicit_f.inc"
2601C-----------------------------------------------
2602 INTEGER J,IADISU,IBUFBOX(*),NN,NSEG0,SURF_NODES(NSEG0,4),
2603 . SURF_ELTYP(NSEG0),SURF_ELEM(NSEG0)
2604C---------------------------------
2605 j=ibufbox(iadisu) ! N1
2606 iadisu=iadisu+1
2607 surf_nodes(nn,1) = j
2608C
2609 j=ibufbox(iadisu) ! N2
2610 iadisu=iadisu+1
2611 surf_nodes(nn,2) = j
2612C
2613 j=ibufbox(iadisu) ! N3
2614 iadisu=iadisu+1
2615 surf_nodes(nn,3) = j
2616C
2617 j=ibufbox(iadisu) ! N4
2618 iadisu=iadisu+1
2619 surf_nodes(nn,4) = j
2620C
2621 j=ibufbox(iadisu) ! IELTYP
2622 iadisu=iadisu+1
2623 surf_eltyp(nn) = j
2624C
2625 j=ibufbox(iadisu) ! JS - element id
2626 iadisu=iadisu+1
2627 surf_elem(nn) = j
2628C
2629 RETURN
2630 END
2631!||====================================================================
2632!|| ssurf10tmp ../starter/source/model/box/bigbox.F
2633!||--- called by ------------------------------------------------------
2634!|| facebox ../starter/source/model/box/bigbox.F
2635!||====================================================================
2636 SUBROUTINE ssurf10tmp(N1,N2,N3,N4,IAD,JS,IBUFBOX,IEXT_SET)
2637C-----------------------------------------------
2638C I m p l i c i t T y p e s
2639C-----------------------------------------------
2640#include "implicit_f.inc"
2641C-----------------------------------------------
2642C D u m m y A r g u m e n t s
2643C-----------------------------------------------
2644 INTEGER N1,N2,N3,N4,IAD,JS,IBUFBOX(*),IEXT_SET
2645C-----------------------------------------------
2646 ibufbox(iad)=n1
2647 iad=iad+1
2648 ibufbox(iad)=n2
2649 iad=iad+1
2650 ibufbox(iad)=n3
2651 iad=iad+1
2652 ibufbox(iad)=n4
2653 iad=iad+1
2654 ibufbox(iad)=1
2655 iad=iad+1
2656 ibufbox(iad)=js
2657 iad=iad+1
2658!
2659 IF (iext_set > 0) THEN
2660 ibufbox(iad) = 2 ! IEXT = 2 (all - need for /LINE/SURF)
2661 iad=iad+1
2662 ENDIF
2663!---
2664 RETURN
2665 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:2132
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:1955
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:2637
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:2597
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:178
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:320
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:463
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
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:668
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1010
optiondef_mod
Definition optiondef_mod.F:90
submodel_mod
Definition submodel_mod.F:717
checkcyl
subroutine checkcyl(xp1, yp1, zp1, xp2, yp2, zp2, nodin, d, ok)
Definition rdbox.F:228
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:346
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:895
freerr
subroutine freerr(it)
Definition freform.F:501
starter
program starter
Definition starter.F:39
submodel_mod::submodel_data
Definition submodel_mod.F:728