Esope source files

   1 : C RAFDEN    SOURCE    CHAT      07/09/04    21:15:00     5847           
   2 :       SUBROUTINE RAFDEN(ICHPO,XPT,YPT,ZPT,NDIM,DENPT)                                                           
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)
   5 : -INC CCREEL
   6 : -INC CCOPTIO
   7 :       SEGMENT ICHPO
   8 :         REAL*8 XR(NBPTCH),YR(NBPTCH),ZR(NBPTCH),DEN(NBPTCH)
   9 :       ENDSEGMENT
  10 :       DENF=0.
  11 :       DENOM=0.
  12 :       DENM=XPETIT
  13 :       DO 1 I=1,DEN(/1)
  14 :         DENM=MAX(DENM,DEN(I))
  15 :    1  CONTINUE
  16 :       DENM=MAX(1.D0,DENM)
  17 :       XCORR=DEN(/1)*DENM*1D17
  18 : C
  19 : C ** MODIFICATIONS
  20 : C
  21 : C      GOTO 10
  22 :       SEGMENT XWORK
  23 :         REAL*8 XTAB(NLIGN)
  24 :         INTEGER ITAB(NLIGN)
  25 :       ENDSEGMENT
  26 :       NLIGN=3
  27 :       NCOLO=2
  28 :       SEGINI XWORK
  29 :       DO 7 I=1,NLIGN
  30 :         XTAB(I)=XGRAND
  31 :    7  CONTINUE
  32 :       SEGACT XWORK*MOD
  33 :       DO 6 I=1,XR(/1)
  34 :         di2=(XR(I)-XPT)**2+(YR(I)-YPT)**2
  35 :         if(ndim.eq.3)di2=di2 + (ZR(I)-ZPT)**2
  36 :         DIST=SQRT(di2)
  37 :         IF (DIST.LT.XTAB(1)) THEN
  38 :           XTAB(3)=XTAB(2)
  39 :           ITAB(3)=ITAB(2)
  40 :           ITAB(2)=ITAB(1)
  41 :           XTAB(2)=XTAB(1)
  42 :           XTAB(1)=DIST
  43 :           ITAB(1)=I
  44 :         ELSEIF (DIST.LT.XTAB(2)) THEN
  45 :           XTAB(3)=XTAB(2)
  46 :           ITAB(3)=ITAB(2)
  47 :           XTAB(2)=DIST
  48 :           ITAB(2)=I
  49 :         ELSEIF (DIST.LT.XTAB(3)) THEN
  50 :           XTAB(3)=DIST
  51 :           ITAB(3)=I      
  52 :         ENDIF
  53 :    6  CONTINUE
  54 :       DO 8 I=1,3
  55 :        J= ITAB(I)
  56 :        di2=(XR(J)-XPT)**2+(YR(J)-YPT)**2
  57 :         if(ndim.eq.3)di2=di2 + (ZR(J)-ZPT)**2
  58 :         DIST=SQRT(di2)
  59 :         IF (ABS(DIST).LT.XPETIT*XCORR) DIST=XPETIT*XCORR
  60 :         DENF=DENF+DEN(J)/DIST
  61 :         DENOM=DENOM+1/DIST
  62 :    8  CONTINUE
  63 :       SEGSUP XWORK
  64 :       GOTO 5
  65 :   10  CONTINUE
  66 : C
  67 : C ** FIN DES MODIFICATIONS
  68 : C
  69 :       IF (NDIM.NE.3) GOTO 3
  70 :       DO 2 I=1,DEN(/1)
  71 :         DIST=SQRT((XR(I)-XPT)**2+(YR(I)-YPT)**2+(ZR(I)-ZPT)**2)
  72 :         IF (ABS(DIST).LT.XPETIT*XCORR) DIST=XPETIT*XCORR
  73 :         DENF=DENF+DEN(I)/DIST
  74 :         DENOM=DENOM+1/DIST
  75 :    2  CONTINUE
  76 :       GOTO 5
  77 :    3  CONTINUE
  78 :       DO 4 I=1,DEN(/1)
  79 :           DIST=SQRT((XR(I)-XPT)**2+(YR(I)-YPT)**2)
  80 :         IF (ABS(DIST).LT.XPETIT*XCORR) DIST=XPETIT*XCORR
  81 :         DENF=DENF+DEN(I)/DIST
  82 :         DENOM=DENOM+1/DIST
  83 :    4  CONTINUE
  84 :    5  CONTINUE
  85 :        DENPT=DENF/DENOM
  86 :       IF (IIMPI.NE.0)
  87 :      # wrIte (6,*) ' rafden retour ',denf,denom,Xpt,ypt,zpt,den(/1)   
  88 :       RETURN                                                                    
  89 :       END                                                                       
  90 :  
  91 :  
  92 :