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