Télécharger extr50.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTR50 SOURCE CHAT 05/01/12 23:52:38 5004
  2. SUBROUTINE EXTR50(IPOINT,BORNINF,XVAL,IPOSI)
  3.  
  4. **********************************************************************
  5. *
  6. * Extraction de la borne inf. ou sup. d'un objet NUAGE selon
  7. * les donnees du nom d'une composante reelle et de sa valeur
  8. *
  9. * INTEGER (E) IPOINT pointeur sur un objet NUAGE
  10. * LOGICAL (E) BORNINF logique valant vrai si l'on veut la
  11. * borne inf. du nuage
  12. * FLOTTANT (E) XVAL valeur de la composante reelle pour
  13. * laquelle on desire le n-uplet inferieur
  14. * ou superieur
  15. * INTEGER (E) IPOSI Position informatique de la composante
  16. * reelle du nuage
  17. *
  18. ***********************************************************************
  19.  
  20. IMPLICIT INTEGER(I-N)
  21. -INC SMNUAGE
  22.  
  23. REAL*8 XVAL,XVAL1,XVAL2,XVAL3
  24. INTEGER IPOINT,IPOSI,IPO2,IPOSI3,IDIM2
  25. LOGICAL BORNINF,BORNSUP
  26. CHARACTER*8 TYPR
  27.  
  28. BORNSUP = .NOT.BORNINF
  29.  
  30. MNUAG1 = IPOINT
  31. SEGACT MNUAG1
  32. IDIM1 = MNUAG1.NUANOM(/2)
  33. TYPR = MNUAG1.NUATYP(IPOSI)
  34. IF (TYPR.NE.'FLOTTANT') THEN
  35. SEGDES MNUAG1
  36. *- Le nom de la composante ne correspond pas a des variables reelles -
  37. CALL ERREUR(671)
  38. RETURN
  39. ENDIF
  40. NUAVF1 = MNUAG1.NUAPOI(IPOSI)
  41. SEGACT NUAVF1
  42. IDIM2 = NUAVF1.NUAFLO(/1)
  43. XVAL1 = NUAVF1.NUAFLO(1)
  44. IPOSI3 = 0
  45. IF (XVAL1.LE.XVAL.AND.BORNINF) THEN
  46. IPOSI3 = 1
  47. XVAL3 = XVAL1
  48. ENDIF
  49. IF (XVAL1.GE.XVAL.AND.BORNSUP) THEN
  50. IPOSI3 = 1
  51. XVAL3 = XVAL1
  52. ENDIF
  53.  
  54. IF (IDIM2.GT.1) THEN
  55. DO 11 I=2,IDIM2
  56. XVAL2 = NUAVF1.NUAFLO(I)
  57. IF (BORNINF) THEN
  58. IF (IPOSI3.NE.0) THEN
  59. IF ((XVAL2.GT.XVAL1).AND.(XVAL2.LE.XVAL)) THEN
  60. XVAL3 = XVAL2
  61. IPOSI3 = I
  62. ENDIF
  63. ELSE
  64. IF (XVAL2.LE.XVAL) THEN
  65. XVAL3 = XVAL2
  66. IPOSI3 = I
  67. ENDIF
  68. ENDIF
  69. ELSE
  70. IF (IPOSI3.NE.0) THEN
  71. IF ((XVAL2.LT.XVAL1).AND.(XVAL2.GE.XVAL)) THEN
  72. XVAL3 = XVAL2
  73. IPOSI3 = I
  74. ENDIF
  75. ELSE
  76. IF (XVAL2.GE.XVAL) THEN
  77. XVAL3 = XVAL2
  78. IPOSI3 = I
  79. ENDIF
  80. ENDIF
  81. ENDIF
  82. 11 CONTINUE
  83. ENDIF
  84. SEGDES NUAVF1
  85.  
  86. *----- La borne inf. ou sup. du NUAGE n'existe pas ----------------
  87.  
  88. IF (IPOSI3.EQ.0) THEN
  89. SEGDES MNUAG1
  90. CALL ERREUR(669)
  91. RETURN
  92. ENDIF
  93.  
  94. NVAR = IDIM1
  95. NBCOUP = 1
  96. SEGINI MNUAGE
  97. IPO2 = MNUAGE
  98. DO 10 I=1,IDIM1
  99. NUANOM(I)=MNUAG1.NUANOM(I)
  100. NUATYP(I)=MNUAG1.NUATYP(I)
  101. IF (NUATYP(I).EQ.'INTEGER ') THEN
  102. SEGINI NUAVIN
  103. NUAPOI(I) = NUAVIN
  104. NUAVI1 = MNUAG1.NUAPOI(I)
  105. SEGACT NUAVI1
  106. NUAINT(1) = NUAVI1.NUAINT(IPOSI3)
  107. SEGDES NUAVI1
  108. SEGDES NUAVIN
  109. ELSE IF (NUATYP(I).EQ.'FLOTTANT') THEN
  110. SEGINI NUAVFL
  111. NUAPOI(I) = NUAVFL
  112. NUAVF1 = MNUAG1.NUAPOI(I)
  113. SEGACT NUAVF1
  114. NUAFLO(1) = NUAVF1.NUAFLO(IPOSI3)
  115. SEGDES NUAVF1
  116. SEGDES NUAVFL
  117. ELSE IF (NUATYP(I).EQ.'MOT ') THEN
  118. SEGINI NUAVMO
  119. NUAPOI(I) = NUAVMO
  120. NUAVM1 = MNUAG1.NUAPOI(I)
  121. SEGACT NUAVM1
  122. NUAMOT(1) = NUAVM1.NUAMOT(IPOSI3)
  123. SEGDES NUAVM1
  124. SEGDES NUAVMO
  125. ELSE IF (NUATYP(I).EQ.'LOGIQUE ') THEN
  126. SEGINI NUAVLO
  127. NUAPOI(I) = NUAVLO
  128. NUAVL1 = MNUAG1.NUAPOI(I)
  129. SEGACT NUAVL1
  130. NUALOG(1) = NUAVL1.NUALOG(IPOSI3)
  131. SEGDES NUAVL1
  132. SEGDES NUAVLO
  133. ELSE
  134. SEGINI NUAVIN
  135. NUAPOI(I) = NUAVIN
  136. NUAVI1 = MNUAG1.NUAPOI(I)
  137. SEGACT NUAVI1
  138. NUAINT(1) = NUAVI1.NUAINT(IPOSI3)
  139. SEGDES NUAVI1
  140. SEGDES NUAVIN
  141. END IF
  142. 10 CONTINUE
  143.  
  144. SEGDES MNUAGE
  145. SEGDES MNUAG1
  146. CALL ECROBJ('NUAGE ',IPO2)
  147. RETURN
  148. END
  149.  
  150.  
  151.  

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