1 : C VNIMP SOURCE MAGN 10/05/18 21:16:35 6675 2 : SUBROUTINE VNIMP 3 : C************************************************************************ 4 : C 5 : C************************************************************************ 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8 (A-H,O-Z) 8 : 9 : -INC CCOPTIO 10 : -INC CCGEOME 11 : -INC SIZFFB 12 : POINTEUR IZF1.IZFFM,IZH2.IZHR 13 : 14 : -INC SMCOORD 15 : -INC SMLENTI 16 : -INC SMELEME 17 : POINTEUR MELEM1.MELEME,MELEMS.MELEME,MELEML.MELEME 18 : POINTEUR MELENE.MELEME,MELEMQ.MELEME 19 : -INC SMCHPOI 20 : POINTEUR IZTU1.MPOVAL,IZTU2.MPOVAL,VNORM.MPOVAL 21 : 22 : -INC SMMATRIK 23 : -INC CCREEL 24 : -INC SMLMOTS 25 : POINTEUR LINCO.MLMOTS 26 : CHARACTER*8 NOMZ,NOMI,TYPE,TYPC,NOM0,NOMA,NOM,NOMP 27 : PARAMETER (NTB=1) 28 : CHARACTER*8 LTAB(NTB) 29 : DIMENSION KTAB(NTB),IXV(3),RO(1) 30 : DATA LTAB/'KIZX '/,RO/1.D0/ 31 : C***************************************************************************** 32 : CVNIMP 33 : C write(6,*)' DEBUT VNIMP ' 34 : 35 : IAXI=0 36 : IF(IFOMOD.EQ.0)IAXI=2 37 : 38 : DEUPI=1.D0 39 : IF(IAXI.NE.0)DEUPI=2.D0*XPI 40 : 40 : CALL LITABS(LTAB,KTAB,NTB,1,IRET) 41 : IF (IERR.NE.0) RETURN 42 : MTABX=KTAB(1) 43 : C 44 : C- Récupération de la table EQEX (pointeur MTAB1) 45 : C 45 : CALL LEKTAB(MTABX,'EQEX',MTAB1) 46 : IF(MTAB1.EQ.0)THEN 47 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 48 : MOTERR( 1: 8) = ' EQEX ' 49 : MOTERR( 9:16) = ' EQEX ' 50 : MOTERR(17:24) = ' KIZX ' 50 : CALL ERREUR(786) 51 : RETURN 52 : ENDIF 53 : 54 : C 55 : C- Récupération de la table INCO (pointeur KINC) 56 : C 56 : CALL LEKTAB(MTAB1,'INCO',KINC) 57 : IF(KINC.EQ.0)THEN 58 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 59 : MOTERR( 1: 8) = ' INCO ' 60 : MOTERR( 9:16) = ' INCO ' 61 : MOTERR(17:24) = ' EQEX ' 61 : CALL ERREUR(786) 62 : RETURN 63 : ENDIF 64 : 65 : C***************************************************************************** 66 : C OPTIONS 67 : C KIMPL = 0 -> EXPL 1 -> IMPL 2 -> SEMI 68 : C KFORM = 0 -> SI 1 -> EF 2 -> VF 3 -> EFMC 69 : C IDCEN = 0-> rien 1-> CENTREE 2-> SUPGDC 3-> SUPG 4-> TVISQUEU 5-> CNG 70 : 71 : C 72 : C- Récupération de la table des options KOPT (pointeur KOPTI) 73 : C 73 : CALL LEKTAB(MTABX,'KOPT',KOPTI) 74 : IF (KOPTI.EQ.0) THEN 75 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 76 : MOTERR( 1: 8) = ' KOPT ' 77 : MOTERR( 9:16) = ' KOPT ' 78 : MOTERR(17:24) = ' KIZX ' 78 : CALL ERREUR(786) 79 : RETURN 80 : ENDIF 81 : 81 : CALL ACME(KOPTI,'KIMPL',KIMPL) 81 : CALL ACME(KOPTI,'KPOIN',KPRE) 81 : CALL ACME(KOPTI,'KFORM',KFORM) 82 : 83 : IF (IERR.NE.0) RETURN 84 : 85 : C write(6,*)' Apres les options ' 86 : C***************************************************************************** 87 : C 88 : C- Récupération de la table DOMAINE associée au domaine local 89 : C 89 : CALL ACMM(MTABX,'NOMZONE',NOMZ) 90 : TYPE=' ' 90 : CALL ACMO(MTABX,'DOMZ',TYPE,MMODEL) 91 : IF(TYPE.NE.'MMODEL')THEN 92 : C On attend un des objets : %m1:8 %m9:16 %m17:24 %m25:32 %m33:40 93 : MOTERR( 1: 8) = ' MMODEL ' 94 : MOTERR( 8:16) = ' MMODEL ' 95 : MOTERR(17:24) = ' MMODEL ' 96 : MOTERR(25:32) = ' MMODEL ' 97 : MOTERR(33:40) = ' MMODEL ' 97 : CALL ERREUR(471) 98 : RETURN 99 : ENDIF 100 : 101 : C E/ MMODEL : Pointeur de la table contenant l'information cherchée 102 : C /S IPOINT : Pointeur sur la table DOMAINE 103 : C /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE 104 : C INEFMD=4 LINB 105 : 105 : CALL LEKMOD(MMODEL,MTABZ,INEFMD) 106 : 107 : IF(INEFMD.EQ.4.AND.KPRE.NE.5)THEN 108 : C% Données incompatibles 108 : CALL ERREUR(21) 109 : RETURN 110 : ENDIF 111 : 111 : CALL LEKTAB(MTABZ,'MAILLAGE',MELEME) 111 : CALL LEKTAB(MTABZ,'SOMMET',MELEMS) 111 : CALL LEKTAB(MTABZ,'MLGVNIMP',MELEML) 111 : IF(KPRE.EQ.5)CALL LEKTAB(MTABZ,'MSOMMET',MELEML) 111 : IF(KPRE.EQ.5)CALL LEKTAB(MTABZ,'MMAIL' ,MELENE) 112 : 113 : 114 : C************************************************************************* 115 : C VERIFICATIONS SUR LES INCONNUES 116 : C 117 : C- Récupération du nombre d'inconnues et du nom de l'inconnue NOMI 118 : C 119 : TYPE='LISTMOTS' 119 : CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO) 120 : IF (IERR.NE.0) RETURN 121 : SEGACT LINCO 122 : NBINC=LINCO.MOTS(/2) 123 : IF((NBINC.NE.1.AND.NBINC.NE.2).AND.KPRE.NE.5)THEN 124 : C Indice %m1:8 : contient plus de %i1 %m9:16 125 : MOTERR( 1:8) = 'LISTINCO' 126 : INTERR(1) = 1 127 : MOTERR(9:16) = ' MOTS ' 127 : CALL ERREUR(799) 128 : RETURN 129 : ELSEIF(NBINC.NE.2.AND.KPRE.EQ.5)THEN 130 : C Indice %m1:8 : contient plus de %i1 %m9:16 131 : MOTERR( 1:8) = 'LISTINCO' 132 : INTERR(1) = 2 133 : MOTERR(9:16) = ' MOTS ' 133 : CALL ERREUR(799) 134 : RETURN 135 : ENDIF 136 : 137 : NOMI=LINCO.MOTS(1) 138 : NOMP='LVNP' 139 : IF(KPRE.EQ.5)NOMP=LINCO.MOTS(2) 140 : C 141 : C- Récupération de l'inconnue 142 : C 143 : TYPE=' ' 143 : CALL ACMO(KINC,NOMI,TYPE,MCHPOI) 144 : IF(TYPE.NE.'CHPOINT ')THEN 145 : C Indice %m1:8 : ne contient pas un objet de type %m9:16 146 : MOTERR( 1: 8) = 'INC '//NOMI 147 : MOTERR( 9:16) = 'CHPOINT ' 147 : CALL ERREUR(800) 148 : RETURN 149 : ELSE 149 : CALL LICHT(MCHPOI,IZTU1,TYPC,MELEM1) 150 : NINKO = IZTU1.VPOCHA(/2) 151 : IF (NINKO.NE.IDIM) THEN 152 : C Indice %m1:8 : Le %m9:16 n'a pas le bon nombre de composantes 153 : MOTERR( 1: 8) = 'INC '//NOMI 154 : MOTERR( 9:16) = 'CHPOINT ' 154 : CALL ERREUR(784) 155 : RETURN 156 : ENDIF 157 : C On fait pointer ces deux tableaux sur le champ U inconu (tjs présent) pour 158 : C eviter de les enlever lors de l'appel FORTRAN si les options sont absentes 159 : ENDIF 160 : 161 : IF(KPRE.EQ.5)THEN 162 : 163 : TYPE=' ' 163 : CALL ACMO(KINC,NOMP,TYPE,MCHPO2) 164 : IF(TYPE.NE.'CHPOINT ')THEN 165 : C Indice %m1:8 : ne contient pas un objet de type %m9:16 166 : MOTERR( 1: 8) = 'INC '//NOMP 167 : MOTERR( 9:16) = 'CHPOINT ' 167 : CALL ERREUR(800) 168 : RETURN 169 : ELSE 169 : CALL LICHT(MCHPO2,IZTU2,TYPC,MELEM2) 170 : NINK2 = IZTU2.VPOCHA(/2) 171 : IF (NINK2.NE.1) THEN 172 : C Indice %m1:8 : Le %m9:16 n'a pas le bon nombre de composantes 173 : MOTERR( 1: 8) = 'INC '//NOMP 174 : MOTERR( 9:16) = 'CHPOINT ' 174 : CALL ERREUR(784) 175 : RETURN 176 : ENDIF 177 : C On fait pointer ces deux tableaux sur le champ U inconu (tjs présent) pour 178 : C eviter de les enlever lors de l'appel FORTRAN si les options sont absentes 179 : ENDIF 180 : 181 : ENDIF 182 : C***************************************************************************** 183 : C Le domaine de definition est donne par le SPG de la premiere inconnue 184 : C Les inconnues suivantes devront posseder ce meme pointeur 185 : C On verifie que les points de la zone sont tous inclus dans ce SPG 186 : 186 : CALL KRIPAD(MELEM1,IPADI) 187 : 187 : CALL VERPAD(IPADI,MELEME,IRET) 188 : IF(IRET.NE.0)THEN 189 : C Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique 190 : MOTERR(1: 8) = 'INC '//NOMI 191 : MOTERR(9:16) = 'CHPOINT ' 191 : CALL ERREUR(788) 192 : RETURN 193 : ENDIF 194 : 195 : C***************************************************************************** 196 : 197 : 198 : 199 : C************************************************************************* 200 : C Lecture des coefficients 201 : C Type du coefficient : 202 : C IK1=0 CHPOINT IK1=1 scalaire IK1=2 vecteur 203 : C write(6,*)' Lecture des coefficients ' 204 : 204 : CALL ACME(MTABX,'IARG',IARG) 205 : IF(IARG.LT.2)THEN 206 : C Indice %m1:8 : nombre d'arguments incorrect 207 : MOTERR(1:8) = 'IARG ' 207 : CALL ERREUR(804) 208 : RETURN 209 : ENDIF 210 : 211 : TYPE=' ' 211 : CALL ACMO(MTABX,'ARG1',TYPE,MMODER) 212 : IF(TYPE.NE.'MMODEL')THEN 213 : C On attend un des objets : %m1:8 %m9:16 %m17:24 %m25:32 %m33:40 214 : MOTERR( 1: 8) = ' MMODEL ' 215 : MOTERR( 8:16) = ' MMODEL ' 216 : MOTERR(17:24) = ' MMODEL ' 217 : MOTERR(25:32) = ' MMODEL ' 218 : MOTERR(33:40) = ' MMODEL ' 218 : CALL ERREUR(471) 219 : RETURN 220 : ENDIF 221 : 222 : C E/ MMODEL : Pointeur de la table contenant l'information cherchée 223 : C /S IPOINT : Pointeur sur la table DOMAINE 224 : C /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE 225 : C INEFMD=4 LINB 226 : 226 : CALL LEKMOD(MMODER,MTABR,INEFDR) 227 : IF(INEFDR.NE.INEFMD)THEN 228 : C% Données incompatibles 228 : CALL ERREUR(21) 229 : RETURN 230 : ENDIF 230 : CALL LEKTAB(MTABR,'SOMMET',MELEMR) 230 : CALL KRIPAD(MELEMR,MLENTI) 230 : CALL VERPAD(MLENTI,MELEMS,IRET) 231 : IF(IRET.NE.0)THEN 232 : C Le support du %m1:8 est incompatible avec celui-ci 233 : MOTERR(1: 8) = 'MODELE' 233 : CALL ERREUR(708) 234 : RETURN 235 : ENDIF 236 : SEGSUP MLENTI 237 : 238 : 239 : c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 240 : IXV(1)=MELEMS 241 : C IXV(1)=0 242 : IXV(2)=1 243 : IXV(3)=0 243 : CALL LEKCOF('Opérateur VNIMP :', 244 : & MTABX,KINC,2,IXV,IZTG1,VNORM,NPT1,NC1,IK1,IRET) 245 : IF(IRET.EQ.0)RETURN 246 : 247 : C write(6,*)' Operateur VNIMP : Fin lecture Arguments ' 248 : C Fin lecture Arguments ************************************************ 249 : 250 : IF(KPRE.NE.5)THEN 251 : C 252 : C Pressions discontinues 253 : C 253 : CALL LEKTAB(MTABZ,'NORMALEV',MNORM) 253 : CALL LICHT(MNORM,MPOVA2,TYPC,MELEML) 254 : 255 : NAT=2 256 : NSOUPO=1 257 : SEGACT MELEML 258 : N=MELEML.NUM(/2) 259 : NC=1 260 : SEGINI MCHPO1,MSOUP1,MPOVA1 261 : MCHPO1.IFOPOI=IFOMOD 262 : MCHPO1.MOCHDE=' ' 263 : MCHPO1.MTYPOI='SMBR' 264 : MCHPO1.JATTRI(1)=2 265 : MCHPO1.IPCHP(1)=MSOUP1 266 : MSOUP1.NOCOMP(1)='LVNP' 267 : MSOUP1.IGEOC=MELEML 268 : MSOUP1.IPOVAL=MPOVA1 269 : 270 : NRIGE=7 271 : NKID =9 272 : NKMT =7 273 : NMATRI=1 274 : SEGINI MATRIK 275 : 276 : NBSOUS=1 277 : 278 : IRIGEL(1,1)=MELEMS 279 : IRIGEL(2,1)=MELEML 280 : IRIGEL(7,1)=4 281 : IF(KFORM.EQ.2)IRIGEL(7,1)=9 282 : NBME=NINKO 283 : SEGINI IMATRI 284 : IRIGEL(4,1)=IMATRI 285 : KSPGP=MELEMS 286 : KSPGD=MELEML 287 : DO 102 I=1,NBME 288 : WRITE(NOM,FMT='(I1,A7)')I,NOMI(1:7) 289 : LISPRI(I)=NOM(1:4)//' ' 290 : LISDUA(I)='LVNP'//' ' 291 : 102 CONTINUE 292 : 293 : 294 : NUTOEL=0 295 : NBEL =MELEML.NUM(/2) 296 : NP =1 297 : MP =1 298 : 299 : SEGINI IPM1,IPM2 300 : LIZAFM(1,1)=IPM1 301 : LIZAFM(1,2)=IPM2 302 : IF(NBME.EQ.3)THEN 303 : SEGINI IPM3 304 : LIZAFM(1,3)=IPM3 305 : ENDIF 306 : 307 : DO 301 K=1,NBEL 308 : IPM1.AM(K,1,1)= MPOVA2.VPOCHA(K,1) 309 : IPM2.AM(K,1,1)= MPOVA2.VPOCHA(K,2) 310 : IF(IDIM.EQ.3)IPM3.AM(K,1,1)= MPOVA2.VPOCHA(K,3) 311 : 301 CONTINUE 312 : 313 : ELSEIF(KPRE.EQ.5)THEN 314 : C 315 : C Cas Pressions continue 316 : C 317 : C write(6,*)'Pressions continue' 318 : 318 : IF(INEFMD.EQ.2)CALL LEKTAB(MTABZ,'MACRO',MELEME) 318 : CALL LEKTAB(MTABR,'OENVELOP',MCHPOR) 318 : CALL LEKTAB(MTABZ,'QUAF ',MELEMQ) 319 : 319 : CALL LICHT(MCHPOR,MPOVA3,TYPC,IGEOM) 319 : CALL KRIPAD(IGEOM,MLENT3) 320 : 321 : NAT=2 322 : NSOUPO=1 323 : SEGACT MELEML 324 : N=MELEML.NUM(/2) 325 : NC=1 326 : SEGINI MCHPO1,MSOUP1,MPOVA1 327 : MCHPO1.IFOPOI=IFOMOD 328 : MCHPO1.MOCHDE=' ' 329 : MCHPO1.MTYPOI='SMBR' 330 : MCHPO1.JATTRI(1)=2 331 : MCHPO1.IPCHP(1)=MSOUP1 332 : MSOUP1.NOCOMP(1)=NOMP(1:4) 333 : MSOUP1.IGEOC=MELEML 334 : MSOUP1.IPOVAL=MPOVA1 335 : 336 : NRIGE=7 337 : NKID =9 338 : NKMT =7 339 : NMATRI=1 340 : SEGINI MATRIK 341 : 342 : SEGACT MELEME,MELENE 343 : NBSOUS=LISOUS(/1) 344 : 345 : IRIGEL(1,1)=MELEME 346 : IRIGEL(2,1)=MELENE 347 : IRIGEL(7,1)=-3 348 : NBME=NINKO 349 : NBSOUS=MAX(1,LISOUS(/1)) 350 : SEGINI IMATRI 351 : IRIGEL(4,1)=IMATRI 352 : KSPGP=MELEMS 353 : KSPGD=MELEML 354 : DO 202 I=1,NBME 355 : WRITE(NOM,FMT='(I1,A7)')I,NOMI(1:7) 356 : LISPRI(I)=NOM(1:4)//' ' 357 : LISDUA(I)=NOMP(1:4)//' ' 358 : 202 CONTINUE 359 : 360 : SEGACT MELEMQ 361 : NUTOEL=0 362 : DO 203 L=1,MAX(1,LISOUS(/1)) 363 : IPT1=MELEME 364 : IPT2=MELENE 365 : IPT3=MELEMQ 366 : IF(LISOUS(/1).NE.0)IPT1=LISOUS(L) 367 : IF(MELENE.LISOUS(/1).NE.0)IPT2=MELENE.LISOUS(L) 368 : IF(MELEMQ.LISOUS(/1).NE.0)IPT3=MELEMQ.LISOUS(L) 369 : SEGACT IPT1,IPT2,IPT3 370 : 371 : NBEL =IPT1.NUM(/2) 372 : NP =IPT1.NUM(/1) 373 : MP =IPT2.NUM(/1) 374 : NQ =IPT3.NUM(/1) 375 : IF(NQ.EQ.3)THEN 376 : IFA=2 377 : ELSE 378 : IFA=NQ 379 : ENDIF 380 : 381 : 382 : SEGINI IPM1,IPM2 383 : LIZAFM(L,1)=IPM1 384 : LIZAFM(L,2)=IPM2 385 : IF(NBME.EQ.3)THEN 386 : SEGINI IPM3 387 : LIZAFM(L,3)=IPM3 388 : ENDIF 389 : 390 : NOM0=NOMS(IPT1.ITYPEL)//' ' 391 : IF(INEFMD.EQ.1)NOM0=NOMS(IPT1.ITYPEL)//'P1P1' 392 : IF(INEFMD.EQ.2)NOM0=NOMS(IPT1.ITYPEL)//'MCF1' 393 : IF(INEFMD.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'PFP1' 394 : IF(INEFMD.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'P1P1' 395 : 395 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 396 : SEGACT IZFFM*MOD 397 : IZHR=KZHR(1) 398 : IZH2=KZHR(2) 399 : IZF1=KTP(1) 400 : SEGACT IZHR*MOD,IZF1*MOD 401 : NES=GR(/1) 402 : NPG=GR(/3) 403 : 404 : DO 201 K=1,NBEL 405 : 406 : DO 20 I=1,NP 407 : J1 = IPT1.NUM(I,K) 408 : DO 10 N=1,IDIM 409 : XYZ(N,I) = XCOOR((J1-1)*(IDIM+1)+N) 410 : 10 CONTINUE 411 : 20 CONTINUE 411 : CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG, 412 : & NES,IDIM,NP,NPG,IAXI,AIRE,AJ,ASGN) 413 : 414 : BSGN=0.D0 415 : DO 21 N=1,IDIM 416 : BSGN=BSGN+ 417 : &(AJ(N,IDIM,1)*MPOVA3.VPOCHA(MLENT3.LECT(IPT3.NUM(IFA,K)),N)) 418 : 21 CONTINUE 419 : CSGN=-1.D0 420 : IF(BSGN.LT.0.D0)CSGN=1.D0 421 : 422 : DO 302 I=1,NP 423 : DO 302 J=1,MP 424 : UX=0.D0 425 : UY=0.D0 426 : UZ=0.D0 427 : UT=0.D0 428 : DO 304 LG=1,NPG 429 : UX=UX+FN(I,LG)*IZF1.FN(J,LG)*AJ(1,IDIM,LG)*PGSQ(Lg)*DEUPI*RPG(Lg) 430 : UY=UY+FN(I,LG)*IZF1.FN(J,LG)*AJ(2,IDIM,LG)*PGSQ(Lg)*DEUPI*RPG(Lg) 431 : IF(IDIM.EQ.3) 432 : &UZ=UZ+FN(I,LG)*IZF1.FN(J,LG)*AJ(3,IDIM,LG)*PGSQ(Lg)*DEUPI*RPG(Lg) 433 : 304 CONTINUE 434 : IPM1.AM(K,I,J)= UX*CSGN 435 : IPM2.AM(K,I,J)= UY*CSGN 436 : IF(IDIM.EQ.3)IPM3.AM(K,I,J)= UZ*CSGN 437 : 302 CONTINUE 438 : 201 CONTINUE 439 : SEGSUP IZFFM,IZHR,IZH2,IZF1 440 : SEGDES IPT1,IPT2 441 : 203 CONTINUE 442 : 443 : SEGSUP MLENT3 444 : 445 : ENDIF 446 : 446 : CALL ECROBJ('MATRIK',MATRIK) 446 : CALL ECROBJ('CHPOINT',MCHPO1) 447 : 448 : RETURN 449 : 1001 FORMAT(20(1X,I5)) 450 : 1002 FORMAT(10(1X,1PE11.4)) 451 : END 452 : 453 : 454 : 455 : 456 : 457 : 458 : 459 : 460 : 461 : 462 :
© Cast3M 2003 - All rights reserved.
Disclaimer