C PROGA     SOURCE    PV        22/04/22    21:15:13     11344          
      SUBROUTINE PROGA(F1,G,YAMB1,A,B,C,D,D2,CO)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION V(3),A(3),B(3),C(3),D(3),G(11,10)
      IF(D2.LT.1.E-8)THEN
         WRITE(6,*)'PB D2=0 : MAUVAIS MAILLAGE OU PB DS MITAB'
         F1=0
         RETURN
      ENDIF
      D32=0
      PS1=0
      PS2=0
      RAC=0
      DO 10 K=1,3
          V(K)=(C(K)-A(K))
          V(K)=V(K)-YAMB1*(B(K)-A(K))
          D32=D32+V(K)**2
 10   CONTINUE
      DO 20 K=1,3
           PS2=PS2+V(K)*(D(K)-C(K))
 20   CONTINUE
C
C     IF(ABS(CO).LT.(1.E-8))THEN
C        F1=0
C        RETURN
C     ENDIF
      PS1=PS2/D2
      RAC=SQRT(ABS(D32-PS1**2))
      D4=D32+D2**2+2*PS2
      IF (D4.LT.(1.E-8))THEN
C         WRITE(6,*)'D4=0'
          F1=LOG(D2)-1
          RETURN
      ENDIF
      IF(D32.LT.(1.E-8))THEN
C         WRITE(6,*)'D32=0 '
          F1=LOG(D2)-1
          RETURN
      ENDIF
      IF(RAC.LT.(1.E-8))THEN
C         WRITE(6,*)'RAC=0'
          IF (ABS(ABS(CO)-1).LT.(1.E-6))THEN
            F1=(D2+PS1)*(LOG(D4)-2)-(PS1*(LOG(D32)-2))
            F1=F1/D2/2
          ELSE
            F1=LOG(D2)-1
          ENDIF
          RETURN
      ENDIF
      F1=(D2+PS1)*(LOG(D4)-2)+2*RAC*ATAN((D2+PS1)/RAC)
      F1=F1-(PS1*LOG(D32)-2*PS1+2*RAC*ATAN(PS1/RAC))
      F1=F1/2/D2
C     WRITE(7,*)'F1=',F1
      RETURN
      END