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. -INC CCOPTIO
  66. -INC COCOLL
  67. -INC SMLREEL
  68. -INC SMLENTI
  69. -INC TMCOLAC
  70.  
  71. pointeur piles.LISPIL
  72. pointeur jcolac.ICOLAC
  73. pointeur jlisse.ILISSE
  74. pointeur jtlacc.ITLACC
  75. *
  76. *
  77. MLREEL = IPLIST
  78. SEGACT,MLREEL
  79. LLIST = PROG(/1)
  80. *
  81. * Preparation de la liste donnant le nouvel ordre de MLREEL
  82. IF (IORDRE.NE.0) THEN
  83. JG = LLIST
  84. SEGINI,MLENT1
  85. IORDRE=MLENT1
  86. DO I=1,LLIST
  87. MLENT1.LECT(I)=I
  88. ENDDO
  89. ENDIF
  90. *
  91. IF (LLIST.LE.1) THEN
  92. SEGDES,MLREEL
  93. IF (IORDRE.NE.0) SEGDES,MLENT1
  94. RETURN
  95. END IF
  96. *
  97. *
  98. * ===========================
  99. * TRI PAR FUSION (MERGE SORT)
  100. * ===========================
  101. *
  102. IF (LLIST.GT.100) THEN
  103. JG = (LLIST+1)/2
  104. SEGINI,MLREE2
  105. *
  106. IF (IORDRE.EQ.0) THEN
  107. IF (ABSOLU) THEN
  108. CALL ORDM11(PROG(1),LLIST,MLREE2.PROG(1),CROISS)
  109. ELSE
  110. CALL ORDM01(PROG(1),LLIST,MLREE2.PROG(1),CROISS)
  111. END IF
  112. ELSE
  113. SEGINI,MLENT3
  114. IF (ABSOLU) THEN
  115. CALL ORDM13(PROG(1),MLENT1.LECT(1),LLIST,
  116. & MLREE2.PROG(1),MLENT3.LECT(1),CROISS)
  117. ELSE
  118. CALL ORDM03(PROG(1),MLENT1.LECT(1),LLIST,
  119. & MLREE2.PROG(1),MLENT3.LECT(1),CROISS)
  120. END IF
  121. SEGSUP,MLENT3
  122. SEGDES,MLENT1
  123. ENDIF
  124. *
  125. SEGSUP,MLREE2
  126. *
  127. *
  128. * =================
  129. * TRI PAR INSERTION
  130. * =================
  131. *
  132. ELSE
  133. IF (IORDRE.EQ.0) THEN
  134. IF (ABSOLU) THEN
  135. CALL ORDO11(PROG(1),LLIST,CROISS)
  136. ELSE
  137. CALL ORDO01(PROG(1),LLIST,CROISS)
  138. END IF
  139. ELSE
  140. IF (ABSOLU) THEN
  141. CALL ORDO13(PROG(1),LLIST,CROISS,MLENT1.LECT(1))
  142. ELSE
  143. CALL ORDO03(PROG(1),LLIST,CROISS,MLENT1.LECT(1))
  144. END IF
  145. SEGDES,MLENT1
  146. ENDIF
  147. ENDIF
  148. *
  149. *
  150. SEGDES,MLREEL
  151. *
  152. IF(IPSAUV.NE.0) THEN
  153. ICOLAC = IPSAUV
  154. SEGACT ICOLAC
  155. ILISSE=ILISSG
  156. SEGACT ILISSE*MOD
  157. CALL TYPFIL('LISTREEL',ICO)
  158. ITLACC = KCOLA(ICO)
  159. SEGACT ITLACC*MOD
  160. CALL AJOUN0(ITLACC,MLREEL,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('LISTREEL',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,MLREEL,jlisse,1)
  177. segdes jtlacc
  178. segdes jlisse
  179. segdes jcolac
  180. endif
  181. enddo
  182. segdes piles
  183. endif
  184. RETURN
  185. *
  186. END
  187. *
  188.  
  189.  
  190.  
  191.  

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