C GENERA    SOURCE    SP204843  25/03/14    21:15:05     12201          
C    OPTION GENERATRICE
C
      SUBROUTINE GENERA
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION XCO(4)

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCOORD
-INC SMELEME
-INC CCTOURN
      logical ltelq
      SEGMENT ICPR(2,NBELEC)
      SEGMENT ICPP(nbpts)

      IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL EXTRLI(IPT1,3,IRET,-1)
      IF (IERR.NE.0) RETURN

      IFUSE=0
      IF (IPT1.NE.IRET) IFUSE=IPT1
      IPT1=IRET
      CALL LIROBJ('MAILLAGE',IPT8,1,IRETOU)
      IF (IERR.NE.0) RETURN

      SEGACT IPT8
      IF (IPT8.ITYPEL.NE.KDEGRE(ILCOUR)) CALL ERREUR(16)
      IF (IERR.NE.0) RETURN

      NCOUCH=IPT8.NUM(/2)
      SEGACT IPT1
      SEGACT MCOORD*mod
      NBNN  =IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      IBOUCL=0
      IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1

  20  CONTINUE
      NX=NCOUCH-1
      IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH
 1000 FORMAT(/,' COUCHES ',I6)
      NBNN  =4
      NBELEM=IPT1.NUM(/2)*NCOUCH
      NBSOUS=0
      NBREF =4
      SEGINI,MELEME
      ITYPEL=8
      INCR  =IPT1.ITYPEL-1
      IL    =1
      NBELEC=IPT1.NUM(/2)
      SEGINI,ICPR

C    ON FAIT D'ABORD L' EXTREMITEE
      SEGINI,ICPP
      DO 52 I=1,ICPP(/1)
      ICPP(I)=0
  52  CONTINUE

      ICLE   =1
      IPBAS  =IPT8.NUM(1,1)
      IPHAU  =IPT8.NUM(IPT8.NUM(/1),NCOUCH)
      IREFB  =(IDIM+1)*(IPBAS-1)
      IREFH  =(IDIM+1)*(IPHAU-1)

      DO 200 I=1,IDIM+1
        XCO(I)=XCOOR(IREFH+I)-XCOOR(IREFB+I)
 200  CONTINUE

      CALL ADDITE(XCO,IPT1,IPT3,ICPP,0)
      IF (IERR.NE.0) RETURN
      SEGSUP ICPP
      SEGACT MCOORD*mod
      SEGACT IPT3
      CALL INVERS(IPT3,IPT4)
      SEGDES IPT4
      LISREF(3)=IPT4
C    ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS
      IDEB=nbpts+1
      DO 70 I=1,2
      DO 700 J=1,NBELEC
        ICPR(I,J)=0
  700 CONTINUE
  70  CONTINUE
      LCPR=0
      DO 71 J=1,NBELEC
      DO 710 I=1,2
      I1=IPT1.NUM((I-1)*INCR+1,J)
      LCPR=LCPR+1
      DO 72 JJ=1,J
      DO 720 II=1,2
      IF (IPT1.NUM((II-1)*INCR+1,JJ).NE.I1) GOTO 720
      IF (II.NE.I) GOTO 73
      IF (JJ.EQ.J) GOTO 710
  73  ICPR(I,J)=II+(JJ-1)*2
      LCPR=LCPR-1
      IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 75
       GOTO 710
  75  IF (IBOUCL.EQ.1) GOTO 710
      ICPR(I,J)=0
      ICPR(II,JJ)=I+(J-1)*2
      GOTO 710
  720  CONTINUE
  72  CONTINUE
  710 CONTINUE
  71  CONTINUE
*  IL SEMBLERAIT QUE L'ON AIT NCOUCH A FAIRE AVEC LCPR POINTS EFFECTIFS
C   ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR
C    LE MOMENT   D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER
      DO 40 I=1,IPT1.NUM(/2)
       NUM(1,I)=IPT1.NUM(1,I)
      NUM(2,I)=IPT1.NUM(1+INCR,I)
  40  CONTINUE
      ILASI=IDEB-1
      ILASJ=ILASI+(INCR*NX)+INCR-1
      IF (IBOUCL.EQ.1) ILASJ=ILASI
      ILAS=ILASJ+INCR*NX+INCR
      DO 42 ICOUCH=1,NCOUCH
      IF (NCOUCH.EQ.ICOUCH) GOTO 41
      ILASI=ILASI+INCR
      ILASJ=ILASJ+INCR
      INI=(ICOUCH-1)*IPT1.NUM(/2)
      NUM(1,1+INI+NBELEC)=ILASI
      NUM(4,1+INI)=ILASI
      NUM(2,INI+2*NBELEC)=ILASJ
      NUM(3,INI+NBELEC)=ILASJ
      DO 420 J=1,IPT1.NUM(/2)
      DO 421 I=1,2
      ILL=ILAS
      IF (I.EQ.1.AND.J.EQ.1) GOTO 421
      IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 421
      IF (ICPR(I,J).NE.0) ILL=NUM(MOD(ICPR(I,J)-1,2)+1,
     # (ICPR(I,J)-1)/2+1+INI+NBELEC)
      NUM(I,J+INI+NBELEC)=ILL
      NUM(5-I,J+INI)=ILL
      IF (ICPR(I,J).NE.0) GOTO 421
      ILAS=ILL+1
  421 CONTINUE
  420 CONTINUE
  42  CONTINUE
  41  CONTINUE
      INI=(NCOUCH-1)*IPT1.NUM(/2)
      DO 43 I=1,NBELEC
      NUM(4,INI+I)=IPT3.NUM(1,I)
      NUM(3,INI+I)=IPT3.NUM(1+INCR,I)
  43  CONTINUE
      DO 44 I=1,NCOUCH
       DO 440 J=1,IPT1.NUM(/2)
        II=(I-1)*IPT1.NUM(/2)+J
        ICOLOR(II)=IPT1.ICOLOR(J)
  440 CONTINUE
  44  CONTINUE
      LISREF(1)=IPT1
C   CREATION DES BORDS LATERAUX PAR LIGNE   PETIT SOUCI
C  CECI EST A REVOIR (NOUVEAU S-P POUR CE CAS QUI RESPECTE LA
C   NUMEROTATION
      ILS=IPT1.ITYPEL
      IDS=IPT1.ICOLOR(1)
      LP1=IPT1.NUM(1,1)
      LP2=IPT3.NUM(1,1)
      CALL GENERL(LP1,LP2,IPT8,IPT2,IDS)
      IF (IERR.NE.0) RETURN
      CALL INVERS(IPT2,IPT4)
      LISREF(4)=IPT4
      SEGDES IPT4,IPT2
      IF (IBOUCL.EQ.0) GOTO 46
      LISREF(2)=IPT2
      GOTO 45
  46  CONTINUE
      IDS=IPT1.ICOLOR(IPT1.ICOLOR(/1))
      LP2=IPT3.NUM(IPT3.NUM(/1),IPT3.NUM(/2))
      LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))
      CALL GENERL(LP1,LP2,IPT8,IPT2,IDS)
      IF (IERR.NE.0) RETURN
      SEGDES IPT2
      LISREF(2)=IPT2
  45  CONTINUE
      SEGSUP IPT3
C    CREATION DES POINTS  (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES
C     EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS)
      IADR=nbpts
      IF (NCOUCH.EQ.1) GOTO 60
      NBPTS=IADR+IPT1.NUM(/2)*(NCOUCH-1)*2
      SEGADJ MCOORD
      DO 61 I=2,NCOUCH
      IF (IPT1.NUM(/2).EQ.1) GOTO 60
      IREFI=(IDIM+1)*(IPT8.NUM(1,I)-1)
      XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1)
      YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2)
      ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3)
      DO 62 J=1,IPT1.NUM(/2)
      DO 620 K=1,2
      IF (K.EQ.1.AND.J.EQ.1) GOTO 620
      IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 620
      IF (ICPR(K,J).NE.0) GOTO 620
      IREF=(IDIM+1)*IPT1.NUM((K-1)*INCR+1,J)-IDIM
      XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF)+XVI
      XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+1)+YVI
      IF (IDIM.NE.2) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+2)+ZVI
      XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM)
      IADR=IADR+1
  620 CONTINUE
  62  CONTINUE
  61  CONTINUE
  60  CONTINUE
      NBPTS=IADR
      SEGADJ MCOORD
      IF (KSURF(ILCOUR).EQ.8) GOTO 101
      IF (KSURF(ILCOUR).NE.4) GOTO 102
      NBNN=3
      NBELEM=2*NUM(/2)
      NBREF=4
      NBSOUS=0
      SEGINI IPT1
      IPT1.ITYPEL=4
      IPT1.LISREF(1)=LISREF(1)
      IPT1.LISREF(2)=LISREF(2)
      IPT1.LISREF(3)=LISREF(3)
      IPT1.LISREF(4)=LISREF(4)
      DO 103 I=1,NUM(/2),2
      J=2*I-1
      IPT1.NUM(1,J)=NUM(1,I)
      IPT1.NUM(2,J)=NUM(2,I)
      IPT1.NUM(3,J)=NUM(3,I)
      IPT1.ICOLOR(J)=ICOLOR(I)
      J=J+1
      IPT1.NUM(1,J)=NUM(1,I)
      IPT1.NUM(2,J)=NUM(3,I)
      IPT1.NUM(3,J)=NUM(4,I)
      IPT1.ICOLOR(J)=ICOLOR(I)
      J=J+1
      IF (J.GT.IPT1.NUM(/2)) GOTO 103
      IPT1.NUM(1,J)=NUM(1,I+1)
      IPT1.NUM(2,J)=NUM(2,I+1)
      IPT1.NUM(3,J)=NUM(4,I+1)
      IPT1.ICOLOR(J)=ICOLOR(I+1)
      J=J+1
      IPT1.NUM(1,J)=NUM(2,I+1)
      IPT1.NUM(2,J)=NUM(3,I+1)
      IPT1.NUM(3,J)=NUM(4,I+1)
      IPT1.ICOLOR(J)=ICOLOR(I+1)
 103  CONTINUE
      SEGSUP MELEME
      MELEME=IPT1
      GOTO 101
 102  CONTINUE
      IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104
C    ON FAIT DES QUA8 OU DES TRI6
      NBNN=8
      NBELEM=NUM(/2)
      NBREF=4
      NBSOUS=0
      SEGINI IPT5
      IPT5.ITYPEL=10
      IPT1=LISREF(1)
      IPT2=LISREF(2)
      IPT3=LISREF(3)
      IPT4=LISREF(4)
      IPT5.LISREF(1)=IPT1
      IPT5.LISREF(2)=IPT2
      IPT5.LISREF(3)=IPT3
      IPT5.LISREF(4)=IPT4
      SEGACT IPT1,IPT2,IPT3,IPT4
      DO 105 J=1,NUM(/1)
      JJ=2*J-1
      DO 1050 I=1,NBELEM
      IPT5.NUM(JJ,I)=NUM(J,I)
 1050 CONTINUE
 105  CONTINUE
      DO 135 I=1,NBELEM
       IPT5.ICOLOR(I)=ICOLOR(I)
 135   CONTINUE
      NLIG=IPT1.NUM(/2)
      DO 106 I=1,NLIG
      IPT5.NUM(2,I)=IPT1.NUM(2,I)
      IPT5.NUM(6,NBELEM+1-I)=IPT3.NUM(2,I)
 106  CONTINUE
      NBPTA=nbpts
      NBPTS=NBPTA+NCOUCH*(NLIG+NLIG*2)
      SEGADJ MCOORD
      DO 107 I=1,NCOUCH
      IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I)
      IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I)
C  ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS)
C  CREATION DES NOEUDS
      IF (I.EQ.NCOUCH) GOTO 108
      IREFI=(IDIM+1)*(IPT8.NUM(IPT8.NUM(/1),I)-1)
      XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1)
      YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2)
      ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3)
      DO 109 J=1,NLIG
      IREF=(IDIM+1)*(IPT1.NUM(2,J)-1)
      XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI
      XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI
      IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI
      XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1)
      IADR=IADR+1
C  ON MET LE NOEUD DANS LES ELEMENTS
      IPT5.NUM(6,(I-1)*NLIG+J)=IADR
      IPT5.NUM(2,I*NLIG+J)=IADR
 109  CONTINUE
 108  CONTINUE
      IF (NLIG.EQ.1) GOTO 113
C  ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE
C  CREATION DES NOEUDS
      IREFI=(IDIM+1)*(IPT8.NUM(2,I)-1)
      XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1)
      YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2)
      ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3)
      DO 115 J=1,NLIG
      DO 1150 K=1,2
      IF (K.EQ.1.AND.J.EQ.1) GOTO 1150
      IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 1150
      IF (ICPR(K,J).NE.0) GOTO 116
      IREF=(IPT1.NUM(2*K-1,J)-1)*(IDIM+1)
      XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI
      XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI
      IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI
      XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1)
      IADR=IADR+1
 116  CONTINUE
C  NOEUDS DES ELEM
      IF (ICPR(K,J).NE.0) GOTO 119
      IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR
      GOTO 1150
 119  CONTINUE
      IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR(K,J)-1,2)),
     # (ICPR(K,J)+1)/2+(I-1)*NLIG)
 1150 CONTINUE
 115  CONTINUE
 113  CONTINUE
 107  CONTINUE
      NBPTS=IADR
      SEGADJ MCOORD
      SEGSUP MELEME
      MELEME=IPT5
      SEGDES IPT1,IPT2,IPT3,IPT4
      IF (KSURF(ILCOUR).NE.6) GOTO 101
C  ON FAIT DES TRI6
      NBNN=6
      NBELEM=2*NUM(/2)
      NBREF=4
      NBSOUS=0
      SEGINI IPT1
      IPT1.ITYPEL=6
      IPT1.LISREF(1)=LISREF(1)
      IPT1.LISREF(2)=LISREF(2)
      IPT1.LISREF(3)=LISREF(3)
      IPT1.LISREF(4)=LISREF(4)
      IALT=1
      NBPTS=nbpts+NCOUCH*NLIG
      SEGADJ MCOORD
      DO 120 I=1,NCOUCH
      IREFI=(IDIM+1)*(IPT8.NUM(2,I)-1)
      XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1)
      YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2)
      ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3)
      DO 1200 J=1,NLIG
      INU=(I-1)*NLIG+J
      IALT=3-IALT
C  CREATION DU POINT SUPPLEMENTAIRE
      IREF=(NUM(2,J)-1)*(IDIM+1)
      XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI
      XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI
      IF (IDIM.EQ.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI
      XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1)
      IADR=IADR+1
      ITR1=2*INU-1
      ITR2=2*INU
      GOTO (124,125),IALT
C  CREATION DES TRIANGLES
 124  IPT1.NUM(1,ITR1)=NUM(1,INU)
      IPT1.NUM(2,ITR1)=NUM(2,INU)
      IPT1.NUM(3,ITR1)=NUM(3,INU)
      IPT1.NUM(5,ITR1)=NUM(7,INU)
      IPT1.NUM(6,ITR1)=NUM(8,INU)
      IPT1.NUM(4,ITR1)=IADR
      IPT1.NUM(1,ITR2)=NUM(3,INU)
      IPT1.NUM(2,ITR2)=NUM(4,INU)
      IPT1.NUM(3,ITR2)=NUM(5,INU)
      IPT1.NUM(4,ITR2)=NUM(6,INU)
      IPT1.NUM(5,ITR2)=NUM(7,INU)
      IPT1.NUM(6,ITR2)=IADR
      IPT1.ICOLOR(ITR1)=ICOLOR(INU)
      IPT1.ICOLOR(ITR2)=ICOLOR(INU)
      GOTO 126
 125  IPT1.NUM(1,ITR1)=NUM(1,INU)
      IPT1.NUM(2,ITR1)=NUM(2,INU)
      IPT1.NUM(3,ITR1)=NUM(3,INU)
      IPT1.NUM(4,ITR1)=NUM(4,INU)
      IPT1.NUM(5,ITR1)=NUM(5,INU)
      IPT1.NUM(6,ITR1)=IADR
      IPT1.NUM(1,ITR2)=NUM(5,INU)
      IPT1.NUM(2,ITR2)=NUM(6,INU)
      IPT1.NUM(3,ITR2)=NUM(7,INU)
      IPT1.NUM(4,ITR2)=NUM(8,INU)
      IPT1.NUM(5,ITR2)=NUM(1,INU)
      IPT1.NUM(6,ITR2)=IADR
      IPT1.ICOLOR(ITR1)=ICOLOR(INU)
      IPT1.ICOLOR(ITR2)=ICOLOR(INU)
      GOTO 126
 126  CONTINUE
 1200 CONTINUE
 120  CONTINUE
      SEGSUP MELEME
      MELEME=IPT1
      GOTO 101
 104  CONTINUE
 101  CONTINUE
      SEGSUP ICPR
C  S'IL Y A LIEU EXAMINER LA DEGENERESCENCE  (ROTATION)
      SEGDES IPT1
      IF (IFUSE.EQ.0) GOTO 63
      IPT5=IFUSE
      SEGACT IPT5,MELEME
      ltelq=.false.
      CALL FUSE(IPT5,MELEME,IRET,ltelq)
      SEGDES IPT5
      SEGSUP MELEME
      MELEME=IRET
  63  CONTINUE
      CALL ECROBJ('MAILLAGE',MELEME)
      SEGDES MELEME,IPT8
      RETURN
      END