1 : C PRCHAN SOURCE GOUNAND 14/01/31 21:15:10 7925 2 : 3 : SUBROUTINE PRCHAN 4 : 5 : C-------------------------------------------------------------------- 6 : C Ce sous programme permet : 7 : C 8 : C - De changer les elements d'un maillage 9 : C 10 : C - De convertir un MCHAML en CHPOINT (mot cle CHPO) 11 : C 12 : C - De convertir un CHPOINT en MCHAML (mot cle CHAM) 13 : C 14 : C - De changer le support d'un MCHAML 15 : C (mots cles NOEUDS, GRAVITE, RIGIDITE, MASSE et STRESSES) 16 : C 17 : C - De changer l'attribut d'un champ de points 18 : C 19 : C - De changer le nom du constituant d'un champ par element ou d un modele 20 : C 21 : C - De changer une rigidite cree par RELA en rigidite de dependence 22 : C 23 : C - Changer la casse d'un mot 24 : C-------------------------------------------------------------------- 25 : 26 : IMPLICIT INTEGER(I-N) 27 : IMPLICIT REAL*8(A-H,O-Z) 28 : 29 : -INC CCOPTIO 30 : -INC CCHAMP 31 : -INC CCGEOME 32 : 33 : -INC SMELEME 34 : -INC SMCHPOI 35 : -INC SMCHAML 36 : -INC SMRIGID 37 : -INC SMMODEL 38 : -INC SMLMOTS 39 : C 40 : PARAMETER (NTYP=23 , LATRI = 4, NLIG = 8 ) 41 : CHARACTER*8 LISTYP(NTYP) 42 : CHARACTER*4 LISTATRI(LATRI) 43 : CHARACTER*4 LISMAT(3), LIRIG(1), liscom(2),lismul(1) 44 : CHARACTER*4 MOTLIG(NLIG), MOMOYE(2) 45 : CHARACTER*72 CHAR,CHAR1 46 : PARAMETER (LMOTL=512) 47 : CHARACTER*(LMOTL) MENT,MSOR 48 : 49 : DATA LISTYP / 'NOEUD ', 'GRAVITE ', 'RIGIDITE', 'MASSE ', 50 : & 'STRESSES', 'THERMIQU', 'FACE ', 'P1CENTRE', 51 : & 'MSOMMET ', 'CHPO ', 'CHAM ', '--------', 52 : & '--------', 'TYPE ', 'ATTRIBUT', 'CONS ', 53 : & 'DEPE ', 'COND ', 'COMP ', 'INCO ', 54 : & 'TABL ', 'MINU ', 'MAJU '/ 55 : 56 : DATA LISTATRI / 'NATU', 'INDE', 'DIFF', 'DISC' / 57 : 58 : DATA LISMAT / 'SYME', 'ANTI', 'QUEL' / 59 : DATA LIRIG / 'LX ' / 60 : DATA LISCOM / 'COMP', 'REEL' / 61 : DATA LISMUL / 'MULT' / 62 : 63 : DATA MOMOYE/'SOMM','MOYE'/ 64 : DATA MOTLIG / 'LIGN', 'LINE', 'QUAD', 'QUAF', 'MACR', 'CUBI', 65 : & 'DECL', 'LINB' / 66 : 67 : ILIG=0 68 : 68 : CALL LIRMOT(LISTYP,NTYP,IPLAC,0) 69 : * WRITE(IOIMP,*) 'IPLAC=',IPLAC 70 : IF (IERR.NE.0) RETURN 71 : C 71 : IF (IPLAC.EQ.0) CALL LIRMOT(MOTLIG,NLIG,ILIG,0) 72 : IF (ILIG.EQ.1) THEN 72 : CALL CHANLG 73 : RETURN 74 : ELSEIF(ILIG.EQ.2) THEN 74 : CALL CHANLI 75 : RETURN 76 : ELSEIF(ILIG.EQ.3) THEN 76 : CALL CHANQU 77 : RETURN 78 : ELSEIF(ILIG.EQ.4) THEN 78 : CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 79 : IF(IRET.EQ.0)RETURN 79 : CALL KQCEST(MELEME,IKR) 79 : CALL ECROBJ('MAILLAGE',MELEME) 80 : IF(IKR.EQ.2)THEN 80 : CALL CHANQU 81 : ENDIF 81 : CALL C20227 82 : RETURN 83 : ELSEIF(ILIG.EQ.5) THEN 83 : CALL CMACRO 84 : RETURN 85 : ELSEIF(ILIG.EQ.6) THEN 85 : CALL CCUBIC 86 : RETURN 87 : ELSEIF(ILIG.EQ.7) THEN 87 : CALL CQ2L 88 : RETURN 89 : ELSEIF(ILIG.EQ.8) THEN 89 : CALL CLINB 90 : RETURN 91 : ENDIF 92 : C 93 : IF (IPLAC.EQ.0) THEN 93 : CALL LIRMOT(NOMS,NOMBR,ITY,0) 94 : IF (ITY.EQ.0) ITY=ILCOUR 94 : CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU) 95 : IF (IRETOU.EQ.1) THEN 96 : SEGACT MELEME 96 : CALL CHANGE(MELEME,ITY) 96 : IF(IERR.EQ.0) CALL ECROBJ('MAILLAGE',MELEME) 97 : SEGDES MELEME 98 : RETURN 99 : ELSE 100 : C 101 : C PAS D OPERANDE CORRECTE TROUVE 102 : C 102 : CALL QUETYP(MOTERR(1:8),0,IRETOU) 103 : IF(IRETOU.NE.0) THEN 103 : CALL ERREUR (39) 104 : ELSE 104 : CALL ERREUR(533) 105 : ENDIF 106 : RETURN 107 : ENDIF 108 : C 109 : C OPERANDE CORRECTE TROUVE 110 : C 111 : ELSE 112 : GO TO ( 300, 300, 300, 300, 300, 300, 300, 300, 300, 100, 113 : & 800, 400, 600,1200,1300,1400,1500,1500,1600,1700, 114 : & 2100,2200,2200),IPLAC 115 : C 116 : C CHANGEMENT EN CHPOINT D'UN MCHAML 117 : C 117 : 100 CALL LIRMOT(MOMOYE,2,IMOY,0) 118 : IF(IMOY.EQ.0) IMOY=2 119 : IMOY=IMOY-1 119 : CALL LIROBJ('MCHAML ',IPOI2,1,IRETOU) 120 : IF(IERR.NE.0) RETURN 120 : CALL LIROBJ('MMODEL',IPOI1,1,IRETOU) 121 : IF(IERR.NE.0) RETURN 121 : CALL CHASUP(IPOI1,IPOI2,IPOI3,IRT2,1) 122 : IF(IRT2.NE.0) THEN 122 : CALL ERREUR(IRT2) 123 : RETURN 124 : ENDIF 124 : CALL CHAMPO(IPOI3,IMOY,IPOI4,IRET) 125 : C A PRIORI LE CHPO EST DE NATURE DIFFUSE 126 : MCHPOI = IPOI4 127 : SEGACT MCHPOI*MOD 128 : JATTRI(1) = 1 129 : SEGDES MCHPOI 129 : CALL ECROBJ('CHPOINT ',IPOI4) 130 : RETURN 131 : C 132 : 200 CONTINUE 133 : 400 CONTINUE 134 : 600 CONTINUE 135 : RETURN 136 : C 137 : C CHANGEMENT DE CHPOINT EN MCHAML A PARTIR D'UN MODELE 138 : C 138 : 800 CALL LIROBJ('MMODEL ',IPOI1,0,IRETOU) 139 : IF(IERR.NE.0) RETURN 140 : IF(IRETOU.EQ.0) GOTO 900 140 : CALL LIROBJ('CHPOINT ',IPOI2,1,IRETOU) 141 : IF(IERR.NE.0) RETURN 142 : 143 : LONS=0 144 : MMODEL=IPOI1 145 : SEGACT MMODEL 146 : N1=KMODEL(/1) 147 : DO 41 L=1,N1 148 : IMODEL=KMODEL(L) 149 : SEGACT IMODEL 150 : IF(FORMOD(1).EQ.'NAVIER_STOKES') LONS=LONS+1 151 : SEGDES IMODEL 152 : 41 CONTINUE 153 : SEGDES MMODEL 154 : 155 : IF(LONS.EQ.0) THEN 156 : * 157 : * LECTURE DU LIEU SUPPORT DU MCHAML 158 : * 158 : CALL LIRMOT(LISTYP,5,ISUP ,0) 159 : IF (IERR.NE.0) RETURN 160 : IF (ISUP.EQ.0) ISUP=1 161 : * 161 : CALL LIRCHA(CHAR,0,IRETOU) 162 : IF(IERR.NE.0) RETURN 163 : C 164 : IF (IRETOU.EQ.0) THEN 165 : CHAR=' ' 166 : IRETOU=1 167 : ENDIF 168 : C 168 : CALL CHAME1(0,IPOI1,IPOI2,CHAR(1:IRETOU),IPOI3,ISUP) 169 : IF(IERR.NE.0) RETURN 169 : CALL ECROBJ('MCHAML ',IPOI3) 170 : RETURN 171 : 172 : ELSEIF(LONS.EQ.N1) THEN 173 : C Traitement specifique dans le cas d'un objet modele de 174 : C type Navier-Stokes 175 : * 176 : * LECTURE EVENTUELLE DU SUPPORT CIBLE DU MCHAML 177 : * 177 : CALL LIRMOT(LISTYP,9,ISUP ,0) 178 : IF (IERR.NE.0) RETURN 179 : C ISUP=0 : Transformation CHPO->CHAML en gardant le meme spg 179 : CALL KCHAM1(IPOI1,IPOI2,IPOI3) 180 : IF(IERR.NE.0) RETURN 181 : IF (ISUP.NE.0) THEN 181 : CALL CHASPG(IPOI1,IPOI3,IPOI4,IRET,ISUP) 182 : C IF (IRET.NE.0) MCHAM=MCHA1 182 : IF (IRET.NE.0) CALL ERREUR(IRET) 183 : IF(IERR.NE.0) RETURN 184 : IPOI3=IPOI4 185 : ENDIF 185 : CALL ECROBJ('MCHAML ',IPOI3) 186 : RETURN 187 : ENDIF 188 : C 189 : C CHANGEMENT DE CHPOINT EN MCHAML A PARTIR D'UN MAILLAGE 190 : C 190 : 900 CALL LIROBJ('MAILLAGE',IPOI1,1,IRETOU) 191 : IF(IERR.NE.0) RETURN 191 : CALL LIROBJ('CHPOINT ',IPOI2,1,IRETOU) 192 : IF(IERR.NE.0) RETURN 192 : CALL LIRCHA(CHAR,0,IRETOU) 193 : IF(IERR.NE.0) RETURN 194 : C 195 : IF (IRETOU.EQ.0) THEN 196 : CHAR='SCALAIRE' 197 : IRETOU=8 198 : ENDIF 199 : C 199 : CALL CHAME1(IPOI1,0,IPOI2,CHAR(1:IRETOU),IPOI3,1) 200 : IF(IERR.NE.0) RETURN 200 : CALL ECROBJ('MCHAML ',IPOI3) 201 : RETURN 202 : C 203 : C CHANGEMENT DE SUPPORT D'UN MCHAML 204 : C 204 : 300 CALL LIROBJ('MMODEL',IPOI1,1,IRETOU) 205 : IF(IERR.NE.0) RETURN 205 : CALL LIROBJ('MCHAML',IPOI2,1,IRETOU) 206 : IF(IERR.NE.0) RETURN 207 : 208 : LONS=0 209 : MMODEL=IPOI1 210 : SEGACT MMODEL 211 : N1=KMODEL(/1) 212 : DO 42 L=1,N1 213 : IMODEL=KMODEL(L) 214 : SEGACT IMODEL 215 : IF(FORMOD(1).EQ.'NAVIER_STOKES') LONS=LONS+1 216 : SEGDES IMODEL 217 : 42 CONTINUE 218 : SEGDES MMODEL 219 : 220 : IF(LONS.EQ.0) THEN 221 : C cas normal 221 : CALL CHASUP(IPOI1,IPOI2,IPOI3,IRT2,IPLAC) 222 : IF(IRT2.NE.0) THEN 222 : CALL ERREUR(IRT2) 223 : RETURN 224 : ENDIF 225 : ELSEIF(LONS.EQ.N1) THEN 226 : C Traitement specifique dans le cas d'un objet modele de 227 : C type Navier-Stokes 227 : CALL CHASPG(IPOI1,IPOI2,IPOI3,IRT2,IPLAC) 227 : IF (IRT2.NE.0) CALL ERREUR(IRT2) 228 : IF(IERR.NE.0) RETURN 229 : ENDIF 229 : CALL ECROBJ('MCHAML',IPOI3) 230 : RETURN 231 : C 232 : C CHANGEMENT DE TITRE D'UN MCHAML 233 : C 233 : 1200 CALL LIROBJ('MCHAML',IPOI1,1,IRETOU) 234 : IF(IERR.NE.0) RETURN 234 : CALL LIRCHA(CHAR,1,IRETOU) 235 : IF(IERR.NE.0) RETURN 235 : CALL CHATIT(IPOI1,CHAR(1:IRETOU),IPOI2) 235 : CALL ECROBJ('MCHAML',IPOI2) 236 : ENDIF 237 : RETURN 238 : C 239 : C CHANGEMENT DE L'ATTRIBUT D'UN CHAMP DE POINTS 240 : C 241 : 1300 CONTINUE 242 : C 242 : CALL LIRMOT(LISTATRI,LATRI,IPLAC,1) 243 : IF (IERR.NE.0) RETURN 243 : CALL LIROBJ('CHPOINT ',IPOI1,1,IRETOU) 244 : IF (IERR.NE.0) RETURN 245 : MCHPOI = IPOI1 246 : C CHANGEMENT DE NATURE 247 : IF ( IPLAC .EQ. 1 ) THEN 247 : CALL LIRMOT(LISTATRI,LATRI,IPLAC,1) 248 : IPLAC = IPLAC - 2 249 : SEGINI, MCHPO1=MCHPOI 250 : do iou=1,mchpo1.ipchp(/1) 251 : msoupo=mchpo1.ipchp(iou) 252 : segini,msoup1=msoupo 253 : mchpo1.ipchp(iou)=msoup1 254 : segdes msoup1 255 : enddo 256 : IPOI2 = MCHPO1 257 : MCHPO1.JATTRI(1) = IPLAC 258 : SEGDES, MCHPOI,MCHPO1 258 : CALL ECROBJ('CHPOINT ',IPOI2) 259 : ELSE 260 : MOTERR(1:4)='NATU' 260 : CALL ERREUR(396) 261 : RETURN 262 : ENDIF 263 : RETURN 264 : C 265 : C CHANGEMENT DE CONSTITUANT D'UN CHAMP PAR ELEMENT ou d 'un modele 266 : C 266 : 1400 CALL LIROBJ('MCHAML',IPOI1,0,IRETOU) 267 : IF (IERR.NE.0) RETURN 268 : if (iretou.ne.0) then 269 : MCHELM = IPOI1 270 : SEGINI , MCHEL1 = MCHELM 270 : CALL LIRCHA(CHAR,1,LCHAR) 271 : IF (IERR.NE.0) RETURN 272 : N1 = MCHEL1.CONCHE(/2) 273 : CHAR1 = MCHEL1.CONCHE(1) 274 : DO 1410 I=1,N1 275 : IF ( MCHEL1.CONCHE(I) .NE. CHAR1) THEN 275 : CALL ERREUR(716) 276 : SEGSUP MCHEL1 277 : RETURN 278 : ENDIF 279 : 1410 CONTINUE 280 : C 281 : DO 1420 I=1,N1 282 : MCHEL1.CONCHE(I) = CHAR 283 : 1420 CONTINUE 284 : SEGDES MCHEL1 285 : IPOI1 = MCHEL1 285 : CALL ECROBJ('MCHAML',IPOI1) 286 : RETURN 287 : * 288 : else 288 : CALL LIROBJ('MMODEL ',IPOI1,0,IRETOU) 289 : if (ierr.ne.0) return 290 : if (iretou.eq.0) then 291 : moterr(1:8) = 'MCHAML ' 292 : moterr(9:16)= 'MMODEL ' 292 : call erreur(471) 293 : return 294 : endif 295 : mmode1 = ipoi1 296 : segact mmode1 297 : n1 = mmode1.kmodel(/1) 298 : imode1 = mmode1.kmodel(1) 299 : segact imode1 300 : char1(1:LCONMO) = imode1.conmod 301 : segdes imode1 302 : if (n1.gt.1) then 303 : do ikmo = 2,n1 304 : imode2 = mmode1.kmodel(ikmo) 305 : segact imode2 306 : if (char1(1:LCONMO).ne.imode2.conmod(1:LCONMO)) then 307 : segdes imode2 307 : call erreur(732) 308 : return 309 : endif 310 : segdes imode2 311 : enddo 312 : endif 313 : segini,mmodel = mmode1 313 : CALL LIRCHA(CHAR,1,LCHAR) 314 : IF (IERR.NE.0) RETURN 315 : do ikmo = 1,n1 316 : imode1 = kmodel(ikmo) 317 : segini,imodel = imode1 318 : NFOR=FORMOD(/2) 319 : C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT 319 : CALL PLACE (FORMOD,NFOR,IDARC,'DARCY') 319 : CALL PLACE (FORMOD,NFOR,IEULE,'EULER') 319 : CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES') 320 : IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0)) INFMOD(2)=0 321 : kmodel(ikmo) = imodel 322 : conmod = char 323 : segdes imodel 324 : enddo 325 : segdes mmodel 326 : ipoi1 = mmodel 326 : call ecrobj('MMODEL ',ipoi1) 327 : return 328 : endif 329 : C 330 : C changement d une rigidite cree par relation 331 : C en matrice de dependence ou de condensation 332 : C 332 : 1500 CALL LIROBJ('RIGIDITE',IRIG,1,iret) 333 : IF (IERR.NE.0) RETURN 334 : 335 : * verification que la rigidité ne contient que des relation 336 : * c'est à dire n'est supportée que par des maillage de type 22 337 : * 338 : MRIGID = IRIG 339 : SEGACT, MRIGID*NOMOD 340 : DO 1510 I=1,IRIGEL(/2) 341 : MELEME = IRIGEL(1,I) 342 : SEGACT , MELEME*NOMOD 343 : IF (ITYPEL.NE.22) THEN 343 : CALL ERREUR(889) 344 : SEGDES MELEME 345 : SEGDES MRIGID 346 : RETURN 347 : ENDIF 348 : segdes meleme 349 : 1510 CONTINUE 350 : C 351 : C matrice de depedence 352 : MRIGID = IRIG 353 : SEGACT MRIGID 354 : segini , ri1=MRIGID 355 : iri1 = ri1 356 : * nrige=8 357 : nrigel=irigel(/2) 358 : segadj ri1 359 : do 1520 i=1,nrigel 360 : ri1.irigel(8,i)=1 361 : 1520 continue 362 : segdes mrigid,ri1 363 : C 364 : if(iplac.eq.17) then 364 : call ecrobj('RIGIDITE',iri1) 365 : else 365 : call depen3(iri1,iri2) 365 : call dual00(iri2,iri3) 365 : call ecrobj('RIGIDITE',iri3) 365 : call ecrobj('RIGIDITE',iri2) 366 : endif 367 : return 368 : c 368 : 1600 call nomc 369 : return 370 : * changement de nom d'inconnues primale et duale d'une matrice 371 : 1700 continue 371 : CALL LIROBJ('MATRIK ',IPO1,0,IRETOU) 372 : IF (IRETOU.NE.0) THEN 372 : CALL REFUS 372 : CALL MACHIN 373 : RETURN 374 : ENDIF 374 : CALL LIRMOT(LISCOM,2,ival,0) 374 : call lirobj('RIGIDITE',RI1,1,iretou) 375 : if( ierr.ne.0) return 376 : if(IVAL.EQ.0 )THEN 376 : call lirobj ( 'LISTMOTS',mlmot1,1,iretou) 377 : if(ierr.ne.0) return 377 : call lirobj ('LISTMOTS',mlmot2,1,iretou) 378 : if( ierr.ne.0) return 378 : call lirobj('LISTMOTS',mlmot3,1,iretou) 379 : if( ierr.ne.0) return 379 : call lirobj('LISTMOTS',mlmot4,1,iretou) 380 : if( ierr.ne.0) return 381 : C 381 : CALL LIRMOT(LISMAT,3,IPLAMA,0) 381 : CALL LIRMOT(LISMUL,1,IPLMUL,0) 382 : C 383 : segact mlmot1,mlmot2,mlmot3,mlmot4 384 : il1=mlmot1.mots(/2) 385 : il2=mlmot2.mots(/2) 386 : il3=mlmot3.mots(/2) 387 : il4=mlmot4.mots(/2) 388 : if(il1.ne.il2.or.il3.ne.il4) then 388 : call erreur(854) 389 : segdes mlmot1,mlmot2,mlmot3,mlmot4 390 : endif 391 : ELSE 392 : JGN=4 393 : JGM=lnomdd 394 : segini mlmot1,mlmot2,mlmot3,mlmot4 395 : do jkl=1,lnomdd 396 : mlmot1.mots(jkl)=nomdd(jkl) 397 : mlmot2.mots(jkl)(1:1)='I' 398 : mlmot2.mots(jkl)(2:4)=nomdd(jkl)(1:3) 399 : mlmot3.mots(jkl)=nomdu(jkl) 400 : mlmot4.mots(jkl)(1:1)='I' 401 : mlmot4.mots(jkl)(2:4)=nomdu(jkl)(1:3) 402 : enddo 403 : 404 : ENDIF 405 : segini,mrigid=ri1 406 : ichole=0 407 : imgeo1=0 408 : imgeo2=0 409 : isupeq=0 410 : jrcond=0 411 : jrdepp=0 412 : jrdepd=0 413 : jrelim=0 414 : jrgard=0 415 : jrtot=0 416 : do 1701 k=1,irigel(/2) 417 : IF (IPLAMA.EQ.1) THEN 418 : irigel(7,k) = 0 419 : ELSEIF (IPLAMA.EQ.2) THEN 420 : irigel(7,k) = 1 421 : ELSEIF (IPLAMA.EQ.3) THEN 422 : irigel(7,k) = 2 423 : ENDIF 424 : des1=irigel(3,k) 425 : segini,descr=des1 426 : 427 : irigel(3,k)=descr 428 : do 1702 ka=1,lisinc(/2) 429 : if(lisinc(ka).EQ.'LX '.and.iplmul.eq.0) go to 1702 430 : do 1703 kb=1,mlmot1.mots(/2) 431 : if( lisinc(ka).eq.mlmot1.mots(kb) ) then 432 : lisinc(ka)=mlmot2.mots(kb) 433 : go to 1702 434 : endif 435 : 1703 continue 436 : 1702 continue 437 : do 1704 ka=1,lisdua(/2) 438 : if( lisdua(ka).eq.'FLX '.and.iplmul.eq.0) go to 1704 439 : do 1705 kb=1,mlmot3.mots(/2) 440 : if( lisdua(ka).eq.mlmot3.mots(kb) ) then 441 : lisdua(ka)=mlmot4.mots(kb) 442 : go to 1704 443 : endif 444 : 1705 continue 445 : 1704 continue 446 : segdes descr 447 : 1701 continue 448 : segdes mrigid 449 : if(ival.eq.0) then 450 : segdes mlmot1,mlmot2,mlmot3,mlmot4 451 : else 452 : segsup mlmot1,mlmot2,mlmot3,mlmot4 453 : endif 453 : call ecrobj('RIGIDITE',mrigid) 454 : return 455 : * 456 : * changement de presentation d'un chargement 457 : * mise sous forme table de chpoint (plus rapide pour l'opérateur TIRE) 458 : * 458 : 2100 call chatab 459 : return 460 : * 461 : * Changement de la casse d'un mot 462 : * 463 : 2200 continue 464 : ICASS=IPLAC-22 464 : CALL LIRCHA(MENT,1,LENT) 465 : IF (IERR.NE.0) RETURN 465 : CALL CHCASS(MENT(1:LENT),ICASS,MSOR(1:LENT)) 465 : CALL ECRCHA(MSOR(1:LENT)) 466 : END 467 : 468 : 469 : 470 : 471 : 472 : 473 : 474 :
© Cast3M 2003 - All rights reserved.
Disclaimer