Télécharger la plaquette Cast3M


fr en

Télécharger copba3.eso

Retour à la liste

Numérotation des lignes : 

copba3

  1. C COPBA3    SOURCE    CB215821  20/11/25    13:22:14     10792          
  2.       SUBROUTINE COPBA3(ITBAS,MOTCLE,IMODE,IMAIL,INOMA,LCHAIN,KTRCHP,
  3.      &                  KTRCHA,KTRAV,ICONT)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8(A-H,O-Z)
  6.  
  7. *--------------------------------------------------------------------*
  8. *                                                                    *
  9. *     Effectue une op{ration g{om{trique de translation (MOTCLE =    *
  10. *     'PLUS') ou de rotation (MOTCLE = 'ROTA') sur ITBAS contenant   *
  11. *     les modes, les pseudo-modes de la structure.                   *
  12. *                                                                    *
  13. *     Param}tres:                                                    *
  14. *                                                                    *
  15. * e   ITBAS   table contenant les modes, ou les pseudo-modes         *
  16. * e   MOTCLE  mot : PLUS ou ROTA                                     *
  17. *                                                                    *
  18. *     Auteur, date de cr{ation:                                      *
  19. *                                                                    *
  20. *     Lionel VIVAN, le 31 mai 1990.                                  *
  21. *                                                                    *
  22. *--------------------------------------------------------------------*
  23. *                                                                    *
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC SMCHPOI
  28. -INC SMCHAML
  29. -INC SMELEME
  30. -INC SMTABLE
  31. *
  32.       SEGMENT ITRCHP
  33.          INTEGER ICHCA(NSOU),ICHCN(NSOU)
  34.       ENDSEGMENT
  35.       SEGMENT ITRCHA
  36.          INTEGER ICHAM(NSOUS)
  37.       ENDSEGMENT
  38.       SEGMENT MTRAV
  39.          REAL*8 XPT(IDIMB),XPTP(IDIMB),XP1PT(IDIMB),XMPT(IDIMB,IDIMB)
  40.       ENDSEGMENT
  41.       SEGMENT MTRA2
  42.          INTEGER IDEP(3),IROT(3)
  43.          REAL*8 XDEP(3),XROT(3)
  44.       ENDSEGMENT
  45.       SEGMENT MTRA3
  46.          REAL*8 XDGEN(3),XDGE2(3)
  47.       ENDSEGMENT
  48.       SEGMENT MTRA4
  49.          INTEGER IFOR(3),IMOM(3)
  50.          REAL*8 XFOR(3),XMOM(3)
  51.       ENDSEGMENT
  52. *
  53.       INTEGER LCHAIN(*)
  54.       CHARACTER*(*) MOTCLE
  55.       CHARACTER*(LOCOMP) COMP
  56. *
  57.       ITRCHP = KTRCHP
  58.       NSOU = ICHCA(/1)
  59.       IF (ICONT.EQ.1) THEN
  60.          ITRCHA = KTRCHA
  61.          NSOUS = ICHAM(/1)
  62.       ENDIF
  63.       IF (MOTCLE.EQ.'ROTA') MTRAV = KTRAV
  64. *
  65.       MTABLE = ITBAS
  66.       SEGACT MTABLE*MOD
  67.       LONG = MLOTAB
  68.       IM = IMODE
  69.       DO 10 I = 1,LONG
  70.          IF (MTABTI(I).EQ.'ENTIER  ' .AND. MTABII(I).EQ.IM .AND.
  71.      &                   MTABTV(I).EQ.'TABLE   ') THEN
  72.             ITMOD = MTABIV(I)
  73.             IM = IM + 1
  74.             MTAB1 = ITMOD
  75.             SEGACT MTAB1*MOD
  76.             LON1 = MTAB1.MLOTAB
  77.             DO 20 I1 = 1,LON1
  78.                IF (MTAB1.MTABTI(I1).EQ.'MOT     ') THEN
  79.                   IF (MTAB1.MTABII(I1).EQ.LCHAIN(3) .OR.
  80.      &                MTAB1.MTABII(I1).EQ.LCHAIN(6)) THEN
  81.                      IF (MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
  82.                         ICHDEP = MTAB1.MTABIV(I1)
  83.                         MCHPOI = ICHDEP
  84.                         SEGACT MCHPOI
  85.                         DO 22 INS = 1,NSOU
  86.                            MSOUPO = IPCHP(INS)
  87.                            SEGACT MSOUPO*MOD
  88.                            IF (MOTCLE.EQ.'ROTA') THEN
  89.                               NCOM = NOCOMP(/2)
  90.                               SEGINI MTRA2
  91.                               MPOVAL = IPOVAL
  92.                               SEGACT MPOVAL
  93.                               NPOIN = VPOCHA(/1)
  94.                               DO 24 IP = 1,NPOIN
  95.                                  ICD = 0
  96.                                  ICR = 0
  97.                                  DO 26 IC = 1,NCOM
  98.                                     COMP = NOCOMP(IC)
  99.                                     IF (COMP(1:1).EQ.'U') THEN
  100.                                        ICD = ICD + 1
  101.                                        IDEP(ICD) = IC
  102.                                        XDEP(ICD) = VPOCHA(IP,IC)
  103.                                     ELSE IF (COMP(1:1).EQ.'R') THEN
  104.                                        ICR = ICR + 1
  105.                                        IROT(ICR) = IC
  106.                                        XROT(ICR) = VPOCHA(IP,IC)
  107.                                     ENDIF
  108.  26                                 CONTINUE
  109. *                                end do
  110.                                  DO 28 IDE = 1,ICD
  111.                                     XVAL = 0.D0
  112.                                     DO 30 ID2 = 1,ICD
  113.                                XVAL = XVAL + XMPT(IDE,ID2) * XDEP(ID2)
  114.  30                                    CONTINUE
  115. *                                   end do
  116.                                     IC = IDEP(IDE)
  117.                                     VPOCHA(IP,IC) = XVAL
  118.  28                                 CONTINUE
  119. *                                end do
  120.                                  IF (IDIM.EQ.3) THEN
  121.                                  DO 32 IRO = 1,ICR
  122.                                     XVAL = 0.D0
  123.                                     DO 34 IR2 = 1,ICR
  124.                                XVAL = XVAL + XMPT(IRO,IR2) * XROT(IR2)
  125.  34                                    CONTINUE
  126. *                                   end do
  127.                                     IC = IROT(IRO)
  128.                                     VPOCHA(IP,IC) = XVAL
  129.  32                                 CONTINUE
  130. *                                end do
  131.                                  ENDIF
  132.  24                              CONTINUE
  133. *                             end do
  134.                               SEGDES MPOVAL
  135.                               SEGSUP MTRA2
  136.                            ENDIF
  137.                            IGEOC = ICHCN(INS)
  138.                            SEGDES MSOUPO
  139.  22                        CONTINUE
  140. *                       end do
  141.                         SEGDES MCHPOI
  142.                         MTAB1.MTABIV(I1) = ICHDEP
  143.                      ENDIF
  144.                   ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(5) .OR.
  145.      &                     MTAB1.MTABII(I1).EQ.LCHAIN(8)) THEN
  146.                      IF (MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
  147.                         ICHDEP = MTAB1.MTABIV(I1)
  148.                         MCHPOI = ICHDEP
  149.                         SEGACT MCHPOI
  150.                         NSOU2 = IPCHP(/1)
  151.                         DO 40 INS = 1,NSOU2
  152.                            MSOUPO = IPCHP(INS)
  153.                            SEGACT MSOUPO*MOD
  154.                            IF (MOTCLE.EQ.'ROTA') THEN
  155.                               NCOM2 = NOCOMP(/2)
  156.                               SEGINI MTRA4
  157.                               MPOVAL = IPOVAL
  158.                               SEGACT MPOVAL
  159.                               NPOI2 = VPOCHA(/1)
  160.                               NCOM2 = VPOCHA(/2)
  161.                               DO 42 IP = 1,NPOI2
  162.                                  ICF = 0
  163.                                  ICM = 0
  164.                                  DO 44 IC = 1,NCOM2
  165.                                     COMP = NOCOMP(IC)
  166.                                     IF (COMP(1:1).EQ.'F') THEN
  167.                                        ICF = ICF + 1
  168.                                        IFOR(ICF) = IC
  169.                                        XFOR(ICF) = VPOCHA(IP,IC)
  170.                                     ELSE IF (COMP(1:1).EQ.'M') THEN
  171.                                        ICM = ICM + 1
  172.                                        IMOM(ICM) = IC
  173.                                        XMOM(ICM) = VPOCHA(IP,IC)
  174.                                     ENDIF
  175.  44                                 CONTINUE
  176. *                                end do
  177.                                  DO 46 IDE = 1,ICF
  178.                                     XVAL = 0.D0
  179.                                     DO 48 ID2 = 1,ICF
  180.                                XVAL = XVAL + XMPT(IDE,ID2) * XFOR(ID2)
  181.  48                                    CONTINUE
  182. *                                   end do
  183.                                     IC = IFOR(IDE)
  184.                                     VPOCHA(IP,IC) = XVAL
  185.  46                                 CONTINUE
  186. *                                end do
  187.                                  IF (IDIM.EQ.3) THEN
  188.                                  DO 50 IRO = 1,ICM
  189.                                     XVAL = 0.D0
  190.                                     DO 52 IR2 = 1,ICM
  191.                                XVAL = XVAL + XMPT(IRO,IR2) * XMOM(IR2)
  192.  52                                    CONTINUE
  193. *                                   end do
  194.                                     IC = IMOM(IRO)
  195.                                     VPOCHA(IP,IC) = XVAL
  196.  50                                 CONTINUE
  197. *                                end do
  198.                                  ENDIF
  199.  42                              CONTINUE
  200. *                             end do
  201.                               SEGDES MPOVAL
  202.                               SEGSUP MTRA4
  203.                            ENDIF
  204.                            IPT1 = IGEOC
  205.                            SEGINI,MELEME=IPT1
  206.                            NBE = NUM(/2)
  207.                            NBP = NUM(/1)
  208.                            DO 54 IE = 1,NBE
  209.                               DO 56 IP = 1,NBP
  210.                                  IPTS = NUM(IP,IE)
  211.                                  CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
  212.                                  IF (IERR.NE.0) RETURN
  213.                                  NUM(IP,IE) = INOPT
  214.  56                              CONTINUE
  215. *                             end do
  216.  54                           CONTINUE
  217. *                          end do
  218.                            SEGDES MELEME
  219.                            IGEOC = MELEME
  220.                            SEGDES MSOUPO
  221.  40                        CONTINUE
  222. *                       end do
  223.                         SEGDES MCHPOI
  224.                         MTAB1.MTABIV(I1) = ICHDEP
  225.                      ENDIF
  226.                   ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(4) .OR.
  227.      &                     MTAB1.MTABII(I1).EQ.LCHAIN(7)) THEN
  228.                      IF (MTAB1.MTABTV(I1).EQ.'MCHAML  ') THEN
  229.                         ICHCON = MTAB1.MTABIV(I1)
  230.                         MCHELM = ICHCON
  231.                         SEGACT MCHELM*MOD
  232.                         DO 60 INS = 1,NSOUS
  233.                            IMACHE(INS) = ICHAM(INS)
  234. 60                        CONTINUE
  235. *                       end do
  236.                         SEGDES MCHELM
  237.                         MTAB1.MTABIV(I1) = ICHCON
  238.                      ENDIF
  239.                   ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(9) .AND.
  240.      &                  MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
  241.                         ICHDEP = MTAB1.MTABIV(I1)
  242.                         MCHPOI = ICHDEP
  243.                         SEGACT MCHPOI
  244.                         NSOU3 = IPCHP(/1)
  245.                         DO 80 INS = 1,NSOU3
  246.                            MSOUPO = IPCHP(INS)
  247.                            SEGACT MSOUPO
  248.                            IPT1 = IGEOC
  249.                            SEGINI,MELEME=IPT1
  250.                            NBE = NUM(/2)
  251.                            NBP = NUM(/1)
  252.                            DO 82 IE = 1,NBE
  253.                               DO 84 IP = 1,NBP
  254.                                  IPTS = NUM(IP,IE)
  255.                                  CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
  256.                                  IF (IERR.NE.0) RETURN
  257.                                  NUM(IP,IE) = INOPT
  258.  84                              CONTINUE
  259. *                             end do
  260.  82                           CONTINUE
  261. *                          end do
  262.                            SEGDES MELEME
  263.                            IGEOC = MELEME
  264.                            SEGDES MSOUPO
  265.  80                        CONTINUE
  266. *                       end do
  267.                         SEGDES MCHPOI
  268.                         MTAB1.MTABIV(I1) = ICHDEP
  269.                   ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(10) .AND.
  270.      &                   MTAB1.MTABTV(I1).EQ.'POINT   ') THEN
  271.                      IPTS = MTAB1.MTABIV(I1)
  272.                      CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
  273.                      IF (IERR.NE.0) RETURN
  274.                      MTAB1.MTABIV(I1) = INOPT
  275.                   ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(2) .AND.
  276.      &                           MTAB1.MTABTV(I1).EQ.'TABLE   ') THEN
  277.                      IF (MOTCLE.EQ.'ROTA') THEN
  278.                         ITDEPG = MTAB1.MTABIV(I1)
  279.                         SEGINI MTRA3
  280.                         MTAB2 = ITDEPG
  281.                         SEGACT MTAB2
  282.                         LON2 = MTAB2.MLOTAB
  283.                         IDG = 1
  284.                         DO 70 I2 = 1,LON2
  285.                            IF (MTAB2.MTABTI(I2).EQ.'ENTIER  ' .AND.
  286.      &                          MTAB2.MTABII(I2).EQ.IDG .AND.
  287.      &                          MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN
  288.                               XDGEN(IDG) = MTAB2.RMTABV(I2)
  289.                               IDG = IDG + 1
  290.                            ENDIF
  291.  70                        CONTINUE
  292. *                       end do
  293.                         DO 72 ID1 = 1,IDIM
  294.                            XVAL = 0.D0
  295.                            DO 74 ID2 = 1,IDIM
  296.                            XVAL = XVAL + (XMPT(ID1,ID2) * XDGEN(ID2))
  297.  74                           CONTINUE
  298. *                          end do
  299.                            XDGE2(ID1) = XVAL
  300.  72                        CONTINUE
  301. *                       end do
  302.                         IDG = 1
  303.                         DO 76 I2 = 1,LON2
  304.                            IF (MTAB2.MTABTI(I2).EQ.'ENTIER  ' .AND.
  305.      &                               MTAB2.MTABII(I2).EQ.IDG .AND.
  306.      &                            MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN
  307.                                MTAB2.RMTABV(I2) = XDGE2(IDG)
  308.                                IDG = IDG + 1
  309.                             ENDIF
  310.  76                        CONTINUE
  311. *                       end do
  312.                         SEGDES MTAB2
  313.                         MTAB1.MTABIV(I1) = ITDEPG
  314.                         SEGSUP MTRA3
  315.                      ENDIF
  316.                   ENDIF
  317.                ENDIF
  318.  20            CONTINUE
  319. *           end do
  320.             SEGDES MTAB1
  321.             MTABIV(I) = ITMOD
  322.          ENDIF
  323.  10      CONTINUE
  324. *     end do
  325.       SEGDES MTABLE
  326. *
  327.       END
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  

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