C GENJO3    SOURCE    BP208322  16/11/18    21:17:21     9177           
      SUBROUTINE GENJO3
C--------------------------------------------------------------------
C
C     MAIL1 = GENJ MAIL2 FLOT1;
C
C     MAIL1 : MAILLAGE DE JOT3 OU JOI4
C     MAIL2 : MAILLAGE DE CUB8, PRI6, PYR5 ET/OU TET4
C     FLOT1 : TOLERANCE
C
C     Pierre Pegon/JRC Ispra
C--------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C

-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
-INC CCGEOME
-INC SMLENTI
-INC SMLREEL
C
      SEGMENT,JO4GEN
        INTEGER P4(4,NCOT4)
        INTEGER SZ4(NCOT4), NELM4(NCOT4)
        INTEGER FLA4(NCOT4)
      ENDSEGMENT
      POINTEUR JO4GE1.JO4GEN
C
      SEGMENT,JO3GEN
        INTEGER P3(3,NCOT3)
        INTEGER SZ3(NCOT3), NELM3(NCOT3)
        INTEGER FLA3(NCOT3)
      ENDSEGMENT
      POINTEUR JO3GE1.JO3GEN
C
      LOGICAL GENTST
      DIMENSION FAC1(3,4),FAC2(3,4),BAR1(3),BAR2(3)
C
      IF(IIMPI.EQ.1790)THEN
        WRITE(IOIMP,*)'GENJO3: On entre dans la subroutine'
      ENDIF
C
      CALL LIROBJ('MAILLAGE',IPT1,1,IRET)
      IF(IERR.NE.0) RETURN
      CALL LIRREE(XTOL,1,IRET)
      IF(IERR.NE.0) RETURN
      XTOL2=XTOL**2
C
C     VERIFICATION DE LA DIMENSION
C
      IF (IDIM.NE.3)THEN
        WRITE(IOIMP,*)'GENJO3: on n"est pas en 3D'
        RETURN
      ENDIF
C
C     VERIFICATION DES TYPES D'ELEMENT (POUR LE MOMENT CUB8, PRI6,
C                                                      PYR5 ET TET4)
C     ET CALCUL DU NOMBRE DE COTES
C
      NCOT4=0
      NCOT3=0
      SEGACT,IPT1
      NBSOUS=IPT1.LISOUS(/1)
      DO IE1=1,MAX(NBSOUS,1)
        IF(NBSOUS.EQ.0)THEN
          MELEME=IPT1
        ELSE
          MELEME=IPT1.LISOUS(IE1)
          SEGACT,MELEME
        ENDIF
        ILC=ITYPEL
        IF(ILC.NE.14.AND.ILC.NE.16.AND.ILC.NE.23.AND.ILC.NE.25)THEN
          WRITE(IOIMP,*)'GENJO3: type d"element incorrect'
          SEGDES,MELEME*NOMOD
          RETURN
        ELSE
          NBELEM=ICOLOR(/1)
          IF(ILC.EQ.23)THEN
            NCOT3=NCOT3+4*NBELEM
          ELSEIF(ILC.EQ.14)THEN
            NCOT4=NCOT4+6*NBELEM
          ELSEIF(ILC.EQ.16)THEN
            NCOT3=NCOT3+2*NBELEM
            NCOT4=NCOT4+3*NBELEM
          ELSEIF(ILC.EQ.25)THEN
            NCOT3=NCOT3+4*NBELEM
            NCOT4=NCOT4+  NBELEM
          ENDIF
        ENDIF
        SEGDES,MELEME*NOMOD
      ENDDO
C
      IF(IIMPI.EQ.1790)THEN
        WRITE(IOIMP,*)'GENJO3: fin verification'
      ENDIF
C
C     REMPLISSAGE DU SEGMENT DES COTES
C
      SEGACT,IPT1
      SEGINI,JO3GEN,JO4GEN
      IJOI3=0
      IJOI4=0
      DO IE1=1,MAX(NBSOUS,1)
        IF(NBSOUS.EQ.0)THEN
          MELEME=IPT1
        ELSE
          MELEME=IPT1.LISOUS(IE1)
          SEGACT,MELEME
        ENDIF
        ILC=ITYPEL
        NBELEM=ICOLOR(/1)
        DO IE2=1,NBELEM
          IF(ILC.EQ.23)THEN
            CALL GF2323(P3,SZ3,NELM3,FLA3, IJOI3,3,
     >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
          ELSEIF(ILC.EQ.14)THEN
            CALL GF1424(P4,SZ4,NELM4,FLA4, IJOI4,4,
     >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
          ELSEIF(ILC.EQ.16)THEN
            CALL GF1623(P3,SZ3,NELM3,FLA3, IJOI3,3,
     >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
            CALL GF1624(P4,SZ4,NELM4,FLA4, IJOI4,4,
     >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
          ELSEIF(ILC.EQ.25)THEN
            CALL GF2523(P3,SZ3,NELM3,FLA3, IJOI3,3,
     >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
            CALL GF2524(P4,SZ4,NELM4,FLA4, IJOI4,4,
     >                  NUM(1,IE2),MIN(NBSOUS,IE1),IE2)
          ENDIF
        ENDDO
      ENDDO
C
      IF(IIMPI.EQ.1790)THEN
        WRITE(IOIMP,*)'GENJO3: fin remplissage'
      ENDIF
C
C     ELIMINATION DES DOUBLONS A NOEUDS IDENTIQUES
C
      IF(NCOT3.GT.0)THEN
        JG=NCOT3
        SEGINI,MLENTI,MLENT1
        DO IE1=1,NCOT3
          LECT(IE1)=IE1
          MLENT1.LECT(IE1)=FLA3(IE1)
        ENDDO
        CALL GENOR2(MLENT1.LECT,LECT,NCOT3)
        IF(IIMPI.EQ.1790)THEN
          WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
        ENDIF
        IFI=MLENT1.LECT(1)
        DO IE1=2,NCOT3
          IFF=MLENT1.LECT(IE1)
          IF(IFI.EQ.IFF)THEN
            JE1=LECT(IE1-1)
            IF(FLA3(JE1).NE.0)THEN
              DO IE2=IE1,NCOT3
                IFFF=MLENT1.LECT(IE2)
                IF(IFI.NE.IFFF)GOTO 30
                JE2=LECT(IE2)
                IF(FLA3(JE2).NE.0)THEN
                  IF(GENTST(P3(1,JE1),P3(1,JE2),3))THEN
                    FLA3(JE1)=0
                    FLA3(JE2)=0
                    GOTO 30
                  ENDIF
                ENDIF
              ENDDO
            ENDIF
          ENDIF
 30       IFI=IFF
        ENDDO
        SEGSUP,MLENTI,MLENT1
      ENDIF
C
      IF(NCOT4.GT.0)THEN
        JG=NCOT4
        SEGINI,MLENTI,MLENT1
        DO IE1=1,NCOT4
          LECT(IE1)=IE1
          MLENT1.LECT(IE1)=FLA4(IE1)
        ENDDO
        CALL GENOR2(MLENT1.LECT,LECT,NCOT4)
        IF(IIMPI.EQ.1790)THEN
          WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
        ENDIF
        IFI=MLENT1.LECT(1)
        DO IE1=2,NCOT4
          IFF=MLENT1.LECT(IE1)
          IF(IFI.EQ.IFF)THEN
            JE1=LECT(IE1-1)
            IF(FLA4(JE1).NE.0)THEN
              DO IE2=IE1,NCOT4
                IFFF=MLENT1.LECT(IE2)
                IF(IFI.NE.IFFF)GOTO 40
                JE2=LECT(IE2)
                IF(FLA4(JE2).NE.0)THEN
                  IF(GENTST(P4(1,JE1),P4(1,JE2),4))THEN
                    FLA4(JE1)=0
                    FLA4(JE2)=0
                    GOTO 40
                  ENDIF
                ENDIF
              ENDDO
            ENDIF
          ENDIF
 40       IFI=IFF
        ENDDO
        SEGSUP,MLENTI,MLENT1
      ENDIF
C
      IF(IIMPI.EQ.1790)THEN
        WRITE(IOIMP,*)'GENJO3: fin elimination des doublons'
      ENDIF
C
C     CONCATENATION DES LISTES
C
      IF (NCOT3.GT.0)THEN
        NNCOT3=NCOT3
        NCOT3=0
        DO IE1=1,NNCOT3
          IF(FLA3(IE1).NE.0)NCOT3=NCOT3+1
        ENDDO
        SEGINI,JO3GE1
        JE1=0
        DO IE1=1,NNCOT3
          IF(FLA3(IE1).NE.0)THEN
            JE1=JE1+1
            DO IE2=1,IDIM
              JO3GE1.P3(IE2,JE1)=P3(IE2,IE1)
            ENDDO
            JO3GE1.SZ3(JE1)=SZ3(IE1)
            JO3GE1.NELM3(JE1)=NELM3(IE1)
            JO3GE1.FLA3(JE1)=0
          ENDIF
        ENDDO
        SEGSUP,JO3GEN
        JO3GEN=JO3GE1
      ENDIF
C
      IF (NCOT4.GT.0)THEN
        NNCOT4=NCOT4
        NCOT4=0
        DO IE1=1,NNCOT4
          IF(FLA4(IE1).NE.0)NCOT4=NCOT4+1
        ENDDO
        SEGINI,JO4GE1
        JE1=0
        DO IE1=1,NNCOT4
          IF(FLA4(IE1).NE.0)THEN
            JE1=JE1+1
            DO IE2=1,4
              JO4GE1.P4(IE2,JE1)=P4(IE2,IE1)
            ENDDO
            JO4GE1.SZ4(JE1)=SZ4(IE1)
            JO4GE1.NELM4(JE1)=NELM4(IE1)
            JO4GE1.FLA4(JE1)=0
          ENDIF
        ENDDO
        SEGSUP,JO4GEN
        JO4GEN=JO4GE1
      ENDIF
C
      IF(IIMPI.EQ.1790)THEN
        WRITE(IOIMP,*)'GENJO3: fin concatenation'
      ENDIF
C
C     DETERMINATION DES SEGMENTS AVEC VIS-A-VIS
C
      IRET=0
      IF(NCOT3.GT.1)THEN
        JG=NCOT3
        SEGINI,MLENTI,MLREEL
        DO IE1=1,NCOT3
          LECT(IE1)=IE1
          DO IE2=1,IDIM
            BAR1(IE2)=0.D0
          ENDDO
          DO IE2=1,3
            IPR1=(IDIM+1)*(P3(IE2,IE1)-1)
            DO IE3=1,IDIM
              BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3)
            ENDDO
          ENDDO
          PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/3
        ENDDO
        CALL GENOS2(PROG,LECT,NCOT3)
        IF(IIMPI.EQ.1790)THEN
          WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
        ENDIF
        XFI=PROG(1)
        DO IE1=2,NCOT3
          XFF=PROG(IE1)
          IF(ABS(XFI-XFF).LT.XTOL)THEN
            JE1=LECT(IE1-1)
            IF(FLA3(JE1).EQ.0)THEN
              DO IE2=1,IDIM
                BAR1(IE2)=0.D0
              ENDDO
              DO IE2=1,3
                IPR1=(IDIM+1)*(P3(IE2,JE1)-1)
                DO IE3=1,IDIM
                  FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
                  BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2)
                ENDDO
              ENDDO
              DO IE2=IE1,NCOT3
                XFFF=PROG(IE2)
                IF(ABS(XFI-XFFF).GE.XTOL)GOTO 31
                JE2=LECT(IE2)
                IF(FLA3(JE2).EQ.0)THEN
                  DO IE3=1,IDIM
                    BAR2(IE3)=0.D0
                  ENDDO
                  DO IE3=1,3
                    IPR2=(IDIM+1)*(P3(IE3,JE2)-1)
                    DO IE4=1,IDIM
                      FAC2(IE4,IE3)=XCOOR(IPR2+IE4)
                      BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3)
                    ENDDO
                  ENDDO
                  DIS12=0.D0
                  DO IE3=1,IDIM
                    DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2
                  ENDDO
                  DIS12=DIS12/9
                  IF(DIS12.LT.XTOL2)THEN
                    FLA3(JE1)=JE2
                    FLA3(JE2)=JE1
                    CALL GENRD1(FAC1,FAC2,P3(1,JE2),3,XTOL2,IRET)
                    IF(IRET.NE.0)GOTO 9999
                    GOTO 31
                  ENDIF
                ENDIF
              ENDDO
            ENDIF
          ENDIF
 31       XFI=XFF
        ENDDO
        SEGSUP,MLREEL,MLENTI
      ENDIF
C
      IRET=0
      IF(NCOT4.GT.1)THEN
        JG=NCOT4
        SEGINI,MLENTI,MLREEL
        DO IE1=1,NCOT4
          LECT(IE1)=IE1
          DO IE2=1,IDIM
            BAR1(IE2)=0.D0
          ENDDO
          DO IE2=1,4
            IPR1=(IDIM+1)*(P4(IE2,IE1)-1)
            DO IE3=1,IDIM
              BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3)
            ENDDO
          ENDDO
          PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/4
        ENDDO
        CALL GENOS2(PROG,LECT,NCOT4)
        IF(IIMPI.EQ.1790)THEN
          WRITE(IOIMP,*)'GENJO3: fin de mise en ordre'
        ENDIF
        XFI=PROG(1)
        DO IE1=2,NCOT4
          XFF=PROG(IE1)
          IF(ABS(XFI-XFF).LT.XTOL)THEN
            JE1=LECT(IE1-1)
            IF(FLA4(JE1).EQ.0)THEN
              DO IE2=1,IDIM
                BAR1(IE2)=0.D0
              ENDDO
              DO IE2=1,4
                IPR1=(IDIM+1)*(P4(IE2,JE1)-1)
                DO IE3=1,IDIM
                  FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
                  BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2)
                ENDDO
              ENDDO
              DO IE2=IE1,NCOT4
                XFFF=PROG(IE2)
                IF(ABS(XFI-XFFF).GE.XTOL)GOTO 41
                JE2=LECT(IE2)
                IF(FLA4(JE2).EQ.0)THEN
                  DO IE3=1,IDIM
                    BAR2(IE3)=0.D0
                  ENDDO
                  DO IE3=1,4
                    IPR2=(IDIM+1)*(P4(IE3,JE2)-1)
                    DO IE4=1,IDIM
                      FAC2(IE4,IE3)=XCOOR(IPR2+IE4)
                      BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3)
                    ENDDO
                  ENDDO
                  DIS12=0.D0
                  DO IE3=1,IDIM
                    DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2
                  ENDDO
                  DIS12=DIS12/16
                  IF(DIS12.LT.XTOL2)THEN
                    FLA4(JE1)=JE2
                    FLA4(JE2)=JE1
                    CALL GENRD1(FAC1,FAC2,P4(1,JE2),4,XTOL2,IRET)
                    IF(IRET.NE.0)GOTO 9999
                    GOTO 41
                  ENDIF
                ENDIF
              ENDDO
            ENDIF
          ENDIF
 41       XFI=XFF
        ENDDO
        SEGSUP,MLREEL,MLENTI
      ENDIF
C
      IF(IIMPI.EQ.1790)THEN
        WRITE(IOIMP,*)'GENJO3: fin determination des vis-a-vis'
      ENDIF
C
C     CREATION DU/DES MAILLAGE(S) DE JOINT
C
      NBREF=0
      NBSOUS=0
      NBELEM=0
      DO IE1=1,NCOT3
        IF(FLA3(IE1).NE.0)NBELEM=NBELEM+1
      ENDDO
      NBELEM=NBELEM/2
      IF(NBELEM.NE.0)THEN
        NBNN=6
        SEGINI,MELEME
        ITYPEL=18
        DO IE1=1,NBELEM
          ICOLOR(IE1)=0
        ENDDO
        IPT3=MELEME
      ELSE
        IPT3=0
      ENDIF
C
      NBELEM=0
      DO IE1=1,NCOT4
        IF(FLA4(IE1).NE.0)NBELEM=NBELEM+1
      ENDDO
      NBELEM=NBELEM/2
      IF(NBELEM.NE.0)THEN
        NBNN=8
        SEGINI,MELEME
        ITYPEL=19
        DO IE1=1,NBELEM
          ICOLOR(IE1)=0
        ENDDO
        IPT4=MELEME
      ELSE
        IPT4=0
      ENDIF
C
      IF(IPT3*IPT4.EQ.0)THEN
        IF(IPT3.EQ.0.AND.IPT4.EQ.0)THEN
          WRITE(IOIMP,*)'GENJO3: aucun joint cree'
          GOTO 9999
        ELSEIF(IPT3.NE.0)THEN
          IPT2=IPT3
        ELSE
          IPT2=IPT4
        ENDIF
      ELSE
        NBSOUS=2
        NBNN=0
        NBELEM=0
        SEGINI,MELEME
        LISOUS(1)=IPT3
        LISOUS(2)=IPT4
        IPT2=MELEME
        SEGDES,MELEME
      ENDIF
C
      IF(IIMPI.EQ.1790)THEN
        WRITE(IOIMP,*)'GENJO3: fin creation maillage'
      ENDIF
C
C     GENERATION DU/DES MAILLAGE(S) DE JOINT
C
      IF(IPT3.NE.0)THEN
        IELEM=0
        DO IE1=1,NCOT3
          IF(FLA3(IE1).NE.0)THEN
            IELEM=IELEM+1
*
*         premier barycentre
*
            DO IE2=1,IDIM
              BAR1(IE2)=0.D0
            ENDDO
            IF(SZ3(IE1).EQ.0)THEN
              MELEME=IPT1
            ELSE
              MELEME=IPT1.LISOUS(SZ3(IE1))
            ENDIF
            NBNN=NUM(/1)
            DO IE3=1,NBNN
              IPDUM=(IDIM+1)*(NUM(IE3,NELM3(IE1))-1)
              DO IE4=1,IDIM
                BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4)
              ENDDO
            ENDDO
            DO IE2=1,IDIM
              BAR1(IE2)=BAR1(IE2)/NBNN
            ENDDO
*
*         Chargement de la premiere face
*
            DO IE2=1,3
              IPR1=(IDIM+1)*(P3(IE2,IE1)-1)
              DO IE3=1,IDIM
                FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
              ENDDO
            ENDDO
*
*         second barycentre
*
            JE1=FLA3(IE1)
            DO IE2=1,IDIM
              BAR2(IE2)=0.D0
            ENDDO
            IF(SZ3(JE1).EQ.0)THEN
              MELEME=IPT1
            ELSE
              MELEME=IPT1.LISOUS(SZ3(JE1))
            ENDIF
            NBNN=NUM(/1)
            DO IE3=1,NBNN
              IPDUM=(IDIM+1)*(NUM(IE3,NELM3(JE1))-1)
              DO IE4=1,IDIM
                BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4)
              ENDDO
            ENDDO
            DO IE2=1,IDIM
              BAR2(IE2)=BAR2(IE2)/NBNN
            ENDDO
*
*         Chargement de la seconde face
*
            DO IE2=1,3
              IPR1=(IDIM+1)*(P3(IE2,JE1)-1)
              DO IE3=1,IDIM
                FAC2(IE3,IE2)=XCOOR(IPR1+IE3)
              ENDDO
            ENDDO
*
*         On ordonne correctement les points
*
            CALL GENRD2(FAC1,BAR1,P3(1,IE1),BAR2,P3(1,JE1),3,TOL)
*
*         On charge le joint
*
            DO IE2=1,3
              IPT3.NUM(IE2  ,IELEM)=P3(IE2,IE1)
              IPT3.NUM(IE2+3,IELEM)=P3(IE2,JE1)
            ENDDO
*
*         on efface les 2 cotes
*
            FLA3(IE1)=0
            FLA3(JE1)=0
          ENDIF
        ENDDO
        SEGDES,IPT3
      ENDIF
C
      IF(IPT4.NE.0)THEN
        IELEM=0
        DO IE1=1,NCOT4
          IF(FLA4(IE1).NE.0)THEN
            IELEM=IELEM+1
*
*         premier barycentre
*
            DO IE2=1,IDIM
              BAR1(IE2)=0.D0
            ENDDO
            IF(SZ4(IE1).EQ.0)THEN
              MELEME=IPT1
            ELSE
              MELEME=IPT1.LISOUS(SZ4(IE1))
            ENDIF
            NBNN=NUM(/1)
            DO IE3=1,NBNN
              IPDUM=(IDIM+1)*(NUM(IE3,NELM4(IE1))-1)
              DO IE4=1,IDIM
                BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4)
              ENDDO
            ENDDO
            DO IE2=1,IDIM
              BAR1(IE2)=BAR1(IE2)/NBNN
            ENDDO
*
*         Chargement de la premiere face
*
            DO IE2=1,4
              IPR1=(IDIM+1)*(P4(IE2,IE1)-1)
              DO IE3=1,IDIM
                FAC1(IE3,IE2)=XCOOR(IPR1+IE3)
              ENDDO
            ENDDO
*
*         second barycentre
*
            JE1=FLA4(IE1)
            DO IE2=1,IDIM
              BAR2(IE2)=0.D0
            ENDDO
            IF(SZ4(JE1).EQ.0)THEN
              MELEME=IPT1
            ELSE
              MELEME=IPT1.LISOUS(SZ4(JE1))
            ENDIF
            NBNN=NUM(/1)
            DO IE3=1,NBNN
              IPDUM=(IDIM+1)*(NUM(IE3,NELM4(JE1))-1)
              DO IE4=1,IDIM
                BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4)
              ENDDO
            ENDDO
            DO IE2=1,IDIM
              BAR2(IE2)=BAR2(IE2)/NBNN
            ENDDO
*
*         Chargement de la seconde face
*
            DO IE2=1,4
              IPR1=(IDIM+1)*(P4(IE2,JE1)-1)
              DO IE3=1,IDIM
                FAC2(IE3,IE2)=XCOOR(IPR1+IE3)
              ENDDO
            ENDDO
*
*         On ordonne correctement les points
*
            CALL GENRD2(FAC1,BAR1,P4(1,IE1),BAR2,P4(1,JE1),4,TOL)
*
*         On charge le joint
*
            DO IE2=1,4
              IPT4.NUM(IE2  ,IELEM)=P4(IE2,IE1)
              IPT4.NUM(IE2+4,IELEM)=P4(IE2,JE1)
            ENDDO
*
*         on efface les 2 cotes
*
            FLA4(IE1)=0
            FLA4(JE1)=0
          ENDIF
        ENDDO
        SEGDES,IPT4
      ENDIF
C
      IF(IIMPI.EQ.1790)THEN
        WRITE(IOIMP,*)'GENJO3: fin chargement maillage'
      ENDIF
C
C     DESTRUCTION, DESACTIVATION ET RETOUR A GIBIANE
C
      CALL ECROBJ('MAILLAGE',IPT2)
C
 9999 SEGSUP,JO3GEN,JO4GEN
C
      NBSOUS=IPT1.LISOUS(/1)
      DO IE1=1,MAX(NBSOUS,1)
        IF(NBSOUS.EQ.0)THEN
          MELEME=IPT1
        ELSE
          MELEME=IPT1.LISOUS(IE1)
        ENDIF
        SEGDES,MELEME*NOMOD
      ENDDO
C
      RETURN
      END