Télécharger extr13.eso

Retour à la liste

Numérotation des lignes :

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

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