Télécharger diagne.eso

Retour à la liste

Numérotation des lignes :

  1. C DIAGNE SOURCE GF238795 18/02/01 21:15:14 9724
  2. SUBROUTINE DIAGNE
  3. ************************************************************************
  4. *
  5. * D I A G N E
  6. * -----------
  7. *
  8. * SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "DIAGNEG"
  9. *
  10. * FONCTION:
  11. * ---------
  12. * DONNER LE NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA MATICE
  13. * DIAGONALE "D" D'UNE 'RIGIDITE' DECOMPOSEE EN L.D.LT
  14. *
  15. * PHRASE D'APPEL (EN GIBIANE):
  16. * ----------------------------
  17. * NOMBRE = DIAGNEG RIGID ;
  18. *
  19. * ARGUMENTS (EN GIBIANE):
  20. * -----------------------
  21. * RIGID 'RIGIDITE' MATRICE DE RIGIDITE.
  22. * NOMBRE 'ENTIER ' NOMBRE DE TERMES DIAGONAUX NEGATIFS.
  23. *
  24. * DICTIONNAIRE DES VARIABLES: (ORDRE ALPHABETIQUE)
  25. * ---------------------------
  26. * IPRIGI ENTIER POINTEUR SUR "RIGID".
  27. * INFER0 ENTIER CONTENU DE "NOMBRE".
  28. *
  29. * SOUS-PROGRAMMES APPELES: LIRE, ECRIRE, DIAGN1.
  30. *
  31. * CREATION: PASCAL MANIGOT, 8 OCTOBRE 1984
  32. * MODIF : - correction bug si on utilise DIAG puis RESO (BP, 12/05/2011)
  33. * en utilisant syntaxe de RESOU
  34. * - idem mais en gardant la syntaxe d'origine (BP, 12/09/2011)
  35. *
  36. * LANGAGE: FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS
  37. *
  38. ************************************************************************
  39. *
  40. IMPLICIT INTEGER(I-N)
  41. -INC CCOPTIO
  42. -INC SMRIGID
  43. -INC SMELEME
  44. INTEGER lagdu
  45. *
  46. *
  47. *
  48. lagdu=0
  49. ICODE = 1
  50. CALL LIROBJ ('RIGIDITE',IPRIGI,ICODE,IRETOU)
  51. if (ierr.ne.0) return
  52.  
  53. c c bp: ancienne methode -----------------------------------------------*
  54. c call dbblx(iprigi,lagdu)
  55. c IF(IERR .NE. 0) RETURN
  56.  
  57. c c bp: nouvelle methode (basee sur RESOU) -----------------------------*
  58. c IPRIG0=IPRIGI
  59. c ipoiri=IPRIGI
  60. c * verification pas de blocage en double
  61. c call verlag(ipoiri)
  62. c if(ierr.ne.0) return
  63. c * y a t il des matrices de relations non unilaterales
  64. c ipoir0 = ipoiri
  65. c mrigid=ipoiri
  66. c segact mrigid
  67. c nrige= irigel(/1)
  68. c idepe=0
  69. c nbr = irigel(/2)
  70. c do 1000 irig = 1,nbr
  71. c meleme=irigel(1,irig)
  72. c segact meleme
  73. c if((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
  74. c & idepe=idepe+1
  75. c if(irigel(6,irig).ne.0) iunil=1
  76. c segdes meleme
  77. c 1000 continue
  78. c * idepe=0
  79. c lagdua=0
  80. c
  81. c if (idepe.ne.0) then
  82. c
  83. c C on va separer les raideurs
  84. c if (jrcond.eq.0) then
  85. c call separm(mrigid,ri1,ri2,nounil,lagdua)
  86. c segact mrigid*mod
  87. c jrelim=ri1
  88. c jrgard=ri2
  89. c imlag=lagdua
  90. c call fusrig(ri1,ri2,ipoir0)
  91. c jrtot=ipoir0
  92. c else
  93. c ri1=jrelim
  94. c ri2=jrgard
  95. c ipoir0=jrtot
  96. c lagdua=imlag
  97. c ipt1=lagdua
  98. c if(ipt1.ne.0) segact ipt1
  99. c endif
  100. c iri1s=ri1
  101. c iri2s=ri2
  102. c C
  103. c 1010 continue
  104. c C
  105. c * mrigid matrice complete
  106. c * ri1 dependance
  107. c * ri2 les autres matrices
  108. c * ri6 matrice de transfert
  109. c * ri3 matrice reduite
  110. c * ri5 matrice de transfert transposee
  111. c C
  112. c C on va proceder a la condensation rigidite
  113. c if (jrcond.eq.0) then
  114. c CALL DEPEN3(RI1,RI6)
  115. c call scnd2 (ri2,ri6,ri3)
  116. c segact ri3
  117. c if (ierr.ne.0) then
  118. c segsup ri1,ri2,ri6
  119. c return
  120. c endif
  121. c segact mrigid*mod
  122. c jrcond=ri3
  123. c JRDEPP=RI6
  124. c C dualisation de la (les) matrice(s) de dependance
  125. c call dual00(ri6,ri5)
  126. c jrdepd=ri5
  127. c ipoiri = ri3
  128. c else
  129. c ipoiri= jrcond
  130. c RI6 = JRDEPP
  131. c ri5 = jrdepd
  132. c endif
  133. c * test si ri3 est vide
  134. c ri3=jrcond
  135. c segact ri3
  136. c if(ri3.irigel(/2).eq.0) imtvid=1
  137. c C
  138. c segdes ri1,ri2,mrigid
  139. c
  140. c noid = 1
  141. c endif
  142. c
  143. c * bp : on fournit ipoiri = jrcond de IPRIG0 a DIAGN1 qui fait le reste
  144. c IPRIGI=ipoiri
  145.  
  146. c bp: ancienne methode corrigée --------------------------------------*
  147. * on travaille desormais sur une copie locale du mrigid
  148. mrigid=IPRIGI
  149. segini,RI1=mrigid
  150. IPRIGI=RI1
  151. segact ri1
  152. imlagl = ri1.imlag
  153. if (imlagl.eq.0) call dbblx(iprigi,lagdu)
  154. IF(IERR .NE. 0) RETURN
  155.  
  156. c bp: fin de la distinction entre methode ----------------------------*
  157. *
  158. CALL DIAGN1 (IPRIGI,INFER0)
  159. IF(IERR.NE.0) RETURN
  160. *
  161. CALL ECRENT (INFER0)
  162. *
  163. * destruction objets "locaux" (version ancienne methode corrigée)
  164. segsup,RI1
  165. ipt1=lagdu
  166. if(imlagl.eq.0.and.ipt1.ne.0) segsup,ipt1
  167. *
  168. END
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  

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