Télécharger gajome.eso

Retour à la liste

Numérotation des lignes :

  1. C GAJOME SOURCE CHAT 05/01/13 00:15:19 5004
  2. SUBROUTINE GAJOME(A,M,N,B,IRET,IOIMP)
  3. *
  4. * Cette subroutine associe a la matrice rectangulaire A de
  5. * rang M et de dimension MxN ou M<N la matrice carree B de
  6. * dimension NxN telle que A.B=[I:0] ou I est la matrice
  7. * identite de dimension MxM et 0 la matrice nulle de
  8. * dimension Mx(N-M).
  9. *
  10. * P.PEGON (ISPRA) AOUT 1996
  11. *
  12. *************************************
  13. IMPLICIT INTEGER(I-N)
  14. IMPLICIT REAL*8 (A-H,O-Z)
  15. DIMENSION A(M,N),B(N,N)
  16. *
  17. IRET=0
  18. IF (M.GT.N)THEN
  19. WRITE(IOIMP,*)'GAJOME: reduction impossible'
  20. IRET=1
  21. RETURN
  22. ENDIF
  23. *
  24. * Initialisation de B a la matrice identite
  25. *
  26. DO J=1,N
  27. DO I=1,N
  28. B(I,J)=0.D0
  29. ENDDO
  30. B(J,J)=1.D0
  31. ENDDO
  32. *
  33. * Boucle sur les lignes du systeme original
  34. *
  35. DO I=1,M
  36. *
  37. * recherche du pivot dnas la ligne I
  38. *
  39. BIG=1.D-6
  40. ICOL=0
  41. DO J=I,N
  42. IF (ABS(A(I,J)).GE.BIG)THEN
  43. BIG=ABS(A(I,J))
  44. ICOL=J
  45. ENDIF
  46. ENDDO
  47. IF(ICOL.EQ.0)THEN
  48. WRITE(IOIMP,*)'GAJOME: Il y a un mecanisme global'
  49. IRET=1
  50. RETURN
  51. ENDIF
  52. *
  53. * on place la colone pivot en position I et on fait de meme dans B
  54. *
  55. IF (ICOL.NE.I)THEN
  56. DO II=1,M
  57. DUM=A(II,ICOL)
  58. A(II,ICOL)=A(II,I)
  59. A(II,I)=DUM
  60. ENDDO
  61. DO II=1,N
  62. DUM=B(II,ICOL)
  63. B(II,ICOL)=B(II,I)
  64. B(II,I)=DUM
  65. ENDDO
  66. ENDIF
  67. *
  68. * on pivote, on normalise la colonne et on reduit la ligne
  69. *
  70. PIVINV=1.D0/A(I,I)
  71. DO II=1,M
  72. A(II,I)=A(II,I)*PIVINV
  73. ENDDO
  74. A(I,I)=1.D0
  75. DO II=1,N
  76. B(II,I)=B(II,I)*PIVINV
  77. ENDDO
  78. DO J=1,N
  79. IF(J.NE.I)THEN
  80. DUM=A(I,J)
  81. IF(DUM.NE.0.D0)THEN
  82. A(I,J)=0.D0
  83. DO II=1,M
  84. A(II,J)=A(II,J)-A(II,I)*DUM
  85. ENDDO
  86. DO II=1,N
  87. B(II,J)=B(II,J)-B(II,I)*DUM
  88. ENDDO
  89. ENDIF
  90. ENDIF
  91. ENDDO
  92. *
  93. ENDDO
  94. *
  95. RETURN
  96. END
  97.  
  98.  
  99.  

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