1 : C ZKMIC SOURCE MAGN 09/07/30 21:23:26 6458 2 : SUBROUTINE ZKMIC(IKAS,MTABX,MTAB1) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************ 6 : C Operateur KMAC 7 : C 8 : C OBJET : Cree un objet de type MATRIK 9 : C 10 : C SYNTAXE : RESU = KMAC INCO UN ; 11 : C 12 : C RVP : TABLE de soustype EQPR (cree par EQPR) 13 : C IMPR : impression du contenu de l'objet' 14 : C 15 : C REMARQUE : Cet objet n'est pas un objet STANDART CASTEM2000 16 : C Il n'est donc pas listable 17 : C Il est tout juste bon a mettre dans la table RVP pour etre utilise 18 : C par les operateurs de résolution de la matrice de contrainte 19 : C 20 : C IKAS=1 KMAC calcul de C uniquement 21 : C IKAS=2 KMCT calcul de Ct 22 : C IKAS=3 KCCT calcul de C assemblage pour C et Ct 23 : C 24 : C*********************************************************************** 25 : -INC CCOPTIO 26 : -INC SMCHPOI 27 : POINTEUR IZCH2.MCHPOI,IZCCH2.MPOVAL 28 : POINTEUR IZDV.MCHPOI,IZDDV.MPOVAL,IZTU1.MPOVAL,TETAN.MPOVAL 29 : POINTEUR IZTG1.MCHPOI,IZTGG1.MPOVAL,IZBETA.MPOVAL 30 : -INC SMMATRIK 31 : 32 : -INC SMLENTI 33 : POINTEUR IZIPAD.MLENTI,MLENTI1.MLENTI,MLENTI2.MLENTI 34 : -INC SMLMOTS 35 : POINTEUR LINCO.MLMOTS 36 : -INC SMELEME 37 : POINTEUR MELEMZ.MELEME,MELEMB.MELEME,MELSTB.MELEME 38 : POINTEUR MELEM1.MELEME,MELES1.MELEME,MCTREI.MELEME 39 : POINTEUR IGEOM.MELEME,MELEMM.MELEME,MELEMA.MELEME 40 : POINTEUR IZLEMC.MELEME,MELEMS.MELEME,MELEMC.MELEME 41 : POINTEUR MELEMI.MELEME,MELEMP.MELEME 42 : 43 : CHARACTER*8 TYPE,TYPC,NOMZ,NOMP,NOMD 44 : CHARACTER*8 NOMPP,NOMDD 45 : CHARACTER*4 NOM 46 : INTEGER IPAD,IPAD2,IK 47 : REAL*8 KAUX,TETA1 48 : DIMENSION IXV(3) 49 : C 50 : DATA IMPR/0/ 51 : C************************************************************************* 52 : CKMIC 53 : C write(6,*)' Operateur KMIC MTABX=',MTABX 54 : C 55 : C- Récupération de la table EQEX (pointeur MTAB1) 56 : C 56 : CALL LEKTAB(MTABX,'EQEX',MTAB1) 57 : IF(MTAB1.EQ.0)THEN 58 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 59 : MOTERR( 1: 8) = ' EQEX ' 60 : MOTERR( 9:16) = ' EQEX ' 61 : MOTERR(17:24) = ' KIZX ' 61 : CALL ERREUR(786) 62 : RETURN 63 : ENDIF 64 : C 65 : C- Récupération de la table INCO (pointeur KINC) 66 : C 66 : CALL LEKTAB(MTAB1,'INCO',KINC) 67 : IF(KINC.EQ.0)THEN 68 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 69 : MOTERR( 1: 8) = ' INCO ' 70 : MOTERR( 9:16) = ' INCO ' 71 : MOTERR(17:24) = ' EQEX ' 71 : CALL ERREUR(786) 72 : RETURN 73 : ENDIF 74 : 75 : C************************************************************************* 76 : C OPTIONS 77 : C KIMPL = 0 -> EXPL 1 -> IMPL 2 -> CN 78 : C KFORM = 0 -> EFSI 1 -> EF 2 -> VF 3 -> EFMC 79 : C KPRE=3 pression P0 KPRE=4 pression P1 KPRE=2 cas macro 1ère génération 80 : 81 : IAXI=0 82 : IK=0 83 : IF(IFOMOD.EQ.0)IAXI=2 84 : C 85 : C- Récupération de la table des options KOPT (pointeur KOPTI) 86 : C 86 : CALL LEKTAB(MTABX,'KOPT',KOPTI) 87 : IF (KOPTI.EQ.0) THEN 88 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 89 : MOTERR( 1: 8) = ' KOPT ' 90 : MOTERR( 9:16) = ' KOPT ' 91 : MOTERR(17:24) = ' KIZX ' 91 : CALL ERREUR(786) 92 : RETURN 93 : ENDIF 94 : 94 : CALL ACME(KOPTI,'KIMPL',KIMPL) 94 : CALL ACME(KOPTI,'KPOIN',KPRE) 94 : CALL ACMF(KOPTI,'AIMPL',TETA1) 94 : CALL ACME(KOPTI,'KFORM',KFORM) 95 : 96 : IF (IERR.NE.0) RETURN 97 : C write(6,*)' Apres les options ' 98 : C************************************************************************* 99 : C 100 : C- Récupération de la table DOMAINE associée au domaine local 101 : C 101 : CALL ACMM(MTABX,'NOMZONE',NOMZ) 101 : CALL LEKTAB(MTABX,'DOMZ',MTABZ) 102 : IF(MTABZ.EQ.0)THEN 103 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 104 : MOTERR( 1: 8) = ' DOMZ ' 105 : MOTERR( 9:16) = ' DOMZ ' 106 : MOTERR(17:24) = ' KIZX ' 106 : CALL ERREUR(786) 107 : RETURN 108 : ENDIF 109 : 109 : CALL LEKTAB(MTABZ,'MAILLAGE',MELEME) 109 : CALL LEKTAB(MTABZ,'SOMMET',MELEMS) 109 : CALL LEKTAB(MTABZ,'CENTRE',MELEMC) 109 : CALL LEKTAB(MTABZ,'MACRO',MACRO) 110 : MACRO1=0 110 : IF(MACRO.NE.0)CALL LEKTAB(MTABZ,'MACRO1',MACRO1) 111 : C write(6,*)' KMIC : MACRO1=',macro1 111 : CALL LEKTAB(MTABZ,'QUADRATI',MQUAD) 112 : C write(6,*)' KMIC : MQUAD=',MQUAD 113 : IF (IERR.NE.0) RETURN 114 : 115 : MELEMI=MELEME 116 : IF(MACRO1.NE.0.AND.KPRE.NE.2)THEN 116 : C? CALL KMACRO(MACRO,MELEMM,MTABZ) 117 : C? MELEMI=MELEMM 118 : MELEMI=MACRO1 119 : ENDIF 120 : 121 : IF(KPRE.EQ.2.AND.MACRO1.EQ.0)KPRE=3 122 : IF(MQUAD.EQ.0.AND.MACRO1.EQ.0)KPRE=2 123 : 124 : IF(KPRE.EQ.3)THEN 124 : CALL LEKTAB(MTABZ,'CENTREP0',MELEMC) 125 : MELEMP=MELEMC 126 : ELSEIF(KPRE.EQ.4)THEN 126 : CALL LEKTAB(MTABZ,'CENTREP1',MELEMC) 126 : CALL LEKTAB(MTABZ,'ELTP1NC ',MELEMP) 127 : ELSEIF(KPRE.EQ.2)THEN 127 : CALL LEKTAB(MTABZ,'CENTRE',MELEMC) 128 : MELEMP=MELEMC 129 : ENDIF 130 : 131 : C************************************************************************* 132 : C VERIFICATIONS SUR LES INCONNUES 133 : 134 : C write(6,*)' Verification sur les inconnues ' 135 : TYPE='LISTMOTS' 135 : CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO) 136 : IF(LINCO.EQ.0)GO TO 90 137 : SEGACT LINCO 138 : NBINC=LINCO.MOTS(/2) 139 : IF(NBINC.NE.2)THEN 140 : WRITE(6,*)'Operateur KMAC ' 141 : WRITE(6,*)'Nombre d''inconnues incorrecte : ',NBINC,' On attend 2' 142 : C Indice %m1:8 : contient plus de %i1 %m9:16 143 : MOTERR( 1:8) = 'LISTINCO' 144 : INTERR(1) = 2 145 : MOTERR(9:16) = ' MOTS ' 145 : CALL ERREUR(799) 146 : RETURN 147 : ENDIF 148 : 149 : C On recupere PHI n et TETA n pour Cranck-Nicholson 150 : NOMP=LINCO.MOTS(1) 151 : TYPE=' ' 151 : CALL ACMO(KINC,NOMP,TYPE,MCHPOI) 152 : IF(TYPE.NE.'CHPOINT ')THEN 153 : WRITE(6,*)' Opérateur KMAC :' 154 : WRITE(6,*)' L objet CHPOINT ',NOMP, 155 : & ' n existe pas dans la table' 156 : C Indice %m1:8 : ne contient pas un objet de type %m9:16 157 : MOTERR( 1: 8) = 'INC '//NOMP 158 : MOTERR( 9:16) = 'CHPOINT ' 158 : CALL ERREUR(800) 159 : RETURN 160 : ELSE 160 : CALL LICHT(MCHPOI,IZTU1,TYPC,IGEOM0) 161 : ENDIF 162 : C************************************************************************* 163 : C Le domaine de definition est donne par le SPG de la premiere inconnue 164 : C Les inconnues suivantes devront posseder ce meme pointeur 165 : C On verifie que les points de la zone sont tous inclus dans ce SPG 166 : C Inconnue Primale 167 : 168 : C write(6,*)' Verification inconnue primale ' 168 : CALL KRIPAD(IGEOM0,MLENTI) 169 : IF(IKAS.EQ.1.OR.IKAS.EQ.3)THEN 170 : MELEMK=MELEMS 171 : ELSE 172 : MELEMK=MELEMC 173 : ENDIF 174 : 174 : CALL VERPAD(MLENTI,MELEMK,IRET) 175 : IF(IRET.NE.0)THEN 176 : WRITE(6,*)' Opérateur KMAC ' 177 : WRITE(6,*)' La zone ',NOMZ,' n''est pas incluse dans le domaine' 178 : & , ' de définition de l''inconnue ',NOMP 179 : WRITE(6,*)' MELEMK=',melemk,' IGEOM0=',IGEOM0 180 : C Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique 181 : MOTERR(1: 8) = 'INC '//NOMP 182 : MOTERR(9:16) = 'CHPOINT ' 182 : CALL ERREUR(788) 183 : IPAS=0 184 : RETURN 185 : ENDIF 186 : 187 : SEGSUP MLENTI 188 : 189 : C************************************************************************* 190 : 191 : NOMD=LINCO.MOTS(2) 192 : TYPE=' ' 192 : CALL ACMO(KINC,NOMD,TYPE,MCHPOI) 193 : IF(TYPE.NE.'CHPOINT ')THEN 194 : WRITE(6,*)' Opérateur KMAC :' 195 : WRITE(6,*)' L objet CHPOINT ',NOMD, 196 : & ' n existe pas dans la table' 197 : C Indice %m1:8 : ne contient pas un objet de type %m9:16 198 : MOTERR( 1: 8) = 'INC '//NOMD 199 : MOTERR( 9:16) = 'CHPOINT ' 199 : CALL ERREUR(800) 200 : RETURN 201 : ELSE 201 : CALL LICHT(MCHPOI,TETAN,TYPC,IGEOM0) 202 : ENDIF 203 : 204 : NC=TETAN.VPOCHA(/2) 205 : C************************************************************************* 206 : C Le domaine de definition est donne par le SPG de la premiere inconnue 207 : C Les inconnues suivantes devront posseder ce meme pointeur 208 : C On verifie que les points de la zone sont tous inclus dans ce SPG 209 : C Inconnue Duale 210 : 211 : C write(6,*)' IGEOM0=',igeom0 211 : CALL KRIPAD(IGEOM0,MLENTI) 212 : IF(IKAS.EQ.1.OR.IKAS.EQ.3)THEN 213 : MELEMK=MELEMC 214 : ELSE 215 : MELEMK=MELEMS 216 : ENDIF 217 : 218 : C write(6,*)' Verification inconnue duale ',MELEMK 218 : CALL VERPAD(MLENTI,MELEMK,IRET) 219 : IF(IRET.NE.0)THEN 220 : WRITE(6,*)' Opérateur KMAC ' 221 : WRITE(6,*)' La zone ',NOMZ,' n''est pas incluse dans le domaine' 222 : & ,' de définition de l''inconnue ',NOMD 223 : WRITE(6,*)' MELEMK=',melemk,' IGEOM0=',IGEOM0 224 : C Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique 225 : MOTERR(1: 8) = 'INC '//NOMD 226 : MOTERR(9:16) = 'CHPOINT ' 226 : CALL ERREUR(788) 227 : IPAS=0 228 : RETURN 229 : ENDIF 230 : 231 : SEGSUP MLENTI 232 : 233 : C************************************************************************* 234 : C Lecture du ou des coefficients 235 : C Type du coefficient : 236 : C IK1=0 CHPOINT IK1=1 scalaire IK1=2 vecteur 237 : 238 : C write(6,*)' Verification sur les coefficients ' 238 : CALL ACME(MTABX,'IARG',IARG) 239 : 240 : IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.2)THEN 241 : C? MELEMM=MACRO 242 : TYPE=' ' 242 : CALL ACMO(MTABZ,'MELSTB',TYPE,MELSTB) 243 : SEGACT MELSTB 244 : NBELEM=MELSTB.NUM(/2)/4 245 : NBNN=MELSTB.NUM(/1) 246 : NBSOUS=0 247 : NBREF=0 248 : SEGINI MELEMA 249 : MELEMA.ITYPEL=MELSTB.ITYPEL 250 : 251 : NKPE=4 252 : IF(IDIM.EQ.3)NKPE=8 253 : do 4878 k=1,nbelem 254 : mi=(k-1)*NKPE+1 255 : do 4879 i=1,nbnn 256 : MELEMA.num(i,k)=melstb.num(i,mi) 257 : 4879 continue 258 : C write(6,*)k,(MELEMA.num(i,k),i=1,nbnn) 259 : 4878 continue 260 : 261 : TYPE=' ' 261 : CALL ACMO(MTABZ,'MCHPOC',TYPE,MCHPOC) 262 : TYPE=' ' 262 : CALL ACMO(MTABZ,'CENTRE',TYPE,MCTREI) 263 : ENDIF 264 : 265 : 266 : C 1er COEF 267 : 268 : IXV(1)=MELEMC 269 : IXV(2)=1 270 : IXV(3)=0 270 : CALL LEKCOF('Opérateur KMAC :', 271 : & MTABX,KINC,1,IXV,IZTG1,IZTGG1,NPT1,NC1,IK1,IRET) 272 : IF(IRET.EQ.0)RETURN 273 : 274 : IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.2)THEN 275 : C 2ème COEF 276 : IXV(1)=0 277 : IXV(2)=1 278 : IXV(3)=0 278 : CALL LEKCOF('Opérateur KMAC :', 279 : & MTABX,KINC,2,IXV,IZTG2,IZBETA,NPT2,NC2,IK2,IRET) 280 : IF(IRET.EQ.0)RETURN 281 : ENDIF 282 : 283 : 284 : NOMP=LINCO.MOTS(1) 285 : NOMD=LINCO.MOTS(2)(1:4) 286 : 287 : NRIGE=7 288 : NKID =9 289 : NKMT =7 290 : NMATRI=1 291 : IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.2)NMATRI=2 292 : SEGINI MATRIK 293 : 294 : C CAS Stabilisation via MACRO 295 : IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.2)THEN 296 : I2=2 297 : NBME=1 298 : NBSOUS=1 299 : SEGINI IMATRI 300 : IRIGEL(4,i2)=IMATRI 301 : KSPGP=MCTREI 302 : KSPGD=MCTREI 303 : IRIGEL(1,i2)=MELEMA 304 : IRIGEL(2,i2)=MELEMA 305 : IRIGEL(7,i2)=0 305 : CALL LICHT(MCHPOC,MPOVAL,TYPC,IGEOM) 306 : 307 : SEGACT MELSTB 308 : NBSOUS=MELSTB.LISOUS(/1) 309 : IF(NBSOUS.NE.0)THEN 309 : CALL ERREUR(5) 310 : ENDIF 311 : 312 : C? SEGACT MELEMM 313 : NBEL=MELEMA.NUM(/2) 314 : NBCI=MELSTB.NUM(/2) 315 : NP =MELSTB.NUM(/1) 316 : MP =NP 317 : 318 : SEGINI IZAFM 319 : LIZAFM(1,1)=IZAFM 320 : LISPRI(1)=NOMD 321 : LISDUA(1)=NOMD 322 : 322 : CALL KRIPAD(MCTREI,MLENTI) 323 : 324 : DO 33 K=1,NBEL 325 : 326 : DO 32 J=1,NP 327 : K1=LECT(MELEMA.NUM(J,K)) 328 : ii=j 329 : do 321 i=1,np 330 : u=VPOCHA(K1,I)*IZBETA.VPOCHA(1,1) 331 : if(i.eq.1)u=abs(VPOCHA(K1,I))*IZBETA.VPOCHA(1,1) 332 : if(ii.le.np)then 333 : AM(K,II,J)=U 334 : else 335 : AM(K,II-NP,J)=U 336 : endif 337 : ii=ii+1 338 : 321 continue 339 : 32 CONTINUE 340 : 33 CONTINUE 341 : SEGSUP MLENTI 342 : ENDIF 343 : 344 : 345 : NBME=IDIM 346 : C write(6,*)'MELEMI=',MELEMI 346 : CALL KRIPAD(MELEMI,MLENTI1) 347 : SEGACT MELEMI 348 : NBSOUS=MELEMI.LISOUS(/1) 349 : IF(NBSOUS.EQ.0)NBSOUS=1 350 : SEGINI IMATRI 351 : 352 : IF(IKAS.EQ.2)THEN 353 : KSPGD=MELEMS 354 : KSPGP=MELEMC 355 : IRIGEL(2,1)=MELEMI 356 : IRIGEL(1,1)=MELEMP 357 : ELSE 358 : KSPGP=MELEMS 359 : KSPGD=MELEMC 360 : IRIGEL(1,1)=MELEMI 361 : IRIGEL(2,1)=MELEMP 362 : ENDIF 363 : SEGACT MELEMP 364 : 365 : C write(6,*)' ds kmac melemp=',IRIGEL(1,1) 366 : C write(6,*)' ds kmac melemd=',IRIGEL(2,1) 367 : 368 : IRIGEL(4,1)=IMATRI 369 : IF(IKAS.EQ.1)IRIGEL(7,1)=3 370 : IF(IKAS.EQ.2)IRIGEL(7,1)=3 371 : IF(IKAS.EQ.3)IRIGEL(7,1)=4 372 : 373 : NK=0 374 : DO 11 L=1,NBSOUS 375 : IPT1=MELEMI 376 : IF(NBSOUS.NE.1)IPT1=MELEMI.LISOUS(L) 377 : SEGACT IPT1 378 : NBEL=IPT1.NUM(/2) 379 : 380 : IF(IKAS.EQ.2)THEN 381 : MP=IPT1.NUM(/1) 382 : NP=MELEMP.NUM(/1) 383 : ELSE 384 : NP=IPT1.NUM(/1) 385 : MP=MELEMP.NUM(/1) 386 : ENDIF 387 : 388 : DO 12 I=1,NBME 389 : SEGINI IZAFM 390 : C write(6,*)' ni izafm np=',np,' mp=',mp,' nbel=',nbel,izafm,l,i 391 : LIZAFM(L,I)=IZAFM 392 : IF(IKAS.EQ.2)THEN 393 : WRITE(NOM,FMT='(I1,A3)')I,NOMD(1:3) 394 : LISDUA(I)=NOM//' ' 395 : LISPRI(I)=NOMP 396 : ELSE 397 : WRITE(NOM,FMT='(I1,A3)')I,NOMP(1:3) 398 : LISPRI(I)=NOM//' ' 399 : LISDUA(I)=NOMD 400 : ENDIF 401 : 12 CONTINUE 402 : IPM1=LIZAFM(L,1) 403 : IPM2=LIZAFM(L,2) 404 : IPM3=LIZAFM(L,2) 405 : IF(IDIM.EQ.3)IPM3=LIZAFM(L,3) 406 : 407 : C write(6,*)' AVt KPRISS MACRO1=',MACRO1,KPRE 407 : CALL KPRISS(IPT1,IPM1,IPM2,IPM3,IAXI,IKAS,MACRO1,KPRE) 408 : C write(6,*)' APR KPRISS' 409 : C ============================= 410 : C Option Cranck-Nickolson 411 : 412 : C ************** TETA1 **** 413 : IF (KIMPL.NE.2) TETA1=1.0D0 414 : C ************************* 415 : C On recupere le coeficient devant la matrice 416 : 417 : IF (KIMPL.EQ.2) THEN 418 : 419 : C write(6,*)' MELEMC=',melemc 419 : CALL KRIPAD(MELEMC,MLENTI2) 420 : XV=IZTGG1.VPOCHA(1,1) 421 : SEGACT IPT1 422 : SEGACT MELEMC 423 : SEGACT IPM1,IPM2,IPM3 424 : NAT=2 425 : NSOUPO=1 426 : N=MELEMC.NUM(/2) 427 : 428 : C NC=1 429 : C On initialise les segments necessaire a la conception 430 : C du second membre 431 : SEGINI MCHPO1,MSOUP1,MPOVA1 432 : MCHPO1.IFOPOI=IFOMOD 433 : MCHPO1.MOCHDE=TITREE 434 : MCHPO1.MTYPOI='SMBR' 435 : MCHPO1.JATTRI(1)=2 436 : MCHPO1.IPCHP(1)=MSOUP1 437 : DO LN=1,NC 438 : MSOUP1.NOCOMP(LN)=LISDUA(LN)(1:4) 439 : END DO 440 : MSOUP1.IGEOC=MELEMC 441 : MSOUP1.IPOVAL=MPOVA1 442 : 443 : SEGACT IZTU1 444 : SEGACT MLENTI1,MLENTI2 445 : 446 : KAUX=XV*(1.0D0-TETA1) 447 : c DO K=1,NBEL 448 : c IK=IK+1 449 : c DO I=1,NP 450 : c IPAD=MLENTI2.LECT(MELEMC.NUM(1,IK)) 451 : C Par securite on met a zero le second membre a ajouter 452 : c MPOVA1.VPOCHA(IPAD,1)=0.0D0 453 : c END DO 454 : c END DO 455 : 456 : DO K=1,NBEL 457 : IK=IK+1 458 : DO I=1,NP 459 : DO J=1,MP 460 : 461 : C On recupere les bonnes valeurs pour la localisation dans la 462 : C matrice pour le produit matriciel. 463 : IPAD=MLENTI2.LECT(MELEMC.NUM(J,IK)) 464 : IPAD2=MLENTI1.LECT(IPT1.NUM(I,K)) 465 : 466 : C On effectue le produit matriciel 467 : MPOVA1.VPOCHA(IPAD,1)=MPOVA1.VPOCHA(IPAD,1)- 468 : & IPM1.AM(K,I,J)*IZTU1.VPOCHA(IPAD2,1)*KAUX 469 : IF (IDIM.GT.1) THEN 470 : MPOVA1.VPOCHA(IPAD,1)=MPOVA1.VPOCHA(IPAD,1)- 471 : & IPM2.AM(K,I,J)*IZTU1.VPOCHA(IPAD2,2)*KAUX 472 : END IF 473 : IF (IDIM.GT.2) THEN 474 : MPOVA1.VPOCHA(IPAD,1)=MPOVA1.VPOCHA(IPAD,1)- 475 : & IPM3.AM(K,I,J)*IZTU1.VPOCHA(IPAD2,3)*KAUX 476 : END IF 477 : END DO 478 : END DO 479 : END DO 480 : 481 : SEGDES IPM1,IPM2,IPM3 482 : SEGSUP MLENTI1,MLENTI2 483 : SEGDES MELEMC,IZTU1 484 : SEGDES MCHPO1,MSOUP1,MPOVA1 485 : C On ajoute le second membre a l'ancien (s'il y en avait un). 486 : TYPE=' ' 486 : CALL ACMO(MTAB1,'SMBR',TYPE,MCHPO2) 487 : C write(6,*)' SMBR ',type 488 : IF(TYPE.NE.'CHPOINT')THEN 489 : C write(6,*)' On cree un 1er SMBR ' 489 : CALL ECMO(MTAB1,'SMBR','CHPOINT',MCHPO1) 490 : ELSE 490 : CALL ECROBJ('CHPOINT',MCHPO2) 490 : CALL ECROBJ('CHPOINT',MCHPO1) 490 : CALL PRFUSE 490 : C ? CALL OPERAD 490 : CALL LIROBJ('CHPOINT',MCHPOI,1,IRET) 490 : C CALL DTRCHP(MCHPO1) 490 : C CALL DTRCHP(MCHPO2) 491 : C write(6,*)' On cree un SMBR ' 491 : CALL ECMO(MTAB1,'SMBR','CHPOINT',MCHPOI) 492 : ENDIF 493 : END IF 494 : C =================================== 495 : SEGACT IPT1,IPM1*MOD,IPM2*MOD,IPM3*MOD 496 : NBEL=IPT1.NUM(/2) 497 : NP=IPM1.AM(/2) 498 : MP=IPM1.AM(/3) 499 : DO 23 K=1,NBEL 500 : NK=NK+1 501 : K1=1+(1-IK1)*(NK-1) 502 : XV=IZTGG1.VPOCHA(K1,1) 503 : 504 : DO 24 I=1,NP 505 : DO 24 J=1,MP 506 : IF (KIMPL.NE.2) THEN 507 : IPM1.AM(K,I,J)=IPM1.AM(K,I,J)*XV 508 : IPM2.AM(K,I,J)=IPM2.AM(K,I,J)*XV 509 : ELSE 510 : IPM1.AM(K,I,J)=TETA1*IPM1.AM(K,I,J)*XV 511 : IPM2.AM(K,I,J)=TETA1*IPM2.AM(K,I,J)*XV 512 : END IF 513 : 24 CONTINUE 514 : IF(IDIM.EQ.3)THEN 515 : DO 25 I=1,NP 516 : DO 25 J=1,MP 517 : IF (KIMPL.NE.2) THEN 518 : IPM3.AM(K,I,J)=IPM3.AM(K,I,J)*XV 519 : ELSE 520 : IPM3.AM(K,I,J)=TETA1*IPM3.AM(K,I,J)*XV 521 : END IF 522 : 25 CONTINUE 523 : ENDIF 524 : 23 CONTINUE 525 : 526 : SEGDES IPM1,IPM2,IPM3 527 : SEGDES IPT1 528 : 11 CONTINUE 529 : SEGDES MELEMI 529 : CALL ECMO(MTABX,'MATELM','MATRIK',MATRIK) 530 : 531 : C write(6,*)' Fin operateur KMIC' 532 : SEGDES IMATRI,MATRIK 533 : RETURN 534 : 90 CONTINUE 535 : WRITE(6,*)' Interruption anormale de KMAC ' 536 : C Option %m1:8 incompatible avec les données 536 : CALL ERREUR(803) 537 : RETURN 538 : 1001 FORMAT(20(1X,I5)) 539 : END 540 : 541 : 542 : 543 : 544 : 545 : 546 : 547 : 548 :
© Cast3M 2003 - All rights reserved.
Disclaimer