Télécharger la plaquette Cast3M


fr en

Télécharger qzrest.eso

Retour à la liste

Numérotation des lignes : 

qzrest

  1. C QZREST    SOURCE    BP208322  22/09/16    21:15:12     11454          
  2.       SUBROUTINE QZREST(IPBASR, IPBASC)
  3. *
  4. *****************************************************************************
  5. *          RESTITUTION D'UNE BASE DE MODES COMPLEXES A PARTIR               *
  6. *                D'UNE BASE DE MODES COMPLEXES DEFINIE                      *
  7. *                   RELATIVEMENT A UNE BASE REELLE                          *
  8. * _________________________________________________________________________ *
  9. *                                                                           *
  10. *      DATE : le 31 Juillet 1995                                            *
  11. *      AUTEUR : Nicolas BENECH                                              *
  12. * _________________________________________________________________________ *
  13. *                                                                           *
  14. *      MODULE(S) APPELANT(S) : VIBRAC                                       *
  15. *                                                                           *
  16. *      MODULE(S) APPELE(S) : ACCTAB, CRTABL, ECCTAB, EXTRA9, EXTR11         *
  17. * _________________________________________________________________________ *
  18. *                                                                           *
  19. * EN ENTREE :                                                               *
  20. *         - IPBASR : BASE DE MODES REELS PHYSIQUE                           *
  21. *         - IPBASC : BASE DE MODES COMPLEXES RELATIVE A IPBASR (ddl modaux) *
  22. * _________________________________________________________________________ *
  23. *                                                                           *
  24. * EN SORTIE :                                                               *
  25. *         - IPBASC : BASE DE MODES COMPLEXES sur base EF (ddl PHYSIQUE)     *
  26. *****************************************************************************
  27. *
  28.       IMPLICIT INTEGER(I-N)
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC SMCHPOI
  33. -INC SMCOORD
  34. -INC SMELEME
  35. -INC SMLMOTS
  36. -INC SMTABLE
  37. *
  38.       REAL*8 XVALRE
  39.       LOGICAL LOGRE
  40.       CHARACTER*(8) CHARRE
  41.       REAL*8 XVAL1, XVAL2, XVAL4
  42.       INTEGER I, J, K, NNOEUD, NCOMP, NBMODR, NBMODC, SWAP, PT1, PT2
  43.       INTEGER IOBRE
  44.       LOGICAL AFFICH
  45.       CHARACTER* (8) TYPEMODR, TYPEMODC
  46.       CHARACTER*4 MOT1, MOT2
  47. *
  48.       POINTEUR IPBASR2.MTABLE, IPBASR3.MTABLE
  49.       POINTEUR IPBASC2.MTABLE, IPBASC3.MTABLE
  50.       POINTEUR MCHPO5.MCHPOI
  51. *
  52. *----- Ecriture des messages pour verification
  53.       NUMAFF = 23
  54.       AFFICH = ((MOD(IIMPI, NUMAFF).EQ.0) .AND. (IIMPI.NE.0))
  55. *      AFFICH = .TRUE.
  56. *
  57. *----- Fin faute de donnees
  58.       IF (IPBASR*IPBASC .EQ. 0) RETURN
  59. *
  60. *----- Lecture des donnees
  61.       IF (AFFICH) WRITE (*,*) 'Lecture des donnees ...'
  62.       CALL ACCTAB(IPBASR,'MOT',0,0.0D0,'MODES',.TRUE.,0,
  63.      &            'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR2)
  64.       CALL ACCTAB(IPBASC,'MOT',0,0.0D0,'MODES',.TRUE.,0,
  65.      &            'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC2)
  66. *
  67. * --- Tri des donnees
  68.       IF (AFFICH) WRITE (*,*) 'TEST : ordre des donnees ...'
  69.         CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0,
  70.      &              'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3)
  71.         CALL ACCTAB(IPBASC2,'ENTIER',1,0.0D0,' ',.TRUE.,0,
  72.      &              'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC3)
  73. *
  74.         CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  75.      &            'MOT',IVALRE,XVALRE,TYPEMODR,LOGRE,IOBRE)
  76.         CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  77.      &            'MOT',IVALRE,XVALRE,TYPEMODC,LOGRE,IOBRE)
  78.       IF (AFFICH) THEN
  79.         WRITE (*,*) 'TYPEMODR = ',TYPEMODR
  80.         WRITE (*,*) 'TYPEMODC = ',TYPEMODC
  81.       ENDIF
  82. *
  83.       IF (((TYPEMODR.EQ.'MODE_COM') .OR. (TYPEMODR.EQ.'MODE_ANN'))
  84.      &     .AND. (TYPEMODC.EQ.'MODE')) THEN
  85.         IF (AFFICH) WRITE (*,*) 'Permutation !'
  86.         SWAP=IPBASR
  87.         IPBASR=IPBASC
  88.         IPBASC=SWAP
  89.         SWAP=IPBASR2
  90.         IPBASR2=IPBASC2
  91.         IPBASC2=SWAP
  92.         TYPEMODR='MODE'
  93.         TYPEMODC='MODE_COM'
  94.       ENDIF
  95.       IF (.NOT. AFFICH) GOTO 1
  96.       IF ((TYPEMODR.EQ.'MODE') .AND. ((TYPEMODC.EQ.'MODE_COM')
  97.      &                              .OR. (TYPEMODR.EQ.'MODE_ANN')))
  98.      &  THEN
  99.         WRITE (*,*) 'OK'
  100.       ELSE
  101.         WRITE (*,*) 'Erreur !'
  102.       ENDIF
  103.   1   CONTINUE
  104. *
  105. *******************************************
  106. *          Donnees fondamentales          *
  107. *******************************************
  108. * --- nombre de modes complexes
  109.       SEGACT, IPBASC2
  110.         NBMODC = IPBASC2.MLOTAB-2
  111.       SEGDES, IPBASC2
  112. * --- nombre de modes reels
  113.       SEGACT, IPBASR2
  114.         NBMODR = IPBASR2.MLOTAB-2
  115.       SEGDES, IPBASR2
  116. * --- nombre de SOUPO dans les chpoints reels
  117.       CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0,
  118.      &            'TABLE   ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3)
  119.       CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE',.TRUE.,
  120.      &            0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO1)
  121. *
  122.       SEGACT, MCHPO1
  123.         NSOUPO=MCHPO1.IPCHP(/1)
  124. *
  125. *************************************************
  126. *   Creation de la table MTAB2 BASE_DE_MODES    *
  127. *************************************************
  128. *
  129.       IF (AFFICH) WRITE (*,*) 'Creation de la table BASE_DE_MODES ...'
  130.       CALL CRTABL(MTAB2)
  131.       CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  132.      &            'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0)
  133. *
  134.       CALL ACCTAB(IPBASR2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0,
  135.      &            'MAILLAGE',IVALRE,XVALRE,CHARRE,LOGRE,IPT1)
  136.       CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0,
  137.      &            'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT1)
  138. *
  139. *
  140. *=========================================*
  141. *     Boucle sur les modes Complexes      *
  142. *=========================================*
  143. *
  144.       DO 20, I=1, NBMODC
  145.       IF (AFFICH) WRITE (*,*) 'Boucle sur les MODES ...', I
  146. *
  147. ************************************************
  148. *       Creation de la table MTAB3 du MODE I   *
  149. ************************************************
  150. *
  151.         CALL ACCTAB(IPBASC2,'ENTIER',I,0.0D0,' ',.TRUE.,0,
  152.      &            'TABLE   ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC3)
  153.         SEGINI, MTAB3=IPBASC3
  154.         SEGDES, MTAB3
  155.         CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  156.      &                    'MOT',IVALRE,XVALRE,TYPEMODC,LOGRE,IOBRE)
  157.         IF (TYPEMODC .EQ. 'MODE_ANN') GOTO 20
  158. *
  159. ***** CALCUL DE LA DEFORMEE MODALE (mchpo3 + i mchpo4) *****
  160. *
  161. * --- Recup de ALFA_R du mode I (=mchpo2)
  162.         CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
  163.      &            .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO2)
  164. * --- Recup de ALFA_I du mode I (=mchpo2)
  165.         CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE',
  166.      &            .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO4)
  167.  
  168. * --- creation du chpoint Resultat depuis le 1er chpoint mode reel mise a 0
  169. *       partie reelle  MCHPO3
  170.         SEGINI, MCHPO3=MCHPO1
  171.         SEGACT, MCHPO1
  172.         DO 30,  J=1, NSOUPO
  173.       IF (AFFICH) WRITE (*,*) 'creation MCHPO3: Boucle sur les SOUPO',J
  174.           MSOUP1 = MCHPO1.IPCHP(J)
  175.           SEGINI, MSOUP3=MSOUP1
  176.             MCHPO3.IPCHP(J) = MSOUP3
  177.           SEGACT, MSOUP1
  178.             MPOVA1 = MSOUP1.IPOVAL
  179.           SEGACT, MPOVA1
  180.             N = MPOVA1.VPOCHA(/1)
  181.             NC = MPOVA1.VPOCHA(/2)
  182.           SEGINI, MPOVA3
  183.             MSOUP3.IPOVAL = MPOVA3
  184. *         Maillage et nom de Composantes ne seront pas detruits
  185.  30     CONTINUE
  186. *
  187. *       partie imaginaire  MCHPO5
  188.         SEGINI, MCHPO5=MCHPO1
  189.         SEGACT, MCHPO1
  190.         DO 31,  J=1, NSOUPO
  191.       IF (AFFICH) WRITE (*,*) 'creation MCHPO5: Boucle sur les SOUPO',J
  192.           MSOUP1 = MCHPO1.IPCHP(J)
  193.           SEGINI, MSOUP5=MSOUP1
  194.             MCHPO5.IPCHP(J) = MSOUP5
  195.           SEGACT, MSOUP1
  196.             MPOVA1 = MSOUP1.IPOVAL
  197.           SEGACT, MPOVA1
  198.             N = MPOVA1.VPOCHA(/1)
  199.             NC = MPOVA1.VPOCHA(/2)
  200.           SEGINI, MPOVA5
  201.             MSOUP5.IPOVAL = MPOVA5
  202. *         Maillage et nom de Composantes ne seront pas detruits
  203.  31     CONTINUE
  204.  
  205. * --- Points supports
  206.         SEGACT, MCHPO2
  207.         nsou=MCHPO2.IPCHP(/1)
  208.  
  209. *    -- boucle sur les eventuelles zones
  210.         do 25 isou=1,nsou
  211.         MSOUP2 = MCHPO2.IPCHP(isou)
  212.  
  213.         SEGACT, MSOUP2
  214.           IPT2 = MSOUP2.IGEOC
  215.         SEGACT, IPT2
  216.           NBP2 = IPT2.NUM(/2)
  217. * --- composantes (rem : on ne fait rien si plus de 1 composante....)
  218.         CALL EXTR11(MCHPO2,MLMOT2)
  219.         SEGACT, MLMOT2
  220.           MOT2=MLMOT2.MOTS(1)
  221. *
  222. *
  223. ******************************************
  224. *     Boucle sur les noeuds supports     *
  225. ******************************************
  226. *
  227.          DO 50, K=1, NBP2
  228.  
  229.        IF (AFFICH)  WRITE (*,*) '---  Noeud support ',K,'  ---'
  230.             SEGACT, IPT2
  231.             PT2 = IPT2.NUM(1,K)
  232. * ---       Contribution a mchpo3
  233.             CALL EXTRA9(MCHPO2,PT2,MOT2,0,.FALSE.,XVAL2,IRET)
  234. * ---       Contribution a mchpo5
  235.             CALL EXTRA9(MCHPO4,PT2,MOT2,0,.FALSE.,XVAL4,IRET)
  236.         IF (AFFICH) WRITE (*,*) '   alfa_R et alfa_I = ',XVAL2,XVAL4
  237.  
  238. * --- on recherche le chpoint reel correspondant
  239.             L=1
  240.  60           CALL ACCTAB(IPBASR2,'ENTIER',L,0.0D0,' ',.TRUE.,
  241.      &                0,'TABLE   ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3)
  242.               CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,
  243.      &                    0,'POINT',IVALRE,XVALRE,CHARRE,LOGRE,PT1)
  244.             IF (PT1 .NE. PT2) THEN
  245.               L=L+1
  246.               IF (L .LE. NBMODR) GOTO 60
  247.             ELSE
  248.               CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE',
  249.      &                    .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,
  250.      &                    MCHPO1)
  251.       IF (AFFICH) WRITE (*,*) '   Prise en compte du MCHPO1', L,MCHPO1
  252. *
  253. * ---         Sommes...
  254.               MSOMM3=0
  255.               XVAL1=1.d0
  256.               IF (AFFICH) WRITE (*,*) 'Somme ...',MSOMM3,XVAL1,XVAL2
  257. * ---         ... pour mchpo3
  258.               call ADCHPO(MCHPO3,MCHPO1,MSOMM3,XVAL1,XVAL2)
  259.               call DTCHPO(MCHPO3)
  260.               MCHPO3=MSOMM3
  261. * ---         ... pour mchpo5
  262.               call ADCHPO(MCHPO5,MCHPO1,MSOMM5,XVAL1,XVAL4)
  263.               call DTCHPO(MCHPO5)
  264.               MCHPO5=MSOMM5
  265. *
  266.             ENDIF
  267.  
  268.  50      CONTINUE
  269. *********************************************
  270. *      Fin de boucle sur les noeuds support *
  271. *********************************************
  272. *
  273.  25     continue
  274.  
  275.  
  276.       IF (AFFICH) WRITE (*,*) 'Enregistrement du CHPOINT ...'
  277. * --- enregistrement du chpoint
  278.         CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
  279.      &            .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO3)
  280. * --- enregistrement du chpoint
  281.         CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE',
  282.      &            .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO5)
  283. * --- enregistrement du mode
  284.         CALL ECCTAB(MTAB2,'ENTIER',I,0.0D0,' ',
  285.      &            .TRUE.,0,'TABLE   ',0,0.0D0,' ',.TRUE.,MTAB3)
  286.  
  287.  20   CONTINUE
  288. ******************************************
  289. *        Fin boucle sur les modes        *
  290. ******************************************
  291. *
  292. *
  293. ******************************************
  294. *   Creation de la table BASE_MODALE     *
  295. ******************************************
  296. *
  297. *     CALL CRTABL(MTAB1)
  298. *     CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  299. *    &             'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
  300. *     CALL ECCTAB(MTAB1,'MOT',I,0.0D0,'MODES',
  301. *    &            .TRUE.,0,'TABLE   ',0,0.0D0,' ',.TRUE.,MTAB2)
  302.       CALL ECCTAB(IPBASC,'MOT',I,0.0D0,'MODES',
  303.      &            .TRUE.,0,'TABLE   ',0,0.0D0,' ',.TRUE.,MTAB2)
  304. *
  305. * --- fin
  306. *
  307.       RETURN
  308.       END
  309. *
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  

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