Télécharger j3disk.eso

Retour à la liste

Numérotation des lignes :

  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
  47. CALL GENOS2(PROG,LECT,JG)
  48. IF(IIMPI.EQ.1791)THEN
  49. WRITE(IOIMP,*)'AFTER GENOS2:I,PROG(I),LECT(I)'
  50. DO IE1=1,JG
  51. WRITE(IOIMP,*)IE1,PROG(IE1),LECT(IE1)
  52. ENDDO
  53. ENDIF
  54. C
  55. C ON VERIFIE QUE LES POINTS IDENTIQUES EN POSITION ONT LA MEME DENSITE
  56. C
  57. XFI=PROG(1)
  58. DO IE1=2,JG
  59. JE1=LECT(IE1-1)
  60. XFF=PROG(IE1)
  61. IF(JE1.EQ.0)GOTO 1
  62. IF(ABS(XFI-XFF).GE.XTOL)GOTO 1
  63. DO IE2=IE1,JG
  64. XXXX=PROG(IE2)
  65. IF(ABS(XFI-XXXX).GE.XTOL)GOTO 1
  66. JE2=LECT(IE2)
  67. XXXX=0.D0
  68. DO IE3=1,IDIM
  69. XXXX=XXXX+(YCOOR(IE3,JE2)-YCOOR(IE3,JE1))**2
  70. ENDDO
  71. IF(SQRT(XXXX).LT.XTOL)THEN
  72. XXXX=ABS(YCOOR(IDIM+1,JE2)-YCOOR(IDIM+1,JE1))
  73. IF(XXXX.GT.XTOL)THEN
  74. WRITE(IOIMP,*)
  75. > 'J3DISK: 2 points identiques n"ont pas la meme densite'
  76. IRET=IRET+1
  77. GOTO 9998
  78. ELSE
  79. DO IE3=1,IDIM+1
  80. YCOOR(IE3,JE2)=YCOOR(IE3,JE1)
  81. ENDDO
  82. LECT(IE2)=0
  83. ENDIF
  84. ENDIF
  85. ENDDO
  86. 1 XFI=XFF
  87. ENDDO
  88. *
  89. IF(IIMPI.EQ.1791)THEN
  90. WRITE(IOIMP,*)'BLOCOM OUTPUT: I,LECT,X,Y,Z'
  91. DO IE1=1,JG
  92. WRITE(IOIMP,*)IE1,LECT(IE1),(YCOOR(IE2,IE1),IE2=1,3)
  93. ENDDO
  94. ENDIF
  95. C
  96. 9998 SEGSUP,MLENTI,MLREEL
  97. C
  98. RETURN
  99. END
  100.  
  101.  
  102.  

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