Télécharger extr13.eso

Retour à la liste

Numérotation des lignes :

extr13
  1. C EXTR13 SOURCE PV 17/09/29 21:15:10 9578
  2. SUBROUTINE EXTR13(IRIG,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. ************************************************************************
  6. *
  7. * E X T R 1 3
  8. * -----------
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * Sous-programme pour extraire d'une rigidit{ :
  14. * - les matrices élémentaires symétriques si IRET = 3
  15. * - les matrices élémentaires antisymétriques si IRET = 4
  16. *
  17. * MODULES UTILISES:
  18. * -----------------
  19. *
  20.  
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMRIGID
  24. *
  25. * PARAMETRES: (e)=ENTREE (s)=SORTIE (+ = CONTENU DANS UN COMMUN)
  26. * -----------
  27. *
  28. * IRIG (e) pointeur sur l'objet RIGIDITE.
  29. * IRET (e) = 3 , matrice symétrique.
  30. * = 4 , matrice antisymétrique.
  31. *
  32. * AUTEUR, DATE DE CREATION:
  33. * -------------------------
  34. *
  35. * Lionel VIVAN juin 1991
  36. *
  37. * LANGAGE:
  38. * --------
  39. *
  40. * ESOPE + FORTRAN77
  41. *
  42. ************************************************************************
  43. *
  44. RI1 = IRIG
  45. SEGACT RI1
  46. C ... NRIG1 = taille du tableau d'infos ...
  47. NRIG1 = RI1.IRIGEL(/1)
  48. C ... NRIGE1 = nombre de "sous-matrices" ...
  49. NRIGE1 = RI1.IRIGEL(/2)
  50. ISYM = 0
  51. IANT = 0
  52. IF (NRIG1.GE.7) THEN
  53. DO 10 IN = 1,NRIGE1
  54. IANTI = RI1.IRIGEL(7,IN)
  55. IF (IANTI.EQ.0) ISYM = ISYM + 1
  56. IF (IANTI.EQ.1) IANT = IANT + 1
  57. IF (IANTI.EQ.2) THEN
  58. ISYM = ISYM + 1
  59. IANT = IANT + 1
  60. ENDIF
  61. 10 CONTINUE
  62. ELSE
  63. ISYM = NRIGE1
  64. ENDIF
  65. *
  66. * On extrait les matrices ...
  67. *
  68. NRIGE = NRIG1
  69. IF(IRET.EQ.3) THEN
  70. NRIGEL = ISYM
  71. ELSE IF(IRET.EQ.4) THEN
  72. NRIGEL = IANT
  73. ENDIF
  74. SEGINI MRIGID
  75. IRIS = MRIGID
  76. MTYMAT = RI1.MTYMAT
  77. ICHOLE = 0
  78. IMGEO1 = 0
  79. IMGEO2 = 0
  80. IFORIG = RI1.IFORIG
  81. ISUPEQ = 0
  82. II = 0
  83. DO 20 IN = 1,NRIGE1
  84. IF(NRIG1.GE.7) THEN
  85. IANTI = RI1.IRIGEL(7,IN)
  86. ELSE
  87. IANTI = 0
  88. ENDIF
  89. C ... Si la matrice possède déjà la bonne symétrie,
  90. C on ne fait que recopier les pointeurs, sinon,
  91. C si la matrice est non-symétrique on va en
  92. C extraire ce qu'il faut ...
  93. IF (IANTI.EQ.2.OR.IANTI.EQ.IRET-3) THEN
  94. II = II + 1
  95. COERIG(II) = RI1.COERIG(IN)
  96. DO 22 IN2 = 1,NRIGE
  97. IRIGEL(IN2,II) = RI1.IRIGEL(IN2,IN)
  98. 22 CONTINUE
  99. C ... si la matrice est non-symétrique, il faut
  100. C surcharger le flag de symétrie (N° 7) et
  101. C le pointeur sur IMATRI (N° 4) ...
  102. IF(IANTI.EQ.2) THEN
  103. IRIGEL(7,II) = IRET-3
  104. xMATR1 = RI1.IRIGEL(4,IN)
  105. SEGACT,xMATR1
  106. NELRIG = xmatr1.re(/3)
  107. nligrp = xmatr1.re(/2)
  108. nligrd= xmatr1.re(/1)
  109. SEGINI xMATRI
  110. xmatri.symre=irigel(7,ii)
  111. IRIGEL(4,II) = xMATRI
  112. DO 25 INUMEL = 1,NELRIG
  113. * XMATR1 = IMATR1.IMATTT(INUMEL)
  114. * SEGACT XMATR1
  115. * NLIGRD = XMATR1.RE(/1)
  116. * NLIGRP = XMATR1.RE(/2)
  117. IF(NLIGRD.NE.NLIGRP) THEN
  118. write(*,*) 'Matrice non carrée !!!'
  119. return
  120. ENDIF
  121. * SEGINI XMATRI
  122. * IMATTT(INUMEL) = XMATRI
  123. DO 26 ILIG=1,NLIGRP
  124. DO 27 ICOL=1,NLIGRD
  125. IF(IRET.EQ.3) RE(ICOL,ILIG,inumel) =
  126. & (XMATR1.RE(ICOL,ILIG,inumel)+XMATR1.RE(ILIG,ICOL,inumel))/2.d0
  127. IF(IRET.EQ.4) RE(ICOL,ILIG,inumel) =
  128. & (XMATR1.RE(ICOL,ILIG,inumel)-XMATR1.RE(ILIG,ICOL,inumel))/2.D0
  129. 27 CONTINUE
  130. 26 CONTINUE
  131. * SEGDES XMATRI
  132. * SEGDES XMATR1
  133. 25 CONTINUE
  134. SEGDES xMATR1,xmatri
  135. ENDIF
  136. ENDIF
  137. 20 CONTINUE
  138.  
  139. SEGDES MRIGID
  140. SEGDES RI1
  141. CALL ECROBJ('RIGIDITE',IRIS)
  142. *
  143. RETURN
  144. END
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  

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