Sources Esope | Cast3M

clinb
C CLINB     SOURCE    CHAT      05/01/12    22:08:16     5004
      SUBROUTINE CLINB
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C************************************************************************
C Ce sp transforme des éléments QUAF pris
C dans la liste ci-dessous
C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19
C  3    7    11   33   34   35   36
C
C en les éléments linéaires bulle construits à parir des sommets
C
C SEG2 TRI4 QUA5 CUB9 PRI7 TET5 PYR6
C  2    5    9    48   49   50   51
C************************************************************************
-INC SMELEME
      POINTEUR MLINB.MELEME
 
      CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
      IF(IRET.EQ.0)RETURN
 
      SEGACT MELEME
      NBSOU1=LISOUS(/1)
      IF(NBSOU1.EQ.0)NBSOU1=1
 
C     write(6,*)'CLINB il y a a faire '
 
      NBSOUS=NBSOU1
      NBNN=0
      NBELEM=0
      NBREF=0
      SEGINI MLINB
      DO 200 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      ITYP=IPT1.ITYPEL
      NBNN0=IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      MLINB.LISOUS(L)=IPT1
 
C     write(6,*)' CLINB ITYP=',ityp
      IF(ITYP.EQ.3)THEN
C SEG3 -> SEG2
      NBNN=2
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      MLINB.LISOUS(L)=IPT2
      IPT2.ITYPEL=2
      DO 202 K=1,NBELEM
      IPT2.NUM(1,K)=IPT1.NUM(1,K)
      IPT2.NUM(2,K)=IPT1.NUM(3,K)
 202  CONTINUE
 
      ELSEIF(ITYP.EQ.7)THEN
C TRI7 -> TRI4
      NBNN=4
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      MLINB.LISOUS(L)=IPT2
      IPT2.ITYPEL=5
      DO 304 K=1,NBELEM
      I1=0
      DO 204 I=1,6,2
      I1=I1+1
      IPT2.NUM(I1,K)=IPT1.NUM(I,K)
 204  CONTINUE
      IPT2.NUM(4,K)=IPT1.NUM(7,K)
 304  CONTINUE
 
      ELSEIF(ITYP.EQ.11)THEN
C QUA9 -> QUA5
      NBNN=5
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      MLINB.LISOUS(L)=IPT2
      IPT2.ITYPEL=9
      DO 308 K=1,NBELEM
      I1=0
      DO 208 I=1,8,2
      I1=I1+1
      IPT2.NUM(I1,K)=IPT1.NUM(I,K)
 208  CONTINUE
      IPT2.NUM(5,K)=IPT1.NUM(9,K)
 308  CONTINUE
 
      ELSEIF(ITYP.EQ.33)THEN
C CU27 -> CUB8
      NBNN=8
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      MLINB.LISOUS(L)=IPT2
      IPT2.ITYPEL=14
      DO 214 K=1,NBELEM
      I1=0
      DO 214 I=1,8,2
      I1=I1+1
      IPT2.NUM(I1,K)=IPT1.NUM(I,K)
      IPT2.NUM(I1+4,K)=IPT1.NUM(I+12,K)
 214  CONTINUE
 
      ELSEIF(ITYP.EQ.34)THEN
C PR21 -> PRI6
      NBNN=6
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      MLINB.LISOUS(L)=IPT2
      IPT2.ITYPEL=16
      DO 216 K=1,NBELEM
      I1=0
      DO 216 I=1,6,2
      I1=I1+1
      IPT2.NUM(I1,K)=IPT1.NUM(I,K)
      IPT2.NUM(I1+3,K)=IPT1.NUM(I+9,K)
 216  CONTINUE
 
      ELSEIF(ITYP.EQ.35)THEN
C TE15 -> TET5
      NBNN=5
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      MLINB.LISOUS(L)=IPT2
      IPT2.ITYPEL=9
      DO 2230 K=1,NBELEM
      IPT2.NUM(1,K)=IPT1.NUM(1,K)
      IPT2.NUM(2,K)=IPT1.NUM(3,K)
      IPT2.NUM(3,K)=IPT1.NUM(5,K)
      IPT2.NUM(4,K)=IPT1.NUM(10,K)
      IPT2.NUM(5,K)=IPT1.NUM(15,K)
 2230 CONTINUE
 
      ELSEIF(ITYP.EQ.36)THEN
C PY19 -> PYR5
      NBNN=5
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      MLINB.LISOUS(L)=IPT2
      IPT2.ITYPEL=25
      DO 2250 K=1,NBELEM
      I1=0
      DO 225 I=1,8,2
      I1=I1+1
      IPT2.NUM(I1,K)=IPT1.NUM(I,K)
 225  CONTINUE
      IPT2.NUM(5,K)=IPT1.NUM(13,K)
 2250 CONTINUE
 
 
      ENDIF
 
 200  CONTINUE
 
      IF(NBSOU1.EQ.1)THEN
      IPT3=MLINB
      MLINB=MLINB.LISOUS(1)
      SEGSUP IPT3
      ENDIF
 
      CALL ECROBJ('MAILLAGE',MLINB)
 
      RETURN
 1001 FORMAT(20(1X,I5))
 1002 FORMAT(10(1X,1PE11.4))
      END