Télécharger crsolu.eso

Retour à la liste

Numérotation des lignes :

  1. C CRSOLU SOURCE BP208322 09/03/20 21:15:09 6331
  2. C CRSOLU SOURCE WPAMJ 05/09/94
  3. ************************************************************************
  4. *
  5. * CRSOLU
  6. * -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. * -- CONSTRUCTION D'UN OBJET SOLUTION, A PARTIR DE LA LISTE
  12. * DES FREQUENCES PROPRES ET DE CELLE DES MODES PROPRES.
  13. * LES LISTES SONT SUPPOSES TRIEES, LES FREQUENCES SHIFTEES,
  14. * ET LES MODES ORTHONORMALISES. --
  15. *
  16. * MODE D'APPEL:
  17. * -------------
  18. *
  19. * CALL CRSOLU (FREQ,IPLVAL, IPLVEC, NBMOD, IPKW2M, IPMASS, IPSOLU)
  20. *
  21. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  22. * -----------
  23. *
  24. * IPLVAL ENTIER (E) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
  25. * LA SUITE DES FREQUENCES PROPRES.
  26. * IPLVEC ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
  27. * LA SUITE DES MODES PROPRES.
  28. * NBMOD ENTIER (E) NOMBRE DE MODES A INSERER DANS LA SOLUTION
  29. * ON A: NBMOD .LE. DIMENSION( IPLVAL )
  30. *
  31. * IPKW2M, IPMASS (E) MATRICES DE RIGIDITE (DECALEE) ET DE MASSE
  32. *
  33. * FREQ REEL (E) FREQUENCE UTILISEE POUR LE DECALLAGE
  34. *
  35. * IPSOLU ENTIER (S) POINTEUR SUR LA SOLUTION CREE.
  36. *
  37. *
  38. * AUTEUR, DATE DE CREATION:
  39. * -------------------------
  40. *
  41. * A.M. JOLIVALT, W. PASILLAS 06 / 07 / 94. ( ESOPE )
  42. *
  43. ***************************************************
  44. * SUBROUTINE CRSOLU (FREQ,IPLVAL,IPLVEC,NBMOD,IPKW2M,IPMASS,
  45. SUBROUTINE CRSOLU (W2,IPLVAL,IPLVEC,NBMOD,IPKW2M,IPMASS,
  46. > IPSOLU,INF0)
  47.  
  48. IMPLICIT INTEGER(I-N)
  49. IMPLICIT REAL*8 (A-H,O-Z)
  50.  
  51. -INC CCOPTIO
  52. -INC SMLCHPO
  53. -INC SMLREEL
  54. -INC SMLMOTS
  55. -INC CCREEL
  56.  
  57. ******
  58. * -- CONSTANTES --
  59. ***
  60. PARAMETER (LPROPR = 5)
  61. PARAMETER (DEUXPI = (2.D0*XPI))
  62.  
  63. ******
  64. * -- ARGUMENTS --
  65. ***
  66. POINTEUR IPLVEC.MLCHPO, IPLVAL.MLREEL
  67. INTEGER NBMOD, IPKW2M, IPMASS, IPSOLU
  68.  
  69. ******
  70. * -- VARIABLES LOCALES --
  71. ***
  72. POINTEUR IPLMD.MLMOTS, IPLMF.MLMOTS
  73. INTEGER IPMX, IPMODE, IPSOL1
  74. REAL*8 OMEGA2, PROPRE(LPROPR), FREQ, XXTMX
  75.  
  76.  
  77. ******
  78. * -- LES MODES PROPRES CORRESPONDENT AUX COUPLES: --
  79. * ( IPLVAL(I) , IPLVEC(I) ) I = 1, NBMOD
  80. ***
  81. SEGACT ,IPLVEC, IPLVAL
  82.  
  83. * NBMOD2 = 0
  84. * DO 10 IB100 = 1, NBMOD
  85. * FREQUI = IPLVAL.PROG(IB100)
  86. * IF (FREQUI.GE.FREQ) NBMOD2 = NBMOD2 + 1
  87. * 10 CONTINUE
  88. *
  89. * NNBMOD = NBMOD - NBMOD2
  90. NBNEG = 1
  91. NBPOS = 0
  92.  
  93. DO 100 IB100 = 1, NBMOD
  94. IPVECP = IPLVEC.ICHPOI(IB100)
  95. CALL XTMX ( IPVECP, IPMASS, XXTMX )
  96. IF ( IERR .NE. 0 ) RETURN
  97. CALL MUCPRI ( IPVECP, IPMASS, IPMX )
  98. IF ( IERR .NE. 0 ) RETURN
  99. IF ( IB100 .EQ. 1 ) THEN
  100. * -- NOM DES COMPOSANTES: --
  101. CALL CORRSP ( ipmass, IPVECP, IPMX, IPLMD, IPLMF )
  102. IF ( IERR .NE. 0 ) RETURN
  103. ENDIF
  104. * NUMOD2 = IB100 - NNBMOD
  105. PROPRE(1) = IPLVAL.PROG(IB100)
  106. PROPRE(2) = XXTMX
  107. XLAMBR = sign( ((DEUXPI*PROPRE(1))**2) , PROPRE(1) )
  108. if(XLAMBR .lt. W2) then
  109. NBNEG = NBNEG - 1
  110. NUMOD2 = NBNEG
  111. else
  112. NBPOS = NBPOS + 1
  113. NUMOD2 = NBPOS
  114. endif
  115. CALL MASGEN ( IPVECP, PROPRE )
  116. IF ( IERR .NE. 0 ) RETURN
  117. CALL DEPGEN ( IPMASS, IPVECP, PROPRE, IPMX, IPLMD, IPLMF)
  118. IF ( IERR .NE. 0 ) RETURN
  119. * CALL CREMOD ( PROPRE,IPVECP,IPKW2M,INF0,FREQ,NUMOD2,IPMODE)
  120. CALL CREMOD ( PROPRE,IPVECP,IPKW2M,INF0,NUMOD2,IPMODE)
  121. IF ( IERR .NE. 0 ) RETURN
  122. * -- AFFICHAGE DE LA SOLUTION --
  123. IF ( IIMPI .EQ. 2 ) CALL ECMODE ( IPMODE )
  124. IF (IB100 .EQ. 1) THEN
  125. IPSOLU = IPMODE
  126. ELSE
  127. CALL FUSOLU( IPSOLU, IPMODE, IPSOL1 )
  128. IF ( IERR .NE. 0 ) RETURN
  129. CALL DESOLU( IPMODE )
  130. IF ( IERR .NE. 0 ) RETURN
  131. CALL DESOLU( IPSOLU )
  132. IF ( IERR .NE. 0 ) RETURN
  133. IPSOLU = IPSOL1
  134. ENDIF
  135. CALL DTCHPO ( IPMX )
  136. IF ( IERR .NE. 0 ) RETURN
  137. 100 CONTINUE
  138.  
  139. IPMODE = IPSOLU
  140.  
  141. SEGDES ,IPLVEC, IPLVAL
  142.  
  143. SEGSUP ,IPLMD , IPLMF
  144.  
  145. RETURN
  146. END
  147.  
  148.  
  149.  

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