Télécharger arpsoq.eso

Retour à la liste

Numérotation des lignes :

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

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