Télécharger diagn1.eso

Retour à la liste

Numérotation des lignes :

  1. C DIAGN1 SOURCE PV 19/06/03 21:15:00 10225
  2. SUBROUTINE DIAGN1 (IPRIGI,INFER0)
  3. ************************************************************************
  4. *
  5. * D I A G N 1
  6. * -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. * EXECUTER LA FONCTION ATTRIBUEE A L'OPERATEUR "DIAGNEG".
  12. *
  13. * MODE D'APPEL:
  14. * -------------
  15. *
  16. * CALL DIAGN1 (IPRIGI,INFER0)
  17. *
  18. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  19. * -----------
  20. *
  21. * IPRIGI ENTIER (E) POINTEUR D'UNE 'RIGIDITE'.
  22. * INFER0 ENTIER (S) NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA
  23. * MATRICE DIAGONALE "D" DE LA 'RIGIDITE'
  24. * DECOMPOSEE EN "L.D.LT"
  25. *
  26. * AUTEUR, DATE DE CREATION:
  27. * -------------------------
  28. *
  29. * PASCAL MANIGOT 8 OCTOBRE 1984
  30. *
  31. * LANGAGE:
  32. * --------
  33. *
  34. * ESOPE + FORTRAN77
  35. *
  36. ************************************************************************
  37. *
  38. IMPLICIT INTEGER(I-N)
  39. -INC CCOPTIO
  40. -INC SMMATRI
  41. -INC SMRIGID
  42. -INC SMTABLE
  43. *
  44. integer insym
  45. infer0 = 0
  46. isupt = 0
  47. insym = 0
  48. MRIGID = IPRIGI
  49. SEGACT,MRIGID
  50. isupt = isupeq
  51. ** write(6,*) ' isupt 1 dans diagn1 ',isupt
  52. * write (6,*) ' isupeq 1 ',isupeq
  53. ipoiri = jrcond
  54. if (ipoiri.ne.0) then
  55. mrigid = ipoiri
  56. segact mrigid
  57. if (isupt.eq.0) isupt = isupeq
  58. ** write(6,*) ' isupt 2 dans diagn1 ',isupt
  59. * write (6,*) ' isupoq 2 ',isupeq
  60. endif
  61. NRG = IRIGEL(/1)
  62. NBR = IRIGEL(/2)
  63. if (nbr.eq.0) then
  64. infer0 = 0
  65. segdes mrigid
  66. return
  67. endif
  68. IPMATR = ICHOLE
  69. IF(NORINC.GT.0 .AND. NORIND.GT.0) THEN
  70. INSYM = 1
  71. ENDIF
  72. IF (NRG.GE.7) THEN
  73. DO 9 IN = 1,NBR
  74. IANTI=IRIGEL(7,IN)
  75. IF(IANTI.GT.0) THEN
  76. INSYM = 1
  77. ENDIF
  78. 9 CONTINUE
  79. ENDIF
  80. ** SEGDES,MRIGID
  81. *
  82. mrigid=iprigi
  83. do ifois=1,29
  84. * write(6,*) 'diagn1 ifois ipmatr mrigid ',ifois,ipmatr,mrigid
  85. if (jrcond.ne.0) then
  86. mrigid=jrcond
  87. segact mrigid
  88. nbr=irigel(/2)
  89. if (nbr.eq.0) then
  90. infer0 = 0
  91. * write(6,*) ' diagn1 nbr 0 '
  92. segdes mrigid
  93. return
  94. endif
  95. if(isupt.eq.0) isupt=isupeq
  96. endif
  97. enddo
  98. if (ichole.eq.0) then
  99. IF (IPMATR .EQ. 0) THEN
  100. IF (INSYM .EQ. 0) THEN
  101. CALL TRIANG (mrigid,1D-18,0)
  102. ELSE
  103. CALL ldmt1(mrigid,1d-18)
  104. ENDIF
  105. IF (IERR .NE. 0) RETURN
  106. MRIGID = IPRIGI
  107. SEGACT,MRIGID
  108. IPMATR = ICHOLE
  109. END IF
  110. endif
  111. if (isupt.ne.0) then
  112. mtable = isupt
  113. segact mtable
  114. CALL ACCTAB(mtable,'ENTIER',13,0.d0,' ',.true.,IP0,
  115. & 'ENTIER',infer0,X1,CHARRE,.true.,ITMOD)
  116. * write (6,*) ' unilateral nbneg ',infer0
  117. segdes mtable
  118. END IF
  119. *
  120.  
  121. if (ichole.ne.0.and.isupt.eq.0) then
  122. MMATRI = ichole
  123. SEGACT,MMATRI
  124. INFER0 = INEG
  125. SEGDES,MMATRI
  126. else
  127. *** infer0=0
  128. endif
  129. *
  130. END
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  

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