Télécharger la plaquette Cast3M


fr en

Télécharger crebas.eso

Retour à la liste

Numérotation des lignes : 

crebas

  1. C CREBAS    SOURCE    CB215821  20/11/25    13:23:03     10792          
  2. *       SUBROUTINE CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,FREQ,
  3. *     >                          NUMODE2,MTAB3,I)
  4.        SUBROUTINE CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,
  5.      >                    NUMODE2,MTAB3,I)
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8 (A-H,O-Z)
  8. ************************************************************************
  9. *
  10. *                             C R E B A S
  11. *                             -----------
  12. *
  13. * FONCTION:
  14. * ---------
  15. *
  16. *     CREATION D'UNE BASE DE MODES PROPRES COMPLEXES POUR PROCHE
  17. *
  18. * MODE D'APPEL:
  19. * -------------
  20. *
  21. *     CALL CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,FREQ,NUMODE2,MTAB3)
  22. *
  23. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE
  24. * -----------
  25. *
  26. *     PROPRE  REEL DP   (E)  TABLEAU DE CARACTERISTIQUES DU MODE PROPRE
  27. *                            CALCULE:
  28. *                            PROPRE(1) = FREQUENCE PROPRE REELLE,
  29. *                            PROPRE(2) = MASSE GENERALISEE,
  30. *                            PROPRE(3,4 ET 5) = DEPLACEMENTS GENERALISES
  31. *                            REELS
  32. *                            PROPRE(6) = FREQUENCE PROPRE IMAGINAIRE
  33. *                            PROPRE(8,9,10) = DEPL. GEN. IMAGINAIRES
  34. *     IPRX    ENTIER    (E)  POINTEUR DU 'CHPOINT' PROPRE REEL.
  35. *     IPIX    ENTIER    (E)  POINTEUR DU 'CHPOINT' PROPRE IMAGINAIRE.
  36. *     IPKW2M  ENTIER    (E)  POINTEUR DE LA 'RIGIDITE' "DECALEE" QUI A
  37. *                            SERVI AU CALCUL DU MODE PROPRE.
  38. *     INF0    ENTIER    (E)  NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA
  39. *                            'RIGIDITE' "K" NON "DECALEE" LORSQU'ELLE
  40. *                            EST DECOMPOSEE EN LT.D.L.
  41. *     FREQ    REEL DP   (E)  FREQUENCE QUI A ETE UTILISEE POUR LE
  42. *                            DECALAGE DE LA 'RIGIDITE' "K".
  43. *     MTAB3   TABLE    (S)  POINTEUR DE L'OBJET 'SOLUTION' REPRESENTANT
  44. *                            LA BASE DE MODE PROPRE.
  45. *
  46. * SOUS-PROGRAMMES APPELES:
  47. * ------------------------
  48. *
  49. *     DIAGN1, ECR..., LIR.ALL/LIMO.
  50. *
  51. * AUTEUR, DATE DE CREATION:
  52. * -------------------------
  53. *
  54. *     C. LE BIDEAU     JUILLET 2001
  55. *     MODIF: Benoit Prabel   Mars 2009
  56. *
  57. * LANGAGE:
  58. * --------
  59. *
  60. *     FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS.
  61. *
  62. ************************************************************************
  63. *
  64.  
  65. -INC PPARAM
  66. -INC CCOPTIO
  67. -INC SMTABLE
  68. -INC CCREEL
  69. -INC SMLCHPO
  70. -INC SMLMOTS
  71. -INC SMCHPOI
  72. -INC SMRIGID
  73. *
  74.         REAL*8 PROPRE(*)
  75. *
  76. *******************************************
  77. *    Creation de la table BASE_DE_MODES   *
  78. *******************************************
  79. *
  80.       CALL CRTABL(IPTAB2)
  81.       CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  82.      &     'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0)
  83.  
  84.  
  85. *
  86. *******************************************
  87. *     VERIFICATION DU MODES               *
  88. *******************************************
  89. *
  90. *        NUMERO DU MODE
  91.          CALL DIAGN1(IPKW2M,NMODEN)
  92. *  BP :  Attention !!! le nombre de terme négatif de [K-wshift^2M]
  93. *        n'a pas vraiment le meme sens que dans le cas symetrique
  94. *        (qui est = au nombre de val propre < shift) !!!
  95.          IF (IERR .NE. 0) RETURN
  96.          NUMODE = NMODEN + NUMODE2
  97.          NUMODE = NUMODE - INF0
  98. *         write(6,*)'crebas : (NMODEN + NUMODE2) - INFO = NUMODE'
  99. *         write(6,*) NMODEN,NUMODE2,INF0,NUMODE
  100. * selon CREMOD, INF0 est toujours nul car le traitement des LX a changé,
  101. * et le nbre de terme diag <0 est bien celui des inconnues en depalcements
  102. *
  103. *******************************************
  104. *        CREATION DU MODE
  105. *******************************************
  106.  
  107. *        si lambda_I = 0 (<=> w Re ou Im pur),  alors vp réel
  108. *         IF ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.)) GOTO 1000
  109.  
  110.  
  111. *------- Cas d'un mode Complexe ---------------------------------------*
  112.  
  113.          ZERO = 0.D0
  114.          CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)
  115.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'NUMERO_MODE',.TRUE.,0,
  116.      &        'ENTIER',NUMODE,0.D0,' ',.TRUE.,0)
  117.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'POINT_REPERE',.TRUE.,0,
  118.      &        'POINT',0,0.D0,' ',.TRUE.,IPOIN)
  119.  
  120.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'FREQUENCE_REELLE',.TRUE.,0,
  121.      &        'FLOTTANT',0,PROPRE(1),' ',.TRUE.,0)
  122.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'FREQUENCE_IMAGINAIRE',.TRUE.,0
  123.      &       ,'FLOTTANT',0,PROPRE(6),' ',.TRUE.,0)
  124.  
  125.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'MASSE_GENERALISEE',.TRUE.,0
  126.      &       ,'FLOTTANT',0,PROPRE(2),' ',.TRUE.,0)
  127.  
  128.          if(IPRX .ne. 0)    then
  129.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_REELLE',
  130.      &        .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IPRX)
  131.          else
  132.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_REELLE',
  133.      &        .TRUE.,0,'MOT',0,0.D0,'NULLE',.TRUE.,0)
  134.          endif
  135.          if(IPIX .ne. 0)    then
  136.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_IMAGINAIRE',
  137.      &        .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IPIX)
  138.          else
  139.          CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_IMAGINAIRE',
  140.      &        .TRUE.,0,'MOT',0,0.D0,'NULLE',.TRUE.,0)
  141.          endif
  142. *
  143. *        DEPLACEMENTS GENERALISES
  144.  
  145.          if(IPRX .ne. 0)    then
  146.          CALL CRTABL(IPTDG11)
  147.          CALL ECCTAB(IPTDG11,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  148.      &   'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',.TRUE.,0)
  149.          CALL ECCTAB(IPTDG11,'ENTIER',1,0.0D0,' ',
  150.      &       .TRUE.,0,'FLOTTANT',0,PROPRE(3),' ',.TRUE.,0)
  151.          CALL ECCTAB(IPTDG11,'ENTIER',2,0.0D0,' ',
  152.      &       .TRUE.,0,'FLOTTANT',0,PROPRE(4),' ',.TRUE.,0)
  153.          CALL ECCTAB(IPTDG11,'ENTIER',3,0.0D0,' ',
  154.      &       .TRUE.,0,'FLOTTANT',0,PROPRE(5),' ',.TRUE.,0)
  155.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,
  156.      &     'DEPLACEMENTS_GENERALISES_REELS',
  157.      &     .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG11)
  158.          endif
  159.  
  160.          if(IPIX .ne. 0)    then
  161.          CALL CRTABL(IPTDG3)
  162.          CALL ECCTAB(IPTDG3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  163.      &   'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_IMAGINAIRES',.TRUE.,0)
  164.          CALL ECCTAB(IPTDG3,'ENTIER',1,0.0D0,' ',
  165.      &       .TRUE.,0,'FLOTTANT',0,PROPRE(8),' ',.TRUE.,0)
  166.          CALL ECCTAB(IPTDG3,'ENTIER',2,0.0D0,' ',
  167.      &       .TRUE.,0,'FLOTTANT',0,PROPRE(9),' ',.TRUE.,0)
  168.          CALL ECCTAB(IPTDG3,'ENTIER',3,0.0D0,' ',
  169.      &       .TRUE.,0,'FLOTTANT',0,PROPRE(10),' ',.TRUE.,0)
  170.          CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,
  171.      &     'DEPLACEMENTS_GENERALISES_IMAGINAIRES',
  172.      &     .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG3)
  173.          endif
  174.  
  175. c        Ecriture dans MTAB3 . I
  176.          CALL ECCTAB(MTAB3,'ENTIER',I,0.0D0,' ',
  177.      &        .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2)
  178.  
  179.          GOTO 2000
  180.  
  181. *
  182. *------- Cas des modes Reels ---------------------------------------*
  183. *   L'ecriture specifique pour ce cas est abandonnée au profit de celle ci-dessus
  184. *   qui est plus générale pour l'utilisation des données résultats
  185. * 1000    CONTINUE
  186. *
  187. *         ZERO = 0.D0
  188. *         CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)
  189. *         CALL CRTABL(IPTAB2)
  190. *         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'NUMERO_MODE',.TRUE.,0,
  191. *     &        'ENTIER',NUMODE,0.0D0,' ',.TRUE.,0)
  192. *         CALL CREPO1(0.0D0,0.0D0,0.0D0,IPOIN)
  193. *         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,
  194. *     &        'POINT',0,0.0D0,' ',.TRUE.,IPOIN)
  195. *         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'FREQUENCE_REELLE',.TRUE.
  196. *     &        ,0,'FLOTTANT',0,PROPRE(1),' ',.TRUE.,0)
  197. *         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MASSE_GENERALISEE',.TRUE.
  198. *     &        ,0,'FLOTTANT',0,PROPRE(2),' ',.TRUE.,0)
  199. *         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
  200. *     &        .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,IPRX)
  201. *         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'COMPOSANTES_IMAGINAIRES',
  202. *     &        .TRUE.,0,'MOT',0,0.0D0,'NULLES',.TRUE.,0)
  203. **
  204. **      DEPLACEMENTS GENERALISES
  205. **
  206. *         CALL CRTABL(IPTDG11)
  207. *         CALL ECCTAB(IPTDG11,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  208. *     &   'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',.TRUE.,0)
  209. *
  210. *         CALL ECCTAB(IPTDG11,'ENTIER',1,0.0D0,' ',
  211. *     &       .TRUE.,0,'FLOTTANT',0,PROPRE(3),' ',.TRUE.,0)
  212. *         CALL ECCTAB(IPTDG11,'ENTIER',2,0.0D0,' ',
  213. *     &       .TRUE.,0,'FLOTTANT',0,PROPRE(4),' ',.TRUE.,0)
  214. *         CALL ECCTAB(IPTDG11,'ENTIER',3,0.0D0,' ',
  215. *     &       .TRUE.,0,'FLOTTANT',0,PROPRE(5),' ',.TRUE.,0)
  216. **
  217. **      CREATION DE L'OBJET SOLUTION REEL
  218. **
  219. *      CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',
  220. *     &     .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG11)
  221. *         CALL ECCTAB(MTAB3,'ENTIER',I,0.0D0,' ',
  222. *     &        .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2)
  223.  
  224.  
  225.  
  226.  2000 CONTINUE
  227.  
  228.        END
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  

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