Télécharger extr24.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTR24 SOURCE JC220346 16/04/25 21:15:08 8915
  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. *
  21. -INC CCOPTIO
  22. -INC SMLCHPO
  23. -INC SMCHPOI
  24. -INC SMELEME
  25. -INC SMCOORD
  26. -INC SMLREEL
  27. -INC SMLMOTS
  28. *
  29. CHARACTER*4 MCO
  30. *
  31. * NOMBRE D'OBJETS CHPOINT CONTENUS DANS LE LISTCHPO
  32. MLCHPO=ILCHP
  33. SEGACT,MLCHPO
  34. NCH=ICHPOI(/1)
  35. *
  36. *
  37. * INITIALISATION DE LA LISTE DE REELS RENVOYEE EN SORTIE
  38. MLMOTS=ILMOT
  39. IF (ILMOT.EQ.0) THEN
  40. NCO=1
  41. KCO=1
  42. JG=NCH
  43. ELSE
  44. SEGACT,MLMOTS
  45. NCO=MOTS(/2)
  46. JG=NCH*NCO
  47. IF (NCO.EQ.0) THEN
  48. CALL ERREUR(643)
  49. RETURN
  50. ENDIF
  51. ENDIF
  52. SEGINI,MLREEL
  53. ILREE=MLREEL
  54.  
  55.  
  56. ICH=0
  57.  
  58. * (label 1 = boucle sur les CHPOINT)
  59. 1 CONTINUE
  60. IF (ICH.EQ.NCH) RETURN
  61. ICH=ICH+1
  62. MCHPOI=ICHPOI(ICH)
  63. SEGACT,MCHPOI
  64. NSOUPO=IPCHP(/1)
  65.  
  66. IF (ILMOT.EQ.0.AND.NSOUPO.GT.1) GOTO 999
  67.  
  68. ISOUPO=0
  69.  
  70. * (label 10 = boucle sur les SOUPO)
  71. 10 CONTINUE
  72. IF (ISOUPO.EQ.NSOUPO) THEN
  73. SEGDES,MCHPOI
  74. GOTO 1
  75. ENDIF
  76. ISOUPO=ISOUPO+1
  77. MSOUPO=IPCHP(ISOUPO)
  78. SEGACT,MSOUPO
  79.  
  80. NCOCH=NOCOMP(/2)
  81. IF (ILMOT.EQ.0.AND.NCOCH.GT.1) GOTO 999
  82.  
  83. ICO=0
  84.  
  85. * (label 20 = boucle sur les composantes demandees dans le LISTMOTS)
  86. 20 CONTINUE
  87. IF (ICO.EQ.NCO) GOTO 90
  88. ICO=ICO+1
  89.  
  90. * on recherche la composante requise dans le SOUPO/NOCOMP courant
  91. IF (ILMOT.NE.0) THEN
  92. DO KCO=1,NCOCH
  93. IF (NOCOMP(KCO).EQ.MOTS(ICO)) GOTO 30
  94. ENDDO
  95. KCO=0
  96. GOTO 20
  97. ENDIF
  98. *
  99. 30 CONTINUE
  100. MELEME=IGEOC
  101. MPOVAL=IPOVAL
  102. SEGACT,MELEME,MPOVAL
  103. NPOI1=NUM(/2)
  104. IF (NBNO.EQ.0) GOTO 90
  105. *
  106. * on recherche le noeud requis dans le SOUPO/MPOVAL courant
  107. DO KNO=1,NPOI1
  108. IF (NUM(1,KNO).EQ.IPOIN) GOTO 40
  109. ENDDO
  110. GOTO 90
  111. *
  112. 40 CONTINUE
  113. PROG((ICO-1)*NCH+ICH)=VPOCHA(KNO,KCO)
  114. GOTO 20
  115. *
  116. *
  117. *
  118. 90 IF (KCO.GT.0) SEGDES,MELEME,MPOVAL
  119. SEGDES,MSOUPO
  120. GOTO 10
  121. *
  122. ************************************************************************
  123. *
  124. 999 CALL ERREUR(641)
  125. RETURN
  126. *
  127. *
  128. RETURN
  129. *
  130. END
  131. *
  132. *
  133.  

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