Télécharger impos5.eso

Retour à la liste

Numérotation des lignes :

  1. C IMPOS5 SOURCE CHAT 05/01/13 00:33:59 5004
  2. SUBROUTINE IMPOS5(MCTC1,MCTC2,ICODE)
  3. c
  4. c regarde si les deux contacts ont un point en commun
  5. c
  6. c les deux segments en entrée sont actifs
  7. c
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8 (A-H,O-Z)
  10. SEGMENT MCTC
  11. INTEGER IPOT1(NNO1)
  12. INTEGER IPOT2(NNO2)
  13. ENDSEGMENT
  14. POINTEUR MCTC1.MCTC,MCTC2.MCTC,MCTC3.MCTC
  15. c executable
  16. 1 ICODE = 0
  17. ICOD1 = 0
  18. ICOD2 = 0
  19. c
  20. c boucle sur la premiere couche du second segment
  21. c
  22. DO 100 I=1,MCTC2.IPOT1(/1)
  23. DO 10 J= 1,MCTC1.IPOT1(/1)
  24. IF (MCTC1.IPOT1(J) .EQ. MCTC2.IPOT1(I)) THEN
  25. ICOD1 = 1
  26. ENDIF
  27. 10 CONTINUE
  28. DO 20 J= 1,MCTC1.IPOT2(/1)
  29. IF (MCTC1.IPOT2(J) .EQ. MCTC2.IPOT1(I)) THEN
  30. ICOD2 = -1
  31. ENDIF
  32. 20 CONTINUE
  33. 100 CONTINUE
  34. c
  35. IF ( (ICOD1 * ICOD2) .EQ. -1 ) THEN
  36. c petite magouille pour les fonds de fissures
  37. c par exemple deux lignes de contacts ont un point en commun
  38. IF (MCTC2.IPOT1(/1).EQ.2 .AND. MCTC2.IPOT2(/1).EQ.1) THEN
  39. c un des cote du triangle a ses points dans les deux couches
  40. c on effectue une permutation circulaire
  41. IDUMY = MCTC2.IPOT1(1)
  42. MCTC2.IPOT1(1) = MCTC2.IPOT2(1)
  43. MCTC2.IPOT1(2) = MCTC2.IPOT2(1)
  44. MCTC2.IPOT2(1) = IDUMY
  45. GOTO 1
  46. ENDIF
  47. ICODE = -1
  48. RETURN
  49. ELSE
  50. ICODE = ICOD1 + ICOD2
  51. IF (ICODE .NE. 0) RETURN
  52. ENDIF
  53. c
  54. c boucle sur la seconde couche du second segment
  55. c
  56. DO 200 I=1,MCTC2.IPOT2(/1)
  57. DO 110 J= 1,MCTC1.IPOT1(/1)
  58. IF (MCTC1.IPOT1(J) .EQ. MCTC2.IPOT2(I)) THEN
  59. ICODE = -1
  60. RETURN
  61. ENDIF
  62. 110 CONTINUE
  63. DO 120 J= 1,MCTC1.IPOT2(/1)
  64. IF (MCTC1.IPOT2(J) .EQ. MCTC2.IPOT2(I)) THEN
  65. ICODE = 1
  66. RETURN
  67. ENDIF
  68. 120 CONTINUE
  69. 200 CONTINUE
  70. RETURN
  71. END
  72.  
  73.  
  74.  

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