Télécharger ordon3.eso

Retour à la liste

Numérotation des lignes :

  1. C ORDON3 SOURCE PV 16/11/26 21:16:15 9205
  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. -INC CCOPTIO
  43. -INC COCOLL
  44. -INC SMLREEL
  45. -INC SMEVOLL
  46. -INC TMCOLAC
  47.  
  48. pointeur piles.LISPIL
  49. pointeur jcolac.ICOLAC
  50. pointeur jlisse.ILISSE
  51. pointeur jtlacc.ITLACC
  52. *
  53. *
  54. DECROI = .NOT.CROISS
  55. MEVOLL=IPEVOL
  56. SEGACT MEVOLL*MOD
  57. NCOU=IEVOLL(/1)
  58. *
  59. * BOUCLE SUR LES DIFFERENTES COURBES
  60. *
  61. DO 400 NC=1,NCOU
  62. KEVOL1 = IEVOLL(NC)
  63. SEGINI,KEVOLL=KEVOL1
  64. IEVOLL(NC)=KEVOLL
  65. SEGACT KEVOLL*MOD
  66. *
  67. * TEST SUR LE TYPE DES ABSCISSES ET DES ORDONNEES
  68. *
  69. IF(TYPX(1:8).NE.'LISTREEL'.OR.TYPY(1:8).NE.'LISTREEL') THEN
  70. CALL ERREUR(19)
  71. SEGDES KEVOLL,MEVOLL
  72. RETURN
  73. ENDIF
  74. *
  75. MLREE1=IPROGX
  76. SEGINI,MLREEL=MLREE1
  77. IPROGX=MLREEL
  78. NBPT=PROG(/1)
  79. *
  80. * TEST SUR LE NOMBRE DE POINTS
  81. *
  82. IF(NBPT.EQ.1) THEN
  83. SEGDES MLREEL
  84. SEGDES KEVOLL
  85. GO TO 400
  86. ENDIF
  87. *
  88. MLREE3=IPROGY
  89. SEGINI,MLREE1=MLREE3
  90. IPROGY=MLREE1
  91. c
  92. SEGACT MLREE1*MOD
  93. DO 100 IB=2,NBPT
  94. XL1 = PROG(IB)
  95. FXL1 = MLREE1.PROG(IB)
  96. IF(ABSOLU) THEN
  97. YL1 = ABS(XL1)
  98. ELSE
  99. YL1 = XL1
  100. ENDIF
  101. IB1 = IB - 1
  102. NRANG = IB
  103. DO 110 JB=IB1,1,-1
  104. XL2 = PROG(JB)
  105. IF(ABSOLU) THEN
  106. YL2 = ABS(XL2)
  107. ELSE
  108. YL2 = XL2
  109. ENDIF
  110. IF ( (CROISS .AND. YL1.LT.YL2)
  111. & .OR. (DECROI .AND. YL1.GT.YL2) ) THEN
  112. NRANG = NRANG - 1
  113. ELSE
  114. GOTO 112
  115. END IF
  116. 110 CONTINUE
  117. 112 CONTINUE
  118. DO 120 JB=IB1,NRANG,-1
  119. PROG(JB+1) = PROG(JB)
  120. MLREE1.PROG(JB+1) = MLREE1.PROG(JB)
  121. 120 CONTINUE
  122. PROG(NRANG) = XL1
  123. MLREE1.PROG(NRANG) = FXL1
  124. 100 CONTINUE
  125. SEGDES KEVOLL,kevol1,MLREEL,MLREE1,mlree3
  126. 400 CONTINUE
  127. *
  128. SEGDES MEVOLL
  129. IF(IPSAUV.NE.0) THEN
  130. ICOLAC = IPSAUV
  131. SEGACT ICOLAC
  132. ILISSE=ILISSG
  133. SEGACT ILISSE*MOD
  134. CALL TYPFIL('EVOLUTIO',ICO)
  135. ITLACC = KCOLA(ICO)
  136. SEGACT ITLACC*MOD
  137. CALL AJOUN0(ITLACC,MEVOLL,ILISSE,1)
  138. SEGDES ICOLAC,ILISSE
  139. ENDIF
  140. C Suppression des piles d'objets communiques
  141. if(piComm.gt.0) then
  142. piles=piComm
  143. segact piles
  144. call typfil('EVOLUTIO',ico)
  145. do ipile=1,piles.proc(/1)
  146. jcolac= piles.proc(ipile)
  147. if(jcolac.ne.0) then
  148. segact jcolac
  149. jlisse=jcolac.ilissg
  150. segact jlisse*mod
  151. jtlacc=jcolac.kcola(ico)
  152. segact jtlacc*mod
  153. call ajoun0(jtlacc,MEVOLL,jlisse,1)
  154. segdes jtlacc
  155. segdes jlisse
  156. segdes jcolac
  157. endif
  158. enddo
  159. segdes piles
  160. endif
  161. RETURN
  162. END
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  

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