Télécharger la plaquette Cast3M


fr en

Télécharger sespa.eso

Retour à la liste

Numérotation des lignes : 

sespa

  1. C SESPA     SOURCE    BP208322  19/04/29    21:15:14     10213          
  2. C SESPA    SOURCE    WP        23//08/94
  3. C     SUBROUTINE SESPA ( IPLVAL, IPLVEC, NBMOD, IPRIGI, IPMASS )
  4. ************************************************************************
  5. *
  6. *                                SESPA
  7. *                             -----------
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. *     CONSTRUIT NBMOD ELEMENTS PROPRES EN ITERANT LE SOUS-ESPACE
  13. *     IPLVEC, JUSQU'A LA CONVERGENCE DE CELUI-CI.
  14. *
  15. * MODE D'APPEL:
  16. * -------------
  17. *
  18. *     CALL SESPA ( IPLVAL, IPLVEC, NBMOD, IPRIGI, IPMASS )
  19. *
  20. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE
  21. * -----------
  22. *
  23. *     IPLVAL  ENTIER    (S)  POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
  24. *                            LA SUITE DE VALEURS PROPRES OBTENUES.
  25. *     IPLVEC  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
  26. *                            LE SOUS-ESPACE INITIAL.
  27. *     IPLVEC  ENTIER    (S)  POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
  28. *                            LE SOUS-ESPACE FINAL. EN ORTHONORMALISANT
  29. *                            LES 'CHPOINT' DE CET ESPACE ON OBTIENT LES
  30. *                            VECTEURS PROPRES RECHERCHES.
  31. *     NBMOD   ENTIER    (E)  NOMBRE DE VECTEURS RECHERCHES. IPLVEC
  32. *                            CONTIENT PLUS QUE NBMOD 'CHPO', CAR CECI
  33. *                            PERMET DE CONVERGER PLUS RAPIDEMENT.
  34. *
  35. *     IPRIGI  ENTIER    (E)  POINTEUR SUR L'OBJET 'RIGIDITE' K
  36. *     IPMASS  ENTIER    (E)  POINTEUR SUR L'OBJET 'RIGIDITE' M
  37. *
  38. *
  39. * AUTEUR, DATE DE CREATION:
  40. * -------------------------
  41. *
  42. *   A.M. JOLIVALT, W. PASILLAS  13 / 07 / 94. ( ESOPE )
  43. *
  44. ***********************************************************************
  45.  
  46.       SUBROUTINE SESPA ( IPLVAL, IPLVEC, NBMOD, IPRIGI, IPMASS )
  47.  
  48.       IMPLICIT INTEGER(I-N)
  49.       IMPLICIT REAL*8 (A-H,O-Z)
  50.  
  51. -INC PPARAM
  52. -INC CCOPTIO
  53. -INC  SMLCHPO
  54. -INC  SMLREEL
  55.  
  56. ******
  57. *     -- CONSTANTES --
  58. ***
  59.       PARAMETER ( ITERMX = 40 )
  60.  
  61. ******
  62. *     -- ARGUMENTS --
  63. ***
  64.       POINTEUR IPLVEC.MLCHPO, IPLVAL.MLREEL
  65.       INTEGER  NBMOD, IPRIGI, IPMASS
  66.  
  67. ******
  68. *     -- VARIABLES LOCALES --
  69. ***
  70.       POINTEUR IPLCH1.MLCHPO, IPLCH2.MLCHPO
  71.       POINTEUR IPLVA1.MLREEL, IPLVA2.MLREEL
  72.       INTEGER ILDIM
  73.       LOGICAL BOOL
  74.  
  75.  
  76. ****************************************************************
  77. *                    INITIALISATIONS                           *
  78. ****************************************************************
  79.  
  80.       SEGACT ,IPLVEC
  81.       ILDIM = IPLVEC.ICHPOI( /1 )
  82.       SEGDES ,IPLVEC
  83.  
  84. ******
  85. *     -- ON PREND 0.0 COMME PREMIERE APPROXIMATION DES
  86. *     VALEURS PROPRES --
  87. ***
  88.       JG = 0
  89.       SEGINI ,IPLVA1, IPLVA2
  90.       DO 90 IB90 = 1, ILDIM
  91.          IPLVA1.PROG(**) = 0.D0
  92.          IPLVA2.PROG(**) = 0.D0
  93.  90   CONTINUE
  94.  
  95. ******
  96. *     -- ON PREND LA LISTE IPLVEC COMME PREMIERE APPROX
  97. *     DES MODES PROPRES --
  98. ***
  99.       N1 = 0
  100.       SEGINI ,IPLCH1
  101.       SEGACT ,IPLVEC
  102.       DO 95 IB95 = 1, ILDIM
  103.          IPCHPO = IPLVEC.ICHPOI(IB95)
  104.          CALL COPIE2 ( IPCHPO, IPCH1 )
  105.          IF ( IERR .NE. 0 ) RETURN
  106.          IPLCH1.ICHPOI(**)  = IPCH1
  107.  95   CONTINUE
  108.       SEGDES ,IPLVEC, IPLCH1
  109.       IPLCH2 = IPLVEC
  110.       IPLVEC = 0
  111.  
  112.  
  113. ****************************************************************
  114. *           ITERATION DU SOUS-ESPACE IPLVEC                    *
  115. ****************************************************************
  116.  
  117. ******
  118. *     -- REPETER JUSQU'A:
  119. *            *  CONVERGER.
  120. *            *  DEPASSER ITERMX ITERATIONS
  121. ***
  122.       DO 100 IB100 = 1, ITERMX
  123.  
  124. ******
  125. *        -- MISE A JOUR DE IPLVA1 --
  126. ***
  127.          CALL DTLREE ( IPLVA1 )
  128.          IF ( IERR .NE. 0 ) RETURN
  129.          IPLVA1 = IPLVA2
  130.  
  131. ******
  132. *        -- MISE A JOUR DE IPLCH1 --
  133. ***
  134. *        -- ON DETRUIT --
  135.          SEGACT ,IPLCH1
  136.          DO 200 IB200 = 1, ILDIM
  137.             IPCHPO = IPLCH1.ICHPOI(IB200)
  138.             CALL DTCHPO (IPCHPO)
  139.             IF ( IERR .NE. 0 ) RETURN
  140.  200     CONTINUE
  141.          SEGDES ,IPLCH1
  142.          CALL DTLCHP ( IPLCH1 )
  143.          IF ( IERR .NE. 0 ) RETURN
  144.  
  145. *        -- ET ON RECOPIE --
  146.          SEGACT ,IPLCH2
  147.          N1 = 0
  148.          SEGINI ,IPLCH1
  149.          DO 300 IB300 = 1, ILDIM
  150.             IPCHPO = IPLCH2.ICHPOI(IB300)
  151.             CALL COPIE2 ( IPCHPO, IPCHP1 )
  152.             IF ( IERR .NE. 0 ) RETURN
  153.             IPLCH1.ICHPOI(**) = IPCHP1
  154.  300     CONTINUE
  155.          SEGDES ,IPLCH1, IPLCH2
  156.  
  157. ******
  158. *        -- UNE ITERATION DU SOUS-ESPACE IPLVEC --
  159. ***
  160.          CALL SESPA0 ( IPLCH2, IPLVA2, IPRIGI, IPMASS )
  161.          IF ( IERR .NE. 0 ) RETURN
  162.  
  163. ******
  164. *        -- ON TESTE LA CONVERGENCE
  165. ***
  166.          CALL SESPA5 ( IPLVA1, IPLVA2, IPLCH1, IPLCH2,
  167.      1                 IPMASS, BOOL, NBMOD )
  168.          IF ( IERR .NE. 0 ) RETURN
  169.          IF ( BOOL ) THEN
  170. *           -- SI ON A CONVERGE, C'EST FINI !   --
  171.             IF ( IIMPI .EQ. 2 ) THEN
  172.                WRITE ( IOIMP, 1000 ) IB100
  173.  1000          FORMAT( /1X, 'On a effectue ',I2,' iterations.', /)
  174.             ENDIF
  175.             GOTO 110
  176.          ENDIF
  177.  
  178.          IF ( IB100 .EQ. ITERMX ) THEN
  179. *           -- SI NON, PAS DE CONVERGE, MAIS ON RENVOIE LA SOLUTION !
  180. c             WRITE ( IOIMP, 2000 ) ITERMX
  181. c  2000       FORMAT( /1X, 'Pas de convergence apres ',I2,' iterations.',
  182. c      1              /1X, 'La solution est quand meme renvoyee.',
  183. c      2              /1X, 'L''execution continue ...', / )
  184.             INTERR(1)=ITERMX
  185.             CALL ERREUR(151)
  186.         ENDIF
  187.  100  CONTINUE
  188.  110  CONTINUE
  189.  
  190. ** estimation d'une borne superieure de l'erreur sur les valeurs propres
  191. ** (c.f. Argyris, Wilkinson)
  192.            segact iplch2, iplva2, iplva1
  193.            do 50 ibmod = 1,nbmod
  194.              ix = iplch2.ichpoi(ibmod)
  195.              xlamda =  IPLVA2.PROG( IBMOD)
  196.              xlamd0 =  IPLVA1.PROG( IBMOD)
  197.              call mucpri(ix,ipmass,ixm1)
  198.              call mucpri(ix,iprigi,ixk1)
  199.              xco1= 1.d0
  200.              xco2 = -1d0*xlamda
  201.              call adchpo(ixk1,ixm1,ires,xco1, xco2)
  202.              call xtx1(ires,xres)
  203.              call dtchpo(ixk1)
  204.              call dtchpo(ixm1)
  205.              call dtchpo(ires)
  206.              dlamda = abs(xlamda - xlamd0)
  207.              xerr1 = dlamda /abs(xlamda)
  208.              xerr2 = (sqrt(abs(xres)))/abs(xlamda)
  209.  
  210.             IF ( (IIMPI .EQ. 2) .or. (.not. bool)) then
  211.              reaerr(1) = xerr1
  212.              reaerr(2) = xerr2
  213.              interr(1) = ibmod
  214. c   Valeur propre (omega**2) de rang ibmod :
  215. c   convergence relative : xerr1 borne sup de l erreur relative : xerr2             
  216.              call erreur(-327)
  217.              write (ioimp,2010)
  218.  2010        format (1x)
  219.             endif
  220.  
  221.  50        continue
  222.            segdes iplch2, iplva2,iplva1
  223.  
  224.  
  225. ****************************************************************
  226. *                  NETTOYAGE DE LA MEMOIRE                     *
  227. ****************************************************************
  228.  
  229. ******
  230. *     -- ON DETRUIT IPLVA1 ET IPLCH1
  231. ***
  232.       CALL DTLREE ( IPLVA1 )
  233.       IF ( IERR .NE. 0 ) RETURN
  234.  
  235.       SEGACT ,IPLCH1
  236.       DO 400 IB400 = 1, ILDIM
  237.          IPCHPO = IPLCH1.ICHPOI(IB400)
  238.          CALL DTCHPO (IPCHPO)
  239.          IF ( IERR .NE. 0 ) RETURN
  240.  400  CONTINUE
  241.       SEGDES ,IPLCH1
  242.       CALL DTLCHP ( IPLCH1 )
  243.       IF ( IERR .NE. 0 ) RETURN
  244.  
  245. ******
  246. *     -- ON RENVOIE LES VALEURS ET VECTEURS PROPRES --
  247. ***
  248.       IPLVEC = IPLCH2
  249.       IPLVAL = IPLVA2
  250.  
  251.       RETURN
  252.       END
  253.  
  254.  
  255.  
  256.  

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