Télécharger crsol1.eso

Retour à la liste

Numérotation des lignes :

crsol1
  1. C CRSOL1 SOURCE PV 22/04/25 21:15:02 11344
  2. ************************************************************************
  3. *
  4. * CRSOL1
  5. * -----------
  6. *
  7. * FONCTION:
  8. * ---------
  9. *
  10. * -- CONSTRUCTION D'UN OBJET SOLUTION, A PARTIR DE LA LISTE
  11. * DES FREQUENCES PROPRES ET DE CELLE DES MODES PROPRES.
  12. * LES LISTES SONT SUPPOSES TRIEES, LES FREQUENCES SHIFTEES,
  13. * ET LES MODES ORTHONORMALISES. --
  14. *
  15. * MODE D'APPEL:
  16. * -------------
  17. *
  18. * CALL CRSOL1 (FREQ,IPLVAR,IPLVAI,IPLVER, IPLVEI, NBMOD, IPKW2M, IPMASS,
  19. * & MTAB3, ICOMP, I)
  20. *
  21. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  22. * -----------
  23. *
  24. * IPLVAR ENTIER (E) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
  25. * LA SUITE DES FREQUENCES PROPRES REELLES.
  26. * IPLVAI ENTIER (E) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
  27. * LA SUITE DES FREQUENCES IMAGINAIRES
  28. * IPLVER ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
  29. * LA SUITE DES MODES PROPRES REELS.
  30. * IPLVEI ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
  31. * LA SUITE DES MODES PROPRES IMAGINAIRES.
  32. * NBMOD ENTIER (E) NOMBRE DE MODES A INSERER DANS LA SOLUTION
  33. * ON A: NBMOD .LE. DIMENSION( IPLVAL )
  34. *
  35. * IPKW2M, IPMASS (E) MATRICES DE RIGIDITE (DECALEE) ET DE MASSE
  36. *
  37. * FREQ REEL (E) FREQUENCE UTILISEE POUR LE DECALLAGE
  38. *
  39. * MTAB3 ENTIER (S) POINTEUR SUR LA SOLUTION CREEE.
  40. *
  41. *
  42. * AUTEUR, DATE DE CREATION:
  43. * -------------------------
  44. *
  45. * C. LE BIDEAU 09 / 2001 ( FORTRAN + ESOPE )
  46. * MODIF Benoit Prabel Mars 2009
  47. *
  48. ***************************************************
  49. * SUBROUTINE CRSOL1 (FREQ,IPLVAR,IPLVAI,IPLVER, IPLVEI,
  50. * & NBMOD,IPKW2M,IPMASS,MTAB3,ICOMP, I)
  51. SUBROUTINE CRSOL1 (W2,IPLVAR,IPLVAI,IPLVER,NBMOD,NBMOD2,
  52. & IPKW2M,IPMASS,MTAB3,I,INF0)
  53.  
  54. IMPLICIT INTEGER(I-N)
  55. IMPLICIT REAL*8 (A-H,O-Z)
  56.  
  57.  
  58. -INC PPARAM
  59. -INC CCOPTIO
  60. -INC SMLCHPO
  61. -INC SMLREEL
  62. -INC SMLMOTS
  63. -INC SMTABLE
  64. -INC CCREEL
  65.  
  66. ******
  67. * -- CONSTANTES --
  68. ***
  69. PARAMETER (LPROPR = 10)
  70. PARAMETER (DEUXPI = (2.D0*XPI))
  71.  
  72. ******
  73. * -- ARGUMENTS --
  74. ***
  75. POINTEUR IPLVER.MLCHPO,IPLVAR.MLREEL,IPLVAI.MLREEL
  76. INTEGER NBMOD, IPKW2M, IPMASS
  77.  
  78. ******
  79. * -- VARIABLES LOCALES --
  80. ***
  81. POINTEUR IPLMOX.MLMOTS, IPLMOY.MLMOTS
  82. INTEGER IPMODE, IPSOL1
  83. REAL*8 W2, PROPRE(LPROPR),PROPR2(LPROPR),XRVP, XIVP
  84.  
  85.  
  86. ***** ACTIVATIONS ****************************************************
  87. SEGACT ,IPLVER, IPLVAR, IPLVAI
  88.  
  89. *-----initialisation
  90. NBNEG = 1
  91. NBPOS = 0
  92.  
  93.  
  94. ***** BOUCLE SUR LES MODES A ECRIRE **********************************
  95. JVEC = 0
  96. * DO 100 IB100 = 1, NBMOD
  97. DO 100 IB100 = 1, NBMOD2
  98.  
  99. JVEC = JVEC + 1
  100.  
  101. *------ frequence propre
  102. XRVP = IPLVAR.PROG(JVEC)
  103. XIVP = IPLVAI.PROG(JVEC)
  104. PROPRE(1) = XRVP
  105. PROPRE(6) = XIVP
  106.  
  107. *------ numero du mode (indicé selon lambda)
  108. * NUMOD2 = JVEC - NNBMOD
  109. XLAMBR = (DEUXPI**2) * ((XRVP**2) - (XIVP**2))
  110. * WRITE(6,*) 'CRSOL1: mode',JVEC
  111. * WRITE(6,*) ' w=',XRVP,'+i',XIVP,'L=',XLAMBR,'W2=',W2
  112. if(XLAMBR .lt. W2) then
  113. NBNEG = NBNEG - 1
  114. NUMOD2 = NBNEG
  115. else
  116. NBPOS = NBPOS + 1
  117. NUMOD2 = NBPOS
  118. endif
  119. * write(6,*) 'NBNEG,NBPOS,NUMOD2=',NBNEG,NBPOS,NUMOD2
  120.  
  121. *------ partie reelle du vecteur propre
  122. IPRX = IPLVER.ICHPOI(JVEC)
  123.  
  124. *------ debut masse généralisée + eventuelle recup des mots utiles
  125. CALL MUCPRI ( IPRX, IPMASS, IPBXR )
  126. IF (IB100 .EQ. 1) THEN
  127. CALL CORRSP(IPMASS, IPRX, IPBXR, IPLMOX, IPLMOY)
  128. END IF
  129. CALL XTY1(IPRX, IPBXR, IPLMOX, IPLMOY, XRBXR)
  130. IF (IERR .NE. 0 ) RETURN
  131.  
  132.  
  133. *------ Cas d'un mode Réel
  134. IF((XRVP .eq. 0.) .or. (XIVP .eq. 0.)) then
  135. * valeur propre w réelle pure ou imaginaire pure (car lambda réel pur)
  136. * vecteur propre reel = IPRX
  137. IPIX = 0
  138. * masse complexe généralisée
  139. PROPRE(2) = XRBXR
  140. PROPRE(7) = 0.D0
  141. C INTRODUCTION DES COEF. PI OU 2PI EVENTUELS + calcul DEPGEN
  142. * CALL MASGEN(XRVP,PROPRE)
  143. CALL DEPGEN(IPMASS, IPRX, PROPRE, IPBXR, IPLMOX,IPLMOY)
  144.  
  145. * Ecriture dans MTAB3 du I^eme mode
  146. CALL CREBAS (PROPRE, IPRX, IPIX, IPKW2M, INF0,
  147. & NUMOD2, MTAB3, I)
  148. I = I+1
  149.  
  150.  
  151. *------ Cas d'un mode Complexe
  152. ELSE
  153. IPIX = IPLVER.ICHPOI(JVEC + 1)
  154. * valeur et vecteur propre complexe',IPIX
  155. * fin du calcul de la masse complexe généralisée
  156. CALL XTY1(IPIX, IPBXR, IPLMOX, IPLMOY, XIBXR)
  157. CALL MUCPRI(IPIX, IPMASS, IPBXI)
  158. CALL XTY1(IPRX, IPBXI, IPLMOX, IPLMOY, XRBXI)
  159. CALL XTY1(IPIX, IPBXI, IPLMOX, IPLMOY, XIBXI)
  160. PROPRE(2) = XRBXR - XIBXI
  161. PROPRE(7) = XIBXR + XRBXI
  162. * write(*,*)'masse gene complexe=',(PROPRE(2)),(PROPRE(7))
  163. C INTRODUCTION DES COEF. PI OU 2PI EVENTUELS + calcul DEPGEN
  164. CALL DEPGEN(IPMASS, IPRX, PROPRE, IPBXR, IPLMOX,IPLMOY)
  165. CALL DEPGE2(IPMASS, IPRX,IPIX, PROPRE, IPBXR, IPLMOX,IPLMOY)
  166. * write(*,*)'* on decale JVEC...'
  167. JVEC = JVEC + 1
  168. if(XLAMBR .lt. W2) then
  169. NBNEG = NBNEG - 1
  170. else
  171. NBPOS = NBPOS + 1
  172. endif
  173.  
  174. * Ecriture dans MTAB3 du I^eme mode
  175. CALL CREBAS (PROPRE, IPRX, IPIX, IPKW2M, INF0,
  176. & NUMOD2, MTAB3, I)
  177. I = I+1
  178.  
  179. * Ecriture dans MTAB3 du I+1^eme mode (=conjugué du 1er)
  180. PROPR2(1) = IPLVAR.PROG(JVEC)
  181. PROPR2(6) = IPLVAI.PROG(JVEC)
  182. PROPR2(2) = -1.*PROPRE(2)
  183. PROPR2(7) = -1.*PROPRE(7)
  184. call MUCHPO(IPIX,-1.D0,IPIXCONJ,1)
  185. CALL CREBAS (PROPR2, IPRX, IPIXCONJ, IPKW2M, INF0,
  186. & NUMOD2, MTAB3, I)
  187. I = I+1
  188.  
  189.  
  190. ENDIF
  191. *-------fin de la distinction Mode reel/complexe
  192.  
  193.  
  194. CALL DTCHPO ( IPBXR )
  195. if((XRVP .ne. 0.) .and. (XIVP .ne. 0.))
  196. & CALL DTCHPO ( IPBXI )
  197.  
  198.  
  199. IF ( IERR .NE. 0 ) RETURN
  200.  
  201. if(JVEC .ge. NBMOD2) goto 900
  202.  
  203. 100 CONTINUE
  204.  
  205. 900 CONTINUE
  206.  
  207. SEGDES ,IPLVER, IPLVAR, IPLVAI
  208.  
  209. RETURN
  210. END
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  

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