Télécharger graamo.eso

Retour à la liste

Numérotation des lignes :

  1. C GRAAMO SOURCE CHAT 05/01/13 00:19:25 5004
  2. C GRAAMO SOURCE WP 23/08/94
  3. C SUBROUTINE GRAAMO ( IPLSNO, IPRIGI )
  4. ************************************************************************
  5. *
  6. * GRAAMO
  7. * -----------
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. * ORTHONORMALISER UNE SUITE DE 'CHPOINT' PAR RAPPORT A UNE RIGIDITE
  13. * si dans le processus on detecte des vecteurs du noyau on les
  14. * enleve
  15. *
  16. * MODE D'APPEL:
  17. * -------------
  18. *
  19. * CALL GRAAMO ( IPLSNO, IPRIGI )
  20. *
  21. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  22. * -----------
  23. *
  24. * IPLSNO ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
  25. * LA SUITE DE 'CHPOINT' NON ORTHOGONAUX,
  26. * MAIS LINEAIREMENT INDEPENDANTS.
  27. *
  28. * IPLSNO ENTIER (S) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
  29. * LA SUITE DE 'CHPOINT' ORTHOGONAUX.
  30. *
  31. * IPRIGI ENTIER (E) POINTEUR SUR L'OBJET 'RIGIDITE' PAR
  32. * RAPPORT AUQUEL ON ORTHOGONALISE.
  33. *
  34. *
  35. *
  36. * MODE DE FONCTIONNEMENT:
  37. * -----------------------
  38. *
  39. * PROCEDE D'ORTHOGONALISATION DE GRAM-SCHMITH.
  40. *
  41. * AUTEUR, DATE DE CREATION:
  42. * -------------------------
  43. *
  44. * A.M. JOLIVALT, W. PASILLAS 06 / 07 / 94. ( ESOPE )
  45. *
  46. ***************************************************
  47.  
  48. SUBROUTINE GRAAMO ( IPLSNO, IPRIGI )
  49.  
  50. IMPLICIT INTEGER(I-N)
  51. IMPLICIT REAL*8 (A-H,O-Z)
  52.  
  53. -INC CCOPTIO
  54. -INC SMLCHPO
  55. -INC CCREEL
  56.  
  57. ******
  58. * -- ARGUMENTS --
  59. ***
  60. POINTEUR IPLSNO.MLCHPO
  61. INTEGER IPRIGI
  62.  
  63. ******
  64. * -- VARIABLES LOCALES --
  65. ***
  66. POINTEUR IPLSO.MLCHPO
  67. INTEGER ILDIM, IB100, IB200
  68. INTEGER IPTMP, IPTMP1, IPCHPO, IPLMOT
  69. CHARACTER*4 MOTCLE
  70. ******
  71. * -- ON CREE UNE 'LISTCHPO' VIDE --
  72. ***
  73. N1 = 0
  74. SEGINI ,IPLSO
  75. segdes iplso
  76.  
  77. ******
  78. * -- DANS LAQUELLE ON INSERE DES VECTEURS ORTHOGONALISES
  79. * PAR GRAAM1 ET NORMES PAR NORMA1. --
  80. ***
  81. CALL MOTS1( IPLMOT, MOTCLE )
  82. IF ( IERR .NE. 0 ) RETURN
  83. SEGACT ,IPLSNO
  84. ILDIM = IPLSNO.ICHPOI(/1)
  85.  
  86. DO 100 IB100 = 1, ILDIM
  87. IPCHPO = IPLSNO.ICHPOI( IB100 )
  88. CALL GRAAM1 ( IPCHPO, IPRIGI, IPLSO, IPTMP )
  89. IF ( IERR .NE. 0 ) RETURN
  90. * on teste si la matrice est singuliere
  91. * on ne garde pas les vecteurs du noyau
  92. call xtmx(iptmp,iprigi,xm)
  93. if (abs(xm).gt.1d2*xpetit) then
  94. CALL NORMA1 ( IPTMP, IPLMOT, MOTCLE, IPTMP1 )
  95. IF ( IERR .NE. 0 ) RETURN
  96. CALL DTCHPO ( IPTMP )
  97. IF ( IERR .NE. 0 ) RETURN
  98. segact iplso*mod
  99. IPLSO.ICHPOI(**) = IPTMP1
  100. segdes iplso
  101. endif
  102. 100 CONTINUE
  103.  
  104. ******
  105. * -- ON EFFACE L'ANCIENNE LISTE --
  106. ***
  107. DO 200 IB200 = 1, ILDIM
  108. IPCHPO = IPLSNO.ICHPOI(IB200)
  109. CALL DTCHPO ( IPCHPO )
  110. IF ( IERR .NE. 0 ) RETURN
  111. 200 CONTINUE
  112. CALL DTLCHP ( IPLSNO )
  113. segsup iplsno
  114. ******
  115. * -- ON RETOURNE LA NOUVELLE LISTE --
  116. ***
  117. IPLSNO = IPLSO
  118.  
  119. RETURN
  120. END
  121.  
  122.  
  123.  
  124.  

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