1 : C DYN205 SOURCE CHAT 05/01/12 23:10:52 5004 2 : SUBROUTINE DYN205(I,ITLB,ITYP,KTLIAB,NPLB) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : *--------------------------------------------------------------------* 6 : * * 7 : * Operateur DYNE : algorithme de Fu - de Vogelaere * 8 : * ________________________________________________ * 9 : * * 10 : * Remplissage des tableaux de description des liaisons sur * 11 : * la base a partir des informations contenues dans la * 12 : * TABLE ILIB (LIAISON DE TYPE POINT_POINT_ROTATION_PLASTIQUE). * 13 : * * 14 : * Parametres: * 15 : * * 16 : * e I Numero de la liaison. * 17 : * e ITLB Table rassemblant la description d'une liaison. * 18 : * e ITYP Type de la liaison. * 19 : * s KTLIAB Segment descriptif des liaisons sur base B. * 20 : * e NPLB Nombre total de points. * 21 : * * 22 : * * 23 : * Auteur, date de creation: * 24 : * * 25 : * Nicolas WECXSTEEN 04/96 point-point- ... -plastique * 26 : * * 27 : *--------------------------------------------------------------------* 28 : -INC CCOPTIO 29 : -INC SMCOORD 30 : -INC SMEVOLL 31 : -INC SMLREEL 32 : * 33 : SEGMENT MTLIAB 34 : INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB) 35 : REAL*8 XPALB(NLIAB,NXPALB) 36 : REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP) 37 : ENDSEGMENT 38 : * 39 : LOGICAL L1,L0,LPERM,LELAS,LECRO 40 : CHARACTER*8 MONAMO,CHARRE,MONPER,MONELA,TYPRET 41 : CHARACTER*20 MONECR 42 : 43 : * 44 : MTLIAB = KTLIAB 45 : * 46 : * --- choc elementaire POINT_POINT_ROTATION_PLASTIQUE avec ou sans 47 : * amortissement 48 : * 49 : IF (ITYP.EQ.50) THEN 49 : CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0, 50 : & 'POINT',I1,X1,' ',L1,INOA) 51 : IF (IERR.NE.0) RETURN 51 : CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0, 52 : & 'POINT',I1,X1,' ',L1,INOB) 53 : IF (IERR.NE.0) RETURN 53 : CALL ACCTAB(ITLB,'MOT',I0,X0,'AXE_ROTATION',L0,IP0, 54 : & 'POINT',I1,X1,' ',L1,IPOI) 55 : IF (IERR.NE.0) RETURN 55 : CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, 56 : & 'FLOTTANT',I0,XJEU,' ',L1,IP1) 57 : IF (IERR.NE.0) RETURN 57 : CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0, 58 : & 'EVOLUTIO',I1,X1,' ',L1,IPEVO) 59 : IF (IERR.NE.0) RETURN 60 : * 61 : MONPER = ' ' 62 : LPERM = .FALSE. 62 : CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0, 63 : & IP0,MONPER,I0,X1,' ',LPERM,IP1) 64 : IF (IERR.NE.0) RETURN 65 : TYPRET = ' ' 65 : CALL ACCTAB(ITLB,'MOT',I1,X0,'ECROUISSAGE',L0, 66 : & IP0,TYPRET,I0,X1,MONECR,L1,IP1) 67 : IF (IERR.NE.0) RETURN 68 : LECRO = (TYPRET.EQ.'MOT') 69 : MONELA = ' ' 70 : LELAS = .FALSE. 70 : CALL ACCTAB(ITLB,'MOT',I1,X0,'COMPORTEMENT_ELASTIQUE',L0, 71 : & IP0,MONELA,I0,X1,' ',LELAS,IP1) 72 : IF (IERR.NE.0) RETURN 73 : IPERM = 0 74 : * 75 : * iperm = -2 : liaison elastique permanente 76 : * iperm = -1 : choc elastique 77 : * iperm = 0 : donnees incoherentes ou insuffisantes 78 : * iperm = 1 : choc plastique 79 : * iperm = 2 : liaison plastique isotrope 80 : * iperm = 3 : liaison plastique cinematique 81 : * 82 : 83 : IF (LPERM) THEN 84 : IF (LELAS.AND.(.NOT.LECRO)) IPERM = -2 85 : IF (MONECR.EQ.'ISOTROPE'.AND.(.NOT.LELAS)) IPERM = 2 86 : IF (MONECR.EQ.'CINEMATIQUE'.AND.(.NOT.LELAS)) IPERM = 3 87 : IF (.NOT.(XJEU.EQ.0.)) THEN 88 : * WRITE(*,*) 'Liaison permanente, mise a zero du jeu.' 89 : XJEU = 0.D0 90 : ENDIF 91 : ELSE 92 : IF (.NOT.LECRO) THEN 93 : IF (LELAS) THEN 94 : IPERM = -1 95 : ELSE 96 : IPERM = 1 97 : ENDIF 98 : ENDIF 99 : ENDIF 100 : IF (IPERM.EQ.0) THEN 100 : CALL ERREUR(905) 101 : RETURN 102 : ENDIF 103 : * 104 : MEVOLL = IPEVO 105 : * 106 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) 107 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des 108 : * tableaux xabsci et xordon 109 : * 110 : SEGACT MEVOLL 111 : KEVOLL = IEVOLL(1) 112 : SEGACT KEVOLL 113 : MLREE1 = IPROGX 114 : MLREE2 = IPROGY 115 : SEGACT MLREE1 116 : SEGACT MLREE2 117 : * NIP = MLREE1.PROG(/1) 118 : NIP = XABSCI(/2) 119 : * 120 : DO 10 MM=1,NIP 121 : XABSCI (I,MM) = MLREE1.PROG(MM) 122 : XORDON (I,MM) = MLREE2.PROG(MM) 123 : 10 CONTINUE 124 : * 125 : SEGDES MLREE1 126 : SEGDES MLREE2 127 : SEGDES KEVOLL 128 : SEGDES MEVOLL 129 : * 130 : MONAMO = ' ' 130 : CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0, 131 : & MONAMO,I0,XAMON,CHARRE,L1,IP1) 132 : IF (IERR.NE.0) RETURN 133 : * 134 : IPALB(I,1) = ITYP 135 : IPALB(I,3) = IDIM 136 : IPALB(I,5) = IPERM 137 : XPALB(I,1) = XJEU 138 : * 139 : * normalisation de l'axe de rotation 140 : * 141 : IPNV = (IDIM + 1) * (IPOI - 1) 142 : PS = 0.D0 143 : DO 20 ID = 1,IDIM 144 : XC = XCOOR(IPNV + ID) 145 : PS = PS + XC * XC 146 : 20 CONTINUE 147 : * end do 148 : IF (PS.LE.0.D0) THEN 148 : CALL ERREUR(162) 149 : RETURN 150 : ENDIF 151 : IF (MONAMO.EQ.'FLOTTANT') THEN 152 : IPALB(I,1) = 51 153 : XPALB(I,2) = XAMON 154 : DO 22 ID = 1,IDIM 155 : ID2 = 2 + ID 156 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 157 : 22 CONTINUE 158 : * end do 159 : ELSE 160 : DO 24 ID = 1,IDIM 161 : ID2 = 1 + ID 162 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 163 : 24 CONTINUE 164 : * end do 165 : ENDIF 166 : * 166 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) 167 : IPLIB(I,1) = IPLAC 167 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) 168 : IPLIB(I,2) = IPLAC 169 : * 170 : * 171 : * --- choc elementaire POINT_POINT... 172 : * 173 : * ELSE IF (ITYP.EQ. ) THEN 174 : * ... 175 : * ... 176 : ENDIF 177 : * 178 : END 179 : 180 : 181 : 182 : 183 : 184 :
© Cast3M 2003 - All rights reserved.
Disclaimer