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.  
  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