Télécharger extr53.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTR53 SOURCE CHAT 05/01/12 23:52:53 5004
  2. SUBROUTINE EXTR53(IPOINT,XVAL1,XVAL2,IPOSI)
  3.  
  4. **********************************************************************
  5. *
  6. * Extraction du sous-NUAGE compris entre deux valeurs réelles
  7. * correspondant a une composante de type FLOTTANT
  8. *
  9. * INTEGER (E) IPOINT pointeur sur un objet NUAGE
  10. * FLOTTANT (E) XVAL1 valeur des composantes reelles entre
  11. * FLOTTANT (E) XVAL2 lesquelles on desire extraire le nuage
  12. * INTEGER (E) IPOSI Position informatique de la composante
  13. * reelle du nuage
  14. *
  15. ***********************************************************************
  16.  
  17. IMPLICIT INTEGER(I-N)
  18. -INC SMNUAGE
  19. -INC SMLENTI
  20.  
  21. REAL*8 XVAL1,XVAL2,XVAL3,BORN1,BORN2
  22. INTEGER IPOINT,IPOSI,IPO2,IDIM2,IDIM3,JG,IPOSI3,IDIM1
  23. CHARACTER*8 TYPR
  24.  
  25. IF (XVAL1.LT.XVAL2) THEN
  26. BORN1 = XVAL1
  27. BORN2 = XVAL2
  28. ELSE
  29. BORN2 = XVAL1
  30. BORN1 = XVAL2
  31. ENDIF
  32.  
  33. MNUAG1 = IPOINT
  34. SEGACT MNUAG1
  35. IDIM1 = MNUAG1.NUANOM(/2)
  36. TYPR = MNUAG1.NUATYP(IPOSI)
  37. IF (TYPR.NE.'FLOTTANT') THEN
  38. SEGDES MNUAG1
  39. *- Le nom de la composante ne correspond pas a des variables reelles -
  40. CALL ERREUR(671)
  41. RETURN
  42. ENDIF
  43. NUAVF1 = MNUAG1.NUAPOI(IPOSI)
  44. SEGACT NUAVF1
  45. IDIM2 = NUAVF1.NUAFLO(/1)
  46. IDIM3 = 0
  47. DO 22 I2 = 1,IDIM2
  48. XVAL3 = NUAVF1.NUAFLO(I2)
  49. IF (XVAL3.LE.BORN2.AND.XVAL3.GT.BORN1) THEN
  50. IDIM3 = IDIM3 + 1
  51. ENDIF
  52. 22 CONTINUE
  53.  
  54. IF (IDIM3.EQ.0) THEN
  55. SEGDES MNUAG1
  56. SEGDES NUAVF1
  57. *------ les deux valeurs réelles définissent un nuage "vide" --------
  58. CALL ERREUR (666)
  59. RETURN
  60. ENDIF
  61.  
  62. JG = IDIM3
  63. SEGINI MLENTI
  64. ITE2 = 0
  65. DO 20 I=1,IDIM2
  66. XVAL3 = NUAVF1.NUAFLO(I)
  67. IF (XVAL3.LE.BORN2.AND.XVAL3.GT.BORN1) THEN
  68. ITE2 = ITE2 + 1
  69. LECT(ITE2) = I
  70. ENDIF
  71. 20 CONTINUE
  72. SEGDES NUAVF1
  73.  
  74. NVAR = IDIM1
  75. NBCOUP = IDIM3
  76. SEGINI MNUAGE
  77. IPO2 = MNUAGE
  78.  
  79. DO 21 I = 1,IDIM3
  80. IPOSI3 = LECT(I)
  81. DO 10 I2=1,IDIM1
  82. IF (I.EQ.1) THEN
  83. NUANOM(I2)=MNUAG1.NUANOM(I2)
  84. NUATYP(I2)=MNUAG1.NUATYP(I2)
  85. ENDIF
  86. IF (NUATYP(I2).EQ.'INTEGER ') THEN
  87. IF (I.EQ.1) THEN
  88. SEGINI NUAVIN
  89. NUAPOI(I2) = NUAVIN
  90. ELSE
  91. NUAVIN = NUAPOI(I2)
  92. SEGACT NUAVIN
  93. ENDIF
  94. NUAVI1 = MNUAG1.NUAPOI(I2)
  95. SEGACT NUAVI1
  96. NUAINT(I) = NUAVI1.NUAINT(IPOSI3)
  97. SEGDES NUAVI1
  98. SEGDES NUAVIN
  99. ELSE IF (NUATYP(I2).EQ.'FLOTTANT') THEN
  100. IF (I.EQ.1) THEN
  101. SEGINI NUAVFL
  102. NUAPOI(I2) = NUAVFL
  103. ELSE
  104. NUAVFL = NUAPOI(I2)
  105. SEGACT NUAVFL
  106. ENDIF
  107. NUAVF1 = MNUAG1.NUAPOI(I2)
  108. SEGACT NUAVF1
  109. NUAFLO(I) = NUAVF1.NUAFLO(IPOSI3)
  110. SEGDES NUAVF1
  111. SEGDES NUAVFL
  112. ELSE IF (NUATYP(I2).EQ.'MOT ') THEN
  113. IF (I.EQ.1) THEN
  114. SEGINI NUAVMO
  115. NUAPOI(I2) = NUAVMO
  116. ELSE
  117. NUAVMO = NUAPOI(I2)
  118. SEGACT NUAVMO
  119. ENDIF
  120. NUAVM1 = MNUAG1.NUAPOI(I2)
  121. SEGACT NUAVM1
  122. NUAMOT(I) = NUAVM1.NUAMOT(IPOSI3)
  123. SEGDES NUAVM1
  124. SEGDES NUAVMO
  125. ELSE IF (NUATYP(I2).EQ.'LOGIQUE ') THEN
  126. IF (I.EQ.1) THEN
  127. SEGINI NUAVLO
  128. NUAPOI(I2) = NUAVLO
  129. ELSE
  130. NUAVLO = NUAPOI(I2)
  131. SEGACT NUAVLO
  132. ENDIF
  133. NUAVL1 = MNUAG1.NUAPOI(I2)
  134. SEGACT NUAVL1
  135. NUALOG(I) = NUAVL1.NUALOG(IPOSI3)
  136. SEGDES NUAVL1
  137. SEGDES NUAVLO
  138. ELSE
  139. IF (I.EQ.1) THEN
  140. SEGINI NUAVIN
  141. NUAPOI(I2) = NUAVIN
  142. ELSE
  143. NUAVIN = NUAPOI(I2)
  144. SEGACT NUAVIN
  145. ENDIF
  146. NUAVI1 = MNUAG1.NUAPOI(I2)
  147. SEGACT NUAVI1
  148. NUAINT(I) = NUAVI1.NUAINT(IPOSI3)
  149. SEGDES NUAVI1
  150. SEGDES NUAVIN
  151. END IF
  152. 10 CONTINUE
  153. 21 CONTINUE
  154.  
  155. SEGDES MLENTI
  156. SEGDES MNUAGE
  157. SEGDES MNUAG1
  158. CALL ECROBJ('NUAGE ',IPO2)
  159. RETURN
  160. END
  161.  
  162.  
  163.  

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