C DYN201 SOURCE CHAT 05/01/12 23:09:54 5004 SUBROUTINE DYN201(I,ITLB,ITYP,KTLIAB,NPLB) 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 (liaison de type ..._PLAN). * * Liaison POINT_PLAN avec ou sans amortissement * * Liaison POINT_PLAN_FROTTEMENT avec ou sans amortissement * * Liaison CERCLE_PLAN_FROTTEMENT avec ou sans amortissement * * Liaison POINT_PLAN_FLUIDE * * * * Param}tres: * * * * e I Num{ro de la liaison. * * e ITLB Table rassemblant la description d'une liaison. * * e ITYP Type de la liaison. * * s KTLIAB Segment descriptif des liaisons sur base B. * * e NPLB Nombre total de points. * * * * * * Auteur, date de cr{ation: * * * * Lionel VIVAN, le 5 D{cembre 1990. * * * *--------------------------------------------------------------------* -INC CCOPTIO -INC SMCOORD -INC SMEVOLL -INC SMLREEL * 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 * LOGICAL L1,L0,LPERM CHARACTER*8 MONAMO,MONSEUIL,CHARRE,TYPRET,MARAID,MONPER * MTLIAB = KTLIAB * * --- choc {l{mentaire POINT_PLAN avec ou sans amortissement * IF (ITYP.EQ.1) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'SUPPORT',L0,IP0, & 'POINT',I1,X1,' ',L1,IMOD) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN MARAID = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & MARAID,I0,XRAID,' ',L1,IP1) IF (MARAID .EQ. 'ENTIER ') THEN XRAID = 1.D0*I1 MARAID = 'FLOTTANT' ENDIF IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, & 'FLOTTANT',I0,XJEU,' ',L1,IP1) IF (IERR.NE.0) RETURN MONPER = ' ' LPERM = .FALSE. IPERM = 0 CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0, & IP0,MONPER,I0,X1,' ',LPERM,IP1) IF (IERR.NE.0) RETURN IF (LPERM) THEN IPERM = 1 ENDIF TYPRET = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0, & TYPRET,I1,X1,' ',L1,IPEVO) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I0,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I1,XAMON,'CHARRE',L1,IP1) IF (IERR.NE.0) RETURN IF (MONAMO .EQ. 'ENTIER ') THEN XAMON = 1.D0*I1 MONAMO = 'FLOTTANT' ENDIF MONSEUIL = ' ' CALL ACCTAB(ITLB,'MOT',I0,X0,'SEUIL_PLASTIQUE',L0,IP0, & MONSEUIL,I1,XSEUIL,'CHARRE',L1,IP1) IF (MONSEUIL .EQ. 'ENTIER ') THEN XSEUIL = 1.D0*I1 MONSEUIL = 'FLOTTANT' ENDIF IF (IERR.NE.0) RETURN IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN CALL ERREUR(891) RETURN ENDIF * * 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 10 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 10 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF ID1 = 3 IF (MONAMO.EQ.'FLOTTANT') THEN XPALB(I,3) = XAMON ELSE XPALB(I,3) = 0.D0 ENDIF 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 * end do 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 * CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * * --- choc {l{mentaire POINT_PLAN_FROTTEMENT avec ou sans amortissement * ELSE IF (ITYP.EQ.3) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'SUPPORT',L0,IP0, & 'POINT',I1,X1,' ',L1,IMOD) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN MARAID = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & MARAID,I0,XRAIN,' ',L1,IP1) IF (MARAID .EQ. 'ENTIER ') THEN XRAIN = 1.D0*I0 MARAID = 'FLOTTANT' ENDIF IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, & 'FLOTTANT',I0,XJEU,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0, & 'FLOTTANT',I0,XGLIS,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0, & 'FLOTTANT',I0,XADHE,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0, & 'FLOTTANT',I0,XRAIT,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0, & IP0,'FLOTTANT',I0,XAMOT,' ',L1,IP1) IF (IERR.NE.0) RETURN TYPRET = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0, & TYPRET,I1,X1,' ',L1,IPEVO) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I0,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I1,XAMON,' ',L1,IP1) IF (IERR.NE.0) RETURN IF (MONAMO .EQ. 'ENTIER ') THEN XAMON = 1.D0*I1 MONAMO = 'FLOTTANT' ENDIF 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 * * --- choc {l{mentaire CERCLE_PLAN_FROTTEMENT avec ou sans amortissement * ELSE IF (ITYP.EQ.5) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'SUPPORT',L0,IP0, & 'POINT',I1,X1,' ',L1,IMOD) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & 'FLOTTANT',I0,XRAIN,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, & 'FLOTTANT',I0,XJEU,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAYON_SUPPORT',L0,IP0, & 'FLOTTANT',I0,XRAYP,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0, & 'FLOTTANT',I0,XGLIS,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0, & 'FLOTTANT',I0,XADHE,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0, & 'FLOTTANT',I0,XRAIT,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0, & IP0,'FLOTTANT',I0,XAMOT,' ',L1,IP1) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I0,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I1,XAMON,' ',L1,IP1) IF (IERR.NE.0) RETURN * 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 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) = 6 XPALB(I,7) = XAMON ID1 = 7 ELSE ID1 = 6 ENDIF ID8 = ID1 + 7*IDIM XPALB(I,ID8+1) = XRAYP DO 32 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 32 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * * --- choc {l{mentaire POINT_PLAN_FLUIDE * ELSE IF (ITYP.EQ.7) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'SUPPORT',L0,IP0, & 'POINT',I1,X1,' ',L1,IMOD) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_INERTIE',L0,IP0, & 'FLOTTANT',I0,XINER,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_CONVECTION',L0,IP0, & 'FLOTTANT',I0,XCONV,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_VISCOSITE',L0,IP0, & 'FLOTTANT',I0,XVISC,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0, & 'COEFFICIENT_P_D_C_ELOIGNEMENT',L0,IP0, & 'FLOTTANT',I0,XPCEL,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0, & 'COEFFICIENT_P_D_C_RAPPROCHEMENT',L0,IP0, & 'FLOTTANT',I0,XPCRA,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU_FLUIDE',L0,IP0, & 'FLOTTANT',I0,XJEU,' ',L1,IP1) IF (IERR.NE.0) RETURN * 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 * * --- choc {l{mentaire ..._PLAN... * * ELSE IF (ITYP.EQ. ) THEN * ... * ... ENDIF * END