Télécharger arpsol.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPSOL SOURCE BP208322 15/10/21 21:15:11 8690
  2. SUBROUTINE ARPSOL (SIGMA,CHOIX,QUAD,NVAL,IPRIGI,IPMASS,LAGDUA,NK,
  3. & 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
  43. *
  44. * INVER LOGIQUE (E) .TRUE. -> PRODUIT SCALAIRE X'KX
  45. * .FALSE. -> PRODUIT SCALAIRE X'MX
  46. *
  47. * PIRE LOGIQUE (E) PRODUIT SCALAIRE EUCLIDIEN
  48. *
  49. * SYM LOGIQUE (E) PROBLEME SYMETRIQUE OU NON
  50. *
  51. * CHOLE LOGIQUE (E) CHOLESKY NON ALTERNATIVE POSSIBLE
  52. *
  53. * IPSOLU ENTIER (S) POINTEUR SUR LA SOLUTION CREE
  54. *
  55. * EPSI REEL DP (E) ZERO DE TOLERANCE
  56. *
  57. *
  58. * SOUS-PROGRAMMES APPELES:
  59. * ------------------------
  60. *
  61. * ARPINI,ARPALE,ARPOPE,ARPITL,ARPOST
  62. *
  63. * AUTEUR, DATE DE CREATION:
  64. * -------------------------
  65. *
  66. * PASCAL BOUDA 29 JUIN 2015
  67. *
  68. * LANGAGE:
  69. * --------
  70. *
  71. * FORTRAN 77 & 90
  72. *
  73. ***********************************************************************
  74.  
  75. IMPLICIT INTEGER(I-N)
  76. IMPLICIT REAL*8 (A-H,O-Z)
  77.  
  78. -INC CCOPTIO
  79. -INC TARWORK
  80.  
  81. COMPLEX*16 SIGMA
  82. CHARACTER*2 CHOIX
  83. LOGICAL QUAD
  84. INTEGER NVAL
  85. INTEGER IPRIGI
  86. INTEGER IPMASS
  87. INTEGER LAGDUA
  88. INTEGER NK
  89. INTEGER NM
  90. LOGICAL INVER
  91. LOGICAL PIRE
  92. LOGICAL SYM
  93. LOGICAL CHOLE
  94. INTEGER IPSOLU
  95. REAL*8 EPSI
  96.  
  97. INTEGER ITER
  98. INTEGER IPRTRA
  99. INTEGER IPBUFF
  100. LOGICAL OUT
  101.  
  102.  
  103. *Nombre maximal d'iteration autorise
  104. MAXITE=MIN(100*MAX(NK,NM),10000)
  105.  
  106.  
  107. *Initialisation de tous les paramètres ARPACK
  108. CALL ARPINI (NVAL,NK,SYM,CHOLE,INVER,PIRE,
  109. & SIGMA,CHOIX,IPMAUP,MAXITE)
  110.  
  111. *Construction des operateurs de travail
  112. CALL ARPOPE (IPRIGI,IPMASS,0,QUAD,SIGMA,IPRTRA)
  113.  
  114. *Inititalisation du vecteur residu d'arpack
  115. CALL ARPALE (IPRTRA,IPMAUP,QUAD)
  116. IF (IERR.NE.0) GOTO 999
  117.  
  118. *Boucle pour la factorisation d'Arnoldi
  119. DO ITER=1,MAXITE
  120. IF (IIMPI.GE.10) WRITE(IOIMP,*) '*** ITERATION N°:',ITER,'***'
  121. *Iteration
  122. CALL ARPITL (IPRTRA,IPMAUP,SIGMA,INVER,SYM,EPSI,OUT)
  123. IF (IERR.NE.0) GOTO 999
  124. *Sortie si convergence
  125.  
  126. IF (OUT) THEN
  127. GOTO 999
  128. END IF
  129.  
  130. ENDDO
  131.  
  132. 999 CONTINUE
  133.  
  134. IF (IIMPI.GE.1)
  135. & WRITE(IOIMP,*) '*** SORTIE APRES :',ITER,' ITERATIONS ***'
  136.  
  137. *Destruction des operateurs de travail (matrices principales exclues)
  138.  
  139. MRITRA=IPRTRA
  140. SEGACT MRITRA*MOD
  141. DO i=3,RIGI(/1)
  142. IF (RIGI(i) .NE. 0) THEN
  143. IPBUFF=RIGI(i)
  144. CALL DTRIGI(IPBUFF)
  145. RIGI(i)=0
  146. ENDIF
  147. ENDDO
  148. SEGDES MRITRA
  149. IF (IERR.NE.0) RETURN
  150.  
  151. *Posttraitement des resultats: creation de l'objet solution
  152. CALL ARPOST (IPRTRA,LAGDUA,SIGMA,QUAD,SYM,INVER,
  153. & IPMAUP,IPSOLU,EPSI)
  154. IF (IERR.NE.0) RETURN
  155.  
  156. *Suppression du segment de travail ARPACK
  157. MAUP=IPMAUP
  158. SEGSUP MAUP
  159.  
  160. END
  161.  

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