C D2VINI SOURCE KICH 08/06/26 21:15:14 6133 C DEVINI SOURCE KK2000 97/09/08 21:17:20 2809 SUBROUTINE D2VINI(ITINIT,KTKAM,KTQ,KTFEX,KTPAS,KTNUM,KTLIAA, & KTLIAB,KTPHI,KCPR,KOCLFA,KOCLB1,REPRIS, & RIGIDE,lmodyn) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Op�rateur DYNE : algorithme de Fu - de Vogelaere * * ________________________________________________ * * * * Initialisation de l'algorithme ou reprise de calcul. * * * * Parametres: * * * * e ITINIT Table contenant les conditions initiales ou les * * champs necessaires a la reprise du calcul * * es KTKAM Segment contenant les vecteurs XK, XASM et XM * * es KTQ Segment des variables de mouvement g�n�ralis�es * * (et des travaux) * es KTFEX Segment contenant les chargements libres * * es KTPAS Segment des variables au cours d'un pas de temps * * es KTNUM Segment contenant les param�tres num�riques * * e KTLIAA Segment descriptif des liaisons en base A * * e KTLIAB Segment descriptif des liaisons en base B * * e KTPHI Segment contenant les d�form�es modales * * e KCPR Segment des points * * - KOCLFA Segment contenant les tableaux locaux de la subroutine * * D2VLFA * * - KOCLB1 Segment contenant les tableaux locaux de la subroutine * * D2VLB1 * * e REPRIS Vrai si reprise de calcul * * e RIGIDE Vrai si corps rigide * * * Auteur, date de creation: * * * * Denis ROBERT-MOUGIN, le 25 mai 1989. * * * *--------------------------------------------------------------------* -INC CCOPTIO -INC CCNOYAU -INC SMCOORD -INC SMTABLE -INC CCASSIS * SEGMENT,MTQ REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4) REAL*8 WEXT(NA1,2),WINT(NA1,2) 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,MTPAS REAL*8 FTOTA(NA1,4),FTOTB(NPLB,IDIMB),FTOTBA(NA1) REAL*8 XPTB(NPLB,4,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,MTNUM REAL*8 XDT(NPC1),XTEMPS(NPC1) ENDSEGMENT SEGMENT,MTKAM REAL*8 XK(NA1),XASM(NA1),XM(NA1) ENDSEGMENT SEGMENT,MTLIAA INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA) REAL*8 XPALA(NLIAA,NXPALA) 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,MTPHI INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB) INTEGER IAROTA(NSB) REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB) ENDSEGMENT SEGMENT,ICPR(XCOOR(/1)/(IDIM+1)) * Segment "local" pour D2VLFA ... SEGMENT,LOCLFA REAL*8 FTEST(NA1,4),FTOTA0(NA1,4) ENDSEGMENT * Segment "local" pour D2VLB1 ... SEGMENT,LOCLB1 REAL*8 FTEST2(NPLB,6),FTOTB0(NPLB,6) ENDSEGMENT segment mwinit integer jpdep,jpvit,jrepr endsegment * LOGICAL L0,L1,REPRIS,RIGIDE,lmodyn CHARACTER*8 TYPRET,TYPIND,CHARRE CHARACTER*(19) CHAI1 ILC1 = 19 DATA CHAI1 /'VARIABLES_LIAISON_A'/ * MTFEX = KTFEX MTPAS = KTPAS MTNUM = KTNUM MTKAM = KTKAM MTQ = KTQ MTLIAA = KTLIAA MTLIAB = KTLIAB MTPHI = KTPHI LOCLFA = KOCLFA LOCLB1 = KOCLB1 IDEPL = 0 IVITE = 0 ITABL = 0 ICH1 = 0 ICH2 = 0 ICH3 = 0 ICH4 = 0 ICH5 = 0 ICH6 = 0 NA1 = Q1(/1) NLIAA = IPALA(/1) NLIAB = IPALB(/1) NPLB = JPLIB(/1) NSB = XPHILB(/1) NPLSB = XPHILB(/2) NA2 = XPHILB(/3) IDIMB = XPHILB(/4) NPFEXA = FEXA(/1) NPC1 = FEXPSM(/2) NIP = XABSCI(/2) IERRD = 0 * * S'agit-il d'une initialisation ou d'une reprise de calcul ? * IF ( REPRIS ) THEN IF (IIMPI.EQ.333) THEN WRITE(IOIMP,*)'DEVINI : ---> reprise de calcul' ENDIF if (lmodyn) then mwinit = itinit segact mwinit ITABL = jrepr else CALL ACCTAB(ITINIT,'MOT',I0,X0,'REPRISE',L0,IP0, & 'TABLE',I1,X1,' ',L1,ITABL) endif * * Reprise du calcul, on remplit: info initiales * CALL ACCTAB(ITABL,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICH1) IF (IERR.NE.0) RETURN * CALL ACCTAB(ITABL,'MOT',I0,X0,'VITESSE',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICH2) IF (IERR.NE.0) RETURN * CALL ACCTAB(ITABL,'MOT',I0,X0,'FORCES_BASE_A',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICH5) IF (IERR.NE.0) RETURN CALL ACCTAB(ITABL,'MOT',I0,X0,'ACCELERATION',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICH7) IF (IERR.NE.0) RETURN * CALL ACCTAB(ITABL,'MOT',I0,X0,'TRAVAIL_EXTERIEUR',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICH9) IF (IERR.NE.0) RETURN * CALL ACCTAB(ITABL,'MOT',I0,X0,'TRAVAIL_INTERIEUR',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICH10) IF (IERR.NE.0) RETURN * IF (ICH1.NE.0) THEN CALL DYNE18(ICH1,KTQ,1,2,KCPR) ELSE CALL ERREUR(487) RETURN ENDIF * IF (ICH2.NE.0) THEN CALL DYNE18(ICH2,KTQ,2,2,KCPR) ELSE CALL ERREUR(487) RETURN ENDIF IF (ICH5.NE.0) THEN CALL DYNE23(ICH5,KTPAS,2) ELSE CALL ERREUR(487) RETURN ENDIF IF (ICH7.NE.0) THEN CALL DYNE18(ICH7,KTQ,3,2,KCPR) ELSE CALL ERREUR(487) RETURN ENDIF IF (ICH9.NE.0) THEN CALL DYNE18(ICH9,KTQ,4,2,KCPR) ENDIF IF (ICH10.NE.0) THEN CALL DYNE18(ICH10,KTQ,5,2,KCPR) ENDIF * * IF (NLIAA.NE.0) THEN * * l'indice VARIABLES_LIAISON_A n'existe que pour * les liaisons POLYNOMIALES * IPOLY = 0 MTABLE = ITABL SEGACT,MTABLE NIND1 = MLOTAB if(nbesc.ne.0)segact ipiloc DO 100 I=1,NIND1 TYPIND = MTABTI(I) IF (TYPIND.EQ.'MOT ') THEN IP = MTABII(I) ID = IPCHAR(IP) IFI = IPCHAR(IP+1) IL1 = IFI - ID IF (IL1.EQ.ILC1) THEN IF (CHAI1.EQ.ICHARA(ID:IFI-1)) THEN IPOLY = 1 ENDIF ENDIF ENDIF 100 CONTINUE if(nbesc.ne.0)segdes ipiloc SEGDES,MTABLE IF (IIMPI.EQ.333) THEN WRITE(IOIMP,*) 'DEVINI : IPOLY = ',IPOLY ENDIF IF (IPOLY.NE.0) THEN CALL ACCTAB(ITABL,'MOT',I0,X0,'VARIABLES_LIAISON_A', & L0,IP0,'TABLE',I1,X1,' ',L1,ITREFR) CALL DYNA14(ITREFR,KTLIAA) IF (IERR.NE.0) RETURN ENDIF ENDIF IF (NLIAB.NE.0) THEN CALL DEVRCO(Q1,NA1,XPTB,NPLB,XPHILB,NSB,NPLSB,NA2,IDIMB, & IBASB,IPLSB,INMSB,IORSB,2,IAROTA) CALL ACCTAB(ITABL,'MOT',I0,X0,'VARIABLES_LIAISON_B', & L0,IP0,'TABLE',I1,X1,' ',L1,ITREFR) IF (IERR.NE.0) RETURN CALL DYNE14(ITREFR,KTLIAB) IF (IERR.NE.0) RETURN ENDIF * ELSE * * Chpoints initiaux de d�placement et de vitesse: * IF (ITINIT.NE.0) THEN if (lmodyn) then mwinit = itinit segact mwinit idepl = jpdep ivite = jpvit else TYPRET=' ' CALL ACCTAB(ITINIT,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IDEPL) * TYPRET=' ' CALL ACCTAB(ITINIT,'MOT',I0,X0,'VITESSE',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IVITE) endif ENDIF * * Mise des valeurs initiales au pas m (indice 3) * IF (IDEPL.NE.0) THEN CALL DYNE18(IDEPL,KTQ,1,2,KCPR) MTQ = KTQ ENDIF IVINIT = 0 IF (IVITE.NE.0) THEN CALL DYNE18(IVITE,KTQ,2,2,KCPR) IVINIT = 1 ENDIF * * Ajout des forces de liaison * IF (NLIAA.NE.0) THEN CALL D2VLFA(Q1,Q2,FTOTA,XM,NA1,IPALA,IPLIA,XPALA,XVALA, & NLIAA,XDT,1,2,FINERT,IVINIT,FTEST,FTOTA0) ENDIF IF (NLIAB.NE.0) THEN IF (RIGIDE) THEN DO 13 IP=1,NPLB DO 15 ID=1,IDIM FEXB(IP,2,ID) = FTEXB(IP,1,2,ID) 15 CONTINUE 13 CONTINUE ENDIF CALL D2VLF2(Q1,Q2,FTOTA,XM,NA1,IPALB,IPLIB,XPALB,XVALB, & NLIAB,XPHILB,JPLIB,NPLB,IDIMB,FTOTB,FTOTBA,XPTB, & XDT,1,IBASB,IPLSB,INMSB,IORSB,NSB,NPLSB,NA2,2, & FEXPSM,NPC1,IERRD,FTEST2,FTOTB0,XABSCI,XORDON, & NIP,IAROTA,RIGIDE,FEXB,XCHPFB) IF (IERRD.NE.0) THEN IF (IERRD.EQ.1) CALL ERREUR(528) RETURN ENDIF ENDIF * * Calcul des d�placements et des vitesses au pas debut du initial * IF (IIMPI.EQ.333) THEN DO 91 I=1,NA1 WRITE(IOIMP,*)'DEVINI :' WRITE(IOIMP,*)'DEVINI : FTOTA(',I,',3) =',FTOTA(I,3) WRITE(IOIMP,*)'DEVINI : FTOTA(',I,',4) =',FTOTA(I,4) WRITE(IOIMP,*)'DEVINI : Fexa (',I,',1) =',Fexa(I,1) WRITE(IOIMP,*)'DEVINI : Fexa (',I,',2) =',Fexa(I,2) 91 CONTINUE * end do ENDIF DO 10 I = 1,NA1 UNSM = 1.D0 / ( XM(I) - FINERT(I,2) ) FTOTA(I,2) = FTOTA(I,2) + FEXA(I,1,2) - XK(I)*Q1(I,2) & - XASM(I)*Q2(I,2) Q3(I,2) = FTOTA(I,2)*UNSM 10 CONTINUE * end do * ENDIF IF (IIMPI.EQ.333) THEN DO 30 I=1,NA1 WRITE(IOIMP,*)'DEVINI :' WRITE(IOIMP,*)'DEVINI : Q1(',I,',3) =',Q1(I,3) WRITE(IOIMP,*)'DEVINI : Q2(',I,',3) =',Q2(I,3) WRITE(IOIMP,*)'DEVINI : Q3(',I,',3) =',Q3(I,3) WRITE(IOIMP,*)'DEVINI :' WRITE(IOIMP,*)'DEVINI : Q1(',I,',4) =',Q1(I,4) WRITE(IOIMP,*)'DEVINI : Q2(',I,',4) =',Q2(I,4) WRITE(IOIMP,*)'DEVINI : Q3(',I,',4) =',Q3(I,4) 30 CONTINUE * end do ENDIF IF (IIMPI.EQ.333) THEN DO 31 I=1,NA1 WRITE(IOIMP,*)'DEVINI :' WRITE(IOIMP,*)'DEVINI : FTOTA(',I,',3) =',FTOTA(I,3) WRITE(IOIMP,*)'DEVINI : FTOTA(',I,',4) =',FTOTA(I,4) 31 CONTINUE * end do ENDIF * ICPR = KCPR SEGSUP,ICPR * END