Télécharger la plaquette Cast3M


fr en

Télécharger j3disk.eso

Retour à la liste

Numérotation des lignes : 

j3disk

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales