Télécharger ordon1.eso

Retour à la liste

Numérotation des lignes :

  1. C ORDON1 SOURCE PV 17/12/05 21:16:55 9646
  2. SUBROUTINE ORDON1 (IPLIST,CROISS,ABSOLU,IORDRE)
  3. ************************************************************************
  4. *
  5. * O R D O N 1
  6. * -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. * RANGER EN ORDRE CROISSANT OU DECROISSANT UN 'LISTREEL'.
  12. *
  13. * MODE D'APPEL:
  14. * -------------
  15. *
  16. * CALL ORDON1 (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 | ORDM01 | ORDM03 | ABSO=F | ORDO01 | ORDO03 |
  41. * --------+----------+----------+ --------+----------+----------+
  42. * ABSO=V | ORDM11 | ORDM13 | ABSO=V | ORDO11 | ORDO13 |
  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 SMLREEL
  70. -INC SMLENTI
  71. -INC TMCOLAC
  72.  
  73. pointeur piles.LISPIL
  74. pointeur jcolac.ICOLAC
  75. pointeur jlisse.ILISSE
  76. pointeur jtlacc.ITLACC
  77. *
  78. *
  79. MLREEL = IPLIST
  80. SEGACT,MLREEL
  81. LLIST = PROG(/1)
  82. *
  83. * Preparation de la liste donnant le nouvel ordre de MLREEL
  84. IF (IORDRE.NE.0) THEN
  85. JG = LLIST
  86. SEGINI,MLENT1
  87. IORDRE=MLENT1
  88. DO I=1,LLIST
  89. MLENT1.LECT(I)=I
  90. ENDDO
  91. ENDIF
  92. *
  93. IF (LLIST.LE.1) THEN
  94. SEGDES,MLREEL
  95. IF (IORDRE.NE.0) SEGDES,MLENT1
  96. RETURN
  97. END IF
  98. *
  99. *
  100. * ===========================
  101. * TRI PAR FUSION (MERGE SORT)
  102. * ===========================
  103. *
  104. IF (LLIST.GT.100) THEN
  105. JG = (LLIST+1)/2
  106. SEGINI,MLREE2
  107. *
  108. IF (IORDRE.EQ.0) THEN
  109. IF (ABSOLU) THEN
  110. CALL ORDM11(PROG(1),LLIST,MLREE2.PROG(1),CROISS)
  111. ELSE
  112. CALL ORDM01(PROG(1),LLIST,MLREE2.PROG(1),CROISS)
  113. END IF
  114. ELSE
  115. SEGINI,MLENT3
  116. IF (ABSOLU) THEN
  117. CALL ORDM13(PROG(1),MLENT1.LECT(1),LLIST,
  118. & MLREE2.PROG(1),MLENT3.LECT(1),CROISS)
  119. ELSE
  120. CALL ORDM03(PROG(1),MLENT1.LECT(1),LLIST,
  121. & MLREE2.PROG(1),MLENT3.LECT(1),CROISS)
  122. END IF
  123. SEGSUP,MLENT3
  124. SEGDES,MLENT1
  125. ENDIF
  126. *
  127. SEGSUP,MLREE2
  128. *
  129. *
  130. * =================
  131. * TRI PAR INSERTION
  132. * =================
  133. *
  134. ELSE
  135. IF (IORDRE.EQ.0) THEN
  136. IF (ABSOLU) THEN
  137. CALL ORDO11(PROG(1),LLIST,CROISS)
  138. ELSE
  139. CALL ORDO01(PROG(1),LLIST,CROISS)
  140. END IF
  141. ELSE
  142. IF (ABSOLU) THEN
  143. CALL ORDO13(PROG(1),LLIST,CROISS,MLENT1.LECT(1))
  144. ELSE
  145. CALL ORDO03(PROG(1),LLIST,CROISS,MLENT1.LECT(1))
  146. END IF
  147. SEGDES,MLENT1
  148. ENDIF
  149. ENDIF
  150. *
  151. *
  152. SEGDES,MLREEL
  153. *
  154. IF(IPSAUV.NE.0) THEN
  155. ICOLAC = IPSAUV
  156. SEGACT ICOLAC
  157. ILISSE=ILISSG
  158. SEGACT ILISSE*MOD
  159. CALL TYPFIL('LISTREEL',ICO)
  160. ITLACC = KCOLA(ICO)
  161. SEGACT ITLACC*MOD
  162. CALL AJOUN0(ITLACC,MLREEL,ILISSE,1)
  163. SEGDES ICOLAC,ILISSE
  164. ENDIF
  165. C Suppression des piles d'objets communiques
  166. if(piComm.gt.0) then
  167. piles=piComm
  168. segact piles
  169. call typfil('LISTREEL',ico)
  170. do ipile=1,piles.proc(/1)
  171. jcolac= piles.proc(ipile)
  172. if(jcolac.ne.0) then
  173. segact jcolac
  174. jlisse=jcolac.ilissg
  175. segact jlisse*mod
  176. jtlacc=jcolac.kcola(ico)
  177. segact jtlacc*mod
  178. call ajoun0(jtlacc,MLREEL,jlisse,1)
  179. segdes jtlacc
  180. segdes jlisse
  181. segdes jcolac
  182. endif
  183. enddo
  184. segdes piles
  185. endif
  186. RETURN
  187. *
  188. END
  189. *
  190.  
  191.  
  192.  
  193.  

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