Télécharger raflre.eso

Retour à la liste

raflre
C RAFLRE    SOURCE    PASCAL    20/06/08    21:15:10     10623          
      SUBROUTINE RAFLRE(ILRE1,KR1,XR1,ICAS,ILRE2)
C----------------------------------------------------------------------C
C     Sous-programme de raffinement d'un LISTREEL (Operateur RAFF)     C
C----------------------------------------------------------------------C
C
C Syntaxe   : LRE2 = RAFF LRE1 | ENT1 ;
C                              | FLOT1 ;
C
C Entrees :
C - ILRE1 : pointeur sur LISTREEL
C - KR1   : ENTIER, nb de coupes de chaque intervalles
C - XR1   : FLOTTANT, taille cible des intervalles
C - ICAS  : ICAS = 1 : syntaxe avec un entier
C           ICAS = 2 : syntaxe avec un flottant
C
C Sortie  :
C - ILRE2 : pointeur sur LISTREEL resultat
C   
C----------------------------------------------------------------------C
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER(I-N)
C
-INC SMLREEL
-INC CCREEL
-INC PPARAM
-INC CCOPTIO
C
      MLREEL = ILRE1
      SEGACT,MLREEL
      NL1 = PROG(/1)
C
C---- CAS OU LE LISTREEL EST VIDE OU N'A QU'UNE SEULE VALEUR
C     => on le renvoie en sortie
      IF (NL1.LE.1) THEN
        ILRE2 = ILRE1
        RETURN
      ENDIF 
 
C---- ANALYSE DES ARGUMENTS si donnee d'un ENTIER :
      IF (ICAS.EQ.1) THEN
C
C       Si LE NOMBRE DE COUPES EST EGAL A 1 OU -1
C       => on renvoie le LISTREEL en entree (identite)
        IF (ABS(KR1).EQ.1) THEN
          ILRE2 = ILRE1
          RETURN
        ENDIF
C
C       Si LE NOMBRE DE COUPES EST NUL => erreur
        IF (KR1.EQ.0) THEN
          INTERR(1) = KR1
          CALL ERREUR(36)
          RETURN
        ENDIF
 
C---- Cas donnee d'un FLOTTANT
      ELSEIF (ICAS.EQ.2) THEN
        KR1 = 1
      ELSE
        CALL ERREUR(5)
        RETURN
      ENDIF
C
C---- CAS GENERAL
C     Initialisation du LISTREEL resultat
      JG = ABS(KR1)*(NL1-1)+1
      JG = 5*JG
      SEGINI,MLREE1
      ILRE2 = MLREE1
C
C     Sous-decoupage des intervalles
      XKR1 = REAL(KR1)
      VAL1 = MLREEL.PROG(1)
      DVI1 = 0.D0
      ICP1 = 1 
      MLREE1.PROG(ICP1) = VAL1 
      DO 20 I=2,NL1
        VAL2 = MLREEL.PROG(I)
        DVI2 = VAL2 - VAL1
C        IF (I.EQ.2) DVI1 = DVI2
        VALM = MAX(VAL1,VAL2)
        TOL1 = MAX(XZPREC*VALM,XPETIT)
        IF (ABS(DVI2).GT.TOL1) THEN
C         write(6,*) 'Cas DVI2 non nul'
          IF (ICAS.EQ.2) THEN
            IF (ABS(XR1).LT.TOL1) THEN
              REAERR(1) = XR1
              CALL ERREUR(1009)
              RETURN
            ELSE
              XKR1 = DVI2/XR1
              KR1  = INT(XKR1+0.5D0)
              KR1   = MAX(1,KR1)
            ENDIF
          ENDIF
          DEN2 = 1.D0 / ABS(XKR1)
          IF(ABS(DVI1).GT.TOL1.AND.ICAS.EQ.1)THEN
            DEN1 = ABS(DVI1 / (XKR1 * DVI2))
          ELSE
            DEN1 = DEN2
          ENDIF
C         Si FLOT1 donne, alors KR1 peut valoir 1
          IF (KR1.GT.1) THEN
C           Appel a decoup 
C           write(6,*) 'DEN1, DEN2',DEN1,DEN2
            KR2  = KR1
            CALL DECOUP(KR2,DEN1,DEN2,A1,NBE,DENI,DECA,DVI2)
C           write(6,*) 'NBE,A1,DENI = ',NBE,A1,DENI
            XVA1 = A1*DENI
            XVA1 = XVA1 + VAL1
            ICP1 = ICP1 + 1
            IF(ICP1 .GT. JG)THEN
              JG = ICP1*2 + 20
              SEGADJ,MLREE1
            ENDIF
            MLREE1.PROG(ICP1) = XVA1
            XXVA = XVA1
            DO 21 J=1,NBE-2
              XXVA = A1*(XXVA - VAL1) + XVA1
              ICP1 = ICP1 + 1
              IF(ICP1 .GT. JG)THEN
                JG = ICP1*2 + 20
                SEGADJ,MLREE1
              ENDIF
              MLREE1.PROG(ICP1) = XXVA
 21         CONTINUE
          ENDIF
          ICP1 = ICP1 + 1
          IF(ICP1 .GT. JG)THEN
            JG = ICP1*2 + 20
            SEGADJ,MLREE1
          ENDIF
          MLREE1.PROG(ICP1) = VAL2
        ELSE
C         write(6,*) 'Cas DVI2 nul'
          IF (ICAS.EQ.2) KR1 = 1
          DO 22 J=1,ABS(KR1)
            ICP1 = ICP1 + 1
            IF(ICP1 .GT. JG)THEN
              JG = ICP1*2 + 20
              SEGADJ,MLREE1
            ENDIF
            MLREE1.PROG(ICP1) = MLREE1.PROG(ICP1-1)
 22       CONTINUE
        ENDIF
        DVI1 = DVI2
        VAL1 = VAL2 
 20   CONTINUE
      JG = ICP1
      SEGADJ,MLREE1
 
      SEGACT,MLREE1*NOMOD
C
      END
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales