Télécharger la plaquette Cast3M


fr en

Télécharger indeta.eso

Retour à la liste

Numérotation des lignes : 

indeta

  1. C INDETA    SOURCE    JC220346  18/12/04    21:15:29     9991           
  2.       SUBROUTINE INDETA
  3. C-----------------------------------------------------------------------
  4. C    FABRIQUE L'INDEX D'UNE TABLE              DANS UNE TABLE          |
  5. C    RECUPERE TOUS LES OBJETS NOMMES D'UN TYPE DANS UNE TABLE          |
  6. C-----------------------------------------------------------------------
  7.  
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8(A-H,O-Z)
  10.  
  11. -INC CCNOYAU
  12. -INC SMTABLE
  13.  
  14. -INC PPARAM
  15. -INC CCOPTIO
  16. -INC TMLNOMS
  17.  
  18.       LOGICAL LOGI,LVAL
  19.       REAL*8 XVA
  20.       CHARACTER*(1) CHARI
  21.       CHARACTER*512 IMO
  22.       CHARACTER*(LONOM) CNOM
  23.       CHARACTER*8 CTYP,CTYP2,CVAL
  24.  
  25.  
  26.       PARAMETER (NMO=36)
  27.       CHARACTER*(8) LISMO(NMO)
  28.       DATA LISMO / 'MOT     ','ENTIER  ','FLOTTANT','LOGIQUE ',
  29.      $             'MAILLAGE','LISTENTI','POINT   ','LISTREEL',
  30.      $             'CHPOINT ','RIGIDITE','TEXTE   ','STRUCTUR',
  31.      $             'ATTACHE ','SOLUTION','BASEMODA','--------',
  32.      $             '--------','VECTDOUB','LISTMOTS','DEFORME ',
  33.      $             'LISTCHPO','CHARGEME','EVOLUTIO','--------',
  34.      $             'VECTEUR ','TABLE   ','PROCEDUR','ELEMSTRU',
  35.      $             'BLOQSTRU','MCHAML  ','MMODEL  ','ANNULE  ',
  36.      $             'NUAGE   ','MATRIK  ','OBJET   ','ESCLAVE ' /
  37.  
  38.  
  39. C     Syntaxe qui fait l'index d'un type d'OBJET Cast3M (Indexation par leurs noms dans la pile des objets nommes)
  40.       CALL LIRCHA(IMO,0,IRETOU)
  41.       IF(IERR.NE.0) RETURN
  42.       IF ((IRETOU .EQ. 0) .OR. (IMO(1:1).NE.'*'))     GOTO 100
  43.  
  44.       CTYP = IMO(2:9)
  45.  
  46.       IF (CTYP .EQ. '        ') THEN
  47. C       Lecture OBLIGATOIRE d'un autre MOT
  48.         CALL LIRCHA(CTYP,1,IRETOU)
  49.       ENDIF
  50.  
  51. C     Creation de la TABLE de resultats
  52.       M=0
  53.       SEGINI,MTABLE
  54.  
  55. C     Recuperation de la liste des noms des objets de ce type
  56.       CALL  REPLIS(CTYP,MLNOMS)
  57.  
  58.       IF (LINOMS(/2) .EQ. 0) THEN
  59. C       Cas où la liste est vide
  60.         MOTERR(1:8)=CTYP
  61.         CALL ERREUR(-14)
  62.       ELSE
  63. C       Cas où la liste n'est pas vide
  64.         DO I=1,LINOMS(/2)
  65. C         Recherche du numero de pointeur associe au nom
  66.           CTYP2='        '
  67.           CNOM=LINOMS(I)
  68.           IVAL=0
  69.           RVAL=0.D0
  70.           CVAL='        '
  71.           LVAL=.FALSE.
  72.           IOBJ=0
  73.           CALL CQUOI(CNOM,CTYP2,IVAL,RVAL,CVAL,LVAL,IOBJ)
  74.  
  75. C         Ecriture dans la table du TYPE CTYP
  76.           CALL ECCTAB(MTABLE,'MOT     ',0,0.d0,CNOM,.FALSE.,0,
  77.      &                        CTYP,IVAL,RVAL,CVAL,LVAL,IOBJ)
  78.         ENDDO
  79.       ENDIF
  80.  
  81.       SEGSUP MLNOMS
  82. C     Ecriture de l'objet TABLE resultat
  83.  20   CONTINUE
  84.       CALL ECROBJ('TABLE   ',MTABLE)
  85.       RETURN
  86.  
  87.  
  88.  100  CONTINUE
  89. C     Syntaxe qui fait l'index d'une table (Indexation par des entiers)
  90.       CALL LIROBJ('TABLE   ',ITAB,1,IRETOU)
  91.       IF(IERR.NE.0) RETURN
  92.  
  93.       MTABLE=ITAB
  94.       SEGACT MTABLE
  95.       NB=MLOTAB
  96.       IF(NB.EQ.0) GOTO 99
  97.       M=NB
  98.       SEGINI MTAB1
  99.       MTAB1.MLOTAB=M
  100.  
  101.       DO 10 IJ=1,NB
  102.         CALL QUERAN(IRET,'ENTIER  ',IJ,XVA,CHARI,LOGI,IOB)
  103.         MTAB1.MTABTI(IJ)='ENTIER  '
  104.         MTAB1.MTABII(IJ)=IRET
  105.         MTAB1.MTABTV(IJ)=MTABTI(IJ)
  106.         IF (MTABTI(IJ).EQ.'FLOTTANT') THEN
  107.           MTAB1.RMTABV(IJ)=RMTABI(IJ)
  108.         ELSE
  109.           MTAB1.MTABIV(IJ)=MTABII(IJ)
  110.         ENDIF
  111.   10  CONTINUE
  112.  
  113.       SEGDES MTAB1,MTABLE
  114.       CALL ECROBJ('TABLE   ',MTAB1)
  115.       RETURN
  116.  
  117.    99 CONTINUE
  118.       CALL CRTABL(ita1)
  119.       CALL ECROBJ('TABLE   ',ita1)
  120.       RETURN
  121.  
  122.       END
  123.  
  124.  
  125.  
  126.  

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