C COML10 SOURCE CB215821 25/04/23 21:15:06 12247 SUBROUTINE COML10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC CCHAMP * segment deroulant le mcheml -INC DECHE -INC SMCHPOI -INC SMCOORD -INC SMELEME -INC SMLENTI -INC SMLREEL *------------------------------------------------------------- * CF DEVPAS et autres s-p de DYNE ** calcul des vitesses correct pour dernière liaison (JLIAIB.eq.NLIADY) *------------------------------------------------------------- ** segment sous-structures dynamiques segment struli integer itlia,itbmod,momoda, mostat,itmail,molia integer ldefo(np1),lcgra(np1),lsstru(np1) integer nsstru,nndefo,nliab,nsb,na2,idimb integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0) INTEGER ICHAIN endsegment * * Segment contenant les variables au cours d'un pas de temps: * SEGMENT,MTPAS REAL*8 FTOTA(NA1,4),FTOTB(NPLB,IDIMB),FTOTBA(NA1) REAL*8 XPTB(NPLB,2,IDIMB),FINERT(NA1,4) REAL*8 XVALA(NLIAA,4,NTVAR),XVALB(NLIAB,4,NTVAR) REAL*8 FEXB(NPLB,2,IDIM),XCHPFB(2,NLIAB,4,NPLB) ENDSEGMENT * SEGMENT,MTKAM REAL*8 XK(NA1,NB1K),XASM(NA1,NB1C),XM(NA1,NB1M) REAL*8 XOPER(NB1,NB1,NOPER) ENDSEGMENT * SEGMENT,MTQ REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4) REAL*8 WEXT(NA1,2),WINT(NA1,2) ENDSEGMENT * SEGMENT MTLIAB INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB) REAL*8 XPALB(NLIAB,NXPALB) REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP) ENDSEGMENT * SEGMENT,MTLIAA INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA) REAL*8 XPALA(NLIAA,NXPALA) ENDSEGMENT * SEGMENT,MTPHI INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB) INTEGER IAROTA(NSB) REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB) ENDSEGMENT SEGMENT,MTRES REAL*8 XRES(NRES,NCRES,NPRES),XREP(NREP,NCRES) REAL*8 XRESLA(NLSA,NPRES,NVALA),XRESLB(NLSB,NPRES,NVALB) REAL*8 XMREP(NLIAB,4,IDIMB) INTEGER ICHRES(NVES),IPORES(NRESPO,NPRES),IPOREP(NREP) INTEGER ILIRES(NRESLI,NCRES) INTEGER IPOLA(NLSA),INULA(NLSA),IPLRLA(NLSA,NVALA) INTEGER IPOLB(NLSB),INULB(NLSB),IPLRLB(NLSB,NVALB) INTEGER ILIREA(NLSA,NTVAR),ILIREB(NLSB,NTVAR) INTEGER ILIRNA(NLSA,NTVAR),ILIRNB(NLSB,NTVAR) INTEGER IPOLR(1),IMREP(NLIAB,2),IPPREP(NLIAB,4) INTEGER ILPOLA(NLIAA,2) ENDSEGMENT SEGMENT,MPREF INTEGER IPOREF(NPREF) ENDSEGMENT * SEGMENT,MTFEX REAL*8 FEXA(NPFEXA,NPC1,2) REAL*8 FEXPSM(NPLB,NPC1,2,IDIMB) REAL*8 FTEXB(NPLB,NPC1,2,IDIM) * INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB) ENDSEGMENT SEGMENT,MTNUM REAL*8 XDT(NPC1),XTEMPS(NPC1) ENDSEGMENT c Segment "local" pour DEVLFA ... SEGMENT,LOCLFA REAL*8 FTEST(NA1,4) ENDSEGMENT * Segment "local" pour DEVLB1 ... SEGMENT,LOCLB1 REAL*8 FTEST2(NPLB,6) ENDSEGMENT * Segment pour Champoints SEGMENT,MSAM integer jplibb(NPLB) ENDSEGMENT * SEGMENT,ICPR(nbpts) * PARAMETER ( ZERO=0.D0 ) LOGICAL RIGIDE,REPRIS,LMODYN * IERRD = 0 struli = itruli lmodyn = .true. MTKAM = ktkam MPREF = KPREF NPREF = iporef(/1) rigide = .false. * npc1 = 1 plante dans devso4 : pv npc1 = 2 SEGINI,MTNUM KTNUM = MTNUM xdt(1) = tempf - temp0 xtemps(1) = temp0 IF (var0(3).gt.0.and.var0(4).gt.0) THEN *--------------------------------------------------------------------* * suite d un calcul avec variables internes de preconditionnement * VAEN , VARE, pour modeles liaisons herites de DYNE de_vogelaere *--------------------------------------------------------------------* * its2 = int(var0(2)) mlreel = int(var0(4)) segact mlreel mlenti = int(var0(3)) segact mlenti itmail = int(var0(5)) jjr = 0 jje = 0 jje = jje + 1 JLIAIB = lect(jje) jje = jje + 1 nchain = lect(jje) if (ichain.eq.0) then jg = nchain segini,mlent3 ichain = mlent3 else mlent3 = ichain jg = mlent3.lect(/1) if (nchain.ne.jg) then write(6,*) 'pb developpement coml10' ierr = 2 return endif endif do lg = 1,nchain jje = jje + 1 if (JLIAIB.eq.1) mlent3.lect(lg)= lect(jje) enddo jje = jje + 1 NPAS = lect(jje) jje = jje + 1 NIPALB = lect(jje) jje = jje + 1 NXPALB = lect(jje) jje = jje + 1 NPLBB = lect(jje) jje = jje + 1 NPLB = lect(jje) jje = jje + 1 NPLSB = lect(jje) jje = jje + 1 NIP = lect(jje) jje = jje + 1 nsstru = lect(jje) jje = jje + 1 nndefo = lect(jje) MTQ = KTQ NA1 = q1(/1) jje = jje + 1 nliab = lect(jje) jje = jje + 1 nsb = lect(jje) jje = jje + 1 na2 = lect(jje) jje = jje + 1 idimb = lect(jje) jje = jje + 1 NTVAR = lect(jje) jje = jje + 1 NLIAA = lect(jje) jje = jje + 1 NRES = lect(jje) jje = jje + 1 NCRES = lect(jje) jje = jje + 1 NPRES = lect(jje) jje = jje + 1 NREP = lect(jje) jje = jje + 1 NLSA = lect(jje) jje = jje + 1 NVALA = lect(jje) jje = jje + 1 NLSB = lect(jje) jje = jje + 1 NVALB = lect(jje) jje = jje + 1 NVES = lect(jje) jje = jje + 1 i2MAX = lect(jje) * seulement sortie chpoint pour pasapas * (et pas de listreel comme dans dyne) NRESPO=NRES NRESLI=0 NPRES = 1 segini MTRES * MTRES do lg1 = 1,NVES jje = jje + 1 ichres(lg1) = lect(jje) enddo do lg1 = 1,NLSA jje = jje + 1 ipola(lg1) = lect(jje) enddo do lg1 = 1,NLSA jje = jje + 1 inula(lg1) = lect(jje) enddo do lg1 = 1,NLSB jje = jje + 1 ipolb(lg1) = lect(jje) enddo do lg1 = 1,NLSB jje = jje + 1 inulb(lg1) = lect(jje) enddo do lg1 = 1,nlsa do lg2 = 1,ntvar jje = jje + 1 ilirea(lg1,lg2) = lect(jje) enddo enddo do lg1 = 1,nlsa do lg2 = 1,ntvar jje = jje + 1 ilirna(lg1,lg2) = lect(jje) enddo enddo do lg1 = 1,nlsb do lg2 = 1,ntvar jje = jje + 1 ilireb(lg1,lg2) = lect(jje) enddo enddo do lg1 = 1,nlsb do lg2 = 1,ntvar jje = jje + 1 ilirnb(lg1,lg2) = lect(jje) enddo enddo do lg1 = 1,nliaa do lg2 = 1,2 jje = jje + 1 ilpola(lg1,lg2) = lect(jje) enddo enddo * MTPAS if (JLIAIB.eq.1) then segini MTPAS ktpas = mtpas else mtpas = ktpas endif do lu1 = 1,nplb cbp,2020-09 do lu2 = 1, 4 do lu2 = 1, 2 do lu3 = 1,idimb jjr = jjr + 1 xptb(lu1,lu2,lu3) = prog(jjr) enddo enddo enddo do lu1 = 1,na1 do lu2 = 1,4 jjr = jjr + 1 finert(lu1,lu2) = prog(jjr) enddo enddo do lu1 = 1,nliaa do lu2 = 1, 4 do lu3 = 1,ntvar jjr = jjr + 1 xvala(lu1,lu2,lu3) = prog(jjr) enddo enddo enddo do lu1 = 1,nliab do lu2 = 1, 4 do lu3 = 1,ntvar jjr = jjr + 1 xvalb(lu1,lu2,lu3) = prog(jjr) enddo enddo enddo do lu1 = 1,nplb do lu2 = 1, 2 do lu3 = 1,idim jjr = jjr + 1 fexb(lu1,lu2,lu3) = prog(jjr) enddo enddo enddo do lu1 = 1,2 do lu2 = 1, nliab do lu3 = 1,4 do lu4 = 1,nplb jjr = jjr + 1 XCHPFB(lu1,lu2,lu3,lu4) = prog(jjr) enddo enddo enddo enddo do lu1 = 1,na1 jjr = jjr + 1 ftota(lu1,3) = prog(jjr) jjr = jjr + 1 ftota(lu1,4) = prog(jjr) enddo * MTQ MTQ = KTQ do lu1 = 1,na1 do lu2 = 1,2 jjr = jjr + 1 wext(lu1,lu2) = prog(jjr) enddo enddo do lu1 = 1,na1 do lu2 = 1,2 jjr = jjr + 1 wint(lu1,lu2) = prog(jjr) enddo enddo * MTLIAB segini MTLIAB do lu1 = 1,nliab do lu2 = 1,nxpalb jjr = jjr + 1 xpalb(lu1,lu2) = prog(jjr) enddo enddo do lu1 = 1,nliab do lu2 = 1,nip jjr = jjr + 1 xabsci(lu1,lu2) = prog(jjr) enddo enddo do lu1 = 1,nliab do lu2 = 1,nip jjr = jjr + 1 xordon(lu1,lu2) = prog(jjr) enddo enddo do lg1 = 1,nliab do lg2 = 1,nipalb jje = jje + 1 ipalb(lg1,lg2) = lect(jje) enddo enddo do lg1 = 1,nliab do lg2 = 1,nplbb jje = jje + 1 iplib(lg1,lg2) = lect(jje) enddo enddo do lg1=1,nplb jje = jje + 1 jplib(lg1) = lect(jje) enddo cbp cas particulier ou IPALB contient un listreel a activer (palier) do lg1 = 1,nliab if(ipalb(lg1,1).eq.60) then if(ipalb(lg1,5).eq.1) then nlob=ipalb(lg1,6) do ilob=1,nlob mlree1=ipalb(lg1,7+ilob) segact,mlree1 enddo else mlree1=ipalb(lg1,7) segact,mlree1 endif endif enddo cbp fin du cas particulier ou IPALB contient un listreel a activer * MTPHI segini MTPHI do lu1 = 1,nsb do lu2 = 1,nplsb do lu3 = 1,na2 do lu4 = 1,idimb jjr = jjr + 1 xphilb(lu1,lu2,lu3,lu4) = prog(jjr) enddo enddo enddo enddo do lg1=1,nplb jje = jje + 1 ibasb(lg1) = lect(jje) enddo do lg1=1,nplb jje = jje + 1 iplsb(lg1) = lect(jje) enddo do lg1=1,nsb jje = jje + 1 inmsb(lg1) = lect(jje) enddo do lg1=1,nsb jje = jje + 1 iorsb(lg1) = lect(jje) enddo do lg1=1,nsb jje = jje + 1 iarota(lg1) = lect(jje) enddo * MTFEX NPFEXA = q1(/1) NPFEXB = 0 segini MTFEX do lu1 = 1,nplb do lu2 = 1,npc1 do lu3 = 1,2 do lu4 = 1,idimb jjr = jjr + 1 fexpsm(lu1,lu2,lu3,lu4) = prog(jjr) enddo enddo enddo enddo do lu1 = 1,npfexa jjr = jjr + 1 fexa(lu1,1,1) = prog(jjr) enddo * LOCLFA segini loclfa c do lu1 = 1,na1 c do lu2 = 1,4 c jjr = jjr + 1 c prog(jjr) = ftest(lu1,lu2) c enddo c enddo c do lu1 = 1,na1 c do lu2 = 1,4 c jjr = jjr + 1 c prog(jjr) = ftota0(lu1,lu2) c enddo c enddo *LOCLB1 segini loclb1 do lu1 = 1,nplb do lu2 = 1,6 jjr = jjr + 1 ftest2(lu1,lu2) = prog(jjr) enddo enddo KTRES = MTRES KPREF = MPREF SEGINI,MSAM KSAM=MSAM DO 100 IP=1,NPLB JPLIBB(IP)=JPLIB(IP) 100 CONTINUE itkm = 0 jtmail = itmail JTRES = KTRES JPREF = KPREF NLIAA = ilpola(/1) NXPALA = 1 NIPALA=3 NPLAA = 0 NPLA = 0 segini MTLIAA ktliaa = mtliaa CALL DYNE17(1,ITKM,jtmail,JTRES,JPREF,NPLAA,NXPALA,KSAM,lmodyn) IF (IERR.NE.0) RETURN MSAM=KSAM SEGSUP,MSAM ELSE * 1er pas i2MAX = 0 MTQ = ktq MTPHI = ktphi do istru=1,nsstru if(iarota(istru).ne.0) rigide = .true. enddo MTLIAB = ktliab c NSB = XPHILB(/1) NPLSB = XPHILB(/2) c NA2 = XPHILB(/3) c IDIMB = XPHILB(/4) c NPLB = JPLIB(/1) NA1 = nndefo segini loclfa KOCLFA = loclfa segini loclb1 KOCLB1 = loclb1 NPAS = 0 MTRES = KTRES ITINIT = 0 REPRIS = .false. JKCPR = kcpr NLIAA = ilpola(/1) NXPALA = 1 NIPALA=3 NPLAA = 0 NPLA = 0 segini MTLIAA ktliaa = mtliaa * voir comalo NTVAR = 6 + 4 * IDIM * segini mtpas if (JLIAIB.eq.1) then segini MTPAS ktpas = mtpas else mtpas = ktpas endif JKTPAS = ktpas NPFEXA = q1(/1) NPFEXB = 0 SEGINI MTFEX KTFEX = MTFEX JKTLIAB = ktliab JKTQ = ktq JKTPHI = ktphi JKTKAM = KTKAM * kich : permet d'initialiser mais inexact CALL DEVINI(ITINIT,JKTKAM,JKTQ,KTFEX,JKTPAS,KTNUM,KTLIAA,JKTLIAB, & JKTPHI,JKCPR,KOCLFA,KOCLB1,REPRIS,RIGIDE,lmodyn) * segsup mtfex ENDIF IVINIT = 0 * SEGINI MTFEX KTFEX = MTFEX nliady = nliab + nliaa c NLIAB = IPALB(/1) NPAS = NPAS + 1 NPASF = 1 do istru=1,nsstru if(iarota(istru).ne.0) rigide = .true. enddo c calculs en 2 demi-pas Runge-Kutta/ initialisation pour 1ere liaison do kna =1,na1 IF(JLIAIB.eq.1) THEN *voir devfxa * fexa(kna,1,1) = q3(kna,2) * q1(kna,3) = q1(kna,2) q1(kna,2) = (q1(kna,1) + q1(kna,2))* 0.5d0 * q2(kna,3) = q2(kna,2) ftota(kna,2) = q3(kna,2) ftota(kna,1) = q3(kna,2) ENDIF q2(kna,1) = 0.d0 q2(kna,2) = 0.d0 enddo ** voir devpas.eso DO III = 2,1,-1 PDT=XDT(npasf) T=XTEMPS(npasf) ** Ajout des forces de raideur avant demi-pas IF(JLIAIB.eq.1) THEN CALL DEVLK0(Q1,XK,FTOTA,NA1,1,III) ENDIF * * estimation de la vitesse (ici plutot que dans DEVLF*, bp,2020-09): * on espere que cela est coherent ici ...? * \dot{q}_1/2 ~ ({q}_1/2 - {q}_0 ) / dt/2 * \dot{q}_1 ~ ({q}_1 - {q}_1/2) / dt/2 DO I=1,NA1 Q2(I,III)=(Q1(I,III)-Q1(I,III+1))*2./PDT ENDDO * forces liaisons base A (modes) IF (NLIAA.NE.0) THEN CALL DEVLFA(Q1,Q2,FTOTA,NA1,IPALA,IPLIA,XPALA,XVALA, & NLIAA,PDT,T,npasf,III,FINERT,IVINIT,FTEST) ENDIF * * * Ajout des forces de liaison base B matérielle * IF (NLIAB.NE.0) THEN CALL DEVLFB(Q1,Q2,FTOTA,NA1,IPALB,IPLIB,XPALB,XVALB,NLIAB, & XPHILB,JPLIB,NPLB,IDIMB,FTOTB,FTOTBA,XPTB,PDT,T, & npasf,IBASB,IPLSB,INMSB,IORSB,NSB,NPLSB,NA2,III, & FEXPSM,NPC1,IERRD,FTEST2, & XABSCI,XORDON,NIP,FEXB,RIGIDE,IAROTA,XCHPFB) IF (IERRD.NE.0) RETURN ENDIF IF(JLIAIB.eq.nliady) THEN if (III.eq.2) then if (npas.eq.1) then do jj = 1,na1 ftota(jj,3) = ftota(jj,2) enddo endif CALL DEVEQ2(Q2,NA1,XASM,XM,PDT,npasf,FTOTA,FINERT) else CALL DEVEQ4(Q2,NA1,XASM,XM,PDT,npasf,FTOTA,FINERT) endif ENDIF ENDDO * CALL DYNE16(Q1,Q2,Q3,NA1,FTOTA,XPTB,NPLB,IDIMB,FINERT) DO 10 I=1,NA1 FINERT(I,3) = FINERT(I,1) FINERT(I,4) = FINERT(I,2) FTOTA(I,3) = FTOTA(I,1) FTOTA(I,4) = FTOTA(I,2) 10 CONTINUE cbp,2020-09 DO 20 IP = 1,NPLB cbp,2020-09 DO 22 ID = 1,IDIMB cbp,2020-09 XPTB(IP,3,ID) = XPTB(IP,1,ID) cbp,2020-09 XPTB(IP,4,ID) = XPTB(IP,2,ID) cbp,2020-09 22 CONTINUE cbp,2020-09 20 CONTINUE * * calcul des travaux * fin devpas.eso * * production chpoint forces base A (devso2) * meleme = itmail segact meleme if (lisous(/1).eq.0) then ipmmod = itmail ipmsta = 0 else ipmmod = lisous(1) ipmsta = lisous(2) endif NSOUPO = 1 if(ipmmod.gt.0.and.ipmsta.gt.0) nsoupo = 2 NAT=1 SEGINI,MCHPOI IPCHPO = MCHPOI MTYPOI = 'FLIAISONS' IFOPOI = IFOUR * nature diffuse JATTRI(1) = 1 nmost0 = 0 KIPCHP = 0 icoe1 = 1 ymaxf = 0.d0 if (CMATE.eq.'PO_CE_MO') then if (i2max.ne.0) then if (FTOTBA(abs(i2max))*i2max.lt.0.d0) icoe1 = -1 endif endif if (ipmmod.gt.0) then NC = 1 IF(JLIAIB.eq.nliady) NC = 2 SEGINI,MSOUPO KIPCHP = KIPCHP + 1 IPCHP(KIPCHP) = MSOUPO NOCOMP(1) = 'FALF' NOHARM(1) = NIFOUR if (NC.eq.2) then NOCOMP(2) = NOCOMP(1) NOCOMP(2)(1:1) = 'V' NOHARM(2) = NIFOUR endif IGEOC = ipmmod ipt1 = ipmmod segact ipt1 N = ipt1.num(/2) nmost0 = N SEGINI,MPOVAL IPOVAL = MPOVAL * do ii = 1,N if (i2max.eq.0) then if (abs(FTOTBA(ii)).gt.ymaxf) then ymaxf = abs(FTOTBA(ii)) i2max = ii if (FTOTBA(ii).lt.0.d0) i2max = -i2max endif endif vpocha(ii,1) = -icoe1*FTOTBA(ii) if (NC.eq.2) vpocha(ii,2) = q2(ii,1) enddo SEGDES,MPOVAL,MSOUPO endif *kich : extension a tout hasard if (ipmsta.gt.0) then NC = 1 IF(JLIAIB.eq.nliady) NC = 2 SEGINI,MSOUPO KIPCHP = KIPCHP + 1 IPCHP(KIPCHP) = MSOUPO NOCOMP(1) = 'FBET' NOHARM(1) = NIFOUR if (NC.eq.2) then NOCOMP(2) = NOCOMP(1) NOCOMP(2)(1:1) = 'V' NOHARM(2) = NIFOUR endif IGEOC = ipmsta ipt1 = ipmsta segact ipt1 N = ipt1.num(/2) SEGINI,MPOVAL IPOVAL = MPOVAL * do ii = 1,N vpocha(ii,1) = -icoe1*FTOTBA(ii + nmost0) if (NC.eq.2) vpocha(ii,2) = q2(ii,1) enddo SEGDES,MPOVAL,MSOUPO endif segdes MCHPOI varf(1) = IPCHPO MTRES = KTRES * NINS = 1 NRES = XRES(/1) NCRES = XRES(/2) NPRES = XRES(/3) NREP = XREP(/1) NLSA = XRESLA(/1) NLSB = XRESLB(/1) NVES = ICHRES(/1) NVALA = IPLRLA(/2) NVALB = IPLRLB(/2) * if (npas.eq.1) then iins2 = 2 else iins2 = 1 endif * range les resultats de la bonne liaison if (jliaib.gt.1) then do lu3 = 1,ntvar xvalb(1,1,lu3)=xvalb(jliaib,1,lu3) enddo * DO IP=1,NPLB * DO ID=1,2 * II = II + 1 * XCHPFB(ID,IIL,1,IP) = XCHPFB(ID,jliaib,1,IP) * ENDDO * ENDDO endif * transit resultat CALL DEVTR1(Q1,Q2,Q3,NA1,IINS2,NINS,FTOTA,XRES,ICHRES,NRES, & NCRES,NPRES,XREP,NREP,XVALA,INULA,NLIAA,NLSA, & XRESLA,XVALB,INULB,NLIAB,NLSB,XRESLB,ILIREA,ILIREB, & NTVAR,XPALB,IPALB,XMREP,IMREP,IDIMB,WEXT,WINT, & XCHPFB,NPLB) * sauvegarde pour aller plus vite pas suivant * JG = 1000 jje = 0 segini MLENTI jje = jje + 1 lect(jje) = JLIAIB nchain = 0 mlent3 = ichain segact mlent3 nchain = mlent3.lect(/1) jje = jje + 1 lect(jje) = nchain do lg = 1,nchain jje = jje + 1 lect(jje)=mlent3.lect(lg) enddo jje = jje + 1 lect(jje) = NPAS jje = jje + 1 lect(jje) = NIPALB jje = jje + 1 lect(jje) = NXPALB jje = jje + 1 lect(jje) = NPLBB jje = jje + 1 lect(jje) = NPLB jje = jje + 1 lect(jje) = NPLSB jje = jje + 1 lect(jje) = NIP jje = jje + 1 lect(jje) = nsstru jje = jje + 1 lect(jje) = nndefo jje = jje + 1 lect(jje) = nliab jje = jje + 1 lect(jje) = nsb jje = jje + 1 lect(jje) = na2 jje = jje + 1 lect(jje) = idimb jje = jje + 1 lect(jje) = NTVAR jje = jje + 1 lect(jje) = NLIAA jje = jje + 1 lect(jje) = NRES jje = jje + 1 lect(jje) = NCRES jje = jje + 1 lect(jje) = NPRES jje = jje + 1 lect(jje) = NREP jje = jje + 1 lect(jje) = NLSA jje = jje + 1 lect(jje) = NVALA jje = jje + 1 lect(jje) = NLSB jje = jje + 1 lect(jje) = NVALB jje = jje + 1 lect(jje) = NVES jje = jje + 1 lect(jje) = i2MAX * MTRES do lg1 = 1,NVES jje = jje + 1 lect(jje) = ichres(lg1) enddo do lg1 = 1,NLSA jje = jje + 1 lect(jje) = ipola(lg1) enddo do lg1 = 1,NLSA jje = jje + 1 lect(jje) = inula(lg1) enddo do lg1 = 1,NLSB jje = jje + 1 lect(jje) = ipolb(lg1) enddo do lg1 = 1,NLSB jje = jje + 1 lect(jje) = inulb(lg1) enddo do lg1 = 1,nlsa do lg2 = 1,ntvar jje = jje + 1 lect(jje)= ilirea(lg1,lg2) enddo enddo do lg1 = 1,nlsa do lg2 = 1,ntvar jje = jje + 1 lect(jje)= ilirna(lg1,lg2) enddo enddo do lg1 = 1,nlsb do lg2 = 1,ntvar jje = jje + 1 lect(jje)= ilireb(lg1,lg2) enddo enddo do lg1 = 1,nlsb do lg2 = 1,ntvar jje = jje + 1 lect(jje)= ilirnb(lg1,lg2) enddo enddo do lg1 = 1,nliaa do lg2 = 1,2 jje = jje + 1 lect(jje)= ilpola(lg1,lg2) enddo enddo JG = (nplb*4*idimb)+(na1*4)+(nliaa*4*ntvar)+(nliab*4*ntvar)+ &(nplb*2*idim)+(2*nliab*4*nplb)+(2*na1)+(na1*2*2)+ &(nliab*(nxpalb+nip+nip))+(nsb*na2*nplsb*idimb)+ &(nplb*npc1*2*idimb)+ npfexa +(nplb*6*2) SEGINI MLREEL jjr = 0 * MTPAS do lu1 = 1,nplb cbp,2020-09 do lu2 = 1, 4 do lu2 = 1, 2 do lu3 = 1,idimb jjr = jjr + 1 prog(jjr) = xptb(lu1,lu2,lu3) enddo enddo enddo do lu1 = 1,na1 do lu2 = 1,4 jjr = jjr + 1 prog(jjr) = finert(lu1,lu2) enddo enddo do lu1 = 1,nliaa do lu2 = 1, 4 do lu3 = 1,ntvar jjr = jjr + 1 prog(jjr) = xvala(lu1,lu2,lu3) enddo enddo enddo do lu1 = 1,nliab do lu2 = 1, 4 do lu3 = 1,ntvar jjr = jjr + 1 prog(jjr) = xvalb(lu1,lu2,lu3) enddo enddo enddo do lu1 = 1,nplb do lu2 = 1, 2 do lu3 = 1,idim jjr = jjr + 1 prog(jjr) = fexb(lu1,lu2,lu3) enddo enddo enddo do lu1 = 1,2 do lu2 = 1, nliab do lu3 = 1,4 do lu4 = 1,nplb jjr = jjr + 1 prog(jjr) = XCHPFB(lu1,lu2,lu3,lu4) enddo enddo enddo enddo do lu1 = 1,na1 jjr = jjr + 1 prog(jjr) = ftota(lu1,3) jjr = jjr + 1 prog(jjr) = ftota(lu1,4) enddo * MTQ do lu1 = 1,na1 do lu2 = 1,2 jjr = jjr + 1 prog(jjr) = wext(lu1,lu2) enddo enddo do lu1 = 1,na1 do lu2 = 1,2 jjr = jjr + 1 prog(jjr) = wint(lu1,lu2) enddo enddo * MTLIAB do lu1 = 1,nliab do lu2 = 1,nxpalb jjr = jjr + 1 prog(jjr) = xpalb(lu1,lu2) enddo enddo do lu1 = 1,nliab do lu2 = 1,nip jjr = jjr + 1 prog(jjr) = xabsci(lu1,lu2) enddo enddo do lu1 = 1,nliab do lu2 = 1,nip jjr = jjr + 1 prog(jjr) = xordon(lu1,lu2) enddo enddo do lg1 = 1,nliab do lg2 = 1,nipalb jje = jje + 1 lect(jje)= ipalb(lg1,lg2) enddo enddo do lg1 = 1,nliab do lg2 = 1,nplbb jje = jje + 1 lect(jje)= iplib(lg1,lg2) enddo enddo do lg1=1,nplb jje = jje + 1 lect(jje)= jplib(lg1) enddo * MTPHI do lu1 = 1,nsb do lu2 = 1,nplsb do lu3 = 1,na2 do lu4 = 1,idimb jjr = jjr + 1 prog(jjr) = xphilb(lu1,lu2,lu3,lu4) enddo enddo enddo enddo do lg1=1,nplb jje = jje + 1 lect(jje)= ibasb(lg1) enddo do lg1=1,nplb jje = jje + 1 lect(jje)= iplsb(lg1) enddo do lg1=1,nsb jje = jje + 1 lect(jje)= inmsb(lg1) enddo do lg1=1,nsb jje = jje + 1 lect(jje)= iorsb(lg1) enddo do lg1=1,nsb jje = jje + 1 lect(jje)= iarota(lg1) enddo * MTFEX do lu1 = 1,nplb do lu2 = 1,npc1 do lu3 = 1,2 do lu4 = 1,idimb jjr = jjr + 1 prog(jjr) = fexpsm(lu1,lu2,lu3,lu4) enddo enddo enddo enddo do lu1 = 1,npfexa jjr = jjr + 1 prog(jjr) = fexa(lu1,1,1) enddo * LOCLFA c do lu1 = 1,na1 c do lu2 = 1,4 c jjr = jjr + 1 c prog(jjr) = ftest(lu1,lu2) c enddo c enddo c do lu1 = 1,na1 c do lu2 = 1,4 c jjr = jjr + 1 c prog(jjr) = ftota0(lu1,lu2) c enddo c enddo *LOCLB1 do lu1 = 1,nplb do lu2 = 1,6 jjr = jjr + 1 prog(jjr) = ftest2(lu1,lu2) enddo enddo JG = jjr segadj mlreel varf(4) = mlreel JG = JJE segadj mlenti varf(3) = mlenti varf(5) = itmail segdes mlreel,mlenti * JKTLIAB= mtliab JKTPHI = mtphi JKTQ = mtq JKTRES = ktres JKTNUM = mtnum JKTFEX = mtfex JKPREF = mpref JKTLIAA = 0 JKTKAM = 0 JKTPAS = mtpas IPMAIL = itmail JMAILz = itmail REPRIS = .false. lmodyn = .true. jchain = ichain call crtabl(its2) ITDYN = its2 CALL DEVSO5(JKPREF,JKTQ,JKTKAM,JKTPHI,JKTLIAA,JKTLIAB,JKTFEX, & JKTPAS,JKTRES,JKTNUM,NINS,JMAILz,REPRIS,JCHAIN, & LMODYN,ITDYN) if (ierr.ne.0) return if (itdyn.gt.0) varf(2) = itdyn IF(JLIAIB.eq.nliady) then SEGSUP,MPREF segsup,MTQ SEGSUP,MTKAM SEGSUP,MTPAS ENDIF SEGSUP MTFEX segsup mtnum * SEGSUP,MTPHI SEGSUP,MTLIAB SEGSUP,MTLIAA SEGSUP,MTRES SEGSUP,LOCLFA SEGSUP,LOCLB1 if (npas.eq.1.and.jliaib.lt.nliady) then mlent3 = ichain segsup mlent3 endif ichain = jchain RETURN END