Télécharger la plaquette Cast3M


fr en

Télécharger hbmtra.eso

Retour à la liste

Numérotation des lignes : 

hbmtra

  1. C HBMTRA    SOURCE    OF166741  26/05/11    21:15:16     12538          
  2.  
  3. *--------------------------------------------------------------------*
  4. *                                                                    *
  5. *     Operateur DYNC                                                 *
  6. *     ________________________________________________               *
  7. *                                                                    *
  8. *     Transpose l'information des objets de Castem2000 dans des      *
  9. *     tableaux de travail.                                           *
  10. *                                                                    *
  11. *     Parametres:                                                    *
  12. *                                                                    *
  13. * e   ITBAS   Table representant une base modale                     *
  14. * e   ITKM    Table contenant les matrices XK et XM                  *
  15. * e   ITA     Table contenant la matrice XASM                        *
  16. * es  KTKAM   Segment contenant les matrices XK, XASM et XM          *
  17. * e   IPMAIL  Maillage de reference pour les CHPOINTs resultats      *
  18. * es  KTRES   Segment de sauvegarde des resultats                    *
  19. * e   KPREF   Segment des points de reference                        *
  20. * es  KTPHI   Segment des deformees modales                          *
  21. * e   KTLIAB  Segment des liaisons sur base B                        *
  22. * e   RIGIDE  Vrai si corps rigide, faux sinon                       *
  23. *                                                                    *
  24. *--------------------------------------------------------------------*
  25.       SUBROUTINE HBMTRA(ITBAS,ITKM,ITA,KTKAM,IPMAIL,NHBM,KTRES,KTNUM,
  26.      &                  KPREF,KTPHI,KTLIAB,RIGIDE)
  27.  
  28.       IMPLICIT INTEGER(I-N)
  29.       IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC CCREEL
  34.  
  35. -INC SMRIGID
  36. -INC SMCOORD
  37. -INC SMELEME
  38.  
  39. -INC TMDYNC
  40.  
  41.       LOGICAL L0,L1,RIGIDE
  42.       CHARACTER*4 CMOT,MOINC
  43.       CHARACTER*8 TYPRET,CHARRE
  44.       CHARACTER*40 MONMOT
  45. *
  46.       MTKAM  = KTKAM
  47.       MTPHI  = KTPHI
  48.       MTLIAB = KTLIAB
  49.       MPREF  = KPREF
  50.       MTNUM  = KTNUM
  51.  
  52. *     dimensions de MTPHI
  53.       NPLB  = IBASB(/1)
  54.       NSB   = INMSB(/1)
  55.       NA2   = XPHILB(/3)
  56.       IDIMB = XPHILB(/4)
  57.       NLIAB = IPALB(/1)
  58.  
  59. *     dimensions de MTKAM
  60.       NA1  = XASM(/1)
  61.       NB1K = XK(/2)
  62.       NB1C = XASM(/2)
  63.       NB1M = XM(/2)
  64.  
  65. *     dimensions de MTQ
  66. *      NT1 = NA1*(2*NHBM+1)
  67.  
  68.       NPREF=IPOREF(/1)
  69. *
  70.       IA1 = 0
  71.       DEUXPI = 2.D0 * XPI
  72.       RIGIDE =.FALSE.
  73. *
  74. *     Traitement des matrices de variables generalisees:
  75. *
  76.       IF (ITBAS.NE.0 .AND.ITKM.EQ.0) THEN
  77.          IF (IIMPI.EQ.333)
  78.      &   WRITE(IOIMP,*) 'HBMTRA: cas table BASE_DE_MODES, quel type?'
  79.          CALL ACCTAB(ITBAS,'MOT',IMODE,X0,'SOUSTYPE',L0,IP0,
  80.      &                     'MOT',I1,X1,MONMOT,L1,IP1)
  81.          IF (IERR.NE.0) RETURN
  82. *
  83. *        Cas ou la base est unique
  84. *
  85.          IF (MONMOT(1:11).EQ.'BASE_MODALE') THEN
  86.             IF (IIMPI.EQ.333)
  87.      &      WRITE(IOIMP,*) 'HBMTRA: lecture table BASE_MODALE'
  88. *
  89. *           On recupere la base de modes
  90. *
  91.             CALL ACCTAB(ITBAS,'MOT',IMODE,X0,'MODES',L0,IP0,
  92.      &                        'TABLE',I1,X1,' ',L1,IBAS)
  93.             IF (IERR.NE.0) RETURN
  94.             CALL HBM26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,1,ICOMP,RIGIDE,ITKM)
  95. *            CALL DYNE26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,1,ICOMP,RIGIDE,
  96. *     &                  0,.false.,ITKM)
  97.             IF (RIGIDE) THEN
  98.                RIGIDE =.FALSE.
  99.                DO 80 ILIA =1,NLIAB
  100.                    ITYP = IPALB(ILIA,1)
  101.                    IF (ITYP.EQ.35.OR.ITYP.EQ.36) THEN
  102.                        RIGIDE =.TRUE.
  103.                    ENDIF
  104. 80             CONTINUE
  105.             ENDIF
  106.             IF (IERR.NE.0) RETURN
  107. *
  108. *        Cas ou on a un ensemble de bases
  109. *
  110.          ELSE IF (MONMOT(1:17).EQ.'ENSEMBLE_DE_BASES') THEN
  111.             IF (IIMPI.EQ.333)
  112.      &      WRITE(IOIMP,*) 'HBMTRA: lecture table ENSEMBLE_DE_BASES'
  113. *
  114. *           On boucle sur le nombre de bases
  115. *
  116.             IT = 0
  117.             NPLSB = 0
  118.  10         CONTINUE
  119.             TYPRET = ' '
  120.             IT = IT + 1
  121.             CALL ACCTAB(ITBAS,'ENTIER',IT,X0,' ',L0,IP0,
  122.      &                          TYPRET,I1,X1,CHARRE,L1,ITTBAS)
  123.             IF (IERR.NE.0) RETURN
  124.             IF (ITTBAS.NE.0) THEN
  125.                IF (TYPRET.EQ.'TABLE   ') THEN
  126.                   CALL ACCTAB(ITTBAS,'MOT',IMODE,X0,'MODES',L0,IP0,
  127.      &                             'TABLE',I1,X1,' ',L1,IBAS)
  128.                   IF (IERR.NE.0) RETURN
  129.                   CALL HBM26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,IT,ICOMP,
  130.      &                              RIGIDE,ITKM)
  131. *                  CALL DYNE26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,IT,ICOMP,
  132. *     &                              RIGIDE,0,.false.,ITKM)
  133.                   IF (IERR.NE.0) RETURN
  134.                   NPLSB = MAX(NPLSB,ICOMP)
  135.                   GOTO 10
  136.                ELSE
  137.                   CALL ERREUR(491)
  138.                   RETURN
  139.                ENDIF
  140.             ENDIF
  141.          ENDIF
  142. *
  143.       ELSE IF (ITKM.NE.0) THEN
  144. *        cas table RAIDEUR_ET_MASSE non prevu pour l'instant
  145.          CALL ERREUR(491)
  146.          RETURN
  147.       ENDIF
  148. *
  149. *     Traitement de la matrice d'amortissement
  150. *
  151.       IF (ITA.NE.0) THEN
  152.          IF (IIMPI.EQ.333)
  153.      &   WRITE(IOIMP,*) 'HBMTRA: cas table AMORTISSEMENT'
  154.            TYPRET = ' '
  155.            CALL ACCTAB(ITA,'MOT',I0,X0,'AMORTISSEMENT',L0,IP0,
  156.      &                    TYPRET,I1,X1,CHARRE,L1,IAMOR)
  157.            IF (IERR.NE.0) RETURN
  158.          IF (IAMOR.NE.0 .AND. TYPRET.EQ.'RIGIDITE') THEN
  159.             IF (IIMPI.EQ.333)
  160.      &      WRITE(IOIMP,*) 'HBMTRA: lecture table AMORTISSEMENT ok'
  161.             MRIGID = IAMOR
  162.             SEGACT,MRIGID
  163.             NAMOR = IRIGEL(/2)
  164.             DO 60 I=1,NAMOR
  165.                COEF = COERIG(I)
  166. c          write(ioimp,*) 'HBMTRA: sous rigidite ',I,'/',NAMOR,COEF
  167.                MELEME = IRIGEL(1,I)
  168.                DESCR  = IRIGEL(3,I)
  169.                XMATRI = IRIGEL(4,I)
  170.                SEGACT,DESCR,MELEME,XMATRI
  171.                NRIG = RE(/3)
  172.                LVAL = RE(/1)
  173.                DO 70 IRIG=1,NRIG
  174. c          write(ioimp,*) 'HBMTRA: + element',IRIG,'/',NRIG
  175. c                 boucle sur les lignes (ddls duals)
  176.                   DO 75 IN=1,LVAL
  177.                     INODE=NOELED(IN)
  178.                     IF(INODE.ne.NOELEP(IN)) THEN
  179.                        WRITE(IIOMP,*) 'Incoherence entre les inconnues',
  180.      &                 'primales et duales de la matrice AMORTISSEMENT'
  181.                        CALL ERREUR(47)
  182.                        RETURN
  183.                     ENDIF
  184.                     NNODE=NUM(INODE,IRIG)
  185. c          write(ioimp,*) 'HBMTRA:   + noeud dual',IN,'/',LVAL,' #',NNODE
  186. c                   position de cette inconnue dans IPOREF de MPREF
  187.                     DO 76 IA=1,NPREF
  188.                       IF (IPOREF(IA).EQ.NNODE) GOTO 79
  189.  76                 CONTINUE
  190.                     write(ioimp,*) 'HBMTRA: Incoherence entre les ',
  191.      &              'points de reference et la matrice AMORTISSEMENT'
  192.                     CALL ERREUR(504)
  193.  79                 CONTINUE
  194. c          write(ioimp,*) 'HBMTRA:   + noeud dual trouve en position',IA
  195. *                     Partie diagonale seulement ...
  196.                       XASM(IA,1) = XASM(IA,1) + (RE(IN,IN,IRIG) * COEF)
  197.  75               CONTINUE
  198.  70            CONTINUE
  199.                SEGDES,XMATRI,MELEME,DESCR
  200.  60         CONTINUE
  201.             SEGDES,MRIGID
  202.          ELSE
  203.             CALL ERREUR(485)
  204.             RETURN
  205.          ENDIF
  206.       ENDIF
  207. *
  208.       IF (IIMPI.EQ.333) THEN
  209.          WRITE(IOIMP,*)'     segment MTPHI'
  210.          WRITE(IOIMP,*)'HBMTRA : valeur de NPLB  :',IBASB(/1)
  211.          WRITE(IOIMP,*)'HBMTRA : valeur de NSB   :',XPHILB(/1)
  212.          WRITE(IOIMP,*)'HBMTRA : valeur de NPLSB :',XPHILB(/2)
  213.          WRITE(IOIMP,*)'HBMTRA : valeur de NA2   :',XPHILB(/3)
  214.          WRITE(IOIMP,*)'HBMTRA : valeur de IDIMB :',XPHILB(/4)
  215.          WRITE(IOIMP,*)'     segment MTKAM'
  216.          WRITE(IOIMP,*)'NA1,NB1K,NB1C,NB1M=',NA1,NB1K,NB1C,NB1M
  217.          if(NB1K.gt.1) then
  218.             do iou=1,NA1
  219.                WRITE(IOIMP,*) 'XK=',(XK(iou,jou),jou=1,NB1K)
  220.             enddo
  221.          else
  222.             do iou=1,NA1
  223.                WRITE(IOIMP,*) 'XK(',iou,',1)=',XK(iou,1)
  224.             enddo
  225.          endif
  226.          if(NB1C.gt.1) then
  227.             do iou=1,NA1
  228.               WRITE(IOIMP,*) 'XASM=',(XASM(iou,jou),jou=1,NB1C)
  229.             enddo
  230.          else
  231.             do iou=1,NA1
  232.               WRITE(IOIMP,*) 'XASM(',iou,',1)=',XASM(iou,1)
  233.             enddo
  234.          endif
  235.          if(NB1M.gt.1) then
  236.             do iou=1,NA1
  237.                WRITE(IOIMP,*) 'XM=',(XM(iou,jou),jou=1,NB1M)
  238.             enddo
  239.          else
  240.             do iou=1,NA1
  241.                WRITE(IOIMP,*) 'XM(',iou,',1)=',XM(iou,1)
  242.             enddo
  243.          endif
  244.        ENDIF
  245.  
  246.       RETURN
  247.       END
  248.  
  249.  
  250.  

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