Esope source files

   1 : C J3DISJ    SOURCE    CHAT      05/01/13    00:46:27     5004           
   2 :       SUBROUTINE J3DISJ(BLOCOM,XTOL,IRET)
   3 : C----------------------------------------------------
   4 : C
   5 : C     ON VERIFIE QU'IL N'Y A PAS DE POINTS DE MEME
   6 : C        POINTEUR DANS 2 BLOCKS DIFFERENTS
   7 : C
   8 : C     ON VERIFIE QUE 2 POINTS DE POSITION IDENTIQUE ONT LA MEME
   9 : C        DENSITE
  10 : C
  11 : C     TRANSFERT DES POINTS INITIAUX DANS J3LOAP
  12 : C
  13 : C     PP 9/97
  14 : C     Pierre Pegon/JRC Ispra
  15 : C----------------------------------------------------
  16 :       IMPLICIT INTEGER(I-N)
  17 :       IMPLICIT REAL*8(A-H,O-Z)
  18 : C
  19 : -INC CCOPTIO
  20 : -INC SMLENTI
  21 : -INC SMLREEL
  22 : C
  23 :       SEGMENT BLOCOM
  24 :         INTEGER POINT(JG)
  25 :         REAL*8 YCOOR(IDIM+1,JG)
  26 :         INTEGER MAILL(MM1)
  27 :       ENDSEGMENT
  28 : C
  29 : C     ON CHARGE MLENTI AVEC LES NUMERO DES POINTS ET 
  30 : C            ET MLENT1 AVEC LE NUMERO DES BLOCKS
  31 : C
  32 :       JG=POINT(/1)
  33 :       SEGINI,MLENTI,MLENT1
  34 :       DO IE1=1,JG
  35 :         LECT(IE1)=POINT(IE1)
  36 :       ENDDO
  37 :       IST1=1
  38 :       DO IE1=1,MAILL(/1)
  39 :         IFI1=MAILL(IE1)
  40 :         DO IE2=IST1,IFI1
  41 :           MLENT1.LECT(IE2)=IE1
  42 :         ENDDO
  43 :         IST1=IFI1+1
  44 :       ENDDO
  45 : C
  46 : C     ON ORDONNE MLENTI EN FAISANT LES PERMUTATIONS UTILES SUR MLENT1
  47 : C
  47 :       CALL GENOR2(LECT,MLENT1.LECT,JG)
  48 : C
  49 : C     ON VERIFIE QUE LES NUMEROS IDENTIQUES DES MLENTI SONT SUR LES
  50 : C        MEMES BLOCKS SUIVANT MLENT1
  51 : C
  52 :       IPO1=LECT(1)
  53 :       DO IE1=2,JG
  54 :         IPO2=LECT(IE1)
  55 :         IF (IPO1.EQ.IPO2)THEN
  56 :           IF(MLENT1.LECT(IE1-1).NE.MLENT1.LECT(IE1))THEN
  57 :             WRITE(IOIMP,*)
  58 :      >      'J3DISJ: 2 points sont communs a des blocks differents'
  59 :             IRET=IRET+1
  60 :             GOTO 9999
  61 :           ENDIF
  62 :         ENDIF
  63 :         IPO1=IPO2
  64 :       ENDDO      
  65 : C
  66 :  9999 SEGSUP,MLENTI,MLENT1
  67 : C
  68 : C     ON CHARGE DANS MLENTI LE RANG DES POINTS ET DANS MLREEL LA
  69 : C        DISTANCE A L'ORIGINE
  70 : C
  71 :       IF(IRET.NE.0)RETURN
  72 :       SEGINI,MLENTI,MLREEL
  73 :       DO IE1=1,JG
  74 :         LECT(IE1)=IE1
  75 :         XXXX=0.D0
  76 :         DO IE2=1,IDIM
  77 :           XXXX=XXXX+YCOOR(IE2,IE1)**2
  78 :         ENDDO
  79 :         PROG(IE1)=SQRT(XXXX)
  80 :       ENDDO
  81 : C
  82 : C     ON ORDONNE MLREEL EN FAISANT LES PERMUTATIONS UTILES SUR MLENTI
  83 : C
  83 :       CALL GENOS2(PROG,LECT,JG)
  84 : C
  85 : C     ON VERIFIE QUE LES POINTS IDENTIQUES EN POSITION ONT LA MEME DENSITE
  86 : C
  87 :       XFI=PROG(1)
  88 :       DO IE1=2,JG
  89 :         JE1=LECT(IE1-1)
  90 :         XFF=PROG(IE1)
  91 :         IF(JE1.EQ.0)GOTO 1
  92 :         IF(ABS(XFI-XFF).GE.XTOL)GOTO 1
  93 :         DO IE2=IE1,JG
  94 :           XXXX=PROG(IE2)
  95 :           IF(ABS(XFI-XXXX).GE.XTOL)GOTO 1
  96 :           JE2=LECT(IE2)
  97 :           XXXX=0.D0
  98 :           DO IE3=1,IDIM
  99 :             XXXX=XXXX+(YCOOR(IE3,JE2)-YCOOR(IE3,JE1))**2
 100 :           ENDDO
 101 :           IF(SQRT(XXXX).LT.XTOL)THEN
 102 :             XXXX=ABS(YCOOR(IDIM+1,JE2)-YCOOR(IDIM+1,JE1))
 103 :             IF(XXXX.GT.XTOL)THEN
 104 :               WRITE(IOIMP,*)
 105 :      >        'J3DISJ: 2 points identiques n"ont pas la meme densite'
 106 :               IRET=IRET+1
 107 :               GOTO 9998
 108 :             ELSE
 109 :               LECT(IE2)=0
 110 :             ENDIF
 111 :           ENDIF
 112 :         ENDDO
 113 :  1      XFI=XFF
 114 :       ENDDO
 115 : C
 116 :  9998 SEGSUP,MLENTI,MLREEL
 117 : C
 118 :       RETURN
 119 :       END
 120 :  
 121 :