OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25surfi.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "param_c.inc"
#include "scr03_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine i25surfi (iallo, ipari, igrnod, igrsurf, irect, frigap, nsv, msr, itab, x, nbinflg, mbinflg, msegtyp, iseadd, isedge, itag, intply, ixc, ixtg, knod2elc, knod2eltg, nod2elc, nod2eltg, knod2els, nod2els, ixs, ixs10, ixs16, ixs20, irtse, is2se, is2pt, is2id, parameters, nin25, flag_elem_inter25)
subroutine sh2surf25 (nrtm0, irect, imbin, mbinflg, msegtyp, nrtm)

Function/Subroutine Documentation

◆ i25surfi()

subroutine i25surfi ( integer iallo,
integer, dimension(npari) ipari,
type (group_), dimension(ngrnod) igrnod,
type (surf_), dimension(nsurf) igrsurf,
integer, dimension(4,*) irect,
frigap,
integer, dimension(*) nsv,
integer, dimension(*) msr,
integer, dimension(*) itab,
x,
integer, dimension(*) nbinflg,
integer, dimension(*) mbinflg,
integer, dimension(*) msegtyp,
integer, dimension(*) iseadd,
integer, dimension(*) isedge,
integer, dimension(*) itag,
integer intply,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
integer, dimension(*) knod2elc,
integer, dimension(*) knod2eltg,
integer, dimension(*) nod2elc,
integer, dimension(*) nod2eltg,
integer, dimension(*) knod2els,
integer, dimension(*) nod2els,
integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(8,*) ixs16,
integer, dimension(12,*) ixs20,
integer, dimension(5,*) irtse,
integer, dimension(*) is2se,
integer, dimension(*) is2pt,
integer, dimension(*) is2id,
type (parameters_), intent(inout) parameters,
integer, intent(in) nin25,
integer, dimension(ninter25,numels), intent(inout) flag_elem_inter25 )

Definition at line 37 of file i25surfi.F.

47C============================================================================
48C-----------------------------------------------
49C M o d u l e s
50C-----------------------------------------------
51 USE message_mod
52 USE groupdef_mod
53 USE parameters_mod
54 USE format_mod , ONLY : fmw_10i, fmw_4i
55 use element_mod , only :nixs,nixc,nixtg
56C-----------------------------------------------
57C I m p l i c i t T y p e s
58C-----------------------------------------------
59#include "implicit_f.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "com04_c.inc"
64#include "units_c.inc"
65#include "param_c.inc"
66#include "scr03_c.inc"
67C-----------------------------------------------
68C D u m m y A r g u m e n t s
69C-----------------------------------------------
70 INTEGER IALLO,NBINFLG(*)
71 INTEGER IPARI(NPARI),
72 . IRECT(4,*), NSV(*),MSEGTYP(*),
73 . MSR(*),ITAB(*),MBINFLG(*),
74 . ISEADD(*) ,ISEDGE(*),ITAG(*),INTPLY,
75 . IXC(NIXC,*),IXTG(NIXTG,*),KNOD2ELC(*),KNOD2ELTG(*),
76 . NOD2ELC(*),NOD2ELTG(*),KNOD2ELS(*),NOD2ELS(*),
77 . IRTSE(5,*) ,IS2SE(*),IS2PT(*) ,IS2ID(*)
78 INTEGER IXS(NIXS,*),IXS10(6,*), IXS16(8,*), IXS20(12,*)
79 INTEGER MODE, WORK(70000), NRTMP, I1, I2
80 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
81 INTEGER, DIMENSION(:,:),ALLOCATABLE :: IRECTMP
82 INTEGER, DIMENSION(:,:),ALLOCATABLE :: IRECTMP_SAV
83 INTEGER, INTENT(IN) :: NIN25
84 INTEGER, INTENT(INOUT) :: FLAG_ELEM_INTER25(NINTER25,NUMELS)
85 my_real
86 . x(3,*),frigap(*)
87C-----------------------------------------------
88 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
89 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
90 TYPE (PARAMETERS_) ,INTENT(INOUT) :: PARAMETERS
91C-----------------------------------------------
92C L o c a l V a r i a b l e s
93C-----------------------------------------------
94 INTEGER I,J,K,L,ISU1,ISU2,NOD1,NRTM,NRTS,NSN,NMN,
95 . ILEV,NLN
96 INTEGER, DIMENSION(:), ALLOCATABLE :: TAG,TAGS
97 INTEGER STAT,IJ,IMIN
98 INTEGER NSU1,NLS1,NLS2,NRTM_SH,NRTM0,
99 . IMBIN,IDEB,ISN
100 LOGICAL :: NEED_SOLID_EROSION
101 INTEGER :: IDEL,SOLID_SEGMENT,ELEM
102C-----------------------------------------------
103C E x t e r n a l F u n c t i o n s
104C-----------------------------------------------
105 INTEGER BITSET
106 EXTERNAL bitset
107C
108 CHARACTER MESS*40
109 DATA mess/'INTERFACE INPUT '/
110C-----------------------------------------------
111 nsn = 0
112 nmn = 0
113 nrtm = 0
114 nrts = 0
115 nod1 = ipari(26)
116 nln = 0
117 ilev = ipari(20)
118 isu1 = ipari(45)
119 isu2 = ipari(46)
120 nsu1 = 0
121 nls1 = 0
122 nls2 = 0
123 IF(iallo == 2 .AND. ilev == 2 ) THEN
124 imbin=1
125 ELSE
126 imbin=0
127 END IF
128C=======================================================================
129c SURFACES
130C=======================================================================
131c-----------------------------------------------------------------
132c surface S1
133c-----------------------------------------------------------------
134c-----------------------------------------------------------------
135c surface S2
136c-----------------------------------------------------------------
137 SELECT CASE (ilev)
138C-----attention: ISU2=ISU1 /=0
139 CASE(1)
140 nrtm = igrsurf(isu1)%NSEG
141 CASE(2)
142 nrtm = igrsurf(isu1)%NSEG
143 nrts = igrsurf(isu2)%NSEG
144 nrtm = nrtm + nrts
145 CASE(3)
146 nrtm = igrsurf(isu2)%NSEG
147 END SELECT
148c-----------------------------------------------------------------
149 ALLOCATE(index(2*nrtm),irectmp(6,nrtm),stat=stat)
150 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
151 . msgtype=msgerror,
152 . c1='IRECTSAV')
153 irectmp(1:6,1:nrtm)=0
154C
155c---------------------------------------
156c Copy of surfaces (Iallo == 2)
157c---------------------------------------
158 l = 0
159 IF(isu1 /= 0)THEN
160 DO j=1,igrsurf(isu1)%NSEG
161 l = l+1
162 DO k=1,4
163 irectmp(k,l) = igrsurf(isu1)%NODES(j,k)
164 ENDDO
165 irectmp(5,l) = igrsurf(isu1)%ELTYP(j) ! MSEGTYP
166 CALL in24coq_sol3(irectmp(1,l) ,ixc ,ixtg ,irectmp(5,l) ,x ,
167 . knod2elc ,knod2eltg ,nod2elc ,nod2eltg,
168 . knod2els,nod2els,ixs ,ixs10 ,ixs16 ,ixs20 )
169 IF(imbin /= 0)irectmp(6,l) = bitset(irectmp(6,l),0) ! MBINFLG
170 IF(ilev==1.OR.ilev==2) THEN
171 elem = igrsurf(isu1)%ELEM(j)
172 IF(elem/=0.AND.igrsurf(isu1)%ELTYP(j)==1) flag_elem_inter25(nin25,elem) = 1 ! tag solid elements included in surface
173 ENDIF
174 ENDDO
175 ENDIF
176 nsu1 = l
177 IF(isu2 /= 0 .AND.ilev /=1)THEN
178 DO j=1,igrsurf(isu2)%NSEG
179 l = l+1
180 DO k=1,4
181 irectmp(k,l) = igrsurf(isu2)%NODES(j,k)
182
183!! IAD = IAD+1
184 ENDDO
185 irectmp(5,l) = igrsurf(isu2)%ELTYP(j) ! MSEGTYP
186 CALL in24coq_sol3(irectmp(1,l) ,ixc ,ixtg ,irectmp(5,l) ,x ,
187 . knod2elc ,knod2eltg ,nod2elc ,nod2eltg,
188 . knod2els,nod2els,ixs ,ixs10 ,ixs16 ,ixs20 )
189 IF(imbin /= 0) irectmp(6,l) = bitset(irectmp(6,l),1) ! MBINFLG
190 elem = igrsurf(isu2)%ELEM(j)
191 IF(elem/=0.AND.igrsurf(isu2)%ELTYP(j)==1) flag_elem_inter25(nin25,elem) = 1 ! tag solid elements included in surface
192 ENDDO
193 ENDIF
194C=======================================================================
195c Filtre
196 nrtmp=nrtm
197C
198 ALLOCATE(irectmp_sav(6,nrtm),stat=stat)
199
200
201 irectmp_sav(1:6,1:nrtm) = irectmp(1:6,1:nrtm)
202 DO i=1,nrtm
203 IF(irectmp(5,i)==0.OR.irectmp(5,i)==1) THEN
204 IF(irectmp(4,i)==irectmp(3,i)) irectmp(4,i) = 0
205 DO j=1,3
206 imin = irectmp(j,i)
207 ij = j
208 DO k=j+1,4
209 IF(irectmp(k,i)<imin.AND.irectmp(k,i) /= 0) THEN
210 imin = irectmp(k,i)
211 ij = k
212 ENDIF
213 ENDDO
214 IF(ij /=j ) THEN
215 irectmp(ij,i) = irectmp(j,i)
216 irectmp(j,i) = imin
217 ENDIF
218 ENDDO
219 ENDIF
220 ENDDO
221C
222 mode=0
223 CALL my_orders( mode, work, irectmp, index, nrtm , 6)
224
225 IF(iallo==1)THEN
226
227 nrtm_sh=0
228
229 ideb=1
230 i1=index(ideb)
231 DO WHILE(irectmp(1,i1)==0)
232 ideb=ideb+1
233 i1=index(ideb)
234 END DO
235
236 nrtm =1
237 IF(irectmp(5,i1)/=0 .AND. irectmp(5,i1)/=1) nrtm_sh=nrtm_sh+1
238
239 DO j=ideb,nrtmp-1
240 i1=index(j)
241 i2=index(j+1)
242
243 IF(irectmp(1,i2)/=irectmp(1,i1).OR.
244 . irectmp(2,i2)/=irectmp(2,i1).OR.
245 . irectmp(3,i2)/=irectmp(3,i1).OR.
246 . irectmp(4,i2)/=irectmp(4,i1).OR.
247 . irectmp(5,i2)/=irectmp(5,i1))THEN ! Teste msegtyp pq has a risk if renumeration between the 2 phases
248 ! A regler
249 nrtm=nrtm+1
250 IF(irectmp(5,i2)/=0 .AND. irectmp(5,i2)/=1) nrtm_sh=nrtm_sh+1
251
252 END IF
253 END DO
254 ELSE ! IF(IALLO==1)THEN
255
256 ideb=1
257 i1=index(ideb)
258 DO WHILE(irectmp(1,i1)==0)
259 ideb=ideb+1
260 i1=index(ideb)
261 END DO
262
263 nrtm=1 ! recompute NRTM same as with IALLO=1 <=> Ipari(4)
264 irect(1,nrtm)=irectmp_sav(1,i1)
265 irect(2,nrtm)=irectmp_sav(2,i1)
266 irect(3,nrtm)=irectmp_sav(3,i1)
267 irect(4,nrtm)=irectmp_sav(4,i1)
268 msegtyp(nrtm)=irectmp_sav(5,i1)
269 IF(imbin/=0) mbinflg(nrtm)=irectmp_sav(6,i1)
270
271 DO j=ideb,nrtmp-1
272 i1=index(j)
273 i2=index(j+1)
274 IF(irectmp(1,i2)/=irectmp(1,i1).OR.
275 . irectmp(2,i2)/=irectmp(2,i1).OR.
276 . irectmp(3,i2)/=irectmp(3,i1).OR.
277 . irectmp(4,i2)/=irectmp(4,i1).OR.
278 . irectmp(5,i2)/=irectmp(5,i1))THEN ! Teste msegtyp pq has a risk if renumeration between the 2 phases
279 ! A regler
280 nrtm=nrtm+1
281 irect(1,nrtm)=irectmp_sav(1,i2)
282 irect(2,nrtm)=irectmp_sav(2,i2)
283 irect(3,nrtm)=irectmp_sav(3,i2)
284 irect(4,nrtm)=irectmp_sav(4,i2)
285 msegtyp(nrtm)=irectmp_sav(5,i2)
286 IF(imbin/=0) mbinflg(nrtm)=irectmp_sav(6,i2)
287
288 ELSEIF(irectmp(6,i1)/=irectmp(6,i2))THEN ! The segment belongs to the 2 surfaces
289 IF(imbin/=0) mbinflg(nrtm)=1+2
290 END IF
291 END DO
292 END IF
293
294
295 DEALLOCATE(index,irectmp)
296 IF(ALLOCATED(irectmp_sav)) DEALLOCATE(irectmp_sav)
297C=======================================================================
298c NODES C=======================================================================
299c-----------------------------------------------------------------
300c tag nodes surfaces S1 S2; 1,2 on S1,S2, 3 on both (ILEV=1)
301c-----------------------------------------------------------------
302 ALLOCATE(tag(numnod),tags(numnod))
303 DO i=1,numnod
304 tag(i)=0 ! initialisation
305 tags(i)=0 ! initialisation
306 ENDDO
307 IF(isu2 /= 0)THEN
308 DO j=1,igrsurf(isu2)%NSEG
309 DO k=1,4
310 tag(igrsurf(isu2)%NODES(j,k)) = 2
311 ENDDO
312 ENDDO
313 ENDIF
314 IF(isu1 /= 0)THEN
315 DO j=1,igrsurf(isu1)%NSEG
316 DO k=1,4
317 i=igrsurf(isu1)%NODES(j,k)
318 IF(tag(i) == 0)THEN
319 tag(i) = 1
320 ELSEIF(tag(i) == 2)THEN
321 tag(i) = 3
322 ENDIF
323 ENDDO
324 ENDDO
325 ENDIF
326C for inteply activation needed for Plyxfem + Type24
327 IF(iallo == 1) THEN
328 IF(isu2 /= 0)THEN
329 DO j=1,igrsurf(isu2)%NSEG
330 DO k=1,4
331
332
333
334!! IAD = IAD+1
335 ENDDO
336 ENDDO
337 ENDIF
338 IF(isu1 /= 0)THEN
339 DO j=1,igrsurf(isu1)%NSEG
340 DO k=1,4
341 i=igrsurf(isu1)%NODES(j,k)
342
343
344!! IAD = IAD+1
345 ENDDO
346 ENDDO
347 ENDIF
348 ENDIF
349c-----------------------------------------------------------------
350c Surface nodes S2: Build Tags, Set NSV, Msr If Iallo = 2
351c-----------------------------------------------------------------
352 IF(isu2 /= 0)THEN
353 DO j=1,igrsurf(isu2)%NSEG
354 DO k=1,4
355 i=igrsurf(isu2)%NODES(j,k)
356 IF(tag(i) == 2 )THEN
357 nmn = nmn + 1
358 IF(iallo == 2)msr(nmn) = i
359 ENDIF
360c taged nodes on S2 -> negative value
361 IF(tag(i) == 2 .OR. tag(i) == 3)THEN
362 tag(i) = - tag(i)
363 IF ( ilev == 2.AND.tags(i) == 0 ) THEN
364 nsn = nsn + 1
365 tags(i) = nsn
366 IF(iallo == 2) THEN
367 nsv(nsn) = i
368 IF(ilev == 2)nbinflg(nsn) = bitset(nbinflg(nsn),1)
369 END IF
370 END IF !( ILEV == 2 ) THEN
371 ENDIF
372 ENDDO
373 ENDDO
374 ENDIF
375c-----------------------------------------------------------------
376c Surface nodes S1: Build Tags, Set NSV, Msr If Iallo = 2
377c-----------------------------------------------------------------
378 IF(isu1 /= 0)THEN
379 DO j=1,igrsurf(isu1)%NSEG
380 DO k=1,4
381 i=igrsurf(isu1)%NODES(j,k)
382 IF(tags(i) == 0 .AND. ilev /= 3 ) THEN
383 nsn = nsn + 1
384 tags(i) = nsn
385 IF(iallo == 2) THEN
386 nsv(nsn) = i
387 IF(ilev == 2)nbinflg(nsn) = bitset(nbinflg(nsn),0)
388 END IF
389 ELSEIF(ilev==2)THEN
390 IF(iallo == 2) THEN
391 isn=tags(i)
392 nbinflg(isn) = bitset(nbinflg(isn),0)
393 END IF
394 ENDIF
395c taged nodes on S1 -> negative value, ->+3 for nodes on both
396 IF(tag(i) == 1 .or. tag(i) == -3)THEN
397 tag(i) = - tag(i)
398 nmn = nmn + 1
399 IF(iallo == 2)msr(nmn) = i
400 ENDIF
401 ENDDO
402 ENDDO
403 ENDIF
404c-----------------------------------------------------------------
405c nodes of the nod1 nod group: build tags, set nsv if iallo = 2
406c-----------------------------------------------------------------
407 IF(nod1 /= 0)THEN
408 DO j=1,igrnod(nod1)%NENTITY
409 i = igrnod(nod1)%ENTITY(j)
410 IF(tags(i) == 0)THEN
411 nsn = nsn+1
412 tags(i) = nsn
413 IF(iallo == 2) THEN
414 nsv(nsn) = i
415 IF(ilev == 2)nbinflg(nsn) = bitset(nbinflg(nsn),2)
416 END IF
417 ENDIF
418 ENDDO
419 ENDIF
420
421 IF(iallo == 2 .and. ipri >= 5) THEN
422 WRITE(iout,'(/,A,I10,/)')' NODES USED FOR SECONDARY SIDE, INTERFACE ID=',ipari(15)
423 WRITE(iout,fmt=fmw_10i)(itab(nsv(i)),i=1,nsn)
424 ENDIF
425C=======================================================================
426C=======================================================================
427c-----------------------------------------------------------------
428c number of nodes in the interface (secondary+main)
429c-----------------------------------------------------------------
430 IF(iallo == 2) THEN
431 nln = ipari(35)
432 ipari(51) = nls1
433 ipari(52) = nls2
434C------initialization of doubler M_seg for shells add ISU1>0
435 nrtm_sh= ipari(42)
436 nrtm0 = ipari(4) - nrtm_sh
437 CALL sh2surf25(nrtm0,irect,imbin,mbinflg,msegtyp,ipari(4))
438
439 IF(ipri>=5) THEN
440 WRITE(iout,'(/,A,I10,/)')' SEGMENTS USED FOR MAIN SURFACE, INTERFACE ID=',ipari(15)
441 DO i=1,nrtm
442 WRITE(iout,fmt=fmw_4i)(itab(irect(k,i)),k=1,4)
443 ENDDO
444 ENDIF
445C
446 ELSE
447C----------due the fact that NRTM is modified w/ shell seg
448 ipari(3) = 0
449 ipari(4) = nrtm
450 ipari(5) = nsn
451 ipari(6) = nmn
452 ipari(35) = nln
453 ipari(42) = nrtm_sh
454
455 idel = ipari(17) ! get the idel option (/=0 --> erosion is ON)
456 solid_segment = nrtm - nrtm_sh ! get the number of segment linked to a solid element
457 need_solid_erosion = .false.
458 ! -------------------
459 ! Solid erosion algorithm is ON if :
460 ! * there at least 1 segment linked to a solid element in the /SURF
461 ! * and if idel is /=0
462 IF(idel/=0.AND.solid_segment>0) THEN
463 IF(isu1/=0) THEN
464 IF(igrsurf(isu1)%EXT_ALL==2) need_solid_erosion = .true.
465 ENDIF
466 IF(isu2/=0) THEN
467 IF(igrsurf(isu2)%EXT_ALL==2) need_solid_erosion = .true.
468 ENDIF
469 ENDIF
470 IF(idel > 0.AND.solid_segment>0) THEN ! Solid erosion
471 ipari(100) = 1 ! solid erosion is ON for this interface
472 parameters%INT25_EROSION_SOLID = 1 ! global flag for solid erosion
473 ENDIF
474 ! -------------------
475 END IF
476
477 DEALLOCATE(tag,tags)
478C
479 RETURN
bitset
integer function bitset(i, n)
Definition bitget.F:66
my_real
#define my_real
Definition cppsort.cpp:32
in24coq_sol3
subroutine in24coq_sol3(irect, ixc, ixtg, msegtyp, x, knod2elc, knod2eltg, nod2elc, nod2eltg, knod2els, nod2els, ixs, ixs10, ixs16, ixs20)
Definition i24surfi.F:941
sh2surf25
subroutine sh2surf25(nrtm0, irect, imbin, mbinflg, msegtyp, nrtm)
Definition i25surfi.F:487
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
groupdef_mod
Definition groupdef_mod.F:668
message_mod
Definition message_mod.F:1257
parameters_mod
Definition parameters_mod.F:49
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

◆ sh2surf25()

subroutine sh2surf25 ( integer nrtm0,
integer, dimension(4,*) irect,
integer imbin,
integer, dimension(*) mbinflg,
integer, dimension(*) msegtyp,
integer nrtm )

Definition at line 486 of file i25surfi.F.

487C-----------------------------------------------
488C I m p l i c i t T y p e s
489C-----------------------------------------------
490#include "implicit_f.inc"
491C-----------------------------------------------
492C D u m m y A r g u m e n t s
493C-----------------------------------------------
494 INTEGER NRTM0,IMBIN,NRTM
495 INTEGER IRECT(4,*),MBINFLG(*),MSEGTYP(*)
496C-----------------------------------------------
497C L o c a l V a r i a b l e s
498C-----------------------------------------------
499 INTEGER I, NR, IT
500 INTEGER, DIMENSION(:), ALLOCATABLE :: ETYP
501C=======================================================================
502 ALLOCATE(etyp(nrtm0))
503C------add asymmetric shell segs at end, change MSEGTYP
504 DO i=1,nrtm0
505 etyp(i) = msegtyp(i)
506 END DO
507C
508 nr=nrtm0
509 DO i=1,nrtm0
510 msegtyp(i)=0
511 IF(etyp(i) ==3 .OR. etyp(i) ==7 ) THEN
512 nr =nr +1
513 irect(1,nr)=irect(2,i)
514 irect(2,nr)=irect(1,i)
515 irect(3,nr)=irect(4,i)
516 irect(4,nr)=irect(3,i)
517 msegtyp(i)=nr
518 msegtyp(nr)=-i
519 IF(imbin/=0) mbinflg(nr)=mbinflg(i)
520C------coating shell don't be doubled--
521 ELSEIF(etyp(i) < 0 ) THEN
522C------coating shell oppposite to solid externl segment => reverse ordering --
523 it= irect(1,i)
524 irect(1,i)=irect(2,i)
525 irect(2,i)=it
526 it= irect(3,i)
527 irect(3,i)=irect(4,i)
528 irect(4,i)=it
529C
530 nr =nr +1
531 irect(1,nr)=irect(2,i)
532 irect(2,nr)=irect(1,i)
533 irect(3,nr)=irect(4,i)
534 irect(4,nr)=irect(3,i)
535C--------coating shell <=> MSEGTYP(I) > NRTM
536 msegtyp(i) = nr+nrtm
537 msegtyp(nr)=-(i+nrtm)
538 IF(imbin/=0) mbinflg(nr)=mbinflg(i)
539 ELSEIF(etyp(i) ==4 .OR. etyp(i) ==8) THEN
540 nr =nr +1
541 irect(1,nr)=irect(2,i)
542 irect(2,nr)=irect(1,i)
543 irect(3,nr)=irect(4,i)
544 irect(4,nr)=irect(3,i)
545C--------coating shell <=> MSEGTYP(I) > NRTM
546 msegtyp(i) = nr+nrtm
547 msegtyp(nr)=-(i+nrtm)
548 IF(imbin/=0) mbinflg(nr)=mbinflg(i)
549 END IF
550 END DO
551C------------------------------------------------------------
552 DEALLOCATE(etyp)
553 RETURN