Télécharger la plaquette Cast3M


fr en

Télécharger copbas.eso

Retour à la liste

Numérotation des lignes : 

copbas

  1. C COPBAS    SOURCE    CB215821  20/11/25    13:22:17     10792          
  2.       SUBROUTINE COPBAS(ITBAS,ITPTS,MOTCLE,IPO1,IPO2,XANG)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,Q-Z)
  5.       LOGICAL L0,L1
  6. *--------------------------------------------------------------------*
  7. *                                                                    *
  8. *     Effectue une op{ration g{om{trique de translation (MOTCLE =    *
  9. *     'PLUS') ou de rotation (MOTCLE = 'ROTA') sur ITBAS contenant   *
  10. *     les modes, les pseudo-modes de la structure.                   *
  11. *                                                                    *
  12. *     Param}tres:                                                    *
  13. *                                                                    *
  14. * e   ITBAS   table de sous-type BASE_MODALE, contenant les modes,   *
  15. *             les pseudo-modes,... de la structure                   *
  16. * e   ITPTS   table de sous-type POINT, points de la g{om{trie que   *
  17. *             l'on souhaite translat{s                               *
  18. * e   MOTCLE  mot : PLUS ou ROTA                                     *
  19. * e   IPO1    premier point de l'axe de rotation                     *
  20. * e   IPO2    deuxi}me point de l'axe de rotation, si 3D             *
  21. * e   XANG    angle de rotation                                      *
  22. *                                                                    *
  23. *     Auteur, date de cr{ation:                                      *
  24. *                                                                    *
  25. *     Lionel VIVAN, le 9 mai 1990.                                   *
  26. *                                                                    *
  27. *--------------------------------------------------------------------*
  28. *                                                                    *
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC SMCHPOI
  33. -INC SMCHAML
  34. -INC SMCOORD
  35. -INC SMELEME
  36. -INC SMTABLE
  37. *
  38.       logical ltelq
  39.       SEGMENT ITRCHP
  40.          INTEGER ICHCA(NSOU),ICHCN(NSOU)
  41.       ENDSEGMENT
  42.       SEGMENT ITRCHA
  43.          INTEGER ICHAM(NSOUS)
  44.       ENDSEGMENT
  45.       SEGMENT MTRAV
  46.          REAL*8 XPT(IDIMB),XPTP(IDIMB),XP1PT(IDIMB),XMPT(IDIMB,IDIMB)
  47.       ENDSEGMENT
  48.       SEGMENT MTRA2
  49.          INTEGER IDEP(3),IROT(3)
  50.          REAL*8 XDEP(3),XROT(3)
  51.       ENDSEGMENT
  52.       SEGMENT MTRA3
  53.          REAL*8 XDGEN(3),XDGE2(3)
  54.       ENDSEGMENT
  55.       SEGMENT MTRA4
  56.          INTEGER IFOR(3),IMOM(3)
  57.          REAL*8 XFOR(3),XMOM(3)
  58.       ENDSEGMENT
  59. *
  60. *     LCHAIN  contiendra les adresses des cha™nes dans CCNOYAU
  61. *
  62.       PARAMETER ( NCHAIN = 19 )
  63.       INTEGER LCHAIN(NCHAIN)
  64.       CHARACTER*(*) MOTCLE
  65.       CHARACTER*(LOCOMP) COMP
  66.       CHARACTER*8 TYPRET,CHARRE
  67.  
  68.       X0=0.D0
  69.       L0=.FALSE.
  70.       IP0=0
  71.       I1=0
  72.       X1=0.D0
  73.       IP1=0
  74.       I0=0
  75. *
  76.       CALL CRTABL(ITBID)
  77. *
  78.       ICHAIN = 1
  79.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  80.      &                  'POINT_REPERE',L1,IP1)
  81.       ICHAIN = 2
  82.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  83.      &                  'DEPLACEMENTS_GENERALISES',L1,IP1)
  84.       ICHAIN = 3
  85.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  86.      &                  'DEFORMEE_MODALE',L1,IP1)
  87.       ICHAIN = 4
  88.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  89.      &                  'CONTRAINTE_MODALE',L1,IP1)
  90.       ICHAIN = 5
  91.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  92.      &                  'REACTION_MODALE',L1,IP1)
  93.       ICHAIN = 6
  94.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  95.      &                  'DEPLACEMENT',L1,IP1)
  96.       ICHAIN = 7
  97.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  98.      &                  'CONTRAINTE',L1,IP1)
  99.       ICHAIN = 8
  100.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  101.      &                  'REACTION',L1,IP1)
  102.       ICHAIN = 9
  103.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  104.      &                  'CHAMP_BASE_B',L1,IP1)
  105.       ICHAIN = 10
  106.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  107.      &                  'POINT',L1,IP1)
  108.       ICHAIN = 11
  109.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  110.      &                  'MODES',L1,IP1)
  111.       ICHAIN = 12
  112.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  113.      &                  'PSEUDO_MODES',L1,IP1)
  114.       ICHAIN = 13
  115.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  116.      &                  'MAILLAGE',L1,IP1)
  117.       ICHAIN = 14
  118.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  119.      &                  'SOUSTYPE',L1,IP1)
  120.       ICHAIN = 15
  121.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  122.      &                  'BASE_MODALE',L1,IP1)
  123.       ICHAIN = 16
  124.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  125.      &                  'BASE_ROTA',L1,IP1)
  126.       ICHAIN = 17
  127.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  128.      &                  'BASE_PLUS',L1,IP1)
  129.       ICHAIN = 18
  130.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  131.      &                  'BASE',L1,IP1)
  132.       ICHAIN = 19
  133.       CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1,
  134.      &                  'MASSE_GENERALISEE',L1,IP1)
  135. *
  136.       MTABLE = ITBID
  137.       SEGACT,MTABLE
  138.       DO 20 ICHAIN = 1 , NCHAIN
  139.          LCHAIN(ICHAIN) = MTABIV(ICHAIN)
  140.  20      CONTINUE
  141. *     end do
  142.       SEGSUP,MTABLE
  143. *
  144. *     R{cup{ration de la table des modes
  145. *
  146.       MTABLE = ITBAS
  147.       SEGACT MTABLE
  148.       LONG = MLOTAB
  149.       DO 10 I = 1,LONG
  150.          IF (MTABTI(I).EQ.'MOT     ' .AND.
  151.      &          MTABII(I).EQ.LCHAIN(11) .AND.
  152.      &          MTABTV(I).EQ.'TABLE   ') THEN
  153.             IBAS = MTABIV(I)
  154.             GOTO 12
  155.          ENDIF
  156.  10      CONTINUE
  157. *     end do
  158.       CALL ERREUR(499)
  159.       SEGDES MTABLE
  160.       RETURN
  161.  12   CONTINUE
  162. *
  163. *     R{cup{ration de la table des pseudo-modes
  164. *
  165.       IPSM = 0
  166.       DO 14 I = 1,LONG
  167.          IF (MTABTI(I).EQ.'MOT     ' .AND.
  168.      &          MTABII(I).EQ.LCHAIN(12) .AND.
  169.      &          MTABTV(I).EQ.'TABLE   ') THEN
  170.             IPSM = MTABIV(I)
  171.             GOTO 16
  172.          ENDIF
  173.  14      CONTINUE
  174. *     end do
  175.  16   CONTINUE
  176.       SEGDES MTABLE
  177. *
  178.       KTRAV = 0
  179.       IF (MOTCLE.EQ.'ROTA') THEN
  180.          IDIM1 = IDIM + 1
  181.          CALL CALMAT(KTRAV,IPO1,IPO2,XANG)
  182.          IF (IERR.NE.0) RETURN
  183.          MTRAV = KTRAV
  184.       ENDIF
  185. *
  186. *     Traitement de la table de modes
  187. *     ===============================
  188. *
  189. *     On duplique la table des modes
  190. *
  191.       CALL COPBA2(LCHAIN,IBAS,IBA2)
  192. *
  193. *     On r{cup}re la premi}re d{form{e modale pour cr{er le nouveau
  194. *     maillage.
  195. *
  196.       MTABLE = IBA2
  197.       SEGACT MTABLE*MOD
  198.       LONG = MLOTAB
  199.       IM = 1
  200.       DO 60 I = 1,LONG
  201.          IF (MTABTI(I).EQ.'ENTIER  ' .AND. MTABII(I).EQ.IM .AND.
  202.      &                   MTABTV(I).EQ.'TABLE   ') THEN
  203.             ITMOD = MTABIV(I)
  204.             GOTO 62
  205.          ENDIF
  206.  60      CONTINUE
  207. *     end do
  208.       CALL ERREUR(500)
  209.       SEGDES MTABLE
  210.       RETURN
  211.  62   CONTINUE
  212.       MTAB1 = ITMOD
  213.       SEGACT MTAB1*MOD
  214.       LON1 = MTAB1.MLOTAB
  215.       DO 64 I1 = 1,LON1
  216.          IF (MTAB1.MTABTI(I1).EQ.'MOT     ' .AND.
  217.      &             MTAB1.MTABII(I1).EQ.LCHAIN(3) .AND.
  218.      &                   MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
  219.             ICHDEP = MTAB1.MTABIV(I1)
  220.             GOTO 66
  221.          ENDIF
  222.  64      CONTINUE
  223. *     end do
  224.       CALL ERREUR(501)
  225.       SEGDES MTAB1
  226.       SEGDES MTABLE
  227.       RETURN
  228.  66   CONTINUE
  229. *
  230.       MCHPOI = ICHDEP
  231.       SEGACT MCHPOI
  232.       NSOU = IPCHP(/1)
  233.       SEGINI ITRCHP
  234.       KTRCHP = ITRCHP
  235.       DO 80 INS = 1,NSOU
  236.          MSOUPO = IPCHP(INS)
  237.          SEGACT MSOUPO*MOD
  238.          IF (MOTCLE.EQ.'PLUS') THEN
  239.             MAIL1 = IGEOC
  240.             ICHCA(INS) = MAIL1
  241.             CALL ECROBJ('POINT   ',IPO1)
  242.             CALL ECROBJ('MAILLAGE',MAIL1)
  243.             CALL PROPER(1)
  244.             IF (IERR.NE.0) RETURN
  245.             CALL LIROBJ('MAILLAGE',NOMA1,1,IRETOU)
  246.             IF (IERR.NE.0) RETURN
  247.             IGEOC = NOMA1
  248.             ICHCN(INS) = NOMA1
  249.          ELSE
  250.             SEGINI MTRA2
  251.             MPOVAL = IPOVAL
  252.             SEGACT MPOVAL
  253.             NPOIN = VPOCHA(/1)
  254.             NCOM  = VPOCHA(/2)
  255.             DO 210 IP = 1,NPOIN
  256.                ICD = 0
  257.                ICR = 0
  258.                DO 220 IC = 1,NCOM
  259.                   COMP = NOCOMP(IC)
  260.                   IF (COMP(1:1).EQ.'U') THEN
  261.                      ICD = ICD + 1
  262.                      IDEP(ICD) = IC
  263.                      XDEP(ICD) = VPOCHA(IP,IC)
  264.                   ELSE IF (COMP(1:1).EQ.'R') THEN
  265.                      ICR = ICR + 1
  266.                      IROT(ICR) = IC
  267.                      XROT(ICR) = VPOCHA(IP,IC)
  268.                   ENDIF
  269.  220              CONTINUE
  270. *              end do
  271.                DO 230 IDE = 1,ICD
  272.                   XVAL = 0.D0
  273.                   DO 232 ID2 = 1,ICD
  274.                      XVAL = XVAL + (XMPT(IDE,ID2) * XDEP(ID2))
  275.  232                 CONTINUE
  276. *                 end do
  277.                   IC = IDEP(IDE)
  278.                   VPOCHA(IP,IC) = XVAL
  279.  230              CONTINUE
  280. *              end do
  281.                IF (IDIM.EQ.3) THEN
  282.                   DO 240 IRO = 1,ICR
  283.                      XVAL = 0.D0
  284.                      DO 242 IR2 = 1,ICR
  285.                         XVAL = XVAL + (XMPT(IRO,IR2) * XROT(IR2))
  286.  242                    CONTINUE
  287. *                    end do
  288.                      IC = IROT(IRO)
  289.                      VPOCHA(IP,IC) = XVAL
  290.  240                 CONTINUE
  291. *                 end do
  292.                ENDIF
  293.  210           CONTINUE
  294. *           end do
  295.             SEGDES MPOVAL
  296.             SEGSUP MTRA2
  297.             MAIL1 = IGEOC
  298.             ICHCA(INS) = MAIL1
  299.             IPT1 = MAIL1
  300.             SEGINI,MELEME=IPT1
  301.             NOMA1 = MELEME
  302.             NBE = NUM(/2)
  303.             segact mcoord*mod
  304.             NBPT = nbpts
  305.             NBPTS = NBPT + NBE
  306.             SEGADJ MCOORD
  307.             DO 82 IP = 1,NBE
  308.                IPT = NUM(IP,1)
  309.                CALL EXCOO1(IPT,XP,YP,ZP,DP)
  310.                NBPT1 = NBPT + 1
  311.                XPT(1) = XP
  312.                XPT(2) = YP
  313.                IF (IDIM.EQ.3) XPT(3) = ZP
  314.                DO 84 ID1 = 1,IDIM
  315.                   XVAL = 0.D0
  316.                   DO 86 ID2 = 1,IDIM
  317.                      XVAL = XVAL + (XMPT(ID1,ID2) * XPT(ID2))
  318.  86                  CONTINUE
  319. *                 end do
  320.                   XPTP(ID1) = XVAL + XP1PT(ID1)
  321.  84               CONTINUE
  322. *              end do
  323.                XCOOR(NBPT * IDIM1 + 1) = XPTP(1)
  324.                XCOOR(NBPT * IDIM1 + 2) = XPTP(2)
  325.                IF (IDIM.EQ.3) XCOOR(NBPT * IDIM1 + 3) = XPTP(3)
  326.                XCOOR(NBPT1 * IDIM1) = DP
  327.                NUM(IP,1) = NBPT1
  328.                NBPT = NBPT1
  329.  82            CONTINUE
  330. *           end do
  331.             SEGDES MELEME
  332.             IGEOC = NOMA1
  333.             ICHCN(INS) = NOMA1
  334.          ENDIF
  335.          SEGDES MSOUPO
  336.  80      CONTINUE
  337. *     end do
  338.       SEGDES MCHPOI
  339.       MTAB1.MTABIV(I1) = ICHDEP
  340. *
  341.       IMAIL = ICHCA(1)
  342.       INOMA = ICHCN(1)
  343.       DO 40 INS = 2,NSOU
  344.          MAIL1 = ICHCA(INS)
  345.          NOMA1 = ICHCN(INS)
  346.          ltelq=.false.
  347.          CALL FUSE(INOMA,NOMA1,INOM2,ltelq)
  348.          INOMA = INOM2
  349.          CALL FUSE(IMAIL,MAIL1,IMAI2,ltelq)
  350.          IMAIL = IMAI2
  351.  40      CONTINUE
  352. *     end do
  353. *
  354.       ICONT = 0
  355.       DO 90 I1 = 1,LON1
  356.          IF (MTAB1.MTABTI(I1).EQ.'MOT     ' .AND.
  357.      &             MTAB1.MTABII(I1).EQ.LCHAIN(4) .AND.
  358.      &                   MTAB1.MTABTV(I1).EQ.'MCHAML  ') THEN
  359.             ICHCON = MTAB1.MTABIV(I1)
  360.             ICONT = 1
  361.             GOTO 92
  362.          ENDIF
  363.  90      CONTINUE
  364. *     end do
  365.  92   CONTINUE
  366.       KTRCHA = 0
  367.       IF (ICONT.EQ.1) THEN
  368.          MCHELM = ICHCON
  369.          SEGACT MCHELM*MOD
  370.          NSOUS = IMACHE(/1)
  371.          SEGINI ITRCHA
  372.          KTRCHA = ITRCHA
  373.          DO 94 IN = 1,NSOUS
  374.             IPT1 = IMACHE(IN)
  375.             SEGINI,MELEME=IPT1
  376.             NBN = NUM(/1)
  377.             NBE = NUM(/2)
  378.             DO 96 IE = 1,NBE
  379.                DO 98 IP = 1,NBN
  380.                   IPO = NUM(IP,IE)
  381.                   CALL BAPOIN(IMAIL,IPO,INOMA,INOPO)
  382.                   IF (IERR.NE.0) RETURN
  383.                   NUM(IP,IE) = INOPO
  384.  98               CONTINUE
  385. *              end do
  386.  96            CONTINUE
  387. *           end do
  388.             SEGDES MELEME
  389.             ICHAM(IN) = MELEME
  390.             IMACHE(IN) = MELEME
  391.  94         CONTINUE
  392. *        end do
  393.          SEGDES MCHELM
  394.          MTAB1.MTABIV(I1) = ICHCON
  395.       ENDIF
  396. *
  397.       IF (MOTCLE.EQ.'ROTA') THEN
  398.          DO 400 I1 = 1,LON1
  399.            IF (MTAB1.MTABTI(I1).EQ.'MOT     ' .AND.
  400.      &                MTAB1.MTABII(I1).EQ.LCHAIN(2) .AND.
  401.      &                      MTAB1.MTABTV(I1).EQ.'TABLE   ') THEN
  402.                ITDEPG = MTAB1.MTABIV(I1)
  403.                GOTO 402
  404.             ENDIF
  405.  400        CONTINUE
  406. *        end do
  407.          CALL ERREUR(502)
  408.          SEGDES MTAB1
  409.          SEGDES MTABLE
  410.          RETURN
  411.  402     CONTINUE
  412. *
  413.          SEGINI MTRA3
  414.          MTAB2 = ITDEPG
  415.          SEGACT MTAB2
  416.          LON2 = MTAB2.MLOTAB
  417.          IDG = 1
  418.          DO 410 I2 = 1,LON2
  419.             IF (MTAB2.MTABTI(I2).EQ.'ENTIER  ' .AND.
  420.      &                MTAB2.MTABII(I2).EQ.IDG .AND.
  421.      &                      MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN
  422.                XDGEN(IDG) = MTAB2.RMTABV(I2)
  423.                IDG = IDG + 1
  424.             ENDIF
  425.  410        CONTINUE
  426. *        end do
  427.          DO 420 ID1 = 1,IDIM
  428.             XVAL = 0.D0
  429.             DO 422 ID2 = 1,IDIM
  430.                XVAL = XVAL + (XMPT(ID1,ID2) * XDGEN(ID2))
  431.  422           CONTINUE
  432. *           end do
  433.             XDGE2(ID1) = XVAL
  434.  420        CONTINUE
  435. *        end do
  436.          IDG = 1
  437.          DO 430 I2 = 1,LON2
  438.             IF (MTAB2.MTABTI(I2).EQ.'ENTIER  ' .AND.
  439.      &                MTAB2.MTABII(I2).EQ.IDG .AND.
  440.      &                      MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN
  441.                MTAB2.RMTABV(I2) = XDGE2(IDG)
  442.                IDG = IDG + 1
  443.             ENDIF
  444.  430        CONTINUE
  445. *        end do
  446.          SEGDES MTAB2
  447.          MTAB1.MTABIV(I1) = ITDEPG
  448.          SEGSUP MTRA3
  449.       ENDIF
  450. *
  451.       IREAC = 0
  452.       DO 790 I1 = 1,LON1
  453.          IF (MTAB1.MTABTI(I1).EQ.'MOT     ' .AND.
  454.      &             MTAB1.MTABII(I1).EQ.LCHAIN(5) .AND.
  455.      &                   MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
  456.             ICHREA = MTAB1.MTABIV(I1)
  457.             IREAC = 1
  458.             GOTO 792
  459.          ENDIF
  460.  790     CONTINUE
  461. *     end do
  462.  792  CONTINUE
  463.       IF (IREAC.EQ.1) THEN
  464.          MCHPOI = ICHREA
  465.          SEGACT MCHPOI
  466.          NSOU2 = IPCHP(/1)
  467.          DO 722 INS = 1,NSOU2
  468.             MSOUPO = IPCHP(INS)
  469.             SEGACT MSOUPO*MOD
  470.             IF (MOTCLE.EQ.'ROTA') THEN
  471.                SEGINI MTRA4
  472.                MPOVAL = IPOVAL
  473.                SEGACT MPOVAL
  474.                NPOI2 = VPOCHA(/1)
  475.                NCOM2 = VPOCHA(/2)
  476.                DO 710 IP = 1,NPOI2
  477.                   ICF = 0
  478.                   ICM = 0
  479.                   DO 720 IC = 1,NCOM2
  480.                      COMP = NOCOMP(IC)
  481.                      IF (COMP(1:1).EQ.'F') THEN
  482.                         ICF = ICF + 1
  483.                         IFOR(ICF) = IC
  484.                         XFOR(ICF) = VPOCHA(IP,IC)
  485.                      ELSE IF (COMP(1:1).EQ.'M') THEN
  486.                         ICM = ICM + 1
  487.                         IMOM(ICM) = IC
  488.                         XMOM(ICM) = VPOCHA(IP,IC)
  489.                      ENDIF
  490.  720                 CONTINUE
  491. *                 end do
  492.                   DO 730 IFO = 1,ICF
  493.                      XVAL = 0.D0
  494.                      DO 732 IF2 = 1,ICF
  495.                         XVAL = XVAL + XMPT(IFO,IF2) * XFOR(IF2)
  496.  732                    CONTINUE
  497. *                    end do
  498.                      IC = IFOR(IFO)
  499.                      VPOCHA(IP,IC) = XVAL
  500.  730                 CONTINUE
  501. *                 end do
  502.                   IF (IDIM.EQ.3) THEN
  503.                      DO 740 IMO = 1,ICM
  504.                         XVAL = 0.D0
  505.                         DO 742 IM2 = 1,ICM
  506.                            XVAL = XVAL + XMPT(IMO,IM2) * XROT(IM2)
  507.  742                       CONTINUE
  508. *                       end do
  509.                         IC = IMOM(IMO)
  510.                         VPOCHA(IP,IC) = XVAL
  511.  740                    CONTINUE
  512. *                    end do
  513.                   ENDIF
  514.  710              CONTINUE
  515. *              end do
  516.                SEGDES MPOVAL
  517.                SEGSUP MTRA4
  518.             ENDIF
  519.             IPT1 = IGEOC
  520.             SEGINI,MELEME=IPT1
  521.             NBE = NUM(/2)
  522.             NBP = NUM(/1)
  523.             DO 750 IE = 1,NBE
  524.                DO 752 IP = 1,NBP
  525.                   IPTS = NUM(IP,IE)
  526.                   CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
  527.                   IF (IERR.NE.0) RETURN
  528.                   NUM(IP,IE) = INOPT
  529.  752              CONTINUE
  530. *                 end do
  531.  750           CONTINUE
  532. *           end do
  533.             SEGDES MELEME
  534.             IGEOC = MELEME
  535.             SEGDES MSOUPO
  536.  722        CONTINUE
  537. *        end do
  538.          SEGDES MCHPOI
  539.          MTAB1.MTABIV(I1) = ICHREA
  540.       ENDIF
  541. *
  542.       SEGDES MTAB1
  543.       MTABIV(I) = ITMOD
  544. *
  545. *     On range le maillage dans la nouvelle table de modes
  546. *
  547.       DO 42 I = 1,LONG
  548.          IF (MTABTI(I).EQ.'MOT     ' .AND.
  549.      &            MTABII(I).EQ.LCHAIN(13) .AND.
  550.      &                   MTABTV(I).EQ.'MAILLAGE') THEN
  551.             MTABIV(I) = INOMA
  552.             GOTO 44
  553.          ENDIF
  554.  42      CONTINUE
  555. *     end do
  556.       CALL ERREUR(503)
  557.       SEGDES MTABLE
  558.       RETURN
  559.  44   CONTINUE
  560. *
  561.       SEGDES MTABLE
  562. *
  563.       IMODE = 2
  564.       CALL COPBA3(IBA2,MOTCLE,IMODE,IMAIL,INOMA,LCHAIN,KTRCHP,KTRCHA,
  565.      &            KTRAV,ICONT)
  566.       IF (IERR.NE.0) RETURN
  567. *
  568. *     Normalisation des modes
  569. *
  570.       IF (MOTCLE.EQ.'ROTA') THEN
  571.          CALL NORMOD(IBA2,LCHAIN)
  572.       ENDIF
  573. *
  574. *     Traitement de la table de pseudo-modes
  575. *     ======================================
  576. *
  577. *     On duplique la table des pseudo-modes
  578. *
  579.       IF (IPSM.NE.0) THEN
  580.          CALL COPBA2(LCHAIN,IPSM,IPS2)
  581.          IMODE = 1
  582.          CALL COPBA3(IPS2,MOTCLE,IMODE,IMAIL,INOMA,LCHAIN,KTRCHP,
  583.      &               KTRCHA,KTRAV,ICONT)
  584.          IF (IERR.NE.0) RETURN
  585. *
  586. *        On projecte les champs base B sur la base modale
  587. *
  588.          CALL COPBA4(IBA2,IPS2)
  589.       ENDIF
  590. *
  591.       SEGSUP ITRCHP
  592.       IF (ICONT.EQ.1) SEGSUP ITRCHA
  593.       IF (MOTCLE.EQ.'ROTA') THEN
  594.          SEGSUP MTRAV
  595.       ENDIF
  596. *
  597. *     Cr{ation de la table de sous-type BASE_MODALE
  598. *
  599.       IF (IPSM.EQ.0) THEN
  600.          M = 2
  601.       ELSE
  602.          M = 3
  603.       ENDIF
  604.       SEGINI MTABLE
  605.       ITBA2 = MTABLE
  606.       MLOTAB = M
  607.       MTABTI(1) = 'MOT     '
  608.       MTABII(1) = LCHAIN(14)
  609.       MTABTV(1) = 'MOT     '
  610.       MTABIV(1) = LCHAIN(15)
  611.       MTABTI(2) = 'MOT     '
  612.       MTABII(2) = LCHAIN(11)
  613.       MTABTV(2) = 'TABLE   '
  614.       MTABIV(2) = IBA2
  615.       IF (IPSM.NE.0) THEN
  616.          MTABTI(3) = 'MOT     '
  617.          MTABII(3) = LCHAIN(12)
  618.          MTABTV(3) = 'TABLE   '
  619.          MTABIV(3) = IPS2
  620.       ENDIF
  621.       SEGDES MTABLE
  622. *
  623. *     Traitement de la table des points
  624. *     =================================
  625. *
  626.       CALL CRTABL(ITPT2)
  627.       IF (MOTCLE.EQ.'PLUS') THEN
  628.          CALL ECCTAB(ITPT2,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  629.      &                     'MOT',I1,X1,'POINT_PLUS',L1,IP1)
  630.       ELSE
  631.          CALL ECCTAB(ITPT2,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  632.      &                     'MOT',I1,X1,'POINT_ROTA',L1,IP1)
  633.       ENDIF
  634.       IP = 0
  635.  50   CONTINUE
  636.       IP = IP + 1
  637.       TYPRET = ' '
  638.       CALL ACCTAB(ITPTS,'ENTIER',IP,X0,' ',L0,IP0,
  639.      &                  TYPRET,I1,X1,CHARRE,L1,IPTS)
  640.       IF (IPTS.NE.0 .AND. TYPRET.EQ.'POINT   ') THEN
  641.          CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
  642.          IF (IERR.NE.0) RETURN
  643.          CALL ECCTAB(ITPT2,'POINT',I0,X0,' ',L0,IPTS,
  644.      &                     'POINT',I1,X1,' ',L1,INOPT)
  645.          GOTO 50
  646.       ENDIF
  647. *
  648. *     Cr{ation de la table de sortie
  649. *
  650.       M = 3
  651.       SEGINI MTABLE
  652.       ITNOBA = MTABLE
  653.       MLOTAB = 3
  654.       MTABTI(1) = 'MOT     '
  655.       MTABII(1) = LCHAIN(14)
  656.       MTABTV(1) = 'MOT     '
  657.       IF (MOTCLE.EQ.'PLUS') THEN
  658.          MTABIV(1) = LCHAIN(17)
  659.       ELSE
  660.          MTABIV(1) = LCHAIN(16)
  661.       ENDIF
  662.       MTABTI(2) = 'MOT     '
  663.       MTABII(2) = LCHAIN(18)
  664.       MTABTV(2) = 'TABLE   '
  665.       MTABIV(2) = ITBA2
  666.       MTABTI(3) = 'MOT     '
  667.       MTABII(3) = LCHAIN(10)
  668.       MTABTV(3) = 'TABLE   '
  669.       MTABIV(3) = ITPT2
  670.       SEGDES MTABLE
  671. *
  672.       CALL ECROBJ('TABLE   ',ITNOBA)
  673. *
  674.       END
  675.  
  676.  
  677.  
  678.  
  679.  
  680.  
  681.  

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