C J3DISJ    SOURCE    CHAT      05/01/13    00:46:27     5004
      SUBROUTINE J3DISJ(BLOCOM,XTOL,IRET)
C----------------------------------------------------
C
C     ON VERIFIE QU'IL N'Y A PAS DE POINTS DE MEME
C        POINTEUR DANS 2 BLOCKS DIFFERENTS
C
C     ON VERIFIE QUE 2 POINTS DE POSITION IDENTIQUE ONT LA MEME
C        DENSITE
C
C     TRANSFERT DES POINTS INITIAUX DANS J3LOAP
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
C     ON CHARGE MLENTI AVEC LES NUMERO DES POINTS ET
C            ET MLENT1 AVEC LE NUMERO DES BLOCKS
C
      JG=POINT(/1)
      SEGINI,MLENTI,MLENT1
      DO IE1=1,JG
        LECT(IE1)=POINT(IE1)
      ENDDO
      IST1=1
      DO IE1=1,MAILL(/1)
        IFI1=MAILL(IE1)
        DO IE2=IST1,IFI1
          MLENT1.LECT(IE2)=IE1
        ENDDO
        IST1=IFI1+1
      ENDDO
C
C     ON ORDONNE MLENTI EN FAISANT LES PERMUTATIONS UTILES SUR MLENT1
C
      CALL GENOR2(LECT,MLENT1.LECT,JG)
C
C     ON VERIFIE QUE LES NUMEROS IDENTIQUES DES MLENTI SONT SUR LES
C        MEMES BLOCKS SUIVANT MLENT1
C
      IPO1=LECT(1)
      DO IE1=2,JG
        IPO2=LECT(IE1)
        IF (IPO1.EQ.IPO2)THEN
          IF(MLENT1.LECT(IE1-1).NE.MLENT1.LECT(IE1))THEN
            WRITE(IOIMP,*)
     >      'J3DISJ: 2 points sont communs a des blocks differents'
            IRET=IRET+1
            GOTO 9999
          ENDIF
        ENDIF
        IPO1=IPO2
      ENDDO
C
 9999 SEGSUP,MLENTI,MLENT1
C
C     ON CHARGE DANS MLENTI LE RANG DES POINTS ET DANS MLREEL LA
C        DISTANCE A L'ORIGINE
C
      IF(IRET.NE.0)RETURN
      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
C
C     ON ORDONNE MLREEL EN FAISANT LES PERMUTATIONS UTILES SUR MLENTI
C
      CALL GENOS2(PROG,LECT,JG)
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,*)
     >        'J3DISJ: 2 points identiques n"ont pas la meme densite'
              IRET=IRET+1
              GOTO 9998
            ELSE
              LECT(IE2)=0
            ENDIF
          ENDIF
        ENDDO
 1      XFI=XFF
      ENDDO
C
 9998 SEGSUP,MLENTI,MLREEL
C
      RETURN
      END