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.  
  81. -INC PPARAM
  82. -INC CCOPTIO
  83. -INC TARWORK
  84.  
  85. COMPLEX*16 SIGMA
  86. CHARACTER*2 CHOIX
  87. LOGICAL QUAD
  88. INTEGER NVAL
  89. INTEGER IPRIGI
  90. INTEGER IPMASS
  91. INTEGER LAGDUA
  92. INTEGER NK
  93. INTEGER NM
  94. LOGICAL INVER
  95. LOGICAL PIRE
  96. LOGICAL SYM
  97. LOGICAL CHOLE
  98. INTEGER IPSOLU
  99. REAL*8 EPSI
  100.  
  101. INTEGER ITER
  102. INTEGER IPRTRA
  103. INTEGER IPBUFF
  104. LOGICAL OUT
  105.  
  106.  
  107. *Nombre maximal d'iteration autorise
  108. MAXITE=MIN(100*MAX(NK,NM),10000)
  109.  
  110. *Initialisation de tous les paramètres ARPACK
  111. CALL ARPINI (NVAL,NK,SYM,CHOLE,INVER,PIRE,
  112. & SIGMA,CHOIX,IPMAUP,MAXITE)
  113.  
  114. *Construction des operateurs de travail
  115. CALL ARPOPE (IPRIGI,IPMASS,0,QUAD,SIGMA,IPRTRA)
  116.  
  117. *Inititalisation du vecteur residu d'arpack
  118. CALL ARPALE (IPRTRA,IPMAUP,QUAD)
  119. IF (IERR.NE.0) GOTO 999
  120.  
  121. *Boucle pour la factorisation d'Arnoldi
  122. DO ITER=1,MAXITE
  123. IF (IIMPI.GE.10) WRITE(IOIMP,*) '*** ITERATION N°:',ITER,'***'
  124. *Iteration
  125. CALL ARPITL (IPRTRA,IPMAUP,SIGMA,INVER,SYM,EPSI,OUT)
  126. IF (IERR.NE.0) GOTO 999
  127. *Sortie si convergence
  128.  
  129. IF (OUT) THEN
  130. GOTO 999
  131. END IF
  132.  
  133. ENDDO
  134.  
  135. * sortie car on a atteint le nombre maxi d'iterations sans converger
  136. * "Pas de convergence apres %i1 iterations. L'execution continue"
  137. INTERR(1)=MAXITE
  138. CALL ERREUR(151)
  139.  
  140. 999 CONTINUE
  141.  
  142. IF (IIMPI.GE.1)
  143. & WRITE(IOIMP,*) '*** SORTIE APRES :',ITER,' ITERATIONS ***'
  144.  
  145. *Post-traitement des resultats: creation de l'objet solution
  146. CALL ARPOST (IPRTRA,LAGDUA,SIGMA,QUAD,SYM,INVER,
  147. & IPMAUP,IPSOLU,EPSI)
  148. IF (IERR.NE.0) RETURN
  149.  
  150. *Destruction des operateurs de travail (matrices principales exclues)
  151.  
  152. MRITRA=IPRTRA
  153. SEGACT MRITRA*MOD
  154. DO i=3,RIGI(/1)
  155. IF (RIGI(i) .NE. 0) THEN
  156. IPBUFF=RIGI(i)
  157. CALL DTRIGI(IPBUFF)
  158. c RIGI(i)=0
  159. ENDIF
  160. ENDDO
  161. SEGSUP MRITRA
  162. IF (IERR.NE.0) RETURN
  163.  
  164. *Suppression du segment de travail ARPACK
  165. MAUP=IPMAUP
  166. c SEGSUP MAUP
  167.  
  168. END
  169.  
  170.  
  171.  
  172.  

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