Télécharger ordon2.eso

Retour à la liste

Numérotation des lignes :

  1. C ORDON2 SOURCE PV 17/12/05 21:16:57 9646
  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.  
  66. -INC PPARAM
  67. -INC CCOPTIO
  68. -INC COCOLL
  69. -INC SMLENTI
  70. -INC TMCOLAC
  71.  
  72. pointeur piles.LISPIL
  73. pointeur jcolac.ICOLAC
  74. pointeur jlisse.ILISSE
  75. pointeur jtlacc.ITLACC
  76. *
  77. *
  78. MLENTI = IPLIST
  79. SEGACT,MLENTI
  80. LLIST = LECT(/1)
  81. *
  82. * Preparation de la liste donnant le nouvel ordre de MLENTI
  83. IF (IORDRE.NE.0) THEN
  84. JG = LLIST
  85. SEGINI,MLENT1
  86. IORDRE=MLENT1
  87. DO I=1,LLIST
  88. MLENT1.LECT(I)=I
  89. ENDDO
  90. ENDIF
  91. *
  92. IF (LLIST.LE.1) THEN
  93. SEGDES,MLENTI
  94. IF (IORDRE.NE.0) SEGDES,MLENT1
  95. RETURN
  96. END IF
  97. *
  98. *
  99. * ===========================
  100. * TRI PAR FUSION (MERGE SORT)
  101. * ===========================
  102. *
  103. IF (LLIST.GT.100) THEN
  104. JG = (LLIST+1)/2
  105. SEGINI,MLENT2
  106. *
  107. IF (IORDRE.EQ.0) THEN
  108. IF (ABSOLU) THEN
  109. CALL ORDM12(LECT(1),LLIST,MLENT2.LECT(1),CROISS)
  110. ELSE
  111. CALL ORDM02(LECT(1),LLIST,MLENT2.LECT(1),CROISS)
  112. END IF
  113. ELSE
  114. SEGINI,MLENT3
  115. IF (ABSOLU) THEN
  116. CALL ORDM14(LECT(1),MLENT1.LECT(1),LLIST,
  117. & MLENT2.LECT(1),MLENT3.LECT(1),CROISS)
  118. ELSE
  119. CALL ORDM04(LECT(1),MLENT1.LECT(1),LLIST,
  120. & MLENT2.LECT(1),MLENT3.LECT(1),CROISS)
  121. END IF
  122. SEGSUP,MLENT3
  123. SEGDES,MLENT1
  124. ENDIF
  125. *
  126. SEGSUP,MLENT2
  127. *
  128. *
  129. * =================
  130. * TRI PAR INSERTION
  131. * =================
  132. *
  133. ELSE
  134. IF (IORDRE.EQ.0) THEN
  135. IF (ABSOLU) THEN
  136. CALL ORDO12(LECT(1),LLIST,CROISS)
  137. ELSE
  138. CALL ORDO02(LECT(1),LLIST,CROISS)
  139. END IF
  140. ELSE
  141. IF (ABSOLU) THEN
  142. CALL ORDO14(LECT(1),LLIST,CROISS,MLENT1.LECT(1))
  143. ELSE
  144. CALL ORDO04(LECT(1),LLIST,CROISS,MLENT1.LECT(1))
  145. END IF
  146. SEGDES,MLENT1
  147. ENDIF
  148. ENDIF
  149. *
  150. *
  151. SEGDES,MLENTI
  152. IF(IPSAUV.NE.0) THEN
  153. ICOLAC = IPSAUV
  154. SEGACT ICOLAC
  155. ILISSE=ILISSG
  156. SEGACT ILISSE*MOD
  157. CALL TYPFIL('LISTENTI',ICO)
  158. ITLACC = KCOLA(ICO)
  159. SEGACT ITLACC*MOD
  160. CALL AJOUN0(ITLACC,MLENTI,ILISSE,1)
  161. SEGDES ICOLAC,ILISSE
  162. ENDIF
  163. C Suppression des piles d'objets communiques
  164. if(piComm.gt.0) then
  165. piles=piComm
  166. segact piles
  167. call typfil('LISTENTI',ico)
  168. do ipile=1,piles.proc(/1)
  169. jcolac= piles.proc(ipile)
  170. if(jcolac.ne.0) then
  171. segact jcolac
  172. jlisse=jcolac.ilissg
  173. segact jlisse*mod
  174. jtlacc=jcolac.kcola(ico)
  175. segact jtlacc*mod
  176. call ajoun0(jtlacc,MLENTI,jlisse,1)
  177. segdes jtlacc
  178. segdes jlisse
  179. segdes jcolac
  180. endif
  181. enddo
  182. segdes piles
  183. endif
  184. *
  185. RETURN
  186. *
  187. END
  188.  
  189.  
  190.  
  191.  

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