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    SP204843  24/08/26    21:15:03     11990          
  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.             JGN = NUAMOT(/1)
  86.             JGM = IDIM
  87.             SEGINI,MLMOTS
  88.             DO 300 I=1,IDIM
  89.                MOTS(I) = NUAMOT(I)
  90.  300        CONTINUE
  91.             CALL ECROBJ('LISTMOTS',MLMOTS)
  92.           ELSE
  93.             MVAL = NUAMOT(1)
  94. C           SEGDES NUAVMO
  95. C           SEGDES MNUAGE
  96.             CALL ECRCHA(MVAL)
  97.           ENDIF
  98.           RETURN
  99.        ELSE
  100.           IPO2 = NUAPOI(IPOSI)
  101.           NUAVIN = IPO2
  102.           SEGACT NUAVIN
  103.           IDIM = NUAINT(/1)
  104.           IF (IDIM.NE.1) THEN
  105.             NOBJ = IDIM
  106.             SEGINI,MLOBJE
  107.             TYPOBJ = TYP1
  108.             DO 400 I=1,IDIM
  109.                LISOBJ(I) = NUAINT(I)
  110.  400        CONTINUE
  111.             CALL ECROBJ('LISTOBJE',MLOBJE)
  112.           ELSE
  113.             IPO3 = NUAINT(1)
  114. C           SEGDES NUAVIN
  115. C           SEGDES MNUAGE
  116.             CALL ECROBJ(TYP1,IPO3)
  117.           ENDIF
  118.           RETURN
  119.        ENDIF
  120.  
  121.        END
  122.  
  123.  
  124.  
  125.  

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