Télécharger la plaquette Cast3M


fr en

Télécharger proch2.eso

Retour à la liste

Numérotation des lignes : 

proch2

  1. C PROCH2    SOURCE    CB215821  19/07/31    21:16:46     10277          
  2.       SUBROUTINE PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,
  3.      &           LIMAGE, INSYM, MTAB3,I)
  4. ************************************************************************
  5. *
  6. *                             P R O C H 2
  7. *                             -----------
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. *     RECHERCHE D'UN MODE PROPRE.
  13. *
  14. * MODE D'APPEL:
  15. * -------------
  16. *
  17. *     CALL PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE,INSYM)
  18. *
  19. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE
  20. * -----------
  21. *
  22. *     FREQ    REEL DP   (E)  FREQUENCE A APPROCHER PAR UNE FREQUENCE
  23. *                            PROPRE.
  24. *     IPRIGI  ENTIER    (E)  POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT
  25. *                            LA MATRICE DE RIGIDITE.
  26. *     IPMASS  ENTIER    (E)  POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT
  27. *                            LA MATRICE MASSE.
  28. *     INF0    ENTIER    (E)  NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA
  29. *                            'RIGIDITE' "K" DECOMPOSEE EN L.D.LT .
  30. *                            CE NOMBRE N'EST PAS NUL A CAUSE DE LA FACON
  31. *                            DONT SONT INTRODUITS LES BLOCAGES DES
  32. *                            D.D.L. (MULTIPLICATEURS DE LAGRANGE "LX").
  33. *     IPMODE  ENTIER    (S)  POINTEUR DE L'OBJET 'SOLUTION' CONTENANT
  34. *                            LE MODE PROPRE TROUVE.
  35. *     INSYM   ENTIER    (E)  INDICATEUR DE LA NON SYMETRIE DE LA RIGIDITE
  36. *                            NON SYMETRIQUE: MODES COMPLEXES
  37. *     MTAB3   TABLE     (S)  TABLE D'UN COUPLE SOLUTION
  38. *
  39. * LEXIQUE: (ORDRE ALPHABETIQUE)
  40. * --------
  41. *
  42. *     CONVRG  LOGIQUE   VOIR LE SOUS-PROGRAMME "ITINV".
  43. *     FREDEC  REEL DP   FREQUENCE DE DECALAGE EFFECTIVE (EN GENERAL,
  44. *                       EGALE A "FREQ")
  45. *     FREQPP  REEL DP   FREQUENCE PROPRE CALCULEE PROCHE DE "FREQ".
  46. *     IPKW2M  ENTIER    POINTEUR DE LA 'RIGIDITE' "DECALEE"  K - W2.M
  47. *     IPRX    ENTIER    POINTEUR DU 'CHPOINT' QUI CONTIENT DES NOMBRES
  48. *                       ALEATOIRES, PUIS UN VECTEUR PROPRE REEL.
  49. *     IPIX    ENTIER    POINTEUR DU 'CHPOINT' CONTENANT UN VECTEUR
  50. *                       PROPRE IMAGINAIRE EN FIN D'ITERATIONS
  51. *     ITERMX  ENTIER    VOIR LE SOUS-PROGRAMME "ITINV".
  52. *     NUMACC  ENTIER    VOIR LE SOUS-PROGRAMME "ITINV".
  53. *     OMEGA2  REEL DP   PULSATION PROPRE TROUVEE AU CARRE.
  54. *     PRECI1  REEL SP   VOIR LE SOUS-PROGRAMME "ITINV".
  55. *     PRECI2  REEL SP   VOIR LE SOUS-PROGRAMME "ITINV".
  56. *     PROPRE  REEL DP   VOIR LE SOUS-PROGRAMME "ITINV".
  57. *     W2      REEL DP   PULSATION AU CARRE A APPROCHER.
  58. *
  59. * MODE DE FONCTIONNEMENT:
  60. * -----------------------
  61. *
  62. *     LE CALCUL D'UN VECTEUR PROPRE SE FAIT PAR LA METHODE DES
  63. *     ITERATIONS INVERSES (DITE AUSSI DE LA PUISSANCE INVERSE), AVEC
  64. *     DECALAGE INITIAL ("SHIFTING").
  65. *
  66. * SOUS-PROGRAMMES APPELES:
  67. * ------------------------
  68. *
  69. *     ALEAT1, CREMOD, DECALE, DTRIGI, ECCHPO, ECSOLU, ERREUR, ITINV,
  70. *     ITINVC, W2FREQ.
  71. *
  72. * AUTEUR, DATE DE CREATION:
  73. * -------------------------
  74. *
  75. *     PASCAL MANIGOT     16 OCTOBRE 1984
  76. *
  77. * MODIFICATION
  78. *-------------
  79. *     C. LE BIDEAU       JUILLET 2001
  80. *     Benoit PRABEL      MARS 2009
  81. *
  82. * LANGAGE:
  83. * --------
  84. *
  85. *     FORTRAN77 + ESOPE
  86. *
  87. ************************************************************************
  88. *
  89.       IMPLICIT INTEGER(I-N)
  90.       IMPLICIT REAL*8 (A-H,O-Z)
  91. -INC CCREEL
  92.  
  93. -INC PPARAM
  94. -INC CCOPTIO
  95. -INC SMTABLE
  96. *
  97.       PARAMETER (LPROPR = 10)
  98. *
  99.       LOGICAL CONVRG,LIMAGE
  100. *
  101.       REAL*8 PROPRE(LPROPR),PROPR2(LPROPR)
  102. *
  103.       PARAMETER (ITERMX = 100)
  104.       PARAMETER (PRECI1 = 1.D-10)
  105.       PARAMETER (PRECI2 = 1.D-11)
  106.       PARAMETER (DEUXPI = (2.D0*XPI))
  107.       PARAMETER (NUMACC = 999999)
  108. *
  109. *     -- CREATION DE (K-W2M) --
  110. *
  111.       W2 = (FREQ * DEUXPI) ** 2
  112.       IF(LIMAGE) THEN
  113.          W2 = SIGN(W2,FREQ)
  114.       ENDIF
  115.       CALL DECALE (IPRIGI,IPMASS,  W2,  IPKW2M)
  116.       IF (IERR .NE. 0) RETURN
  117. *
  118. *     -- INITIALISATION DES ITERATIONS: CREATION D'UN 'CHPOINT'
  119. *     ALEATOIRE --
  120. *
  121.       IPRX = 0
  122. *     bp (03.2009) : si on souhaite eventuellement fournir 1 CHPOINT
  123.       call LIROBJ('CHPOINT ',ICHP1,0,IRET1)
  124.       if(IRET1.eq.0) then
  125.         IF(IALEAT.EQ.0) CALL ALEAT1 (IPKW2M,IALEAT)
  126.         IF (IERR.NE.0) RETURN
  127.         CALL COPIE2(IALEAT,IPRX)
  128.       else
  129.         call ACTOBJ('CHPOINT ',ICHP1,1)
  130.         CALL COPIE2(ICHP1,IPRX)
  131.       endif
  132. C
  133. C     CALCUL DE M*X
  134. C
  135.       CALL MUCPRI(IPRX,IPMASS,IPMX)
  136.  
  137.       IF (IERR .NE. 0) RETURN
  138.       IF (IIMPI .EQ. 747) THEN
  139.          CALL ECCHPO (IPRX,0)
  140.       END IF
  141. *
  142. *     -- RESOLUTION PAR ITERATIONS INVERSES --
  143. *
  144.       IF (INSYM .EQ. 0) THEN
  145.          CALL ITINV (IPKW2M,IPMASS,IPRX,PROPRE,CONVRG,ITERMX,NUMACC
  146.      &        ,PRECI1,PRECI2,IPMX)
  147.          PROPRE(6) = 0.D0
  148.          IF (IERR .NE. 0) RETURN
  149.          IF (.NOT.CONVRG) THEN
  150.             INTERR(1) = ITERMX
  151.             NUMERR = 151
  152.             CALL ERREUR (NUMERR)
  153.          END IF
  154.        ELSE
  155.          CALL ITINVC (IPKW2M,IPMASS,IPRX,IPIX,PROPRE,CONVRG,ITERMX,IPMX)
  156.  
  157.          IF (IERR .NE. 0) RETURN
  158.          IF (.NOT.CONVRG) THEN
  159.             INTERR(1) = ITERMX
  160.             NUMERR = 151
  161.             CALL ERREUR (NUMERR)
  162.          END IF
  163.        END IF
  164. *
  165. *     -- NUMERO DU MODE --
  166. *(relativement a W2=lambda^shift, puisque propre(1) est la valeur shiftée) --
  167. *
  168.       if(PROPRE(1) .lt. 0.)  then
  169.         NUMOD2 = 0
  170.       else
  171.         NUMOD2 = 1
  172.       endif
  173. *
  174. *     -- FREQUENCE PROPRE --
  175. *
  176.       IF (INSYM .EQ. 0 ) THEN
  177.          CALL W2FREQ (PROPRE(1),W2,  OMEGA2,FREQPP,LIMAGE)
  178.          IF (IERR .NE. 0) RETURN
  179.          PROPRE(1) = FREQPP
  180.  
  181.       ELSE
  182.          CALL W2FRQC (PROPRE(1), PROPRE(6), W2, XRW2, XIW2, XRFREQ,
  183.      &        XIFREQ)
  184.          IF (IERR .NE. 0) RETURN
  185. *        on se débarasse des erreurs d'arrondis de W2FRQC
  186.          if (PROPRE(6) .eq. 0.) then
  187.             if ( (PROPRE(1) + W2) .lt. 0.) then
  188.                PROPRE(1)= 0.
  189.                PROPRE(6)= XIFREQ
  190.             else
  191.                PROPRE(1)= XRFREQ
  192.                PROPRE(6)= 0.
  193.             endif
  194.          else
  195.             PROPRE(1)= XRFREQ
  196.             PROPRE(6)= XIFREQ
  197.          endif
  198.       END IF
  199. *
  200.       IF (IIMPI .EQ. 747) THEN
  201.          IF (INSYM .EQ. 0) THEN
  202.             WRITE (IOIMP,*) 'FREQUENCE PROPRE CALCULEE = ',FREQPP
  203.             WRITE (IOIMP,*) '-------------------------'
  204.             WRITE (IOIMP,*) 'CHPOINT PROPRE:'
  205.             CALL ECCHPO (IPRX,0)
  206.          ELSE
  207.             WRITE (IOIMP,*) 'FREQUENCE PROPRE REELLE CALCULEE = ',XRFREQ
  208.             IF (PROPRE(6) .NE. 0) THEN
  209.                WRITE (IOIMP,*) 'FREQUENCE PROPRE IMAGINAIRE CALCULEE = ',XIFREQ
  210.             END IF
  211.             WRITE (IOIMP,*) '-------------------------'
  212.             WRITE (IOIMP,*) 'CHPOINT PROPRE REEL:'
  213.             CALL ECCHPO (IPRX,0)
  214.             IF (PROPRE(6) .NE. 0) THEN
  215.                 WRITE (IOIMP,*) 'CHPOINT PROPRE IMAGINAIRE:'
  216.                 CALL ECCHPO (IPIX,0)
  217.             END IF
  218.          END IF
  219.       END IF
  220. *
  221. *     -- CREATION DE L'OBJET REPRESENTANT LE MODE --
  222. *
  223. *      NUMOD2 = 0
  224.       IF (INSYM .EQ. 0) THEN
  225. *         CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,FREQ,NUMOD2,IPMODE)
  226.          CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,NUMOD2,IPMODE)
  227.          IF (IERR .NE. 0) RETURN
  228.       ELSE
  229. *         CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I)
  230.          CALL CREBAS (PROPRE,IPRX,IPIX,IPKW2M,INF0,NUMOD2,MTAB3,I)
  231.          I = I + 1
  232. *        dans le Cas d'un mode Reel Double,
  233. *        on a stocké dans IPIX le 2eme vecteur du sous espace
  234.          if( ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.))
  235.      &     .and. (IPIX .ne. 0) ) then
  236.            do ipro2=1,LPROPR
  237.              PROPR2(ipro2) = PROPRE(ipro2)
  238.            enddo
  239.            PROPR2(2)=PROPRE(7)
  240. *           CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I)
  241.            CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,NUMOD2,MTAB3,I)
  242.            I = I + 1
  243.          endif
  244.       END IF
  245. *
  246. *     IMPRESSION DU MODE:
  247.       IF (IIMPI.EQ.2) THEN
  248.          IF (INSYM .EQ. 0) THEN
  249.             WRITE (IOIMP,2000)
  250.  2000       FORMAT ('1MODE PROPRE CALCULE:'/' --------------------'//)
  251.             CALL ECMODE (IPMODE)
  252.          ELSE
  253.             CALL ECTABL (MTAB3)
  254.          END IF
  255.       ENDIF
  256. *
  257. *     -- SUPPRESSION DES OBJETS DE TRAVAIL --
  258. *
  259.       CALL DTRIGI (IPKW2M)
  260. *
  261.       END
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  

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