1 : C DYN206 SOURCE CHAT 05/01/12 23:11:02 5004 2 : SUBROUTINE DYN206(I,ITLB,ITYP,KTLIAB,NPLB) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : *--------------------------------------------------------------------* 6 : * * 7 : * Opérateur DYNE : algorithme de Fu - de Vogelaere * 8 : * ________________________________________________ * 9 : * * 10 : * Remplissage des tableaux de description des liaisons sur * 11 : * la base à partir des informations contenues dans la * 12 : * table ILIB (liaison de type ..._PLAN). * 13 : * Liaison POINT_PLAN avec ou sans amortissement * 14 : * Liaison POINT_PLAN_FROTTEMENT avec ou sans amortissement * 15 : * Liaison CERCLE_PLAN_FROTTEMENT avec ou sans amortissement * 16 : * Liaison POINT_PLAN_FLUIDE * 17 : * * 18 : * Paramètres: * 19 : * * 20 : * e I Numéro de la liaison. * 21 : * e ITLB Table rassemblant la description d'une liaison. * 22 : * e ITYP Type de la liaison. * 23 : * s KTLIAB Segment descriptif des liaisons sur base B. * 24 : * e NPLB Nombre total de points. * 25 : * * 26 : * * 27 : * Auteur, date de création: * 28 : * * 29 : * Samuel DURAND, le 18 Octobre 1996. * 30 : * * 31 : *--------------------------------------------------------------------* 32 : -INC CCOPTIO 33 : -INC SMCOORD 34 : -INC SMELEME 35 : -INC SMCHPOI 36 : * 37 : SEGMENT MTLIAB 38 : INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB) 39 : REAL*8 XPALB(NLIAB,NXPALB) 40 : REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP) 41 : ENDSEGMENT 42 : * 43 : SEGMENT MLIGNE 44 : INTEGER KPLIB(NPLB) 45 : ENDSEGMENT 46 : * 47 : LOGICAL L1,L0 48 : CHARACTER*8 MONAMO,MONESC,MONREC,MONJEU,CMOT,CMOT1,MONSYM,CHARRE 49 : * 50 : MTLIAB = KTLIAB 51 : SEGINI MLIGNE 52 : * 53 : * --- choc élémentaire LIGNE_LIGNE_FROTTEMENT 54 : * avec ou sans amortissement 55 : * 55 : CALL ACCTAB(ITLB,'MOT',I0,X0,'LIGNE_MAITRE',L0,IP0, 56 : & 'MAILLAGE',I1,X1,' ',L1,IMAI) 57 : IF (IERR.NE.0) RETURN 58 : MONESC = ' ' 58 : CALL ACCTAB(ITLB,'MOT',I0,X0,'LIGNE_ESCLAVE',L0,IP0, 59 : & MONESC,I1,X1,CHARRE,L1,IESC) 60 : IF (IERR.NE.0) RETURN 60 : CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEURS',L0,IP0, 61 : & 'CHPOINT',I0,X1,' ',L1,IRAIES) 62 : IF (IERR.NE.0) RETURN 62 : CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0, 63 : & 'FLOTTANT',I0,XGLIS,' ',L1,IP1) 64 : IF (IERR.NE.0) RETURN 64 : CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0, 65 : & 'FLOTTANT',I0,XADHE,' ',L1,IP1) 66 : IF (IERR.NE.0) RETURN 66 : CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0, 67 : & 'FLOTTANT',I0,XRAIT,' ',L1,IP1) 68 : IF (IERR.NE.0) RETURN 68 : CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0, 69 : & IP0,'FLOTTANT',I0,XAMOT,' ',L1,IP1) 70 : IF (IERR.NE.0) RETURN 71 : * 72 : MONAMO = ' ' 72 : CALL ACCTAB(ITLB,'MOT',I0,X0,'AMORTISSEMENTS',L0,IP0, 73 : & MONAMO,I1,X1,CHARRE,L1,IAMOES) 74 : IF (IERR.NE.0) RETURN 75 : * 76 : MONREC = ' ' 76 : CALL ACCTAB(ITLB,'MOT',I0,X0,'RECHERCHE',L0,IP0, 77 : & MONREC,I1,X1,CMOT,L1,IP1) 78 : IF (IERR.NE.0) RETURN 79 : * 80 : MONJEU = ' ' 80 : CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, 81 : & MONJEU,I0,XJEU,CHARRE,L1,IP1) 82 : IF (IERR.NE.0) RETURN 83 : * 84 : IPALB(I,1) = ITYP 85 : IPALB(I,3) = IDIM 86 : XPALB(I,3) = XGLIS 87 : XPALB(I,4) = XADHE 88 : XPALB(I,5) = XRAIT 89 : XPALB(I,6) = XAMOT 90 : * 91 : IF (MONAMO.EQ.'CHPOINT') THEN 92 : IPALB(I,1) = 36 93 : ID1 = 7 94 : ELSE 95 : ID1 = 6 96 : ENDIF 97 : * Normale au plan 98 : IF (IDIM.EQ.3) THEN 98 : CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, 99 : & 'POINT',I1,X1,' ',L1,INOR) 100 : IF (IERR.NE.0) RETURN 101 : IPNO = (IDIM + 1) * (INOR - 1) 102 : PS = 0.D0 103 : DO 80 ID = 1,IDIM 104 : XC = XCOOR(IPNO + ID) 105 : PS = PS + XC * XC 106 : 80 CONTINUE 107 : * end do 108 : IF (PS.LE.0.D0) THEN 108 : CALL ERREUR(162) 109 : RETURN 110 : ENDIF 111 : DO 81 ID=1,IDIM 112 : XPALB(I,ID1+ID) = XCOOR(IPNO + ID) / SQRT(PS) 113 : 81 CONTINUE 114 : ELSE 115 : DO 82 ID=1,IDIM 116 : XPALB(I,ID1+ID) = 0.D0 117 : 82 CONTINUE 118 : ENDIF 119 : IF (MONJEU.EQ.'FLOTTANT') THEN 120 : XPALB(I,2) = XJEU 121 : ELSE 122 : XPALB(I,2) = 0.D0 123 : ENDIF 124 : * La recherche s'effectue par défaut localement 125 : IF (MONREC.EQ.'MOT') THEN 126 : IF (CMOT(1:7).EQ.'GLOBALE') THEN 127 : IPALB(I,23) = 1 128 : ELSE 129 : IPALB(I,23) = 0 130 : ENDIF 131 : ELSE 132 : IPALB(I,23) = 0 133 : ENDIF 134 : * 135 : * Coordonnées du maillage_maitre 136 : MELEME = IMAI 137 : SEGACT MELEME 138 : * Pour savoir si le contour est fermé 139 : NELEMA = NUM(/2) 140 : IF (NUM(1,1).EQ.NUM(2,NELEMA)) THEN 141 : NNOEMA = NELEMA 142 : IFERMA = 1 143 : ELSE 144 : NNOEMA = NELEMA +1 145 : IFERMA = 0 146 : ENDIF 147 : IPALB(I,21) = NNOEMA 148 : IPALB(I,24) = IFERMA 149 : ID2 = ID1 + 4*IDIM 150 : IPT = NUM(1,1) 151 : INPT = (IDIM+1)*(IPT-1) 151 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 152 : IPLIB(I,1) = IPLAC 153 : KPLIB(1) = IPT 154 : DO 84 ID=1,IDIM 155 : XPALB(I,ID2+ID) = XCOOR(INPT+ID) 156 : 84 CONTINUE 157 : DO 85 IE=1,(NNOEMA-1) 158 : IPT = NUM(2,IE) 159 : INPT = (IDIM+1)*(IPT-1) 159 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 160 : IPLIB(I,IE+1) = IPLAC 161 : KPLIB(IE+1) = IPT 162 : IDIE = ID2 + IE*IDIM 163 : DO 86 ID=1,IDIM 164 : XPALB(I,IDIE+ID) = XCOOR(INPT+ID) 165 : 86 CONTINUE 166 : 85 CONTINUE 167 : SEGDES MELEME 168 : * 169 : * Maillage_esclave 170 : ID3 = ID2 + NNOEMA*IDIM 171 : IF (MONESC.EQ.'POINT') THEN 172 : * La ligne esclave est un point 173 : NNOEES=1 174 : IFERES=0 175 : ISYMET=-1 176 : * Lecture des coordonnées 177 : IPESC = (IDIM+1)*(IESC-1) 177 : CALL PLACE2(JPLIB,NPLB,IPLAC,IESC) 178 : IPLIB(I,NNOEMA+1) = IPLAC 179 : KPLIB(NNOEMA+1) = IESC 180 : DO 90 ID = 1,IDIM 181 : XPALB(I,ID3+ID) = XCOOR(IPESC+ID) 182 : 90 CONTINUE 183 : * 184 : IPALB(I,22) = NNOEES 185 : IPALB(I,25) = IFERES 186 : IPALB(I,26) = ISYMET 187 : ELSE 188 : IF (MONESC.EQ.'MAILLAGE') THEN 189 : * La ligne esclave est un maillage 190 : MELEME = IESC 191 : SEGACT MELEME 192 : * Pour savoir si le contour est fermé 193 : NELEES = NUM(/2) 194 : IF (NUM(1,1).EQ.NUM(2,NELEES)) THEN 195 : NNOEES = NELEES 196 : IFERES = 1 197 : ELSE 198 : NNOEES = NELEES +1 199 : IFERES = 0 200 : ENDIF 201 : IPALB(I,22) = NNOEES 202 : IPALB(I,25) = IFERES 203 : * Coordonnées du maillage_esclave 204 : IPT = NUM(1,1) 205 : INPT = (IDIM+1)*(IPT-1) 205 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 206 : IPLIB(I,NNOEMA+1) = IPLAC 207 : KPLIB(NNOEMA+1) = IPT 208 : DO 94 ID=1,IDIM 209 : XPALB(I,ID3+ID) = XCOOR(INPT+ID) 210 : 94 CONTINUE 211 : DO 95 IE=1,(NNOEES-1) 212 : IPT = NUM(2,IE) 213 : INPT = (IDIM+1)*(IPT-1) 213 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 214 : IPLIB(I,NNOEMA+IE+1) = IPLAC 215 : KPLIB(NNOEMA+IE+1) = IPT 216 : IDIE = ID3 + IE*IDIM 217 : DO 96 ID=1,IDIM 218 : XPALB(I,IDIE+ID) = XCOOR(INPT+ID) 219 : 96 CONTINUE 220 : 95 CONTINUE 221 : SEGDES MELEME 222 : MONSYM=' ' 222 : CALL ACCTAB(ITLB,'MOT',I0,X0,'SYMETRIE',L0,IP0, 223 : & MONSYM,I1,X1,CMOT1,L1,IP1) 224 : * Le traitement symétrique par défaut ne s'effectue pas 225 : IF (MONSYM.EQ.'MOT') THEN 226 : IF (CMOT1(1:7).EQ.'LOCALE') THEN 227 : IPALB(I,26) = 1 228 : ELSE 229 : IF (CMOT1(1:4).EQ.'VRAI'.OR. 230 : &CMOT1(1:7).EQ.'GLOBALE') THEN 231 : IPALB(I,26) = 0 232 : ELSE 233 : IPALB(I,26) = -1 234 : ENDIF 235 : ENDIF 236 : ELSE 237 : IPALB(I,26) = -1 238 : ENDIF 239 : ELSE 240 : * La ligne esclave n'est ni un point ni un maillage 240 : * CALL ERREUR(...) 241 : RETURN 242 : ENDIF 243 : ENDIF 244 : * Lecture des chpoints de raideur et d amortissement 245 : * Raideurs des noeuds esclaves et maitres 246 : ID4=ID1+(2*(NNOEMA+NNOEES)+4)*IDIM 247 : MCHPOI=IRAIES 248 : SEGACT,MCHPOI 249 : NSOUP=IPCHP(/1) 250 : DO 100 IPC=1,NSOUP 251 : MSOUPO=IPCHP(IPC) 252 : SEGACT,MSOUPO 253 : MELEME = IGEOC 254 : SEGACT,MELEME 255 : MPOVAL = IPOVAL 256 : SEGACT,MPOVAL 257 : NNN = NUM(/2) 258 : DO 110 INN=1,NNN 259 : IPT = NUM(1,INN) 259 : CALL PLACE2(KPLIB,NPLB,IPLAC,IPT) 260 : IF (IPLAC.NE.0) THEN 261 : XPALB(I,ID4+IPLAC)=VPOCHA(INN,1) 262 : ENDIF 263 : 110 CONTINUE 264 : SEGDES,MPOVAL,MELEME 265 : SEGDES MSOUPO 266 : 100 CONTINUE 267 : SEGDES,MCHPOI 268 : * Amortissement des noeuds esclaves et maitres 269 : ID5=ID4+NNOEMA+NNOEES 270 : IF (IPALB(I,1).EQ.36) THEN 271 : MCHPOI=IAMOES 272 : SEGACT,MCHPOI 273 : NSOUP = IPCHP(/1) 274 : DO 120 IPC=1,NSOUP 275 : MSOUPO=IPCHP(IPC) 276 : SEGACT,MSOUPO 277 : MELEME = IGEOC 278 : SEGACT,MELEME 279 : MPOVAL = IPOVAL 280 : SEGACT,MPOVAL 281 : NNN=NUM(/2) 282 : DO 130 INN=1,NNN 283 : IPT = NUM(1,INN) 283 : CALL PLACE2(KPLIB,NPLB,IPLAC,IPT) 284 : IF (IPLAC.NE.0) THEN 285 : XPALB(I,ID5+IPLAC)=VPOCHA(INN,1) 286 : ENDIF 287 : 130 CONTINUE 288 : SEGDES MPOVAL,MELEME 289 : SEGDES MSOUPO 290 : 120 CONTINUE 291 : SEGDES MCHPOI 292 : ENDIF 293 : SEGSUP MLIGNE 294 : * end do 295 : * 296 : * 297 : * --- choc élémentaire ..._PLAN... 298 : * 299 : * ELSE IF (ITYP.EQ. ) THEN 300 : * ... 301 : * ... 302 : * 303 : END 304 : 305 : 306 :
© Cast3M 2003 - All rights reserved.
Disclaimer