Télécharger ordo_2.dgibi

Retour à la liste

Numérotation des lignes :

  1.  
  2. ************************************************************************
  3. * TEST DE L OPERATEUR ORDO 'COUT'
  4. * POUR LE CALCUL DE LA PERMUTATION OPTIMISANT UN COUT
  5. * BP, 2016-06-24
  6. * mot-cles : mathematiques, permutation, arrangement
  7. ************************************************************************
  8.  
  9.  
  10.  
  11. ************************************************************************
  12. * petite procedure utile pour le calcul a la main
  13. ************************************************************************
  14. debp coutperm lili*'LISTENTI' jperm*'LISTENTI';
  15. Scout = 0;
  16. repe bi (dime jperm);
  17. j = extr jperm &bi;
  18. k = ((&bi - 1) * n) + j;
  19. Scout = Scout + (ABS (extr lili k));
  20. fin bi;
  21. finp Scout;
  22.  
  23.  
  24. ************************************************************************
  25. * donnees
  26. ************************************************************************
  27.  
  28. * ml1 = lect
  29. * 6 3 7 1 8
  30. * 5 2 4 4 7
  31. * 2 5 3 9 4
  32. * 6 3 4 5 4
  33. * 2 2 6 5 8 ;
  34. ml1 = brui 'BLAN' 'POIS' 1000 (10**2);
  35. list ml1;
  36.  
  37.  
  38.  
  39. ************************************************************************
  40. * on verifie a la main sur toutes les permutations
  41. ************************************************************************
  42.  
  43. n2 = dime ml1;
  44. n = enti proche (n2**0.5);
  45.  
  46. nfacto = factorie n;
  47. mess 'n!=' nfacto;
  48.  
  49.  
  50. si (nfacto < 1000) ;
  51.  
  52.  
  53. Tperm = table;
  54. Tcout = lect;
  55. * combinaison initiale
  56. perm1 = lect 1 pas 1 n;
  57. cout1 = coutperm ml1 perm1;
  58. Tperm . 1 = (perm1 + 0);
  59. Tcout = Tcout et cout1;
  60. mess '----- Combinaison 1 de cout = ' cout1 '-----';
  61. list perm1;
  62. mess '--------------------------------------------------' ;
  63.  
  64. * boucle sur les combinaisons possibles
  65. repe bcomb (nfacto - 1);
  66. icomb = &bcomb + 1;
  67.  
  68. * i=n-1
  69. i = n - 1;
  70.  
  71. * 10 if(a(i).lt.a(i+1)) go to 20
  72. * i=i-1
  73. * if(i.eq.0) go to 20
  74. * go to 10
  75. repe b10;
  76. si ((extr perm1 i) < (extr perm1 (i+1))); quit b10; finsi;
  77. i = i - 1;
  78. si (i ega 0); quit b10; finsi;
  79. fin b10;
  80.  
  81. * 20 j=i+1
  82. * k=n
  83. j = i + 1;
  84. k = n;
  85.  
  86. * 30 t=a(j)
  87. * a(j)=a(k)
  88. * a(k)=t
  89. * j=j+1
  90. * k=k-1
  91. * if(j.lt.k) go to 30
  92. * j=i
  93. * if(j.ne.0) go to 40
  94. * nextp=.false.
  95. * return
  96. repe b30;
  97. * swap
  98. t = extr perm1 j;
  99. REMPLACER perm1 j (extr perm1 k);
  100. REMPLACER perm1 k t;
  101. j = j + 1;
  102. k = k - 1;
  103. si (j < k); iter b30; finsi;
  104. j = i;
  105. si (j neg 0); quit b30; finsi;
  106. si (j ega 0); quit bcomb; finsi;
  107. fin b30;
  108.  
  109. * 40 j=j+1
  110. * if(a(j).lt.a(i)) go to 40
  111. * t=a(i)
  112. * a(i)=a(j)
  113. * a(j)=t
  114. * nextp=.true.
  115. * end
  116. repe b40;
  117. j = j + 1;
  118. si ((extr perm1 j) < (extr perm1 i)); iter b40; finsi;
  119. * swap
  120. t = extr perm1 i;
  121. REMPLACER perm1 i (extr perm1 j);
  122. REMPLACER perm1 j t;
  123. quit b40;
  124. fin b40;
  125.  
  126. cout1 = coutperm ml1 perm1;
  127. Tperm . icomb = (perm1 + 0);
  128. Tcout = Tcout et cout1;
  129. mess '----- Combinaison 'icomb' de cout = ' cout1 '-----';
  130. list perm1;
  131. mess '--------------------------------------------------' ;
  132.  
  133.  
  134. fin bcomb;
  135.  
  136. jlist = lect 1 pas 1 nfacto;
  137. Tcout2 jlist2 = ordo Tcout jlist;
  138. jmin = extr jlist2 1;
  139. cout2 = extr Tcout2 1;
  140. mess '----- Combinaison ' jmin ' de cout mini = ' cout2 '-----';
  141. list Tperm . jmin;
  142.  
  143. finsi;
  144.  
  145. ************************************************************************
  146. * calcul via ORDO 'COUT' LISTENTI
  147. ************************************************************************
  148.  
  149. * calcul de la permutation et du cout associe
  150.  
  151. *------> methode Hongroise :
  152. jperm = lect 1 pas 1 n;
  153. c_ordo p_ordo = ORDO 'COUT' 'HONG' ml1 jperm;
  154. temp 'SGAC' 'IMPR';
  155. mess '>>>>> Cout mini =' c_ordo '<<<<<';
  156. list p_ordo;
  157.  
  158. *------> methode ou lon calcule tout :
  159. c_ordo2 p_ordo2 = ORDO 'COUT' ml1 jperm;
  160. temp 'SGAC' 'IMPR';
  161. mess '>>>>> Cout mini =' c_ordo2 '<<<<<';
  162. list p_ordo2;
  163.  
  164. ************************************************************************
  165. * calcul via ORDO 'COUT' LISTREEL
  166. ************************************************************************
  167.  
  168. *------> methode Hongroise :
  169. Xperm = lect 1 pas 1 n; list Xperm;
  170. XML1 = FLOT ml1; list XML1;
  171. * opti surv 2121211;
  172. c_ordX p_ordX = ORDO 'COUT' 'HONG' Xml1 Xperm;
  173. temp 'SGAC' 'IMPR';
  174. mess '>>>>> Cout mini =' c_ordX '<<<<<';
  175. list c_ordX;
  176. toto = p_ordX + 1;
  177. list toto;
  178. list p_ordX;
  179.  
  180. *------> methode ou lon calcule tout :
  181. c_ordX2 p_ordX2 = ORDO 'COUT' Xml1 Xperm;
  182. temp 'SGAC' 'IMPR';
  183. mess '>>>>> Cout mini =' c_ordX2 '<<<<<';
  184. list p_ordX2;
  185.  
  186.  
  187.  
  188. ************************************************************************
  189. * test de non regression
  190. ************************************************************************
  191.  
  192. si (nfacto < 1000) ;
  193. errcout = abs (cout2 - c_ordo);
  194. errperm = maxi (Tperm . jmin - p_ordo) 'ABS';
  195. sinon;
  196. errcout = abs (c_ordo2 - c_ordo);
  197. errperm = maxi (p_ordo2 - p_ordo) 'ABS';
  198. finsi;
  199.  
  200. SI ((errcout > 0) OU (errperm > 0)) ;
  201. ERRE 5 ;
  202. SINO ;
  203. ERRE 0 ;
  204. FINSI ;
  205.  
  206. FIN ;
  207.  
  208.  
  209.  

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