1 : C ZZFIMP SOURCE MAGN 10/05/18 21:18:09 6675 2 : SUBROUTINE ZZFIMP(MTABX,MTAB1) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C*********************************************************************** 6 : C 7 : C SYNTAXE : 8 : C 9 : C FIMP coef 10 : C 11 : C EN 2D 12 : C elements SEG2 -> Flux 13 : C elements TRI3 -> Source volumique 14 : C elements QUA4 -> Source volumique 15 : C EN 3D 16 : C elements SEG2 -> Pas de sens !! 17 : C elements TRI3 -> Flux 18 : C elements QUA4 -> Flux 19 : C elements CUB8 -> Source volumique 20 : C elements PRI6 -> Source volumique 21 : C elements TET4 -> Source volumique 22 : C 23 : C 24 : C MTAB1 : Table type EQEX -> RV 25 : C MTABZ : Table type DOMAINE -> Zone definition opérateur 26 : C MTABD : Table type DOMAINE -> Zone Totale apres assemblage 27 : C MTABX : Table type KIZX -> Description opérateur 28 : C 29 : C les cartes correspondantes sont commentées C¤. 30 : C Gare à l'explicite !!! 31 : C 32 : C 33 : C 34 : C 35 : C*********************************************************************** 36 : 37 : -INC CCOPTIO 38 : -INC CCGEOME 39 : -INC SMCHAML 40 : -INC SMCOORD 41 : -INC SMLENTI 42 : -INC SMELEME 43 : POINTEUR MELEM1.MELEME,SPGID.MELEME,SPGZ.MELEME 44 : POINTEUR MELEMP.MELEME 45 : -INC SMCHPOI 46 : POINTEUR IZG1.MCHPOI, IZGG1.MPOVAL 47 : POINTEUR IZTU1.MPOVAL 48 : POINTEUR MZFLU.MPOVAL 49 : POINTEUR IZVOL.MPOVAL 50 : -INC SIZFFB 51 : POINTEUR IZF1.IZFFM 52 : 53 : -INC SMLMOTS 54 : POINTEUR LINCO.MLMOTS 55 : CHARACTER*8 NOMZ,NOMI,NOMA,TYPE,NOM0,TYPC,MTERR 56 : LOGICAL LOGI 57 : PARAMETER (NTB=1) 58 : CHARACTER*8 LTAB(NTB) 59 : DIMENSION KTAB(NTB),IXV(4) 60 : SAVE IPAS 61 : DATA LTAB/'KIZX '/,IPAS/0/ 62 : C***************************************************************************** 63 : CFIMP 64 : C? write(6,*)' Debut FIMP' 65 : C 66 : C- Récupération de la table INCO (pointeur KINC) 67 : C 67 : CALL LEKTAB(MTAB1,'INCO',KINC) 68 : IF(KINC.EQ.0)THEN 69 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 70 : MOTERR( 1: 8) = ' INCO ' 71 : MOTERR( 9:16) = ' INCO ' 72 : MOTERR(17:24) = ' EQEX ' 72 : CALL ERREUR(786) 73 : RETURN 74 : ENDIF 75 : 76 : C***************************************************************************** 77 : C OPTIONS 78 : C KFORM = 0 -> SI 1 -> EF 2 -> VF 3 -> EFMC 79 : C IDCEN = 0->rien 1-> CENTREE 2-> SUPGDC 3-> SUPG 4-> TVISQUEU 5-> CNG 80 : C KPOIN = 0->SOMMET 1-> FACE 2-> CENTRE 3-> CENTREP0 4-> CENTREP1 81 : 82 : IAXI=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 : 95 : 95 : CALL ACME(KOPTI,'MTRMASS ',MMPG) 96 : IPG=0 97 : IF(MMPG.EQ.3)IPG=1 97 : CALL ACME(KOPTI,'IDCEN',IDCEN) 98 : KDIM=1 99 : IF(IDCEN.EQ.2)KDIM=IDIM 99 : CALL ACME(KOPTI,'IKOMP',IKOMP) 99 : CALL ACME(KOPTI,'KIMPL',KIMPL) 99 : CALL ACME(KOPTI,'KFORM',KFORM) 99 : CALL ACME(KOPTI,'KPOIND',KPOIND) 100 : C write(6,*)' INCOD=',KPOIND 101 : 102 : IF(KFORM.GE.2)THEN 103 : C Option %m1:8 incompatible avec les données 104 : MOTERR( 1: 8) = 'EF/EFM1 ' 104 : CALL ERREUR(803) 105 : RETURN 106 : ENDIF 106 : CALL ACME(KOPTI,'KMACO',KMACO) 106 : CALL ACMF(KOPTI,'AIMPL',AIMPL) 107 : IF (IERR.NE.0) RETURN 108 : 109 : C write(6,*)' Apres les options ' 110 : C***************************************************************************** 111 : C 112 : C- Récupération de la table DOMAINE associée au domaine local 113 : C 113 : CALL ACMM(MTABX,'NOMZONE',NOMZ) 113 : CALL LEKTAB(MTABX,'DOMZ',MTABZ) 114 : IF(MTABZ.EQ.0)THEN 115 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 116 : MOTERR( 1: 8) = ' DOMZ ' 117 : MOTERR( 9:16) = ' DOMZ ' 118 : MOTERR(17:24) = ' KIZX ' 118 : CALL ERREUR(786) 119 : RETURN 120 : ENDIF 121 : C 122 : C- Récupération des indices CENTRE, FACE, SOMMET et MAILLAGE 123 : C- de la table DOMAINE 124 : C 124 : C? CALL LEKTAB(MTABZ,'MAILLAGE',MELEME) 124 : CALL LEKTAB(MTABZ,'MAILLAGE',MELEMZ) 124 : CALL LEKTAB(MTABZ,'SOMMET',MELEMS) 124 : CALL LEKTAB(MTABZ,'CENTRE',MELEMC) 124 : CALL LEKTAB(MTABZ,'XXPSOML',MCHELM) 124 : CALL LEKTAB(MTABZ,'XXVOLUM',MCHVOL) 124 : CALL LEKTAB(MTABZ,'MACRO',MACRO) 124 : C? IF(CALL LEKTAB(MTABZ,'MACRO1',MACRO1) 124 : CALL LEKTAB(MTABZ,'QUADRATI',MQUAD) 125 : IF (IERR.NE.0) RETURN 126 : 126 : CALL LICHT(MCHVOL,IZVOL,TYPC,IGEOM) 127 : 128 : SEGACT MCHELM 129 : 130 : C 131 : C- Vérification des compatiblités Formulation/SPG 132 : C- Identification du spg de l'inconnue 133 : C- SPGZ=spg inco duale de la zone; MELEME=connectivité associée ; 134 : C 135 : 136 : C write(6,*)' KPOIND,KFORM=',KPOIND,KFORM 137 : IF(KFORM.EQ.0)THEN 138 : IF(KPOIND.EQ.99)THEN 139 : KPOIND=0 140 : SPGZ =MELEMS 141 : C MELEME=MELEMS 142 : MELEME=MELEMZ 143 : ELSEIF(KPOIND.EQ.2)THEN 144 : SPGZ =MELEMC 145 : MELEME=MELEMC 146 : MELEMP=MELEMC 147 : ELSEIF(KPOIND.EQ.0)THEN 148 : SPGZ =MELEMS 149 : C MELEME=MELEMS 150 : MELEME=MELEMZ 151 : ELSEIF(KPOIND.NE.2.AND.KPOIND.NE.0)THEN 152 : C Option %m1:8 incompatible avec les données 153 : MOTERR( 1: 8) = ' EF ' 153 : CALL ERREUR(803) 154 : RETURN 155 : ENDIF 156 : 157 : ELSEIF(KFORM.EQ.1)THEN 158 : C write(6,*)' KFORM=',kform,' KPOIND=',kpoind 159 : IF(KPOIND.EQ.99)THEN 160 : KPOIND=0 161 : SPGZ =MELEMS 162 : MELEME=MELEMZ 163 : ELSEIF(KPOIND.EQ.0)THEN 164 : SPGZ =MELEMS 165 : MELEME=MELEMZ 166 : ELSEIF(KPOIND.EQ.2)THEN 167 : SPGZ =MELEMC 168 : MELEME=MELEMZ 169 : MELEMP=MELEMC 170 : ELSEIF(KPOIND.EQ.3)THEN 171 : MTERR='EF CTRP0' 172 : IF(MACRO.EQ.0.AND.MQUAD.EQ.0)GO TO 90 172 : CALL LEKTAB(MTABZ,'CENTREP0',MELEMC) 173 : SPGZ =MELEMC 174 : MELEME=MELEMZ 174 : IF(MACRO.NE.0)CALL LEKTAB(MTABZ,'MACRO1',MELEME) 175 : MELEMP=MELEMC 176 : ELSEIF(KPOIND.EQ.4)THEN 177 : MTERR='EF CTRP1' 178 : IF(MACRO.EQ.0.AND.MQUAD.EQ.0)GO TO 90 178 : CALL LEKTAB(MTABZ,'CENTREP1',MELEMC) 179 : SPGZ =MELEMC 180 : MELEME=MELEMZ 180 : IF(MACRO.NE.0)CALL LEKTAB(MTABZ,'MACRO1',MELEME) 180 : CALL LEKTAB(MTABZ,'ELTP1NC ',MELEMP) 181 : ELSEIF(KPOIND.NE.2.AND.KPOIND.NE.0.AND.KPOIND.NE.3 182 : & .AND.KPOIND.NE.4)THEN 183 : C Option %m1:8 incompatible avec les données 184 : MOTERR( 1: 8) = ' EF ' 184 : CALL ERREUR(803) 185 : RETURN 186 : ENDIF 187 : 188 : ELSEIF(KFORM.EQ.2)THEN 189 : IF(KPOIND.EQ.99)THEN 190 : KPOIND=2 191 : SPGZ =MELEMC 192 : MELEME=MELEMC 193 : MELEMP=MELEMC 194 : ELSEIF(KPOIND.EQ.2)THEN 195 : SPGZ =MELEMC 196 : MELEME=MELEMC 197 : MELEMP=MELEMC 198 : ELSEIF(KPOIND.NE.2)THEN 199 : C Option %m1:8 incompatible avec les données 200 : MOTERR( 1: 8) = ' VF ' 200 : CALL ERREUR(803) 201 : RETURN 202 : ENDIF 203 : 204 : ELSEIF(KFORM.EQ.3)THEN 205 : MTERR='EFMC' 206 : GO TO 90 207 : IF(KPOIND.EQ.99.OR.KPOIND.EQ.2)THEN 208 : KPOIND=2 209 : SPGZ =MELEMC 210 : MELEME=MELEMC 211 : ELSEIF(KPOIND.EQ.3.AND.(MACRO.NE.0.OR.MQUAD.NE.0))THEN 211 : CALL LEKTAB(MTABZ,'CENTREP0',MELEMC) 212 : SPGZ =MELEMC 213 : MELEME=MELEMC 214 : ELSEIF(KPOIND.EQ.4.AND.(MACRO.NE.0.OR.MQUAD.NE.0))THEN 214 : CALL LEKTAB(MTABZ,'CENTREP1',MELEMC) 214 : CALL LEKTAB(MTABZ,'ELTP1NC',MELEMQ) 215 : SPGZ =MELEMC 216 : MELEME=MELEMQ 217 : IF(MACRO.NE.0)MELEMO=MACRO1 218 : IF(MQUAD.NE.0)MELEMO=MELEMZ 219 : C ELSEIF(KPOIND.NE.2.AND.KPOIND.NE.3.AND.KPOIND.NE.4)THEN 220 : ELSE 221 : C Option %m1:8 incompatible avec les données 222 : MOTERR( 1: 8) = ' EFMC ' 222 : CALL ERREUR(803) 223 : RETURN 224 : ENDIF 225 : 226 : ENDIF 227 : C************************************************************************* 228 : C VERIFICATIONS SUR LES INCONNUES 229 : C 230 : C- Récupération du nombre d'inconnues et du nom de l'inconnue NOMI 231 : C 232 : TYPE='LISTMOTS' 232 : CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO) 233 : IF (IERR.NE.0) RETURN 234 : SEGACT LINCO 235 : NBINC=LINCO.MOTS(/2) 236 : IF(NBINC.NE.1)THEN 237 : C Indice %m1:8 : contient plus de %i1 %m9:16 238 : MOTERR( 1:8) = 'LISTINCO' 239 : INTERR(1) = 1 240 : MOTERR(9:16) = ' MOTS ' 240 : CALL ERREUR(799) 241 : RETURN 242 : ENDIF 243 : 244 : NOMI=LINCO.MOTS(1) 245 : 246 : IF(KIMPL.EQ.0)THEN 246 : CALL LEKTAB(MTAB1,'KIZG',KIZG) 247 : IF(KIZG.EQ.0)THEN 247 : CALL CRTABL(KIZG) 247 : CALL ECMM(KIZG,'SOUSTYPE','KIZG') 247 : CALL ECMO(MTAB1,'KIZG','TABLE ',KIZG) 248 : ENDIF 249 : ENDIF 250 : 251 : C --> 1 ere Inconnue 252 : 253 : NOMI=LINCO.MOTS(1) 254 : 255 : TYPE=' ' 255 : CALL ACMO(KINC,NOMI,TYPE,MCHPOI) 256 : IF(TYPE.NE.'CHPOINT ')THEN 257 : C Indice %m1:8 : ne contient pas un objet de type %m9:16 258 : MOTERR( 1: 8) = 'INC '//NOMI 259 : MOTERR( 9:16) = 'CHPOINT ' 259 : CALL ERREUR(800) 260 : RETURN 261 : ELSE 261 : CALL LICHT(MCHPOI,IZTU1,TYPC,SPGID) 262 : ENDIF 263 : 264 : C************************************************************************* 265 : C Le domaine de definition est donne par le SPG de la premiere inconnue 266 : C Les inconnues suivantes devront posseder ce meme pointeur 267 : C On verifie que les points de la zone sont tous inclus dans ce SPG 268 : 268 : CALL KRIPAD(SPGID,MLENTI) 269 : IF(IPAS.EQ.0)THEN 269 : CALL VERPAD(MLENTI,SPGZ,IRET) 270 : IF(IRET.NE.0)THEN 271 : C Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique 272 : MOTERR(1: 8) = 'INC '//NOMI 273 : MOTERR(9:16) = 'CHPOINT ' 273 : CALL ERREUR(788) 274 : IPAS=0 275 : RETURN 276 : ENDIF 277 : ENDIF 278 : 279 : C************************************************************************* 280 : C Lecture du coefficient 281 : C Type du coefficient : 282 : C IK1=0 CHPOINT IK1=1 scalaire IK1=2 vecteur 283 : C write(6,*)' Lecture des coefficients ' 284 : 284 : CALL ACME(MTABX,'IARG',IARG) 285 : IF(IARG.NE.1)THEN 286 : C Indice %m1:8 : nombre d'arguments incorrect 287 : MOTERR(1:8) = 'IARG ' 287 : CALL ERREUR(804) 288 : RETURN 289 : ENDIF 290 : 291 : IRET=3 292 : IXV(1)=MELEMC 293 : IXV(2)=1 294 : IXV(3)=0 295 : C? IXV(4)=MELEMS 296 : C write(6,*)' MELEMQ=',melemq 296 : CALL LEKCOF('Opérateur FIMP :', 297 : & MTABX,KINC,1,IXV,MFLU,MZFLU,NPT1,NC1,IK1,IRET) 298 : IF(IRET.EQ.0)RETURN 299 : 300 : C Fin lecture Arguments ************************************************** 301 : 302 : 303 : IF(KIMPL.EQ.0)THEN 304 : TYPE=' ' 304 : CALL ACMO(KIZG,NOMI,TYPE,IZG1) 305 : IF(TYPE.NE.'CHPOINT ')THEN 306 : NC=IZTU1.VPOCHA(/2) 307 : TYPE='SOMMET' 307 : CALL CRCHPT(TYPE,SPGID,NC,IZG1) 308 : C SEGACT IZG1 309 : C MSOUPO=IZG1.IPCHP(1) 310 : C SEGACT MSOUPO 311 : C NOCOMP(1)=NOMI(1:4) 312 : C SEGDES MSOUPO 312 : CALL ECMO(KIZG,NOMI,'CHPOINT ',IZG1) 313 : ENDIF 314 : 315 : ELSE 316 : NC=IZTU1.VPOCHA(/2) 317 : TYPE='SOMMET' 317 : C? pour plutard CALL CRCHPT(TYPE,SPGZ,NC,IZG1) 317 : CALL CRCHPT(TYPE,SPGID,NC,IZG1) 318 : SEGACT IZG1 319 : MSOUPO=IZG1.IPCHP(1) 320 : SEGACT MSOUPO*MOD 321 : NOCOMP(1)=NOMI(1:4) 322 : ENDIF 323 : 323 : CALL LICHT(IZG1,IZGG1,TYPC,IGEOM) 324 : 325 : IF(IGEOM.NE.SPGID)THEN 326 : C Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique 327 : MOTERR(1: 8) = 'INC '//NOMI 328 : MOTERR(9:16) = 'CHPOINT ' 328 : CALL ERREUR(788) 329 : RETURN 330 : ENDIF 331 : 332 : SEGACT MELEME 333 : NBSOUS=LISOUS(/1) 334 : IF(NBSOUS.EQ.0)NBSOUS=1 335 : NUTOEL=0 336 : 337 : NPTD=IZTU1.VPOCHA(/1) 338 : IES=IDIM 339 : 340 : DO 1 L=1,NBSOUS 341 : IPT1=MELEME 342 : IF(NBSOUS.NE.1)IPT1=LISOUS(L) 343 : SEGACT IPT1 344 : 345 : MCHAML=ICHAML(L) 346 : SEGACT MCHAML 347 : MELVAL=IELVAL(1) 348 : SEGACT MELVAL 349 : 350 : NP =IPT1.NUM(/1) 351 : NBEL=IPT1.NUM(/2) 352 : 353 : IF(KPOIND.EQ.0)THEN 354 : 354 : CALL ZXFIMP(NBEL,NUTOEL,NP,LECT,IPT1.NUM, 355 : & VELCHE,IZGG1.VPOCHA,MZFLU.VPOCHA,IK1) 356 : 357 : ELSE 358 : IPT2=MELEMP 359 : IF(NBSOUS.NE.1)IPT2=LISOUS(L) 360 : SEGACT IPT2 361 : 362 : IF(MQUAD.NE.0)THEN 363 : IF(KPOIND.EQ.2)NOM0=NOMS(IPT1.ITYPEL)//'PRP0' 364 : IF(KPOIND.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'PRP0' 365 : IF(KPOIND.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'PRP1' 366 : ELSEIF(MACRO.NE.0)THEN 367 : IF(KPOIND.EQ.2)NOM0=NOMS(IPT1.ITYPEL)//' ' 368 : IF(KPOIND.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'MCP0' 369 : IF(KPOIND.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'MCP1' 370 : ELSE 371 : IF(KPOIND.EQ.2)NOM0=NOMS(IPT1.ITYPEL)//' ' 372 : ENDIF 373 : 373 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 374 : 375 : 376 : SEGACT IZFFM*MOD 377 : IZHR=KZHR(1) 378 : SEGACT IZHR*MOD 379 : NES=GR(/1) 380 : NPG=GR(/3) 381 : IZF1=KTP(1) 382 : SEGACT IZF1*MOD 383 : MP1=IZF1.FN(/1) 384 : NP = IPT1.NUM(/1) 385 : 386 : NK=NUTOEL 387 : DO 21 K=1,NBEL 388 : 389 : NK=NK+1 390 : JC=(1-IK1)*(NK-1)+1 391 : DO 109 I=1,NP 392 : J=IPT1.NUM(I,K) 393 : DO 109 N=1,IDIM 394 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N) 395 : 109 CONTINUE 396 : 396 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE) 397 : 398 : DO 39 M=1,MP1 399 : M1=LECT(IPT2.NUM(M,K)) 400 : U=0.D0 401 : DO 33 LL=1,NPG 402 : U=U+IZF1.FN(M,LL)*MZFLU.VPOCHA(JC,1)*PGSQ(LL) 403 : 33 CONTINUE 404 : IZGG1.VPOCHA(M1,1)=IZGG1.VPOCHA(M1,1)-U 405 : 39 CONTINUE 406 : 407 : 21 CONTINUE 408 : 409 : ENDIF 410 : 411 : SEGDES IPT1,MCHAML,MELVAL 412 : NUTOEL=NUTOEL+NBEL 413 : 414 : 1 CONTINUE 415 : C SEGDES MZFLU,IZVOL 416 : SEGDES MZFLU 417 : 418 : IF(KIMPL.NE.0)THEN 419 : TYPE=' ' 419 : CALL ACMO(MTAB1,'SMBR',TYPE,MCHPO2) 420 : IF(TYPE.NE.'CHPOINT')THEN 420 : CALL ECMO(MTAB1,'SMBR','CHPOINT',IZG1) 421 : ELSE 421 : CALL ECROBJ('CHPOINT',MCHPO2) 421 : CALL ECROBJ('CHPOINT',IZG1) 421 : CALL PRFUSE 421 : CALL LIROBJ('CHPOINT',MCHPOI,1,IRET) 421 : CALL ECMO(MTAB1,'SMBR','CHPOINT',MCHPOI) 422 : ENDIF 423 : 424 : ENDIF 425 : 426 : SEGDES MELEME 427 : 428 : SEGDES IZTU1 429 : SEGDES IZG1,IZGG1 430 : SEGDES LINCO 431 : SEGSUP MLENTI 432 : 433 : IPAS=1 434 : RETURN 435 : 90 CONTINUE 436 : C Option %m1:8 incompatible avec les données 437 : MOTERR( 1: 8) = MTERR 437 : CALL ERREUR(803) 438 : RETURN 439 : 440 : 1002 FORMAT(10(1X,1PE11.4)) 441 : END 442 : 443 : 444 : 445 : 446 : 447 : 448 : 449 : 450 : 451 : 452 :
© Cast3M 2003 - All rights reserved.
Disclaimer