Télécharger ordon2.eso

Retour à la liste

Numérotation des lignes :

  1. C ORDON2 SOURCE PV 16/11/26 21:16:14 9205
  2. SUBROUTINE ORDON2 (IPLIST,CROISS,ABSOLU,IORDRE)
  3. ************************************************************************
  4. *
  5. * O R D O N 2
  6. * -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. * RANGER EN ORDRE CROISSANT OU DECROISSANT UN 'LISTENTI'.
  12. *
  13. * MODE D'APPEL:
  14. * -------------
  15. *
  16. * CALL ORDON2 (IPLIST,CROISS,ABSOLU)
  17. *
  18. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  19. * -----------
  20. *
  21. * IPLIST ENTIER (E) POINTEUR SUR LA LISTE A ORDONNER.
  22. * (S) MEME POINTEUR, LISTE REORDONNEE.
  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. * IORDRE ENTIER (E) SI NON NUL, INDIQUE QUE L'ON SOUHAITE
  29. * RENVOYER LE NOUVEL ORDRE DE LA LISTE
  30. * (S) POINTEUR VERS UN LISTENTI CONTENANT LE
  31. * NOUVEL ORDRE DES ELEMENTS
  32. *
  33. * SOUS-PROGRAMMES APPELES:
  34. * ------------------------
  35. *
  36. * TRI PAR FUSION TRI PAR INSERTION
  37. *
  38. * | IORDRE=0 | IORDRE#0 | | IORDRE=0 | IORDRE#0 |
  39. * --------+----------+----------+ --------+----------+----------+
  40. * ABSO=F | ORDM02 | ORDM04 | ABSO=F | ORDO04 | ORDO04 |
  41. * --------+----------+----------+ --------+----------+----------+
  42. * ABSO=V | ORDM12 | ORDM14 | ABSO=V | ORDO14 | ORDO14 |
  43. * --------+----------+----------+ --------+----------+----------+
  44. *
  45. *
  46. * AUTEUR, DATE DE CREATION:
  47. * -------------------------
  48. *
  49. * PASCAL MANIGOT 19 MARS 1985
  50. *
  51. * OPTION "ABSOLU" AJOUTEE LE 23 AVRIL 1985 (P. MANIGOT)
  52. *
  53. * OPTION "IORDRE" AJOUTEE LE 10 DEC 2014 (JCARDO)
  54. *
  55. * LANGAGE:
  56. * --------
  57. *
  58. * ESOPE + FORTRAN77
  59. *
  60. ************************************************************************
  61. *
  62. IMPLICIT INTEGER(I-N)
  63. LOGICAL CROISS,ABSOLU
  64. integer ICO, IPILE, IPLIST, LLIST
  65. -INC CCOPTIO
  66. -INC COCOLL
  67. -INC SMLENTI
  68. -INC TMCOLAC
  69.  
  70. pointeur piles.LISPIL
  71. pointeur jcolac.ICOLAC
  72. pointeur jlisse.ILISSE
  73. pointeur jtlacc.ITLACC
  74. *
  75. *
  76. MLENTI = IPLIST
  77. SEGACT,MLENTI
  78. LLIST = LECT(/1)
  79. *
  80. * Preparation de la liste donnant le nouvel ordre de MLENTI
  81. IF (IORDRE.NE.0) THEN
  82. JG = LLIST
  83. SEGINI,MLENT1
  84. IORDRE=MLENT1
  85. DO I=1,LLIST
  86. MLENT1.LECT(I)=I
  87. ENDDO
  88. ENDIF
  89. *
  90. IF (LLIST.LE.1) THEN
  91. SEGDES,MLENTI
  92. IF (IORDRE.NE.0) SEGDES,MLENT1
  93. RETURN
  94. END IF
  95. *
  96. *
  97. * ===========================
  98. * TRI PAR FUSION (MERGE SORT)
  99. * ===========================
  100. *
  101. IF (LLIST.GT.100) THEN
  102. JG = (LLIST+1)/2
  103. SEGINI,MLENT2
  104. *
  105. IF (IORDRE.EQ.0) THEN
  106. IF (ABSOLU) THEN
  107. CALL ORDM12(LECT(1),LLIST,MLENT2.LECT(1),CROISS)
  108. ELSE
  109. CALL ORDM02(LECT(1),LLIST,MLENT2.LECT(1),CROISS)
  110. END IF
  111. ELSE
  112. SEGINI,MLENT3
  113. IF (ABSOLU) THEN
  114. CALL ORDM14(LECT(1),MLENT1.LECT(1),LLIST,
  115. & MLENT2.LECT(1),MLENT3.LECT(1),CROISS)
  116. ELSE
  117. CALL ORDM04(LECT(1),MLENT1.LECT(1),LLIST,
  118. & MLENT2.LECT(1),MLENT3.LECT(1),CROISS)
  119. END IF
  120. SEGSUP,MLENT3
  121. SEGDES,MLENT1
  122. ENDIF
  123. *
  124. SEGSUP,MLENT2
  125. *
  126. *
  127. * =================
  128. * TRI PAR INSERTION
  129. * =================
  130. *
  131. ELSE
  132. IF (IORDRE.EQ.0) THEN
  133. IF (ABSOLU) THEN
  134. CALL ORDO12(LECT(1),LLIST,CROISS)
  135. ELSE
  136. CALL ORDO02(LECT(1),LLIST,CROISS)
  137. END IF
  138. ELSE
  139. IF (ABSOLU) THEN
  140. CALL ORDO14(LECT(1),LLIST,CROISS,MLENT1.LECT(1))
  141. ELSE
  142. CALL ORDO04(LECT(1),LLIST,CROISS,MLENT1.LECT(1))
  143. END IF
  144. SEGDES,MLENT1
  145. ENDIF
  146. ENDIF
  147. *
  148. *
  149. SEGDES,MLENTI
  150. IF(IPSAUV.NE.0) THEN
  151. ICOLAC = IPSAUV
  152. SEGACT ICOLAC
  153. ILISSE=ILISSG
  154. SEGACT ILISSE*MOD
  155. CALL TYPFIL('LISTENTI',ICO)
  156. ITLACC = KCOLA(ICO)
  157. SEGACT ITLACC*MOD
  158. CALL AJOUN0(ITLACC,MLENTI,ILISSE,1)
  159. SEGDES ICOLAC,ILISSE
  160. ENDIF
  161. C Suppression des piles d'objets communiques
  162. if(piComm.gt.0) then
  163. piles=piComm
  164. segact piles
  165. call typfil('LISTENTI',ico)
  166. do ipile=1,piles.proc(/1)
  167. jcolac= piles.proc(ipile)
  168. if(jcolac.ne.0) then
  169. segact jcolac
  170. jlisse=jcolac.ilissg
  171. segact jlisse*mod
  172. jtlacc=jcolac.kcola(ico)
  173. segact jtlacc*mod
  174. call ajoun0(jtlacc,MLENTI,jlisse,1)
  175. segdes jtlacc
  176. segdes jlisse
  177. segdes jcolac
  178. endif
  179. enddo
  180. segdes piles
  181. endif
  182. *
  183. RETURN
  184. *
  185. END
  186.  
  187.  
  188.  

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