1 : C NLIA SOURCE CHAT 07/10/29 21:24:57 5940 2 : SUBROUTINE NLIA(CGEOME,FACTIV,TABGEO,TABVDC,TATRAV, 3 : $ METING,LAXI,LERF,LERJ, 4 : $ MYFALS,MYPGS,MYFPGS,MYQRFS, 5 : $ TABMAT, 6 : $ IMPR,IRET) 7 : IMPLICIT REAL*8 (A-H,O-Z) 8 : IMPLICIT INTEGER (I-N) 9 : C*********************************************************************** 10 : C NOM : NLIA 11 : C DESCRIPTION : Création d'une matrice intégration des termes de surface 12 : C 13 : C LANGAGE : ESOPE 14 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 15 : C mél : gounand@semt2.smts.cea.fr 16 : C*********************************************************************** 17 : C APPELES : 18 : C APPELE PAR : PRLIN2 19 : C*********************************************************************** 20 : C ENTREES : 21 : C ENTREES/SORTIES : - 22 : C SORTIES : 23 : C TRAVAIL : * SOUGEO (type MELEME) : maillage élémentaire. 24 : C * MLLRFS (type MLLRFS) : pointeurs sur les 25 : C éléments de référence associés aux 4 espaces de 26 : C discrétisation (géométrie, coefficient, primal, 27 : C dual) sur le maillage élémentaire. 28 : C * PGCOUR (type POGAU) : méthode d'intégration 29 : C courante. 30 : C * JCOOR (type MCHEVA) : valeurs du champ ICOOR 31 : C sur le maillage élémentaire. 32 : C Structure (cf.include SMCHAEL) : 33 : C (1, nb. ddl, 1, dim. esp. réel, 34 : C 1, nb. éléments) 35 : C * JCOEFF (type MCHEVA) : valeurs du champ ICOEFF 36 : C sur le maillage élémentaire. 37 : C Structure (cf.include SMCHAEL) : 38 : C (1, nb. ddl, nb. comp. duales, 39 : C nb. comp. primales, 1, nb. éléments) 40 : C * JMTLIA (type MCHEVA) : valeurs du champ IMTLIA 41 : C sur le maillage élémentaire. 42 : C Structure (cf.include SMCHAEL) : 43 : C (nb. ddl dual, nb. ddl primal, 44 : C nb. comp. duales, nb. comp. primales, 45 : C 1, nb. éléments) 46 : C nb. ddl primal=1 si la matrice est condensée. 47 : C * JMAJAC (type MCHEVA) : valeurs de la matrice 48 : C jacobienne aux points de Gauss sur le maillage 49 : C élémentaire. 50 : C Structure (cf.include SMCHAEL) : 51 : C (1, 1, dim. esp. réel, dim. esp. référence, 52 : C nb. poi. gauss, nb. éléments) 53 : C * JMIJAC (type MCHEVA) : valeurs de l'inverse de 54 : C la matrice jacobienne aux points de Gauss sur 55 : C le maillage élémentaire. 56 : C Structure (cf.include SMCHAEL) : 57 : C (1, 1, dim. esp. référence, dim. esp. réel, 58 : C nb. poi. gauss, nb. éléments) 59 : C JMIJAC n'existe que si dim.esp.réf=dim.esp.réel 60 : C * JDTJAC (type MCHEVA) : valeurs du déterminant 61 : C de la matrice jacobienne aux points de Gauss 62 : C sur le maillage élémentaire. 63 : C Structure (cf.include SMCHAEL) : 64 : C (1, 1, 1, 1, nb. poi. gauss, nb. éléments) 65 : C Si la matrice jacobienne n'est pas carrée, on 66 : C a calculé sqrt(det(trans(J).J)) 67 : C * JCOEFG (type MCHEVA) : valeurs du coefficient 68 : C tensoriel aux points de Gauss sur le maillage 69 : C élémentaire. 70 : C Structure (cf.include SMCHAEL) : 71 : C (1, 1, nb. comp. duales, nb. comp. primales, 72 : C nb. poi. gauss, nb. éléments) 73 : C * FFPG (type MCHEVA) : valeurs des fonctions 74 : C d'interpolation aux points de gauss sur 75 : C l'élément de référence. 76 : C Structure (cf.include SMCHAEL) : 77 : C (1, nb. ddl, 1, 1, nb. poi. gauss, 1) 78 : C * DFFPG (type MCHEVA) : valeurs des dérivées 79 : C premières des fonctions d'interpolation aux 80 : C points de gauss sur l'élément de référence. 81 : C Structure (cf.include SMCHAEL) : 82 : C (1, nb. ddl, 1, dim.esp.réf, nb. poi. gauss, 1) 83 : C * JDFFPG (type MCHEVA) : valeurs des dérivées 84 : C premières des fonctions d'interpolation 85 : C primales aux points de gauss sur l'élément 86 : C réel. 87 : C Structure (cf.include SMCHAEL) : 88 : C (1, nb. ddl, 1, dim.esp.réel, nb. poi. gauss, 89 : C nb. élém.) 90 : C * JDFFDG (type MCHEVA) : valeurs des dérivées 91 : C premières des fonctions d'interpolation 92 : C duales aux points de gauss sur l'élément réel. 93 : C Structure (cf.include SMCHAEL) : 94 : C (1, nb. ddl, 1, dim.esp.réel, nb. poi. gauss, 95 : C nb. élém.) 96 : C*********************************************************************** 97 : C VERSION : v4, 26/07/06, refonte sur le modele du nlin evolue 98 : C VERSION : v3, 11/05/04, refonte (ajout comportement) 99 : C VERSION : v2, 22/09/03, refonte complète (modif SMPOUET) 100 : C VERSION : v1, 22/08/2003, version initiale 101 : C HISTORIQUE : v1, 22/08/2003, création 102 : C HISTORIQUE : 103 : C HISTORIQUE : 104 : C HISTORIQUE : 105 : C*********************************************************************** 106 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 107 : C en cas de modification de ce sous-programme afin de faciliter 108 : C la maintenance ! 109 : C*********************************************************************** 110 : -INC CCOPTIO 111 : -INC CCGEOME 112 : CBEGININCLUDE SELREF 113 : SEGMENT ELREF 114 : CHARACTER*(LNNOM) NOMLRF 115 : CHARACTER*(LNFORM) FORME 116 : CHARACTER*(LNTYPL) TYPEL 117 : CHARACTER*(LNESP) ESPACE 118 : INTEGER DEGRE 119 : REAL*8 XCONOD(NDIMEL,NBNOD) 120 : INTEGER NPQUAF(NBDDL) 121 : INTEGER NUMCMP(NBDDL) 122 : INTEGER QUENOD(NBDDL) 123 : INTEGER ORDDER(NDIMEL,NBDDL) 124 : POINTEUR MBPOLY.POLYNS 125 : ENDSEGMENT 126 : SEGMENT ELREFS 127 : POINTEUR LISEL(0).ELREF 128 : ENDSEGMENT 129 : CENDINCLUDE SELREF 130 : POINTEUR LRFVOL.ELREF 131 : CBEGININCLUDE SFALRF 132 : SEGMENT FALRF 133 : CHARACTER*(LNNFA) NOMFA 134 : INTEGER NUQUAF(NBLRF) 135 : POINTEUR ELEMF(NBLRF).ELREF 136 : ENDSEGMENT 137 : SEGMENT FALRFS 138 : POINTEUR LISFA(0).FALRF 139 : ENDSEGMENT 140 : CENDINCLUDE SFALRF 141 : POINTEUR MYFALS.FALRFS 142 : CBEGININCLUDE SPOGAU 143 : SEGMENT POGAU 144 : CHARACTER*(LNNPG) NOMPG 145 : CHARACTER*(LNTPG) TYPMPG 146 : CHARACTER*(LNFPG) FORLPG 147 : INTEGER NORDPG 148 : REAL*8 XCOPG(NDLPG,NBPG) 149 : REAL*8 XPOPG(NBPG) 150 : ENDSEGMENT 151 : SEGMENT POGAUS 152 : POINTEUR LISPG(0).POGAU 153 : ENDSEGMENT 154 : CENDINCLUDE SPOGAU 155 : POINTEUR MYPGS.POGAUS 156 : CBEGININCLUDE SFAPG 157 : SEGMENT FAPG 158 : CHARACTER*(LNNFAP) NOMFAP 159 : INTEGER NBQUAF(NBMPG) 160 : POINTEUR MPOGAU(NBMPG).POGAU 161 : ENDSEGMENT 162 : SEGMENT FAPGS 163 : POINTEUR LISFPG(0).FAPG 164 : ENDSEGMENT 165 : CENDINCLUDE SFAPG 166 : POINTEUR MYFPGS.FAPGS 167 : CBEGININCLUDE SLCOMP 168 : SEGMENT COMP 169 : CHARACTER*8 NOMCOM 170 : INTEGER DERCOF(NCOCOF) 171 : LOGICAL LTREF 172 : ENDSEGMENT 173 : SEGMENT COMPS 174 : POINTEUR LISCOM(NBCOMP).COMP 175 : ENDSEGMENT 176 : CENDINCLUDE SLCOMP 177 : POINTEUR MYCOM.COMP 178 : POINTEUR IVCOMP.COMP 179 : POINTEUR IVCOMD.COMP 180 : -INC SMLENTI 181 : POINTEUR IPOWCO.MLENTI 182 : -INC SMELEME 183 : POINTEUR CGEOME.MELEME 184 : POINTEUR SOUGEO.MELEME 185 : POINTEUR FACVOL.MELEME 186 : POINTEUR SFAVOL.MELEME 187 : * 188 : CBEGININCLUDE SMCHAEL 189 : SEGMENT MCHAEL 190 : POINTEUR IMACHE(N1).MELEME 191 : POINTEUR ICHEVA(N1).MCHEVA 192 : ENDSEGMENT 193 : SEGMENT MCHEVA 194 : REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM) 195 : ENDSEGMENT 196 : SEGMENT LCHEVA 197 : POINTEUR LISCHE(NBCHE).MCHEVA 198 : ENDSEGMENT 199 : CENDINCLUDE SMCHAEL 200 : INTEGER N1 201 : POINTEUR ICOOR.MCHAEL 202 : POINTEUR MYMCHA.MCHAEL 203 : POINTEUR JXCOPG.MCHEVA 204 : POINTEUR JXPOPG.MCHEVA 205 : POINTEUR JCOOR.MCHEVA,JCOEFF.MCHEVA,JCOEFG.MCHEVA 206 : POINTEUR JDCOFG.MCHEVA 207 : POINTEUR JMAJAC.MCHEVA,JMIJAC.MCHEVA,JDTJAC.MCHEVA 208 : POINTEUR JMAJA2.MCHEVA,JMIJA2.MCHEVA,JDTJA2.MCHEVA 209 : POINTEUR JDTJA3.MCHEVA 210 : POINTEUR IPROCO.MCHEVA 211 : POINTEUR FC.MCHEVA 212 : POINTEUR FFPG.MCHEVA,DFFPG.MCHEVA,JDFFPG.MCHEVA 213 : POINTEUR FVPR.MCHEVA,FVDU.MCHEVA 214 : POINTEUR FCPR.MCHEVA,FCDU.MCHEVA 215 : POINTEUR JMTLIA.MCHEVA 216 : CBEGININCLUDE SMPOUET 217 : SEGMENT TABGEO 218 : CHARACTER*4 DISGEO 219 : POINTEUR IGEO.MCHAEL 220 : ENDSEGMENT 221 : SEGMENT TABVDC 222 : INTEGER VVARPR(NUMVPR) 223 : INTEGER VVARDU(NUMVDU) 224 : INTEGER VDATPR(NUMDPR) 225 : INTEGER VDATDU(NUMDDU) 226 : INTEGER VCOFPR(NUMCPR) 227 : INTEGER VCOFDU(NUMCDU) 228 : INTEGER ILCPR(NUMDER+1,NUMOP,NUMVPR) 229 : INTEGER ILCDU(NUMDER+1,NUMOP,NUMVDU) 230 : POINTEUR VLCOF(JLCOF).MLENTI 231 : POINTEUR VCOMP(JGCOF).COMP 232 : POINTEUR VLDAT(JGCOF).MLENTI 233 : INTEGER DJSVD(JGVD) 234 : POINTEUR NOMVD(JGVD).MLMOTS 235 : POINTEUR MVD(JGVD).MCHPOI 236 : REAL*8 XVD(JGVD) 237 : CHARACTER*4 DISVD(KGVD) 238 : ENDSEGMENT 239 : SEGMENT TATRAV 240 : POINTEUR VVCOF(JLCOF).MCHEVA 241 : POINTEUR VCOF(JGCOF).MCHEVA 242 : POINTEUR IVD(JGVD).MCHAEL 243 : POINTEUR VD(JGVD).MCHEVA 244 : POINTEUR DVD(JGVD).MCHEVA 245 : POINTEUR FFVD(KGVD).MCHEVA 246 : POINTEUR DFFVD(KGVD).MCHEVA 247 : LOGICAL LVCOF(JGCOF) 248 : LOGICAL LVD(JGVD) 249 : LOGICAL LDVD(JGVD) 250 : LOGICAL LFFVD(KGVD) 251 : LOGICAL LDFFVD(KGVD) 252 : ENDSEGMENT 253 : SEGMENT TABMAT 254 : POINTEUR VMAT(NUMVDU,NUMVPR).MCHAEL 255 : ENDSEGMENT 256 : CENDINCLUDE SMPOUET 257 : INTEGER NUMVPR,NUMVDU,NUMDER,NUMOP 258 : INTEGER JGVC,KGVC 259 : CBEGININCLUDE SFACTIV 260 : SEGMENT FACTIV 261 : POINTEUR IFACTI(NBSOUV).SFACTI 262 : ENDSEGMENT 263 : SEGMENT SFACTI 264 : POINTEUR ISFACT(NBSOFV).SSFACT 265 : ENDSEGMENT 266 : SEGMENT SSFACT 267 : LOGICAL LFACTI(NBELFV,NBELEV) 268 : ENDSEGMENT 269 : CENDINCLUDE SFACTIV 270 : CBEGININCLUDE SIQUAF 271 : SEGMENT IQUAF 272 : INTEGER NUMQUF 273 : REAL*8 XCONQR(NDIMQR,NBNOQR) 274 : INTEGER NUCENT 275 : POINTEUR LFACE.MELEME 276 : ENDSEGMENT 277 : SEGMENT IQUAFS 278 : POINTEUR LISQRF(NBQRF).IQUAF 279 : ENDSEGMENT 280 : CENDINCLUDE SIQUAF 281 : POINTEUR MYQRFS.IQUAFS 282 : POINTEUR IQUVOL.IQUAF 283 : POINTEUR IQUFAC.IQUAF 284 : * 285 : CHARACTER*4 METING 286 : INTEGER LAXI 287 : INTEGER LERF 288 : LOGICAL LERJ,LERJ2 289 : INTEGER IMPR,IRET 290 : * 291 : CHARACTER*4 MYDISC 292 : * 293 : INTEGER NBELEF,NBELFV,NBELEV,NBSOFV,NBSOUV 294 : INTEGER IBELEF,IBELFV,IBELEV,IBSOFV,IBSOUV 295 : INTEGER IJVC,IKVC 296 : INTEGER IVARPR,IVARDU,KDERPR,KDERDU,IOP 297 : INTEGER ITYVOL,NBELEM 298 : LOGICAL LF,LDF,LC,LDC 299 : LOGICAL MVVPR,MVVDU,LVID 300 : * 301 : * Executable statements 302 : * 303 : * IMPR=0 304 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans nlia' 305 : * Activation et intialisation des chapeaux 306 : SEGACT CGEOME 307 : SEGACT FACTIV 308 : SEGACT TABGEO 309 : SEGACT TABVDC 310 : SEGACT TATRAV*MOD 311 : NBSOUV=CGEOME.LISOUS(/1) 312 : NUMVPR=TABVDC.VVARPR(/1) 313 : NUMVDU=TABVDC.VVARDU(/1) 314 : JLCOF=TABVDC.VLCOF(/1) 315 : JGCOF=TABVDC.VCOMP(/1) 316 : JGVD=TABVDC.DJSVD(/1) 317 : KGVD=TABVDC.DISVD(/2) 318 : NUMDER=TABVDC.ILCPR(/1)-1 319 : NUMOP=TABVDC.ILCPR(/2) 320 : * 321 : N1=NBSOUV 322 : * NUMVPR et NUMVDU initialisés ci-dessus 323 : SEGINI TABMAT 324 : * Cette instruction n'a pas l'air de fonctionner 325 : * SEGINI TABMAT.VMAT(*) 326 : DO IVARPR=1,NUMVPR 327 : DO IVARDU=1,NUMVDU 328 : SEGINI,MYMCHA 329 : TABMAT.VMAT(IVARDU,IVARPR)=MYMCHA 330 : ENDDO 331 : ENDDO 332 : SEGACT MYPGS 333 : ICOOR=TABGEO.IGEO 334 : SEGACT ICOOR 335 : * SEGACT TABVC.NOMVC(*) 336 : DO IJVD=1,JGVD 337 : MYMCHA=TATRAV.IVD(IJVD) 338 : IF (MYMCHA.NE.0) THEN 339 : SEGACT MYMCHA 340 : ENDIF 341 : ENDDO 342 : * 343 : * On travaille sur chaque sous-domaine 344 : * 345 : DO 1 IBSOUV=1,NBSOUV 346 : SOUGEO=CGEOME.LISOUS(IBSOUV) 347 : SEGACT SOUGEO 348 : SFACTI=FACTIV.IFACTI(IBSOUV) 349 : SEGACT,SFACTI 350 : * 351 : NBELEV=SOUGEO.NUM(/2) 352 : ITYVOL=SOUGEO.ITYPEL 353 : * Détermination de la dimension de l'espace de référence 353 : CALL DIMELE(NOMS(ITYVOL),IESREF,IMPR,IRET) 354 : IF (IRET.NE.0) GOTO 9999 355 : * 355 : CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET) 356 : IF (IRET.NE.0) GOTO 9999 357 : * 358 : SEGACT IQUVOL 359 : FACVOL=IQUVOL.LFACE 360 : SEGDES IQUVOL 361 : SEGACT FACVOL 362 : NBSOFV=FACVOL.LISOUS(/1) 363 : * 364 : * On travaille sur chaque type de face pour chaque sous-domaine 365 : * 366 : DO 12 IBSOFV=1,NBSOFV 367 : SFAVOL=FACVOL.LISOUS(IBSOFV) 368 : SEGACT SFAVOL 369 : NBELFV=SFAVOL.NUM(/2) 370 : ITYFAC=SFAVOL.ITYPEL 370 : CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET) 371 : IF (IRET.NE.0) GOTO 9999 372 : SSFACT=SFACTI.ISFACT(IBSOFV) 373 : * On calcule le nb de face pour un type de face d'un sous-domaine 374 : SEGACT SSFACT 375 : IBELEF=0 376 : DO IBELEV=1,NBELEV 377 : DO IBELFV=1,NBELFV 378 : IF (SSFACT.LFACTI(IBELFV,IBELEV)) THEN 379 : IBELEF=IBELEF+1 380 : ENDIF 381 : ENDDO 382 : ENDDO 383 : SEGDES SSFACT 384 : NBELEF=IBELEF 385 : * 386 : * Celui-ci peut être nul : Cas des prismes où on ne calcule des intégrales 387 : * de surface que sur les triangles 388 : * 389 : IF (NBELEF.EQ.0) GOTO 12 390 : 391 : * Création des segments contenant les poids et points de Gauss sur 392 : * toutes les faces de l'élément de référence. 393 : * In CREPG : SEGINI JXCOPG 394 : * In CREPG : SEGINI JXPOPG 394 : CALL CREPG(IQUVOL,SFAVOL,METING,MYFALS,MYFPGS, 395 : $ JXCOPG,JXPOPG, 396 : $ IMPR,IRET) 397 : IF (IRET.NE.0) GOTO 9999 398 : * 399 : * Géométrie 400 : * 401 : MYDISC=TABGEO.DISGEO 401 : CALL KEEF(ITYVOL,MYDISC, 402 : $ MYFALS, 403 : $ LRFVOL, 404 : $ IMPR,IRET) 405 : IF (IRET.NE.0) GOTO 9999 406 : * In KFNRFF : SEGINI FFPG 407 : * In KFNRFF : SEGINI DFFPG 407 : CALL KFNRFF(LRFVOL,JXCOPG, 408 : $ FFPG,DFFPG, 409 : $ IMPR,IRET) 410 : IF (IRET.NE.0) GOTO 9999 411 : * 412 : * Création des matrices jacobiennes et déterminants 413 : * pour la transformation : élément volumique de référence <-> 414 : * élément volumique réel 415 : * Ici, on ne se servira que de l'inverse de la matrice 416 : * jacobienne. 417 : * In GEOLIF : SEGINI JMAJAC 418 : * In GEOLIF : SEGINI JMIJAC 419 : * In GEOLIF : SEGINI JDTJAC 420 : JCOOR=ICOOR.ICHEVA(IBSOUV) 420 : CALL GEOLIF(DFFPG,JCOOR,SSFACT,NBELEF, 421 : $ JMAJAC,JMIJAC,JDTJAC,LERJ, 422 : $ IMPR,IRET) 423 : IF (IRET.NE.0) THEN 424 : IF (LERJ) GOTO 9666 425 : GOTO 9999 426 : ENDIF 427 : SEGSUP DFFPG 428 : *! SEG SUP JMA JAC 429 : *! SEG SUP JDT JAC 430 : * 431 : * Création des matrices jacobiennes et déterminants 432 : * pour la transformation : élément surfacique de référence <-> 433 : * élément surfacique réel 434 : * Ici, on ne se servira que du déterminant de la matrice jacobienne. 435 : * In GEOLF2 : SEGINI JMAJA2 436 : * In GEOLF2 : SEGINI JMIJA2 437 : * In GEOLF2 : SEGINI JDTJA2 438 : MYDISC=TABGEO.DISGEO 438 : CALL GEOLF2(LRFVOL,IQUVOL,SFAVOL, 439 : $ MYDISC,METING,MYFALS,MYFPGS, 440 : $ JCOOR,SSFACT,NBELEF, 441 : $ JMAJA2,JMIJA2,JDTJA2,LERJ2, 442 : $ IMPR,IRET) 443 : IF (IRET.NE.0) THEN 444 : IF (LERJ2) THEN 445 : LERJ=LERJ2 446 : GOTO 9666 447 : ENDIF 448 : GOTO 9999 449 : ENDIF 450 : IF (IRET.NE.0) GOTO 9999 451 : SEGSUP JMAJA2 452 : IF (JMIJA2.NE.0) THEN 453 : SEGSUP JMIJA2 454 : ENDIF 455 : SEGSUP FFPG 456 : C Inutile normalement, on peut se débrouiller avec les coeffs 457 : C* En axi, on multiplie le determinant de la matrice 458 : C* jacobienne par 2piR (ou R est la premiere coordonnee) 459 : C IF (LAXI.GT.0) THEN 460 : C* In GEOMFT : SEGINI JDTJA3 460 : C CALL GEOMFT(JCOOR,FFPG,SSFACT,NBELEF, 461 : C $ JDTJA2,LAXI, 462 : C $ JDTJA3, 463 : C $ IMPR,IRET) 464 : C IF (IRET.NE.0) GOTO 9999 465 : C SEGSUP JDTJA2 466 : C JDTJA2=JDTJA3 467 : C ENDIF 468 : * 469 : * Attention : modif par rapport à nlin ! 470 : * 471 : JPC=0 472 : JMAREG=0 473 : JDIAMA=0 474 : METRIQ=0 475 : * 476 : * Calcul des fonctions de forme et de leurs dérivées 477 : * 478 : DO IKVD=1,KGVD 479 : LF=TATRAV.LFFVD(IKVD).EQV..TRUE. 480 : LDF=TATRAV.LDFFVD(IKVD).EQV..TRUE. 481 : IF (LF.OR.LDF) THEN 482 : MYDISC=TABVDC.DISVD(IKVD) 482 : CALL KEEF(ITYVOL,MYDISC, 483 : $ MYFALS, 484 : $ LRFVOL, 485 : $ IMPR,IRET) 486 : IF (IRET.NE.0) GOTO 9999 487 : * In KFNRFF : SEGINI FFPG 488 : * In KFNRFF : SEGINI DFFPG 488 : CALL KFNRFF(LRFVOL,JXCOPG, 489 : $ FFPG,DFFPG, 490 : $ IMPR,IRET) 491 : IF (IRET.NE.0) GOTO 9999 492 : IF (LF) THEN 493 : TATRAV.FFVD(IKVD)=FFPG 494 : ELSE 495 : * segini ffpg 496 : SEGSUP FFPG 497 : ENDIF 498 : IF (LDF) THEN 499 : IF (LERF.NE.0) THEN 500 : SEGINI,JDFFPG=DFFPG 501 : SEGDES JDFFPG 502 : ELSE 503 : * In DFNFRF : SEGINI JDFFPG 503 : CALL DFNFRF(DFFPG,JMIJAC,SSFACT,NBELEF, 504 : $ JDFFPG, 505 : $ IMPR,IRET) 506 : IF (IRET.NE.0) GOTO 9999 507 : ENDIF 508 : TATRAV.DFFVD(IKVD)=JDFFPG 509 : ENDIF 510 : SEGSUP DFFPG 511 : ENDIF 512 : ENDDO 513 : * 514 : * Calcul des champs et de leurs dérivées 515 : * 516 : DO IJVD=1,JGVD 517 : LC=TATRAV.LVD(IJVD).EQV..TRUE. 518 : LDC=TATRAV.LDVD(IJVD).EQV..TRUE. 519 : IF (LC.OR.LDC) THEN 520 : MYMCHA=TATRAV.IVD(IJVD) 521 : JCOEFF=MYMCHA.ICHEVA(IBSOUV) 522 : IF (LC) THEN 523 : FFPG=TATRAV.FFVD(TABVDC.DJSVD(IJVD)) 524 : * In COGAUF : SEGINI JCOEFG 524 : CALL COGAUF(JCOEFF,FFPG,SSFACT,NBELEF, 525 : $ JCOEFG, 526 : $ IMPR,IRET) 527 : IF (IRET.NE.0) GOTO 9999 528 : TATRAV.VD(IJVD)=JCOEFG 529 : ENDIF 530 : IF (LDC) THEN 531 : JDFFPG=TATRAV.DFFVD(TABVDC.DJSVD(IJVD)) 532 : * In DCOGAF : SEGINI JDCOFG 532 : CALL DCOGAF(JCOEFF,JDFFPG,SSFACT,NBELEF, 533 : $ JDCOFG, 534 : $ IMPR,IRET) 535 : IF (IRET.NE.0) GOTO 9999 536 : TATRAV.DVD(IJVD)=JDCOFG 537 : ENDIF 538 : ENDIF 539 : ENDDO 540 : *!!! SEG DES JMIJAC 541 : * 542 : * Calcul des coefficients 543 : * 544 : DO IJGCOF=1,JGCOF 545 : LC=TATRAV.LVCOF(IJGCOF).EQV..TRUE. 546 : IF (LC) THEN 547 : IVCOMP=TABVDC.VCOMP(IJGCOF) 548 : IICOMP=TABVDC.VLDAT(IJGCOF) 549 : * In CALCGA : SEGINI FC 550 : * In CALCGA : SEG INI METRIQ.MCHEVA 550 : CALL CALCGA(IVCOMP,IICOMP,JMAJAC,JMIJAC,JDTJAC, 551 : $ JMAREG,JDIAMA,JPC,METRIQ, 552 : $ TATRAV, 553 : $ FC,IMPR,IRET) 554 : IF (IRET.NE.0) GOTO 9999 555 : TATRAV.VCOF(IJGCOF)=FC 556 : ENDIF 557 : ENDDO 558 : * 559 : * Calcul des produits de coefficients 560 : * 561 : DO IJLCOF=1,JLCOF 562 : IPOWCO=TABVDC.VLCOF(IJLCOF) 563 : * In CALPCO : SEGINI IPROCO 563 : CALL CALPCO(IPOWCO,TATRAV, 564 : $ IPROCO,IMPR,IRET) 565 : IF (IRET.NE.0) GOTO 9999 566 : TATRAV.VVCOF(IJLCOF)=IPROCO 567 : ENDDO 568 : * 569 : * On peut faire le ménage dans les coefficients 570 : * 571 : DO IJGCOF=1,JGCOF 572 : FC=TATRAV.VCOF(IJGCOF) 573 : IF (FC.NE.0) THEN 574 : SEGSUP,FC 575 : TATRAV.VCOF(IJGCOF)=0 576 : ENDIF 577 : ENDDO 578 : * 579 : * On effectue le calcul de la matrice 580 : * 581 : DO IVARPR=1,NUMVPR 582 : DO IVARDU=1,NUMVDU 583 : *Bug mis en evidence par toimp_3d JMTLIA=0 584 : MYMCHA=TABMAT.VMAT(IVARDU,IVARPR) 585 : JMTLIA=MYMCHA.ICHEVA(IBSOUV) 586 : IJVARP=TABVDC.VVARPR(IVARPR) 587 : IJVARD=TABVDC.VVARDU(IVARDU) 588 : IKVARP=TABVDC.DJSVD(IJVARP) 589 : IKVARD=TABVDC.DJSVD(IJVARD) 590 : MVVPR=(TABVDC.MVD(IJVARP).NE.0) 591 : MVVDU=(TABVDC.MVD(IJVARD).NE.0) 592 : DO IOP=1,NUMOP 593 : DO KDERPR=0,NUMDER 594 : IJLCPR=TABVDC.ILCPR(KDERPR+1,IOP,IVARPR) 595 : IF (IJLCPR.NE.0) THEN 596 : FCPR=TATRAV.VVCOF(IJLCPR) 597 : * variable primale 598 : IF (KDERPR.EQ.0) THEN 599 : IF (MVVPR) THEN 600 : FVPR=TATRAV.VD(IJVARP) 601 : ELSE 602 : FVPR=TATRAV.FFVD(IKVARP) 603 : ENDIF 604 : ELSE 605 : IF (MVVPR) THEN 606 : FVPR=TATRAV.DVD(IJVARP) 607 : ELSE 608 : FVPR=TATRAV.DFFVD(IKVARP) 609 : ENDIF 610 : ENDIF 611 : DO KDERDU=0,NUMDER 612 : IJLCDU=TABVDC.ILCDU(KDERDU+1,IOP,IVARDU) 613 : IF (IJLCDU.NE.0) THEN 614 : FCDU=TATRAV.VVCOF(IJLCDU) 615 : * Variable duale 616 : IF (KDERDU.EQ.0) THEN 617 : IF (MVVDU) THEN 618 : FVDU=TATRAV.VD(IJVARD) 619 : ELSE 620 : FVDU=TATRAV.FFVD(IKVARD) 621 : ENDIF 622 : ELSE 623 : IF (MVVDU) THEN 624 : FVDU=TATRAV.DVD(IJVARD) 625 : ELSE 626 : FVDU=TATRAV.DFFVD(IKVARD) 627 : ENDIF 628 : ENDIF 629 : * WRITE(IOIMP,*) 'FVPR=',FVPR 630 : * WRITE(IOIMP,*) 'FVDU=',FVDU 631 : * WRITE(IOIMP,*) 'FCPR=',FCPR 632 : * WRITE(IOIMP,*) 'FCDU=',FCDU 633 : * WRITE(IOIMP,*) 'KDERPR=',KDERPR 634 : * WRITE(IOIMP,*) 'KDERDU=',KDERDU 635 : * WRITE(IOIMP,*) 'LDERPR=',LDERPR 636 : * WRITE(IOIMP,*) 'LDERDU=',LDERDU 637 : * SEGPRT,JXPOPG 638 : * SEGPRT,FVPR 639 : * SEGPRT,FVDU 640 : * SEGPRT,FCPR 641 : * SEGPRT,FCDU 642 : * SEGPRT,JDTJA2 643 : * WRITE(IOIMP,*) 'KDERPR=',KDERPR 644 : * WRITE(IOIMP,*) 'KDERDU=',KDERDU 645 : C WRITE(IOIMP,*) 'LDERPR=',LDERPR 646 : C WRITE(IOIMP,*) 'LDERDU=',LDERDU 647 : C SEGPRT,JDTJA2 648 : C WRITE(IOIMP,*) 'NBELEF=',NBELEF 648 : CALL LIALIN(JXPOPG, 649 : $ FVPR,FVDU,FCPR,FCDU, 650 : $ KDERPR,KDERDU, 651 : $ JDTJA2,SSFACT,NBELEF,LERF,IESREF, 652 : $ JMTLIA, 653 : $ IMPR,IRET) 654 : IF (IRET.NE.0) GOTO 9999 655 : C WRITE(IOIMP,*) 'JMTLIA=',JMTLIA 656 : C SEGPRT,JMTLIA 657 : C* STOP 16 658 : ENDIF 659 : ENDDO 660 : ENDIF 661 : ENDDO 662 : ENDDO 663 : MYMCHA=TABMAT.VMAT(IVARDU,IVARPR) 664 : MYMCHA.IMACHE(IBSOUV)=SOUGEO 665 : MYMCHA.ICHEVA(IBSOUV)=JMTLIA 666 : * IF (JMTLIA.NE.0) THEN 667 : * SEGPRT,JMTLIA 668 : * ENDIF 669 : C WRITE(IOIMP,*) 'IVARPR=',IVARPR 670 : C WRITE(IOIMP,*) 'IVARDU=',IVARDU 671 : C WRITE(IOIMP,*) 'JMTLIA=',JMTLIA 672 : ENDDO 673 : ENDDO 674 : * Suppression de tous les MCHEVA 675 : DO IJLCOF=1,JLCOF 676 : IPROCO=TATRAV.VVCOF(IJLCOF) 677 : SEGSUP IPROCO 678 : TATRAV.VVCOF(IJLCOF)=IPROCO 679 : ENDDO 680 : * 681 : DO IJVD=1,JGVD 682 : JCOEFG=TATRAV.VD(IJVD) 683 : IF (JCOEFG.NE.0) THEN 684 : SEGSUP JCOEFG 685 : TATRAV.VD(IJVD)=JCOEFG 686 : ENDIF 687 : JDCOFG=TATRAV.DVD(IJVD) 688 : IF (JDCOFG.NE.0) THEN 689 : SEGSUP JDCOFG 690 : TATRAV.DVD(IJVD)=JDCOFG 691 : ENDIF 692 : ENDDO 693 : * 694 : DO IKVD=1,KGVD 695 : FFPG=TATRAV.FFVD(IKVD) 696 : IF (FFPG.NE.0) THEN 697 : SEGSUP FFPG 698 : TATRAV.FFVD(IKVD)=FFPG 699 : ENDIF 700 : JDFFPG=TATRAV.DFFVD(IKVD) 701 : IF (JDFFPG.NE.0) THEN 702 : SEGSUP JDFFPG 703 : TATRAV.DFFVD(IKVD)=JDFFPG 704 : ENDIF 705 : ENDDO 706 : * 707 : SEGSUP JDTJA2 708 : SEGSUP JXPOPG 709 : SEGSUP JXCOPG 710 : SEGDES SFAVOL 711 : SEGSUP JDTJAC 712 : SEGSUP JMAJAC 713 : SEGSUP JMIJAC 714 : 12 CONTINUE 715 : * SEGPRT,JMTLIA 716 : SEGDES FACVOL 717 : SEGDES SFACTI 718 : SEGDES SOUGEO 719 : 1 CONTINUE 720 : * 721 : DO IJVD=1,JGVD 722 : MYMCHA=TATRAV.IVD(IJVD) 723 : IF (MYMCHA.NE.0) THEN 724 : SEGDES MYMCHA 725 : ENDIF 726 : ENDDO 727 : * SEGDES TABVC.NOMVC(*) 728 : SEGDES ICOOR 729 : SEGDES MYPGS 730 : * Cette instruction n'a pas l'air de fonctionner 731 : * Un peu de ménage là où il n'y a pas d'info 732 : * SEGDES TABMAT.VMAT(*) 733 : DO IVARPR=1,NUMVPR 734 : DO IVARDU=1,NUMVDU 735 : MYMCHA=TABMAT.VMAT(IVARDU,IVARPR) 736 : SEGACT MYMCHA 737 : LVID=.TRUE. 738 : DO ISOUS=1,NBSOUV 739 : MCHEVA=MYMCHA.ICHEVA(ISOUS) 740 : LVID=LVID.AND.(MCHEVA.EQ.0) 741 : ENDDO 742 : IF (LVID) THEN 743 : SEGSUP MYMCHA 744 : TABMAT.VMAT(IVARDU,IVARPR)=0 745 : ELSE 746 : SEGDES,MYMCHA 747 : ENDIF 748 : ENDDO 749 : ENDDO 750 : SEGDES TATRAV 751 : SEGDES TABMAT 752 : SEGDES TABVDC 753 : SEGDES TABGEO 754 : SEGDES FACTIV 755 : SEGDES CGEOME 756 : * 757 : * Normal termination 758 : * 759 : IRET=0 760 : RETURN 761 : * 762 : * Format handling 763 : * 764 : * 765 : * Error handling 766 : * 767 : 9666 CONTINUE 768 : IRET=666 769 : RETURN 770 : 9999 CONTINUE 771 : IRET=1 772 : WRITE(IOIMP,*) 'An error was detected in subroutine nlia' 773 : RETURN 774 : * 775 : * End of subroutine nlia 776 : * 777 : END 778 : 779 : 780 : 781 :
© Cast3M 2003 - All rights reserved.
Disclaimer