C CCOTRO    SOURCE    OF166741  25/02/20    21:15:24     12165          
      SUBROUTINE CCOTRO(WRK52,WRK53,WRK2,NCOURB,MVEL1)
C COTROR    SOURCE    AM        96/11/25    21:16:25     2398
C COTROR    SOURCE    BROC      89/07/19    21:22:26
c      SUBROUTINE COTROR(WRK0,WRK2,NCOURB,MVEL1,KERRE)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMEVOLL
-INC SMLREEL
-INC DECHE
      SEGMENT/WRK2/(TRAC(LTRAC)*D)
      DATA NCOMAX/130/
      KERRE=0
      MEVOLL=MVEL1
      IF(MEVOLL.EQ.0) THEN
      KERRE=37
      RETURN
      ENDIF
      SEGACT MEVOLL
      KEVOLL=IEVOLL(1)
      SEGACT KEVOLL
      MLREEL=IPROGX
      MLREE1=IPROGY
      SEGDES KEVOLL
      SEGACT MLREEL,MLREE1
      NBPOIX=PROG(/1)
      NBPOIY=MLREE1.PROG(/1)
      IF(NBPOIX.GT.NCOMAX+1) KERRE=31
      IF(NBPOIX.LT.3)        KERRE=32
      IF(KERRE.EQ.0) GO TO 693
 692  CONTINUE
C
C   ERREUR
C
      SEGDES MLREEL,MLREE1
      SEGDES MEVOLL
      GO TO 777
 693  CONTINUE
C
C   TESTS SUR LES POINTS DE LA COURBE   ( A COMPLETER )
C
      YUNG=XMAT(1)
      IF(YUNG.EQ.0.D0) THEN
      KERRE=34
      GO TO 692
      ENDIF
      PSIG=MLREE1.PROG(1)
      PEPS=PROG(1)
      IF(PSIG.NE.0.D0.OR.PEPS.NE.0.D0) THEN
      KERRE=35
      GO TO 692
      ENDIF
C
C  VERIF DE LA LIMITE ELASTIQUE NON NULLE
C
      PSIG =MLREE1.PROG(1)
      PEPS=PROG(1)
      PENTE=PSIG/PEPS
      RA=ABS(PENTE-YUNG)/YUNG
      IF(RA.GT.5.D-3) THEN
      KERRE=36
      GO TO 692
      ENDIF
C
C  VERIF DE LA PENTE
C
      DO 100 I=3,NBPOIX
      I1=I-1
      DEPS=PROG(I)-PROG(I1)
      IF(DEPS.EQ.0.D0) THEN
      KERRE=33
      GO TO 692
      ENDIF
      PENTE=(MLREE1.PROG(I)-MLREE1.PROG(I1))/DEPS
      IF(PENTE.GE.YUNG) THEN
      KERRE=33
      GO TO 692
      ENDIF
 100  CONTINUE
      TRAC(1)=MLREE1.PROG(1)
      TRAC(2)=0.D0
      NCOURB=1
      DO 695 I=2,NBPOIX
       PSIG=MLREE1.PROG(I)
       PEPS=PROG(I)
       NCOURB=NCOURB+1
       TRAC(2*NCOURB-1)=PSIG
       TRAC(2*NCOURB)=PEPS
  695 CONTINUE
C
      SEGDES MLREEL,MLREE1
      SEGDES MEVOLL
      RETURN
C
  777 CONTINUE
      RETURN
      END