Télécharger perm13.eso

Retour à la liste

Numérotation des lignes :

  1. C PERM13 SOURCE BP208322 16/06/27 21:16:20 8990
  2.  
  3. SUBROUTINE PERM13(N,A,F,M,XINF,U,V,FB)
  4. C
  5. C SEARCH FOR THE INITXAL DUAL AND PARTXAL PRIMAL SOLUTIONS.
  6. C
  7. C P(I) = FIRST UNSCANNED COLUMN OF ROW I .
  8. C
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8(A-H,O-Z)
  11.  
  12. REAL*8 A(N,N),U(N),V(N)
  13. INTEGER F(N)
  14. INTEGER FB(N),P(N),R
  15. C PHASE 1 .
  16. M = 0
  17. DO 10 K=1,N
  18. F(K) = 0
  19. FB(K) = 0
  20. 10 CONTINUE
  21. C SCANNING OF THE COLUMNS ( INITIALIZATION OF V(J) ).
  22. DO 40 J=1,N
  23. XMIN = XINF
  24. DO 30 I=1,N
  25. XA = A(I,J)
  26. IF ( XA .GT. XMIN ) GO TO 30
  27. IF ( XA .LT. XMIN ) GO TO 20
  28. IF ( F(I) .NE. 0 ) GO TO 30
  29. 20 XMIN = XA
  30. R = I
  31. 30 CONTINUE
  32. V(J) = XMIN
  33. IF ( F(R) .NE. 0 ) GO TO 40
  34. C ASSIGNMENT OF COLUMN J TO ROW R .
  35. M = M + 1
  36. FB(J) = R
  37. F(R) = J
  38. U(R) = 0
  39. P(R) = J + 1
  40. 40 CONTINUE
  41. C PHASE 2 .
  42. C SCANNING OF THE UNASSIGNED ROWS ( UPDATING OF U(I) ).
  43. DO 110 I=1,N
  44. IF ( F(I) .NE. 0 ) GO TO 110
  45. XMIN = XINF
  46. DO 60 K=1,N
  47. XA = A(I,K) - V(K)
  48. IF ( XA .GT. XMIN ) GO TO 60
  49. IF ( XA .LT. XMIN ) GO TO 50
  50. IF ( FB(K) .NE. 0 ) GO TO 60
  51. IF ( FB(J) .EQ. 0 ) GO TO 60
  52. 50 XMIN = XA
  53. J = K
  54. 60 CONTINUE
  55. U(I) = XMIN
  56. JMIN = J
  57. IF ( FB(J) .EQ. 0 ) GO TO 100
  58. DO 80 J=JMIN,N
  59. IF ( A(I,J) - V(J) .GT. XMIN ) GO TO 80
  60. R = FB(J)
  61. KK = P(R)
  62. IF ( KK .GT. N ) GO TO 80
  63. DO 70 K=KK,N
  64. IF ( FB(K) .GT. 0 ) GO TO 70
  65. IF ( A(R,K) - U(R) - V(K) .EQ. 0 ) GO TO 90
  66. 70 CONTINUE
  67. P(R) = N + 1
  68. 80 CONTINUE
  69. GO TO 110
  70. C REASSIGNMENT OF ROW R AND COLUMN K .
  71. 90 F(R) = K
  72. FB(K) = R
  73. P(R) = K + 1
  74. C ASSIGNMENT OF COLUMN J TO ROW I .
  75. 100 M = M + 1
  76. F(I) = J
  77. FB(J)= I
  78. P(I) = J + 1
  79. 110 CONTINUE
  80. RETURN
  81. END
  82.  
  83.  

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