Télécharger rezolu.eso

Retour à la liste

Numérotation des lignes :

rezolu
  1. C REZOLU SOURCE GOUNAND 22/08/25 21:15:11 11434
  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. * Gestion du CTRL-C
  53. if (ierr.NE.0) return
  54. KJD=NLDBLK(IBLK)
  55. IF(IBLK.EQ.1)KJD=2
  56. KJF=NLDBLK(IBLK+1)-1
  57. ISAL=IDESCL(IBLK)
  58. SEGACT ISAL
  59. DO 300 N=KJD,KJF
  60. KDEB=N-KZA(N)+1
  61. LA=KZA(N)-1
  62. IDECI=NUIA(N,2)
  63. IF (LA.NE.0) THEN
  64. US=DDOT(LA,ISAL.A(IDECI+1),1,KS2B.A(KDEB),1)
  65. ELSE
  66. US=0.D0
  67. ENDIF
  68. KS2B.A(N)=(KS2B.A(N)-US)
  69. 300 CONTINUE
  70. SEGDES ISAL*MRU
  71. 305 CONTINUE
  72. C segact KS2B
  73. C WRITE(IOIMP,*) 'Descente'
  74. C WRITE(IOIMP,*) 'KS2B'
  75. C WRITE (IOIMP,2022) (KS2B.A(II),II=1,KS2B.A(/1))
  76. C 2022 FORMAT(10(1X,1PG12.5))
  77.  
  78. *STAT CALL PRMSTA('Descente',MSTAT,1)
  79. CALL DIVISE(NTT,KS2B.A,KS2B.A,D)
  80. SEGDES IZD*MRU
  81. *STAT CALL PRMSTA('Division',MSTAT,1)
  82. C Remontee
  83. DO 304 KBLK=1,NBLK
  84. * Gestion du CTRL-C
  85. if (ierr.NE.0) return
  86. IBLK=NBLK-KBLK+1
  87. KJD=NLDBLK(IBLK)
  88. KJF=NLDBLK(IBLK+1)-1
  89. ISAU=IDESCU(IBLK)
  90. SEGACT ISAU
  91. DO 302 N=KJF,KJD,-1
  92. KDEB=N-KZA(N)
  93. SA=-KS2B.A(N)
  94. I0=NUIA(N,2)
  95. LGL=KZA(N)-1
  96. IF (LGL.NE.0)
  97. > CALL DAXPY(LGL,SA,ISAU.A(I0+1),1,KS2B.A(KDEB+1),1)
  98. 302 CONTINUE
  99. SEGDES ISAU*MRU
  100. 304 CONTINUE
  101. CALL OOOMRU(0)
  102. SEGDES KS2B
  103. SEGDES IDMAT
  104. *STAT CALL PRMSTA('Remontée',MSTAT,1)
  105. *
  106. * Normal termination
  107. *
  108. IRET=0
  109. RETURN
  110. *
  111. * Format handling
  112. *
  113. *
  114. * Error handling
  115. *
  116. 9999 CONTINUE
  117. IRET=1
  118. WRITE(IOIMP,*) 'An error was detected in subroutine rezolu'
  119. RETURN
  120. *
  121. * End of subroutine REZOLU
  122. *
  123. END
  124.  
  125.  

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