Esope source files

   1 : C J3DISK    SOURCE    CHAT      05/01/13    00:46:30     5004           
   2 :       SUBROUTINE J3DISK(BLOCOM,XTOL,IRET)
   3 : C----------------------------------------------------
   4 : C
   5 : C     ON VERIFIE QUE 2 POINTS DE POSITION IDENTIQUE ONT LA MEME
   6 : C        DENSITE, PUIS ON LES REND IDENTIQUE EN VALEUR
   7 : C
   8 : C     PP 9/97
   9 : C     Pierre Pegon/JRC Ispra
  10 : C----------------------------------------------------
  11 :       IMPLICIT INTEGER(I-N)
  12 :       IMPLICIT REAL*8(A-H,O-Z)
  13 : C
  14 : -INC CCOPTIO
  15 : -INC SMLENTI
  16 : -INC SMLREEL
  17 : C
  18 :       SEGMENT BLOCOM
  19 :         INTEGER POINT(JG)
  20 :         REAL*8 YCOOR(IDIM+1,JG)
  21 :         INTEGER MAILL(MM1)
  22 :       ENDSEGMENT
  23 : C
  24 :       JG=POINT(/1)
  25 : C
  26 : C     ON CHARGE DANS MLENTI LE RANG DES POINTS ET DANS MLREEL LA
  27 : C        DISTANCE A L'ORIGINE
  28 : C
  29 :       SEGINI,MLENTI,MLREEL
  30 :       DO IE1=1,JG
  31 :         LECT(IE1)=IE1
  32 :         XXXX=0.D0
  33 :         DO IE2=1,IDIM
  34 :           XXXX=XXXX+YCOOR(IE2,IE1)**2
  35 :         ENDDO
  36 :         PROG(IE1)=SQRT(XXXX)
  37 :       ENDDO
  38 :       IF(IIMPI.EQ.1791)THEN
  39 :         WRITE(IOIMP,*)'BLOCOM INPUT: I,DIST,X,Y,Z'
  40 :         DO IE1=1,JG
  41 :           WRITE(IOIMP,*)LECT(IE1),PROG(IE1),(YCOOR(IE2,IE1),IE2=1,3)
  42 :         ENDDO
  43 :       ENDIF
  44 : C
  45 : C     ON ORDONNE MLREEL EN FAISANT LES PERMUTATIONS UTILES SUR MLENTI
  46 : C
  46 :       CALL GENOS2(PROG,LECT,JG)
  47 :       IF(IIMPI.EQ.1791)THEN
  48 :         WRITE(IOIMP,*)'AFTER GENOS2:I,PROG(I),LECT(I)'
  49 :         DO IE1=1,JG
  50 :           WRITE(IOIMP,*)IE1,PROG(IE1),LECT(IE1)
  51 :         ENDDO
  52 :       ENDIF
  53 : C
  54 : C     ON VERIFIE QUE LES POINTS IDENTIQUES EN POSITION ONT LA MEME DENSITE
  55 : C
  56 :       XFI=PROG(1)
  57 :       DO IE1=2,JG
  58 :         JE1=LECT(IE1-1)
  59 :         XFF=PROG(IE1)
  60 :         IF(JE1.EQ.0)GOTO 1
  61 :         IF(ABS(XFI-XFF).GE.XTOL)GOTO 1
  62 :         DO IE2=IE1,JG
  63 :           XXXX=PROG(IE2)
  64 :           IF(ABS(XFI-XXXX).GE.XTOL)GOTO 1
  65 :           JE2=LECT(IE2)
  66 :           XXXX=0.D0
  67 :           DO IE3=1,IDIM
  68 :             XXXX=XXXX+(YCOOR(IE3,JE2)-YCOOR(IE3,JE1))**2
  69 :           ENDDO
  70 :           IF(SQRT(XXXX).LT.XTOL)THEN
  71 :             XXXX=ABS(YCOOR(IDIM+1,JE2)-YCOOR(IDIM+1,JE1))
  72 :             IF(XXXX.GT.XTOL)THEN
  73 :               WRITE(IOIMP,*)
  74 :      >        'J3DISK: 2 points identiques n"ont pas la meme densite'
  75 :               IRET=IRET+1
  76 :               GOTO 9998
  77 :             ELSE
  78 :               DO IE3=1,IDIM+1
  79 :                 YCOOR(IE3,JE2)=YCOOR(IE3,JE1)
  80 :               ENDDO
  81 :               LECT(IE2)=0
  82 :             ENDIF
  83 :           ENDIF
  84 :         ENDDO
  85 :  1      XFI=XFF
  86 :       ENDDO
  87 : *
  88 :       IF(IIMPI.EQ.1791)THEN
  89 :         WRITE(IOIMP,*)'BLOCOM OUTPUT: I,LECT,X,Y,Z'
  90 :         DO IE1=1,JG
  91 :           WRITE(IOIMP,*)IE1,LECT(IE1),(YCOOR(IE2,IE1),IE2=1,3)
  92 :         ENDDO
  93 :       ENDIF
  94 : C
  95 :  9998 SEGSUP,MLENTI,MLREEL
  96 : C
  97 :       RETURN
  98 :       END
  99 :  
 100 :