Sources Esope | Cast3M

rafden
C RAFDEN    SOURCE    CHAT      07/09/04    21:15:00     5847
      SUBROUTINE RAFDEN(ICHPO,XPT,YPT,ZPT,NDIM,DENPT)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC CCREEL
 
-INC PPARAM
-INC CCOPTIO
      SEGMENT ICHPO
        REAL*8 XR(NBPTCH),YR(NBPTCH),ZR(NBPTCH),DEN(NBPTCH)
      ENDSEGMENT
      DENF=0.
      DENOM=0.
      DENM=XPETIT
      DO 1 I=1,DEN(/1)
        DENM=MAX(DENM,DEN(I))
   1  CONTINUE
      DENM=MAX(1.D0,DENM)
      XCORR=DEN(/1)*DENM*1D17
C
C ** MODIFICATIONS
C
C      GOTO 10
      SEGMENT XWORK
        REAL*8 XTAB(NLIGN)
        INTEGER ITAB(NLIGN)
      ENDSEGMENT
      NLIGN=3
      NCOLO=2
      SEGINI XWORK
      DO 7 I=1,NLIGN
        XTAB(I)=XGRAND
   7  CONTINUE
      SEGACT XWORK*MOD
      DO 6 I=1,XR(/1)
        di2=(XR(I)-XPT)**2+(YR(I)-YPT)**2
        if(ndim.eq.3)di2=di2 + (ZR(I)-ZPT)**2
        DIST=SQRT(di2)
        IF (DIST.LT.XTAB(1)) THEN
          XTAB(3)=XTAB(2)
          ITAB(3)=ITAB(2)
          ITAB(2)=ITAB(1)
          XTAB(2)=XTAB(1)
          XTAB(1)=DIST
          ITAB(1)=I
        ELSEIF (DIST.LT.XTAB(2)) THEN
          XTAB(3)=XTAB(2)
          ITAB(3)=ITAB(2)
          XTAB(2)=DIST
          ITAB(2)=I
        ELSEIF (DIST.LT.XTAB(3)) THEN
          XTAB(3)=DIST
          ITAB(3)=I
        ENDIF
   6  CONTINUE
      DO 8 I=1,3
       J= ITAB(I)
       di2=(XR(J)-XPT)**2+(YR(J)-YPT)**2
        if(ndim.eq.3)di2=di2 + (ZR(J)-ZPT)**2
        DIST=SQRT(di2)
        IF (ABS(DIST).LT.XPETIT*XCORR) DIST=XPETIT*XCORR
        DENF=DENF+DEN(J)/DIST
        DENOM=DENOM+1/DIST
   8  CONTINUE
      SEGSUP XWORK
      GOTO 5
  10  CONTINUE
C
C ** FIN DES MODIFICATIONS
C
      IF (NDIM.NE.3) GOTO 3
      DO 2 I=1,DEN(/1)
        DIST=SQRT((XR(I)-XPT)**2+(YR(I)-YPT)**2+(ZR(I)-ZPT)**2)
        IF (ABS(DIST).LT.XPETIT*XCORR) DIST=XPETIT*XCORR
        DENF=DENF+DEN(I)/DIST
        DENOM=DENOM+1/DIST
   2  CONTINUE
      GOTO 5
   3  CONTINUE
      DO 4 I=1,DEN(/1)
          DIST=SQRT((XR(I)-XPT)**2+(YR(I)-YPT)**2)
        IF (ABS(DIST).LT.XPETIT*XCORR) DIST=XPETIT*XCORR
        DENF=DENF+DEN(I)/DIST
        DENOM=DENOM+1/DIST
   4  CONTINUE
   5  CONTINUE
       DENPT=DENF/DENOM
      IF (IIMPI.NE.0)
     # wrIte (6,*) ' rafden retour ',denf,denom,Xpt,ypt,zpt,den(/1)
      RETURN
      END