Sources Esope | Cast3M

cotraj
C COTRAJ    SOURCE    OF166741  25/09/30    21:15:13     12371          
 
      SUBROUTINE COTRAJ(wrk52,wrk53,WRK2,NUCO,IPOS,NSUP,NPOINT)
C-----------------------------------------------------------------
C
C     RECUPERAGE DE COURBE (RELATIVEMENT GENERAL)
C
C     NUCO   : COMPOSANTE DE XMAT DONNANT L'EVOLUTION
C     IPOS   : DEBUT DE STOCKAGE DE LA COURBE DANS TRAC
C     NSUP   : NOMBRE DE POINT A SUPPRIMER
C     NPOINT : NOMBRE DE POINT STOCKE
C
C-----------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMEVOLL
-INC SMLREEL
-INC DECHE
      SEGMENT WRK2
        REAL*8 TRAC(LTRAC)
      ENDSEGMENT
*
*     QUELQUES INITIALISATIONS A 0
*
      KERRE=0
      NPOINT=0
      LTRAC=TRAC(/1)
      CALL ZDANUL(TRAC(IPOS),LTRAC-IPOS+1)
*
*     LOIS
*
      MEVOLL=nint(XMAT(NUCO))
      IF(MEVOLL.EQ.0) THEN
        KERRE=37
        RETURN
      ENDIF
      SEGACT MEVOLL
      IF(IEVOLL(/1).NE.1) THEN
        KERRE=31
        RETURN
      ENDIF
*
*     COURBE  ( SELON Y )
*
      KEVOLL=IEVOLL(1)
      SEGDES MEVOLL
      SEGACT KEVOLL
      MLREEL=IPROGX
      MLREE1=IPROGY
      SEGDES KEVOLL
      SEGACT MLREEL,MLREE1
      NBPOIX=PROG(/1)
      NBPOIY=MLREE1.PROG(/1)
*
*   ERREUR
*
      IF(NBPOIX.NE.NBPOIY) KERRE=31
      IF(2*(NBPOIX-NSUP).GT.LTRAC-IPOS+1) KERRE=31
      IF (KERRE.NE.0) RETURN
*
      IF (NSUP.GT.0)THEN
        PSUP= mlreel.PROG(NSUP+1)
      ELSE
        PSUP=0.D0
      ENDIF
      NCOURB=0
      DO I=NSUP+1,NBPOIX
        NCOURB=NCOURB+1
        TRAC(IPOS+2*NCOURB-2)= MLREEL.PROG(I)-PSUP
        TRAC(IPOS+2*NCOURB-1)= MLREE1.PROG(I)
      ENDDO
 
      NPOINT=2*NCOURB
C
      SEGDES MLREEL,MLREE1
 
      RETURN
      END