Télécharger la plaquette Cast3M


fr en

Télécharger arpitq.eso

Retour à la liste

Numérotation des lignes : 

arpitq

  1. C ARPITQ    SOURCE    PV        22/04/15    20:16:34     11344          
  2.       SUBROUTINE ARPITQ (IPRTRA,IPMAUP,SIGMA,INVER,EPSI,OUT)
  3.  
  4.  
  5. ***********************************************************************
  6. *
  7. *                          A R P I T Q
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. *     STEP DE LA FACTORISATION D'ARNOLDI POUR UN PROBLEME QUADRATIQUE.
  13. *
  14. * REMARQUE:
  15. * ---------
  16. *
  17. *     LE PROBLEME EST DE DIMENSION DOUBLE PAR RAPPORT AU NOMBRE
  18. *     D'INCONNUES: CEPENDANT LES FONCTIONS DISPONIBLES POUR LA
  19. *     RESOLUTION DE PROBLEMES D'ORDRE 1 SERONT UTILISES CAR LES
  20. *     OPERATIONS MATRICE-VECTEUR SE FONT PAR BLOCS
  21. *
  22. *     RIGI(1) : RIGIDITE
  23. *     RIGI(3) : AMORTISSEMENT
  24. *     RIGI(2) : MASSE
  25. *
  26. *
  27. * PARAMETRES:  (E)=ENTREE   (S)=SORTIE
  28. * -----------
  29. *
  30. *
  31. *     IPRTRA  ENTIER     (E)    OPERATEURS DE TRAVAIL
  32. *
  33. *     IPMAUP  ENTIER     (E/S)  POINTEUR VARIABLES ARPACK
  34. *
  35. *     SIGMA   COMPLEX DP (E)    VALEUR DU SHIFT (PEUT ETRE NUL)
  36. *
  37. *     INVER   LOGIQUE    (E)   .TRUE. -> PRODUIT SCALAIRE X'KX
  38. *                              .FALSE. -> PRODUIT SCALAIRE X'MX
  39. *
  40. *     EPSI    REEL DP    (E)    TOLERANCE
  41. *
  42. *     OUT     LOGIQUE    (S)    FLAG DE CONVERGENCE
  43. *
  44. *
  45. * SOUS-PROGRAMMES APPELES:
  46. * ------------------------
  47. *
  48. *     DNAUPD,ADCHPO,ARPCH2,MUCPRI,RESOU1,LDMT,DTCHPO
  49. *
  50. * AUTEUR,DATE DE CREATION:
  51. * -------------------------
  52. *
  53. *     PASCAL BOUDA     17 JUILLET 2015
  54. *
  55. * LANGAGE:
  56. * --------
  57. *
  58. *     FORTRAN 77 & 90
  59. *
  60. ***********************************************************************
  61.  
  62.       implicit real*8(a-h,o-z)
  63. -INC PPARAM
  64. -INC CCOPTIO
  65. -INC SMLCHPO
  66. -INC TARWORK
  67. -INC CCREEL
  68. c -INC TARTRAK
  69.  
  70.       SEGMENT idemen(0)
  71.  
  72.  
  73.       INTEGER IPRTRA
  74.       INTEGER IPMAUP
  75.       LOGICAL INVER
  76.       COMPLEX*16 SIGMA
  77.       REAL*8 EPSI
  78.       LOGICAL OUT
  79.  
  80.  
  81.       INTEGER IPRIGI,IPMASS,IPAMOR,IPSCAL
  82.       INTEGER TEST
  83.       INTEGER IPLCHP
  84.       INTEGER IPCTRA(9)
  85.       INTEGER NOID,NOEN
  86.       INTEGER ndim,ncv,lworkl
  87.  
  88.       xspetl = xspeti
  89.  
  90.       SEGINI IDEMEN
  91.       IDEMEN(**)=0
  92.       NOID=0
  93.       NOEN=1
  94.  
  95.       OUT=.FALSE.
  96.  
  97.  
  98.       MRITRA=IPRTRA
  99.       SEGACT MRITRA
  100.       IPRIGI=RIGI(1)
  101.       IPMASS=RIGI(2)
  102.       IPAMOR=RIGI(3)
  103.       IPCSIM=RIGI(5)
  104.       IPKCSM=RIGI(6)
  105.  
  106.  
  107.       MAUP=IPMAUP
  108.       SEGACT MAUP*MOD
  109.  
  110. *Récupération de la dimension des tableaux
  111.       ndim=resid(/1)
  112.       ncv=v(/2)
  113.       lworkl=workl(/1)
  114.  
  115. *Le probleme est non symetrique. Appel de la routine ARPACK specifique
  116.       CALL DNAUPD (ido,bmat,ndim,which,nev,EPSI,resid,
  117.      &      ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,ITRAK,info)
  118.  
  119.  
  120. *Reverse communication: On récupère les paramètres de sortie et on
  121. *effectue des actions en fonction de leurs valeurs
  122.       TEST=ido
  123.  
  124.       IPMAUP=MAUP
  125. c       SEGDES MAUP
  126.  
  127.  
  128. *On verifie si on doit stopper le processus
  129.       CALL ARPERR (IPMAUP,.FALSE.,OUT)
  130.       IF (OUT) RETURN
  131.  
  132.  
  133. *Initialisation des chpoints de travail
  134.       DO i=1,9
  135.         IPCTRA(i)=0
  136.       ENDDO
  137.  
  138.  
  139.  
  140.       IF (TEST .EQ. -1 .OR. TEST .EQ. 1) THEN
  141.  
  142. *        &--------------------------------------------------&
  143. *        |  Calcul du produit matrice vecteur               |
  144. *        |    Y <---- RE( inv(A-SIGMA*B)*B*X )              |
  145. *        |                                                  |
  146. *        |              X : workd(ipntr(1))                 |
  147. *        |              Y : workd(ipntr(2))                 |
  148. *        &--------------------------------------------------&
  149.  
  150. *Note: Initialement, ARPACK est prevu pour distinguer test=-1 ou on
  151. *fournit inv(A-SIGMA*B)*B*X et test=1 ou on fournit inv(A-SIGMA*B)*X
  152. *(economie du produit par la matrice masse deja effectue).
  153. *Cependant,la "logique" cast3m nous retire la garantie de fournir le
  154. *produit pour tout type de matrice.
  155. *En outre, meme si la reussite de l'operation etait garantie, elle
  156. *serait plus lourde a effectuer, cette derniere impliquant l'inversion
  157. *d'une matrice de masse
  158.  
  159.         IF (AIMAG(SIGMA) .EQ. 0.D0) THEN
  160.  
  161. *Shift reel : RE( inv(A-SIGMA*B)*B*X ) = inv(A-REAL(SIGMA)*B)*B*X
  162.  
  163.           CALL ARPCH2 (IPRIGI,IPRIGI,IPMAUP,IPLCHP,1,3)
  164.           MLCHPO=IPLCHP
  165.           SEGACT MLCHPO
  166.  
  167.  
  168.           IPCTRA(3)=ICHPOI(1)
  169.  
  170.           CALL MUCPRI (IPCTRA(3),IPMASS,IPCTRA(6))
  171.  
  172.           IPCTRA(1)=ICHPOI(2)
  173.  
  174.           CALL MUCPRI (IPCTRA(1),IPCSIM,IPCTRA(7))
  175.  
  176.           CALL ADCHPO (IPCTRA(6),IPCTRA(7),IPCTRA(2),-1.D0,-1.D0)
  177.  
  178.           SEGDES MLCHPO
  179.  
  180.           IDEMEN(1)=IPCTRA(2)
  181.  
  182.           IF (SYME(6) .EQ. 0) THEN
  183.             CALL RESOU1 (IPKCSM,IDEMEN,NOID,NOEN,xspetl,0,0)
  184.           ELSEIF (SYME(6) .EQ. 1) THEN
  185.             CALL LDMT   (IPKCSM,IDEMEN,NOID,NOEN,xspetl,0)
  186.           ENDIF
  187.           IF (IERR.NE.0) RETURN
  188. C         RESOU desactive IDEMEN on le reactive
  189.           SEGACT,IDEMEN
  190.  
  191.  
  192.           IPCTRA(4)=IDEMEN(1)
  193.  
  194.           CALL ADCHPO(IPCTRA(4),IPCTRA(1),IPCTRA(5),REAL(SIGMA),1.D0)
  195.  
  196.           MLCHPO=IPLCHP
  197.           SEGACT MLCHPO*MOD
  198.           ICHPOI(1)=IPCTRA(5)
  199.           ICHPOI(2)=IPCTRA(4)
  200.           IPLCHP=MLCHPO
  201.           SEGDES MLCHPO
  202.  
  203.           CALL ARPCH2 (IPRIGI,IPRIGI,IPMAUP,IPLCHP,2,1)
  204.  
  205.         ELSE
  206.  
  207. *Shift complexe : RE( inv(A-SIGMA*B)*B*X ) a fournir (non implemente)
  208.  
  209.         ENDIF
  210.  
  211.  
  212.       ELSEIF (TEST .EQ. 2) THEN
  213.  
  214. *        &------------------------------------------&
  215. *        |  Calcul du produit matrice vecteur       |
  216. *        |                                          |
  217. *        |    Si INVER                              |
  218. *        |        Y <---- DIAG(IPRIGI,IPRIGI)*X     |
  219. *        |                                          |
  220. *        |    Sinon                                 |
  221. *        |        Y <---- DIAG(IPMASS,IPMASS)*X     |
  222. *        |                                          |
  223. *        |         X : workd(ipntr(1))              |
  224. *        |         Y : workd(ipntr(2))              |
  225. *        &------------------------------------------&
  226.  
  227.         IF (INVER) THEN
  228.           IPSCAL=IPRIGI
  229.         ELSE
  230.           IPSCAL=IPMASS
  231.         ENDIF
  232.  
  233.         CALL ARPCH2 (IPRIGI,IPRIGI,IPMAUP,IPLCHP,1,3)
  234.  
  235.         MLCHPO=IPLCHP
  236.         SEGACT MLCHPO
  237.  
  238.         IPCTRA(1)=ICHPOI(1)
  239.  
  240.         CALL MUCPRI (IPCTRA(1),IPSCAL,IPCTRA(3))
  241.  
  242.         IPCTRA(2)=ICHPOI(2)
  243.  
  244.         CALL MUCPRI (IPCTRA(2),IPSCAL,IPCTRA(4))
  245.  
  246.         SEGDES MLCHPO
  247.  
  248.         MLCHPO=IPLCHP
  249.         SEGACT MLCHPO*MOD
  250.         ICHPOI(1)=IPCTRA(3)
  251.         ICHPOI(2)=IPCTRA(4)
  252.  
  253.         IPLCHP=MLCHPO
  254.         SEGDES MLCHPO
  255.  
  256.         CALL ARPCH2 (IPRIGI,IPRIGI,IPMAUP,IPLCHP,2,2)
  257.  
  258.  
  259.       ENDIF
  260.  
  261.  
  262. *Destruction des chpoints de travail
  263.       DO i=1,9
  264.         IF (IPCTRA(i) .NE. 0) THEN
  265.           CALL DTCHPO (IPCTRA(i))
  266.         ENDIF
  267.       ENDDO
  268.  
  269.       SEGDES MRITRA
  270.  
  271.  
  272.       END
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  

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