Sources Esope | Cast3M

cotrab
C COTRAB    SOURCE    OF166741  25/09/30    21:15:08     12371          
 
      SUBROUTINE COTRAB(IMAT,TRAC,LTRAC,IPOS,NSUP,NPOINT,KERRE)
 
C-----------------------------------------------------------------
C
C     RECUPERATION DE COURBE (RELATIVEMENT GENERAL)
C
C     IPOS   : DEBUT DE STOCKAGE DE LA COURBE DANS TRAC
C     NSUP   : NOMBRE DE POINTS A SUPPRIMER
C     NPOINT : NOMBRE DE POINTS STOCKES
C
C-----------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC SMEVOLL
-INC SMLREEL
 
      DIMENSION TRAC(LTRAC)
 
      KERRE=0
 
      MEVOLL=IMAT
      IF (MEVOLL.EQ.0) THEN
        KERRE=354
        RETURN
      ENDIF
      SEGACT,MEVOLL
      IF (mevoll.IEVOLL(/1).NE.1) THEN
        KERRE=271
        GOTO 9991
      ENDIF
*
*     COURBE (SELON Y)
*
      KEVOLL = mevoll.IEVOLL(1)
 
      SEGACT,KEVOLL
      MLREEL=IPROGX
      MLREE1=IPROGY
      SEGACT,MLREEL,MLREE1
 
      NBPOIX=PROG(/1)
      NPOINT=2*(NBPOIX-NSUP)
 
      IF (NBPOIX.NE.MLREE1.PROG(/1)) KERRE=271
      IF (NPOINT.LE.0) KERRE=271
      IF (NPOINT.GT.LTRAC-IPOS+1) KERRE=271
      IF (KERRE.NE.0) GOTO 999
 
      IF (NSUP.GT.0) THEN
        PSUP=MLREEL.PROG(NSUP+1)
      ELSE
        PSUP=0.D0
      ENDIF
 
      NCOUR=IPOS
      DO I=NSUP+1,NBPOIX
        TRAC(NCOUR  ) = MLREEL.PROG(I)-PSUP
        TRAC(NCOUR+1) = MLREE1.PROG(I)
        NCOUR=NCOUR+2
      ENDDO
 
 999  CONTINUE
C*//  SEGDES,MLREEL,MLREE1
C*//  SEGDES,KEVOLL
 9991 CONTINUE
C*//  SEGDES,MEVOLL
 
      RETURN
      END