C J3DISK    SOURCE    CHAT      05/01/13    00:46:30     5004
      SUBROUTINE J3DISK(BLOCOM,XTOL,IRET)
C----------------------------------------------------
C
C     ON VERIFIE QUE 2 POINTS DE POSITION IDENTIQUE ONT LA MEME
C        DENSITE, PUIS ON LES REND IDENTIQUE EN VALEUR
C
C     PP 9/97
C     Pierre Pegon/JRC Ispra
C----------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C

-INC PPARAM
-INC CCOPTIO
-INC SMLENTI
-INC SMLREEL
C
      SEGMENT BLOCOM
        INTEGER POINT(JG)
        REAL*8 YCOOR(IDIM+1,JG)
        INTEGER MAILL(MM1)
      ENDSEGMENT
C
      JG=POINT(/1)
C
C     ON CHARGE DANS MLENTI LE RANG DES POINTS ET DANS MLREEL LA
C        DISTANCE A L'ORIGINE
C
      SEGINI,MLENTI,MLREEL
      DO IE1=1,JG
        LECT(IE1)=IE1
        XXXX=0.D0
        DO IE2=1,IDIM
          XXXX=XXXX+YCOOR(IE2,IE1)**2
        ENDDO
        PROG(IE1)=SQRT(XXXX)
      ENDDO
      IF(IIMPI.EQ.1791)THEN
        WRITE(IOIMP,*)'BLOCOM INPUT: I,DIST,X,Y,Z'
        DO IE1=1,JG
          WRITE(IOIMP,*)LECT(IE1),PROG(IE1),(YCOOR(IE2,IE1),IE2=1,3)
        ENDDO
      ENDIF
C
C     ON ORDONNE MLREEL EN FAISANT LES PERMUTATIONS UTILES SUR MLENTI
C
      CALL GENOS2(PROG,LECT,JG)
      IF(IIMPI.EQ.1791)THEN
        WRITE(IOIMP,*)'AFTER GENOS2:I,PROG(I),LECT(I)'
        DO IE1=1,JG
          WRITE(IOIMP,*)IE1,PROG(IE1),LECT(IE1)
        ENDDO
      ENDIF
C
C     ON VERIFIE QUE LES POINTS IDENTIQUES EN POSITION ONT LA MEME DENSITE
C
      XFI=PROG(1)
      DO IE1=2,JG
        JE1=LECT(IE1-1)
        XFF=PROG(IE1)
        IF(JE1.EQ.0)GOTO 1
        IF(ABS(XFI-XFF).GE.XTOL)GOTO 1
        DO IE2=IE1,JG
          XXXX=PROG(IE2)
          IF(ABS(XFI-XXXX).GE.XTOL)GOTO 1
          JE2=LECT(IE2)
          XXXX=0.D0
          DO IE3=1,IDIM
            XXXX=XXXX+(YCOOR(IE3,JE2)-YCOOR(IE3,JE1))**2
          ENDDO
          IF(SQRT(XXXX).LT.XTOL)THEN
            XXXX=ABS(YCOOR(IDIM+1,JE2)-YCOOR(IDIM+1,JE1))
            IF(XXXX.GT.XTOL)THEN
              WRITE(IOIMP,*)
     >        'J3DISK: 2 points identiques n"ont pas la meme densite'
              IRET=IRET+1
              GOTO 9998
            ELSE
              DO IE3=1,IDIM+1
                YCOOR(IE3,JE2)=YCOOR(IE3,JE1)
              ENDDO
              LECT(IE2)=0
            ENDIF
          ENDIF
        ENDDO
 1      XFI=XFF
      ENDDO
*
      IF(IIMPI.EQ.1791)THEN
        WRITE(IOIMP,*)'BLOCOM OUTPUT: I,LECT,X,Y,Z'
        DO IE1=1,JG
          WRITE(IOIMP,*)IE1,LECT(IE1),(YCOOR(IE2,IE1),IE2=1,3)
        ENDDO
      ENDIF
C
 9998 SEGSUP,MLENTI,MLREEL
C
      RETURN
      END