Télécharger diagne.eso

Retour à la liste

Numérotation des lignes :

  1. C DIAGNE SOURCE PV 12/12/04 21:15:06 7586
  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. *
  45. *
  46. *
  47. ICODE = 1
  48. CALL LIROBJ ('RIGIDITE',IPRIGI,ICODE,IRETOU)
  49. if (ierr.ne.0) return
  50.  
  51. c c bp: ancienne methode -----------------------------------------------*
  52. c call dbblx(iprigi,lagdu)
  53. c IF(IERR .NE. 0) RETURN
  54.  
  55. c c bp: nouvelle methode (basee sur RESOU) -----------------------------*
  56. c IPRIG0=IPRIGI
  57. c ipoiri=IPRIGI
  58. c * verification pas de blocage en double
  59. c call verlag(ipoiri)
  60. c if(ierr.ne.0) return
  61. c * y a t il des matrices de relations non unilaterales
  62. c ipoir0 = ipoiri
  63. c mrigid=ipoiri
  64. c segact mrigid
  65. c nrige= irigel(/1)
  66. c idepe=0
  67. c nbr = irigel(/2)
  68. c do 1000 irig = 1,nbr
  69. c meleme=irigel(1,irig)
  70. c segact meleme
  71. c if((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
  72. c & idepe=idepe+1
  73. c if(irigel(6,irig).ne.0) iunil=1
  74. c segdes meleme
  75. c 1000 continue
  76. c * idepe=0
  77. c lagdua=0
  78. c
  79. c if (idepe.ne.0) then
  80. c
  81. c C on va separer les raideurs
  82. c if (jrcond.eq.0) then
  83. c call separm(mrigid,ri1,ri2,nounil,lagdua)
  84. c segact mrigid*mod
  85. c jrelim=ri1
  86. c jrgard=ri2
  87. c imlag=lagdua
  88. c call fusrig(ri1,ri2,ipoir0)
  89. c jrtot=ipoir0
  90. c else
  91. c ri1=jrelim
  92. c ri2=jrgard
  93. c ipoir0=jrtot
  94. c lagdua=imlag
  95. c ipt1=lagdua
  96. c if(ipt1.ne.0) segact ipt1
  97. c endif
  98. c iri1s=ri1
  99. c iri2s=ri2
  100. c C
  101. c 1010 continue
  102. c C
  103. c * mrigid matrice complete
  104. c * ri1 dependance
  105. c * ri2 les autres matrices
  106. c * ri6 matrice de transfert
  107. c * ri3 matrice reduite
  108. c * ri5 matrice de transfert transposee
  109. c C
  110. c C on va proceder a la condensation rigidite
  111. c if (jrcond.eq.0) then
  112. c CALL DEPEN3(RI1,RI6)
  113. c call scnd2 (ri2,ri6,ri3)
  114. c segact ri3
  115. c if (ierr.ne.0) then
  116. c segsup ri1,ri2,ri6
  117. c return
  118. c endif
  119. c segact mrigid*mod
  120. c jrcond=ri3
  121. c JRDEPP=RI6
  122. c C dualisation de la (les) matrice(s) de dependance
  123. c call dual00(ri6,ri5)
  124. c jrdepd=ri5
  125. c ipoiri = ri3
  126. c else
  127. c ipoiri= jrcond
  128. c RI6 = JRDEPP
  129. c ri5 = jrdepd
  130. c endif
  131. c * test si ri3 est vide
  132. c ri3=jrcond
  133. c segact ri3
  134. c if(ri3.irigel(/2).eq.0) imtvid=1
  135. c C
  136. c segdes ri1,ri2,mrigid
  137. c
  138. c noid = 1
  139. c endif
  140. c
  141. c * bp : on fournit ipoiri = jrcond de IPRIG0 a DIAGN1 qui fait le reste
  142. c IPRIGI=ipoiri
  143.  
  144. c bp: ancienne methode corrigée --------------------------------------*
  145. * on travaille desormais sur une copie locale du mrigid
  146. mrigid=IPRIGI
  147. segini,RI1=mrigid
  148. IPRIGI=RI1
  149. segact ri1
  150. imlagl = ri1.imlag
  151. if (imlagl.eq.0) call dbblx(iprigi,lagdu)
  152. IF(IERR .NE. 0) RETURN
  153.  
  154. c bp: fin de la distinction entre methode ----------------------------*
  155. *
  156. CALL DIAGN1 (IPRIGI,INFER0)
  157. IF(IERR.NE.0) RETURN
  158. *
  159. CALL ECRENT (INFER0)
  160. *
  161. * destruction objets "locaux" (version ancienne methode corrigée)
  162. segsup,RI1
  163. ipt1=lagdu
  164. if(imlagl.eq.0.and.ipt1.ne.0) segsup,ipt1
  165. *
  166. END
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  

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