C VOLUMG    SOURCE    PV        20/03/24    21:23:15     10554          
C    FABRICATION DE CUBES ET PRISMES PAR TRANSLATION D'UNE SURFACE
C    SELON UNE GENERATRICE    (NOVEMBRE 1985)
      SUBROUTINE VOLUMG
      IMPLICIT INTEGER(I-N)
      IMPLICIT real*8 (a-h,o-z)
-INC SMELEME

-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC CCGEOME
      logical ltelq
      SEGMENT ICPR(NBNNEL,NBELEC)
      IF (ILCOUR.LT.14.OR.ILCOUR.GT.17) CALL ERREUR(16)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
      CALL LIROBJ('MAILLAGE',IPT9,1,IRETOU)
       IF(IERR.NE.0) RETURN
C  IPT9 EST LA GENERATRICE VERIFICATION DU TYPE
      SEGACT IPT9
      IF (IPT9.ITYPEL.NE.KDEGRE(ILCOUR)) THEN
      CALL ERREUR(16)
      SEGDES IPT9
      RETURN
      ENDIF
      ISVOL1=0
      SEGACT IPT1
C  SI IPT1 VOLUME IL FAUT EN EXTRAIRE LA FACE 2
 3100 IF (IPT1.LISOUS(/1).EQ.0) GOTO 1000
      IF (IPT1.LISOUS(/1).NE.2) GOTO 3102
      IDEUX=2
      IPT3=IPT1.LISOUS(1)
      IPT4=IPT1.LISOUS(2)
      SEGACT IPT3,IPT4
      IP=IPT3.ITYPEL*IPT4.ITYPEL
      IF (IP.NE.32.AND.IP.NE.60) GOTO 3101
      IS=IPT3.ITYPEL+IPT4.ITYPEL
      IF (IS.NE.12.AND.IS.NE.16) GOTO 3101
      INCR=1
      IF (IS.EQ.16) INCR=2
      NBNNEL=4*INCR
C  EN FAIT ON CREE UN SEGMENT QUI CONTIENT LES CUBES ET LES TRIANGLES
C  0 DANS LA DERNIERE POSITION DU TRIANGLE
      NBSOUS=0
      NBREF=0
      NBNN=NBNNEL
      NBELE3=IPT3.NUM(/2)
      IF (IPT3.ITYPEL.LE.6) NBTRI=NBELE3
      IF (IPT3.ITYPEL.GE.8) NBQUA=NBELE3
      NBELE4=IPT4.NUM(/2)
      IF (IPT4.ITYPEL.LE.6) NBTRI=NBELE4
      IF (IPT4.ITYPEL.GE.8) NBQUA=NBELE4
      NBELEM=NBELE3+NBELE4
      SEGINI MELEME
      DO 1100 I=1,NBNN
      DO 1100 J=1,NBELEM
      NUM(I,J)=0
 1100 CONTINUE
      DO 1101 J=1,NBELE3
      ICOLOR(J)=IPT3.ICOLOR(J)
      DO 1101 I=1,IPT3.NUM(/1)
      NUM(I,J)=IPT3.NUM(I,J)
 1101 CONTINUE
      DO 1102 J=1,NBELE4
      ICOLOR(J+NBELE3)=IPT4.ICOLOR(J)
      DO 1102 I=1,IPT4.NUM(/1)
      NUM(I,J+NBELE3)=IPT4.NUM(I,J)
 1102 CONTINUE
      SEGDES IPT3,IPT4
      GOTO 1001
C  RECHERCHE DE LA PREMIERE FACE DE IPT1
 3101 SEGDES IPT3,IPT4
 3102 IF (IPT1.LISREF(/1).LT.2) CALL ERREUR(16)
      IF (IERR.NE.0) RETURN
      ISVOL1=IPT1
      IAUX=IPT1.LISREF(2)
      SEGDES IPT1
      IPT1=IAUX
      SEGACT IPT1
      GOTO 3100
 1000 CONTINUE
      IDEUX=1
      NBNNEL=IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      IF  (IPT1.ITYPEL.NE.8.AND.IPT1.ITYPEL.NE.10.AND.IPT1.ITYPEL.NE.4
     #.AND.IPT1.ITYPEL.NE.6)  GOTO 3102
      INCR=1
      IF (KDEGRE(IPT1.ITYPEL).EQ.3) INCR=2
      MELEME=IPT1
 1001 SEGACT MCOORD*mod
      IPT3=MELEME
      NCOUCH=IPT9.NUM(/2)
      NX=NCOUCH-1
      IF (IIMPI.EQ.1) WRITE(IOIMP,9000) NCOUCH
 9000 FORMAT(/,' COUCHES ',I6)
C  ON FAIT TOUJOURS COMME SI IL N'Y AVAIT QU'UN TYPE D'ELEMENT
      NBSOUS=0
C  MODIF POUR CONSTRUIRE TOUJOURS LE POURTOUR
      NBREF=3
      IF (IPT1.LISREF(/1).NE.0) NBREF=3
      NBNN=2*NBNNEL+(INCR-1)*(NBNNEL/2)
      NBNNV=NBNN
      NBASE=NBELEM
      NBELEM=NBELEM*NCOUCH
      SEGINI IPT7
      IF (NBNNV.EQ.6 ) IPT7.ITYPEL=16
      IF (NBNNV.EQ.15) IPT7.ITYPEL=17
      IF (NBNNV.EQ.8 ) IPT7.ITYPEL=14
      IF (NBNNV.EQ.20) IPT7.ITYPEL=15
      IPT7.LISREF(1)=IPT1
      DO 1040 I=1,NBNN
      DO 1040 J=1,NBELEM
      IPT7.NUM(I,J)=0
 1040 CONTINUE
      IOPTG=1
C  CALCUL DU VECTEUR TRANSLATION TOTALE
      IREFB=(IPT9.NUM(1,1)-1)*4
      IREFH=(IPT9.NUM(IPT9.NUM(/1),NCOUCH)-1)*4
      NBPTS=nbpts+1
      SEGADJ MCOORD
      XCOOR((NBPTS-1)*(IDIM+1)+1)=XCOOR(IREFH+1)-XCOOR(IREFB+1)
      XCOOR((NBPTS-1)*(IDIM+1)+2)=XCOOR(IREFH+2)-XCOOR(IREFB+2)
      XCOOR((NBPTS-1)*(IDIM+1)+3)=XCOOR(IREFH+3)-XCOOR(IREFB+3)
      XCOOR(NBPTS*(IDIM+1))=XCOOR(IREFH+4)
      IVEC=NBPTS
      IDEB=IVEC+1
      CALL ECROBJ('POINT ',IVEC)
      CALL ECROBJ('MAILLAGE',IPT1)
      CALL PROPER(IOPTG)
      CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
      IF (IERR.NE.0) RETURN
C  IPT3 ET IPT4 ONT ETE DESCENDU DANS L'OPERATION AINSI QUE MCOORD/REFPO
  16  SEGACT IPT1,IPT2,MCOORD
      IPT4=IPT2
      IF (IDEUX.EQ.1) GOTO 15
      IPT5=IPT2.LISOUS(1)
      IPT6=IPT2.LISOUS(2)
      SEGACT IPT5,IPT6
C  ON FAIT COMME POUR LE BAS
      NBSOUS=0
      NBREF=0
      NBNN=4*INCR
      NBNNR=NBNN
      NBELEM=NBELE3+NBELE4
      SEGINI MELEME
      DO 1110 J=1,NBELEM
      DO 1110 I=1,NBNN
      NUM(I,J)=0
 1110 CONTINUE
      DO 1111 J=1,NBELE3
      ICOLOR(J)=IPT5.ICOLOR(J)
      DO 1111 I=1,IPT5.NUM(/1)
      NUM(I,J)=IPT5.NUM(I,J)
 1111 CONTINUE
      DO 1112 J=1,NBELE4
      ICOLOR(J+NBELE3)=IPT6.ICOLOR(J)
      DO 1112 I=1,IPT6.NUM(/1)
      NUM(I,J+NBELE3)=IPT6.NUM(I,J)
 1112 CONTINUE
      SEGDES IPT5,IPT6,IPT2
      IPT4=MELEME
  15  IPT7.LISREF(2)=IPT2
C  CONSTRUCTION DE LA TABLE DES POINTS EFFECTIFS
      NBELEC=IPT3.NUM(/2)
      SEGINI ICPR
      DO 12 I=1,NBNNEL
      DO 12 J=1,NBELEC
  12  ICPR(I,J)=0
      DO 13 J=1,NBELEC
      DO 13 I=1,NBNNEL
      IR=IPT3.NUM(I,J)
      IR2=IPT4.NUM(I,J)
      IF (IR.EQ.0) GOTO 1120
      IF (IR2.EQ.0) GOTO 8833
      I1=IR
      I1R2=IR2
      IF (J.EQ.1) GOTO 13
      JM1=J-1
      DO 14 JJ=1,JM1
      DO 14 II=1,NBNNEL
      IR=IPT3.NUM(II,JJ)
      IR2=IPT4.NUM(II,JJ)
      IF (IR.EQ.0) GOTO 14
      IF (IR.NE.I1) GOTO 8834
      IF (IR2.NE.I1R2) GOTO 8833
      ICPR(I,J)=II+(JJ-1)*8
      GOTO 13
 8834 IF (IR2.EQ.I1R2) GOTO 8833
  14  CONTINUE
      GOTO 13
 1120 ICPR(I,J)=-1
      IF (IR2.NE.0) GOTO 8833
  13  CONTINUE
      GOTO 8835
 8833 CONTINUE
C  LES TOPOLOGIES SONT DIFFERENTES
      SEGSUP ICPR
      CALL ERREUR(21)
      RETURN
 8835 CONTINUE
C  ON FABRIQUE POUR LE MOMENT DES CUBES A 8 OU 20 NOEUDS ET DES PRISMES
C  A 6 OU 15 NOEUDS
C  D'ABORD LES POINTS DU BAS
      DO 20 I=1,NBELEC
       IPT7.ICOLOR(I)=IPT3.ICOLOR(I)
      DO 20 J=1,NBNNEL
      IR=IPT3.NUM(J,I)
      IF (IR.EQ.0) GOTO 20
      IPT7.NUM(J,I)=IR
  20  CONTINUE
      IBASE=nbpts
C  ON FABRIQUE ENSUITE LES COUCHES
C  ON AFFECTE SEULEMENT LES NUMEROS DE NOEUDS
      IDIF=(INCR-1)*(NBNNEL/2)
      NX=NCOUCH-1
      DO 21 ICOUCH=1,NCOUCH
      IF (ICOUCH.EQ.NCOUCH) GOTO 21
      JBASE=(ICOUCH-1)*NBELEC
      IF (INCR.EQ.1) GOTO 2000
C  ON FABRIQUE D'ABORD LA COUCHE INTERMEDIAIRE
      DO 2001 J=1,NBELEC
      IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
      DO 2001 IA=1,(NBNNEL/2)
      I=2*IA-1
      IF (ICPR(I,J).EQ.-1) GOTO 2001
      IF (ICPR(I,J).NE.0) GOTO 2002
      IBASE=IBASE+1
      IPT7.NUM(IA+NBNNEL,J+JBASE)=IBASE
      GOTO 2001
 2002 IAUX=ICPR(I,J)
      JJ=(IAUX-1)/8+1
      II=IAUX-8*JJ+8
      IIA=(II+1)/2
      IPT7.NUM(IA+NBNNEL,J+JBASE)=IPT7.NUM(IIA+NBNNEL,JJ+JBASE)
 2001 CONTINUE
 2000 CONTINUE
      DO 22 J=1,NBELEC
      IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
      DO 22 I=1,NBNNEL
      IF (ICPR(I,J).EQ.-1) GOTO 22
      IF (ICPR(I,J).NE.0) GOTO 23
      IBASE=IBASE+1
      IPT7.NUM(I,J+JBASE+NBELEC)=IBASE
      IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IBASE
      GOTO 22
  23  IAUX=ICPR(I,J)
      JJ=(IAUX-1)/8+1
      II=IAUX-8*JJ+8
      IPT7.NUM(I,J+JBASE+NBELEC)=IPT7.NUM(II,JJ+JBASE+NBELEC)
      IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IPT7.NUM(II+NBNNEL+IDIF,JJ+JBASE)
  22  CONTINUE
  21  CONTINUE
  25  CONTINUE
C  ON FAIT LES POINTS DU HAUT ET EVENTUELLEMENT LA COUCHE INTERMEDIAIRE
C  PRECEDENTE
      JBASE=NBELEC*NX
      IF (INCR.EQ.1) GOTO 2003
      DO 2004 J=1,NBELEC
      IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
      DO 2004 IA=1,(NBNNEL/2)
      I=2*IA-1
      IF (ICPR(I,J).EQ.-1) GOTO 2004
      IF (ICPR(I,J).NE.0) GOTO 2005
      IBASE=IBASE+1
      IPT7.NUM(IA+NBNNEL,J+JBASE)=IBASE
      GOTO 2004
 2005 IAUX=ICPR(I,J)
      JJ=(IAUX-1)/8+1
      II=IAUX-8*JJ+8
      IIA=(II+1)/2
      IPT7.NUM(IA+NBNNEL,J+JBASE)=IPT7.NUM(IIA+NBNNEL,JJ+JBASE)
 2004 CONTINUE
 2003 CONTINUE
      DO 30 J=1,NBELEC
      IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
      DO 30 I=1,NBNNEL
      IF (ICPR(I,J).EQ.-1) GOTO 30
      IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IPT4.NUM(I,J)
  30  CONTINUE
C  CREATION DES POINTS
      IADR=nbpts
      NBPTS=IADR+NCOUCH*INCR*NBELEC*NBNNEL
      SEGADJ MCOORD
      DO 61 ICOUCH=1,NCOUCH
      DO 610 IC=1,INCR
      IREFC=(IPT9.NUM(IC+1,ICOUCH)-1)*4
      XPLUS=XCOOR(IREFC+1)-XCOOR(IREFB+1)
      YPLUS=XCOOR(IREFC+2)-XCOOR(IREFB+2)
      ZPLUS=XCOOR(IREFC+3)-XCOOR(IREFB+3)
      TPLUS=XCOOR(IREFC+4)
      IC1=INCR+1-IC
      IF (ICOUCH.EQ.NCOUCH.AND.IC.EQ.INCR) GOTO 610
      DO 620 J=1,NBELEC
      DO 62 I=1,NBNNEL,IC1
      IF (ICPR(I,J).NE.0) GOTO 62
      IREF=4*IPT3.NUM(I,J)-4
      XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XPLUS
      XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YPLUS
      XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZPLUS
      XCOOR((IADR+1)*(IDIM+1))=TPLUS
      IADR=IADR+1
  62  CONTINUE
 620  CONTINUE
 610  CONTINUE
  61  CONTINUE
      NBPTS=IADR
      SEGADJ MCOORD
C  C'EST FINI
C  IL RESTE DANS LE CAS OU ON A DES CUBES ET DES PRISMES A LES SEPARER
C  ET A SUPPRIMER LES SEGMENTS SUPPLEMENTAIRES DE TRAVAIL
C  D'ABORD FAIRE LE POURTOUR A PARTIR DU CONTOUR
      IF (IPT7.LISREF(/1).EQ.2) GOTO 3000
      CALL ECROBJ('MAILLAGE',IPT1)
      CALL PRCONT
      CALL LIROBJ('MAILLAGE',IPT5,1,IRETOU)
      IF (IERR.NE.0) GOTO 3000
C  IPT5 LE CONTOUR  IPT6 SERA LE POURTOUR
      SEGACT IPT5
      NBASE=IPT5.NUM(/2)
      NBNN=INCR*4
      NBELEM=NBASE*NCOUCH
      NBSOUS=0
      NBREF=0
      SEGINI IPT6
      IPT6.ITYPEL=6+2*INCR
      SEGACT IPT3
      DO 3001 IEL=1,NBASE
      DO 3001 IP=1,INCR+1
      INP=IPT5.NUM(IP,IEL)
      DO 3003 IELS=1,NBELEC
      DO 3003 IPS=1,NBNNEL
      IPSP=IPT3.NUM(IPS,IELS)
      IF (IPSP.EQ.0) GOTO 3003
      IF (IPSP.EQ.INP) GOTO 3002
 3003 CONTINUE
      GOTO 3000
 3002 CONTINUE
      DO 3004 IC=1,NCOUCH
      IBASE=(IC-1)*NBASE
      JBASE=(IC-1)*NBELEC
C  PTS DU BAS
      IPT6.NUM(IP,IEL+IBASE)=IPT7.NUM(IPS,IELS+JBASE)
C  PTS DU HAUT
      IPT6.NUM(NBNN+2-INCR-IP,IEL+IBASE)=
     #                 IPT7.NUM(IPS+NBNNEL+IDIF,IELS+JBASE)
C  EVENTUELLEMENT PTS MILIEUX
      IF (INCR.EQ.1.OR.IP.EQ.2) GOTO 3004
      IPT6.NUM(10-2*IP,IEL+IBASE)=IPT7.NUM((IPS+1)/2+NBNNEL,IELS+JBASE)
 3004 CONTINUE
 3001 CONTINUE
      DO 3005 I=1,NCOUCH
       DO 3005 J=1,NBASE
              IPT6.ICOLOR(J+(I-1)*NBASE)=IPT5.ICOLOR(J)
 3005 CONTINUE
      SEGDES IPT5,IPT6
      IPT7.LISREF(3)=IPT6
 3000 CONTINUE
      IF (IDEUX.EQ.1) GOTO 1500
      SEGSUP IPT3,IPT4
      MELEME=IPT7
      NBSOUS=2
      NBREF=LISREF(/1)
      NBNN=0
      NBELEM=0
      SEGINI IPT7
      IPT7.LISREF(1)=LISREF(1)
      IPT7.LISREF(2)=LISREF(2)
      IF (NBREF.EQ.3) IPT7.LISREF(3)=LISREF(3)
      NBSOUS=0
      NBREF=0
      NBNN=6
      IF (INCR.EQ.2) NBNN=15
      NBELEM=NBTRI*NCOUCH
      SEGINI IPT3
      IPT3.ITYPEL=16
      IF (INCR.EQ.2) IPT3.ITYPEL=17
      IPT7.LISOUS(1)=IPT3
      NBNN=8
      IF (INCR.EQ.2) NBNN=20
      NBELEM=NBQUA*NCOUCH
      SEGINI IPT4
      IPT4.ITYPEL=14
      IF (INCR.EQ.2) IPT4.ITYPEL=15
      IPT7.LISOUS(2)=IPT4
      IT=0
      IQ=0
      DO 1501 J=1,NUM(/2)
      IF (NUM(NBNNV,J).EQ.0) GOTO 1502
C  C'EST UN CUBE
      IQ=IQ+1
      IPT4.ICOLOR(IQ)=ICOLOR(J)
      DO 1503 K=1,IPT4.NUM(/1)
      IPT4.NUM(K,IQ)=NUM(K,J)
 1503 CONTINUE
      GOTO 1501
 1502 IT=IT+1
      IPT3.ICOLOR(IT)=ICOLOR(J)
C  C'EST UN PRISME
      IF (INCR.EQ.2) GOTO 2020
      IPT3.NUM(1,IT)=NUM(1,J)
      IPT3.NUM(2,IT)=NUM(2,J)
      IPT3.NUM(3,IT)=NUM(3,J)
      IPT3.NUM(4,IT)=NUM(NBNNEL+1,J)
      IPT3.NUM(5,IT)=NUM(NBNNEL+2,J)
      IPT3.NUM(6,IT)=NUM(NBNNEL+3,J)
      GOTO 1501
 2020 CONTINUE
      DO 2021 L=1,6
      IPT3.NUM(L,IT)=NUM(L,J)
 2021 CONTINUE
      IPT3.NUM(7,IT)=NUM(NBNNEL+1,J)
      IPT3.NUM(8,IT)=NUM(NBNNEL+2,J)
      IPT3.NUM(9,IT)=NUM(NBNNEL+3,J)
      DO 2022 L=1,6
      IPT3.NUM(L+9,IT)=NUM(NBNNEL+IDIF+L,J)
 2022 CONTINUE
 1501 CONTINUE
      SEGDES IPT3,IPT4
      SEGSUP MELEME
 1500 SEGDES IPT1,IPT2
      SEGSUP ICPR
      IF (ISVOL1.EQ.0) GOTO 3200
      IPT8=ISVOL1
      SEGACT IPT8
      ltelq=.false.
      CALL FUSE(IPT8,IPT7,IRET,ltelq)
      SEGDES IPT7,IPT8
      IPT7=IRET
 3200 CONTINUE
      SEGDES IPT7,IPT9
      CALL ECROBJ('MAILLAGE',IPT7)
      RETURN
      END