C DYNE20 SOURCE CHAT 11/03/16 21:19:25 6902 SUBROUTINE DYNE20(ILIB,KTLIAB,ITCARA,LMODYN) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Op�rateur DYNE : algorithme de Fu - de Vogelaere * * ________________________________________________ * * * * Remplissage des tableaux de description des liaisons sur * * la base @ partir des informations contenues dans la * * table ILIB. * * * * Param�tres: * * * * e ILIB Table rassemblant la description des liaisons * * es KTLIAB Segment descriptif des liaisons sur la base B. * * * * * * Param�tres de dimensionnement pour une liaison sur base: * * * * NIPALB : nombre de param�tres pour d�finir le type des * * liaisons (NIPALB est fix� � 3). * * NXPALB : nombre maxi de param�tres internes d�finissant 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) : param�tres 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) : num�ro global des points. * * IPLIB(NLIAB,NPLBB) : num�ros locaux des points concern�s par * * la liaison. * * * * Icorres Pour garder le numero du pointeur des tables de * * liaison * * * * * * Auteur, date de cr�ation: * * * * Lionel VIVAN, le 21 Septembre 1989. * * E de LANGRE 08/94 laisns conditionnelles * * I. Pinto 05/97, liaisons ligne_cercle,appels a dyn207 * * * *--------------------------------------------------------------------* -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 mchelm = itcara MTLIAB = KTLIAB NPLB = JPLIB(/1) NLIAB = IPALB(/1) segini icorres * * Boucle sur le nombre de liaisons * II = 0 IF (lmodyn) THEN * 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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'INER') then melval = ielval(io) segact melval XINER = velche(1,1) else if (nomche(io)(1:4).eq.'CONV') then melval = ielval(io) segact melval XCONV = velche(1,1) else if (nomche(io)(1:4).eq.'VISC') then melval = ielval(io) segact melval XVISC = velche(1,1) else if (nomche(io)(1:4).eq.'PELO') then melval = ielval(io) segact melval XPCEL = velche(1,1) else if (nomche(io)(1:4).eq.'PRAP') then melval = ielval(io) segact melval XPCRA = velche(1,1) else if (nomche(io)(1:4).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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (nomche(io)(1:4).eq.'JEU') then melval = ielval(io) segact melval XJEU = velche(1,1) else if (nomche(io)(1:4).eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (nomche(io)(1:4).eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (nomche(io)(1:4).eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (nomche(io)(1:4).eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (nomche(io)(1:4).eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO = 'FLOTTANT' else if (nomche(io)(1:4).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 * 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 ID1 = 7 DO 22 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 22 CONTINUE * end do 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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) else if (nomche(io)(1:4).eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (nomche(io)(1:4).eq.'SPLA') then melval = ielval(io) segact melval xseuil = velche(1,1) MONSEUIL ='FLOTTANT' else if (nomche(io)(1:4).eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) XPALB(I,3) = XAMON else if (nomche(io)(1:4).eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (nomche(io)(1:4).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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) else if (nomche(io)(1:4).eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (nomche(io)(1:4).eq.'POIB') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (nomche(io)(1:4).eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else if (nomche(io)(1:4).eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (nomche(io)(1:4).eq.'MODE') then melval = ielval(io) segact melval igibe = ielche(1,1) TYPREG = 'MOT' CHARRE = 'GIBERT' else if (nomche(io)(1:4).eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (nomche(io)(1:4).eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (nomche(io)(1:4).eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (nomche(io)(1:4).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.'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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'ECRO') then melval = ielval(io) segact melval * IPERM = 2 <= isotrope , IPERM = 3 <= cinematique IPERM = ielche(1,1) else if (nomche(io)(1:4).eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (nomche(io)(1:4).eq.'POIB') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (nomche(io)(1:4).eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else if (nomche(io)(1:4).eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (nomche(io)(1:4).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 if (nomche(io)(1:4).eq.'AXRO') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (nomche(io)(1:4).eq.'POIB') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (nomche(io)(1:4).eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else if (nomche(io)(1:4).eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (nomche(io)(1:4).eq.'PERM') then melval = ielval(io) segact melval LPERM = .true. else if (nomche(io)(1:4).eq.'ELAS') then melval = ielval(io) segact melval LELAS = .true. else if (nomche(io)(1:4).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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) else if (nomche(io)(1:4).eq.'JEU') then melval = ielval(io) segact melval xjeu = velche(1,1) else if (nomche(io)(1:4).eq.'POIB') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (nomche(io)(1:4).eq.'AMOR') then melval = ielval(io) segact melval xamon = velche(1,1) MONAMO='FLOTTANT' else if (nomche(io)(1:4).eq.'LOIC') then melval = ielval(io) segact melval ipevo = ielche(1,1) TYPRET = 'EVOLUTIO' else if (nomche(io)(1:4).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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) elseif (nomche(io)(1:4).eq.'PCER') then melval = ielval(io) segact melval INOB = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (nomche(io)(1:4).eq.'RAYO') then melval = ielval(io) segact melval XRAYO = velche(1,1) else if (nomche(io)(1:4).eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (nomche(io)(1:4).eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (nomche(io)(1:4).eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (nomche(io)(1:4).eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (nomche(io)(1:4).eq.'CINT') then melval = ielval(io) segact melval LINTER = .FALSE. else if (nomche(io)(1:4).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 IPALB(I,4) = 1 IF (.NOT.LINTER) THEN IPALB(I,4) = 0 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 IPALB(I,1) = 34 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 = ' ' MARAID = ' ' MONINTER = ' ' LINTER = .true. do io = 1,n2 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) elseif (nomche(io)(1:4).eq.'EXCE') then melval = ielval(io) segact melval IEXC = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (nomche(io)(1:4).eq.'RAYO') then melval = ielval(io) segact melval XRAYO = velche(1,1) else if (nomche(io)(1:4).eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (nomche(io)(1:4).eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (nomche(io)(1:4).eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (nomche(io)(1:4).eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (nomche(io)(1:4).eq.'CINT') then melval = ielval(io) segact melval LINTER = .false. else if (nomche(io)(1:4).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 IPALB(I,4) = 1 IF (.NOT.LINTER) THEN IPALB(I,4) = 0 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) IPEX = (IDIM + 1) * (IEXC - 1) PS = 0.D0 DO 320 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 320 CONTINUE *** write (6,*) ' ps - 2 ',ps * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 24 XPALB(I,7) = XAMON ID1 = 7 ELSE ID1 = 6 ENDIF 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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) else if (nomche(io)(1:4).eq.'EXCE') then melval = ielval(io) segact melval IEXC = ielche(1,1) else if (nomche(io)(1:4).eq.'RAYO') then melval = ielval(io) segact melval xrayo = velche(1,1) else if (nomche(io)(1:4).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 (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (nomche(io)(1:4).eq.'JEU') then melval = ielval(io) segact melval XJEU = velche(1,1) else if (nomche(io)(1:4).eq.'RAYS') then melval = ielval(io) segact melval XRAYP = velche(1,1) else if (nomche(io)(1:4).eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (nomche(io)(1:4).eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (nomche(io)(1:4).eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (nomche(io)(1:4).eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (nomche(io)(1:4).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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval IPOI = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xrain = velche(1,1) MARAID = 'FLOTTANT' else if (nomche(io)(1:4).eq.'EXCE') then melval = ielval(io) segact melval IEXC = ielche(1,1) else if (nomche(io)(1:4).eq.'RAYS') then melval = ielval(io) segact melval XRAYP = velche(1,1) else if (nomche(io)(1:4).eq.'RAYB') then melval = ielval(io) segact melval XRAYB = velche(1,1) else if (nomche(io)(1:4).eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (nomche(io)(1:4).eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (nomche(io)(1:4).eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (nomche(io)(1:4).eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (nomche(io)(1:4).eq.'CINT') then melval = ielval(io) segact melval LINTER = .false. else if (nomche(io)(1:4).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 IPALB(I,4) = 1 IF (.NOT.LINTER) THEN IPALB(I,4) = 0 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 IPALB(I,1) = 26 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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval INOR = ielche(1,1) else if (nomche(io)(1:4).eq.'RAID') then melval = ielval(io) segact melval xraid = velche(1,1) MARAID = 'FLOTTANT' else if (nomche(io)(1:4).eq.'PFIX') then melval = ielval(io) segact melval IMA1 = ielche(1,1) else if (nomche(io)(1:4).eq.'PMOB') then melval = ielval(io) segact melval IMA2 = ielche(1,1) else if (nomche(io)(1:4).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 {l{ment 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 {l{ment 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 * * cr{ation d'un rep}re orthonorm{ 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 form{es par les {l{ments de IMA1 CALL DYNE29(IPALB,XPALB,NLIAB,NOMBN1,NOMBN2,I,ID1,IP1) * * position initiale de IMA2 par rapport @ 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 if (nomche(io)(1:4).eq.'NORM') then melval = ielval(io) segact melval INOR = ielche(1,1) else if (nomche(io)(1:4).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 (nomche(io)(1:4).eq.'LIMA') then melval = ielval(io) segact melval IMAI = ielche(1,1) else if (nomche(io)(1:4).eq.'LIES') then melval = ielval(io) segact melval MONESC = typche(io)(9:16) IESC = ielche(1,1) else if (nomche(io)(1:4).eq.'JEU') then melval = ielval(io) segact melval MONJEU = 'FLOTTANT' xjeu = velche(1,1) else if (nomche(io)(1:4).eq.'RAYB') then melval = ielval(io) segact melval XRAYB = velche(1,1) else if (nomche(io)(1:4).eq.'GLIS') then melval = ielval(io) segact melval XGLIS = velche(1,1) else if (nomche(io)(1:4).eq.'ADHE') then melval = ielval(io) segact melval XADHE = velche(1,1) else if (nomche(io)(1:4).eq.'RTAN') then melval = ielval(io) segact melval XRAIT = velche(1,1) else if (nomche(io)(1:4).eq.'ATAN') then melval = ielval(io) segact melval XAMOT = velche(1,1) else if (nomche(io)(1:4).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 (nomche(io)(1:4).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 (nomche(io)(1:4).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 d�faut 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 * Coordonn�es du maillage_maitre MELEME = IMAI SEGACT MELEME * Pour savoir si le contour est ferm� 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 coordonn�es 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 ferm� 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 * Coordonn�es 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 sym�trique par d�faut 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 à 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 if (nomche(io)(1:4).eq.'VISC') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,1) = X1 else if (nomche(io)(1:4).eq.'RHOF') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,2) = X1 else if (nomche(io)(1:4).eq.'PADM') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,3) = X1 else if (nomche(io)(1:4).eq.'LONG') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,4) = X1 else if (nomche(io)(1:4).eq.'AFFI') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,5) = X1 else if (nomche(io)(1:4).eq.'RAYO') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,6) = X1 else if (nomche(io)(1:4).eq.'VROT') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,7) = X1 else if (nomche(io)(1:4).eq.'EPSI') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,8) = X1 else if (nomche(io)(1:4).eq.'PHII') then melval = ielval(io) segact melval X1 = velche(1,1) XPALB(NUML,9) = X1 else if (nomche(io)(1:4).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 à lobes, avec modèle 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,'NB_MAILLES',L0,IP0, & 'ENTIER',I1,X1,' ',L1,IP1) IPALB(NUML,7+ILOB) = I1 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 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 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 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 * * donn�es par table * ELSE * DO 10 I = 1,NLIAB CALL ACCTAB(ILIB,'ENTIER',I,X0,' ',L0,IP0, & 'TABLE',I0,X0,' ',L1,ITLIAI) icorres ( i )=itliai IF (IERR.NE.0) RETURN CALL ACCTAB(ITLIAI,'MOT',I0,X0,'SOUSTYPE',L0,IP0, & 'MOT',I1,X0,MONMOT,L1,IP1) IF (IERR.NE.0) RETURN * * Liaison �l�mentaire * IF (MONMOT(1:19).EQ.'LIAISON_ELEMENTAIRE') THEN CMOT = ' ' CALL ACCTAB(ITLIAI,'MOT',I0,X0,'TYPE_LIAISON',L0,IP0, & 'MOT',I1,X0,CMOT,L1,IP1) IF (IERR.NE.0) RETURN * IF (CMOT(1:17).EQ.'POINT_PLAN_FLUIDE') THEN ITYP = 7 CALL DYN201(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:22).EQ.'CERCLE_PLAN_FROTTEMENT') THEN ITYP = 5 CALL DYN201(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF & (CMOT(1:30).EQ.'POINT_POINT_ROTATION_PLASTIQUE') THEN ITYP = 50 CALL DYN205(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF & (CMOT(1:33).EQ.'POINT_POINT_DEPLACEMENT_PLASTIQUE') THEN ITYP = 16 CALL DYN202(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:21).EQ.'POINT_PLAN_FROTTEMENT') THEN ITYP = 3 CALL DYN201(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:10).EQ.'POINT_PLAN') THEN ITYP = 1 CALL DYN201(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:22).EQ.'POINT_POINT_FROTTEMENT') THEN ITYP = 13 CALL DYN202(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:11).EQ.'POINT_POINT') THEN ITYP = 11 CALL DYN202(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:24).EQ.'CERCLE_CERCLE_FROTTEMENT') THEN ITYP = 25 CALL DYN203(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:23).EQ.'POINT_CERCLE_FROTTEMENT') THEN ITYP = 23 CALL DYN203(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:19).EQ.'POINT_CERCLE_MOBILE') THEN ITYP = 33 CALL DYN203(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:12).EQ.'POINT_CERCLE') THEN ITYP = 21 CALL DYN203(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:23).EQ.'PROFIL_PROFIL_INTERIEUR') THEN ITYP = 31 CALL DYN204(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:23).EQ.'PROFIL_PROFIL_EXTERIEUR') THEN ITYP = 32 CALL DYN204(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE IF (CMOT(1:22).EQ.'LIGNE_LIGNE_FROTTEMENT') THEN ITYP = 35 CALL DYN206(I,ITLIAI,ITYP,KTLIAB,NPLB) ELSE IF &(CMOT(1:23).EQ.'LIGNE_CERCLE_FROTTEMENT') THEN ITYP = 37 CALL DYN207(I,ITLIAI,ITYP,KTLIAB,NPLB) ELSE IF (CMOT(1:13).EQ.'PALIER_FLUIDE') THEN ITYP = 60 CALL DYN208(I,ITLIAI,ITYP,KTLIAB,NPLB) IF (IERR.NE.0) RETURN ELSE CALL ERREUR(490) RETURN ENDIF * * Liaison ........... * * ELSE IF (MONMOT(1: ).EQ.' ') THEN * ....... * ....... * ELSE CALL ERREUR(489) RETURN ENDIF 10 CONTINUE * * * * * ----- liaisons conditionnelles ? * * DO 911 I = 1,NLIAB ksi = 0 CALL ACCTAB(ILIB,'ENTIER',I,X0,' ',L0,IP0, & 'TABLE',I0,X0,' ',L1,ITLIAI) DO 912 j = 1,NLIAB jtliai = icorres ( j ) monmot = ' ' CALL ACCTAB(ITLIAI,'TABLE',I0,x0,' ',L0,jtliai, & monmot,I1,X0,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN * ------- si on trouve un logique en face d'une table * de liaison , c'est bon IF (MONMOT.EQ.'LOGIQUE ') THEN ksi = ksi + 1 ipalb(i,4) = 1 IF (L1 ) tHEN ipalb (i,4+ksi) = j ELSE IF (.NOT. L1) THEN ipalb (i,4+ksi) = -1 * j ENDIF ENDIF 912 CONTINUE 911 CONTINUE * --------- fin des conditions * * end do ENDIF * 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,*)'DYNE20 : IPALB(',IN,',',II,') =',IPALB(IN,II) 1002 CONTINUE DO 1004 IX = 1,NXPALB WRITE(IOIMP,*)'DYNE20 : XPALB(',IN,',',IX,') =',XPALB(IN,IX) 1004 CONTINUE DO 1006 IP = 1,NPLBB WRITE(IOIMP,*)'DYNE20 : IPLIB(',IN,',',IP,') =',IPLIB(IN,IP) 1006 CONTINUE 1000 CONTINUE DO 1008 IP = 1,NPLB WRITE(IOIMP,*)'DYNE20 : JPLIB(',IP,') =',JPLIB(IP) 1008 CONTINUE ENDIF * RETURN END