Télécharger exdiag.eso

Retour à la liste

Numérotation des lignes :

  1. C EXDIAG SOURCE PV 16/11/17 21:59:20 9180
  2. SUBROUTINE EXDIAG(IOPT)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C*************************************************************************
  6. C Operateur EXDIAG
  7. C
  8. C OBJET : Extrait une diagonale d'une matrice au format
  9. C MATRIK
  10. C Pour cela, on doit l'assembler.
  11. C L'assemblage se fait comme dans KRES2.
  12. C Si IOPT=1, on renvoie la diagonale de la matrice.
  13. C Si IOPT=2, on renvoie un inverse approché (SPAI)
  14. C diagonal de la matrice entrée.
  15. C Son expression est :
  16. C m_ii = a_ii / \sum_{j=1,n} aij^2
  17. C
  18. C Voir aussi la notice de KOPS
  19. C
  20. C***********************************************************************
  21. C HISTORIQUE : 21/03/08 : Première version
  22. C
  23. C***********************************************************************
  24. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  25. C en cas de modification de ce sous-programme afin de faciliter
  26. C la maintenance !
  27. C***********************************************************************
  28. -INC CCOPTIO
  29. -INC CCREEL
  30. -INC SMCHPOI
  31. POINTEUR MCHDIA.MCHPOI
  32. POINTEUR MATRI2.MATRIK
  33. POINTEUR AMORS.PMORS
  34. POINTEUR AISA.IZA
  35. POINTEUR IDIAGO.IZA
  36. POINTEUR ISCAR.IZA
  37. INTEGER IMPR,IRET
  38. C
  39. CHARACTER*4 MRENU,MMULAG
  40. CHARACTER*8 TYPE
  41. CHARACTER*8 TYMATK,TYRIGI,BLAN
  42. DATA TYMATK,TYRIGI,BLAN/'MATRIK ','RIGIDITE',' '/
  43. *
  44. IMPR=0
  45. *
  46. * Lecture de la matrice
  47. *
  48. TYPE=BLAN
  49. CALL QUETYP(TYPE,1,IRET)
  50. IF (IRET.EQ.0) GOTO 9999
  51. IF (TYPE.EQ.TYRIGI) THEN
  52. IF (IOPT.EQ.2) THEN
  53. * Transformation en matrik en changement de noms d'inconnues
  54. CALL RIMA
  55. IF (IERR.NE.0) RETURN
  56. CALL MACHI2(1)
  57. IF (IERR.NE.0) RETURN
  58. ELSE
  59. CALL LIROBJ('RIGIDITE',IRIG,1,IRET)
  60. IF (IERR.NE.0) RETURN
  61. *
  62. CALL EXDIAR(IRIG,ICHP)
  63. IF (IERR.NE.0) RETURN
  64. *
  65. CALL ECROBJ('CHPOINT ',ICHP)
  66. RETURN
  67. ENDIF
  68. ENDIF
  69. TYPE=TYMATK
  70. CALL LIROBJ(TYPE,MATRIK,1,IRET)
  71. IF(IRET.EQ.0) GOTO 9999
  72. C
  73. C Assemblage proprement dit
  74. C
  75. C Attention, on effectue une recopie du chapeau pour ne garder
  76. C aucune information de préconditionnement (assemblage, numérotation)
  77. C dans la matrice originale sinon une résolution subséquente poserait
  78. C problème !!!!!!
  79. C
  80. SEGINI,MATRI2=MATRIK
  81. MATRIK=MATRI2
  82. MATASS=MATRIK
  83. MRENU='RIEN'
  84. MMULAG='RIEN'
  85. * SG 2016/02/09 : non à la ligne suivante : il faut que METASS soit
  86. * égale à 5 (voir remarque dans makpr2)
  87. * METASS=4
  88. METASS=5
  89.  
  90. CALL KRES3(MATRIK,MATASS,MRENU,MMULAG,METASS,
  91. $ 0,.FALSE.,
  92. $ IMPR,IRET)
  93. IF (IRET.NE.0) GOTO 9999
  94. C
  95. C Extraction de la diagonale
  96. C
  97. SEGACT MATRIK
  98. AMORS=MATRIK.KIDMAT(4)
  99. AISA=MATRIK.KIDMAT(5)
  100. *
  101. SEGACT AMORS
  102. SEGACT AISA
  103. NTTDDL=AMORS.IA(/1)-1
  104. NBVA=NTTDDL
  105. SEGINI IDIAGO
  106. IF (IOPT.EQ.2) THEN
  107. SEGINI ISCAR
  108. ENDIF
  109. DO ITTDDL=1,NTTDDL
  110. JSTRT=AMORS.IA(ITTDDL)
  111. JSTOP=AMORS.IA(ITTDDL+1)-1
  112. DO J=JSTRT,JSTOP
  113. JTTDDL=AMORS.JA(J)
  114. IF (JTTDDL.EQ.ITTDDL) THEN
  115. IDIAGO.A(ITTDDL)=AISA.A(J)
  116. ENDIF
  117. IF (IOPT.EQ.2) THEN
  118. VAL=AISA.A(J)
  119. ISCAR.A(ITTDDL)=ISCAR.A(ITTDDL)+(VAL*VAL)
  120. ENDIF
  121. ENDDO
  122. ENDDO
  123. SEGSUP AISA
  124. SEGSUP AMORS
  125. *
  126. IF (IOPT.EQ.2) THEN
  127. DO ITTDDL=1,NTTDDL
  128. VAL=ISCAR.A(ITTDDL)
  129. IF (VAL.LE.SQRT(XPETIT)) THEN
  130. WRITE(IOIMP,*) 'La ligne ',ITTDDL,
  131. $ ' de la matrice est nulle : ', VAL
  132. GOTO 9999
  133. ENDIF
  134. IDIAGO.A(ITTDDL)=IDIAGO.A(ITTDDL)/VAL
  135. ENDDO
  136. ENDIF
  137. IF (IOPT.EQ.2) THEN
  138. SEGSUP ISCAR
  139. ENDIF
  140. C
  141. C Transformation en chpoint
  142. C
  143. CALL XDISP(MATRIK,IDIAGO,MCHDIA,IMPR,IRET)
  144. IF (IRET.NE.0) GOTO 9999
  145. SEGSUP IDIAGO
  146. SEGSUP MATRIK
  147. CALL ECROBJ('CHPOINT ',MCHDIA)
  148. *
  149. * Normal termination
  150. *
  151. RETURN
  152. *
  153. * Format handling
  154. *
  155. *
  156. * Error handling
  157. *
  158. 9999 CONTINUE
  159. WRITE(IOIMP,*) 'An error was detected in exdiag.eso'
  160. * 153 2
  161. * Opération illicite dans ce contexte
  162. CALL ERREUR(153)
  163. RETURN
  164. *
  165. * End of EXDIAG
  166. *
  167. END
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  

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