Télécharger la plaquette Cast3M


fr en

Télécharger comalo.eso

Retour à la liste

Numérotation des lignes : 

comalo

  1. C COMALO    SOURCE    CB215821  24/04/12    21:15:19     11897          
  2.       SUBROUTINE COMALO(ipmode,itruli,ipmel)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. *--------------------------------------------------------
  6. * CF DEVALO.ESO et DEVTRA.ESO
  7. * indexe infos deformees modales , deplacements
  8. *--------------------------------------------------------
  9. -INC SMCOORD
  10. -INC DECHE
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC CCGEOME
  15. -INC SMCHAML
  16. -INC SMELEME
  17. -INC SMMODEL
  18. -INC SMLENTI
  19. -INC CCREEL
  20. *
  21.       segment wrktvu
  22.         integer jtvu(lilmel(/1))
  23.       endsegment
  24.       segment mwinit
  25.         integer jpdep,jpvit,jrepr
  26.       endsegment
  27. *
  28. *     Segment des variables generalisees:
  29. *
  30.       SEGMENT,MTQ
  31.          REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4)
  32.          REAL*8 WEXT(NA1,2),WINT(NA1,2)
  33.       ENDSEGMENT
  34.       SEGMENT,MTKAM
  35.          REAL*8 XK(NA1,NB1K),XASM(NA1,NB1C),XM(NA1,NB1M)
  36.          REAL*8 XOPER(NB1,NB1,NOPER)
  37.       ENDSEGMENT
  38.  
  39. * Segment pour Champoints
  40.       SEGMENT,MSAM
  41.          integer jplibb(NPLB)
  42.       ENDSEGMENT
  43. *
  44. *** segment sous-structures dynamiques
  45.       segment struli
  46.        integer itlia,itbmod,momoda, mostat,itmail,molia
  47.        integer ldefo(np1),lcgra(np1),lsstru(np1)
  48.        integer nsstru,nndefo,nliab,nsb,na2,idimb
  49.        integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas
  50.        INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib
  51. * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0)
  52.        INTEGER ICHAIN
  53.       endsegment
  54.  
  55.       SEGMENT MOLIAI
  56.          integer modtla,modtlb
  57.       ENDSEGMENT
  58. *
  59. *     Segment de travail pour reprise force POLYNOMIALE base A
  60. *
  61.       SEGMENT,MTRA
  62.          INTEGER IPLA(NTRA)
  63.       ENDSEGMENT
  64.  
  65.       SEGMENT,ICPR(nbpts)
  66.       SEGMENT,MCPR(nbpts)
  67.       SEGMENT,MPREF
  68.          INTEGER IPOREF(NPREF)
  69.       ENDSEGMENT
  70.       segment icma(0)
  71.       segment icnna2(0)
  72.       PARAMETER (MDEPL=20)
  73.       LOGICAL REPRIS,LMODYN,RIGIDE,ilogmo,ilogst,ilogre,L0,LVA1,LVAR
  74.       CHARACTER*4 LISDEP(MDEPL),LISVIT(MDEPL),TESDEP
  75.       CHARACTER*6  MO2
  76.       CHARACTER*8 CMOT,TYPRET,MORIGI,CHARRE
  77.       CHARACTER*10 MO1
  78.       CHARACTER*40 MONMOT
  79.       DATA LISDEP/ 'UX  ','UY  ','UZ  ','UR  ','UT  ','RX  ','RY  ',
  80.      &'RZ  ','RT  ','ALFA','BETA','IUX ','IUY ','IUZ ','IUR ','IUT ',
  81.      &'IRX ','IRY ','IRZ ','IRT '/
  82.       DATA LISVIT/ 'VTX ','VTY ','VTZ ','VTR ','VTT ','VWX ','VWY ',
  83.      &'VWZ ','VWT ','VALF','VBET','IVTX','IVTY','IVTZ','IVTR','IVTT',
  84.      &'IVWX','IVWY','IVWZ','IVWT'/
  85. *
  86. *     si IFOMOD = -1  :  mod?le PLAN
  87. *     si IFOMOD =  0  :  mod?le AXIS
  88. *     si IFOMOD =  1  :  mod?le FOUR
  89. *     si IFOMOD =  2  :  mod?le TRID
  90. *
  91. *
  92.       ITREP  = 0
  93.       MTQ    = 0
  94.       MTKAM  = 0
  95.       MTPHI  = 0
  96.       MTLIAA = 0
  97.       MTLIAB = 0
  98.       MTFEX  = 0
  99.       MTPAS  = 0
  100.       MTRES  = 0
  101.       MTNUM  = 0
  102.       MTRA   = 0
  103.       XTINI  = 0.D0
  104.       ITLA = 0
  105.       ITLB = 0
  106.       REPRIS = .FALSE.
  107.  
  108.       lilmel = ipmel
  109.       struli = itruli
  110.       jliaib = 0
  111.       nmost = 0
  112.       nmost0 = 0
  113.       kovaen = 0
  114.       kovare = 0
  115. * identifie materiau MODAL ou STATIQUE
  116.  
  117.           itmod = ipmode
  118. *
  119.          call ecrcha('MODAL')
  120.           call ecrcha('MATE')
  121.           call ecrobj('MMODEL',ITMOD)
  122.           call exis
  123.           call lirlog(ilogmo,0,iret)
  124.          IF (ilogmo) THEN
  125.            call ecrcha('MECANIQUE')
  126.            call ecrcha('FORM')
  127.            call ecrobj('MMODEL',ITMOD)
  128.            call extrai
  129.            call lirobj('MMODEL',momod1,0,iret)
  130.            call ecrcha('MODAL')
  131.            call ecrcha('MATE')
  132.            call ecrobj('MMODEL',momod1)
  133.            call extrai
  134.            call lirobj('MMODEL',ipmodz,0,iret)
  135.            momoda = ipmodz
  136.            mmode1 = ipmodz
  137.            segact mmode1
  138.            nmost0 = mmode1.kmodel(/1)
  139.            nmost = nmost + nmost0
  140.          ENDIF
  141.           call ecrcha('STATIQUE')
  142.           call ecrcha('MATE')
  143.           call ecrobj('MMODEL',ITMOD)
  144.           call exis
  145.           call lirlog(ilogst,0,iret)
  146.          IF (ilogst) THEN
  147.             call ecrcha('MECANIQUE')
  148.            call ecrcha('FORM')
  149.            call ecrobj('MMODEL',ITMOD)
  150.            call extrai
  151.            call lirobj('MMODEL',momod1,0,iret)
  152.            call ecrcha('STATIQUE')
  153.            call ecrcha('MATE')
  154.            call ecrobj('MMODEL',momod1)
  155.            call extrai
  156.            call lirobj('MMODEL',ipmodz,0,iret)
  157.            mostat = ipmodz
  158.            mmode1 = ipmodz
  159.            segact mmode1
  160.            nmost = nmost + mmode1.kmodel(/1)
  161.          ENDIF
  162.          na1 = nmost
  163.          mmode2 = itlia
  164.          segact mmode2
  165.          nliat = mmode2.kmodel(/1)
  166.          mmode1 = ipmode
  167.          segact mmode1
  168.          ilogre = (mmode1.kmodel(/1) - na1 - nliat).gt.0
  169.  
  170.          n1 = nmost
  171.          segini mmodel
  172.          mmode1 = momoda
  173.          do im = 1,nmost0
  174.            kmodel(im) = mmode1.kmodel(im)
  175.          enddo
  176.          IF (ilogst) THEN
  177.          mmode1 = mostat
  178.          do im = 1,mmode1.kmodel(/1)
  179.            kmodel(nmost0 + im) = mmode1.kmodel(im)
  180.          enddo
  181.          ENDIF
  182.          itbmod = mmodel
  183.          np1 = nmost
  184.          segadj struli
  185. *
  186. * collecte deplacements, vitesses, deformation , centre gravite
  187.           segini wrktvu
  188.           iptvu = wrktvu
  189.           do 2010 mvu = 1,lilmel(/1)
  190.            deche = lilmel(mvu)
  191.            if(ilogmo) then
  192.             if (nomdec.eq.'ALFA    '.and.indec.eq.1) then
  193.               jtvu(mvu) = 101
  194.               goto 2010
  195.             endif
  196.             if (nomdec.eq.'ALFA    '.and.indec.gt.1) then
  197.               jtvu(mvu) = 102
  198.               goto 2010
  199.             endif
  200.             if (nomdec.eq.'FALF    '.and.indec.gt.1) then
  201.               jtvu(mvu) = 105
  202.               goto 2010
  203.             endif
  204.             if (nomdec.eq.'VALF    '.and.indec.eq.1) then
  205.               jtvu(mvu) = 106
  206.               goto 2010
  207.             endif
  208.             if (nomdec.eq.'VALF    '.and.indec.gt.1) then
  209.               jtvu(mvu) = 107
  210.               goto 2010
  211.             endif
  212.            endif
  213.            if(ilogst) then
  214.              if (nomdec.eq.'BETA    '.and.indec.eq.1) then
  215.               jtvu(mvu) = 201
  216.               goto 2010
  217.             endif
  218.             if (nomdec.eq.'BETA    '.and.indec.gt.1) then
  219.               jtvu(mvu) = 202
  220.               goto 2010
  221.             endif
  222.             if (nomdec.eq.'FBET    '.and.indec.gt.1) then
  223.               jtvu(mvu) = 205
  224.               goto 2010
  225.             endif
  226.             if (nomdec.eq.'VBET    '.and.indec.eq.1) then
  227.               jtvu(mvu) = 206
  228.               goto 2010
  229.             endif
  230.             if (nomdec.eq.'VBET    '.and.indec.gt.1) then
  231.               jtvu(mvu) = 207
  232.               goto 2010
  233.             endif
  234.            endif
  235.            if(ilogmo.or.ilogst) then
  236.             if (nomdec.eq.'DEFO    '.and.indec.gt.1) then
  237.                jtvu(mvu)= 302
  238.                goto 2010
  239.             endif
  240.             if (nomdec.eq.'AMOR    '.and.indec.gt.1) then
  241.                jtvu(mvu)= 305
  242.                goto 2010
  243.             endif
  244.            endif
  245.            if(ilogmo) then
  246.             if (nomdec.eq.'CGRA    '.and.indec.gt.1) then
  247.                jtvu(mvu)= 303
  248.                goto 2010
  249.             endif
  250.             if (nomdec.eq.'FREQ    '.and.indec.gt.1) then
  251.                jtvu(mvu)= 304
  252.                goto 2010
  253.             endif
  254.             if (nomdec.eq.'MASS    '.and.indec.gt.1) then
  255.                jtvu(mvu)= 305
  256.                goto 2010
  257.             endif
  258.            endif
  259.           if (ilogre) then
  260.            do mdep = 1,MDEPL
  261.              if (nomdec(1:4).eq.lisdep(mdep)) then
  262.                jtvu(mvu)= mdep
  263.                goto 2010
  264.              endif
  265.              if (nomdec(1:4).eq.lisvit(mdep)) then
  266.                jtvu(mvu)= mdep * (-1)
  267.                goto 2010
  268.              endif
  269.            enddo
  270.           endif
  271.  
  272.           if (nomdec.eq.'SORT    ') then
  273.             jtvu(mvu) = 501
  274.             goto 2010
  275.           endif
  276.  
  277.           if (nomdec.eq.'VAEN    ') then
  278.             jtvu(mvu) = 506
  279.             kovaen = kovaen + 1
  280.             goto 2010
  281.           endif
  282.  
  283.           if (nomdec.eq.'VARE    ') then
  284.             jtvu(mvu) = 507
  285.             kovare = kovare + 1
  286.             goto 2010
  287.           endif
  288.  
  289.  
  290.           jtvu(mvu) = -100
  291.  
  292.  2010     continue
  293.  
  294.       IK = 0
  295.       SEGINI,ICPR
  296.       LCPR = nbpts
  297.  
  298.        MMODEL = itbmod
  299.        segact MMODEL
  300.        do 60 im = 1,kmodel(/1)
  301.          imodel = kmodel(im)
  302.          segact imodel*nomod
  303.           meleme = imamod
  304.           segact meleme
  305. * a priori 1 seul point
  306.           do ip = 1,num(/2)
  307.             knoe = num(1,ip)
  308.             IF (KNOE.NE.0) THEN
  309.                IF (ICPR(KNOE).EQ.0) THEN
  310.                   IK = IK + 1
  311.                   ICPR(KNOE) = IK
  312.       IF (IIMPI.EQ.333) THEN
  313.       WRITE(IOIMP,*)'COMALO : basemo. ICPR(',KNOE,')=',ICPR(KNOE)
  314.       ENDIF
  315.                ENDIF
  316.             ENDIF
  317.           enddo
  318.  60    continue
  319. *
  320.  
  321. *
  322. *     5/ Cr{ation du segment d{finissant les points supports:
  323. *
  324.       NPREF = IK
  325.       SEGINI,MPREF
  326.       KPREF = MPREF
  327.       ikpref = KPREF
  328.       DO 100 I=1,LCPR
  329.          IF (ICPR(I).NE.0) THEN
  330.             IREF = ICPR(I)
  331.             IPOREF(IREF) = I
  332.             IF (IIMPI.EQ.333) THEN
  333.                WRITE(IOIMP,*)'COMALO : IPOREF(',IREF,')=',IPOREF(IREF)
  334.             ENDIF
  335.          ENDIF
  336.  100  CONTINUE
  337.  
  338. *
  339. * creation et remplissage MTQ (revoir indices dans DYNE 1=actuel 2=avant)
  340. *
  341.       NA1 = nmost
  342.       NB1K = 1
  343.       NB1C = 1
  344.       NB1M = 1
  345.       NB1  = 1
  346.       NOPER = 0
  347.       segini MTQ,MTKAM
  348.       ktq = MTQ
  349.       ktkam = MTKAM
  350.       do ia1 = 1,na1
  351.         xk(ia1,1) = 1.d0
  352.       enddo
  353.       mmodel = itbmod
  354.  
  355.       do 3010 mvu = 1,lilmel(/1)
  356.         if (jtvu(mvu).ne.101.and.jtvu(mvu).ne.102.and.
  357.      &jtvu(mvu).ne.106.and.jtvu(mvu).ne.107.and.
  358.      &jtvu(mvu).ne.201.and.jtvu(mvu).ne.202.and.
  359.      &jtvu(mvu).ne.206.and.jtvu(mvu).ne.207.and.
  360.      &jtvu(mvu).ne.105.and.jtvu(mvu).ne.205.and.
  361.      &jtvu(mvu).ne.304.and.jtvu(mvu).ne.305) goto 3010
  362.            deche = lilmel(mvu)
  363.               melval = ABS(ieldec)
  364. **            segact melval
  365.  
  366.             do 3050 im = 1,kmodel(/1)
  367.              imodel = kmodel(im)
  368.              if (imadec.ne.imamod.or.
  369.      &           condec(1:LCONMO).ne.conmod(1:LCONMO)) goto 3050
  370.               meleme = imamod
  371.               IA = ICPR(num(1,1))
  372. * en gros ordre du MMODEL
  373.            if (nomdec.eq.'ALFA    '.or.nomdec.eq.'BETA    ') then
  374.               if (indec.eq.1) Q1(ia,2) = velche(1,1)
  375.               if (indec.gt.1) Q1(ia,1) = velche(1,1)
  376.               q1(ia,3) = q1(ia,2)
  377.            endif
  378.            if (nomdec.eq.'VALF    '.or.nomdec.eq.'VBET    ') then
  379.               if (indec.eq.1) Q2(ia,2) = velche(1,1)
  380.               if (indec.gt.1) Q2(ia,1) = velche(1,1)
  381.               q2(ia,3) = q2(ia,2)
  382.            endif
  383.            if (nomdec.eq.'FALF    '.or.nomdec.eq.'FBET    ') then
  384.               if (indec.gt.1) then
  385.                 Q3(ia,2) = velche(1,1)
  386.               endif
  387.            endif
  388.            if (nomdec.eq.'FREQ    ') then
  389.              OMEGA = velche(1,1) * 2.d0* xpi
  390.              xk(ia,1) = xk(ia,1) * omega * omega
  391.            endif
  392.            if (nomdec.eq.'MASS    ') then
  393.              xm(ia,1) = velche(1,1)
  394.              xk(ia,1) = velche(1,1) * xk(ia,1)
  395.            endif
  396.            if (nomdec.eq.'AMOR    ') then
  397.              xasm(ia,1) = velche(1,1)
  398.            endif
  399.            goto 3009
  400.  3050       continue
  401.  3009        continue
  402. ***           segdes melval
  403.  
  404.  3010 continue
  405.          segsup icpr
  406.  
  407.  5001    continue
  408.  
  409. *  (kich : traitement sur base modale-stat pour l instant)
  410. *
  411.          ipmodz = itbmod
  412.          call ecrcha('MAIL')
  413.          call ecrobj('MMODEL',ipmodz)
  414.          call extrai
  415.          call lirobj('MAILLAGE',ipt1,0,iret)
  416.          itmail = ipt1
  417.          if (ierr.ne.0) return
  418.          if (iret.ne.1) then
  419.           write(6,*) 'pb developpement comalo'
  420.           ierr = 2
  421.           return
  422.          endif
  423.          segact ipt1
  424.          segini mcpr
  425.          do ie = 1,ipt1.num(/2)
  426.           mcpr(ipt1.num(1,ie)) = 1
  427.          enddo
  428.  
  429.          mmodel = itlia
  430.          segact mmodel
  431.          n1 = kmodel(/1)
  432.          segini mmode1,mmode2
  433.          klia = 0
  434.          klib = 0
  435.          do ik = 1,kmodel(/1)
  436.            imodel = kmodel(ik)
  437. * liaisons issues de DYNE
  438.            segact imodel
  439.            meleme = imamod
  440.            if (imatee.lt.23) then
  441.            segact meleme
  442.  
  443.            if (mcpr(num(1,1)).gt.0) then
  444.              klia = klia + 1
  445.              mmode1.kmodel(klia) = imodel
  446.            else
  447.              klib = klib + 1
  448.              mmode2.kmodel(klib) = imodel
  449.            endif
  450.  
  451.            endif
  452.          enddo
  453.          nliady = klia+klib
  454.          n1 = klia
  455.          itla = mmode1
  456.          segadj mmode1
  457.          n1 = klib
  458.          segadj mmode2
  459.          itlb = mmode2
  460.          segsup mcpr
  461.          segini moliai
  462.          modtla = itla
  463.          if (klia.eq.0) modtla = 0
  464.          modtlb = itlb
  465.          if (klib.eq.0) modtlb = 0
  466. * distingue liaisons A et B
  467.          IMOLIA = MOLIAI
  468.          molia = moliai
  469.  
  470. * recense variables internes de continuation, rustique !
  471.          if (kovare.eq.kovaen.and.kovare.eq.klia + klib) then
  472.            segsup wrktvu
  473.            return
  474.          endif
  475.  
  476. *
  477. * dimensionnement MTPHI : repere les deformees modales
  478.        wrktvu =iptvu
  479.  
  480.        segini icma,icnna2
  481.        MMODEL = itbmod
  482.        segact MMODEL
  483.        kstru = 0
  484.        kdefo = 0
  485.        do 50 im = 1,kmodel(/1)
  486.          imodel = kmodel(im)
  487.          segact imodel*nomod
  488.           meleme = imamod
  489.           segact meleme
  490. ** recherche sommaire nombre de sous-structures independantes (NSB)
  491. ** nombre maxi de modes pour une meme sous-structure (NA2)
  492.         do 46 in = 1,jtvu(/1)
  493.           if (jtvu(in).ne.302.and.jtvu(in).ne.303) goto 46
  494.           deche = lilmel(in)
  495.           if (condec(1:16).ne.conmod(1:16).or.imamod.ne.imadec) goto 46
  496.  
  497. * assume point support reduit a 1 point
  498.             if (nomdec(1:4).eq.'CGRA') then
  499. * recherche corps rigide
  500.               if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3
  501.               if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6
  502.               melval = ABS(ieldec)
  503. **            segact melval
  504.               icdg = ielche(1,1)
  505.               lcgra(im) = icdg
  506. **            segdes melval
  507.             else if (nomdec(1:4).eq.'DEFO') then
  508.               melval = ABS(ieldec)
  509. **            segact melval
  510. * assume que le maillage modele  se reduit au point support
  511.               icdef1 = ielche(1,1)
  512. **            segdes melval
  513.               call ecrcha('NOMU')
  514.               call ecrcha('MAIL')
  515.               call ecrobj('CHPOINT ',icdef1)
  516.               call extrai
  517.               call lirobj('MAILLAGE', icmaio,1,iret)
  518.               if (ierr.ne.0) return
  519.               if (kstru.eq.0)  goto 44
  520.  
  521.                 ipt5 = icmaio
  522.                 do ic = 1,kstru
  523.                   icmic = icma(ic)
  524.                   CALL INTERB(icmaio,icmic,IRETIB,icinte)
  525.                   if (iretib.eq.0) then
  526.                      ipt6 = icinte
  527.                      segact ipt6,ipt5
  528.                      if (ipt5.num(/2).eq.ipt6.num(/2)) then
  529.                        segsup ipt6
  530.                        icnna2(ic) = icnna2(ic) + 1
  531.                        lsstru(im) = ic
  532.                        goto 45
  533.                      endif
  534.                      segsup ipt6
  535.                   endif
  536.                 enddo
  537.  44            continue
  538.                 kstru = kstru + 1
  539.                 icma(**) = icmaio
  540.                 icnna2(**) = 1
  541.                 lsstru(im) = kstru
  542.  45            continue
  543.             do ism = 1,im
  544.              if (icdef1.ne.0.and.icdef1.eq.ldefo(ism)) then
  545. c        write(6,*) 'deformee ',icdef1,'utilisee autre support', ism,im
  546.             call erreur(26)
  547.              return
  548.              endif
  549.             enddo
  550.             ldefo(im) = icdef1
  551.             kdefo = kdefo + 1
  552.               goto 46
  553.             endif
  554.  46     continue
  555.             if (ldefo(im).eq.0) then
  556. c               write(6,*) 'manque deformee modale pour support', imamod
  557.                call erreur(26)
  558.                return
  559.             endif
  560.  
  561.   47     continue
  562.  49      continue
  563.  50      continue
  564.             NSB = icma(/1)
  565.             NA2 = icnna2(1)
  566.             do ic = 1,icnna2(/1)
  567.              na2 = MAX(icnna2(ic),NA2)
  568.             enddo
  569.             nsstru = kstru
  570.             nndefo = kdefo
  571.             if (nndefo.ne.nmost) then
  572.                 call erreur(26)
  573.                 return
  574.             endif
  575.          if (nsstru.ne.nsb) then
  576.                 call erreur(26)
  577.                 return
  578.             endif
  579.             segsup icma,icnna2
  580.          segsup wrktvu
  581. *
  582.       RETURN
  583.       END
  584.  
  585.  
  586.  
  587.  
  588.  
  589.  
  590.  
  591.  
  592.  
  593.  
  594.  
  595.  
  596.  
  597.  
  598.  

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