Esope source files

   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
  31 :                     CALL ERREUR(945)
  32 :                 END IF
  33 :             END IF 
  34 :         END IF
  35 :                      
  36 :         D=((XP-XM)**2+(YP-YM)**2+(ZP-ZM)**2)**0.5
  37 :         
  38 : c        XMI=MIN(XA,XB)
  39 : c        XMA=MAX(XA,XB)
  40 : c        YMI=MIN(YA,YB)
  41 : c        YMA=MAX(YA,YB)
  42 : c        ZMI=MIN(ZA,ZB)
  43 : c        ZMA=MAX(ZA,ZB)
  44 : c        IF (XM.GE.XMI.AND.XM.LE.XMA) THEN
  45 : c           IF (YM.GE.YMI.AND.YM.LE.YMA) THEN
  46 : c              IF (ZM.GE.ZMI.AND.ZM.LE.ZMA) THEN
  47 : c                  MARQ=0
  48 : c              ENDIF
  49 : c           ENDIF
  50 : c        ENDIF
  51 : 
  52 : c si AM.BM négatif M est dans le segment
  53 :         XYM=(XM-XA)*(XM-XB)+(YM-YA)*(YM-YB)+(ZM-ZA)*(ZM-ZB)
  54 :         IF (XYM.LE.0) THEN
  55 :            MARQ=0
  56 :         ENDIF
  57 : c        if (marq.eq.0) then
  58 : c            write(6,*)xm,ym,zm
  59 : c            write(6,*)'marq',marq,'dist',d
  60 : c        end if
  61 :        
  62 :         RETURN
  63 :         END
  64 : 
  65 :  
  66 :