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