Télécharger la plaquette Cast3M


fr en

Télécharger extr51.eso

Retour à la liste

Numérotation des lignes : 

extr51

  1. C EXTR51    SOURCE    PASCAL    22/11/22    21:15:02     11507          
  2.         SUBROUTINE EXTR51(IPO1,IPOSI)
  3. **********************************************************************
  4. *
  5. *     Extraction de l'objet contenu dans un NUAGE "colonne"
  6. *          Correspondant a une composante donnee
  7. *
  8. *   INTEGER    (E)   IPO1   pointeur sur l'objet NUAGE
  9. *   INTEGER    (E)   IPOSI  position informatique de la composante
  10. *                           souhaitee
  11. *
  12. **********************************************************************
  13.       IMPLICIT INTEGER(I-N)
  14. -INC SMNUAGE
  15. -INC SMLREEL
  16. -INC SMLENTI
  17. -INC SMLMOTS
  18. -INC SMLOBJE
  19.  
  20.        INTEGER     IPO1,IPO2,IPO3,IPOSI,IDIM,IVAL
  21.        CHARACTER*8 TYP1,MVAL
  22.        LOGICAL     LVAL
  23.        REAL*8      XVAL
  24.  
  25.        MNUAGE = IPO1
  26.        SEGACT MNUAGE
  27.        TYP1 = NUATYP(IPOSI)
  28.        IF (TYP1.EQ.'FLOTTANT') THEN
  29.           NUAVFL = NUAPOI(IPOSI)
  30.           SEGACT NUAVFL
  31.           IDIM = NUAFLO(/1)
  32.           IF (IDIM.NE.1) THEN
  33.             JG = IDIM
  34.             SEGINI,MLREEL
  35.             DO 100 I=1,IDIM
  36.                PROG(I) = NUAFLO(I)
  37.  100        CONTINUE
  38.             CALL ECROBJ('LISTREEL',MLREEL)
  39.           ELSE 
  40.             XVAL = NUAFLO(1)
  41. C           SEGDES NUAVFL
  42. C           SEGDES MNUAGE
  43.             CALL ECRREE(XVAL)
  44.           ENDIF
  45.           RETURN
  46.        ELSE IF (TYP1.EQ.'ENTIER') THEN
  47.           NUAVIN = NUAPOI(IPOSI)
  48.           SEGACT NUAVIN
  49.           IDIM = NUAINT(/1)
  50.           IF (IDIM.NE.1) THEN
  51.             JG = IDIM
  52.             SEGINI,MLENTI
  53.             DO 200 I=1,IDIM
  54.                LECT(I) = NUAINT(I)
  55.  200        CONTINUE
  56.             CALL ECROBJ('LISTENTI',MLENTI)
  57.           ELSE
  58.             IVAL = NUAINT(1)
  59. C           SEGDES NUAVIN
  60. C           SEGDES MNUAGE
  61.             CALL ECRENT(IVAL)
  62.           ENDIF
  63.           RETURN
  64.        ELSE IF (TYP1.EQ.'LOGIQUE ') THEN
  65.           NUAVLO = NUAPOI(IPOSI)
  66.           SEGACT NUAVLO
  67.           IDIM = NUALOG(/1)
  68.           IF (IDIM.NE.1) THEN
  69.              SEGDES NUAVLO
  70.              SEGDES MNUAGE
  71. *------------- Le nuage n'est pas un nuage "colonne" -------------
  72.              CALL ERREUR(670)
  73.              RETURN
  74.           ENDIF
  75.           LVAL = NUALOG(1)
  76.           SEGDES NUAVLO
  77.           SEGDES MNUAGE
  78.           CALL ECRLOG(LVAL)
  79.           RETURN
  80.        ELSE IF (TYP1.EQ.'MOT     ') THEN
  81.           NUAVMO = NUAPOI(IPOSI)
  82.           SEGACT NUAVMO
  83.           IDIM = NUAMOT(/2)
  84.           IF (IDIM.NE.1) THEN
  85.             JG = IDIM
  86.             SEGINI,MLMOTS
  87.             DO 300 I=1,IDIM
  88.                MOTS(I) = NUAMOT(I)
  89.  300        CONTINUE
  90.             CALL ECROBJ('LISTMOTS',MLMOTS)
  91.           ELSE
  92.             MVAL = NUAMOT(1)
  93. C           SEGDES NUAVMO
  94. C           SEGDES MNUAGE
  95.             CALL ECRCHA(MVAL)
  96.           ENDIF
  97.           RETURN
  98.        ELSE
  99.           IPO2 = NUAPOI(IPOSI)
  100.           NUAVIN = IPO2
  101.           SEGACT NUAVIN
  102.           IDIM = NUAINT(/1)
  103.           IF (IDIM.NE.1) THEN
  104.             NOBJ = IDIM
  105.             SEGINI,MLOBJE
  106.             TYPOBJ = TYP1
  107.             DO 400 I=1,IDIM
  108.                LISOBJ(I) = NUAINT(I)
  109.  400        CONTINUE
  110.             CALL ECROBJ('LISTOBJE',MLOBJE)
  111.           ELSE
  112.             IPO3 = NUAINT(1)
  113. C           SEGDES NUAVIN
  114. C           SEGDES MNUAGE
  115.             CALL ECROBJ(TYP1,IPO3)
  116.           ENDIF
  117.           RETURN
  118.        ENDIF
  119.  
  120.        END
  121.  
  122.  
  123.  

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