C C20227    SOURCE    CHAT      05/01/12    21:44:53     5004           
      SUBROUTINE C20227
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C************************************************************************
C Ce sp transforme des elemnts quadratique d'un type pris
C dans la liste ci-dessous
C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
C  3    6    10   15   17   24   26
C
C en les éléments correspondant quadratique complet de la liste
C ci-dessous
C
C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19
C  3    7    11   33   34   35   36
C************************************************************************
-INC SMELEME
-INC SMCOORD
-INC CCOPTIO
-INC SMLENTI
      SEGMENT TRAV
      INTEGER IFAC4(4,NBFTM)
      ENDSEGMENT
      SEGMENT TRAV1
      INTEGER NUMF4(9,NBFTM)
      ENDSEGMENT
      SEGMENT SITAF
      INTEGER ITAF(NBFAX,MMMAX)
      ENDSEGMENT
      SEGMENT TRAV2
      INTEGER NUF(6,NBELT)
      ENDSEGMENT
      SEGMENT CARA
      INTEGER KM(6,NBSOU1)
      ENDSEGMENT


      DIMENSION IAR(3,35),IFR(4,20)
      DATA IAR /1,2,3,3,4,5,5,6,7,7,8,1,
     &          1,9,13,3,10,15,5,11,17,7,12,19,
     &          13,14,15,15,16,17,17,18,19,19,20,13,
     &          1,2,3,3,4,5,5,6,1,1,7,10,3,8,12,5,9,14,
     &          10,11,12,12,13,14,14,15,10,
     &          1,2,3,3,4,5,5,6,1,1,7,10,3,8,10,5,9,10,
     &          1,2,3,3,4,5,5,6,7,7,8,1,1,9,13,3,10,13,
     &          5,11,13,7,12,13/

      DATA IFR /1,6,9,5, 2,7,10,6, 3,8,11,7, 4,5,12,8,
     &          1,2,3,4, 9,10,11,12,
     &          1,5,7,4, 2,6,8,5, 3,4,9,6, 1,2,3,0, 7,8,9,0,
     &          1,2,3,0, 1,5,4,0, 2,6,5,0, 3,6,4,0,
     &          1,2,3,4, 1,6,5,0, 2,7,6,0, 3,8,7,0, 4,5,8,0/

C Nb de pts par face par type elt
      DIMENSION KNPF(6,7)
      DATA KNPF/1,1,0,0,0,0,
     &          3,3,3,0,0,0,
     &          3,3,3,3,0,0,
     &          8,8,8,8,8,8,
     &          8,8,8,6,6,0,
     &          6,6,6,6,0,0,
     &          8,6,6,6,6,0/

C Nb d'arretes par face par type elt
      DIMENSION KNAF(6,7)
      DATA KNAF/0,0,0,0,0,0,
     &          0,0,0,0,0,0,
     &          0,0,0,0,0,0,
     &          4,4,4,4,4,4,
     &          4,4,4,3,3,0,
     &          3,3,3,3,0,0,
     &          4,3,3,3,3,0/

C?    DIMENSION I12(35),J12(11)
C?    DATA I12  /1,2,3,4,5,6,7,8,10,12,14,16,19,20,21,22,23,24,25,26,
C?   &           1,2,3,4,5,6,8,10,12,15,16,17,18,19,20/
C?    DATA J12  /11,13,15,17,9,27,
C?   &           9 ,11,13,7 ,21/

      DIMENSION INF(8,20)
C CU20
      DATA INF/1,2,3,10,15,14,13,9,  3,4,5,11,17,16,15,10,
     &         5,6,7,12,19,18,17,11, 7,8,1,9,13,20,19,12,
     &         1,8,7,6,5,4,3,2,      13,14,15,16,17,18,19,20,
C PR15
     &         1,2,3,8 ,12,11,10,7,  3,4,5,9 ,14,13,12,8 ,
     &         5,6,1,7,10,15,14,9 ,  1,2,3,4,5,6,0,0,
     &         10,11,12,13,14,15,0,0,
C TE15
     &  1,2,3,4,5,6,0,0,  1,2,3,8,10,7,0,0,  3,4,5,9,10,8,0,0,
     &  1,6,5,9,10,7,0,0,
C PY15
     &  1,2,3,4,5,6,7,8,  1,2,3,10,13,9,0,0,  3,4,5,11,13,10,0,0,
     &  5,6,7,12,13,11,0,0,  7,8,1,9,13,12,0,0/





      DIMENSION NUA(12),NUMA(4),XA(3,21),KTA(7,9)
      DATA KTA/3,6,10,15,17,24,26,
     &         3,7,11,33,34,35,36,
C nb de faces
     &         2,3,4 ,6 ,5 ,4 ,5 ,
C nb d'arretes
     &         0,3,4 ,12,9 ,6 ,8,
C Idec
     &         0,0,0 ,0 ,12,21,27,
C Idc3
     &         0,0,0 ,0 ,6 ,11,15,
C Nbnn
     &         3,7,9 ,27,21,15,19,
C NP
     &         3,6,8 ,20,15,10,13,
C IDF
     &         0,0,0 ,0 ,6 ,11,15/

C?Numero pt centre N18
C?   &         0,0,0 ,18,14,14,18/
C?Idc2
C?   &         0,0,0 ,0 ,20,35,45,

C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
C  3    6    10   15   17   24   26
C SEG3 TRI7 QUA9 CU27 PR21 TE15 PY19
C  3    7    11   33   34   35   36


C     write(6,*)' C20227 dbut '
C*************************************************************

      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
      IKQF=1
      IK=1
      DO 11 L=1,NBSOU1
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      ITYP=IPT1.ITYPEL

      DO 111 I=1,7
      IF(ITYP.EQ.KTA(I,1))THEN
      IK=I
      GO TO 110
      ENDIF
 111  CONTINUE
      IK=0
 110  CONTINUE

      DO 112 I=1,7
      IF(ITYP.EQ.KTA(I,2))GO TO 113
 112  CONTINUE
C     write(6,*)' ITYP=',ityp
      IKQF=0
 113  CONTINUE

      NP    =IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      IF(IK.GT.1)THEN
      NBELT=NBELT+NBELEM
      ENDIF
      KM(1,L)=NBELEM
      KM(2,L)=IPT1
      KM(3,L)=IK
C nb d'aretes par element
      KM(4,L)=KTA(IK,4)
C nb de faces
      KM(5,L)=KTA(IK,3)
      SEGDES IPT1
 11   CONTINUE
      SEGDES MELEME

      IF(IDIM.EQ.3)THEN
      ONBN=FLOAT(NBELT)+(3.D0*(FLOAT(NBELT)**(2.D0/3.D0)))
      NBNO=INT(ONBN)
      ELSE
      ONBN=FLOAT(NBELT)+(2.D0*(FLOAT(NBELT)**(0.5D0)))
      NBNO=INT(ONBN)
      ENDIF

C     write(6,*)'IKQF=',ikqf,' IK=',ik
      IF(IKQF.NE.0)THEN
C     write(6,*)' C20227 il n y a rien a faire'
      CALL ECROBJ('MAILLAGE',MELEME)
      SEGSUP CARA
      RETURN
      ENDIF

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

C     write(6,*)' C20227 on fait quekchose '
      NBPT=XCOOR(/1)/(IDIM+1)
      JG=NBPT
      SEGINI MLENTI,MLENT1

      NBFAX=4+1
      MMMAX=3*NBELT+300
      SEGINI SITAF

      NBFTM=5*NBELT+500
      SEGINI TRAV,TRAV1,TRAV2

      SEGACT MELEME

      NBFT4=0
      NBAT=0
      NN=0
      MM=0

      NK=0
      DO 1 L=1,NBSOU1
      IK=KM(3,L)

      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NBELEM=IPT1.NUM(/2)
      NP    =IPT1.NUM(/1)
C     write(6,*)' ITYP,NBELEM=',ITYP,NBELEM

      IF(IK.EQ.1)GO TO 1
      IF(IK.EQ.2.OR.IK.EQ.3)THEN
      NK=NK+NBELEM
      GO TO 1
      ENDIF

      IDEC=KTA(IK,5)
      IDC3=KTA(IK,6)
      IDF =KTA(IK,9)
      NBA=KTA(IK,4)
      NBF=KTA(IK,3)
C     write(6,*)' NBA,NBF,NPF=',NBA,NBF

      DO 2 K=1,NBELEM
      NK=NK+1

      DO 5 NA=1,NBA
      N1=IPT1.NUM(IAR(1,NA+IDEC),K)
      N2=IPT1.NUM(IAR(3,NA+IDEC),K)
      NM=IPT1.NUM(IAR(2,NA+IDEC),K)

      IF(LECT(NM).EQ.0)THEN
C le milieu n'a pas encore été touché
      NBAT=NBAT+1
      LECT(NM)=NBAT
      NUA(NA)=NBAT
      ELSE
      NUA(NA)=LECT(NM)
      ENDIF

 5    CONTINUE

      DO 6 NF=1,NBF
C nb de pts par faces
      NPF=KNPF(NF,IK)
C nb d'arretes par faces
      NAF=KNAF(NF,IK)

      DO 61 NFA=1,NAF
      NUMA(NFA)=NUA(IFR(NFA,NF+IDF))
 61   CONTINUE

      CALL ORDOTA(NUMA,NAF)
      IF(MLENT1.LECT(NUMA(1)).EQ.0)THEN
C l'arrete n'a pas encore été touché
      NBFT4=NBFT4+1

      IF(NBFT4.GT.NBFTM)THEN
C     write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
      NBFTM=NBFTM+NBELEM
      SEGADJ TRAV,TRAV1
      ENDIF

      NUMF4(9,NBFT4)=NPF
      DO 621 I=1,NPF
      NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
 621  CONTINUE
      MM=MM+1

      IF(MM.GT.MMMAX)THEN
C     write(6,*)' Taille ITAF 2eme dime insuffisante MM=',MM
      MMMAX=MMMAX+NBELEM
      SEGADJ SITAF
      ENDIF

      MLENT1.LECT(NUMA(1))=MM
      ITAF(1,MM)=1
      ITAF(1+1,MM)=NBFT4
C     write(6,*)' NBFT4=',nbft4,' mm=',mm,' NB=',ITAF(1,mm)
      NUF(NF,NK)=NBFT4
      CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)
      GO TO 6
      ENDIF

C On cherche si la face existe déja dans la table ITAF
      MM1=MLENT1.LECT(NUMA(1))
      NB=ITAF(1,MM1)
      DO 631 II=1,NB
      I=ITAF(II+1,MM1)
        IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I)
     & .AND.NUMA(1).EQ.IFAC4(1,I))THEN
        NUF(NF,NK)=I
        GO TO 6
        ENDIF
 631  CONTINUE

      IF(NB.LT.(NBFAX-1))THEN
C la face n'existe pas dans la table ITAF qui n'est pas pleine
C On peut donc considerer que la face est nouvelle
      NBFT4=NBFT4+1

      IF(NBFT4.GT.NBFTM)THEN
C     write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
      NBFTM=NBFTM+NBELEM
C     write(6,*)' NBFTM=',NBFTM,NBELEM
      SEGADJ TRAV,TRAV1
      ENDIF

      NUMF4(9,NBFT4)=NPF
      DO 622 I=1,NPF
      NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
 622  CONTINUE
      ITAF(1,MM1)=NB+1
      ITAF(NB+2,MM1)=NBFT4
C     write(6,*)' NBFT4=',NBFT4,' mm1=',mm1,' NB=',ITAF(1,mm1)
      NUF(NF,NK)=NBFT4
      CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)
      GO TO 6
      ENDIF

C     write(6,*)' Taille ITAF 1ere dime insuffisante NB=',NB
      NBFAX=NBFAX+2
      SEGADJ SITAF
C On fait une recherche parmis toutes les faces existantes


      IF(NAF.EQ.4)THEN
      DO 7 I=1,NBFT4
        IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I)
     & .AND.NUMA(1).EQ.IFAC4(1,I))THEN
        NUF(NF,NK)=I
        GO TO 6
        ENDIF
 7    CONTINUE
      ELSEIF(NAF.EQ.3)THEN
      DO 71 I=1,NBFT4
        IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I))THEN
        NUF(NF,NK)=I
        GO TO 6
        ENDIF
 71   CONTINUE
      ENDIF


 64   CONTINUE
      NBFT4=NBFT4+1

      IF(NBFT4.GT.NBFTM)THEN
C     write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
      NBFTM=NBFTM+NBELEM
      SEGADJ TRAV,TRAV1
      ENDIF

      ITAF(1,MM1)=NB+1
      ITAF(NB+2,MM1)=NBFT4
      NUMF4(9,NBFT4)=NPF
      DO 623 I=1,NPF
      NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
 623  CONTINUE
      NUF(NF,NK)=NBFT4
      CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)

 6    CONTINUE
 2    CONTINUE
 1    CONTINUE

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

      SEGSUP SITAF,MLENTI,MLENT1,TRAV

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

      SEGACT MELEME

      NK=0
      DO 80 L=1,NBSOU1
      IK=KM(3,L)
      NBF=KTA(IK,3)
      IF(IK.EQ.1)GO TO 80

      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1

      NBELEM=KM(1,L)
      NBNN  =KTA(IK,7)
      NP    =KTA(IK,8)

      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      KM(2,L)=IPT2
      IPT2.ITYPEL=KTA(IK,2)

      IF(IK.GE.4)THEN
C CU27 & PR21
      IDC3=KTA(IK,6)

      DO 83 K=1,NBELEM
      NK=NK+1
      DO 8 I=1,NP
      IPT2.NUM(I,K)=IPT1.NUM(I,K)
 8    CONTINUE
      DO 81 I=1,NBF
      IPT2.NUM(I+NP,K)=NBPT+NBELT+NUF(I,NK)
 81   CONTINUE
      IPT2.NUM(NBNN,K)=NBPT+NK
 83   CONTINUE

      ELSEIF(IK.EQ.2.OR.IK.EQ.3)THEN
      IDC=7
      IF(IK.EQ.3)IDC=9
      NP=NBNN-1
      DO 84 K=1,NBELEM
      NK=NK+1
      DO 88 I=1,NP
      IPT2.NUM(I,K)=IPT1.NUM(I,K)
 88   CONTINUE
      IPT2.NUM(IDC,K)=NBPT+NK
 84   CONTINUE

      ENDIF

      SEGDES IPT1,IPT2
 80   CONTINUE

C     write(6,*)' NUF '
C     DO 783 K=1,NBELT
C     write(6,1011)K,(NUF(i,k),i=1,6)
C783  continue

C     do 784 k=1,nbft4
C     write(6,1011)K,(NUMF4(i,k),i=1,8)
C784  continue

C     write(6,*)' NBPT=',nbpt
C     write(6,*)' NBAT=',nbat
C     write(6,*)' NBELT=',NBELT,' NBFT4=',nbft4

      NBPTS=NBPT+NBELT+NBFT4
      IF(NBPTS.GT.NBPT)SEGADJ MCOORD

C************** On calcule les coordonnées des points ***********



      IF(NBFT4.NE.0)THEN

      DO 23 J=1,NBFT4

      NPF=NUMF4(9,J)
      DO 21 I=1,NPF
      N1=NUMF4(I,J)
      DO 21 M=1,IDIM
      XA(M,I)=XCOOR((N1-1)*(IDIM+1)    +M)
 21   CONTINUE

      CALL FFFACE(XA,NPF)

      N9=NBPT+NBELT+J
      DO 22 M=1,IDIM
      XCOOR((N9-1)*(IDIM+1)    +M)=XA(M,NPF+1)
 22   CONTINUE
 23   CONTINUE
      ENDIF


C     write(6,*)' On calcule les coordonnées du pt centre ',NBELT
      IF(NBELT.NE.0)THEN
      SEGACT MELEME
      NK=0
      DO 90 L=1,NBSOU1

      IK=KM(3,L)
      IF(IK.EQ.1)GO TO 90
      IPT1=MELEME
      IF(NBSOU1.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1

      NBELEM=KM(1,L)
      NBNN  =KTA(IK,7)
      NP    =KTA(IK,8)

      IPT2=KM(2,L)

      DO 24 K=1,NBELEM
      NK=NK+1
      CALL INITD(XA(1,21),IDIM,0.D0)
      DO 25 I=1,NP
      N1=IPT1.NUM(I,K)
      DO 25 M=1,IDIM
      XA(M,I)=XCOOR((N1-1)*(IDIM+1)    +M)
      XA(M,NP+1)=XA(M,NP+1)+(XA(M,I)/FLOAT(NP))
 25   CONTINUE
      CALL FFFACE(XA,NP)


      N18=NBPT+NK
C     write(6,*)' *** NK=',nk,NBELT,L
      DO 26 M=1,IDIM
      XCOOR((N18-1)*(IDIM+1)    +M)=XA(M,NP+1)
 26   CONTINUE
 24   CONTINUE

 90   CONTINUE

      ENDIF


C     write(6,*)' NBPT=',nbpt
C     write(6,*)' NBAT=',nbat
C     do 116 l=1,nbat
C     write(6,1011)L,(itab(i,l),i=1,3)
C116  continue

C     write(6,*)' LECT '
C     write(6,1001)(lect(ii),ii=1,nbpt)

C     write(6,*)' ITAC NN=',NN
C     do 118 l=1,NN
C      nb=itac(1,l)
C     write(6,1011)L,itac(1,l),(itac(i+1,l),i=1,nb)
C118  continue

C     write(6,*)' NBFT4=',nbft4

C     do 117 l=1,nbft4
C     write(6,1011)L,(ifac4(i,l),i=1,4)
C117  continue

C     write(6,*)' MLENT1.LECT '
C     write(6,1001)(mlent1.lect(ii),ii=1,nbpt)

C     write(6,*)' ITAF MM=',MM
C     do 119 l=1,MM
C     nb=itaf(1,l)
C     write(6,1011)L,itaf(1,l),(itaf(i+1,l),i=1,nb)
C119  continue

      SEGSUP TRAV1
      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
      ENDIF

C?    SEGACT IPT3
C?    nbref=IPT3.LISREF(/1)
C?    write(6,*)' nbref,meleme=',nbref,meleme
C?    IPT3.LISREF(1)=MELEME
      SEGDES IPT3

C     write(6,*)' C20227 ipt3=',ipt3
      CALL ECROBJ('MAILLAGE',IPT3)

      SEGSUP CARA,TRAV2

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