Télécharger ordon3.eso

Retour à la liste

Numérotation des lignes :

  1. C ORDON3 SOURCE PV 17/12/05 21:16:58 9646
  2. SUBROUTINE ORDON3 (IPEVOL,CROISS,ABSOLU)
  3. ************************************************************************
  4. *
  5. * O R D O N 3
  6. * -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. * RANGER EN ORDRE CROISSANT OU DECROISSANT UN 'EVOLUTIO'.
  12. *
  13. * MODE D'APPEL:
  14. * -------------
  15. *
  16. * CALL ORDON3 (IPEVOL,CROISS,ABSOLU)
  17. *
  18. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  19. * -----------
  20. *
  21. * IPEVOL ENTIER (E) POINTEUR SUR L' EVOL A ORDONNER.
  22. * (S) MEME POINTEUR, EVOL REORDONNE .
  23. * CROISS LOGIQUE (E) INDIQUE PAR "VRAI" OU "FAUX" SI ON ORDONNE
  24. * CROISSANT OU NON.
  25. * ABSOLU LOGIQUE (E) INDIQUE PAR "VRAI" OU "FAUX" SI ON ORDONNE
  26. * EN CONSIDERANT LES VALEURS ABSOLUES OU LES
  27. * VRAIES VALEURS.
  28. *
  29. * LANGAGE:
  30. * --------
  31. *
  32. * ESOPE + FORTRAN77
  33. *
  34. ************************************************************************
  35. *
  36. IMPLICIT INTEGER(I-N)
  37. IMPLICIT REAL*8 (A-H,O-Z)
  38. LOGICAL CROISS,ABSOLU,DECROI
  39. integer IB, IB1, ICO, IPEVOL
  40. integer IPILE, JB, NBPT, NC, NCOU, NRANG
  41. real*8 FXL1, XL1, XL2, YL1, YL2
  42.  
  43. -INC PPARAM
  44. -INC CCOPTIO
  45. -INC COCOLL
  46. -INC SMLREEL
  47. -INC SMEVOLL
  48. -INC TMCOLAC
  49.  
  50. pointeur piles.LISPIL
  51. pointeur jcolac.ICOLAC
  52. pointeur jlisse.ILISSE
  53. pointeur jtlacc.ITLACC
  54. *
  55. *
  56. DECROI = .NOT.CROISS
  57. MEVOLL=IPEVOL
  58. SEGACT MEVOLL*MOD
  59. NCOU=IEVOLL(/1)
  60. *
  61. * BOUCLE SUR LES DIFFERENTES COURBES
  62. *
  63. DO 400 NC=1,NCOU
  64. KEVOL1 = IEVOLL(NC)
  65. SEGINI,KEVOLL=KEVOL1
  66. IEVOLL(NC)=KEVOLL
  67. SEGACT KEVOLL*MOD
  68. *
  69. * TEST SUR LE TYPE DES ABSCISSES ET DES ORDONNEES
  70. *
  71. IF(TYPX(1:8).NE.'LISTREEL'.OR.TYPY(1:8).NE.'LISTREEL') THEN
  72. CALL ERREUR(19)
  73. SEGDES KEVOLL,MEVOLL
  74. RETURN
  75. ENDIF
  76. *
  77. MLREE1=IPROGX
  78. SEGINI,MLREEL=MLREE1
  79. IPROGX=MLREEL
  80. NBPT=PROG(/1)
  81. *
  82. * TEST SUR LE NOMBRE DE POINTS
  83. *
  84. IF(NBPT.EQ.1) THEN
  85. SEGDES MLREEL
  86. SEGDES KEVOLL
  87. GO TO 400
  88. ENDIF
  89. *
  90. MLREE3=IPROGY
  91. SEGINI,MLREE1=MLREE3
  92. IPROGY=MLREE1
  93. c
  94. SEGACT MLREE1*MOD
  95. DO 100 IB=2,NBPT
  96. XL1 = PROG(IB)
  97. FXL1 = MLREE1.PROG(IB)
  98. IF(ABSOLU) THEN
  99. YL1 = ABS(XL1)
  100. ELSE
  101. YL1 = XL1
  102. ENDIF
  103. IB1 = IB - 1
  104. NRANG = IB
  105. DO 110 JB=IB1,1,-1
  106. XL2 = PROG(JB)
  107. IF(ABSOLU) THEN
  108. YL2 = ABS(XL2)
  109. ELSE
  110. YL2 = XL2
  111. ENDIF
  112. IF ( (CROISS .AND. YL1.LT.YL2)
  113. & .OR. (DECROI .AND. YL1.GT.YL2) ) THEN
  114. NRANG = NRANG - 1
  115. ELSE
  116. GOTO 112
  117. END IF
  118. 110 CONTINUE
  119. 112 CONTINUE
  120. DO 120 JB=IB1,NRANG,-1
  121. PROG(JB+1) = PROG(JB)
  122. MLREE1.PROG(JB+1) = MLREE1.PROG(JB)
  123. 120 CONTINUE
  124. PROG(NRANG) = XL1
  125. MLREE1.PROG(NRANG) = FXL1
  126. 100 CONTINUE
  127. SEGDES KEVOLL,kevol1,MLREEL,MLREE1,mlree3
  128. 400 CONTINUE
  129. *
  130. SEGDES MEVOLL
  131. IF(IPSAUV.NE.0) THEN
  132. ICOLAC = IPSAUV
  133. SEGACT ICOLAC
  134. ILISSE=ILISSG
  135. SEGACT ILISSE*MOD
  136. CALL TYPFIL('EVOLUTIO',ICO)
  137. ITLACC = KCOLA(ICO)
  138. SEGACT ITLACC*MOD
  139. CALL AJOUN0(ITLACC,MEVOLL,ILISSE,1)
  140. SEGDES ICOLAC,ILISSE
  141. ENDIF
  142. C Suppression des piles d'objets communiques
  143. if(piComm.gt.0) then
  144. piles=piComm
  145. segact piles
  146. call typfil('EVOLUTIO',ico)
  147. do ipile=1,piles.proc(/1)
  148. jcolac= piles.proc(ipile)
  149. if(jcolac.ne.0) then
  150. segact jcolac
  151. jlisse=jcolac.ilissg
  152. segact jlisse*mod
  153. jtlacc=jcolac.kcola(ico)
  154. segact jtlacc*mod
  155. call ajoun0(jtlacc,MEVOLL,jlisse,1)
  156. segdes jtlacc
  157. segdes jlisse
  158. segdes jcolac
  159. endif
  160. enddo
  161. segdes piles
  162. endif
  163. RETURN
  164. END
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  

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