Télécharger la plaquette Cast3M


fr en

Télécharger distan.eso

Retour à la liste

Numérotation des lignes : 

distan

  1. C DISTAN    SOURCE    CHAT      05/01/12    22:51:23     5004
  2.         SUBROUTINE DISTAN(XP,XA,XB,YP,YA,YB,ZP,ZA,ZB,D,MARQ)
  3.       IMPLICIT INTEGER(I-N)
  4.         IMPLICIT REAL*8 (A-H,O-Z)
  5. C
  6. C
  7. C
  8.  
  9. C
  10. C
  11.         MARQ=1
  12. c        write(6,*)xa,ya,za
  13.         IF (XA.NE.XB) THEN
  14.         XM=((XB-XA)**2*XP+(YB-YA)*(XB-XA)*YP-(ZB-ZA)*(XB*ZA-XA*ZB)+(ZB-Z
  15.      $A)*(XB-XA)*ZP-(YB-YA)*(YA*XB-YB*XA))/((XB-XA)**2+(YB-YA)**2+(ZB-Z
  16.      $A)**2)
  17.  
  18.         YM=((YB-YA)/(XB-XA))*XM+((YA*XB-YB*XA)/(XB-XA))
  19.         ZM=((ZB-ZA)/(XB-XA))*XM+((ZA*XB-ZB*XA)/(XB-XA))
  20.         ELSE
  21.             IF (ZA.NE.ZB) THEN
  22.                XM=XA
  23.                ZM=((YB-YA)*YP+(ZB-ZA)*ZP-YA*ZB+YB*ZA)/((ZB-ZA)+((YB-YA)
  24.      $**2)/(ZB-ZA)+(YA*ZB-YB*ZA)*(YB-YA)/(ZB-ZA))
  25.                YM=(YB-YA)/(ZB-ZA)*ZM+(YA*ZB-YB*ZA)/(ZB-ZA)
  26.             ELSE
  27.                 IF (YA.NE.YB) THEN
  28.                     XM=XA
  29.                     ZM=ZA
  30.                     YM=YP
  31.                 ELSE
  32.                     CALL ERREUR(945)
  33.                 END IF
  34.             END IF
  35.         END IF
  36.  
  37.         D=((XP-XM)**2+(YP-YM)**2+(ZP-ZM)**2)**0.5
  38.  
  39. c        XMI=MIN(XA,XB)
  40. c        XMA=MAX(XA,XB)
  41. c        YMI=MIN(YA,YB)
  42. c        YMA=MAX(YA,YB)
  43. c        ZMI=MIN(ZA,ZB)
  44. c        ZMA=MAX(ZA,ZB)
  45. c        IF (XM.GE.XMI.AND.XM.LE.XMA) THEN
  46. c           IF (YM.GE.YMI.AND.YM.LE.YMA) THEN
  47. c              IF (ZM.GE.ZMI.AND.ZM.LE.ZMA) THEN
  48. c                  MARQ=0
  49. c              ENDIF
  50. c           ENDIF
  51. c        ENDIF
  52.  
  53. c si AM.BM négatif M est dans le segment
  54.         XYM=(XM-XA)*(XM-XB)+(YM-YA)*(YM-YB)+(ZM-ZA)*(ZM-ZB)
  55.         IF (XYM.LE.0) THEN
  56.            MARQ=0
  57.         ENDIF
  58. c        if (marq.eq.0) then
  59. c            write(6,*)xm,ym,zm
  60. c            write(6,*)'marq',marq,'dist',d
  61. c        end if
  62.  
  63.         RETURN
  64.         END
  65.  
  66.  
  67.  
  68.  

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