Télécharger la plaquette Cast3M


fr en

Télécharger extr50.eso

Retour à la liste

Numérotation des lignes : 

extr50

  1. C EXTR50    SOURCE    CHAT      05/01/12    23:52:38     5004
  2.         SUBROUTINE EXTR50(IPOINT,BORNINF,XVAL,IPOSI)
  3.  
  4. **********************************************************************
  5. *
  6. *   Extraction de la borne inf. ou sup. d'un objet NUAGE selon
  7. *   les donnees du nom d'une composante reelle et de sa valeur
  8. *
  9. *    INTEGER   (E)   IPOINT   pointeur sur un objet NUAGE
  10. *    LOGICAL   (E)   BORNINF  logique valant vrai si l'on veut la
  11. *                             borne inf. du nuage
  12. *    FLOTTANT  (E)   XVAL     valeur de la composante reelle pour
  13. *                             laquelle on desire le n-uplet inferieur
  14. *                             ou superieur
  15. *    INTEGER   (E)   IPOSI    Position informatique de la composante
  16. *                             reelle du nuage
  17. *
  18. ***********************************************************************
  19.  
  20.       IMPLICIT INTEGER(I-N)
  21. -INC SMNUAGE
  22.  
  23.         REAL*8      XVAL,XVAL1,XVAL2,XVAL3
  24.         INTEGER     IPOINT,IPOSI,IPO2,IPOSI3,IDIM2
  25.         LOGICAL     BORNINF,BORNSUP
  26.         CHARACTER*8 TYPR
  27.  
  28.         BORNSUP = .NOT.BORNINF
  29.  
  30.         MNUAG1 = IPOINT
  31.         SEGACT MNUAG1
  32.         IDIM1 = MNUAG1.NUANOM(/2)
  33.         TYPR = MNUAG1.NUATYP(IPOSI)
  34.         IF (TYPR.NE.'FLOTTANT') THEN
  35.            SEGDES MNUAG1
  36. *- Le nom de la composante ne correspond pas a des variables reelles -
  37.            CALL ERREUR(671)
  38.            RETURN
  39.         ENDIF
  40.         NUAVF1 = MNUAG1.NUAPOI(IPOSI)
  41.         SEGACT NUAVF1
  42.         IDIM2 = NUAVF1.NUAFLO(/1)
  43.         XVAL1 = NUAVF1.NUAFLO(1)
  44.         IPOSI3 = 0
  45.         IF (XVAL1.LE.XVAL.AND.BORNINF) THEN
  46.             IPOSI3 = 1
  47.             XVAL3 = XVAL1
  48.         ENDIF
  49.         IF (XVAL1.GE.XVAL.AND.BORNSUP) THEN
  50.             IPOSI3 = 1
  51.             XVAL3 = XVAL1
  52.         ENDIF
  53.  
  54.         IF (IDIM2.GT.1) THEN
  55.            DO 11 I=2,IDIM2
  56.               XVAL2 = NUAVF1.NUAFLO(I)
  57.               IF (BORNINF) THEN
  58.                  IF (IPOSI3.NE.0) THEN
  59.                     IF ((XVAL2.GT.XVAL1).AND.(XVAL2.LE.XVAL)) THEN
  60.                        XVAL3 = XVAL2
  61.                        IPOSI3 = I
  62.                     ENDIF
  63.                  ELSE
  64.                     IF (XVAL2.LE.XVAL) THEN
  65.                        XVAL3 = XVAL2
  66.                        IPOSI3 = I
  67.                     ENDIF
  68.                  ENDIF
  69.               ELSE
  70.                  IF (IPOSI3.NE.0) THEN
  71.                     IF ((XVAL2.LT.XVAL1).AND.(XVAL2.GE.XVAL)) THEN
  72.                        XVAL3 = XVAL2
  73.                        IPOSI3 = I
  74.                     ENDIF
  75.                  ELSE
  76.                     IF (XVAL2.GE.XVAL) THEN
  77.                        XVAL3 = XVAL2
  78.                        IPOSI3 = I
  79.                     ENDIF
  80.                  ENDIF
  81.               ENDIF
  82.  11        CONTINUE
  83.         ENDIF
  84.         SEGDES NUAVF1
  85.  
  86. *----- La borne inf. ou sup. du NUAGE n'existe pas ----------------
  87.  
  88.         IF (IPOSI3.EQ.0) THEN
  89.            SEGDES MNUAG1
  90.            CALL ERREUR(669)
  91.            RETURN
  92.         ENDIF
  93.  
  94.         NVAR = IDIM1
  95.         NBCOUP = 1
  96.         SEGINI MNUAGE
  97.         IPO2 = MNUAGE
  98.         DO 10 I=1,IDIM1
  99.            NUANOM(I)=MNUAG1.NUANOM(I)
  100.            NUATYP(I)=MNUAG1.NUATYP(I)
  101.            IF (NUATYP(I).EQ.'INTEGER ') THEN
  102.               SEGINI NUAVIN
  103.               NUAPOI(I) = NUAVIN
  104.               NUAVI1 = MNUAG1.NUAPOI(I)
  105.               SEGACT NUAVI1
  106.               NUAINT(1) = NUAVI1.NUAINT(IPOSI3)
  107.               SEGDES NUAVI1
  108.               SEGDES NUAVIN
  109.            ELSE IF (NUATYP(I).EQ.'FLOTTANT') THEN
  110.               SEGINI NUAVFL
  111.               NUAPOI(I) = NUAVFL
  112.               NUAVF1 = MNUAG1.NUAPOI(I)
  113.               SEGACT NUAVF1
  114.               NUAFLO(1) = NUAVF1.NUAFLO(IPOSI3)
  115.               SEGDES NUAVF1
  116.               SEGDES NUAVFL
  117.            ELSE IF (NUATYP(I).EQ.'MOT     ') THEN
  118.               SEGINI NUAVMO
  119.               NUAPOI(I) = NUAVMO
  120.               NUAVM1 = MNUAG1.NUAPOI(I)
  121.               SEGACT NUAVM1
  122.               NUAMOT(1) = NUAVM1.NUAMOT(IPOSI3)
  123.               SEGDES NUAVM1
  124.               SEGDES NUAVMO
  125.            ELSE IF (NUATYP(I).EQ.'LOGIQUE ') THEN
  126.               SEGINI NUAVLO
  127.               NUAPOI(I) = NUAVLO
  128.               NUAVL1 = MNUAG1.NUAPOI(I)
  129.               SEGACT NUAVL1
  130.               NUALOG(1) = NUAVL1.NUALOG(IPOSI3)
  131.               SEGDES NUAVL1
  132.               SEGDES NUAVLO
  133.            ELSE
  134.               SEGINI NUAVIN
  135.               NUAPOI(I) = NUAVIN
  136.               NUAVI1 =  MNUAG1.NUAPOI(I)
  137.               SEGACT NUAVI1
  138.               NUAINT(1) = NUAVI1.NUAINT(IPOSI3)
  139.               SEGDES NUAVI1
  140.               SEGDES NUAVIN
  141.            END IF
  142.  10     CONTINUE
  143.  
  144.         SEGDES MNUAGE
  145.         SEGDES MNUAG1
  146.         CALL ECROBJ('NUAGE   ',IPO2)
  147.         RETURN
  148.         END
  149.  
  150.  
  151.  

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