Esope source files

   1 : C PROGA     SOURCE    CHAT      05/01/13    02:30:52     5004           
   2 :       SUBROUTINE PROGA(F1,G,YAMB1,A,B,C,D,D2,CO)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)
   5 :       DIMENSION V(3),A(3),B(3),C(3),D(3)
   6 :       IF(D2.LT.1.E-8)THEN
   7 :          WRITE(6,*)'PB D2=0 : MAUVAIS MAILLAGE OU PB DS MITAB'
   8 :          F1=0
   9 :          RETURN
  10 :       ENDIF
  11 :       D32=0
  12 :       PS1=0
  13 :       PS2=0
  14 :       RAC=0
  15 :       DO 10 K=1,3
  16 :           V(K)=(C(K)-A(K))
  17 :           V(K)=V(K)-YAMB1*(B(K)-A(K))
  18 :           D32=D32+V(K)**2
  19 :  10   CONTINUE
  20 :       DO 20 K=1,3
  21 :            PS2=PS2+V(K)*(D(K)-C(K))
  22 :  20   CONTINUE
  23 : C                                                                               
  24 : C     IF(ABS(CO).LT.(1.E-8))THEN
  25 : C        F1=0
  26 : C        RETURN
  27 : C     ENDIF
  28 :       PS1=PS2/D2
  29 :       RAC=DSQRT(DABS(D32-PS1**2))
  30 :       D4=D32+D2**2+2*PS2
  31 :       IF (D4.LT.(1.E-8))THEN
  32 : C         WRITE(6,*)'D4=0'
  33 :           F1=DLOG(D2)-1
  34 :           RETURN
  35 :       ENDIF
  36 :       IF(D32.LT.(1.E-8))THEN
  37 : C         WRITE(6,*)'D32=0 '
  38 :           F1=DLOG(D2)-1
  39 :           RETURN
  40 :       ENDIF
  41 :       IF(RAC.LT.(1.E-8))THEN
  42 : C         WRITE(6,*)'RAC=0'
  43 :           IF (DABS(DABS(CO)-1).LT.(1.E-6))THEN
  44 :             F1=(D2+PS1)*(DLOG(D4)-2)-(PS1*(DLOG(D32)-2))
  45 :             F1=F1/D2/2
  46 :           ELSE
  47 :             F1=DLOG(D2)-1
  48 :           ENDIF
  49 :           RETURN
  50 :       ENDIF
  51 :       F1=(D2+PS1)*(DLOG(D4)-2)+2*RAC*DATAN((D2+PS1)/RAC)
  52 :       F1=F1-(PS1*DLOG(D32)-2*PS1+2*RAC*DATAN(PS1/RAC))
  53 :       F1=F1/2/D2
  54 : C     WRITE(7,*)'F1=',F1
  55 :       RETURN
  56 :       END
  57 :