Télécharger la plaquette Cast3M


fr en

Télécharger j3disj.eso

Retour à la liste

Numérotation des lignes : 

j3disj

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

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