Télécharger extr53.eso

Retour à la liste

extr53
C EXTR53    SOURCE    CHAT      05/01/12    23:52:53     5004
        SUBROUTINE EXTR53(IPOINT,XVAL1,XVAL2,IPOSI)
 
**********************************************************************
*
*   Extraction du sous-NUAGE compris entre deux valeurs réelles
*   correspondant a une composante de type FLOTTANT
*
*    INTEGER   (E)   IPOINT   pointeur sur un objet NUAGE
*    FLOTTANT  (E)   XVAL1    valeur des composantes reelles entre
*    FLOTTANT  (E)   XVAL2    lesquelles on desire extraire le nuage
*    INTEGER   (E)   IPOSI    Position informatique de la composante
*                             reelle du nuage
*
***********************************************************************
 
      IMPLICIT INTEGER(I-N)
-INC SMNUAGE
-INC SMLENTI
 
        REAL*8      XVAL1,XVAL2,XVAL3,BORN1,BORN2
        INTEGER     IPOINT,IPOSI,IPO2,IDIM2,IDIM3,JG,IPOSI3,IDIM1
        CHARACTER*8 TYPR
 
        IF (XVAL1.LT.XVAL2) THEN
           BORN1 = XVAL1
           BORN2 = XVAL2
        ELSE
           BORN2 = XVAL1
           BORN1 = XVAL2
        ENDIF
 
        MNUAG1 = IPOINT
        SEGACT MNUAG1
        IDIM1 = MNUAG1.NUANOM(/2)
        TYPR = MNUAG1.NUATYP(IPOSI)
        IF (TYPR.NE.'FLOTTANT') THEN
           SEGDES MNUAG1
*- Le nom de la composante ne correspond pas a des variables reelles -
           CALL ERREUR(671)
           RETURN
        ENDIF
        NUAVF1 = MNUAG1.NUAPOI(IPOSI)
        SEGACT NUAVF1
        IDIM2 = NUAVF1.NUAFLO(/1)
        IDIM3 = 0
        DO 22 I2 = 1,IDIM2
           XVAL3 = NUAVF1.NUAFLO(I2)
           IF (XVAL3.LE.BORN2.AND.XVAL3.GT.BORN1) THEN
              IDIM3 = IDIM3 + 1
           ENDIF
 22     CONTINUE
 
        IF (IDIM3.EQ.0) THEN
          SEGDES MNUAG1
          SEGDES NUAVF1
*------ les deux valeurs réelles définissent un nuage "vide" --------
          CALL ERREUR (666)
          RETURN
        ENDIF
 
        JG = IDIM3
        SEGINI MLENTI
        ITE2 = 0
        DO 20 I=1,IDIM2
           XVAL3 = NUAVF1.NUAFLO(I)
           IF (XVAL3.LE.BORN2.AND.XVAL3.GT.BORN1) THEN
              ITE2 = ITE2 + 1
              LECT(ITE2) = I
           ENDIF
 20     CONTINUE
        SEGDES NUAVF1
 
        NVAR = IDIM1
        NBCOUP = IDIM3
        SEGINI MNUAGE
        IPO2 = MNUAGE
 
        DO 21 I = 1,IDIM3
           IPOSI3 =  LECT(I)
           DO 10 I2=1,IDIM1
              IF (I.EQ.1) THEN
                 NUANOM(I2)=MNUAG1.NUANOM(I2)
                 NUATYP(I2)=MNUAG1.NUATYP(I2)
              ENDIF
              IF (NUATYP(I2).EQ.'INTEGER ') THEN
                 IF (I.EQ.1) THEN
                    SEGINI NUAVIN
                    NUAPOI(I2) = NUAVIN
                 ELSE
                    NUAVIN = NUAPOI(I2)
                    SEGACT NUAVIN
                 ENDIF
                 NUAVI1 = MNUAG1.NUAPOI(I2)
                 SEGACT NUAVI1
                 NUAINT(I) = NUAVI1.NUAINT(IPOSI3)
                 SEGDES NUAVI1
                 SEGDES NUAVIN
              ELSE IF (NUATYP(I2).EQ.'FLOTTANT') THEN
                 IF (I.EQ.1) THEN
                    SEGINI NUAVFL
                    NUAPOI(I2) = NUAVFL
                 ELSE
                    NUAVFL = NUAPOI(I2)
                    SEGACT NUAVFL
                 ENDIF
                 NUAVF1 = MNUAG1.NUAPOI(I2)
                 SEGACT NUAVF1
                 NUAFLO(I) = NUAVF1.NUAFLO(IPOSI3)
                 SEGDES NUAVF1
                 SEGDES NUAVFL
              ELSE IF (NUATYP(I2).EQ.'MOT     ') THEN
                 IF (I.EQ.1) THEN
                    SEGINI NUAVMO
                    NUAPOI(I2) = NUAVMO
                 ELSE
                    NUAVMO = NUAPOI(I2)
                    SEGACT NUAVMO
                 ENDIF
                 NUAVM1 = MNUAG1.NUAPOI(I2)
                 SEGACT NUAVM1
                 NUAMOT(I) = NUAVM1.NUAMOT(IPOSI3)
                 SEGDES NUAVM1
                 SEGDES NUAVMO
              ELSE IF (NUATYP(I2).EQ.'LOGIQUE ') THEN
                 IF (I.EQ.1) THEN
                    SEGINI NUAVLO
                    NUAPOI(I2) = NUAVLO
                 ELSE
                    NUAVLO = NUAPOI(I2)
                    SEGACT NUAVLO
                 ENDIF
                 NUAVL1 = MNUAG1.NUAPOI(I2)
                 SEGACT NUAVL1
                 NUALOG(I) = NUAVL1.NUALOG(IPOSI3)
                 SEGDES NUAVL1
                 SEGDES NUAVLO
              ELSE
                 IF (I.EQ.1) THEN
                    SEGINI NUAVIN
                    NUAPOI(I2) = NUAVIN
                 ELSE
                    NUAVIN = NUAPOI(I2)
                    SEGACT NUAVIN
                 ENDIF
                 NUAVI1 =  MNUAG1.NUAPOI(I2)
                 SEGACT NUAVI1
                 NUAINT(I) = NUAVI1.NUAINT(IPOSI3)
                 SEGDES NUAVI1
                 SEGDES NUAVIN
              END IF
 10        CONTINUE
 21     CONTINUE
 
        SEGDES MLENTI
        SEGDES MNUAGE
        SEGDES MNUAG1
        CALL ECROBJ('NUAGE   ',IPO2)
        RETURN
        END
 
 
 

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