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
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "com04_c.inc"
63#include "units_c.inc"
64#include "param_c.inc"
65#include "scr03_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 INTEGER IALLO,NBINFLG(*)
70 INTEGER IPARI(NPARI),
71 . IRECT(4,*), NSV(*),MSEGTYP(*),
72 . MSR(*),ITAB(*),MBINFLG(*),
73 . ISEADD(*) ,ISEDGE(*),ITAG(*),INTPLY,
74 . IXC(NIXC,*),IXTG(NIXTG,*),KNOD2ELC(*),KNOD2ELTG(*),
75 . NOD2ELC(*),NOD2ELTG(*),KNOD2ELS(*),NOD2ELS(*),
76 . IRTSE(5,*) ,IS2SE(*),IS2PT(*) ,IS2ID(*)
77 INTEGER IXS(NIXS,*),IXS10(6,*), IXS16(8,*), IXS20(12,*)
78 INTEGER MODE, WORK(70000), NRTMP, I1, I2
79 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
80 INTEGER, DIMENSION(:,:),ALLOCATABLE :: IRECTMP
81 INTEGER, DIMENSION(:,:),ALLOCATABLE :: IRECTMP_SAV
82 INTEGER, INTENT(IN) :: NIN25
83 INTEGER, INTENT(INOUT) :: FLAG_ELEM_INTER25(NINTER25,NUMELS)
84 my_real
85 . x(3,*),frigap(*)
86C-----------------------------------------------
87 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
88 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
89 TYPE (PARAMETERS_) ,INTENT(INOUT) :: PARAMETERS
90C-----------------------------------------------
91C L o c a l V a r i a b l e s
92C-----------------------------------------------
93 INTEGER I,J,K,L,LL,NL,ISU1,ISU2,NOD1,NRTM,NRTS,NSN,NMN,
94 . NLINSA,NLINMA,ILEV,NLN,ISYM
95 INTEGER, DIMENSION(:), ALLOCATABLE :: TAG,TAGS
96 INTEGER NLINS,NLINM,LINE1,LINE2,STAT,IL,IG,N,II,IJ,IMIN
97 INTEGER NSU1,NLS1,NLS2,NRTM_SH,ETYP,NRTM0,
98 . IMBIN,IM,IDEB,ISN
99 LOGICAL :: NEED_SOLID_EROSION
100 INTEGER :: IDEL,SOLID_SEGMENT,ELEM
101C-----------------------------------------------
102C E x t e r n a l F u n c t i o n s
103C-----------------------------------------------
104 INTEGER BITSET
105 EXTERNAL bitset
106C
107 CHARACTER MESS*40
108 DATA mess/'INTERFACE INPUT '/
109C-----------------------------------------------
110 nsn = 0
111 nmn = 0
112 nrtm = 0
113 nrts = 0
114 nod1 = ipari(26)
115 nln = 0
116 ilev = ipari(20)
117 isu1 = ipari(45)
118 isu2 = ipari(46)
119 nsu1 = 0
120 nls1 = 0
121 nls2 = 0
122 IF(iallo == 2 .AND. ilev == 2 ) THEN
123 imbin=1
124 ELSE
125 imbin=0
126 END IF
127C=======================================================================
128c SURFACES
129C=======================================================================
130c-----------------------------------------------------------------
131c surface S1
132c-----------------------------------------------------------------
133c-----------------------------------------------------------------
134c surface S2
135c-----------------------------------------------------------------
136 SELECT CASE (ilev)
137C-----attention: ISU2=ISU1 /=0
138 CASE(1)
139 nrtm = igrsurf(isu1)%NSEG
140 CASE(2)
141 nrtm = igrsurf(isu1)%NSEG
142 nrts = igrsurf(isu2)%NSEG
143 nrtm = nrtm + nrts
144 CASE(3)
145 nrtm = igrsurf(isu2)%NSEG
146 END SELECT
147c-----------------------------------------------------------------
148 ALLOCATE(index(2*nrtm),irectmp(6,nrtm),stat=stat)
149 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
150 . msgtype=msgerror,
151 . c1='IRECTSAV')
152 irectmp(1:6,1:nrtm)=0
153C
154c---------------------------------------
155c copie des surfaces (IALLO == 2)
156c---------------------------------------
157 l = 0
158 IF(isu1 /= 0)THEN
159 DO j=1,igrsurf(isu1)%NSEG
160 l = l+1
161 DO k=1,4
162 irectmp(k,l) = igrsurf(isu1)%NODES(j,k)
163 ENDDO
164 irectmp(5,l) = igrsurf(isu1)%ELTYP(j) ! MSEGTYP
165 CALL in24coq_sol3(irectmp(1,l) ,ixc ,ixtg ,irectmp(5,l) ,x ,
166 . knod2elc ,knod2eltg ,nod2elc ,nod2eltg,
167 . knod2els,nod2els,ixs ,ixs10 ,ixs16 ,ixs20 )
168 IF(imbin /= 0)irectmp(6,l) = bitset(irectmp(6,l),0) ! MBINFLG
169 IF(ilev==1.OR.ilev==2) THEN
170 elem = igrsurf(isu1)%ELEM(j)
171 IF(elem/=0.AND.igrsurf(isu1)%ELTYP(j)==1) flag_elem_inter25(nin25,elem) = 1 ! tag solid elements included in surface
172 ENDIF
173 ENDDO
174 ENDIF
175 nsu1 = l
176 IF(isu2 /= 0 .AND.ilev /=1)THEN
177 DO j=1,igrsurf(isu2)%NSEG
178 l = l+1
179 DO k=1,4
180 irectmp(k,l) = igrsurf(isu2)%NODES(j,k)
181
182!! IAD = IAD+1
183 ENDDO
184 irectmp(5,l) = igrsurf(isu2)%ELTYP(j) ! MSEGTYP
185 CALL in24coq_sol3(irectmp(1,l) ,ixc ,ixtg ,irectmp(5,l) ,x ,
186 . knod2elc ,knod2eltg ,nod2elc ,nod2eltg,
187 . knod2els,nod2els,ixs ,ixs10 ,ixs16 ,ixs20 )
188 IF(imbin /= 0) irectmp(6,l) = bitset(irectmp(6,l),1) ! MBINFLG
189 elem = igrsurf(isu2)%ELEM(j)
190 IF(elem/=0.AND.igrsurf(isu2)%ELTYP(j)==1) flag_elem_inter25(nin25,elem) = 1 ! tag solid elements included in surface
191 ENDDO
192 ENDIF
193C=======================================================================
194c Filtre
195 nrtmp=nrtm
196C
197 ALLOCATE(irectmp_sav(6,nrtm),stat=stat)
198
199
200 irectmp_sav(1:6,1:nrtm) = irectmp(1:6,1:nrtm)
201 DO i=1,nrtm
202 IF(irectmp(5,i)==0.OR.irectmp(5,i)==1) THEN
203 IF(irectmp(4,i)==irectmp(3,i)) irectmp(4,i) = 0
204 DO j=1,3
205 imin = irectmp(j,i)
206 ij = j
207 DO k=j+1,4
208 IF(irectmp(k,i)<imin.AND.irectmp(k,i) /= 0) THEN
209 imin = irectmp(k,i)
210 ij = k
211 ENDIF
212 ENDDO
213 IF(ij /=j ) THEN
214 irectmp(ij,i) = irectmp(j,i)
215 irectmp(j,i) = imin
216 ENDIF
217 ENDDO
218 ENDIF
219 ENDDO
220C
221 mode=0
222 CALL my_orders( mode, work, irectmp, index, nrtm , 6)
223
224 IF(iallo==1)THEN
225
226 nrtm_sh=0
227
228 ideb=1
229 i1=index(ideb)
230 DO WHILE(irectmp(1,i1)==0)
231 ideb=ideb+1
232 i1=index(ideb)
233 END DO
234
235 nrtm =1
236 IF(irectmp(5,i1)/=0 .AND. irectmp(5,i1)/=1) nrtm_sh=nrtm_sh+1
237
238 DO j=ideb,nrtmp-1
239 i1=index(j)
240 i2=index(j+1)
241
242 IF(irectmp(1,i2)/=irectmp(1,i1).OR.
243 . irectmp(2,i2)/=irectmp(2,i1).OR.
244 . irectmp(3,i2)/=irectmp(3,i1).OR.
245 . irectmp(4,i2)/=irectmp(4,i1).OR.
246 . irectmp(5,i2)/=irectmp(5,i1))THEN ! Teste MSEGTYP pq ya un risque si renumerotation entre les 2 phases
247 ! A regler
248 nrtm=nrtm+1
249 IF(irectmp(5,i2)/=0 .AND. irectmp(5,i2)/=1) nrtm_sh=nrtm_sh+1
250
251 END IF
252 END DO
253 ELSE ! IF(IALLO==1)THEN
254
255 ideb=1
256 i1=index(ideb)
257 DO WHILE(irectmp(1,i1)==0)
258 ideb=ideb+1
259 i1=index(ideb)
260 END DO
261
262 nrtm=1 ! recompute NRTM same as with IALLO=1 <=> Ipari(4)
263 irect(1,nrtm)=irectmp_sav(1,i1)
264 irect(2,nrtm)=irectmp_sav(2,i1)
265 irect(3,nrtm)=irectmp_sav(3,i1)
266 irect(4,nrtm)=irectmp_sav(4,i1)
267 msegtyp(nrtm)=irectmp_sav(5,i1)
268 IF(imbin/=0) mbinflg(nrtm)=irectmp_sav(6,i1)
269
270 DO j=ideb,nrtmp-1
271 i1=index(j)
272 i2=index(j+1)
273 IF(irectmp(1,i2)/=irectmp(1,i1).OR.
274 . irectmp(2,i2)/=irectmp(2,i1).OR.
275 . irectmp(3,i2)/=irectmp(3,i1).OR.
276 . irectmp(4,i2)/=irectmp(4,i1).OR.
277 . irectmp(5,i2)/=irectmp(5,i1))THEN ! teste msegtyp pq ya un risque si renumerotation entre les 2 phases
278 ! A regler
279 nrtm=nrtm+1
280 irect(1,nrtm)=irectmp_sav(1,i2)
281 irect(2,nrtm)=irectmp_sav(2,i2)
282 irect(3,nrtm)=irectmp_sav(3,i2)
283 irect(4,nrtm)=irectmp_sav(4,i2)
284 msegtyp(nrtm)=irectmp_sav(5,i2)
285 IF(imbin/=0) mbinflg(nrtm)=irectmp_sav(6,i2)
286
287 ELSEIF(irectmp(6,i1)/=irectmp(6,i2))THEN ! le segment appartient aux 2 surfaces
288 IF(imbin/=0) mbinflg(nrtm)=1+2
289 END IF
290 END DO
291 END IF
292
293
294 DEALLOCATE(index,irectmp)
295 IF(ALLOCATED(irectmp_sav)) DEALLOCATE(irectmp_sav)
296C=======================================================================
297c NOEUDS
298C=======================================================================
299c-----------------------------------------------------------------
300c tag noeuds 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 noeuds de la surface 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 noeuds de la surface 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 noeuds du groupe de noeud NOD1: 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 nombre de noeuds dans l'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 pour 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:940
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:662
message_mod
Definition message_mod.F:1249
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:889

◆ 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, J, ITYPE
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