C DYNE70 SOURCE OF166741 25/02/20 21:16:11 12165 C C DYNE20 SOURCE AM 15/12/16 21:15:08 8752 SUBROUTINE DYNE70(ILIB,KTLIAB,ITCARA) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Operateur DYNE : * * Remplissage des tableaux de description des liaisons sur * * la base a partir des informations contenues dans la * * table ILIB. * * * *--------------------------------------------------------------------* * * * Parametres: * * * * e ILIB Table rassemblant la description des liaisons * * es KTLIAB Segment descriptif des liaisons sur la base B. * * * * * * Parametres de dimensionnement pour une liaison sur base: * * * * NIPALB : nombre de parametres pour definir le type des * * liaisons (NIPALB est fixe a 3). * * NXPALB : nombre maxi de parametres internes definissant les * * liaisons. * * NPLBB : nombre maxi de points intervenant dans une liaison. * * * * NPLB : nombre total de points. * * NLIAB : nombre total de liaisons. * * * * * * Tableaux fortran pour les liaisons sur base B : * * * * XPALB(NLIAB,NXPALB) : parametres de la liaison. * * IPALB(NLIAB,NIPALB) : renseigne sur le type de liaison. * * et les eventuelles conditions * * XABSCI Tableau contenant les abscisses de la loi plastique * * pour les liaisons point-point- ... -plastique * * XORDON Tableau contenant les ordonnees de la loi plastique * * pour les liaisons point-point- ... -plastique * * * * JPLIB(NPLB) : numero global des points. * * IPLIB(NLIAB,NPLBB) : numeros locaux des points concernes par * * la liaison. * * * * Icorres Pour garder le numero du pointeur des tables de * * liaison * * * * * * Auteur, date de creation: * * * * kich, 2007, #5994, d'abord dans dyne20.eso * * BP, 2018, creation de dyne70.eso pour une meilleure lisibilite * * * *--------------------------------------------------------------------* -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMEVOLL -INC SMLREEL -INC SMMODEL -INC SMCHAML -INC SMELEME -INC SMCHPOI * 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 MLIGNE INTEGER KPLIB(NPLB) ENDSEGMENT * SEGMENT icorres( nliab) * LOGICAL L1,L0, log1, lmodyn,LPERM,LINTER,LECRO,LELAS CHARACTER*40 CMOT,MONMOT,CHARRE ,CMOT1 ,MONECR CHARACTER*8 MONAMO,MONSEUIL,CHARRE2,TYPRET,MARAID,MONPER CHARACTER*8 TYPREG,MONREC,MONJEU,MONSYM,MONELA,MONINTER CHARACTER*8 MONESC CHARACTER*4 MO4 mchelm = itcara MTLIAB = KTLIAB NPLB = JPLIB(/1) NLIAB = IPALB(/1) segini icorres * * Boucle sur le nombre de liaisons * II = 0 * mmodel = ilib segact mchelm n1 = imache(/1) do I = 1, kmodel(/1) imodel = kmodel(I) segact imodel ipt8 = imamod segact ipt8 imod = ipt8.num(1,1) inoa = ipt8.num(1,1) isup = ipt8.num(1,1) do 46 in = 1,n1 meleme = imache(in) if (meleme.ne.imamod) goto 46 if (conche(in).ne.conmod) goto 46 segact meleme mchaml = ichaml(in) segact mchaml n2 = ielval(/1) goto 51 46 continue write(6,*) 'pas de caracteristique liaison' , i, conmod return 51 continue TYPRET = ' ' MONSEUIL = ' ' if (cmatee.eq.'PO_PL_FL') then ITYP = 7 do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'INER') then melval = ielval(io) segact melval XINER = velche(1,1) else if (MO4.eq.'CONV') then melval = ielval(io) segact melval XCONV = velche(1,1) else if (MO4.eq.'VISC') then melval = ielval(io) segact melval XVISC = velche(1,1) else if (MO4.eq.'PELO') then melval = ielval(io) segact melval XPCEL = velche(1,1) else if (MO4.eq.'PRAP') then melval = ielval(io) segact melval XPCRA = velche(1,1) else if (MO4.eq.'JFLU') then melval = ielval(io) segact melval XJEU = velche(1,1) else endif enddo IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XINER XPALB(I,2) = XCONV XPALB(I,3) = XVISC XPALB(I,4) = XPCEL XPALB(I,5) = XPCRA XPALB(I,6) = XJEU * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 70 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 70 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF ID1 = 6 DO 72 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 72 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * else if(cmatee.eq.'PO_PL_FR') then ITYP = 3 MARAID = ' ' TYPRET = ' ' MONAMO = ' ' do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (MO4.eq.'JEU') then melval = ielval(io) segact melval XJEU = velche(1,1) else if (MO4.eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (MO4.eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (MO4.eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (MO4.eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO = 'FLOTTANT' else if (MO4.eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else endif enddo IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN CALL ERREUR(891) RETURN ENDIF IF (TYPRET.EQ.'EVOLUTIO') THEN ITYP = 103 XRAIN = 0.d0 ENDIF IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XRAIN XPALB(I,2) = XJEU XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT IF (MONAMO.EQ.'FLOTTANT') THEN XPALB(I,7) = XAMON ELSE XPALB(I,7) = 0.D0 ENDIF * NORMALE IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 20 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 20 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF cbp,2020 ID1 = 7 ID1 = 9 DO 22 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 22 CONTINUE IF (IPALB(I,1) .EQ. 103) THEN MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans * des tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 NIP = XABSCI(/2) * DO 26 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 26 CONTINUE SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL ENDIF * CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * else if(cmatee.eq.'PO_PL') then ITYP = 1 IPERM = 0 XPALB(I,3) = 0.D0 do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) else if (MO4.eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (MO4.eq.'SPLA') then melval = ielval(io) segact melval xseuil = velche(1,1) MONSEUIL ='FLOTTANT' else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) XPALB(I,3) = XAMON else if (MO4.eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (MO4.eq.'PERM') then melval = ielval(io) segact melval IPERM = 1 else endif enddo IPALB(I,1) = ITYP IPALB(I,3) = IDIM IPALB(I,4) = IPERM XPALB(I,1) = XRAID XPALB(I,2) = XJEU * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 17 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 17 CONTINUE * IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF ID1 = 3 IF (MONSEUIL .EQ.'FLOTTANT') THEN IF (TYPRET .EQ. 'EVOLUTIO') THEN IPALB(I,1) = 101 ELSE IPALB(I,1) = 100 ENDIF ID1 = 4 XPALB(I,ID1) = XSEUIL ELSE IF (TYPRET .EQ. 'EVOLUTIO') THEN IPALB(I,1) = 102 ENDIF ENDIF * DO 12 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 12 CONTINUE * IF (IPALB(I,1) .EQ. 101 .OR. IPALB(I,1) .EQ. 102) THEN MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans * des tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 NIP = XABSCI(/2) * DO 16 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 16 CONTINUE * SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL ENDIF * IMOD = num(1,1) CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * else if (cmatee.eq.'PO_PO_FR') then ITYP = 13 MARAID = ' ' MONPER = ' ' MONAMO = ' ' TYPRET = ' ' TYPREG = ' ' CHARRE = ' ' do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) else if (MO4.eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (MO4.eq.'POIB') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else if (MO4.eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (MO4.eq.'MODE') then melval = ielval(io) segact melval igibe = ielche(1,1) TYPREG = 'MOT' CHARRE = 'NEDJAI-GIBERT' else if (MO4.eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (MO4.eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (MO4.eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (MO4.eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else endif enddo IF (IERR.NE.0) RETURN ** dans quel cas monamo est il entier? PV ** IF (MONAMO .EQ. 'ENTIER ') THEN ** XAMON = 1.D0*I0 ** MONAMO = 'FLOTTANT' ** ENDIF IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN CALL ERREUR(891) RETURN ENDIF IF (TYPRET.EQ.'EVOLUTIO') THEN ITYP = 113 XRAID = 0.d0 ENDIF * IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XRAID XPALB(I,2) = XJEU XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT IF (MONAMO.EQ.'FLOTTANT') THEN XPALB(I,7) = XAMON ELSE XPALB(I,7) = 0.D0 ENDIF * cas particulier pas tres orthodoxe pour Gibert * on passe a ityp = -13 et on modifie et ajoute * devlb2, devlb1-->devfb2--->dgcha4--->dgchfr--->dgchgl, devso4 IF (TYPREG.EQ.'MOT') THEN IF (CHARRE.EQ.'NEDJAI-GIBERT') THEN IPALB(I,1) = -13 ELSE CALL ERREUR(891) RETURN ENDIF ELSEIF (IGIBE.NE.0) THEN CALL ERREUR(891) RETURN ENDIF * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 420 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 420 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF DO 422 ID = 1,IDIM ID2 = 7 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 422 CONTINUE * end do * IF (IPALB(I,1) .EQ. 113) THEN MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans * des tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 NIP = XABSCI(/2) * DO 424 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 424 CONTINUE * SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL ENDIF * CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * else if(cmatee.eq.'PO_PO_DP') then ITYP = 16 MARAID = ' ' MONPER = ' ' LPERM = .false. IPERM = 0 MONAMO = ' ' TYPRET = ' ' do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'ECRO') then melval = ielval(io) segact melval * IPERM = 2 <= isotrope , IPERM = 3 <= cinematique IPERM = ielche(1,1) else if (MO4.eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (MO4.eq.'POIB') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else if (MO4.eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (MO4.eq.'PERM') then melval = ielval(io) segact melval LPERM = .true. else endif enddo IF (IERR.NE.0) RETURN IF (LPERM) THEN IF (.NOT.(XJEU.EQ.0.D0)) THEN * WRITE (*,*) 'Liaison permanente, mise a zero du jeu.' XJEU = 0.D0 ENDIF IF (IPERM.ne.3.and.IPERM.ne.2) THEN call erreur(21) RETURN ENDIF ENDIF * MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans * des tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 NIP = XABSCI(/2) * DO 426 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 426 CONTINUE * SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL * IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XJEU IPALB(I,5) = IPERM * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 30 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 30 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 17 XPALB(I,2) = XAMON DO 32 ID = 1,IDIM ID2 = 2 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 32 CONTINUE * end do ELSE DO 34 ID = 1,IDIM ID2 = 1 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 34 CONTINUE * end do ENDIF * CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * else if(cmatee.eq.'PO_PO_RP') then ITYP = 50 MARAID = ' ' MONPER = ' ' MONELA = ' ' LPERM = .FALSE. LELAS = .FALSE. LECRO = .FALSE. IPERM = 0 MONAMO = ' ' TYPRET = ' ' do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'AXRO') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (MO4.eq.'POIB') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else if (MO4.eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (MO4.eq.'PERM') then melval = ielval(io) segact melval LPERM = .true. else if (MO4.eq.'ELAS') then melval = ielval(io) segact melval LELAS = .true. else if (MO4.eq.'ECRO') then melval = ielval(io) segact melval * IECRO = 1 <= isotrope , IECRO = 2 <= cinematique LECRO = .true. iecro = ielche(1,1) if (iecro.eq.1) monecr = 'ISOTROPE' if (iecro.eq.2) monecr = 'CINEMATIQUE' else endif enddo IF (IERR.NE.0) RETURN * * iperm = -2 : liaison elastique permanente * iperm = -1 : choc elastique * iperm = 0 : donnees incoherentes ou insuffisantes * iperm = 1 : choc plastique * iperm = 2 : liaison plastique isotrope * iperm = 3 : liaison plastique cinematique * IF (LPERM) THEN IF (LELAS.AND.(.NOT.LECRO)) IPERM = -2 IF (MONECR.EQ.'ISOTROPE'.AND.(.NOT.LELAS)) IPERM = 2 IF (MONECR.EQ.'CINEMATIQUE'.AND.(.NOT.LELAS)) IPERM = 3 IF (.NOT.(XJEU.EQ.0.)) THEN * WRITE(*,*) 'Liaison permanente, mise a zero du jeu.' XJEU = 0.D0 ENDIF ELSE IF (.NOT.LECRO) THEN IF (LELAS) THEN IPERM = -1 ELSE IPERM = 1 ENDIF ENDIF ENDIF IF (IPERM.EQ.0) THEN CALL ERREUR(905) RETURN ENDIF * MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans * des tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 * NIP = MLREE1.PROG(/1) NIP = XABSCI(/2) * DO 110 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 110 CONTINUE * SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL * IPALB(I,1) = ITYP IPALB(I,3) = IDIM IPALB(I,5) = IPERM XPALB(I,1) = XJEU * * normalisation de l'axe de rotation * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 120 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 120 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 51 XPALB(I,2) = XAMON DO 122 ID = 1,IDIM ID2 = 2 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 122 CONTINUE * end do ELSE DO 124 ID = 1,IDIM ID2 = 1 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 124 CONTINUE * end do ENDIF * CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * * else if(cmatee.eq.'PO_PO') then ITYP = 11 MARAID = ' ' MONPER = ' ' LPERM = .FALSE. IPERM = 0 MONAMO = ' ' TYPRET = ' ' do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) else if (MO4.eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (MO4.eq.'POIB') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else if (MO4.eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (MO4.eq.'PERM') then melval = ielval(io) segact melval IPERM = ielche(1,1) LPERM = .true. else endif enddo IF (IERR.NE.0) RETURN IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN CALL ERREUR(891) RETURN ENDIF * IF (TYPRET.EQ.'EVOLUTIO') THEN ITYP = 111 XRAID = 0.d0 ENDIF IPALB(I,1) = ITYP IPALB(I,3) = IDIM IPALB(I,4) = IPERM XPALB(I,1) = XRAID XPALB(I,2) = XJEU * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 111 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 111 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN XPALB(I,3) = XAMON ELSE XPALB(I,3) = 0.d0 ENDIF DO 112 ID = 1,IDIM ID2 = 3 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 112 CONTINUE * end do * IF (IPALB(I,1) .EQ. 111) THEN MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans * des tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 NIP = XABSCI(/2) * DO 116 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 116 CONTINUE * SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL ENDIF * CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * else if(cmatee.eq.'PO_CE_MO') then ITYP = 33 MONAMO = ' ' MARAID = ' ' MONINTER = ' ' LINTER = .true. do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) elseif (MO4.eq.'PCER') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (MO4.eq.'RAYO') then melval = ielval(io) segact melval XRAYO = velche(1,1) else if (MO4.eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (MO4.eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (MO4.eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (MO4.eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (MO4.eq.'CINT') then melval = ielval(io) segact melval LINTER = .FALSE. else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO = 'FLOTTANT' else endif enddo IF (IERR.NE.0) RETURN IPALB(I,1) = ITYP IPALB(I,3) = IDIM cbp IPALB(I,4) = 1 IF (.NOT.LINTER) THEN cbp IPALB(I,4) = 0 cbp : on laisse IPALB(I,4) pour les liaisons conditionnelles ITYP=ITYP+100 IPALB(I,1) = ITYP ENDIF XPALB(I,1) = XRAIN XPALB(I,2) = XRAYO XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) IPNOA = (IDIM + 1) * (INOA - 1) IPNOB = (IDIM + 1) * (INOB - 1) PS = 0.D0 DO 202 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 202 CONTINUE *** write (6,*) ' ps - 3 ',ps IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN cbp IPALB(I,1) = 34 ITYP=ITYP+1 IPALB(I,1) = ITYP XPALB(I,7) = XAMON ID1 = 7 ELSE ID1 = 6 ENDIF ID2 = ID1 + IDIM DO 222 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) XPALB(I,ID2+ID) = XCOOR(IPNOB+ID) - XCOOR(IPNOA+ID) 222 CONTINUE CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * else if(cmatee.eq.'PO_CE_FR') then ITYP = 23 MONAMO = ' ' xamon=0.D0 MARAID = ' ' MONINTER = ' ' LINTER = .true. do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) elseif (MO4.eq.'EXCE') then melval = ielval(io) segact melval IEXC = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (MO4.eq.'RAYO') then melval = ielval(io) segact melval XRAYO = velche(1,1) else if (MO4.eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (MO4.eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (MO4.eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (MO4.eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (MO4.eq.'CINT') then melval = ielval(io) segact melval LINTER = .false. else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO = 'FLOTTANT' else endif enddo IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM IF (.NOT.LINTER) THEN ITYP=ITYP+100 IPALB(I,1) = ITYP ENDIF XPALB(I,1) = XRAIN XPALB(I,2) = XRAYO XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT * c NORMALE et EXCENTREMENT (TYPE POINT) IPNV = (IDIM + 1) * (IPOI - 1) IPEX = (IDIM + 1) * (IEXC - 1) PS = 0.D0 DO 320 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 320 CONTINUE IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF c IF (MONAMO.EQ.'FLOTTANT') THEN c cbp IPALB(I,1) = 24 c ITYP=ITYP+1 c IPALB(I,1) = ITYP XPALB(I,7) = XAMON c ID1 = 7 c ELSE c ID1 = 6 c ENDIF cbp,2020 : on suppose toujours l'amortissement + ajout regul n et t ID1=10 ID2 = ID1 + IDIM DO 322 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 322 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * else if(cmatee.eq.'PO_CE') then ITYP = 21 MARAID = ' ' MONPER = ' ' MONAMO = ' ' TYPRET = ' ' do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) else if (MO4.eq.'EXCE') then melval = ielval(io) segact melval IEXC = ielche(1,1) else if (MO4.eq.'RAYO') then melval = ielval(io) segact melval xrayo = velche(1,1) else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else endif enddo IF (IERR.NE.0) RETURN IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XRAID XPALB(I,2) = XRAYO * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) IPEX = (IDIM + 1) * (IEXC - 1) PS = 0.D0 DO 210 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 210 CONTINUE *** write (6,*) ' ps ',ps * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 22 XPALB(I,3) = XAMON ID1 = 3 ELSE ID1 = 2 ENDIF ID2 = ID1 + IDIM DO 212 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 212 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * else if(cmatee.eq.'CE_PL_FR') then ITYP = 5 MONAMO = ' ' do io = 1,n2 if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (MO4.eq.'JEU') then melval = ielval(io) segact melval XJEU = velche(1,1) else if (MO4.eq.'RAYS') then melval = ielval(io) segact melval XRAYP = velche(1,1) else if (MO4.eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (MO4.eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (MO4.eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (MO4.eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO = 'FLOTTANT' else endif enddo IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XRAIN XPALB(I,2) = XJEU XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 230 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 230 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 6 XPALB(I,7) = XAMON ID1 = 7 ELSE ID1 = 6 ENDIF ID8 = ID1 + 7*IDIM XPALB(I,ID8+1) = XRAYP DO 232 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 232 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * else if(cmatee.eq.'CE_CE_FR') then ITYP = 25 MONAMO = ' ' MARAID = ' ' MONINTER = ' ' LINTER = .true. do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (MO4.eq.'EXCE') then melval = ielval(io) segact melval IEXC = ielche(1,1) else if (MO4.eq.'RAYS') then melval = ielval(io) segact melval XRAYP = velche(1,1) else if (MO4.eq.'RAYB') then melval = ielval(io) segact melval XRAYB = velche(1,1) else if (MO4.eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (MO4.eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (MO4.eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (MO4.eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (MO4.eq.'CINT') then melval = ielval(io) segact melval LINTER = .false. else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO = 'FLOTTANT' else endif enddo IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM cbp IPALB(I,4) = 1 IF (.NOT.LINTER) THEN cbp IPALB(I,4) = 0 cbp : on laisse IPALB(I,4) pour les liaisons conditionnelles ITYP=ITYP+100 IPALB(I,1) = ITYP ENDIF XPALB(I,1) = XRAIN XPALB(I,2) = XRAYB XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) IPEX = (IDIM + 1) * (IEXC - 1) PS = 0.D0 DO 330 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 330 CONTINUE * end do *** write (6,*) ' ps - 4 ',ps IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN ID1 = 7 cbp IPALB(I,1) = 26 ITYP=ITYP+1 IPALB(I,1) = ITYP XPALB(I,7) = XAMON ELSE ID1 = 6 ENDIF ID10 = ID1 + 9*IDIM XPALB(I,ID10+1) = XRAYP ID2 = ID1 + IDIM ID3 = ID1 + 2*IDIM DO 332 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 332 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * else if(cmatee.eq.'PR_PR_IN'.OR.cmatee.eq.'PR_PR_EX') then if(cmatee.eq.'PR_PR_IN') ityp = 31 IF(cmatee.eq.'PR_PR_EX') ITYP = 32 do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval INOR = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) MARAID = 'FLOTTANT' else if (MO4.eq.'PFIX') then melval = ielval(io) segact melval IMA1 = ielche(1,1) else if (MO4.eq.'PMOB') then melval = ielval(io) segact melval IMA2 = ielche(1,1) else if (MO4.eq.'ERAI') then melval = ielval(io) segact melval xpuis = velche(1,1) else endif enddo IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XRAID XPALB(I,3) = XPUIS ID1 = 3 IP1 = 5 * * le maillage IMA1 est en element de type POI1 MELEME = IMA1 SEGACT MELEME NOMBN1 = NUM(/2) IPALB(I,4) = NOMBN1 IDP = ID1 + 5*IDIM DO 512 IE = 1,NOMBN1 IPT = NUM(1,IE) INPT = ( IDIM + 1 ) * ( IPT - 1 ) DO 514 ID = 1,IDIM XPALB(I,IDP+ID) = XCOOR(INPT + ID) 514 CONTINUE * end do IDP = IDP + IDIM 512 CONTINUE * end do SEGDES MELEME * * le maillage IMA2 est en element de type POI1 MELEME = IMA2 SEGACT MELEME NOMBN2 = NUM(/2) IPALB(I,5) = NOMBN2 DO 516 IE = 1,NOMBN2 IPT = NUM(1,IE) INPT = ( IDIM + 1 ) * ( IPT - 1 ) DO 518 ID = 1,IDIM XPALB(I,IDP+ID) = XCOOR(INPT + ID) 518 CONTINUE * end do IDP = IDP + IDIM 516 CONTINUE * end do SEGDES MELEME CALL PLACE2(JPLIB,NPLB,IPLAC,ISUP) IPLIB(I,1) = IPLAC * * creation d'un rep}re orthonorme dans le plan des maillages * le point origine est le premier point de IMA1 CALL DYNE28(INOR,ISUP,XPALB,NLIAB,I,ID1) IF (IERR.NE.0) RETURN * * coefficient des droites formees par les elements de IMA1 CALL DYNE29(IPALB,XPALB,NLIAB,NOMBN1,NOMBN2,I,ID1,IP1) * * position initiale de IMA2 par rapport a IMA1 CALL DYNE30(IPALB,XPALB,NLIAB,NOMBN1,NOMBN2,I,ID1,IP1) * * calcul de la section du profil mobile CALL DYNE33(XPALB,IPALB,NLIAB,I,ID1,XSECT) XPALB(I,2) = XSECT * * else if(cmatee.eq.'LI_LI_FR') then ITYP = 35 MONJEU = ' ' MONAMO = ' ' MARAID = ' ' CMOT = ' ' MONESC = ' ' MONSYM = ' ' MONREC = ' ' INOR = 0 SEGINI MLIGNE do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'NORM') then melval = ielval(io) segact melval INOR = ielche(1,1) else if (MO4.eq.'RAID') then melval = ielval(io) segact melval typret=typche(io)(1:8) if (typret.eq.'POINTEUR') then IRAIES = ielche(1,1) MARAID = 'CHPOINT' else xraide = velche(1,1) MARAID = 'FLOTTANT' endif else if (MO4.eq.'LIMA') then melval = ielval(io) segact melval IMAI = ielche(1,1) else if (MO4.eq.'LIES') then melval = ielval(io) segact melval MONESC = typche(io)(9:16) IESC = ielche(1,1) else if (MO4.eq.'JEU') then melval = ielval(io) segact melval MONJEU = 'FLOTTANT' xjeu = velche(1,1) else if (MO4.eq.'RAYB') then melval = ielval(io) segact melval XRAYB = velche(1,1) else if (MO4.eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (MO4.eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (MO4.eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (MO4.eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (MO4.eq.'AMOR') then melval = ielval(io) segact melval typret=typche(io)(1:8) if (typret.eq.'POINTEUR') then typret=typche(io)(9:16) iamoes = ielche(1,1) MONAMO = 'CHPOINT' else XAMO = velche(1,1) MONAMO = 'FLOTTANT' endif else if (MO4.eq.'SYME') then melval = ielval(io) segact melval isyme = ielche(1,1) MONSYM = 'MOT' if (isyme.eq.1) CMOT1(1:7)='LOCALE' if (isyme.eq.2) CMOT1(1:4)='VRAI' if (isyme.eq.3) CMOT1(1:7)='GLOBALE' else if (MO4.eq.'RECH') then melval = ielval(io) segact melval irchec = ielche(1,1) MONREC = 'MOT' if (irchec.eq.1) CMOT(1:7)= 'GLOBALE' else endif enddo * IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT * IF (MONAMO.EQ.'CHPOINT') THEN IPALB(I,1) = 36 ID1 = 7 ELSE ID1 = 6 ENDIF * Normale au plan IF (IDIM.EQ.3) THEN if (inor.eq.0) call erreur(5) IPNO = (IDIM + 1) * (INOR - 1) PS = 0.D0 DO 80 ID = 1,IDIM XC = XCOOR(IPNO + ID) PS = PS + XC * XC 80 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF DO 81 ID=1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNO + ID) / SQRT(PS) 81 CONTINUE ELSE DO 82 ID=1,IDIM XPALB(I,ID1+ID) = 0.D0 82 CONTINUE ENDIF IF (MONJEU.EQ.'FLOTTANT') THEN XPALB(I,2) = XJEU ELSE XPALB(I,2) = 0.D0 ENDIF * La recherche s'effectue par defaut localement IF (MONREC.EQ.'MOT') THEN IF (CMOT(1:7).EQ.'GLOBALE') THEN IPALB(I,23) = 1 ELSE IPALB(I,23) = 0 ENDIF ELSE IPALB(I,23) = 0 ENDIF * Coordonnees du maillage_maitre MELEME = IMAI SEGACT MELEME * Pour savoir si le contour est ferme NELEMA = NUM(/2) IF (NUM(1,1).EQ.NUM(2,NELEMA)) THEN NNOEMA = NELEMA IFERMA = 1 ELSE NNOEMA = NELEMA +1 IFERMA = 0 ENDIF IPALB(I,21) = NNOEMA IPALB(I,24) = IFERMA ID2 = ID1 + 4*IDIM IPT = NUM(1,1) INPT = (IDIM+1)*(IPT-1) CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) IPLIB(I,1) = IPLAC KPLIB(1) = IPT DO 84 ID=1,IDIM XPALB(I,ID2+ID) = XCOOR(INPT+ID) 84 CONTINUE DO 85 IE=1,(NNOEMA-1) IPT = NUM(2,IE) INPT = (IDIM+1)*(IPT-1) CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) IPLIB(I,IE+1) = IPLAC KPLIB(IE+1) = IPT IDIE = ID2 + IE*IDIM DO 86 ID=1,IDIM XPALB(I,IDIE+ID) = XCOOR(INPT+ID) 86 CONTINUE 85 CONTINUE SEGDES MELEME * Maillage_esclave ID3 = ID2 + NNOEMA*IDIM IF (MONESC.EQ.'POINT') THEN * La ligne esclave est un point NNOEES=1 IFERES=0 ISYMET=-1 * Lecture des coordonnees IPESC = (IDIM+1)*(IESC-1) CALL PLACE2(JPLIB,NPLB,IPLAC,IESC) IPLIB(I,NNOEMA+1) = IPLAC KPLIB(NNOEMA+1) = IESC DO 90 ID = 1,IDIM XPALB(I,ID3+ID) = XCOOR(IPESC+ID) 90 CONTINUE * IPALB(I,22) = NNOEES IPALB(I,25) = IFERES IPALB(I,26) = ISYMET ELSE IF (MONESC.EQ.'MAILLAGE') THEN * La ligne esclave est un maillage MELEME = IESC SEGACT MELEME * Pour savoir si le contour est ferme NELEES = NUM(/2) IF (NUM(1,1).EQ.NUM(2,NELEES)) THEN NNOEES = NELEES IFERES = 1 ELSE NNOEES = NELEES +1 IFERES = 0 ENDIF IPALB(I,22) = NNOEES IPALB(I,25) = IFERES * Coordonnees du maillage_esclave IPT = NUM(1,1) INPT = (IDIM+1)*(IPT-1) CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) IPLIB(I,NNOEMA+1) = IPLAC KPLIB(NNOEMA+1) = IPT DO 94 ID=1,IDIM XPALB(I,ID3+ID) = XCOOR(INPT+ID) 94 CONTINUE DO 95 IE=1,(NNOEES-1) IPT = NUM(2,IE) INPT = (IDIM+1)*(IPT-1) CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) IPLIB(I,NNOEMA+IE+1) = IPLAC KPLIB(NNOEMA+IE+1) = IPT IDIE = ID3 + IE*IDIM DO 96 ID=1,IDIM XPALB(I,IDIE+ID) = XCOOR(INPT+ID) 96 CONTINUE 95 CONTINUE SEGDES MELEME * Le traitement symetrique par defaut ne s'effectue pas IF (MONSYM.EQ.'MOT') THEN IF (CMOT1(1:7).EQ.'LOCALE') THEN IPALB(I,26) = 1 ELSE IF (CMOT1(1:4).EQ.'VRAI'.OR. & CMOT1(1:7).EQ.'GLOBALE') THEN IPALB(I,26) = 0 ELSE IPALB(I,26) = -1 ENDIF ENDIF ELSE IPALB(I,26) = -1 ENDIF ELSE * La ligne esclave n'est ni un point ni un maillage * CALL ERREUR(...) RETURN ENDIF ENDIF * Lecture des chpoints de raideur et d amortissement * Raideurs des noeuds esclaves et maitres ID4=ID1+(2*(NNOEMA+NNOEES)+4)*IDIM MCHPOI=IRAIES SEGACT,MCHPOI NSOUP=IPCHP(/1) DO 700 IPC=1,NSOUP MSOUPO=IPCHP(IPC) SEGACT,MSOUPO MELEME = IGEOC SEGACT,MELEME MPOVAL = IPOVAL SEGACT,MPOVAL NNN = NUM(/2) DO 711 INN=1,NNN IPT = NUM(1,INN) CALL PLACE2(KPLIB,NPLB,IPLAC,IPT) IF (IPLAC.NE.0) THEN XPALB(I,ID4+IPLAC)=VPOCHA(INN,1) ENDIF 711 CONTINUE SEGDES,MPOVAL,MELEME SEGDES MSOUPO 700 CONTINUE SEGDES,MCHPOI * Amortissement des noeuds esclaves et maitres ID5=ID4+NNOEMA+NNOEES IF (IPALB(I,1).EQ.36) THEN MCHPOI=IAMOES SEGACT,MCHPOI NSOUP = IPCHP(/1) DO 121 IPC=1,NSOUP MSOUPO=IPCHP(IPC) SEGACT,MSOUPO MELEME = IGEOC SEGACT,MELEME MPOVAL = IPOVAL SEGACT,MPOVAL NNN=NUM(/2) DO 130 INN=1,NNN IPT = NUM(1,INN) CALL PLACE2(KPLIB,NPLB,IPLAC,IPT) IF (IPLAC.NE.0) THEN XPALB(I,ID5+IPLAC)=VPOCHA(INN,1) ENDIF 130 CONTINUE SEGDES MPOVAL,MELEME SEGDES MSOUPO 121 CONTINUE SEGDES MCHPOI ENDIF SEGSUP MLIGNE else if(cmatee.eq.'LI_CE_FR') then else if(cmatee.eq.'PA_FL_RO') then ITYP = 60 MONMOT='RODELI' MTLIAB = KTLIAB * NUML = I IP1 = imod IF (IERR.NE.0) RETURN CALL PLACE2(JPLIB,NPLB,IPLAC,IP1) IPLIB(NUML,1) = IPLAC * * Valeurs de IPALB et XPALB communes a tous les types de * paliers fluides : * IPALB(NUML,1) = ITYP IPALB(NUML,2) = 0 IPALB(NUML,3) = 3 IPALB(NUML,4) = 0 * do io = 1,n2 MO4=nomche(io)(1:4) if (MO4.eq.'VISC') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,1) = X1 else if (MO4.eq.'RHOF') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,2) = X1 else if (MO4.eq.'PADM') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,3) = X1 else if (MO4.eq.'LONG') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,4) = X1 else if (MO4.eq.'AFFI') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,5) = X1 else if (MO4.eq.'RAYO') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,6) = X1 else if (MO4.eq.'VROT') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,7) = X1 else if (MO4.eq.'EPSI') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,8) = X1 else if (MO4.eq.'PHII') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,9) = X1 else if (MO4.eq.'TLOB') then melval = ielval(io) segact melval itgeom = ielche(1,1) else endif enddo * IF (MONMOT.EQ.'RODELI'.and.itgeom.gt.0) THEN * ----- Cas du palier cylindrique ou a lobes, avec modele de Rhode et Li * IPALB(NUML,5) = 1 CALL ACCTAB(ITGEOM,'MOT',I0,X0,'NOMBRE_LOBES',L0,IP0, & 'ENTIER',NLOB,X1,' ',L1,IP1) IF (IERR.NE.0) RETURN IPALB(NUML,6) = NLOB C Nombre de parametres reels : NBPR = 6 IPALB(NUML,7) = NBPR CALL ACCTAB(ITGEOM,'MOT',I0,X0,'CRITERE_ARRET',L0,IP0, & 'FLOTTANT',I1,X1,MONMOT,L1,IP1) XPALB(NUML,10) = X1 IF (IERR.NE.0) RETURN DO 610 ILOB = 1, NLOB * CALL ACCTAB(ITGEOM,'ENTIER',ILOB,X0,MONMOT,L0,IP0, & 'TABLE',I1,X1,' ',L1,ITLOB) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLOB,'MOT',I0,X0,'JEU_USINAGE',L0,IP0, & 'FLOTTANT',I1,X1,MONMOT,L1,IP1) XPALB(NUML,11+NBPR*(ILOB-1)) = X1 IF (IERR.NE.0) RETURN CALL ACCTAB(ITLOB,'MOT',I0,X0,'ASYMETRIE',L0,IP0, & 'FLOTTANT',I1,X1,MONMOT,L1,IP1) XPALB(NUML,12+NBPR*(ILOB-1)) = X1 IF (IERR.NE.0) RETURN CALL ACCTAB(ITLOB,'MOT',I0,X0,'PRECHARGE',L0,IP0, & 'FLOTTANT',I1,X1,MONMOT,L1,IP1) XPALB(NUML,13+NBPR*(ILOB-1)) = X1 IF (IERR.NE.0) RETURN CALL ACCTAB(ITLOB,'MOT',I0,X0,'ANGLE_DEBUT',L0,IP0, & 'FLOTTANT',I1,X1,MONMOT,L1,IP1) XPALB(NUML,14+NBPR*(ILOB-1)) = X1 ANGDEB = X1 IF (IERR.NE.0) RETURN CALL ACCTAB(ITLOB,'MOT',I0,X0,'AMPL_ANGLE',L0,IP0, & 'FLOTTANT',I1,X1,MONMOT,L1,IP1) XPALB(NUML,15+NBPR*(ILOB-1)) = X1 AMPLIT=X1 IF (IERR.NE.0) RETURN CALL ACCTAB(ITLOB,'MOT',I0,X0,'COEF_SUR',L0,IP0, & 'FLOTTANT',I1,X1,MONMOT,L1,IP1) XPALB(NUML,16+NBPR*(ILOB-1)) = X1 IF (IERR.NE.0) RETURN CALL ACCTAB(ITLOB,'MOT',I0,X0,'NB_MAILLES',L0,IP0, & 'ENTIER',I1,X1,' ',L1,IP1) cbp2018 IPALB(NUML,7+ILOB) = I1 NMAIL=I1 CALL COS208(ANGDEB,AMPLIT,NMAIL,KLREEL) IPALB(NUML,7+ILOB) = KLREEL IF (IERR.NE.0) RETURN 610 CONTINUE ENDIF * else write(6,*) 'verifier nom liaison', cmatee call erreur(5) return endif enddo * * traiter liaisons conditionnelles * DO I = 1,kmodel(/1) ksi = 0 imodel = kmodel(I) segact imodel if (tymode(/2).gt.0) then do 722 ilc = 1,tymode(/2) do j =1,kmodel(/1) if (kmodel(j).eq.ivamod(ilc)) then ksi = ksi + 1 ipalb(i,4) = 1 IF (tymode(ilc).EQ.'CONDINFE' ) THEN ipalb (i,4+ksi) = j ELSE IF (tymode(ilc).EQ.'CONDSUPE' ) THEN ipalb (i,4+ksi) = -1 * j ENDIF endif goto 722 enddo 722 continue endif 723 continue ENDDO * ranger do I = 1, kmodel(/1) imodel = kmodel(I) ipt8 = imamod segdes imodel,ipt8 enddo do in = 1,n1 meleme = imache(in) mchaml = ichaml(in) segact mchaml n2 = ielval(/1) do io = 1,n2 melval = ielval(io) segdes melval enddo segdes meleme,mchaml enddo segdes mchelm ***** eventuel message **** IF (IIMPI.EQ.333) THEN NLIAB = IPALB(/1) NIPALB = IPALB(/2) NXPALB = XPALB(/2) NPLBB = IPLIB(/2) NPLB = JPLIB(/1) DO 1000 IN = 1,NLIAB DO 1002 II = 1,NIPALB WRITE(IOIMP,*)'DYNE70 : IPALB(',IN,',',II,') =',IPALB(IN,II) 1002 CONTINUE DO 1004 IX = 1,NXPALB WRITE(IOIMP,*)'DYNE70 : XPALB(',IN,',',IX,') =',XPALB(IN,IX) 1004 CONTINUE DO 1006 IP = 1,NPLBB WRITE(IOIMP,*)'DYNE70 : IPLIB(',IN,',',IP,') =',IPLIB(IN,IP) 1006 CONTINUE 1000 CONTINUE DO 1008 IP = 1,NPLB WRITE(IOIMP,*)'DYNE70 : JPLIB(',IP,') =',JPLIB(IP) 1008 CONTINUE ENDIF * RETURN END