Télécharger extr24.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTR24 SOURCE PV 18/02/04 21:15:00 9731
  2. ************************************************************************
  3. * NOM : extr24
  4. * DESCRIPTION : Extrait les valeurs d'un LISTCHPO en un noeud donne
  5. ************************************************************************
  6. * APPELÉ PAR : extrai.eso ; crevlc.eso
  7. ************************************************************************
  8. * ENTRÉES :: aucune
  9. * SORTIES :: aucune
  10. ************************************************************************
  11. * SYNTAXE (GIBIANE) :
  12. *
  13. * LREEL1 = EXTR LCHPO1 'VALE' (MOT1 | LMOT1) (POIN1) ;
  14. *
  15. ************************************************************************
  16. SUBROUTINE EXTR24(ILCHP,ILMOT,IPOIN,ILREE)
  17. *
  18. IMPLICIT INTEGER(I-N)
  19. IMPLICIT REAL*8(A-H,O-Z)
  20. INTEGER NBNO
  21. *
  22. -INC CCOPTIO
  23. -INC SMLCHPO
  24. -INC SMCHPOI
  25. -INC SMELEME
  26. -INC SMCOORD
  27. -INC SMLREEL
  28. -INC SMLMOTS
  29. *
  30.  
  31. CHARACTER*4 MCO
  32. *
  33. * NOMBRE D'OBJETS CHPOINT CONTENUS DANS LE LISTCHPO
  34. NBNO = 0
  35. MLCHPO=ILCHP
  36. SEGACT,MLCHPO
  37. NCH=ICHPOI(/1)
  38. *
  39. *
  40. * INITIALISATION DE LA LISTE DE REELS RENVOYEE EN SORTIE
  41. MLMOTS=ILMOT
  42. IF (ILMOT.EQ.0) THEN
  43. NCO=1
  44. KCO=1
  45. JG=NCH
  46. ELSE
  47. SEGACT,MLMOTS
  48. NCO=MOTS(/2)
  49. JG=NCH*NCO
  50. IF (NCO.EQ.0) THEN
  51. CALL ERREUR(643)
  52. RETURN
  53. ENDIF
  54. ENDIF
  55. SEGINI,MLREEL
  56. ILREE=MLREEL
  57.  
  58.  
  59. ICH=0
  60.  
  61. * (label 1 = boucle sur les CHPOINT)
  62. 1 CONTINUE
  63. IF (ICH.EQ.NCH) RETURN
  64. ICH=ICH+1
  65. MCHPOI=ICHPOI(ICH)
  66. SEGACT,MCHPOI
  67. NSOUPO=IPCHP(/1)
  68.  
  69. IF (ILMOT.EQ.0.AND.NSOUPO.GT.1) GOTO 999
  70.  
  71. ISOUPO=0
  72.  
  73. * (label 10 = boucle sur les SOUPO)
  74. 10 CONTINUE
  75. IF (ISOUPO.EQ.NSOUPO) THEN
  76. SEGDES,MCHPOI
  77. GOTO 1
  78. ENDIF
  79. ISOUPO=ISOUPO+1
  80. MSOUPO=IPCHP(ISOUPO)
  81. SEGACT,MSOUPO
  82.  
  83. NCOCH=NOCOMP(/2)
  84. IF (ILMOT.EQ.0.AND.NCOCH.GT.1) GOTO 999
  85.  
  86. ICO=0
  87.  
  88. * (label 20 = boucle sur les composantes demandees dans le LISTMOTS)
  89. 20 CONTINUE
  90. IF (ICO.EQ.NCO) GOTO 90
  91. ICO=ICO+1
  92.  
  93. * on recherche la composante requise dans le SOUPO/NOCOMP courant
  94. IF (ILMOT.NE.0) THEN
  95. DO KCO=1,NCOCH
  96. IF (NOCOMP(KCO).EQ.MOTS(ICO)) GOTO 30
  97. ENDDO
  98. KCO=0
  99. GOTO 20
  100. ENDIF
  101. *
  102. 30 CONTINUE
  103. MELEME=IGEOC
  104. MPOVAL=IPOVAL
  105. SEGACT,MELEME,MPOVAL
  106. NPOI1=NUM(/2)
  107. *
  108. * on recherche le noeud requis dans le SOUPO/MPOVAL courant
  109. DO KNO=1,NPOI1
  110. IF (NUM(1,KNO).EQ.IPOIN) GOTO 40
  111. ENDDO
  112. GOTO 90
  113. *
  114. 40 CONTINUE
  115. PROG((ICO-1)*NCH+ICH)=VPOCHA(KNO,KCO)
  116. GOTO 20
  117. *
  118. *
  119. *
  120. 90 IF (KCO.GT.0) SEGDES,MELEME,MPOVAL
  121. SEGDES,MSOUPO
  122. GOTO 10
  123. *
  124. ************************************************************************
  125. *
  126. 999 CALL ERREUR(641)
  127. RETURN
  128. *
  129. *
  130. RETURN
  131. *
  132. END
  133. *
  134. *
  135.  
  136.  
  137.  

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