Télécharger la plaquette Cast3M


fr en

Télécharger coml10.eso

Retour à la liste

Numérotation des lignes : 

coml10

  1. C COML10    SOURCE    CB215821  20/11/25    13:21:49     10792          
  2.  
  3.       SUBROUTINE COML10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC CCGEOME
  12. -INC CCHAMP
  13. * segment deroulant le mcheml
  14. -INC DECHE
  15. -INC SMCHPOI
  16. -INC SMELEME
  17. -INC SMLENTI
  18. -INC SMLREEL
  19. *-------------------------------------------------------------
  20. * CF DEVPAS et autres s-p de DYNE
  21. ** calcul des vitesses correct pour dernière liaison (JLIAIB.eq.NLIADY)
  22. *-------------------------------------------------------------
  23.  
  24. ** segment sous-structures dynamiques
  25.       segment struli
  26.        integer itlia,itbmod,momoda, mostat,itmail,molia
  27.        integer ldefo(np1),lcgra(np1),lsstru(np1)
  28.        integer nsstru,nndefo,nliab,nsb,na2,idimb
  29.        integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas
  30.        INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib
  31. * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0)
  32.        INTEGER ICHAIN
  33.       endsegment
  34. *
  35. *     Segment contenant les variables au cours d'un pas de temps:
  36. *
  37.       SEGMENT,MTPAS
  38.          REAL*8 FTOTA(NA1,4),FTOTB(NPLB,IDIMB),FTOTBA(NA1)
  39.          REAL*8 XPTB(NPLB,2,IDIMB),FINERT(NA1,4)
  40.          REAL*8 XVALA(NLIAA,4,NTVAR),XVALB(NLIAB,4,NTVAR)
  41.          REAL*8 FEXB(NPLB,2,IDIM),XCHPFB(2,NLIAB,4,NPLB)
  42.       ENDSEGMENT
  43. *
  44.       SEGMENT,MTKAM
  45.          REAL*8 XK(NA1,NB1K),XASM(NA1,NB1C),XM(NA1,NB1M)
  46.          REAL*8 XOPER(NB1,NB1,NOPER)
  47.       ENDSEGMENT
  48. *
  49.       SEGMENT,MTQ
  50.          REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4)
  51.          REAL*8 WEXT(NA1,2),WINT(NA1,2)
  52.       ENDSEGMENT
  53. *
  54.       SEGMENT MTLIAB
  55.          INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  56.          REAL*8 XPALB(NLIAB,NXPALB)
  57.          REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  58.       ENDSEGMENT
  59. *
  60.       SEGMENT,MTLIAA
  61.          INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA)
  62.          REAL*8  XPALA(NLIAA,NXPALA)
  63.       ENDSEGMENT
  64. *
  65.       SEGMENT,MTPHI
  66.          INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB)
  67.          INTEGER IAROTA(NSB)
  68.          REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB)
  69.       ENDSEGMENT
  70.  
  71.       SEGMENT,MTRES
  72.          REAL*8 XRES(NRES,NCRES,NPRES),XREP(NREP,NCRES)
  73.          REAL*8 XRESLA(NLSA,NPRES,NVALA),XRESLB(NLSB,NPRES,NVALB)
  74.          REAL*8 XMREP(NLIAB,4,IDIMB)
  75.          INTEGER ICHRES(NVES),IPORES(NRESPO,NPRES),IPOREP(NREP)
  76.          INTEGER ILIRES(NRESLI,NCRES)
  77.          INTEGER IPOLA(NLSA),INULA(NLSA),IPLRLA(NLSA,NVALA)
  78.          INTEGER IPOLB(NLSB),INULB(NLSB),IPLRLB(NLSB,NVALB)
  79.          INTEGER ILIREA(NLSA,NTVAR),ILIREB(NLSB,NTVAR)
  80.          INTEGER ILIRNA(NLSA,NTVAR),ILIRNB(NLSB,NTVAR)
  81.          INTEGER IPOLR(1),IMREP(NLIAB,2),IPPREP(NLIAB,4)
  82.          INTEGER ILPOLA(NLIAA,2)
  83.       ENDSEGMENT
  84.  
  85.       SEGMENT,MPREF
  86.          INTEGER IPOREF(NPREF)
  87.       ENDSEGMENT
  88. *
  89.       SEGMENT,MTFEX
  90.          REAL*8  FEXA(NPFEXA,NPC1,2)
  91.          REAL*8  FEXPSM(NPLB,NPC1,2,IDIMB)
  92.          REAL*8  FTEXB(NPLB,NPC1,2,IDIM)
  93. *         INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB)
  94.       ENDSEGMENT
  95.       SEGMENT,MTNUM
  96.          REAL*8 XDT(NPC1),XTEMPS(NPC1)
  97.       ENDSEGMENT
  98. c Segment "local" pour DEVLFA ...
  99.       SEGMENT,LOCLFA
  100.          REAL*8 FTEST(NA1,4)
  101.       ENDSEGMENT
  102. * Segment "local" pour DEVLB1 ...
  103.       SEGMENT,LOCLB1
  104.          REAL*8 FTEST2(NPLB,6)
  105.       ENDSEGMENT
  106.  
  107. * Segment pour Champoints
  108.       SEGMENT,MSAM
  109.          integer jplibb(NPLB)
  110.       ENDSEGMENT
  111. *
  112.       SEGMENT,ICPR(nbpts)
  113. *
  114.       PARAMETER ( ZERO=0.D0 )
  115.       LOGICAL RIGIDE,REPRIS,LMODYN
  116. *
  117.       IERRD = 0
  118.  
  119.       struli = itruli
  120.       lmodyn = .true.
  121.       MTKAM = ktkam
  122.       MPREF = KPREF
  123.       NPREF = iporef(/1)
  124.       rigide = .false.
  125.  
  126. *     npc1 = 1   plante dans devso4 : pv
  127.       npc1 = 2
  128.       SEGINI,MTNUM
  129.       KTNUM = MTNUM
  130.       xdt(1) = tempf - temp0
  131.       xtemps(1) = temp0
  132.  
  133.       IF (var0(3).gt.0.and.var0(4).gt.0) THEN
  134. *--------------------------------------------------------------------*
  135. * suite d un calcul avec variables internes de preconditionnement
  136. * VAEN , VARE, pour  modeles liaisons herites de DYNE de_vogelaere
  137. *--------------------------------------------------------------------*
  138. *      its2 = int(var0(2))
  139.       mlreel = int(var0(4))
  140.       segact mlreel
  141.       mlenti = int(var0(3))
  142.       segact mlenti
  143.       itmail = int(var0(5))
  144.       jjr = 0
  145.       jje = 0
  146.  
  147.       jje = jje + 1
  148.        JLIAIB  = lect(jje)
  149.  
  150.       jje = jje + 1
  151.        nchain = lect(jje)
  152.        if (ichain.eq.0) then
  153.          jg = nchain
  154.          segini,mlent3
  155.          ichain = mlent3
  156.        else
  157.          mlent3 = ichain
  158.          jg = mlent3.lect(/1)
  159.          if (nchain.ne.jg) then
  160.            write(6,*) 'pb developpement coml10'
  161.            ierr = 2
  162.            return
  163.          endif
  164.        endif
  165.       do lg = 1,nchain
  166.        jje = jje + 1
  167.        if (JLIAIB.eq.1) mlent3.lect(lg)= lect(jje)
  168.       enddo
  169.        jje = jje + 1
  170.        NPAS = lect(jje)
  171.       jje = jje + 1
  172.        NIPALB = lect(jje)
  173.       jje = jje + 1
  174.        NXPALB = lect(jje)
  175.       jje = jje + 1
  176.        NPLBB  = lect(jje)
  177.       jje = jje + 1
  178.        NPLB = lect(jje)
  179.       jje = jje + 1
  180.        NPLSB = lect(jje)
  181.       jje = jje + 1
  182.        NIP = lect(jje)
  183.       jje = jje + 1
  184.       nsstru = lect(jje)
  185.       jje = jje + 1
  186.       nndefo = lect(jje)
  187.       MTQ = KTQ
  188.            NA1 = q1(/1)
  189.       jje = jje + 1
  190.       nliab = lect(jje)
  191.       jje = jje + 1
  192.       nsb  = lect(jje)
  193.       jje = jje + 1
  194.       na2 = lect(jje)
  195.       jje = jje + 1
  196.       idimb = lect(jje)
  197.       jje = jje + 1
  198.       NTVAR = lect(jje)
  199.       jje = jje + 1
  200.        NLIAA = lect(jje)
  201.       jje = jje + 1
  202.        NRES = lect(jje)
  203.       jje = jje + 1
  204.        NCRES = lect(jje)
  205.       jje = jje + 1
  206.        NPRES  = lect(jje)
  207.       jje = jje + 1
  208.        NREP = lect(jje)
  209.       jje = jje + 1
  210.        NLSA  = lect(jje)
  211.       jje = jje + 1
  212.        NVALA  = lect(jje)
  213.       jje = jje + 1
  214.        NLSB  = lect(jje)
  215.       jje = jje + 1
  216.        NVALB = lect(jje)
  217.       jje = jje + 1
  218.        NVES  = lect(jje)
  219.       jje = jje + 1
  220.        i2MAX  = lect(jje)
  221.  
  222. *     seulement sortie chpoint pour pasapas 
  223. *     (et pas de listreel comme dans dyne)
  224.       NRESPO=NRES
  225.       NRESLI=0
  226.  
  227.       NPRES = 1
  228.       segini MTRES
  229.  
  230. * MTRES
  231.       do lg1 = 1,NVES
  232.         jje = jje + 1
  233.         ichres(lg1) = lect(jje)
  234.       enddo
  235.       do lg1 = 1,NLSA
  236.         jje = jje + 1
  237.          ipola(lg1) = lect(jje)
  238.       enddo
  239.       do lg1 = 1,NLSA
  240.         jje = jje + 1
  241.         inula(lg1) = lect(jje)
  242.       enddo
  243.       do lg1 = 1,NLSB
  244.         jje = jje + 1
  245.         ipolb(lg1) = lect(jje)
  246.       enddo
  247.       do lg1 = 1,NLSB
  248.         jje = jje + 1
  249.         inulb(lg1) = lect(jje)
  250.       enddo
  251.       do lg1 = 1,nlsa
  252.         do lg2 = 1,ntvar
  253.          jje = jje + 1
  254.          ilirea(lg1,lg2) = lect(jje)
  255.         enddo
  256.       enddo
  257.       do lg1 = 1,nlsa
  258.         do lg2 = 1,ntvar
  259.          jje = jje + 1
  260.          ilirna(lg1,lg2) = lect(jje)
  261.         enddo
  262.       enddo
  263.       do lg1 = 1,nlsb
  264.         do lg2 = 1,ntvar
  265.          jje = jje + 1
  266.          ilireb(lg1,lg2) = lect(jje)
  267.         enddo
  268.       enddo
  269.       do lg1 = 1,nlsb
  270.         do lg2 = 1,ntvar
  271.          jje = jje + 1
  272.          ilirnb(lg1,lg2) = lect(jje)
  273.         enddo
  274.       enddo
  275.       do lg1 = 1,nliaa
  276.         do lg2 = 1,2
  277.          jje = jje + 1
  278.          ilpola(lg1,lg2) = lect(jje)
  279.         enddo
  280.       enddo
  281.  
  282. * MTPAS
  283.       if (JLIAIB.eq.1) then
  284.        segini MTPAS
  285.        ktpas = mtpas
  286.       else
  287.        mtpas = ktpas
  288.       endif
  289.       do lu1 = 1,nplb
  290. cbp,2020-09       do lu2 = 1, 4
  291.        do lu2 = 1, 2
  292.         do lu3 = 1,idimb
  293.          jjr = jjr + 1
  294.           xptb(lu1,lu2,lu3) = prog(jjr)
  295.         enddo
  296.        enddo
  297.       enddo
  298.       do lu1 = 1,na1
  299.         do lu2 = 1,4
  300.          jjr = jjr + 1
  301.           finert(lu1,lu2) = prog(jjr)
  302.         enddo
  303.       enddo
  304.       do lu1 = 1,nliaa
  305.        do lu2 = 1, 4
  306.         do lu3 = 1,ntvar
  307.          jjr = jjr + 1
  308.          xvala(lu1,lu2,lu3) = prog(jjr)
  309.         enddo
  310.        enddo
  311.       enddo
  312.       do lu1 = 1,nliab
  313.        do lu2 = 1, 4
  314.         do lu3 = 1,ntvar
  315.          jjr = jjr + 1
  316.          xvalb(lu1,lu2,lu3) = prog(jjr)
  317.         enddo
  318.        enddo
  319.       enddo
  320.       do lu1 = 1,nplb
  321.        do lu2 = 1, 2
  322.         do lu3 = 1,idim
  323.          jjr = jjr + 1
  324.          fexb(lu1,lu2,lu3) = prog(jjr)
  325.         enddo
  326.        enddo
  327.       enddo
  328.       do lu1 = 1,2
  329.        do lu2 = 1, nliab
  330.         do lu3 = 1,4
  331.          do lu4 = 1,nplb
  332.          jjr = jjr + 1
  333.           XCHPFB(lu1,lu2,lu3,lu4) = prog(jjr)
  334.          enddo
  335.         enddo
  336.        enddo
  337.       enddo
  338.       do lu1 = 1,na1
  339.          jjr = jjr + 1
  340.           ftota(lu1,3) = prog(jjr)
  341.          jjr = jjr + 1
  342.           ftota(lu1,4) = prog(jjr)
  343.       enddo
  344. * MTQ
  345.       MTQ = KTQ
  346.       do lu1 = 1,na1
  347.         do lu2 = 1,2
  348.          jjr = jjr + 1
  349.          wext(lu1,lu2) = prog(jjr)
  350.         enddo
  351.       enddo
  352.       do lu1 = 1,na1
  353.         do lu2 = 1,2
  354.          jjr = jjr + 1
  355.           wint(lu1,lu2) = prog(jjr)
  356.         enddo
  357.       enddo
  358. * MTLIAB
  359.       segini MTLIAB
  360.       do lu1 = 1,nliab
  361.         do lu2 = 1,nxpalb
  362.          jjr = jjr + 1
  363.          xpalb(lu1,lu2) = prog(jjr)
  364.         enddo
  365.       enddo
  366.       do lu1 = 1,nliab
  367.         do lu2 = 1,nip
  368.          jjr = jjr + 1
  369.          xabsci(lu1,lu2) = prog(jjr)
  370.         enddo
  371.       enddo
  372.       do lu1 = 1,nliab
  373.         do lu2 = 1,nip
  374.          jjr = jjr + 1
  375.           xordon(lu1,lu2) = prog(jjr)
  376.         enddo
  377.       enddo
  378.       do lg1 = 1,nliab
  379.         do lg2 = 1,nipalb
  380.          jje = jje + 1
  381.          ipalb(lg1,lg2) = lect(jje)
  382.         enddo
  383.       enddo
  384.       do lg1 = 1,nliab
  385.         do lg2 = 1,nplbb
  386.          jje = jje + 1
  387.          iplib(lg1,lg2) = lect(jje)
  388.         enddo
  389.       enddo
  390.       do lg1=1,nplb
  391.          jje = jje + 1
  392.           jplib(lg1) = lect(jje)
  393.       enddo
  394. cbp   cas particulier ou IPALB contient un listreel a activer (palier)
  395.       do lg1 = 1,nliab
  396.         if(ipalb(lg1,1).eq.60) then
  397.           if(ipalb(lg1,5).eq.1) then
  398.             nlob=ipalb(lg1,6)
  399.             do ilob=1,nlob
  400.               mlree1=ipalb(lg1,7+ilob)
  401.               segact,mlree1
  402.             enddo
  403.           else
  404.               mlree1=ipalb(lg1,7)
  405.               segact,mlree1
  406.           endif
  407.         endif      
  408.       enddo
  409. cbp   fin du cas particulier ou IPALB contient un listreel a activer
  410.  
  411. * MTPHI
  412.       segini MTPHI
  413.       do lu1 = 1,nsb
  414.        do lu2 = 1,nplsb
  415.         do lu3 = 1,na2
  416.          do lu4 = 1,idimb
  417.          jjr = jjr + 1
  418.           xphilb(lu1,lu2,lu3,lu4) = prog(jjr)
  419.          enddo
  420.         enddo
  421.        enddo
  422.       enddo
  423.       do lg1=1,nplb
  424.          jje = jje + 1
  425.          ibasb(lg1) = lect(jje)
  426.       enddo
  427.       do lg1=1,nplb
  428.          jje = jje + 1
  429.          iplsb(lg1) = lect(jje)
  430.       enddo
  431.       do lg1=1,nsb
  432.          jje = jje + 1
  433.          inmsb(lg1) = lect(jje)
  434.       enddo
  435.       do lg1=1,nsb
  436.          jje = jje + 1
  437.          iorsb(lg1) = lect(jje)
  438.       enddo
  439.       do lg1=1,nsb
  440.          jje = jje + 1
  441.          iarota(lg1) = lect(jje)
  442.       enddo
  443. * MTFEX
  444.       NPFEXA = q1(/1)
  445.       NPFEXB = 0
  446.       segini MTFEX
  447.       do lu1 = 1,nplb
  448.        do lu2 = 1,npc1
  449.         do lu3 = 1,2
  450.          do lu4 = 1,idimb
  451.          jjr = jjr + 1
  452.          fexpsm(lu1,lu2,lu3,lu4) = prog(jjr)
  453.          enddo
  454.         enddo
  455.        enddo
  456.       enddo
  457.       do lu1 = 1,npfexa
  458.          jjr = jjr + 1
  459.          fexa(lu1,1,1) = prog(jjr)
  460.       enddo
  461. * LOCLFA
  462.        segini loclfa
  463. c      do lu1 = 1,na1
  464. c        do lu2 = 1,4
  465. c         jjr = jjr + 1
  466. c         prog(jjr) = ftest(lu1,lu2)
  467. c        enddo
  468. c      enddo
  469. c      do lu1 = 1,na1
  470. c        do lu2 = 1,4
  471. c         jjr = jjr + 1
  472. c         prog(jjr) = ftota0(lu1,lu2)
  473. c        enddo
  474. c      enddo
  475. *LOCLB1
  476.       segini loclb1
  477.       do lu1 = 1,nplb
  478.         do lu2 = 1,6
  479.          jjr = jjr + 1
  480.           ftest2(lu1,lu2) = prog(jjr)
  481.         enddo
  482.       enddo
  483.  
  484.       KTRES = MTRES
  485.       KPREF = MPREF
  486.       SEGINI,MSAM
  487.       KSAM=MSAM
  488.       DO 100 IP=1,NPLB
  489.          JPLIBB(IP)=JPLIB(IP)
  490.  100  CONTINUE
  491.       itkm = 0
  492.       jtmail = itmail
  493.       JTRES = KTRES
  494.       JPREF = KPREF
  495.       NLIAA = ilpola(/1)
  496.       NXPALA = 1
  497.       NIPALA=3
  498.       NPLAA = 0
  499.       NPLA = 0
  500.       segini MTLIAA
  501.       ktliaa = mtliaa
  502.       CALL DYNE17(1,ITKM,jtmail,JTRES,JPREF,NPLAA,NXPALA,KSAM,lmodyn)
  503.       IF (IERR.NE.0) RETURN
  504.       MSAM=KSAM
  505.       SEGSUP,MSAM
  506.  
  507.       ELSE
  508. * 1er pas
  509.  
  510.       i2MAX = 0
  511.       MTQ = ktq
  512.       MTPHI  = ktphi
  513.       do istru=1,nsstru
  514.        if(iarota(istru).ne.0) rigide = .true.
  515.       enddo
  516.       MTLIAB = ktliab
  517. c      NSB = XPHILB(/1)
  518.       NPLSB = XPHILB(/2)
  519. c      NA2 =  XPHILB(/3)
  520. c      IDIMB = XPHILB(/4)
  521. c      NPLB = JPLIB(/1)
  522.       NA1 = nndefo
  523.       segini loclfa
  524.       KOCLFA = loclfa
  525.       segini loclb1
  526.       KOCLB1 = loclb1
  527.       NPAS = 0
  528.  
  529.        MTRES  = KTRES
  530.        ITINIT = 0
  531.        REPRIS = .false.
  532.       JKCPR = kcpr
  533.       NLIAA = ilpola(/1)
  534.       NXPALA = 1
  535.       NIPALA=3
  536.       NPLAA = 0
  537.       NPLA = 0
  538.       segini MTLIAA
  539.       ktliaa = mtliaa
  540. * voir comalo
  541.       NTVAR  = 6 + 4 * IDIM
  542. *      segini mtpas
  543.       if (JLIAIB.eq.1) then
  544.        segini MTPAS
  545.        ktpas = mtpas
  546.       else
  547.        mtpas = ktpas
  548.       endif
  549.       JKTPAS = ktpas
  550.       NPFEXA = q1(/1)
  551.       NPFEXB = 0
  552.       SEGINI MTFEX
  553.       KTFEX = MTFEX
  554.       JKTLIAB = ktliab
  555.       JKTQ = ktq
  556.       JKTPHI = ktphi
  557.       JKTKAM = KTKAM
  558. * kich : permet d'initialiser mais inexact
  559.       CALL DEVINI(ITINIT,JKTKAM,JKTQ,KTFEX,JKTPAS,KTNUM,KTLIAA,JKTLIAB,
  560.      &            JKTPHI,JKCPR,KOCLFA,KOCLB1,REPRIS,RIGIDE,lmodyn)
  561.  
  562. *       segsup mtfex
  563.       ENDIF
  564.  
  565.       IVINIT = 0
  566. *      SEGINI MTFEX
  567.       KTFEX = MTFEX
  568.  
  569.       nliady = nliab + nliaa
  570.  
  571. c      NLIAB = IPALB(/1)
  572.  
  573.       NPAS = NPAS + 1
  574.       NPASF = 1
  575.  
  576.       do istru=1,nsstru
  577.        if(iarota(istru).ne.0) rigide = .true.
  578.       enddo
  579.  
  580. c calculs en 2 demi-pas Runge-Kutta/ initialisation pour 1ere liaison
  581.       do kna =1,na1
  582.         IF(JLIAIB.eq.1) THEN
  583. *voir devfxa
  584. *       fexa(kna,1,1) = q3(kna,2)
  585.  
  586. *       q1(kna,3) = q1(kna,2)
  587.        q1(kna,2) = (q1(kna,1) + q1(kna,2))* 0.5d0
  588. *       q2(kna,3) = q2(kna,2)
  589.        ftota(kna,2) = q3(kna,2)
  590.        ftota(kna,1) = q3(kna,2)
  591.         ENDIF
  592.  
  593.        q2(kna,1) = 0.d0
  594.        q2(kna,2) = 0.d0
  595.       enddo
  596.  
  597. ** voir devpas.eso
  598.       DO III = 2,1,-1
  599.  
  600.        PDT=XDT(npasf)
  601.        T=XTEMPS(npasf)
  602.  
  603. **     Ajout des forces de raideur avant demi-pas
  604.         IF(JLIAIB.eq.1) THEN
  605.       CALL DEVLK0(Q1,XK,FTOTA,NA1,1,III)
  606.         ENDIF
  607. *
  608. *     estimation de la vitesse (ici plutot que dans DEVLF*, bp,2020-09):
  609. *     on espere que cela est coherent ici ...?
  610. *     \dot{q}_1/2 ~ ({q}_1/2 - {q}_0  ) / dt/2
  611. *     \dot{q}_1   ~ ({q}_1   - {q}_1/2) / dt/2
  612.       DO I=1,NA1
  613.         Q2(I,III)=(Q1(I,III)-Q1(I,III+1))*2./PDT
  614.       ENDDO
  615.  
  616. * forces liaisons base A (modes)
  617.  
  618.       IF (NLIAA.NE.0) THEN
  619.          CALL DEVLFA(Q1,Q2,FTOTA,NA1,IPALA,IPLIA,XPALA,XVALA,
  620.      &               NLIAA,PDT,T,npasf,III,FINERT,IVINIT,FTEST)
  621.       ENDIF
  622. *
  623. *
  624. *     Ajout des forces de liaison base B matérielle
  625. *
  626.       IF (NLIAB.NE.0) THEN
  627.          CALL DEVLFB(Q1,Q2,FTOTA,NA1,IPALB,IPLIB,XPALB,XVALB,NLIAB,
  628.      &               XPHILB,JPLIB,NPLB,IDIMB,FTOTB,FTOTBA,XPTB,PDT,T,
  629.      &               npasf,IBASB,IPLSB,INMSB,IORSB,NSB,NPLSB,NA2,III,
  630.      &               FEXPSM,NPC1,IERRD,FTEST2,
  631.      &               XABSCI,XORDON,NIP,FEXB,RIGIDE,IAROTA,XCHPFB)
  632.          IF (IERRD.NE.0) RETURN
  633.       ENDIF
  634.           IF(JLIAIB.eq.nliady) THEN
  635.       if (III.eq.2) then
  636.         if (npas.eq.1) then
  637.          do jj = 1,na1
  638.           ftota(jj,3) = ftota(jj,2)
  639.          enddo
  640.         endif
  641.         CALL DEVEQ2(Q2,NA1,XASM,XM,PDT,npasf,FTOTA,FINERT)
  642.        else
  643.         CALL DEVEQ4(Q2,NA1,XASM,XM,PDT,npasf,FTOTA,FINERT)
  644.        endif
  645.          ENDIF
  646.  
  647.       ENDDO
  648.  
  649. *         CALL DYNE16(Q1,Q2,Q3,NA1,FTOTA,XPTB,NPLB,IDIMB,FINERT)
  650.        DO 10 I=1,NA1
  651.          FINERT(I,3) = FINERT(I,1)
  652.          FINERT(I,4) = FINERT(I,2)
  653.          FTOTA(I,3) = FTOTA(I,1)
  654.          FTOTA(I,4) = FTOTA(I,2)
  655.  10     CONTINUE
  656. cbp,2020-09       DO 20 IP = 1,NPLB
  657. cbp,2020-09         DO 22 ID = 1,IDIMB
  658. cbp,2020-09            XPTB(IP,3,ID) = XPTB(IP,1,ID)
  659. cbp,2020-09            XPTB(IP,4,ID) = XPTB(IP,2,ID)
  660. cbp,2020-09 22         CONTINUE
  661. cbp,2020-09 20     CONTINUE
  662. *
  663. * calcul des travaux
  664. * fin devpas.eso
  665.  
  666. *
  667. * production chpoint forces base A (devso2)
  668. *
  669.          meleme = itmail
  670.          segact meleme
  671.          if (lisous(/1).eq.0) then
  672.           ipmmod = itmail
  673.           ipmsta = 0
  674.          else
  675.           ipmmod = lisous(1)
  676.           ipmsta = lisous(2)
  677.          endif
  678.  
  679.          NSOUPO = 1
  680.          if(ipmmod.gt.0.and.ipmsta.gt.0) nsoupo = 2
  681.          NAT=1
  682.          SEGINI,MCHPOI
  683.          IPCHPO = MCHPOI
  684.          MTYPOI = 'FLIAISONS'
  685.          IFOPOI = IFOUR
  686. *          nature  diffuse
  687.          JATTRI(1) = 1
  688.        nmost0 = 0
  689.        KIPCHP = 0
  690.  
  691.        icoe1 = 1
  692.        ymaxf = 0.d0
  693.        if (CMATE.eq.'PO_CE_MO') then
  694.         if (i2max.ne.0) then
  695.          if (FTOTBA(abs(i2max))*i2max.lt.0.d0) icoe1 = -1
  696.         endif
  697.        endif
  698.  
  699.        if (ipmmod.gt.0) then
  700.         NC = 1
  701.         IF(JLIAIB.eq.nliady)   NC = 2
  702.          SEGINI,MSOUPO
  703.          KIPCHP = KIPCHP + 1
  704.          IPCHP(KIPCHP)  = MSOUPO
  705.          NOCOMP(1) = 'FALF'
  706.          NOHARM(1) = NIFOUR
  707.         if (NC.eq.2) then
  708.          NOCOMP(2) = NOCOMP(1)
  709.          NOCOMP(2)(1:1) = 'V'
  710.          NOHARM(2) = NIFOUR
  711.         endif
  712.          IGEOC = ipmmod
  713.          ipt1 = ipmmod
  714.          segact ipt1
  715.          N = ipt1.num(/2)
  716.          nmost0 = N
  717.          SEGINI,MPOVAL
  718.          IPOVAL = MPOVAL
  719. *
  720.          do ii = 1,N
  721.           if (i2max.eq.0) then
  722.            if (abs(FTOTBA(ii)).gt.ymaxf) then
  723.             ymaxf = abs(FTOTBA(ii))
  724.             i2max = ii
  725.             if (FTOTBA(ii).lt.0.d0) i2max = -i2max
  726.            endif
  727.           endif
  728.           vpocha(ii,1) = -icoe1*FTOTBA(ii)
  729.           if (NC.eq.2) vpocha(ii,2) = q2(ii,1)
  730.          enddo
  731.  
  732.          SEGDES,MPOVAL,MSOUPO
  733.        endif
  734.  
  735. *kich : extension a tout hasard
  736.        if (ipmsta.gt.0) then
  737.         NC = 1
  738.         IF(JLIAIB.eq.nliady)   NC = 2
  739.          SEGINI,MSOUPO
  740.          KIPCHP = KIPCHP + 1
  741.          IPCHP(KIPCHP)  = MSOUPO
  742.          NOCOMP(1) = 'FBET'
  743.          NOHARM(1) = NIFOUR
  744.         if (NC.eq.2) then
  745.          NOCOMP(2) = NOCOMP(1)
  746.          NOCOMP(2)(1:1) = 'V'
  747.          NOHARM(2) = NIFOUR
  748.         endif
  749.          IGEOC = ipmsta
  750.          ipt1 = ipmsta
  751.          segact ipt1
  752.          N = ipt1.num(/2)
  753.          SEGINI,MPOVAL
  754.          IPOVAL = MPOVAL
  755. *
  756.          do ii = 1,N
  757.           vpocha(ii,1) = -icoe1*FTOTBA(ii + nmost0)
  758.           if (NC.eq.2) vpocha(ii,2) = q2(ii,1)
  759.          enddo
  760.  
  761.          SEGDES,MPOVAL,MSOUPO
  762.        endif
  763.  
  764.       segdes MCHPOI
  765.       varf(1) = IPCHPO
  766.        MTRES  = KTRES
  767. *
  768.        NINS = 1
  769.       NRES   = XRES(/1)
  770.       NCRES  = XRES(/2)
  771.       NPRES  = XRES(/3)
  772.       NREP   = XREP(/1)
  773.       NLSA   = XRESLA(/1)
  774.       NLSB   = XRESLB(/1)
  775.       NVES = ICHRES(/1)
  776.       NVALA =  IPLRLA(/2)
  777.       NVALB =  IPLRLB(/2)
  778. *
  779.          if (npas.eq.1) then
  780.           iins2 = 2
  781.          else
  782.           iins2 = 1
  783.          endif
  784. * range les resultats de la bonne liaison
  785.         if (jliaib.gt.1) then
  786.           do lu3 = 1,ntvar
  787.             xvalb(1,1,lu3)=xvalb(jliaib,1,lu3)
  788.           enddo
  789. *                  DO IP=1,NPLB
  790. *                    DO ID=1,2
  791. *                      II = II + 1
  792. *                      XCHPFB(ID,IIL,1,IP)  = XCHPFB(ID,jliaib,1,IP)
  793. *                    ENDDO
  794. *                   ENDDO
  795.         endif
  796.  
  797. * transit resultat
  798.          CALL DEVTR1(Q1,Q2,Q3,NA1,IINS2,NINS,FTOTA,XRES,ICHRES,NRES,
  799.      &               NCRES,NPRES,XREP,NREP,XVALA,INULA,NLIAA,NLSA,
  800.      &              XRESLA,XVALB,INULB,NLIAB,NLSB,XRESLB,ILIREA,ILIREB,
  801.      &               NTVAR,XPALB,IPALB,XMREP,IMREP,IDIMB,WEXT,WINT,
  802.      &               XCHPFB,NPLB)
  803.  
  804. * sauvegarde pour aller plus vite pas suivant
  805. *
  806.       JG = 1000
  807.       jje = 0
  808.       segini MLENTI
  809.       jje = jje + 1
  810.       lect(jje) = JLIAIB
  811.       nchain = 0
  812.         mlent3 = ichain
  813.         segact mlent3
  814.         nchain = mlent3.lect(/1)
  815.       jje = jje + 1
  816.       lect(jje) = nchain
  817.         do lg = 1,nchain
  818.          jje = jje + 1
  819.          lect(jje)=mlent3.lect(lg)
  820.         enddo
  821.       jje = jje + 1
  822.       lect(jje) = NPAS
  823.       jje = jje + 1
  824.       lect(jje) = NIPALB
  825.       jje = jje + 1
  826.       lect(jje) = NXPALB
  827.       jje = jje + 1
  828.       lect(jje) = NPLBB
  829.       jje = jje + 1
  830.       lect(jje) =  NPLB
  831.       jje = jje + 1
  832.       lect(jje) =  NPLSB
  833.       jje = jje + 1
  834.       lect(jje) = NIP
  835.       jje = jje + 1
  836.       lect(jje) = nsstru
  837.       jje = jje + 1
  838.       lect(jje) = nndefo
  839.       jje = jje + 1
  840.       lect(jje) = nliab
  841.       jje = jje + 1
  842.       lect(jje) = nsb
  843.       jje = jje + 1
  844.       lect(jje) = na2
  845.       jje = jje + 1
  846.       lect(jje) = idimb
  847.       jje = jje + 1
  848.       lect(jje) = NTVAR
  849.       jje = jje + 1
  850.       lect(jje) = NLIAA
  851.       jje = jje + 1
  852.       lect(jje) = NRES
  853.       jje = jje + 1
  854.       lect(jje) = NCRES
  855.       jje = jje + 1
  856.       lect(jje) = NPRES
  857.       jje = jje + 1
  858.       lect(jje) = NREP
  859.       jje = jje + 1
  860.       lect(jje) = NLSA
  861.       jje = jje + 1
  862.       lect(jje) = NVALA
  863.       jje = jje + 1
  864.       lect(jje) = NLSB
  865.       jje = jje + 1
  866.       lect(jje) = NVALB
  867.       jje = jje + 1
  868.       lect(jje) = NVES
  869.       jje = jje + 1
  870.       lect(jje) = i2MAX
  871.  
  872. * MTRES
  873.       do lg1 = 1,NVES
  874.         jje = jje + 1
  875.         lect(jje) = ichres(lg1)
  876.       enddo
  877.       do lg1 = 1,NLSA
  878.         jje = jje + 1
  879.         lect(jje) = ipola(lg1)
  880.       enddo
  881.       do lg1 = 1,NLSA
  882.         jje = jje + 1
  883.         lect(jje) = inula(lg1)
  884.       enddo
  885.       do lg1 = 1,NLSB
  886.         jje = jje + 1
  887.         lect(jje) = ipolb(lg1)
  888.       enddo
  889.       do lg1 = 1,NLSB
  890.         jje = jje + 1
  891.         lect(jje) = inulb(lg1)
  892.       enddo
  893.       do lg1 = 1,nlsa
  894.         do lg2 = 1,ntvar
  895.          jje = jje + 1
  896.          lect(jje)= ilirea(lg1,lg2)
  897.         enddo
  898.       enddo
  899.       do lg1 = 1,nlsa
  900.         do lg2 = 1,ntvar
  901.          jje = jje + 1
  902.          lect(jje)= ilirna(lg1,lg2)
  903.         enddo
  904.       enddo
  905.       do lg1 = 1,nlsb
  906.         do lg2 = 1,ntvar
  907.          jje = jje + 1
  908.          lect(jje)= ilireb(lg1,lg2)
  909.         enddo
  910.       enddo
  911.       do lg1 = 1,nlsb
  912.         do lg2 = 1,ntvar
  913.          jje = jje + 1
  914.          lect(jje)= ilirnb(lg1,lg2)
  915.         enddo
  916.       enddo
  917.       do lg1 = 1,nliaa
  918.         do lg2 = 1,2
  919.          jje = jje + 1
  920.          lect(jje)= ilpola(lg1,lg2)
  921.         enddo
  922.       enddo
  923.  
  924.       JG = (nplb*4*idimb)+(na1*4)+(nliaa*4*ntvar)+(nliab*4*ntvar)+
  925.      &(nplb*2*idim)+(2*nliab*4*nplb)+(2*na1)+(na1*2*2)+
  926.      &(nliab*(nxpalb+nip+nip))+(nsb*na2*nplsb*idimb)+
  927.      &(nplb*npc1*2*idimb)+ npfexa +(nplb*6*2)
  928.       SEGINI MLREEL
  929.       jjr = 0
  930. * MTPAS
  931.       do lu1 = 1,nplb
  932. cbp,2020-09       do lu2 = 1, 4
  933.        do lu2 = 1, 2
  934.         do lu3 = 1,idimb
  935.          jjr = jjr + 1
  936.          prog(jjr) = xptb(lu1,lu2,lu3)
  937.         enddo
  938.        enddo
  939.       enddo
  940.       do lu1 = 1,na1
  941.         do lu2 = 1,4
  942.          jjr = jjr + 1
  943.          prog(jjr) = finert(lu1,lu2)
  944.         enddo
  945.       enddo
  946.       do lu1 = 1,nliaa
  947.        do lu2 = 1, 4
  948.         do lu3 = 1,ntvar
  949.          jjr = jjr + 1
  950.          prog(jjr) = xvala(lu1,lu2,lu3)
  951.         enddo
  952.        enddo
  953.       enddo
  954.       do lu1 = 1,nliab
  955.        do lu2 = 1, 4
  956.         do lu3 = 1,ntvar
  957.          jjr = jjr + 1
  958.          prog(jjr) = xvalb(lu1,lu2,lu3)
  959.         enddo
  960.        enddo
  961.       enddo
  962.       do lu1 = 1,nplb
  963.        do lu2 = 1, 2
  964.         do lu3 = 1,idim
  965.          jjr = jjr + 1
  966.          prog(jjr) = fexb(lu1,lu2,lu3)
  967.         enddo
  968.        enddo
  969.       enddo
  970.       do lu1 = 1,2
  971.        do lu2 = 1, nliab
  972.         do lu3 = 1,4
  973.          do lu4 = 1,nplb
  974.          jjr = jjr + 1
  975.          prog(jjr) = XCHPFB(lu1,lu2,lu3,lu4)
  976.          enddo
  977.         enddo
  978.        enddo
  979.       enddo
  980.       do lu1 = 1,na1
  981.          jjr = jjr + 1
  982.           prog(jjr) = ftota(lu1,3)
  983.          jjr = jjr + 1
  984.           prog(jjr) = ftota(lu1,4)
  985.       enddo
  986. * MTQ
  987.       do lu1 = 1,na1
  988.         do lu2 = 1,2
  989.          jjr = jjr + 1
  990.          prog(jjr) = wext(lu1,lu2)
  991.         enddo
  992.       enddo
  993.       do lu1 = 1,na1
  994.         do lu2 = 1,2
  995.          jjr = jjr + 1
  996.          prog(jjr) = wint(lu1,lu2)
  997.         enddo
  998.       enddo
  999. * MTLIAB
  1000.       do lu1 = 1,nliab
  1001.         do lu2 = 1,nxpalb
  1002.          jjr = jjr + 1
  1003.          prog(jjr) = xpalb(lu1,lu2)
  1004.         enddo
  1005.       enddo
  1006.       do lu1 = 1,nliab
  1007.         do lu2 = 1,nip
  1008.          jjr = jjr + 1
  1009.          prog(jjr) = xabsci(lu1,lu2)
  1010.         enddo
  1011.       enddo
  1012.       do lu1 = 1,nliab
  1013.         do lu2 = 1,nip
  1014.          jjr = jjr + 1
  1015.          prog(jjr) = xordon(lu1,lu2)
  1016.         enddo
  1017.       enddo
  1018.       do lg1 = 1,nliab
  1019.         do lg2 = 1,nipalb
  1020.          jje = jje + 1
  1021.          lect(jje)= ipalb(lg1,lg2)
  1022.         enddo
  1023.       enddo
  1024.       do lg1 = 1,nliab
  1025.         do lg2 = 1,nplbb
  1026.          jje = jje + 1
  1027.          lect(jje)= iplib(lg1,lg2)
  1028.         enddo
  1029.       enddo
  1030.       do lg1=1,nplb
  1031.          jje = jje + 1
  1032.          lect(jje)= jplib(lg1)
  1033.       enddo
  1034. * MTPHI
  1035.       do lu1 = 1,nsb
  1036.        do lu2 = 1,nplsb
  1037.         do lu3 = 1,na2
  1038.          do lu4 = 1,idimb
  1039.          jjr = jjr + 1
  1040.          prog(jjr) = xphilb(lu1,lu2,lu3,lu4)
  1041.          enddo
  1042.         enddo
  1043.        enddo
  1044.       enddo
  1045.       do lg1=1,nplb
  1046.          jje = jje + 1
  1047.          lect(jje)= ibasb(lg1)
  1048.       enddo
  1049.       do lg1=1,nplb
  1050.          jje = jje + 1
  1051.          lect(jje)= iplsb(lg1)
  1052.       enddo
  1053.       do lg1=1,nsb
  1054.          jje = jje + 1
  1055.          lect(jje)= inmsb(lg1)
  1056.       enddo
  1057.       do lg1=1,nsb
  1058.          jje = jje + 1
  1059.          lect(jje)= iorsb(lg1)
  1060.       enddo
  1061.       do lg1=1,nsb
  1062.          jje = jje + 1
  1063.          lect(jje)= iarota(lg1)
  1064.       enddo
  1065. * MTFEX
  1066.       do lu1 = 1,nplb
  1067.        do lu2 = 1,npc1
  1068.         do lu3 = 1,2
  1069.          do lu4 = 1,idimb
  1070.          jjr = jjr + 1
  1071.          prog(jjr) = fexpsm(lu1,lu2,lu3,lu4)
  1072.          enddo
  1073.         enddo
  1074.        enddo
  1075.       enddo
  1076.       do lu1 = 1,npfexa
  1077.          jjr = jjr + 1
  1078.          prog(jjr) = fexa(lu1,1,1)
  1079.       enddo
  1080. * LOCLFA
  1081. c      do lu1 = 1,na1
  1082. c        do lu2 = 1,4
  1083. c         jjr = jjr + 1
  1084. c         prog(jjr) = ftest(lu1,lu2)
  1085. c        enddo
  1086. c      enddo
  1087. c      do lu1 = 1,na1
  1088. c        do lu2 = 1,4
  1089. c         jjr = jjr + 1
  1090. c         prog(jjr) = ftota0(lu1,lu2)
  1091. c        enddo
  1092. c      enddo
  1093. *LOCLB1
  1094.       do lu1 = 1,nplb
  1095.         do lu2 = 1,6
  1096.          jjr = jjr + 1
  1097.          prog(jjr) = ftest2(lu1,lu2)
  1098.         enddo
  1099.       enddo
  1100.  
  1101.       JG = jjr
  1102.       segadj mlreel
  1103.       varf(4) = mlreel
  1104.       JG = JJE
  1105.       segadj mlenti
  1106.       varf(3) = mlenti
  1107.       varf(5) = itmail
  1108.       segdes mlreel,mlenti
  1109. *
  1110.        JKTLIAB= mtliab
  1111.        JKTPHI = mtphi
  1112.        JKTQ = mtq
  1113.        JKTRES = ktres
  1114.        JKTNUM = mtnum
  1115.        JKTFEX = mtfex
  1116.        JKPREF = mpref
  1117.        JKTLIAA = 0
  1118.        JKTKAM = 0
  1119.        JKTPAS = mtpas
  1120.        IPMAIL = itmail
  1121.        JMAILz = itmail
  1122.        REPRIS = .false.
  1123.        lmodyn = .true.
  1124.        jchain = ichain
  1125.  
  1126.         call crtabl(its2)
  1127.        ITDYN = its2
  1128.        CALL DEVSO5(JKPREF,JKTQ,JKTKAM,JKTPHI,JKTLIAA,JKTLIAB,JKTFEX,
  1129.      &       JKTPAS,JKTRES,JKTNUM,NINS,JMAILz,REPRIS,JCHAIN,
  1130.      &       LMODYN,ITDYN)
  1131.        if (ierr.ne.0) return
  1132.  
  1133.        if (itdyn.gt.0) varf(2) = itdyn
  1134.  
  1135.        IF(JLIAIB.eq.nliady) then
  1136.          SEGSUP,MPREF
  1137.          segsup,MTQ
  1138.          SEGSUP,MTKAM
  1139.          SEGSUP,MTPAS
  1140.        ENDIF
  1141.  
  1142.          SEGSUP MTFEX
  1143.          segsup mtnum
  1144. *
  1145.       SEGSUP,MTPHI
  1146.       SEGSUP,MTLIAB
  1147.       SEGSUP,MTLIAA
  1148.       SEGSUP,MTRES
  1149.       SEGSUP,LOCLFA
  1150.       SEGSUP,LOCLB1
  1151.       if (npas.eq.1.and.jliaib.lt.nliady) then
  1152.         mlent3 = ichain
  1153.         segsup mlent3
  1154.       endif
  1155.  
  1156.       ichain = jchain
  1157.  
  1158.       RETURN
  1159.       END
  1160.  
  1161.  
  1162.  
  1163.  
  1164.  
  1165.  
  1166.  
  1167.  
  1168.  
  1169.  
  1170.  
  1171.  
  1172.  
  1173.  
  1174.  
  1175.  
  1176.  
  1177.  
  1178.  
  1179.  
  1180.  

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