1 : C KOPS SOURCE MAGN 13/03/21 21:15:02 7734 2 : C Retour à la version de Stéphane 3 : C KOPS SOURCE GOUNAND 11/05/25 21:15:20 6980 4 : SUBROUTINE KOPS 5 : C************************************************************************* 6 : C 7 : C cet operateur effectue des operations speciales entre les CHPOINT-TRIO 8 : C 9 : C 10 : C 11 : C 12 : C************************************************************************* 13 : 14 : IMPLICIT INTEGER(I-N) 15 : IMPLICIT REAL*8 (A-H,O-Z) 16 : 17 : -INC CCOPTIO 18 : -INC SMTABLE 19 : -INC SMLMOTS 20 : -INC SMLENTI 21 : -INC SMELEME 22 : POINTEUR MELEMC.MELEME 23 : -INC SMCOORD 24 : 25 : -INC SMMATRIK 26 : POINTEUR MAT1.MATRIK,MAT2.MATRIK,MAT3.MATRIK,IMAT1.IMATRI 27 : 28 : * -INC SMRIGID 29 : * 30 : * OBJET RIGIDITE 31 : * 32 : SEGMENT STCOUP 33 : INTEGER MCOUP(nicd,nicp) 34 : ENDSEGMENT 35 : 36 : SEGMENT MRIGID 37 : CHARACTER*8 MTYMAT 38 : REAL*8 COERIG(NRIGEL) 39 : INTEGER JRIGEL(8,NRIGEL) 40 : INTEGER ICHOLE,IMGEO1,IMGEO2,IFORIG 41 : INTEGER ISUPEQ,JRCOND,JRDEPP,JRDEPD 42 : INTEGER JRELIM,JRGARD,JRTOT,IMLAG 43 : INTEGER IPROFO,IVECRI 44 : ENDSEGMENT 45 : -INC SMCHPOI 46 : C POINTEUR IZV1.MCHPOI,IZVV1.MPOVAL 47 : C POINTEUR IZV2.MCHPOI,IZVV2.MPOVAL 48 : 49 : DIMENSION XVEC(3),ITINC(100) 50 : INTEGER JMOTS 51 : CHARACTER*8 TYPE,TYPC,TYPE1,TYPE2 52 : PARAMETER (NBOP=32) 53 : CHARACTER*4 MOT4,NOMTOT(10) 54 : CHARACTER*8 LOPER(NBOP),MTYP,NOMI,NOM,NOMC,NOMK,LXNM 55 : CHARACTER*8 NOMKP,NOMKD 56 : CHARACTER*8 BLAN 57 : DATA BLAN/' '/ 58 : DATA LOPER/'MULT ','DIVI ','PSRN ','PSCA ','ET ', 59 : & '* ','/ ','+ ','- ','** ', 60 : & '|< ','>| ','GRAD ','ROT ','CLIM ', 61 : & 'INV ','MATRAK ','MATRIK ','VNIMP ','VTIMP ', 62 : & 'MTABX ','CMCTSPLT','MATIDE ','RIGIDITE','GRADS ', 63 : & 'EXTRCOMP','EXTRMASS','EXTRPREC','CHANINCO','TRANSPOS', 64 : & 'MATDIAGO','EXTRCOUP'/ 65 : C*** 66 : JMOTS=0 67 : NAG=0 68 : NBMAT=0 69 : IKASS=0 70 : MCHPO1=0 71 : MCHPO2=0 72 : MCHPOI=0 73 : XVAL1=0.D0 74 : XVAL2=0.D0 75 : NFLOT=0 76 : MTABD=0 77 : 78 : C ******************************************** 79 : C * La premiere partie de cette routine * 80 : C * consiste a recuperer les arguments de * 81 : C * l operateur KOPS afin de pouvoir leurs * 82 : C * attribuer le traitement correspondant * 83 : C ******************************************** 84 : 85 : 10 CONTINUE 86 : C On saisit le premier objet de la pile 87 : C ************************************* 88 : 88 : CALL QUETYP(MTYP,0,IRET) 89 : IF(IRET.EQ.0)GO TO 9 90 : C write(6,*)' KOPS nag=',NAG,' MTYP=',MTYP 91 : 92 : C ============================================ 93 : C Cas : Objet = MOT 94 : C ============================================ 95 : IF(MTYP.EQ.'MOT')THEN 96 : JMOTS=1 97 : 97 : C? CALL LIRCHA(MMOP,1,NBC) 97 : C? CALL OPTLI(KOP,LOPER,MMOP,NBOP) 98 : 98 : CALL LIRMOT(LOPER,NBOP,KOP,0) 99 : C write(6,*)' KOPS ',LOPER(KOP) 100 : IF(KOP.EQ.0)THEN 100 : CALL RYO2V(IRET) 101 : IF(IRET.EQ.0)RETURN 102 : WRITE(6,*)' Opérateur KOPS :',KOP 103 : WRITE(6,*)' Operation inconnue ' 104 : RETURN 105 : ENDIF 106 : 107 : C Cas tres tres particulier(s) 108 : 109 : C CAS KOP=17 110 : IF(KOP.EQ.17)THEN 111 : NRIGE=8 112 : NMATRI=0 113 : NKID =9 114 : NKMT =7 115 : SEGINI MATRIK 116 : SEGDES MATRIK 116 : CALL ECROBJ('MATRIK',MATRIK) 117 : 118 : RETURN 119 : ENDIF 120 : 121 : C CAS KOP=18 122 : IF(KOP.EQ.18)THEN 123 : NRIGE=7 124 : NMATRI=0 125 : NKID =9 126 : NKMT =7 127 : SEGINI MATRIK 128 : SEGDES MATRIK 128 : CALL ECROBJ('MATRIK',MATRIK) 129 : 130 : NAT=2 131 : NSOUPO=0 132 : SEGINI MCHPOI 133 : JATTRI(1)=2 134 : IFOPOI = IFOUR 135 : SEGDES MCHPOI 135 : CALL ECROBJ('CHPOINT',MCHPOI) 136 : 137 : RETURN 138 : ENDIF 139 : 140 : C CAS KOP=19 141 : IF(KOP.EQ.19)THEN 142 : 142 : CALL VNIMP 143 : 144 : RETURN 145 : ENDIF 146 : 147 : C CAS KOP=20 148 : IF(KOP.EQ.20)THEN 149 : 149 : CALL VTIMP 150 : 151 : RETURN 152 : ENDIF 153 : 154 : C CAS KOP=21 MTABX 155 : IF(KOP.EQ.21)THEN 156 : 156 : CALL LIROBJ('TABLE',MTABX,1,IRET) 157 : IF(IRET.EQ.0)RETURN 157 : CALL LIRREE(DTR,1,IRET) 158 : IF(IRET.EQ.0)RETURN 159 : KKIZG=0 160 : TYPE=' ' 160 : CALL ACMO(MTABX,'KIZG',TYPE,KIZG) 161 : IF(KIZG.NE.0)THEN 162 : TYPE=' ' 162 : CALL ACMO(MTABX,'LISTINCO',TYPE,MLMOTS) 163 : IF(MLMOTS.EQ.0)RETURN 164 : SEGACT MLMOTS 165 : NBMOT=MOTS(/2) 166 : DO 36476 I=1,NBMOT 167 : NOMI=MOTS(I) 168 : TYPE=' ' 168 : CALL ACMO(KIZG,NOMI,TYPE,MCHPOI) 169 : IF(TYPE.NE.'CHPOINT')GO TO 36476 170 : SEGACT MCHPOI 171 : NSOUPO=IPCHP(/1) 172 : IF(NSOUPO.NE.1)RETURN 173 : MSOUPO=IPCHP(1) 174 : SEGACT MSOUPO 175 : NC=NOCOMP(/2) 176 : DO 36477 J=1,NC 177 : IF(NC.NE.1.AND.NC.LT.10)THEN 178 : WRITE(MOT4,FMT='(I1,A3)')J,NOMI(1:3) 179 : ELSEIF(NC.EQ.1)THEN 180 : WRITE(MOT4,FMT='(A4)')NOMI 181 : ELSE 182 : RETURN 183 : ENDIF 184 : NOCOMP(J)=MOT4 185 : 36477 CONTINUE 186 : KKIZG=1 186 : CALL ECROBJ('CHPOINT ',MCHPOI) 186 : CALL ECRREE(-1.D0) 186 : CALL OPERMU 186 : IF(I.GT.1)CALL OPERAD 187 : 36476 CONTINUE 188 : ENDIF 189 : 190 : IF(KKIZG.NE.0)THEN 190 : CALL ECRREE(DTR) 190 : CALL OPERMU 191 : ENDIF 192 : 193 : TYPE=' ' 193 : CALL ACMO(MTABX,'SMBR',TYPE,MCHPOI) 194 : IF(TYPE.EQ.'CHPOINT')THEN 194 : CALL ECROBJ('CHPOINT ',MCHPOI) 194 : IF(KKIZG.NE.0)CALL OPERAD 195 : ELSE 195 : IF(KKIZG.EQ.0)CALL ECRREE(1.D0) 196 : ENDIF 197 : 197 : CALL ECME(MTABX,'SMBR',1) 198 : 199 : RETURN 200 : ENDIF 201 : 202 : C CAS KOP=22 203 : IF(KOP.EQ.22)THEN 204 : 204 : CALL SPLTCC 205 : 206 : RETURN 207 : ENDIF 208 : 209 : C KAS KOP=23 ('MATIDE') 210 : 211 : IF(KOP .EQ. 23)THEN 211 : CALL KOPSID 212 : RETURN 213 : ENDIF 214 : 215 : C CAS KOP=24 216 : IF(KOP.EQ.24)THEN 217 : NRIGE=8 218 : NRIGEL=0 219 : SEGINI MRIGID 220 : SEGDES MRIGID 220 : CALL ECROBJ('RIGIDITE',MRIGID) 221 : 222 : NAT=2 223 : NSOUPO=0 224 : SEGINI MCHPOI 225 : JATTRI(1)=2 226 : IFOPOI = IFOUR 227 : SEGDES MCHPOI 227 : CALL ECROBJ('CHPOINT',MCHPOI) 228 : 229 : RETURN 230 : ENDIF 231 : C 232 : C CAS KOP=25 'GRADS' 233 : IF(KOP.EQ.25)THEN 234 : GO TO 10 235 : ENDIF 236 : C 237 : C CAS KOP=26 'EXTRCOMP' 238 : IF(KOP.EQ.26)THEN 238 : CALL LIRCHA(NOMC,1,IRET) 238 : CALL LIRCHA(NOMK,1,IRET) 239 : IF(IRET.EQ.0)RETURN 239 : CALL LIROBJ('MATRIK',MAT1,1,IRET) 240 : IF(IRET.EQ.0)RETURN 241 : 242 : SEGACT MAT1 243 : NRIGE =MAT1.IRIGEL(/1) 244 : NMATRI=MAT1.IRIGEL(/2) 245 : NMATRI=0 246 : NKID =MAT1.KIDMAT(/1) 247 : NKMT =MAT1.KKMMT(/1) 248 : SEGINI MATRIK 248 : CALL RSETI(KIDMAT,MAT1.KIDMAT,NKID) 248 : CALL RSETI(KKMMT ,MAT1.KKMMT ,NKMT) 249 : KSYM = MAT1.KSYM 250 : mincp= MAT1.KMINC 251 : if(mincp.ne.0)then 252 : segact mincp 253 : nbi= mincp.LISINC(/2) 254 : npt= mincp.NPOS(/1)-1 255 : segini minc 255 : call rseti(npos,mincp.npos,npt+1) 255 : call rseti(mpos,mincp.mpos,(npt*(nbi+1))) 256 : lisinc(1)=NOMK 257 : if(nbi.ne.1)then 258 : write(6,*)' Gross Pb NBI=',nbi 259 : write(6,*)(mincp.lisinc(ii),ii=1,nbi) 259 : call arret (0) 260 : endif 261 : KMINC = minc 262 : KMINCP= minc 263 : KMINCD= minc 264 : endif 265 : 266 : KIZM = MAT1.KIZM 267 : 268 : KISPGT= MAT1.KISPGT 269 : KISPGP= MAT1.KISPGP 270 : KISPGD= MAT1.KISPGD 271 : 272 : KNTTT = MAT1.KNTTT 273 : KNTTP = MAT1.KNTTP 274 : KNTTD = MAT1.KNTTD 275 : 276 : NMATR1=MAT1.IRIGEL(/2) 277 : c write(6,*)'NMATR1=',NMATR1 278 : do 6432 lm=1, NMATR1 279 : IMAT1=MAT1.irigel(4,lm) 280 : segact imat1 281 : nbmf=IMAT1.LISPRI(/2) 282 : c write(6,*)' NBMF=',nbmf 283 : 284 : LXNM='LX'//NOMC(1:2) 285 : do 6433 lmf=1,nbmf 286 : NOMKP=NOMK 287 : NOMKD=NOMK 288 : if(NOMC.eq.IMAT1.LISPRI(lmf) 289 : & .OR.LXNM.eq.IMAT1.LISPRI(lmf))then 290 : if(LXNM.eq.IMAT1.LISPRI(lmf))NOMKP='LX'//NOMK(1:2) 291 : 292 : if(NOMC.NE.IMAT1.LISDUA(lmf) 293 : & .AND.LXNM.NE.IMAT1.LISDUA(lmf))then 294 : write(6,*)' On a perdu ', nomc,lmf 294 : call erreur(153) 295 : return 296 : endif 297 : if(LXNM.eq.IMAT1.LISDUA(lmf))NOMKD='LX'//NOMK(1:2) 298 : NMATRI=NMATRI+1 299 : segadj MATRIK 300 : do 6434 i7=1,7 301 : irigel(i7,nmatri)=mat1.irigel(i7,lm) 302 : 6434 continue 303 : 304 : nbme=1 305 : nbsous=IMAT1.lizafm(/1) 306 : segini IMATRI 307 : irigel(4,nmatri)=IMATRI 308 : KSPGP=IMAT1.KSPGP 309 : KSPGD=IMAT1.KSPGD 310 : LISPRI(1)=NOMKP 311 : LISDUA(1)=NOMKD 312 : do 6435 is=1,nbsous 313 : LIZAFM(is,1)=IMAT1. LIZAFM(is,lmf) 314 : 6435 continue 315 : 316 : 317 : endif 318 : 6433 continue 319 : 6432 continue 320 : 321 : SEGDES MATRIK 321 : CALL ECROBJ('MATRIK',MATRIK) 322 : RETURN 323 : ENDIF 324 : C 325 : C 326 : C CAS KOP=32 'EXTRCOUP' 327 : IF(KOP.EQ.32)THEN 327 : CALL LIROBJ('MATRIK',MAT1,1,IRET) 328 : IF(IRET.EQ.0)RETURN 328 : CALL ECROBJ('MATRIK',MAT1) 328 : CALL EXTIPD 328 : CALL LIROBJ('LISTMOTS',MLMOT1,1,IRET) 328 : CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET) 329 : SEGACT MLMOT1 330 : SEGACT MLMOT2 331 : nicp=MLMOT1.MOTS(/2) 332 : nicd=MLMOT2.MOTS(/2) 333 : SEGINI STCOUP 333 : CALL INITI(MCOUP,(nicp*nicd),0) 334 : * write(6,*)(MLMOT1.MOTS(ii),ii=1,nicp) 335 : * write(6,*)(MLMOT2.MOTS(ii),ii=1,nicd) 336 : 337 : SEGACT MAT1 338 : 339 : NMATR1=MAT1.IRIGEL(/2) 340 : do 7432 lm=1, NMATR1 341 : IMAT1=MAT1.irigel(4,lm) 342 : segact imat1 343 : nbmf=IMAT1.LISPRI(/2) 344 : 345 : do 7433 lmf=1,nbmf 346 : NOMKP=IMAT1.LISPRI(lmf) 347 : NOMKD=IMAT1.LISDUA(lmf) 348 : c write(6,*)NOMKP,'----',NOMKD 348 : CALL OPTLI4(IP1,MLMOT1.MOTS,NOMKP(1:4),nicp) 348 : CALL OPTLI4(IP2,MLMOT2.MOTS,NOMKD(1:4),nicd) 349 : MCOUP(IP2,IP1)=1 350 : 7433 continue 351 : 7432 continue 352 : 353 : c write(6,*)' MCOUP ',nicp,nicd 354 : c do 7400 k=1,nicp 355 : c write(6,*)(MCOUP(k,i),i=1,nicd) 356 : c7400 continue 357 : 358 : 359 : IF(nicp.NE.nicd)THEN 360 : write(6,*)' ERREUR nicp ne nicd ',nicp,nicd 361 : return 362 : ENDIF 363 : 364 : 364 : CALL CRTABL(MTABLE) 365 : npart=0 366 : 367 : do 7401 k=1,nicp 368 : 369 : JGN=4 370 : JGM=0 371 : segini MLMOT3 372 : I0=MCOUP(k,k) 373 : 374 : IF(I0.EQ.0)THEN 375 : write(6,*)' ERREUR : La diagonale est nule' 376 : return 377 : ENDIF 378 : 379 : IF(I0.EQ.-1)GO TO 7401 380 : JGM=JGM+1 381 : SEGADJ MLMOT3 382 : MLMOT3.MOTS(JGM)=MLMOT2.MOTS(k) 383 : MCOUP(k,k)=-1 384 : 385 : it=0 386 : do 7402 m=1,nicd 387 : I1=MCOUP(k,m) 388 : IF(I1.EQ.1)THEN 389 : it=it+1 390 : itinc(it)=i1 391 : JGM=JGM+1 392 : SEGADJ MLMOT3 393 : MLMOT3.MOTS(JGM)=MLMOT2.MOTS(m) 394 : MCOUP(k,m)=-1 395 : MCOUP(m,m)=-1 396 : ENDIF 397 : 7402 continue 398 : 399 : 7405 continue 400 : itp=0 401 : do 7403 j=1,it 402 : il=itinc(j) 403 : 404 : do 7403 m=1,nicd 405 : I1=MCOUP(k,m) 406 : IF(I1.EQ.1)THEN 407 : itp=itp+1 408 : itinc(itp)=i1 409 : JGM=JGM+1 410 : SEGADJ MLMOT3 411 : MLMOT3.MOTS(JGM)=MLMOT2.MOTS(m) 412 : MCOUP(il,m)=-1 413 : ENDIF 414 : 7403 continue 415 : do 7404 m=1,itp 416 : itinc(m)=itinc(m+it) 417 : 7404 continue 418 : it=itp 419 : IF(ITP.NE.0)go to 7405 420 : npart=npart+1 421 : segdes MLMOT3 421 : CALL ECCTAB(MTABLE,'ENTIER',npart,0.D0,BLAN,.TRUE.,0, 422 : 1 'LISTMOTS',0,0.D0,BLAN,.TRUE.,MLMOT3) 423 : 424 : 7401 continue 425 : 426 : SEGSUP STCOUP 427 : SEGDES MTABLE,MLMOT3 427 : CALL ECROBJ('TABLE',MTABLE) 428 : RETURN 429 : ENDIF 430 : C 431 : C 432 : C CAS KOP=27 'EXTRMASS' ou 'EXTRPREC' 433 : IF(KOP.EQ.27.OR.KOP.EQ.28)THEN 433 : CALL LIRCHA(NOMC,1,IRET) 433 : CALL LIRCHA(NOMK,1,IRET) 434 : IF(IRET.EQ.0)RETURN 434 : CALL LIROBJ('MATRIK',MAT1,1,IRET) 435 : IF(IRET.EQ.0)RETURN 436 : 437 : SEGACT MAT1 438 : NRIGE =MAT1.IRIGEL(/1) 439 : NMATRI=MAT1.IRIGEL(/2) 440 : NMATRI=0 441 : NKID =MAT1.KIDMAT(/1) 442 : NKMT =MAT1.KKMMT(/1) 443 : SEGINI MATRIK 443 : CALL RSETI(KIDMAT,MAT1.KIDMAT,NKID) 443 : CALL RSETI(KKMMT ,MAT1.KKMMT ,NKMT) 444 : KSYM = MAT1.KSYM 445 : mincp= MAT1.KMINC 446 : if(mincp.ne.0)then 447 : segact mincp 448 : nbi= mincp.LISINC(/2) 449 : npt= mincp.NPOS(/1)-1 450 : segini minc 450 : call rseti(npos,mincp.npos,npt+1) 450 : call rseti(mpos,mincp.mpos,(npt*(nbi+1))) 451 : lisinc(1)=NOMK 452 : if(nbi.ne.1)then 453 : write(6,*)' Gross Pb NBI=',nbi 454 : write(6,*)(mincp.lisinc(ii),ii=1,nbi) 454 : call arret (0) 455 : endif 456 : KMINC = minc 457 : KMINCP= minc 458 : KMINCD= minc 459 : endif 460 : 461 : KIZM = MAT1.KIZM 462 : 463 : KISPGT= MAT1.KISPGT 464 : KISPGP= MAT1.KISPGP 465 : KISPGD= MAT1.KISPGD 466 : 467 : KNTTT = MAT1.KNTTT 468 : KNTTP = MAT1.KNTTP 469 : KNTTD = MAT1.KNTTD 470 : 471 : NMATR1=MAT1.IRIGEL(/2) 472 : c write(6,*)'NMATR1=',NMATR1 473 : do 6532 lm=1, NMATR1 474 : IMAT1=MAT1.irigel(4,lm) 475 : segact imat1 476 : nbmf=IMAT1.LISPRI(/2) 477 : c write(6,*)' NBMF=',nbmf 478 : 479 : do 6533 lmf=1,nbmf 480 : if(NOMC.eq.IMAT1.LISPRI(lmf))then 481 : if(NOMC.NE.IMAT1.LISDUA(lmf))then 482 : c write(6,*)' On a perdu ', nomc,lmf 482 : call erreur(5) 483 : return 484 : endif 485 : c write(6,*)' On a gagne ', nomc,lmf 486 : NMATRI=NMATRI+1 487 : segadj MATRIK 488 : do 6534 i7=1,7 489 : irigel(i7,nmatri)=mat1.irigel(i7,lm) 490 : 6534 continue 491 : 492 : nbme=1 493 : nbsous=IMAT1.lizafm(/1) 494 : segini IMATRI 495 : irigel(4,nmatri)=IMATRI 496 : KSPGP=IMAT1.KSPGP 497 : KSPGD=IMAT1.KSPGD 498 : LISPRI(1)=NOMK 499 : LISDUA(1)=NOMK 500 : do 6535 is=1,nbsous 501 : c? LIZAFM(is,1)=IMAT1. LIZAFM(is,lmf) 502 : 6535 continue 503 : 504 : 505 : endif 506 : 6533 continue 507 : 6532 continue 508 : SEGDES MATRIK 508 : CALL ECROBJ('MATRIK',MATRIK) 509 : RETURN 510 : ENDIF 511 : C 512 : * Option CHANINCO idem opérateur 'CHANGER' 'INCO' 513 : * mais pour les matrik et pour les rigidités y compris les multiplicateurs 514 : IF (KOP.EQ.29) THEN 515 : * MAtrik CHanger INco 515 : CALL MACHIN 516 : RETURN 517 : ENDIF 518 : C 519 : * Option TRANSPOS transpose une matrice 520 : * (matrik ou rigidité) 521 : IF (KOP.EQ.30) THEN 522 : * TRanSpose MaTrice 522 : CALL TRSMAT 523 : RETURN 524 : ENDIF 525 : C 526 : * Option MATIAGO pour créer une matrice diagonale 527 : IF (KOP .EQ. 31) THEN 527 : CALL KOPDIA 528 : RETURN 529 : ENDIF 530 : C 531 : GO TO 10 532 : 533 : C ============================================== 534 : C Cas : Objet = FLOTTANT ou ENTIER 535 : C ============================================== 536 : ELSEIF(MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER')THEN 537 : NAG=NAG+1 538 : NFLOT=NFLOT+1 539 : IF(NAG.GT.2)GO TO 91 540 : IF((NAG.EQ.1).OR.(NBMAT.EQ.1)) THEN 540 : CALL LIRREE(XVAL,1,IRET) 541 : XVAL1=XVAL 542 : GO TO 10 543 : END IF 543 : IF(NAG.EQ.2)CALL LIRREE(XVAL,1,IRET) 544 : XVAL2=XVAL 545 : GO TO 10 546 : 547 : C ============================================= 548 : C Cas : Objet = CHPOINT 549 : C ============================================= 550 : ELSEIF(MTYP.EQ.'CHPOINT')THEN 551 : NAG=NAG+1 552 : IF(NAG.GT.2)GO TO 91 553 : IF ((NAG.EQ.1).OR.(NBMAT.EQ.1))THEN 553 : CALL LIROBJ('CHPOINT',MCHPO1,1,IRET) 553 : CALL LICHT(MCHPO1,MPOVA1,TYPE1,IGEOM1) 554 : ELSE 554 : CALL LIROBJ('CHPOINT',MCHPO2,1,IRET) 555 : IF(KOP.NE.15)THEN 555 : CALL LICHT(MCHPO2,MPOVA2,TYPE2,IGEOM2) 556 : ELSE 557 : GO TO 20 558 : ENDIF 559 : ENDIF 560 : 561 : C ============================================ 562 : C Cas : Objet = TABLE 563 : C ============================================ 564 : ELSEIF(MTYP.EQ.'TABLE'.OR.MTYP.EQ.'MMODEL')THEN 565 : NAG=NAG+1 566 : IF(NAG.GT.2)GO TO 91 566 : C? CALL LITABS('DOMAINE ',MTABD,1,1,IRET) 566 : CALL LITDMD(MMODEL,MTABD,IRET) 567 : IF(IRET.EQ.0)RETURN 567 : IF(MTABD.EQ.0)CALL LEKMOD(MMODEL,MTABD,INEFMD) 568 : C INEFMD=1 LINE =2 MACRO =3 QUADRATIQUE 569 : 570 : C ============================================ 571 : C Cas : Objet = POINT 572 : C ============================================ 573 : ELSEIF(MTYP.EQ.'POINT')THEN 574 : NAG=NAG+1 575 : IF(NAG.GT.2)GO TO 91 575 : CALL LIROBJ('POINT',MPOINT,1,IRET) 576 : IF(NAG.EQ.1)IKASS=4 577 : IF(NAG.EQ.2)IKASS=5 578 : XVEC(1)=XCOOR((MPOINT-1)*(IDIM+1) +1) 579 : XVEC(2)=XCOOR((MPOINT-1)*(IDIM+1) +2) 580 : IF(IDIM.EQ.3)XVEC(3)=XCOOR((MPOINT-1)*(IDIM+1)+3) 581 : C Si MPOVA1 n'est pas initialise, il peut poser 582 : C des problemes dans la partie 'operations' 583 : MPOVA1 = 0 584 : C =========================================== 585 : C Cas Objet = MATRIK 586 : C =========================================== 587 : ELSEIF(MTYP.EQ.'MATRIK')THEN 588 : NAG=NAG+1 589 : IF(NAG.GT.2)GO TO 91 590 : NBMAT=NBMAT+1 591 : IF (NBMAT.EQ.1) THEN 591 : CALL LIROBJ('MATRIK',MAT1,1,IRET) 592 : ELSEIF (NBMAT.EQ.2) THEN 592 : CALL LIROBJ('MATRIK',MAT2,1,IRET) 593 : END IF 594 : IF (NBMAT.EQ.1) IKASS=6 595 : IF (NBMAT.EQ.2) IKASS=7 596 : 597 : C =========================================== 598 : C Cas Objet non prevu 599 : C =========================================== 600 : ELSE 601 : MOTERR(1:8)=MTYP 601 : CALL ERREUR(39) 602 : * WRITE(6,*)' Opérateur KOPS :' 603 : * WRITE(6,*)' Type d''objet :',MTYP,' non prevu' 604 : RETURN 605 : ENDIF 606 : 607 : 608 : GO TO 10 609 : 610 : C ***************************************** 611 : C * Deuxieme partie * 612 : C * On effectue ici une batterie de tests * 613 : C * afin de determiner si on fait des * 614 : C * operations valides * 615 : C ***************************************** 616 : 9 CONTINUE 617 : IF (JMOTS.EQ.0) THEN 618 : moterr(1:8)='MOTS ' 618 : call erreur(37) 619 : RETURN 620 : ENDIF 621 : IKAS=3 622 : IF(MCHPO1.EQ.0)IKAS=1 623 : IF(MCHPO2.EQ.0)IKAS=2 624 : IF((MCHPO1.EQ.0.AND.MCHPO2.EQ.0).AND.NBMAT.EQ.0)THEN 625 : WRITE(6,*)' Opérateur KOPS :' 626 : WRITE(6,*)' Il n''y a pas de CHPOINT ?? ' 627 : RETURN 628 : ENDIF 629 : IF(IKASS.NE.0)IKAS=IKASS 630 : C write(6,*)' MCHPO1,MCHPO2=',MCHPO1,MCHPO2,IKAS,IKASS 631 : C &,' KOP=',KOP 632 : 633 : IF(IKAS.EQ.3)THEN 634 : 635 : IF(IGEOM1.NE.IGEOM2)THEN 636 : INDIC=1 637 : NBCOMP=-1 637 : CALL QUEPOI(MCHPO2,IGEOM1,INDIC,NBCOMP,NOMTOT) 638 : C write(6,*)' indic,nbcom=',indic,nbcom 638 : CALL LICHT(MCHPO2,MPOVA2,TYPE2,IGEOM2) 639 : IF(INDIC.LT.0)THEN 640 : WRITE(6,*)' Opérateur KOPS :' 641 : WRITE(6,*)' Les deux champs n''ont pas le meme support ' 642 : & ,'geometrique ou pire ' 643 : WRITE(6,*)' IGEOM1=',IGEOM1,' IGEOM2=',IGEOM2 644 : RETURN 645 : ENDIF 646 : ENDIF 647 : 648 : IF(MPOVA1.EQ.0.AND.IGEOM1.EQ.0)THEN 649 : C WRITE(6,*)'CAS OU LES CHPOINTS SONT VIDE' 650 : NC1=0 651 : NC2=0 652 : NS=0 653 : ELSE 654 : NC1=MPOVA1.VPOCHA(/2) 655 : NC2=MPOVA2.VPOCHA(/2) 656 : NS=MPOVA1.VPOCHA(/1) 657 : ENDIF 658 : 659 : NC=NC1 660 : NCK=NC 661 : IGEOM=IGEOM1 662 : TYPE=TYPE1 663 : IF(NC1.NE.NC2)THEN 664 : IF(NC1.EQ.1.AND.NC2.EQ.IDIM.AND.KOP.EQ.6)THEN 665 : NC=NC1 666 : NCK=NC2 667 : ELSE 668 : WRITE(6,*)' Opérateur KOPS :' 669 : WRITE(6,*)' Les deux champs n''ont pas le meme nombre ', 670 : & 'de composante' 671 : RETURN 672 : ENDIF 673 : ELSE 674 : IF(KOP.EQ.6)IKAS=6 675 : ENDIF 676 : 677 : 678 : ENDIF 679 : 680 : IF(IKAS.EQ.1)THEN 681 : IF(MPOVA2.EQ.0.AND.IGEOM2.EQ.0)THEN 682 : C WRITE(6,*)'CAS OU LE CHPOINT2 EST VIDE' 683 : NS=0 684 : NC=0 685 : ELSE 686 : NS=MPOVA2.VPOCHA(/1) 687 : NC=MPOVA2.VPOCHA(/2) 688 : ENDIF 689 : 690 : NC2=NC 691 : NCK=NC 692 : IGEOM=IGEOM2 693 : TYPE=TYPE2 694 : 695 : ELSEIF(IKAS.EQ.2)THEN 696 : IF(MPOVA1.EQ.0.AND.IGEOM1.EQ.0)THEN 697 : C WRITE(6,*)'CAS OU LE CHPOINT1 EST VIDE' 698 : NS=0 699 : NC=0 700 : ELSE 701 : NS=MPOVA1.VPOCHA(/1) 702 : NC=MPOVA1.VPOCHA(/2) 703 : ENDIF 704 : NC2=NC 705 : NCK=NC 706 : IGEOM=IGEOM1 707 : TYPE=TYPE1 708 : 709 : ELSEIF(IKAS.EQ.4)THEN 710 : NS=MPOVA2.VPOCHA(/1) 711 : NC=MPOVA2.VPOCHA(/2) 712 : IF(NC.NE.1)THEN 713 : WRITE(6,*)' Opérateur KOPS :' 714 : WRITE(6,*)' Le champoint doit etre scalaire dans ce cas ' 715 : RETURN 716 : ENDIF 717 : NC2=IDIM 718 : NCK=IDIM 719 : IGEOM=IGEOM2 720 : TYPE=TYPE2 721 : ELSEIF(IKAS.EQ.5)THEN 722 : NS=MPOVA1.VPOCHA(/1) 723 : NC=MPOVA1.VPOCHA(/2) 724 : IF(NC.NE.1)THEN 725 : WRITE(6,*)' Opérateur KOPS :' 726 : WRITE(6,*)' Le champoint doit etre scalaire dans ce cas ' 727 : RETURN 728 : ENDIF 729 : NC2=IDIM 730 : NCK=IDIM 731 : IGEOM=IGEOM1 732 : TYPE=TYPE1 733 : ENDIF 734 : 735 : 20 CONTINUE 736 : IF(KOP.EQ.25)GO TO 31 737 : GO TO (21,22,23,24,25,21,22,26,27,28,29,30,31,32,33,34),KOP 738 : 739 : C ************************************ 740 : C * Dans cette partie on effectue * 741 : C * les operations * 742 : C ************************************ 743 : 744 : C MULT 745 : 21 CONTINUE 746 : 747 : C ======================= 748 : C PRODUIT 2 OBJETS MATRIK 749 : C ======================= 750 : IF(NBMAT.EQ.2) THEN 750 : CALL ETOILE(MAT1,MAT2,MAT3,IRET) 751 : 752 : IF (IRET.NE.0) THEN 753 : WRITE(6,*) 'Pb dans ETOILE' 754 : RETURN 755 : END IF 756 : 756 : CALL ECROBJ('MATRIK',MAT3) 757 : 758 : C ============================= 759 : C PRODUIT OBJET MATRIK FLOTTANT 760 : C ============================= 761 : ELSEIF ((NBMAT.EQ.1).AND.(NFLOT.EQ.1)) THEN 762 : 762 : CALL PRDMF(XVAL1,MAT1,MAT2) 762 : CALL ECROBJ('MATRIK',MAT2) 763 : 764 : C ============================= 765 : C PRODUIT OBJET MATRIK CHPOINT 766 : C ============================= 767 : ELSEIF ((NBMAT.EQ.1).AND.(MCHPO1.NE.0)) THEN 767 : CALL PRDMCP(MAT1,MCHPO1,MCHPO2) 767 : CALL ECROBJ('CHPOINT',MCHPO2) 768 : C ============================= 769 : 770 : ELSE 770 : CALL CRCHPT(TYPE,IGEOM,NCK,MCHPOI) 770 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 771 : IF(IKAS.EQ.1)THEN 771 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1, 772 : & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 773 : ELSEIF(IKAS.EQ.2)THEN 773 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1, 774 : & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 775 : ELSE 776 : C segact mchpoi 777 : C write(6,*)' segact ok avt kops1 ',kop 777 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1, 778 : & XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 779 : ENDIF 780 : C segact mchpoi 781 : C write(6,*)' segact ok apr kops1 ' 782 : C write(6,*)' MCHPOI=',mchpoi 782 : CALL ECROBJ('CHPOINT ',MCHPOI) 783 : END IF 784 : 785 : GO TO 89 786 : 787 : 788 : C DIVI 789 : 22 CONTINUE 790 : 790 : CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) 790 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 791 : C write(6,*)' MCHPOI=',mchpoi,IKAS 792 : C write(6,*)' NC,NC2,NS=',NC,NC2,NS 793 : IF(IKAS.EQ.1)THEN 793 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 794 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 795 : ELSEIF(IKAS.EQ.2)THEN 796 : segact mchpoi,mchpo1,mpoval,mpova1 796 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 797 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 798 : segact mchpoi,mchpo1,mpoval,mpova1 799 : ELSE 799 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 800 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 801 : ENDIF 801 : CALL ECROBJ('CHPOINT ',MCHPOI) 802 : GO TO 89 803 : 804 : C PSRN 805 : 23 CONTINUE 806 : IF(IKAS.NE.3)THEN 807 : WRITE(6,*)' Opérateur KOPS :' 808 : WRITE(6,*)' Dans ce cas on attend deux CHPOINT' 809 : RETURN 810 : ENDIF 811 : 812 : N=NS*NC 813 : XVAL=SDOT(N,MPOVA1.VPOCHA(1,1),1,MPOVA2.VPOCHA(1,1),1) 813 : CALL ECRREE(XVAL) 814 : GO TO 89 815 : 816 : C PSCA 817 : 24 CONTINUE 818 : 818 : CALL CRCHPT(TYPE,IGEOM,1,MCHPOI) 818 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 819 : 820 : IF(IKAS.NE.3)THEN 821 : WRITE(6,*)' Opérateur KOPS :' 822 : WRITE(6,*)' Dans ce cas on attend deux CHPOINT' 823 : RETURN 824 : ENDIF 824 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1,XVAL2, 825 : & NC,NC2,NS,IKAS,KOP,XVEC) 825 : CALL ECROBJ('CHPOINT ',MCHPOI) 826 : GO TO 89 827 : 828 : C ET 829 : 25 CONTINUE 830 : WRITE(6,*)' Opérateur KOPS :' 831 : WRITE(6,*)' ET : Non operationnel pour l''instant' 832 : GO TO 89 833 : 834 : C '+' 835 : 26 CONTINUE 836 : 837 : IF (NBMAT.EQ.2) THEN 838 : 839 : C On effectue l addition MAT1+MAT2 et on recupere la 840 : C matrice resultante dans MAT3 en morse 840 : CALL ADDMAT(MAT1,MAT2,MAT3,IRET) 841 : 842 : IF (IRET.NE.0) THEN 843 : WRITE(6,*) 'Pb dans ADDMAT' 844 : RETURN 845 : END IF 846 : 846 : CALL ECROBJ('MATRIK',MAT3) 847 : ELSE 847 : CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) 847 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 848 : IF(IKAS.EQ.1)THEN 848 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA, 849 : & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 850 : ELSEIF(IKAS.EQ.2)THEN 850 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA, 851 : & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 852 : ELSE 852 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA, 853 : & XVAL1,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 854 : ENDIF 854 : CALL ECROBJ('CHPOINT ',MCHPOI) 855 : END IF 856 : GO TO 89 857 : 858 : C '-' 859 : 27 CONTINUE 860 : 860 : CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) 860 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 861 : IF(IKAS.EQ.1)THEN 861 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 862 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 863 : ELSEIF(IKAS.EQ.2)THEN 863 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 864 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 865 : ELSE 865 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 866 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 867 : ENDIF 867 : CALL ECROBJ('CHPOINT ',MCHPOI) 868 : GO TO 89 869 : 870 : C '**' 871 : 28 CONTINUE 872 : 872 : CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) 872 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 873 : IF(IKAS.EQ.1)THEN 873 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 874 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 875 : ELSEIF(IKAS.EQ.2)THEN 875 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 876 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 877 : ELSE 877 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 878 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 879 : ENDIF 879 : CALL ECROBJ('CHPOINT ',MCHPOI) 880 : GO TO 89 881 : 882 : C '|<' 883 : 29 CONTINUE 884 : 884 : CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) 884 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 885 : IF(IKAS.EQ.1)THEN 885 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 886 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 887 : ELSEIF(IKAS.EQ.2)THEN 887 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 888 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 889 : ELSE 889 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 890 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 891 : ENDIF 891 : CALL ECROBJ('CHPOINT ',MCHPOI) 892 : GO TO 89 893 : 894 : C '>|' 895 : 30 CONTINUE 896 : 896 : CALL CRCHPT(TYPE,IGEOM,NC,MCHPOI) 896 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 897 : IF(IKAS.EQ.1)THEN 897 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA2.VPOCHA,MPOVA2.VPOCHA,XVAL1 898 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 899 : ELSEIF(IKAS.EQ.2)THEN 899 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA1.VPOCHA,XVAL1 900 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 901 : ELSE 901 : CALL KOPS1(MPOVAL.VPOCHA,MPOVA1.VPOCHA,MPOVA2.VPOCHA,XVAL1 902 : $ ,XVAL2,NC,NC2,NS,IKAS,KOP,XVEC) 903 : ENDIF 903 : CALL ECROBJ('CHPOINT ',MCHPOI) 904 : GO TO 89 905 : 906 : C 'GRAD' 907 : 31 CONTINUE 908 : IF(MTABD.EQ.0)THEN 908 : CALL ERREUR(-182) 909 : RETURN 910 : ENDIF 911 : IF(KOP.EQ.25)THEN 911 : CALL KGRAS(MCHPO1,MPOVA1,IGEOM1,MTABD) 912 : ELSE 912 : CALL KGRA(MCHPO1,MPOVA1,IGEOM1,MTABD) 913 : ENDIF 914 : GO TO 89 915 : 916 : C 'ROT' 917 : 32 CONTINUE 918 : IF(MTABD.EQ.0)THEN 918 : CALL ERREUR(-182) 919 : RETURN 920 : ENDIF 920 : CALL KROT(MCHPO1,MPOVA1,IGEOM1,MTABD) 921 : GO TO 89 922 : 923 : C 'CLIM' 924 : 33 CONTINUE 924 : CALL KBOR(MCHPO1,MCHPO2) 925 : GO TO 89 926 : 927 : 89 CONTINUE 928 : C? IF(KOP.NE.15)THEN 929 : C? IF(MCHPOI.NE.0)SEGDES MCHPOI,MPOVAL 930 : C? IF(MCHPO1.NE.0)SEGDES MCHPO1,MPOVA1 931 : C? IF(MCHPO2.NE.0)SEGDES MCHPO2,MPOVA2 932 : C? ENDIF 933 : RETURN 934 : 935 : C 'INV' 936 : 34 CONTINUE 937 : IF (NBMAT.EQ.1) THEN 938 : NAG=2 938 : CALL INVMAT(MAT1,MAT2,IRET) 938 : CALL ECROBJ('MATRIK',MAT2) 939 : ELSE 940 : WRITE(6,*) 'KOPS: On ne peut inverser qu une matrice' 941 : END IF 942 : RETURN 943 : 944 : 91 CONTINUE 945 : WRITE(6,*)' Opérateur KOPS :' 946 : WRITE(6,*)' Nombre d''argument superieur a 2 ' 947 : RETURN 948 : END 949 : 950 : 951 : 952 : 953 : 954 : 955 : 956 : 957 : 958 : 959 : 960 : 961 : 962 : 963 : 964 : 965 : 966 : 967 : 968 : 969 : 970 : 971 : 972 : 973 : 974 : 975 : 976 : 977 : 978 : 979 : 980 :
© Cast3M 2003 - All rights reserved.
Disclaimer