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.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. POINTEUR KS2B.IZA
  28. POINTEUR ISAL.IZA
  29. POINTEUR ISAU.IZA
  30. *STAT-INC SMSTAT
  31. SEGMENT IZD
  32. REAL*8 D(1)
  33. ENDSEGMENT
  34. *
  35. INTEGER IMPR,IRET
  36. * Fonctions
  37. REAL*8 DDOT
  38. *
  39. * Executable statements
  40. *
  41. IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans rezolu'
  42. *STAT CALL INMSTA(MSTAT,1)
  43. SEGACT IDMAT
  44. SEGACT KS2B*MOD
  45. NBLK=IDESCL(/1)
  46. C Descente
  47. IZD=IDIAG
  48. SEGACT IZD
  49. NTT=KS2B.A(/1)
  50. CALL OOOMRU(1)
  51. DO 305 IBLK=1,NBLK
  52. KJD=NLDBLK(IBLK)
  53. IF(IBLK.EQ.1)KJD=2
  54. KJF=NLDBLK(IBLK+1)-1
  55. ISAL=IDESCL(IBLK)
  56. SEGACT ISAL
  57. DO 300 N=KJD,KJF
  58. KDEB=N-KZA(N)+1
  59. LA=KZA(N)-1
  60. IDECI=NUIA(N,2)
  61. IF (LA.NE.0) THEN
  62. US=DDOT(LA,ISAL.A(IDECI+1),1,KS2B.A(KDEB),1)
  63. ELSE
  64. US=0.D0
  65. ENDIF
  66. KS2B.A(N)=(KS2B.A(N)-US)
  67. 300 CONTINUE
  68. SEGDES ISAL*MRU
  69. 305 CONTINUE
  70. C segact KS2B
  71. C WRITE(IOIMP,*) 'Descente'
  72. C WRITE(IOIMP,*) 'KS2B'
  73. C WRITE (IOIMP,2022) (KS2B.A(II),II=1,KS2B.A(/1))
  74. C 2022 FORMAT(10(1X,1PG12.5))
  75.  
  76. *STAT CALL PRMSTA('Descente',MSTAT,1)
  77. CALL DIVISE(NTT,KS2B.A,KS2B.A,D)
  78. SEGDES IZD*MRU
  79. *STAT CALL PRMSTA('Division',MSTAT,1)
  80. C Remontee
  81. DO 304 KBLK=1,NBLK
  82. IBLK=NBLK-KBLK+1
  83. KJD=NLDBLK(IBLK)
  84. KJF=NLDBLK(IBLK+1)-1
  85. ISAU=IDESCU(IBLK)
  86. SEGACT ISAU
  87. DO 302 N=KJF,KJD,-1
  88. KDEB=N-KZA(N)
  89. SA=-KS2B.A(N)
  90. I0=NUIA(N,2)
  91. LGL=KZA(N)-1
  92. IF (LGL.NE.0)
  93. > CALL DAXPY(LGL,SA,ISAU.A(I0+1),1,KS2B.A(KDEB+1),1)
  94. 302 CONTINUE
  95. SEGDES ISAU*MRU
  96. 304 CONTINUE
  97. CALL OOOMRU(0)
  98. SEGDES KS2B
  99. SEGDES IDMAT
  100. *STAT CALL PRMSTA('Remontée',MSTAT,1)
  101. *
  102. * Normal termination
  103. *
  104. IRET=0
  105. RETURN
  106. *
  107. * Format handling
  108. *
  109. *
  110. * Error handling
  111. *
  112. 9999 CONTINUE
  113. IRET=1
  114. WRITE(IOIMP,*) 'An error was detected in subroutine rezolu'
  115. RETURN
  116. *
  117. * End of subroutine REZOLU
  118. *
  119. END
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  

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