C CQ2L      SOURCE    MAGN      18/05/16    21:15:00     9823           
      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 PPARAM
-INC CCOPTIO
-INC SMLENTI

      SEGMENT CARA
      INTEGER KM(6,NBSOU1)
      ENDSEGMENT

      DIMENSION I12(8,43)
      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 TE10 8
     & 1,2,6,7,4*0,7,6,8,2,4*0,7,6,8,9,4*0,7,8,9,10,4*0,
     & 2,3,4,8,4*0,6,5,4,9,4*0,9,2,4,8,4*0,9,2,4,6,4*0/

C Tetrahèdres macro
      DIMENSION IT12(8,8)
      DATA IT12/
     & 1,2,6,7,4*0  ,7,6,2,9,4*0  ,7,2,8,9,4*0  ,7,8,9,10,4*0,
     & 2,3,4,8,4*0  ,6,5,4,9,4*0  ,9,2,4,8,4*0  ,9,2,4,6,4*0/
C pyramide macro
      DIMENSION IP12(8,10)
      DATA IP12/
     & 1,2,14,8,9,3*0,  2,3,4,14,10,3*0,  4,5,6,14,11,3*0,
     & 6,7,8,14,12,3*0,  9,10,11,12,13,3*0,  9,10,11,12,14,3*0,
     & 2,14,10,9,4*0,  4,14,10,11,4*0,  6,11,14,12,4*0,  9,10,14,12,4*0/

      DIMENSION KTA(11,5)
      DATA KTA/3,7,11,33,34,35,36,6 ,40,24,26,
     &         2,8,8 ,14,14,23,25,4 ,16,23,25,
C NBNN (des linéaires)
     &   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,   6,   4,   8,   8,   8,
C IDEC  seg3 tri7 qua9 cu27 pr21 te15 py19 tri6 pr18 te10 py14
     &   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,' IK=',IK

      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)

      IF(IK.EQ.7)THEN
      NBNN  =4
      NBELEM=4*NBEL
      NBSOUS=0
      NBREF=0
      SEGINI IPT5
C     write(6,*)' NBELEM,NBNN=',NBELEM,NBNN,' NBEL=',nbel
      KM(5,L)=IPT5
      IPT5.ITYPEL=23
      ENDIF

      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
      NK3=0
      DO 33 K=1,NBEL
      DO 331 M=1,KTA(IK,4)
      NK=NK+1
      NK3=NK3+1
C     write(6,*)' NK=',nk,'M=',M,'IDEC=',IDEC,'nbnn=',nbnn

      IF(IK.EQ.10)THEN
      DO 333 I=1,NBNN
      IPT2.NUM(I,NK)=IPT1.NUM(IT12(I,M),K)
 333  CONTINUE
      ENDIF
      IF(IK.EQ.7)THEN
      DO 334 I=1,NBNN
      IPT2.NUM(I,NK)=IPT1.NUM(IP12(I,M),K)
 334  CONTINUE
      IF(M.LE.4)THEN
      DO 335 I=1,(NBNN-1)
      IPT5.NUM(I,NK3)=IPT1.NUM(IP12(I,M+6),K)
 335  CONTINUE
      ENDIF
      ENDIF
      IF(IK.NE.10.AND.IK.NE.7)THEN
      DO 332 I=1,NBNN
      IPT2.NUM(I,NK)=IPT1.NUM(I12(I,M+IDEC),K)
 332  CONTINUE
      ENDIF

 331  CONTINUE
 33   CONTINUE
 1    CONTINUE

      SEGDES IPT1,IPT2
      IF(IK.EQ.7)THEN
      SEGDES IPT5
      ENDIF

      IF(NBSOU1.EQ.1.AND.IK.NE.7)THEN
      IPT3=KM(2,1)
      ELSE
      NBSOUS=NBSOU1
      IF(IK.EQ.7)NBSOUS=NBSOUS+NBSOU1
      NBELEM=0
      NBNN=0
      NBREF=0
      SEGINI IPT3
      DO 785 L=1,NBSOU1
      IPT3.LISOUS(L)=KM(2,L)
 785  CONTINUE

      IF(IK.EQ.7)THEN
      DO 786 L=1,NBSOU1
      LL=L+NBSOU1
      IPT3.LISOUS(LL)=KM(5,L)
 786  CONTINUE
      ENDIF

      SEGDES IPT3
      ENDIF

      CALL ECROBJ('MAILLAGE',IPT3)

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