Télécharger indeta.eso

Retour à la liste

Numérotation des lignes :

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

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