Télécharger arpsol.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPSOL SOURCE BP208322 20/02/06 21:15:11 10512
  2. SUBROUTINE ARPSOL (SIGMA,CHOIX,QUAD,NVAL,IPRIGI,IPMASS,LAGDUA,NK,
  3. & NM,INVER,PIRE,SYM,CHOLE,IPSOLU,EPSI)
  4.  
  5. ***********************************************************************
  6. *
  7. * A R P S O L
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. * SOLVEUR DU PROBLEME LINAIRE AUX VALEURS PROPRES AVEC LA METHODE
  13. * IRAM (METHODE D'ARNOLDI AVEC REDEMARRAGE IMPLICITE)
  14. *
  15. *
  16. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  17. * -----------
  18. *
  19. * SIGMA COMPLEX DP (E) VALEUR PROPRE DE SHIFT
  20. *
  21. * CHOIX CHAINE*2 (E) VALEURS PROPRES VOULUES
  22. * LM - VP DE MODULE MAX
  23. * SM - VP DE MODULE MIN
  24. * LR - VP DE PARTIE R MAX
  25. * SR - VP DE PARTIE R MIN
  26. * LI - VP DE PARTIE I MAX
  27. * SI - VP DE PARTIE I MIN
  28. * LA - VP MAX
  29. * SA - VP MIN
  30. * BE - VP DE CHAQUE COTE
  31. *
  32. * QUAD LOGIQUE (E) PROBLEME QUADRATIQUE OU NON
  33. *
  34. * NVAL ENTIER (E) NOMBRE DE MODES PROPRES A CALCULER
  35. *
  36. * IPRIGI ENTIER (E) POINTEUR D'UNE RIGIDITE
  37. *
  38. * IPMASS ENTIER (E) POINTEUR D'UNE MASSE
  39. *
  40. * LAGDUA ENTIER (E) NB DE M. DE LAGRANGE DUALISES
  41. *
  42. * NK ENTIER (E) DIMENSION DU PROBLEME (K)
  43. *
  44. * NM ENTIER (E) DIMENSION DU PROBLEME (M)
  45. *
  46. * INVER LOGIQUE (E) .TRUE. -> PRODUIT SCALAIRE X'KX
  47. * .FALSE. -> PRODUIT SCALAIRE X'MX
  48. *
  49. * PIRE LOGIQUE (E) PRODUIT SCALAIRE EUCLIDIEN
  50. *
  51. * SYM LOGIQUE (E) PROBLEME SYMETRIQUE OU NON
  52. *
  53. * CHOLE LOGIQUE (E) CHOLESKY NON ALTERNATIVE POSSIBLE
  54. *
  55. * IPSOLU ENTIER (S) POINTEUR SUR LA SOLUTION CREE
  56. *
  57. * EPSI REEL DP (E) ZERO DE TOLERANCE
  58. *
  59. *
  60. * SOUS-PROGRAMMES APPELES:
  61. * ------------------------
  62. *
  63. * ARPINI,ARPALE,ARPOPE,ARPITL,ARPOST
  64. *
  65. * AUTEUR, DATE DE CREATION:
  66. * -------------------------
  67. *
  68. * PASCAL BOUDA 29 JUIN 2015
  69. *
  70. * LANGAGE:
  71. * --------
  72. *
  73. * FORTRAN 77 & 90
  74. *
  75. ***********************************************************************
  76.  
  77. IMPLICIT INTEGER(I-N)
  78. IMPLICIT REAL*8 (A-H,O-Z)
  79.  
  80. -INC CCOPTIO
  81. -INC TARWORK
  82.  
  83. COMPLEX*16 SIGMA
  84. CHARACTER*2 CHOIX
  85. LOGICAL QUAD
  86. INTEGER NVAL
  87. INTEGER IPRIGI
  88. INTEGER IPMASS
  89. INTEGER LAGDUA
  90. INTEGER NK
  91. INTEGER NM
  92. LOGICAL INVER
  93. LOGICAL PIRE
  94. LOGICAL SYM
  95. LOGICAL CHOLE
  96. INTEGER IPSOLU
  97. REAL*8 EPSI
  98.  
  99. INTEGER ITER
  100. INTEGER IPRTRA
  101. INTEGER IPBUFF
  102. LOGICAL OUT
  103.  
  104.  
  105. *Nombre maximal d'iteration autorise
  106. MAXITE=MIN(100*MAX(NK,NM),10000)
  107.  
  108. *Initialisation de tous les paramètres ARPACK
  109. CALL ARPINI (NVAL,NK,SYM,CHOLE,INVER,PIRE,
  110. & SIGMA,CHOIX,IPMAUP,MAXITE)
  111.  
  112. *Construction des operateurs de travail
  113. CALL ARPOPE (IPRIGI,IPMASS,0,QUAD,SIGMA,IPRTRA)
  114.  
  115. *Inititalisation du vecteur residu d'arpack
  116. CALL ARPALE (IPRTRA,IPMAUP,QUAD)
  117. IF (IERR.NE.0) GOTO 999
  118.  
  119. *Boucle pour la factorisation d'Arnoldi
  120. DO ITER=1,MAXITE
  121. IF (IIMPI.GE.10) WRITE(IOIMP,*) '*** ITERATION N°:',ITER,'***'
  122. *Iteration
  123. CALL ARPITL (IPRTRA,IPMAUP,SIGMA,INVER,SYM,EPSI,OUT)
  124. IF (IERR.NE.0) GOTO 999
  125. *Sortie si convergence
  126.  
  127. IF (OUT) THEN
  128. GOTO 999
  129. END IF
  130.  
  131. ENDDO
  132.  
  133. * sortie car on a atteint le nombre maxi d'iterations sans converger
  134. * "Pas de convergence apres %i1 iterations. L'execution continue"
  135. INTERR(1)=MAXITE
  136. CALL ERREUR(151)
  137.  
  138. 999 CONTINUE
  139.  
  140. IF (IIMPI.GE.1)
  141. & WRITE(IOIMP,*) '*** SORTIE APRES :',ITER,' ITERATIONS ***'
  142.  
  143. *Post-traitement des resultats: creation de l'objet solution
  144. CALL ARPOST (IPRTRA,LAGDUA,SIGMA,QUAD,SYM,INVER,
  145. & IPMAUP,IPSOLU,EPSI)
  146. IF (IERR.NE.0) RETURN
  147.  
  148. *Destruction des operateurs de travail (matrices principales exclues)
  149.  
  150. MRITRA=IPRTRA
  151. SEGACT MRITRA*MOD
  152. DO i=3,RIGI(/1)
  153. IF (RIGI(i) .NE. 0) THEN
  154. IPBUFF=RIGI(i)
  155. CALL DTRIGI(IPBUFF)
  156. c RIGI(i)=0
  157. ENDIF
  158. ENDDO
  159. SEGSUP MRITRA
  160. IF (IERR.NE.0) RETURN
  161.  
  162. *Suppression du segment de travail ARPACK
  163. MAUP=IPMAUP
  164. c SEGSUP MAUP
  165.  
  166. END
  167.  
  168.  
  169.  
  170.  

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