Télécharger crsolu.eso

Retour à la liste

Numérotation des lignes :

  1. C CRSOLU SOURCE BP208322 19/04/29 21:15:11 10213
  2. ************************************************************************
  3. *
  4. * CRSOLU
  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 par lambda croissant,
  13. * LES FREQUENCES SHIFTEES ET LES MODES ORTHONORMALISES.
  14. *
  15. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  16. * -----------
  17. *
  18. * IPLVAL ENTIER (E) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
  19. * LA SUITE DES FREQUENCES PROPRES.
  20. * IPLVEC ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
  21. * LA SUITE DES MODES PROPRES.
  22. * NBMOD ENTIER (E) NOMBRE DE MODES A INSERER DANS LA SOLUTION
  23. * ON A: NBMOD .LE. DIMENSION( IPLVAL )
  24. * IPKW2M, IPMASS (E) MATRICES DE RIGIDITE (DECALEE) ET DE MASSE
  25. * W2 REEL (E) DECALAGE
  26. * IPSOLU ENTIER (S) POINTEUR SUR LA SOLUTION CREE.
  27. *
  28. ************************************************************************
  29.  
  30. SUBROUTINE CRSOLU (W2,IPLVAL,IPLVEC,NBMOD,IPKW2M,IPMASS,IPSOLU)
  31.  
  32. ************************************************************************
  33. * DECLARATIONS
  34. ************************************************************************
  35.  
  36. IMPLICIT INTEGER(I-N)
  37. IMPLICIT REAL*8 (A-H,O-Z)
  38.  
  39. -INC CCOPTIO
  40. -INC SMLCHPO
  41. -INC SMLREEL
  42. -INC SMLMOTS
  43. -INC CCREEL
  44.  
  45. * -- CONSTANTES --
  46. PARAMETER (LPROPR = 5)
  47. PARAMETER (DEUXPI = (2.D0*XPI))
  48.  
  49. * -- ARGUMENTS --
  50. POINTEUR IPLVEC.MLCHPO, IPLVAL.MLREEL
  51. INTEGER NBMOD, IPKW2M, IPMASS, IPSOLU
  52.  
  53. * -- VARIABLES LOCALES --
  54. POINTEUR IPLMD.MLMOTS, IPLMF.MLMOTS
  55. INTEGER IPMX, IPMODE, IPSOL1
  56. REAL*8 OMEGA2, PROPRE(LPROPR), FREQ, XXTMX
  57.  
  58.  
  59. ************************************************************************
  60. * LES MODES PROPRES CORRESPONDENT AUX COUPLES :
  61. * ( IPLVAL(I) , IPLVEC(I) ) avec I = 1, NBMOD
  62. ************************************************************************
  63.  
  64. SEGACT ,IPLVEC, IPLVAL
  65.  
  66.  
  67. ************************************************************************
  68. * TRAVAIL PRELIMINAIRE POUR LA BONNE NUMEROTATION DES MODES
  69. ************************************************************************
  70.  
  71. CALL DIAGN1 (IPMASS,nvp0M)
  72. CALL DIAGN1 (IPKW2M,IND0)
  73.  
  74. cTODO if(IFLU.gt.0) nvp0M=0
  75. c cas d'une matrice M non definie positive : modif de IND0
  76. if(nvp0M.ne.0) then
  77. if (W2.gt.0.D0) then
  78. IND0=nvp0M+IND0
  79. elseif (W2.lt.0.D0) then
  80. IND0=nvp0M-IND0
  81. else
  82. IND0=nvp0M
  83. endif
  84. endif
  85. c calcul de IREP
  86. FSHIFT=SQRT(ABS(W2))/DEUXPI
  87. FSHIFT=SIGN(FSHIFT,W2)
  88. FMIN = IPLVAL.PROG(1)
  89. FMAX = IPLVAL.PROG(NBMOD)
  90. if (FSHIFT.lt.FMIN) then
  91. IREP=1
  92. IND0=IND0+1
  93. elseif(FSHIFT.gt.FMAX) then
  94. IREP=NBMOD
  95. else
  96. do 1 ishift=2,NBMOD
  97. F1=IPLVAL.PROG(ishift-1)
  98. F2=IPLVAL.PROG(ishift)
  99. if(FSHIFT.ge.F1.and.FSHIFT.le.F2) goto 2
  100. 1 continue
  101. call erreur(5)
  102. 2 continue
  103. IREP=ishift-1
  104. endif
  105.  
  106.  
  107. ************************************************************************
  108. * BOUCLE SUR LES MODES
  109. ************************************************************************
  110.  
  111. cbp2019 NBNEG = 1
  112. cbp2019 NBPOS = 0
  113.  
  114. DO 100 IB100 = 1, NBMOD
  115.  
  116. IPVECP = IPLVEC.ICHPOI(IB100)
  117. CALL XTMX ( IPVECP, IPMASS, XXTMX )
  118. IF ( IERR .NE. 0 ) RETURN
  119. CALL MUCPRI ( IPVECP, IPMASS, IPMX )
  120. IF ( IERR .NE. 0 ) RETURN
  121. IF ( IB100 .EQ. 1 ) THEN
  122. * -- NOM DES COMPOSANTES: --
  123. CALL CORRSP ( ipmass, IPVECP, IPMX, IPLMD, IPLMF )
  124. IF ( IERR .NE. 0 ) RETURN
  125. ENDIF
  126.  
  127. PROPRE(1) = IPLVAL.PROG(IB100)
  128. PROPRE(2) = XXTMX
  129. cbp2019 XLAMBR = sign( ((DEUXPI*PROPRE(1))**2) , PROPRE(1) )
  130. cbp2019 if(XLAMBR .lt. W2) then
  131. cbp2019 NBNEG = NBNEG - 1
  132. cbp2019 NUMOD2 = NBNEG
  133. cbp2019 else
  134. cbp2019 NBPOS = NBPOS + 1
  135. cbp2019 NUMOD2 = NBPOS
  136. cbp2019 endif
  137. NUMOD2 = IND0-IREP+IB100
  138.  
  139. CALL MASGEN ( IPVECP, PROPRE )
  140. IF ( IERR .NE. 0 ) RETURN
  141. CALL DEPGEN ( IPMASS, IPVECP, PROPRE, IPMX, IPLMD, IPLMF)
  142. IF ( IERR .NE. 0 ) RETURN
  143.  
  144. c * CALL CREMOD ( PROPRE,IPVECP,IPKW2M,INF0,FREQ,NUMOD2,IPMODE)
  145. c CALL CREMOD ( PROPRE,IPVECP,IPKW2M,INF0,NUMOD2,IPMODE)
  146. CALL MANUSO('MODE ',NUMOD2,PROPRE(1),PROPRE(2),PROPRE(3),
  147. & PROPRE(4),PROPRE(5),IPVECP,0,0,IPMODE)
  148. IF ( IERR .NE. 0 ) RETURN
  149.  
  150. * -- AFFICHAGE DE LA SOLUTION --
  151. IF ( IIMPI .EQ. 2 ) CALL ECMODE ( IPMODE )
  152. IF (IB100 .EQ. 1) THEN
  153. IPSOLU = IPMODE
  154. ELSE
  155. CALL FUSOLU( IPSOLU, IPMODE, IPSOL1 )
  156. IF ( IERR .NE. 0 ) RETURN
  157. CALL DESOLU( IPMODE )
  158. IF ( IERR .NE. 0 ) RETURN
  159. CALL DESOLU( IPSOLU )
  160. IF ( IERR .NE. 0 ) RETURN
  161. IPSOLU = IPSOL1
  162. ENDIF
  163.  
  164. CALL DTCHPO ( IPMX )
  165. IF ( IERR .NE. 0 ) RETURN
  166.  
  167. 100 CONTINUE
  168.  
  169. IPMODE = IPSOLU
  170. SEGDES ,IPLVEC, IPLVAL
  171. SEGSUP ,IPLMD , IPLMF
  172.  
  173. RETURN
  174. END
  175.  
  176.  
  177.  
  178.  

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