C CQ2L      SOURCE    CHAT      05/01/12    22:26:47     5004           
      SUBROUTINE CQ2L
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C
C     Ce SP fait un decoupage en élément linéaire de QCF ou MACRO
C
C
C
C***********************************************************************
-INC SMELEME
-INC SMCOORD
-INC CCOPTIO
-INC SMLENTI

      SEGMENT CARA
      INTEGER KM(6,NBSOU1)
      ENDSEGMENT

      DIMENSION I12(8,35)
      DATA I12/
C SEG2 2
     &   1,2,6*0, 2,3,6*0,
C TRI7 3
     &   1,2,7,6,4*0, 2,3,4,7,4*0, 6,7,4,5,4*0,
C QUA9 4
     &   1,2,9,8,4*0, 2,3,4,9,4*0, 9,4,5,6,4*0, 8,9,6,7,4*0,
C CU27 8
     &   1,2,25,8,9,21,27,24,  2,3,4,25,21,10,22,27,
     &   4,5,6,25,22,11,23,27,  6,7,8,25,23,12,24,27,
     &   9,21,27,24,13,14,26,20, 21,10,22,27,14,15,16,26,
     &   27,22,11,23,26,16,17,18, 27,23,12,24,26,18,19,20,
C PR21 6
     &1,2,19,6,7,16,21,18,2,3,4,19,16,8,17,21,4,5,6,19,17,9,18,21,7,16,
     &21,18,10,11,20,15,16,8,17,21,11,12,13,20,17,9,18,21,13,14,15,20,
C TRI6 4
     & 1,2,6,5*0,  2,3,4,5*0, 4,5,6,5*0, 6,2,4,5*0,
C PR18 8
     & 1,2,6,7,16,18,2*0,2,3,4,16,8,17,2*0,4,5,6,17,9,18,2*0,
     & 2,4,6,16,17,18,2*0,7,16,18,10,11,15,2*0,16,8,17,11,12,13,2*0,
     & 18,17,9,15,13,14,2*0, 16,17,18,11,13,15,2*0/
C tetrahedre et pyramide non fait

      DIMENSION KTA(11,5)
      DATA KTA/3,7,11,33,34,35,36,6 ,40,24,00,
     &         2,8,8 ,14,14,23,25,4 ,16,23,25,
C NBNN
     &         2,4,4 ,8 ,8 ,4 ,5 ,3 ,6 ,4 ,5 ,
C nb  d'éléments du découpage
     &         2,3,4 ,8 ,6 ,8 ,8 ,4 ,8 ,8 ,8 ,
C IDEC  seg3 tri7 qua9 cu27 pr21 te15 py19 tri6 pr18
     &  0,   2,   5,   9,   17,  00,  00,  23,  27,  00,00/

C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19  TRI6 PR18 TE10 PY14
C  3    7    11   33   34   35   36    6    40   24   ??
C SEG2 QUA4 QUA4 CUB8 CUB8 TET4 PYR5  TRI3 PRI6 TET4 PYR5
C  2    8    8    14   14   23   25    4    16   23   25

C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
C  3    6    10   15   17   24   26

C*************************************************************

C     write(6,*)' I12 '
C     do 460 l=1,35
C     write(6,1001)(I12(k,l),k=1,8)
C460  continue
C     write(6,*)' CQ2L alias decl '

      CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
      IF(IRET.EQ.0)RETURN

      SEGACT MELEME

      NBSOU1=LISOUS(/1)
      IF(NBSOU1.EQ.0)NBSOU1=1
      SEGINI CARA
      NBELT=0
      DO 11 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      ITYP=IPT1.ITYPEL
C On vérifie la possibilité de l'opération
      IK=0
      DO 111 I=1,11
      IF(ITYP.EQ.KTA(I,1))IK=I
 111  CONTINUE
C     write(6,*)' ityp=',ityp

      IF(IK.EQ.0)THEN
      CALL ERREUR(29)
      ENDIF

      NBELEM=IPT1.NUM(/2)
      NBELT=NBELT+NBELEM
      KM(1,L)=NBELEM
      KM(3,L)=IK
 11   CONTINUE
C     write(6,*)' NBELEM=',nbelt,' IK=',ik

      NK=0
      DO 1 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
C     write(6,*)' MELEME,IPT1=',MELEME,IPT1
      ITYP=IPT1.ITYPEL

      NBEL  =KM(1,L)
      IK    =KM(3,L)
      IDEC  =KTA(IK,5)
      NP    =IPT1.NUM(/1)
      NBNN  =KTA(IK,3)
      NBELEM=KTA(IK,4)*NBEL
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
C     write(6,*)' NBELEM,NBNN=',NBELEM,NBNN,' NBEL=',nbel
      KM(2,L)=IPT2
      IPT2.ITYPEL=KTA(IK,2)
      NK=0
      DO 33 K=1,NBEL
      DO 331 M=1,KTA(IK,4)
      NK=NK+1
C     write(6,*)' NK=',nk,'M=',M,'IDEC=',IDEC,'nbnn=',nbnn
      DO 332 I=1,NBNN
      IPT2.NUM(I,NK)=IPT1.NUM(I12(I,M+IDEC),K)
 332  CONTINUE
 331  CONTINUE
 33   CONTINUE
 1    CONTINUE

      SEGDES IPT1,IPT2

      IF(NBSOU1.EQ.1)THEN
      IPT3=KM(2,1)
      ELSE
      NBSOUS=NBSOU1
      NBELEM=0
      NBNN=0
      NBREF=0
      SEGINI IPT3
      DO 785 L=1,NBSOU1
      IPT3.LISOUS(L)=KM(2,L)
 785  CONTINUE
      SEGDES IPT3
      ENDIF

      CALL ECROBJ('MAILLAGE',IPT3)

      RETURN
 1011 FORMAT('L=',I3,4X,15(1X,I5))
 1001 FORMAT(20(1X,I5))
      END