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