Télécharger j3disj.eso

Retour à la liste

Numérotation des lignes :

  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
  48. CALL GENOR2(LECT,MLENT1.LECT,JG)
  49. C
  50. C ON VERIFIE QUE LES NUMEROS IDENTIQUES DES MLENTI SONT SUR LES
  51. C MEMES BLOCKS SUIVANT MLENT1
  52. C
  53. IPO1=LECT(1)
  54. DO IE1=2,JG
  55. IPO2=LECT(IE1)
  56. IF (IPO1.EQ.IPO2)THEN
  57. IF(MLENT1.LECT(IE1-1).NE.MLENT1.LECT(IE1))THEN
  58. WRITE(IOIMP,*)
  59. > 'J3DISJ: 2 points sont communs a des blocks differents'
  60. IRET=IRET+1
  61. GOTO 9999
  62. ENDIF
  63. ENDIF
  64. IPO1=IPO2
  65. ENDDO
  66. C
  67. 9999 SEGSUP,MLENTI,MLENT1
  68. C
  69. C ON CHARGE DANS MLENTI LE RANG DES POINTS ET DANS MLREEL LA
  70. C DISTANCE A L'ORIGINE
  71. C
  72. IF(IRET.NE.0)RETURN
  73. SEGINI,MLENTI,MLREEL
  74. DO IE1=1,JG
  75. LECT(IE1)=IE1
  76. XXXX=0.D0
  77. DO IE2=1,IDIM
  78. XXXX=XXXX+YCOOR(IE2,IE1)**2
  79. ENDDO
  80. PROG(IE1)=SQRT(XXXX)
  81. ENDDO
  82. C
  83. C ON ORDONNE MLREEL EN FAISANT LES PERMUTATIONS UTILES SUR MLENTI
  84. C
  85. CALL GENOS2(PROG,LECT,JG)
  86. C
  87. C ON VERIFIE QUE LES POINTS IDENTIQUES EN POSITION ONT LA MEME DENSITE
  88. C
  89. XFI=PROG(1)
  90. DO IE1=2,JG
  91. JE1=LECT(IE1-1)
  92. XFF=PROG(IE1)
  93. IF(JE1.EQ.0)GOTO 1
  94. IF(ABS(XFI-XFF).GE.XTOL)GOTO 1
  95. DO IE2=IE1,JG
  96. XXXX=PROG(IE2)
  97. IF(ABS(XFI-XXXX).GE.XTOL)GOTO 1
  98. JE2=LECT(IE2)
  99. XXXX=0.D0
  100. DO IE3=1,IDIM
  101. XXXX=XXXX+(YCOOR(IE3,JE2)-YCOOR(IE3,JE1))**2
  102. ENDDO
  103. IF(SQRT(XXXX).LT.XTOL)THEN
  104. XXXX=ABS(YCOOR(IDIM+1,JE2)-YCOOR(IDIM+1,JE1))
  105. IF(XXXX.GT.XTOL)THEN
  106. WRITE(IOIMP,*)
  107. > 'J3DISJ: 2 points identiques n"ont pas la meme densite'
  108. IRET=IRET+1
  109. GOTO 9998
  110. ELSE
  111. LECT(IE2)=0
  112. ENDIF
  113. ENDIF
  114. ENDDO
  115. 1 XFI=XFF
  116. ENDDO
  117. C
  118. 9998 SEGSUP,MLENTI,MLREEL
  119. C
  120. RETURN
  121. END
  122.  
  123.  
  124.  

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