Télécharger rezolu.eso

Retour à la liste

Numérotation des lignes :

  1. C REZOLU SOURCE PV 16/11/17 22:01:25 9180
  2. SUBROUTINE REZOLU(IDMAT,
  3. $ KS2B,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C************************************************************************
  8. C
  9. C RESOLUTION (MONTEE DESCENTE) D'UNE MATRICE SYMETRIQUE OU NON
  10. C PRECEDEMMENT TRIANGULEE PAR TRIAKS
  11. C
  12. C POINTEUR : EN ENTREE MATRIK CONTIENT LA MATRICE TRIANGULEE
  13. C B CONTIENT LE SECOND MEMBRE
  14. C EN SORTIE B CONTIENT LA SOLUTION
  15. C
  16. C VERSION OPTIMISEE EN GESTION MEMOIRE POUR LES TRES GROSSES
  17. C MATRICES. ON UTILISE L'ALGORITHME MRU (AVEC LA MODIFICATION
  18. C DANS OOOMWD) POUR LES BLOCS DE LA MATRICE. CECI EVITE DE TRANSFERER
  19. C SUR DISQUE LE RESTE DU CONTENU DE LA MEMOIRE, I.E. LES TABLEAUX
  20. C VITESSE, TEMPERATURE, ETC... QUI AURAIENT A ETRE RAPPELES DES
  21. C LA RESOLUTION TERMINEE.
  22. C
  23. C************************************************************************
  24. -INC CCOPTIO
  25. POINTEUR KS2B.IZA
  26. POINTEUR ISAL.IZA
  27. POINTEUR ISAU.IZA
  28. *STAT-INC SMSTAT
  29. SEGMENT IZD
  30. REAL*8 D(1)
  31. ENDSEGMENT
  32. *
  33. INTEGER IMPR,IRET
  34. * Fonctions
  35. REAL*8 DDOT
  36. *
  37. * Executable statements
  38. *
  39. IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans rezolu'
  40. *STAT CALL INMSTA(MSTAT,1)
  41. SEGACT IDMAT
  42. SEGACT KS2B*MOD
  43. NBLK=IDESCL(/1)
  44. C Descente
  45. IZD=IDIAG
  46. SEGACT IZD
  47. NTT=KS2B.A(/1)
  48. CALL OOOMRU(1)
  49. DO 305 IBLK=1,NBLK
  50. KJD=NLDBLK(IBLK)
  51. IF(IBLK.EQ.1)KJD=2
  52. KJF=NLDBLK(IBLK+1)-1
  53. ISAL=IDESCL(IBLK)
  54. SEGACT ISAL
  55. DO 300 N=KJD,KJF
  56. KDEB=N-KZA(N)+1
  57. LA=KZA(N)-1
  58. IDECI=NUIA(N,2)
  59. IF (LA.NE.0) THEN
  60. US=DDOT(LA,ISAL.A(IDECI+1),1,KS2B.A(KDEB),1)
  61. ELSE
  62. US=0.D0
  63. ENDIF
  64. KS2B.A(N)=(KS2B.A(N)-US)
  65. 300 CONTINUE
  66. SEGDES ISAL*MRU
  67. 305 CONTINUE
  68. C segact KS2B
  69. C WRITE(IOIMP,*) 'Descente'
  70. C WRITE(IOIMP,*) 'KS2B'
  71. C WRITE (IOIMP,2022) (KS2B.A(II),II=1,KS2B.A(/1))
  72. C 2022 FORMAT(10(1X,1PG12.5))
  73.  
  74. *STAT CALL PRMSTA('Descente',MSTAT,1)
  75. CALL DIVISE(NTT,KS2B.A,KS2B.A,D)
  76. SEGDES IZD*MRU
  77. *STAT CALL PRMSTA('Division',MSTAT,1)
  78. C Remontee
  79. DO 304 KBLK=1,NBLK
  80. IBLK=NBLK-KBLK+1
  81. KJD=NLDBLK(IBLK)
  82. KJF=NLDBLK(IBLK+1)-1
  83. ISAU=IDESCU(IBLK)
  84. SEGACT ISAU
  85. DO 302 N=KJF,KJD,-1
  86. KDEB=N-KZA(N)
  87. SA=-KS2B.A(N)
  88. I0=NUIA(N,2)
  89. LGL=KZA(N)-1
  90. IF (LGL.NE.0)
  91. > CALL DAXPY(LGL,SA,ISAU.A(I0+1),1,KS2B.A(KDEB+1),1)
  92. 302 CONTINUE
  93. SEGDES ISAU*MRU
  94. 304 CONTINUE
  95. CALL OOOMRU(0)
  96. SEGDES KS2B
  97. SEGDES IDMAT
  98. *STAT CALL PRMSTA('Remontée',MSTAT,1)
  99. *
  100. * Normal termination
  101. *
  102. IRET=0
  103. RETURN
  104. *
  105. * Format handling
  106. *
  107. *
  108. * Error handling
  109. *
  110. 9999 CONTINUE
  111. IRET=1
  112. WRITE(IOIMP,*) 'An error was detected in subroutine rezolu'
  113. RETURN
  114. *
  115. * End of subroutine REZOLU
  116. *
  117. END
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  

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