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.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC CCREEL
  32. -INC SMCHPOI
  33. POINTEUR MCHDIA.MCHPOI
  34. POINTEUR MATRI2.MATRIK
  35. POINTEUR AMORS.PMORS
  36. POINTEUR AISA.IZA
  37. POINTEUR IDIAGO.IZA
  38. POINTEUR ISCAR.IZA
  39. INTEGER IMPR,IRET
  40. C
  41. CHARACTER*4 MRENU,MMULAG
  42. CHARACTER*8 TYPE
  43. CHARACTER*8 TYMATK,TYRIGI,BLAN
  44. DATA TYMATK,TYRIGI,BLAN/'MATRIK ','RIGIDITE',' '/
  45. *
  46. IMPR=0
  47. *
  48. * Lecture de la matrice
  49. *
  50. TYPE=BLAN
  51. CALL QUETYP(TYPE,1,IRET)
  52. IF (IRET.EQ.0) GOTO 9999
  53. IF (TYPE.EQ.TYRIGI) THEN
  54. IF (IOPT.EQ.2) THEN
  55. * Transformation en matrik en changement de noms d'inconnues
  56. CALL RIMA
  57. IF (IERR.NE.0) RETURN
  58. CALL MACHI2(1)
  59. IF (IERR.NE.0) RETURN
  60. ELSE
  61. CALL LIROBJ('RIGIDITE',IRIG,1,IRET)
  62. IF (IERR.NE.0) RETURN
  63. *
  64. CALL EXDIAR(IRIG,ICHP)
  65. IF (IERR.NE.0) RETURN
  66. *
  67. CALL ECROBJ('CHPOINT ',ICHP)
  68. RETURN
  69. ENDIF
  70. ENDIF
  71. TYPE=TYMATK
  72. CALL LIROBJ(TYPE,MATRIK,1,IRET)
  73. IF(IRET.EQ.0) GOTO 9999
  74. C
  75. C Assemblage proprement dit
  76. C
  77. C Attention, on effectue une recopie du chapeau pour ne garder
  78. C aucune information de préconditionnement (assemblage, numérotation)
  79. C dans la matrice originale sinon une résolution subséquente poserait
  80. C problème !!!!!!
  81. C
  82. SEGINI,MATRI2=MATRIK
  83. MATRIK=MATRI2
  84. MATASS=MATRIK
  85. MRENU='RIEN'
  86. MMULAG='RIEN'
  87. * SG 2016/02/09 : non à la ligne suivante : il faut que METASS soit
  88. * égale à 5 (voir remarque dans makpr2)
  89. * METASS=4
  90. METASS=5
  91.  
  92. CALL KRES3(MATRIK,MATASS,MRENU,MMULAG,METASS,
  93. $ 0,.FALSE.,
  94. $ IMPR,IRET)
  95. IF (IRET.NE.0) GOTO 9999
  96. C
  97. C Extraction de la diagonale
  98. C
  99. SEGACT MATRIK
  100. AMORS=MATRIK.KIDMAT(4)
  101. AISA=MATRIK.KIDMAT(5)
  102. *
  103. SEGACT AMORS
  104. SEGACT AISA
  105. NTTDDL=AMORS.IA(/1)-1
  106. NBVA=NTTDDL
  107. SEGINI IDIAGO
  108. IF (IOPT.EQ.2) THEN
  109. SEGINI ISCAR
  110. ENDIF
  111. DO ITTDDL=1,NTTDDL
  112. JSTRT=AMORS.IA(ITTDDL)
  113. JSTOP=AMORS.IA(ITTDDL+1)-1
  114. DO J=JSTRT,JSTOP
  115. JTTDDL=AMORS.JA(J)
  116. IF (JTTDDL.EQ.ITTDDL) THEN
  117. IDIAGO.A(ITTDDL)=AISA.A(J)
  118. ENDIF
  119. IF (IOPT.EQ.2) THEN
  120. VAL=AISA.A(J)
  121. ISCAR.A(ITTDDL)=ISCAR.A(ITTDDL)+(VAL*VAL)
  122. ENDIF
  123. ENDDO
  124. ENDDO
  125. SEGSUP AISA
  126. SEGSUP AMORS
  127. *
  128. IF (IOPT.EQ.2) THEN
  129. DO ITTDDL=1,NTTDDL
  130. VAL=ISCAR.A(ITTDDL)
  131. IF (VAL.LE.SQRT(XPETIT)) THEN
  132. WRITE(IOIMP,*) 'La ligne ',ITTDDL,
  133. $ ' de la matrice est nulle : ', VAL
  134. GOTO 9999
  135. ENDIF
  136. IDIAGO.A(ITTDDL)=IDIAGO.A(ITTDDL)/VAL
  137. ENDDO
  138. ENDIF
  139. IF (IOPT.EQ.2) THEN
  140. SEGSUP ISCAR
  141. ENDIF
  142. C
  143. C Transformation en chpoint
  144. C
  145. CALL XDISP(MATRIK,IDIAGO,MCHDIA,IMPR,IRET)
  146. IF (IRET.NE.0) GOTO 9999
  147. SEGSUP IDIAGO
  148. SEGSUP MATRIK
  149. CALL ECROBJ('CHPOINT ',MCHDIA)
  150. *
  151. * Normal termination
  152. *
  153. RETURN
  154. *
  155. * Format handling
  156. *
  157. *
  158. * Error handling
  159. *
  160. 9999 CONTINUE
  161. WRITE(IOIMP,*) 'An error was detected in exdiag.eso'
  162. * 153 2
  163. * Opération illicite dans ce contexte
  164. CALL ERREUR(153)
  165. RETURN
  166. *
  167. * End of EXDIAG
  168. *
  169. END
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  

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