1 : C OPERMU SOURCE FANDEUR 12/04/11 21:15:24 7350 2 : SUBROUTINE OPERMU 3 : *_______________________________________________________________________ 4 : * 5 : * multiplie un champ par point par un objet rigidite. 6 : * multiplie un listreel par un flottant (ou un entier) 7 : * multiplie un listreel par un listreel terme a terme. 8 : * multiplie un objet rigidite par un flottant (ou 1 entier) 9 : * multiplie un champs par elemt par un flottant (ou 1 entier) 10 : * multiplie un champ par element par un autre champ par element 11 : * multiplie un champ par element par une evolution 12 : * multiplie un champ par point par un autre champ par point 13 : * multiplie un champ par point par un flottant (ou 1 entier) 14 : * multiplie un champ par point par une evolution 15 : * multiplie 2 nombres (flottant ou entier) 16 : * multiplie un point par un nombre 17 : * multiplie un objet evolutio (ordonnees) par un flottant 18 : * (ou un entier) 19 : * multiplie un objet evolutio par un objet evolutio 20 : * multiplie une table soustype vecteur par un reel 21 : * multiplie une table soustype LIAISONS_STATIQUES ou 22 : * BASE_DE_MODES par une rigidite 23 : * 24 : * passage aux nouveaux mchaml par jm campenon le 29 10 90 25 : * 26 : *_______________________________________________________________________ 27 : * 28 : IMPLICIT INTEGER(I-N) 29 : IMPLICIT REAL*8 (A-H,O-Z) 30 : -INC CCOPTIO 31 : -INC SMCOORD 32 : -INC SMLENTI 33 : -INC SMLREEL 34 : -INC SMTABLE 35 : *_______________________________________________________________________ 36 : * 37 : * produit de deux champoints 38 : *_______________________________________________________________________ 39 : * 39 : CALL LIROBJ('CHPOINT',ICHP1,0,IRETOU) 40 : IF (IRETOU.EQ.0) GOTO 1 40 : CALL LIROBJ('CHPOINT',ICHP2,0,IRETOU) 41 : IF (IRETOU.EQ.0) THEN 41 : CALL REFUS 42 : GOTO 1 43 : ENDIF 43 : CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU) 44 : IF ( IRETOU .EQ. 1) THEN 44 : CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU) 45 : IF (IERR .NE. 0) RETURN 45 : CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU) 46 : IF (IERR .NE. 0) RETURN 46 : CALL MUCHP1(ICHP1,ICHP2,LMOT1,LMOT2,LMOT3,1,IRET) 46 : IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET) 47 : ELSE 47 : CALL MUPOSC(ICHP1,ICHP2,1,IRET) 47 : IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET) 48 : ENDIF 49 : RETURN 50 : * 51 : 1 CONTINUE 52 : *_______________________________________________________________________ 53 : * 54 : * multiplication de deux entiers 55 : *_______________________________________________________________________ 56 : * 56 : CALL LIRENT(IRE1,0,IRETOU) 57 : IF (IRETOU.EQ.0) GOTO 2 57 : CALL LIRENT(IRE2,0,IRETOU) 58 : IF (IRETOU.EQ.0) THEN 58 : CALL REFUS 59 : GOTO 2 60 : ENDIF 60 : CALL ECRENT(IRE1*IRE2) 61 : RETURN 62 : * 63 : 2 CONTINUE 64 : *_______________________________________________________________________ 65 : * 66 : * multiplication de deux flottants 67 : *_______________________________________________________________________ 68 : * 68 : CALL LIRREE(FLO1,0,IRETOU) 69 : IF (IRETOU.EQ.0) GOTO 3 69 : CALL LIRREE(FLO2,0,IRETOU) 70 : IF (IRETOU.EQ.0) THEN 70 : CALL REFUS 71 : GOTO 3 72 : ENDIF 72 : CALL ECRREE(FLO1*FLO2) 73 : RETURN 74 : * 75 : 3 CONTINUE 76 : *_______________________________________________________________________ 77 : * 78 : * produit d'un reel par un point 79 : *_______________________________________________________________________ 80 : * 80 : CALL LIRREE(FLO1,0,IRETOU) 81 : IF (IRETOU.EQ.0) GOTO 4 81 : CALL LIROBJ('POINT',IPT,0,IRETOU) 82 : IF (IRETOU.EQ.0) THEN 82 : CALL REFUS 83 : GOTO 4 84 : ENDIF 85 : SEGACT MCOORD*MOD 86 : XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+1)*FLO1 87 : XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+2)*FLO1 88 : XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+3)*FLO1 89 : IF (IDIM.EQ.3) XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+4)*FLO1 90 : IRET=XCOOR(/1)/(IDIM+1) 90 : CALL ECROBJ('POINT',IRET) 91 : RETURN 92 : * 93 : 4 CONTINUE 94 : *_______________________________________________________________________ 95 : * 96 : * produit d'un chpoint par un reel 97 : *_______________________________________________________________________ 98 : * 98 : CALL LIRREE(FLO,0,IRETOU) 99 : IF (IRETOU.EQ.0) GOTO 5 99 : CALL LIROBJ('CHPOINT',ICHP,0,IRETOU) 100 : IF (IRETOU.EQ.0) THEN 100 : CALL REFUS 101 : GOTO 5 102 : ENDIF 102 : CALL MUCHPO(ICHP,FLO,IRET,1) 102 : IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET) 103 : RETURN 104 : * 105 : 5 CONTINUE 106 : *_______________________________________________________________________ 107 : * 108 : * produit d'un mchaml par un reel 109 : *_______________________________________________________________________ 110 : * 110 : CALL LIRREE(FLO,0,IRETOU) 111 : IF (IRETOU.EQ.0) GOTO 6 111 : CALL LIROBJ('MCHAML',IPCHP,0,IRETOU) 112 : IF (IRETOU.EQ.0) THEN 112 : CALL REFUS 113 : GOTO 6 114 : ENDIF 115 : * 115 : CALL MUCHEL(IPCHP,FLO,IPCHMU,1) 116 : * 116 : IF (IPCHMU.NE.0) CALL ECROBJ('MCHAML',IPCHMU) 117 : * 118 : RETURN 119 : * 120 : 6 CONTINUE 121 : *_______________________________________________________________________ 122 : * 123 : * produit d'une rigidite par un reel 124 : *_______________________________________________________________________ 125 : * 125 : CALL LIRREE(FLO,0,IRETOU) 126 : IF (IRETOU.EQ.0) GOTO 7 126 : CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU) 127 : IF (IRETOU.EQ.0) THEN 127 : CALL REFUS 128 : GOTO 7 129 : ENDIF 129 : CALL MUFLRI(IRIG,FLO,IRET,1) 129 : IF (IRET.NE.0) CALL ECROBJ('RIGIDITE',IRET) 130 : RETURN 131 : * 132 : 7 CONTINUE 133 : *_______________________________________________________________________ 134 : * 135 : * produit d'un matrik par un reel 136 : *_______________________________________________________________________ 137 : * 137 : CALL LIRREE(FLO,0,IRETOU) 138 : IF (IRETOU.EQ.0) GOTO 71 138 : CALL LIROBJ('MATRIK ',IRIG,0,IRETOU) 139 : IF (IRETOU.EQ.0) THEN 139 : CALL REFUS 140 : GOTO 71 141 : ENDIF 141 : CALL PRDMF(FLO,IRIG,IRET) 141 : IF (IRET.NE.0) CALL ECROBJ('MATRIK ',IRET) 142 : RETURN 143 : * 144 : 71 CONTINUE 145 : *_______________________________________________________________________ 146 : * 147 : * produit d'une rigidite par un champoint 148 : *_______________________________________________________________________ 149 : * 149 : CALL LIROBJ('CHPOINT',ICHP,0,IRETOU) 150 : IF (IRETOU.EQ.0) GOTO 8 150 : CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU) 151 : IF (IRETOU.EQ.0) THEN 151 : CALL REFUS 152 : GOTO 8 153 : ENDIF 153 : CALL MUCPRI(ICHP,IRIG,IRET) 153 : CALL ECROBJ('CHPOINT',IRET) 154 : RETURN 155 : * 156 : 8 CONTINUE 157 : *_______________________________________________________________________ 158 : * 159 : * produit d'un matrik par un champoint 160 : *_______________________________________________________________________ 161 : * 161 : CALL LIROBJ('CHPOINT',ICHP,0,IRETOU) 162 : IF (IRETOU.EQ.0) GOTO 9 162 : CALL LIROBJ('MATRIK ',IRIG,0,IRETOU) 163 : IF (IRETOU.EQ.0) THEN 163 : CALL REFUS 164 : GOTO 9 165 : ENDIF 165 : CALL PRDMCP(IRIG,ICHP,IRET) 165 : CALL ECROBJ('CHPOINT',IRET) 166 : RETURN 167 : * 168 : 9 CONTINUE 169 : 170 : *_______________________________________________________________________ 171 : * 172 : * produit de deux mchaml 173 : *_______________________________________________________________________ 174 : * 174 : CALL LIROBJ('MMODEL',IPMODL,0,IRETOU) 175 : IF (IRETOU.EQ.0) IPMODL=0 175 : CALL LIROBJ('MCHAML',ICHP1,0,IRETOU) 176 : IF (IRETOU.EQ.0) GOTO 10 176 : CALL LIROBJ('MCHAML',ICHP2,0,IRETOU) 177 : IF (IRETOU.EQ.0) THEN 177 : CALL REFUS 178 : GOTO 10 179 : ENDIF 180 : * 181 : LMOT1 = -1 182 : LMOT2 = -1 183 : LMOT3 = -1 184 : ILREE = -1 184 : CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU) 185 : IF ( IRETOU .EQ. 1) THEN 185 : CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU) 186 : IF (IERR .NE. 0) RETURN 186 : CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU) 187 : IF (IERR .NE. 0) RETURN 187 : CALL LIROBJ('LISTREEL',ILREE,0,IRETOU) 188 : IF (IERR .NE. 0) RETURN 189 : ENDIF 190 : * 190 : CALL MUCHSC(IPMODL,ICHP1,ICHP2,IPCHMU,LMOT1,LMOT2,LMOT3,ILREE,1) 191 : * 191 : IF (IPCHMU.NE.0) CALL ECROBJ('MCHAML',IPCHMU) 192 : * 193 : RETURN 194 : * 195 : 10 CONTINUE 196 : *_______________________________________________________________________ 197 : * 198 : * produit flottant evolution 199 : *_______________________________________________________________________ 200 : * 200 : CALL LIRREE(XFLO,0,IRETOU) 201 : IF (IRETOU.EQ.0) GOTO 11 201 : CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU) 202 : IF (IRETOU.EQ.0) THEN 202 : CALL REFUS 203 : GOTO 11 204 : ENDIF 204 : CALL MUFLEV(IEVOL,XFLO,IRET,1) 204 : CALL ECROBJ('EVOLUTIO',IRET) 205 : RETURN 206 : * 207 : 11 CONTINUE 208 : *_______________________________________________________________________ 209 : * 210 : * produit de deux evolutions 211 : *_______________________________________________________________________ 212 : * 212 : CALL LIROBJ('EVOLUTIO',IEVOL1,0,IRETOU) 213 : IF (IRETOU.EQ.0) GOTO 12 213 : CALL LIROBJ('EVOLUTIO',IEVOL2,0,IRETOU) 214 : IF (IRETOU.EQ.0) THEN 214 : CALL REFUS 215 : GOTO 12 216 : ENDIF 216 : CALL PUIS(IEVOL1,IEVOL2,IRET,1) 216 : CALL ECROBJ('EVOLUTIO',IRET) 217 : RETURN 218 : * 219 : 12 CONTINUE 220 : *_______________________________________________________________________ 221 : * 222 : * produit flottant listreel 223 : *_______________________________________________________________________ 224 : * 224 : CALL LIRREE(XFLO,0,IRETOU) 225 : IF (IRETOU.EQ.0) GOTO 13 225 : CALL LIROBJ('LISTREEL',IRE,0,IRETOU) 226 : IF (IRETOU.EQ.0) THEN 226 : CALL REFUS 227 : GOTO 13 228 : ENDIF 228 : CALL MUFLIR(IRE,XFLO,IRET,1) 228 : CALL ECROBJ('LISTREEL',IRET) 229 : RETURN 230 : * 231 : 13 CONTINUE 232 : *_______________________________________________________________________ 233 : * 234 : * produit chpoint evolution 235 : *_______________________________________________________________________ 236 : * 236 : CALL LIROBJ('CHPOINT',ICHP,0,IRETOU) 237 : IF (IRETOU.EQ.0) GOTO 14 237 : CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU) 238 : IF (IRETOU.EQ.0) THEN 238 : CALL REFUS 239 : GOTO 14 240 : ENDIF 240 : CALL VARCHP(ICHP,IEVOL,IRET,IRETOU) 240 : IF (IRETOU.NE.0) CALL ECROBJ('CHPOINT',IRET) 241 : RETURN 242 : * 243 : 14 CONTINUE 244 : *_______________________________________________________________________ 245 : * 246 : * produit mchaml evolution 247 : *_______________________________________________________________________ 248 : * 248 : CALL LIROBJ('MCHAML',IPCHP,0,IRETOU) 249 : IF (IRETOU.EQ.0) GOTO 15 249 : CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU) 250 : IF (IRETOU.EQ.0) THEN 250 : CALL REFUS 251 : GOTO 15 252 : ENDIF 253 : * 253 : CALL VARCHE(IPCHP,IEVOL,IPCHMU,IRETOU) 254 : * 254 : IF (IRETOU.NE.0) CALL ECROBJ('MCHAML',IPCHMU) 255 : * 256 : RETURN 257 : * 258 : 15 CONTINUE 259 : *_______________________________________________________________________ 260 : * 261 : * produit listreel listreel 262 : *_______________________________________________________________________ 263 : * 263 : CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU) 264 : IF(IRETOU.EQ.0) GO TO 16 264 : CALL LIROBJ('LISTREEL',MLREE2,0,IRETOU) 265 : IF (IRETOU.EQ.0) THEN 265 : CALL REFUS 266 : GOTO 16 267 : ENDIF 268 : SEGACT MLREE1,MLREE2 269 : JG=MLREE2.PROG(/1) 270 : IF(MLREE1.PROG(/1).NE.JG) THEN 270 : CALL ERREUR (21) 271 : RETURN 272 : ENDIF 273 : SEGINI MLREEL 274 : DO 150 I=1,JG 275 : PROG(I)=MLREE1.PROG(I)*MLREE2.PROG(I) 276 : 150 CONTINUE 277 : SEGDES MLREEL,MLREE1,MLREE2 277 : CALL ECROBJ('LISTREEL',MLREEL) 278 : RETURN 279 : * 280 : 16 CONTINUE 281 : *_______________________________________________________________________ 282 : * 283 : * produit listenti entier 284 : *_______________________________________________________________________ 285 : * 285 : CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU) 286 : IF(IRETOU.EQ.0) GO TO 17 286 : CALL LIRENT(IVA,0,IRETOU) 287 : IF (IRETOU.EQ.0) THEN 287 : CALL REFUS 288 : GOTO 17 289 : ENDIF 290 : SEGACT MLENT1 291 : JG=MLENT1.LECT(/1) 292 : SEGINI MLENTI 293 : DO 160 I=1,JG 294 : LECT(I)=MLENT1.LECT(I)*IVA 295 : 160 CONTINUE 296 : SEGDES MLENTI,MLENT1 296 : CALL ECROBJ('LISTENTI',MLENTI) 297 : RETURN 298 : * 299 : 17 CONTINUE 300 : *_______________________________________________________________________ 301 : * 302 : * produit listenti flottant 303 : *_______________________________________________________________________ 304 : * 304 : CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU) 305 : IF(IRETOU.EQ.0) GO TO 18 305 : CALL LIRREE(XVA,0,IRETOU) 306 : IF (IRETOU.EQ.0) THEN 306 : CALL REFUS 307 : GOTO 18 308 : ENDIF 309 : SEGACT MLENT1 310 : JG=MLENT1.LECT(/1) 311 : SEGINI MLREEL 312 : DO 170 I=1,JG 313 : PROG(I)=MLENT1.LECT(I)*XVA 314 : 170 CONTINUE 315 : SEGDES MLREEL,MLENT1 315 : CALL ECROBJ('LISTREEL',MLREEL) 316 : RETURN 317 : * 318 : 18 CONTINUE 319 : *_______________________________________________________________________ 320 : * 321 : * produit listenti listenti 322 : *_______________________________________________________________________ 323 : * 323 : CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU) 324 : IF(IRETOU.EQ.0) GO TO 19 324 : CALL LIROBJ('LISTENTI',MLENT2,0,IRETOU) 325 : IF (IRETOU.EQ.0) THEN 325 : CALL REFUS 326 : GOTO 19 327 : ENDIF 328 : SEGACT MLENT1,MLENT2 329 : JG=MLENT2.LECT(/1) 330 : IF(MLENT1.LECT(/1).NE.JG) THEN 330 : CALL ERREUR (21) 331 : RETURN 332 : ENDIF 333 : SEGINI MLENTI 334 : DO 180 I=1,JG 335 : LECT(I)=MLENT1.LECT(I)*MLENT2.LECT(I) 336 : 180 CONTINUE 337 : SEGDES MLENTI,MLENT1,MLENT2 337 : CALL ECROBJ('LISTENTI',MLENTI) 338 : RETURN 339 : * 340 : 19 CONTINUE 341 : *_______________________________________________________________________ 342 : * 343 : * produit table-vecteur reel 344 : *_______________________________________________________________________ 345 : * 345 : CALL LIRREE(FLO1,0,IRETOU) 346 : IF(IRETOU.EQ.0) GO TO 20 346 : CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU) 347 : IF (IRETOU.EQ.0) THEN 347 : CALL REFUS 348 : GOTO 20 349 : ENDIF 350 : SEGINI,MTABLE=MTAB1 351 : DO 200 I=1,MLOTAB 352 : IF (MTABTV(I).EQ.'FLOTTANT') THEN 353 : RMTABV(I)=RMTABV(I)*FLO1 354 : ELSE IF (MTABTV(I).EQ.'ENTIER ') THEN 355 : RMTABV(I)=MTABIV(I)*FLO1 356 : MTABTV(I)='FLOTTANT' 357 : ENDIF 358 : 200 CONTINUE 359 : SEGDES MTABLE,MTAB1 359 : CALL ECROBJ('TABLE',MTABLE) 360 : RETURN 361 : * 362 : 20 CONTINUE 363 : *_______________________________________________________________________ 364 : * 365 : * produit d'une rigidite par un champoint 366 : *_______________________________________________________________________ 367 : * 367 : CALL LIROBJ('LISTCHPO',ILCHP,0,IRETOU) 368 : IF (IRETOU.EQ.0) GOTO 21 368 : CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU) 369 : IF (IRETOU.EQ.0) THEN 369 : CALL REFUS 370 : GOTO 21 371 : ENDIF 371 : CALL MUCPLI(ILCHP,IRIG,IRET) 371 : CALL ECROBJ('LISTCHPO',IRET) 372 : RETURN 373 : * 374 : 21 CONTINUE 375 : 376 : * 377 : * produit table-liaisons_statiques rigidite 378 : *_______________________________________________________________________ 379 : * 379 : CALL LIRTAB('LIAISONS_STATIQUES',ITBST,0,IRETOU) 379 : IF(IRETOU.EQ.0) CALL LIRTAB('BASE_DE_MODES',ITBST,0,IRETOU) 380 : IF(IRETOU.EQ.0) GO TO 22 380 : call lirobj('RIGIDITE',ir1,1,iretou) 381 : IF (IRETOU.EQ.0) THEN 381 : CALL REFUS 382 : GOTO 22 383 : ENDIF 383 : call prmu(ir1,itbst) 384 : RETURN 385 : * 386 : 22 CONTINUE 386 : CALL QUETYP(MOTERR(1:8),0,IRETOU) 387 : IF(IRETOU.NE.0) THEN 387 : CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU) 387 : CALL QUETYP(MOTERR(9:16),0,IRETOU) 388 : IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? ' 388 : CALL ERREUR(532) 389 : ELSE 389 : CALL ERREUR(533) 390 : ENDIF 391 : 392 : RETURN 393 : END 394 : 395 :
© Cast3M 2003 - All rights reserved.
Disclaimer