1 : C DEVINI SOURCE KICH 08/06/26 21:15:25 6133 2 : SUBROUTINE DEVINI(ITINIT,KTKAM,KTQ,KTFEX,KTPAS,KTNUM,KTLIAA, 3 : & KTLIAB,KTPHI,KCPR,KOCLFA,KOCLB1,REPRIS, 4 : & RIGIDE,lmodyn) 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8(A-H,O-Z) 7 : *--------------------------------------------------------------------* 8 : * * 9 : * Op�rateur DYNE : algorithme de Fu - de Vogelaere * 10 : * ________________________________________________ * 11 : * * 12 : * Initialisation de l'algorithme ou reprise de calcul. * 13 : * * 14 : * Parametres: * 15 : * * 16 : * e ITINIT Table contenant les conditions initiales ou les * 17 : * champs necessaires a la reprise du calcul * 18 : * es KTKAM Segment contenant les vecteurs XK, XASM et XM * 19 : * es KTQ Segment des variables de mouvement g�n�ralis�es * 20 : * (et des travaux) 21 : * es KTFEX Segment contenant les chargements libres * 22 : * es KTPAS Segment des variables au cours d'un pas de temps * 23 : * es KTNUM Segment contenant les param�tres num�riques * 24 : * e KTLIAA Segment descriptif des liaisons en base A * 25 : * e KTLIAB Segment descriptif des liaisons en base B * 26 : * e KTPHI Segment contenant les d�form�es modales * 27 : * e KCPR Segment des points * 28 : * - KOCLFA Segment contenant les tableaux locaux de la subroutine * 29 : * DEVLFA * 30 : * - KOCLB1 Segment contenant les tableaux locaux de la subroutine * 31 : * DEVLB1 * 32 : * e REPRIS Vrai si reprise de calcul * 33 : * e RIGIDE Vrai si corps rigide 34 : * * 35 : * Auteur, date de creation: * 36 : * * 37 : * Denis ROBERT-MOUGIN, le 25 mai 1989. * 38 : * * 39 : *--------------------------------------------------------------------* 40 : -INC CCOPTIO 41 : -INC CCNOYAU 42 : -INC SMCOORD 43 : -INC SMTABLE 44 : -INC CCASSIS 45 : * 46 : SEGMENT,MTQ 47 : REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4) 48 : REAL*8 WEXT(NA1,2),WINT(NA1,2) 49 : ENDSEGMENT 50 : SEGMENT,MTFEX 51 : REAL*8 FEXA(NPFEXA,NPC1,2) 52 : REAL*8 FEXPSM(NPLB,NPC1,2,IDIMB) 53 : REAL*8 FTEXB(NPLB,NPC1,2,IDIM) 54 : INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB) 55 : ENDSEGMENT 56 : SEGMENT,MTPAS 57 : REAL*8 FTOTA(NA1,4),FTOTB(NPLB,IDIMB),FTOTBA(NA1) 58 : REAL*8 XPTB(NPLB,4,IDIMB),FINERT(NA1,4) 59 : REAL*8 XVALA(NLIAA,4,NTVAR),XVALB(NLIAB,4,NTVAR) 60 : REAL*8 FEXB(NPLB,2,IDIM),XCHPFB(2,NLIAB,4,NPLB) 61 : ENDSEGMENT 62 : SEGMENT,MTNUM 63 : REAL*8 XDT(NPC1),XTEMPS(NPC1) 64 : ENDSEGMENT 65 : SEGMENT,MTKAM 66 : REAL*8 XK(NA1),XASM(NA1),XM(NA1) 67 : ENDSEGMENT 68 : SEGMENT,MTLIAA 69 : INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA) 70 : REAL*8 XPALA(NLIAA,NXPALA) 71 : ENDSEGMENT 72 : SEGMENT,MTLIAB 73 : INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB) 74 : REAL*8 XPALB(NLIAB,NXPALB) 75 : REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP) 76 : ENDSEGMENT 77 : SEGMENT,MTPHI 78 : INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB) 79 : INTEGER IAROTA(NSB) 80 : REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB) 81 : ENDSEGMENT 82 : SEGMENT,ICPR(XCOOR(/1)/(IDIM+1)) 83 : 84 : * Segment "local" pour DEVLFA ... 85 : SEGMENT,LOCLFA 86 : REAL*8 FTEST(NA1,4),FTOTA0(NA1,4) 87 : ENDSEGMENT 88 : * Segment "local" pour DEVLB1 ... 89 : SEGMENT,LOCLB1 90 : REAL*8 FTEST2(NPLB,6),FTOTB0(NPLB,6) 91 : ENDSEGMENT 92 : segment mwinit 93 : integer jpdep,jpvit,jrepr 94 : endsegment 95 : * 96 : LOGICAL L0,L1,REPRIS,RIGIDE,lmodyn 97 : CHARACTER*8 TYPRET,TYPIND,CHARRE 98 : CHARACTER*(19) CHAI1 99 : ILC1 = 19 100 : DATA CHAI1 /'VARIABLES_LIAISON_A'/ 101 : * 102 : MTFEX = KTFEX 103 : MTPAS = KTPAS 104 : MTNUM = KTNUM 105 : MTKAM = KTKAM 106 : MTQ = KTQ 107 : MTLIAA = KTLIAA 108 : MTLIAB = KTLIAB 109 : MTPHI = KTPHI 110 : LOCLFA = KOCLFA 111 : LOCLB1 = KOCLB1 112 : IDEPL = 0 113 : IVITE = 0 114 : ITABL = 0 115 : ICH1 = 0 116 : ICH2 = 0 117 : ICH3 = 0 118 : ICH4 = 0 119 : ICH5 = 0 120 : ICH6 = 0 121 : NA1 = Q1(/1) 122 : NLIAA = IPALA(/1) 123 : NLIAB = IPALB(/1) 124 : NPLB = JPLIB(/1) 125 : NSB = XPHILB(/1) 126 : NPLSB = XPHILB(/2) 127 : NA2 = XPHILB(/3) 128 : IDIMB = XPHILB(/4) 129 : NPFEXA = FEXA(/1) 130 : NPC1 = FEXPSM(/2) 131 : NIP = XABSCI(/2) 132 : IERRD = 0 133 : * 134 : * S'agit-il d'une initialisation ou d'une reprise de calcul ? 135 : * 136 : IF ( REPRIS ) THEN 137 : IF (IIMPI.EQ.333) THEN 138 : WRITE(IOIMP,*)'DEVINI : ---> reprise de calcul' 139 : ENDIF 140 : if (lmodyn) then 141 : mwinit = itinit 142 : segact mwinit 143 : ITABL = jrepr 144 : else 144 : CALL ACCTAB(ITINIT,'MOT',I0,X0,'REPRISE',L0,IP0, 145 : & 'TABLE',I1,X1,' ',L1,ITABL) 146 : endif 147 : * . . 148 : * Reprise du calcul, on remplit: Q Q Q Q 149 : * i,-1/2 i,-1/2 i,0 i,0 150 : * 150 : CALL ACCTAB(ITABL,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, 151 : & 'CHPOINT',I1,X1,' ',L1,ICH1) 152 : IF (IERR.NE.0) RETURN 153 : * 153 : CALL ACCTAB(ITABL,'MOT',I0,X0,'VITESSE',L0,IP0, 154 : & 'CHPOINT',I1,X1,' ',L1,ICH2) 155 : IF (IERR.NE.0) RETURN 156 : * 156 : CALL ACCTAB(ITABL,'MOT',I0,X0,'DEPLACEMENT_1/2',L0,IP0, 157 : & 'CHPOINT',I1,X1,' ',L1,ICH3) 158 : IF (IERR.NE.0) RETURN 159 : * 159 : CALL ACCTAB(ITABL,'MOT',I0,X0,'VITESSE_1/2',L0,IP0, 160 : & 'CHPOINT',I1,X1,' ',L1,ICH4) 161 : IF (IERR.NE.0) RETURN 162 : * 162 : CALL ACCTAB(ITABL,'MOT',I0,X0,'FORCES_BASE_A',L0,IP0, 163 : & 'CHPOINT',I1,X1,' ',L1,ICH5) 164 : IF (IERR.NE.0) RETURN 165 : * 165 : CALL ACCTAB(ITABL,'MOT',I0,X0,'FORCES_BASE_A_1/2',L0,IP0, 166 : & 'CHPOINT',I1,X1,' ',L1,ICH6) 167 : IF (IERR.NE.0) RETURN 168 : * 168 : CALL ACCTAB(ITABL,'MOT',I0,X0,'ACCELERATION',L0,IP0, 169 : & 'CHPOINT',I1,X1,' ',L1,ICH7) 170 : IF (IERR.NE.0) RETURN 171 : * 171 : CALL ACCTAB(ITABL,'MOT',I0,X0,'ACCELERATION_1/2',L0,IP0, 172 : & 'CHPOINT',I1,X1,' ',L1,ICH8) 173 : IF (IERR.NE.0) RETURN 174 : * 174 : CALL ACCTAB(ITABL,'MOT',I0,X0,'TRAVAIL_EXTERIEUR',L0,IP0, 175 : & 'CHPOINT',I1,X1,' ',L1,ICH9) 176 : IF (IERR.NE.0) RETURN 177 : * 177 : CALL ACCTAB(ITABL,'MOT',I0,X0,'TRAVAIL_INTERIEUR',L0,IP0, 178 : & 'CHPOINT',I1,X1,' ',L1,ICH10) 179 : IF (IERR.NE.0) RETURN 180 : * 181 : IF (ICH1.NE.0) THEN 181 : CALL DYNE18(ICH1,KTQ,1,3,KCPR) 182 : ELSE 182 : CALL ERREUR(487) 183 : RETURN 184 : ENDIF 185 : * 186 : IF (ICH2.NE.0) THEN 186 : CALL DYNE18(ICH2,KTQ,2,3,KCPR) 187 : ELSE 187 : CALL ERREUR(487) 188 : RETURN 189 : ENDIF 190 : * 191 : IF (ICH3.NE.0) THEN 191 : CALL DYNE18(ICH3,KTQ,1,4,KCPR) 192 : ELSE 192 : CALL ERREUR(487) 193 : RETURN 194 : ENDIF 195 : * 196 : IF (ICH4.NE.0) THEN 196 : CALL DYNE18(ICH4,KTQ,2,4,KCPR) 197 : ELSE 197 : CALL ERREUR(487) 198 : RETURN 199 : ENDIF 200 : * 201 : IF (ICH5.NE.0) THEN 201 : CALL DYNE23(ICH5,KTPAS,3) 202 : ELSE 202 : CALL ERREUR(487) 203 : RETURN 204 : ENDIF 205 : * 206 : IF (ICH6.NE.0) THEN 206 : CALL DYNE23(ICH6,KTPAS,4) 207 : ELSE 207 : CALL ERREUR(487) 208 : RETURN 209 : ENDIF 210 : * 211 : IF (ICH7.NE.0) THEN 211 : CALL DYNE18(ICH7,KTQ,3,3,KCPR) 212 : ELSE 212 : CALL ERREUR(487) 213 : RETURN 214 : ENDIF 215 : * 216 : IF (ICH8.NE.0) THEN 216 : CALL DYNE18(ICH8,KTQ,3,4,KCPR) 217 : ELSE 217 : CALL ERREUR(487) 218 : RETURN 219 : ENDIF 220 : * 221 : IF (ICH9.NE.0) THEN 221 : CALL DYNE18(ICH9,KTQ,4,1,KCPR) 222 : ENDIF 223 : IF (ICH10.NE.0) THEN 223 : CALL DYNE18(ICH10,KTQ,5,1,KCPR) 224 : ENDIF 225 : * 226 : * 227 : IF (NLIAA.NE.0) THEN 228 : * 229 : * l'indice VARIABLES_LIAISON_A n'existe que pour 230 : * les liaisons POLYNOMIALES 231 : * 232 : IPOLY = 0 233 : MTABLE = ITABL 234 : SEGACT,MTABLE 235 : NIND1 = MLOTAB 236 : if(nbesc.ne.0)segact ipiloc 237 : DO 100 I=1,NIND1 238 : TYPIND = MTABTI(I) 239 : IF (TYPIND.EQ.'MOT ') THEN 240 : IP = MTABII(I) 241 : ID = IPCHAR(IP) 242 : IFI = IPCHAR(IP+1) 243 : IL1 = IFI - ID 244 : IF (IL1.EQ.ILC1) THEN 245 : IF (CHAI1.EQ.ICHARA(ID:IFI-1)) THEN 246 : IPOLY = 1 247 : ENDIF 248 : ENDIF 249 : ENDIF 250 : 100 CONTINUE 251 : if(nbesc.ne.0)segdes ipiloc 252 : SEGDES,MTABLE 253 : IF (IIMPI.EQ.333) THEN 254 : WRITE(IOIMP,*) 'DEVINI : IPOLY = ',IPOLY 255 : ENDIF 256 : IF (IPOLY.NE.0) THEN 256 : CALL ACCTAB(ITABL,'MOT',I0,X0,'VARIABLES_LIAISON_A', 257 : & L0,IP0,'TABLE',I1,X1,' ',L1,ITREFR) 257 : CALL DYNA14(ITREFR,KTLIAA) 258 : IF (IERR.NE.0) RETURN 259 : ENDIF 260 : ENDIF 261 : IF (NLIAB.NE.0) THEN 261 : CALL DEVRCO(Q1,NA1,XPTB,NPLB,XPHILB,NSB,NPLSB,NA2,IDIMB, 262 : & IBASB,IPLSB,INMSB,IORSB,3,IAROTA) 262 : CALL ACCTAB(ITABL,'MOT',I0,X0,'VARIABLES_LIAISON_B', 263 : & L0,IP0,'TABLE',I1,X1,' ',L1,ITREFR) 264 : IF (IERR.NE.0) RETURN 264 : CALL DYNE14(ITREFR,KTLIAB) 265 : IF (IERR.NE.0) RETURN 266 : ENDIF 267 : * 268 : ELSE 269 : * 270 : * Chpoints initiaux de d�placement et de vitesse: 271 : * 272 : IF (ITINIT.NE.0) THEN 273 : if (lmodyn) then 274 : mwinit = itinit 275 : segact mwinit 276 : idepl = jpdep 277 : ivite = jpvit 278 : else 279 : TYPRET=' ' 279 : CALL ACCTAB(ITINIT,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, 280 : & TYPRET,I1,X1,CHARRE,L1,IDEPL) 281 : * 282 : TYPRET=' ' 282 : CALL ACCTAB(ITINIT,'MOT',I0,X0,'VITESSE',L0,IP0, 283 : & TYPRET,I1,X1,CHARRE,L1,IVITE) 284 : endif 285 : ENDIF 286 : * 287 : * Mise des valeurs initiales au pas m (indice 3) 288 : * 289 : IF (IDEPL.NE.0) THEN 289 : CALL DYNE18(IDEPL,KTQ,1,3,KCPR) 290 : MTQ = KTQ 291 : ENDIF 292 : IVINIT = 0 293 : IF (IVITE.NE.0) THEN 293 : CALL DYNE18(IVITE,KTQ,2,3,KCPR) 294 : IVINIT = 1 295 : ENDIF 296 : * 297 : * Ajout des forces de liaison 298 : * 299 : IF (NLIAA.NE.0) THEN 299 : CALL DEVLFA(Q1,Q2,FTOTA,XM,NA1,IPALA,IPLIA,XPALA,XVALA, 300 : & NLIAA,XDT,1,3,FINERT,IVINIT,FTEST,FTOTA0) 301 : ENDIF 302 : IF (NLIAB.NE.0) THEN 303 : IF (RIGIDE) THEN 304 : DO 13 IP=1,NPLB 305 : DO 15 ID=1,IDIM 306 : FEXB(IP,1,ID) = FTEXB(IP,1,1,ID) 307 : 15 CONTINUE 308 : 13 CONTINUE 309 : ENDIF 310 : c SEGMENT,MTPHI 311 : c INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB) 312 : c INTEGER IAROTA(NSB) 313 : c REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB) 314 : c ENDSEGMENT 314 : CALL DEVLF2(Q1,Q2,FTOTA,XM,NA1,IPALB,IPLIB,XPALB,XVALB, 315 : & NLIAB,XPHILB,JPLIB,NPLB,IDIMB,FTOTB,FTOTBA,XPTB, 316 : & XDT,1,IBASB,IPLSB,INMSB,IORSB,NSB,NPLSB,NA2,3, 317 : & FEXPSM,NPC1,IERRD,FTEST2,FTOTB0,XABSCI,XORDON, 318 : & NIP,IAROTA,RIGIDE,FEXB,XCHPFB) 319 : IF (IERRD.NE.0) THEN 319 : IF (IERRD.EQ.1) CALL ERREUR(528) 320 : RETURN 321 : ENDIF 322 : ENDIF 323 : IF (NLIAA.NE.0 .OR. NLIAB.NE.0) THEN 324 : DO 5 I=1,NA1 325 : FINERT(I,4) = FINERT(I,3) 326 : 5 CONTINUE 327 : * end do 328 : ENDIF 329 : * 330 : * Calcul des d�placements et des vitesses au pas -1/2 (indice 4) 331 : * 332 : PDT = XDT(1) 333 : PDTS2 = PDT / 2.D0 334 : AUX2 = PDT * PDT / 8.D0 335 : IF (IIMPI.EQ.333) THEN 336 : DO 91 I=1,NA1 337 : WRITE(IOIMP,*)'DEVINI :' 338 : WRITE(IOIMP,*)'DEVINI : FTOTA(',I,',3) =',FTOTA(I,3) 339 : WRITE(IOIMP,*)'DEVINI : FTOTA(',I,',4) =',FTOTA(I,4) 340 : WRITE(IOIMP,*)'DEVINI : Fexa (',I,',1) =',Fexa(I,1) 341 : WRITE(IOIMP,*)'DEVINI : Fexa (',I,',2) =',Fexa(I,2) 342 : 91 CONTINUE 343 : * end do 344 : ENDIF 345 : DO 10 I = 1,NA1 346 : UNSM3 = 1.D0 / ( XM(I) - FINERT(I,3) ) 347 : UNSM4 = 1.D0 / ( XM(I) - FINERT(I,4) ) 348 : * 349 : * G = F - K Q 350 : * i,0 i,0 i i,0 351 : * 352 : FTOTA(I,3) = FTOTA(I,3) + FEXA(I,1,1) - (XK(I)*Q1(I,3)) 353 : AUX1 = (FTOTA(I,3)*UNSM3) - (XASM(I)*UNSM3*Q2(I,3)) 354 : AUX3 = Q1(I,3) - ( PDTS2 * Q2(I,3) ) 355 : * 356 : * . 2 . 357 : * Q = Q - h/2 Q + h /8 ( G - A Q ) 358 : * i,-1/2 i,0 i,0 i,0 i i,0 359 : * 360 : Q1(I,4) = AUX3 + ( AUX2 * AUX1 ) 361 : * 362 : * G = F - K Q 363 : * i,-1/2 i,-1/2 i i,-1/2 364 : * 365 : FTOTA(I,4) = FTOTA(I,4) + FEXA(I,1,2) - (XK(I)*Q1(I,4)) 366 : AUX4 = 4.D0 + ( XASM(I) * PDT * UNSM3 ) 367 : AUX5 = ( FTOTA(I,4) * UNSM4 ) + ( FTOTA(I,3) * UNSM3 ) 368 : AUX6 = 1.D0 / ( 4.D0 - ( XASM(I) * PDT * UNSM3 ) ) 369 : * 370 : * . 1 . 371 : * Q = ________ ( ( 4 + A h ) Q - h ( G + G ) ) 372 : * i,-1/2 4 - A h i i,0 i,-1/2 i,0 373 : * i 374 : * 375 : Q2(I,4) = AUX6 * ( (AUX4*Q2(I,3)) - (PDT*AUX5) ) 376 : * 377 : * " . 378 : * Q = ( G - A Q ) / M 379 : * i i i i i 380 : * 381 : Q3(I,3) = (FTOTA(I,3)*UNSM3) - (XASM(I)*UNSM3*Q2(I,3)) 382 : Q3(I,4) = (FTOTA(I,4)*UNSM4) - (XASM(I)*UNSM4*Q2(I,4)) 383 : 10 CONTINUE 384 : * end do 385 : * 386 : ENDIF 387 : IF (IIMPI.EQ.333) THEN 388 : DO 30 I=1,NA1 389 : WRITE(IOIMP,*)'DEVINI :' 390 : WRITE(IOIMP,*)'DEVINI : Q1(',I,',3) =',Q1(I,3) 391 : WRITE(IOIMP,*)'DEVINI : Q2(',I,',3) =',Q2(I,3) 392 : WRITE(IOIMP,*)'DEVINI : Q3(',I,',3) =',Q3(I,3) 393 : WRITE(IOIMP,*)'DEVINI :' 394 : WRITE(IOIMP,*)'DEVINI : Q1(',I,',4) =',Q1(I,4) 395 : WRITE(IOIMP,*)'DEVINI : Q2(',I,',4) =',Q2(I,4) 396 : WRITE(IOIMP,*)'DEVINI : Q3(',I,',4) =',Q3(I,4) 397 : 30 CONTINUE 398 : * end do 399 : ENDIF 400 : IF (IIMPI.EQ.333) THEN 401 : DO 31 I=1,NA1 402 : WRITE(IOIMP,*)'DEVINI :' 403 : WRITE(IOIMP,*)'DEVINI : FTOTA(',I,',3) =',FTOTA(I,3) 404 : WRITE(IOIMP,*)'DEVINI : FTOTA(',I,',4) =',FTOTA(I,4) 405 : 31 CONTINUE 406 : * end do 407 : ENDIF 408 : 409 : * 410 : ICPR = KCPR 411 : SEGSUP,ICPR 412 : * 413 : END 414 : 415 : 416 : 417 : 418 :
© Cast3M 2003 - All rights reserved.
Disclaimer