Télécharger extr52.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTR52 SOURCE CHAT 05/01/12 23:52:48 5004
  2. SUBROUTINE EXTR52(IPOINT,MINI,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,IPOSI3
  25. LOGICAL MINI,MAXI
  26. CHARACTER*8 TYPR
  27.  
  28. MAXI = .NOT.MINI
  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. XVAL2 = NUAVF1.NUAFLO(2)
  45. IPOSI3 = 1
  46. XVAL3 = XVAL1
  47. IF (XVAL2.LE.XVAL3.AND.MINI) THEN
  48. IPOSI3 = 2
  49. XVAL3 = XVAL2
  50. ENDIF
  51. IF (XVAL2.GE.XVAL3.AND.MAXI) THEN
  52. IPOSI3 = 2
  53. XVAL3 = XVAL2
  54. ENDIF
  55.  
  56. DO 11 I=3,IDIM2
  57. XVAL1 = XVAL2
  58. XVAL2 = NUAVF1.NUAFLO(I)
  59. IF (XVAL2.LE.XVAL3.AND.MINI) THEN
  60. IPOSI3 = I
  61. XVAL3 = XVAL2
  62. ENDIF
  63. IF (XVAL2.GE.XVAL3.AND.MAXI) THEN
  64. IPOSI3 = I
  65. XVAL3 = XVAL2
  66. ENDIF
  67. 11 CONTINUE
  68.  
  69. SEGDES NUAVF1
  70.  
  71. NVAR = IDIM1
  72. NBCOUP = 1
  73. SEGINI MNUAGE
  74. IPO2 = MNUAGE
  75. DO 10 I=1,IDIM1
  76. NUANOM(I)=MNUAG1.NUANOM(I)
  77. NUATYP(I)=MNUAG1.NUATYP(I)
  78. IF (NUATYP(I).EQ.'INTEGER ') THEN
  79. SEGINI NUAVIN
  80. NUAPOI(I) = NUAVIN
  81. NUAVI1 = MNUAG1.NUAPOI(I)
  82. SEGACT NUAVI1
  83. NUAINT(1) = NUAVI1.NUAINT(IPOSI3)
  84. SEGDES NUAVI1
  85. SEGDES NUAVIN
  86. ELSE IF (NUATYP(I).EQ.'FLOTTANT') THEN
  87. SEGINI NUAVFL
  88. NUAPOI(I) = NUAVFL
  89. NUAVF1 = MNUAG1.NUAPOI(I)
  90. SEGACT NUAVF1
  91. NUAFLO(1) = NUAVF1.NUAFLO(IPOSI3)
  92. SEGDES NUAVF1
  93. SEGDES NUAVFL
  94. ELSE IF (NUATYP(I).EQ.'MOT ') THEN
  95. SEGINI NUAVMO
  96. NUAPOI(I) = NUAVMO
  97. NUAVM1 = MNUAG1.NUAPOI(I)
  98. SEGACT NUAVM1
  99. NUAMOT(1) = NUAVM1.NUAMOT(IPOSI3)
  100. SEGDES NUAVM1
  101. SEGDES NUAVMO
  102. ELSE IF (NUATYP(I).EQ.'LOGIQUE ') THEN
  103. SEGINI NUAVLO
  104. NUAPOI(I) = NUAVLO
  105. NUAVL1 = MNUAG1.NUAPOI(I)
  106. SEGACT NUAVL1
  107. NUALOG(1) = NUAVL1.NUALOG(IPOSI3)
  108. SEGDES NUAVL1
  109. SEGDES NUAVLO
  110. ELSE
  111. SEGINI NUAVIN
  112. NUAPOI(I) = NUAVIN
  113. NUAVI1 = MNUAG1.NUAPOI(I)
  114. SEGACT NUAVI1
  115. NUAINT(1) = NUAVI1.NUAINT(IPOSI3)
  116. SEGDES NUAVI1
  117. SEGDES NUAVIN
  118. END IF
  119. 10 CONTINUE
  120.  
  121. SEGDES MNUAGE
  122. SEGDES MNUAG1
  123. CALL ECROBJ('NUAGE ',IPO2)
  124. RETURN
  125. END
  126.  
  127.  
  128.  

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