Télécharger la plaquette Cast3M


fr en

Télécharger dist.eso

Retour à la liste

Numérotation des lignes : 

dist

  1. C DIST      SOURCE    JC220346  16/11/29    21:15:12     9221           
  2. C---------------------------------------------------------------------|
  3. C                                                                     |
  4.        SUBROUTINE DIST(IP,JP,GL,IOK,I1,I2,I3,I4,I5,I6,I7,I8,I9,I10)
  5. C                                                                     |
  6. C      CETTE SUBROUTINE RECHERCHE LE POINT JP LE PLUS PROCHE DE       |
  7. C      IP. LA DISTANCE ENTRE LES 2 POINTS EST MEMORISEE DANS GL.      |
  8. C      LES POINTS I* SONT EXCLUS DE LA RECHERCHE                      |
  9. C                                                                     |
  10. C---------------------------------------------------------------------|
  11. C
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8(A-H,O-Z)
  14. -INC TDEMAIT
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18. C
  19.        IOK=1
  20.        GL=1.0E+30
  21.        JP=0
  22. C
  23.        xp=XYZ(1,IP)
  24.        yp=XYZ(2,IP)
  25.        zp=XYZ(3,IP)
  26.        tp=XYZ(4,IP)
  27.        DO 100 I=NPTDIS,NPTMAX
  28.               IF (NPF(1,I).EQ.0) GOTO 100
  29.               IF (I.EQ.IP) GOTO 100
  30.               IF (I.EQ.I1) GOTO 100
  31.               IF (I.EQ.I2) GOTO 100
  32.               IF (I.EQ.I3) GOTO 100
  33.               IF (I.EQ.I4) GOTO 100
  34.               IF (I.EQ.I5) GOTO 100
  35.               IF (I.EQ.I6) GOTO 100
  36.               IF (I.EQ.I7) GOTO 100
  37.               IF (I.EQ.I8) GOTO 100
  38.               IF (I.EQ.I9) GOTO 100
  39.               IF (I.EQ.I10) GOTO 100
  40.               S1=xp-XYZ(1,I)
  41.               if (abs(s1).gt.2*tp) goto 100
  42.               S2=yp-XYZ(2,I)
  43.               if (abs(s2).gt.2*tp) goto 100
  44.               S3=zp-XYZ(3,I)
  45.               if (abs(s3).gt.2*tp) goto 100
  46.               S=S1**2+s2**2+s3**2
  47.               IF (S.GT.GL) GOTO 100
  48.               GL=S
  49.               JP=I
  50. 100    CONTINUE
  51.        if (jp.ne.0) then
  52.           xyztes=XYZ(4,JP)
  53.        else
  54.           xyztes=1e30
  55.        endif
  56. *  maintenant test avec le milieu des aretes
  57. *      do 200 i=1,naret
  58.        do 200 i=1,-1
  59.         ii=iigard(i)
  60.         jj=jjgard(i)
  61.         if (ii.lt.0) goto 200
  62.          if ((ii.eq.i1.or.ii.eq.i2.or.ii.eq.i3.or.ii.eq.i4.or.ii.eq.i5
  63.      >   .or.ii.eq.i6.or.ii.eq.i7.or.ii.eq.i8.or.ii.eq.i9.or.ii.eq.i10)
  64.      >   .or.(jj.eq.i1.or.jj.eq.i2.or.jj.eq.i3.or.jj.eq.i4.or.jj.eq.i5
  65.      >   .or.jj.eq.i6.or.jj.eq.i7.or.jj.eq.i8.or.jj.eq.i9.or.jj.eq.i10))
  66.      >   goto 200
  67.               S1=(xp-(XYZ(1,II)+XYZ(1,JJ))/2)
  68.               if (abs(s1).gt.2*tp) goto 200
  69.               S2=(yp-(XYZ(2,II)+XYZ(2,JJ))/2)
  70.               if (abs(s2).gt.2*tp) goto 200
  71.               S3=(zp-(XYZ(3,II)+XYZ(3,JJ))/2)
  72.               if (abs(s3).gt.2*tp) goto 200
  73.               S=S1**2+S2**2+S3**2
  74.               IF (S.GT.GL) GOTO 200
  75.               GL=S
  76.               xyztes=sqrt(XYZ(4,II)*XYZ(4,JJ))
  77.               jp=0
  78.  200   continue
  79.         IF (GL.LE.tp*xyztes*CDIST) IOK=0
  80.         GL=SQRT(GL)
  81. *      write (6,*) ' dist gl ',gl
  82. *      write (6,*) ' ip ',XYZ(1,IP),XYZ(2,IP),XYZ(3,IP)
  83. *      write (6,*) ' jp ',XYZ(1,jP),XYZ(2,jP),XYZ(3,jP)
  84. C
  85.        RETURN
  86. C      FIN DE LA SUBROUTINE DIST
  87.        END
  88.  
  89.  
  90.  
  91.  

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