1 : C PRASEM SOURCE MAGN 09/07/30 21:19:54 6458 2 : SUBROUTINE PRASEM(MATELE,MRENU,MMULAG,METASS, 3 : $ IMPR,IRET) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : IMPLICIT INTEGER (I-N) 6 : C*********************************************************************** 7 : C NOM : PRASEM 8 : C PROJET : Noyau linéaire NLIN 9 : C DESCRIPTION : On effectue l'assemblage d'un ensemble de matrices 10 : C élémentaires pour faire une matrice Morse. 11 : C 12 : C 13 : C Quelques commentaires sur la numérotation pour le placement des 14 : C multiplicateurs de Lagrange : 15 : C 16 : C * Au niveau des noms d'inconnues : 17 : C 1) Placement juste après un nom sur lequel porte la relation 18 : C 2) Placement après tous les noms sur lesquels porte la relation 19 : C * Au niveau des ddls : 20 : C a) Placement après tous les ddls sur lesquels porte la relation 21 : C b) Placement par points si le multiplicateur de Lagrange 22 : C est dans un espace d'éléments finis 23 : C 'APR2' = 1a ; 'APR3' = 1b ; 'APR4' = 2a ; 'APR5' = 2b 24 : C 25 : C 26 : C 27 : C LANGAGE : ESOPE 28 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 29 : C mél : gounand@semt2.smts.cea.fr 30 : C*********************************************************************** 31 : C APPELES : FIXMEL, MLUNIQ, MKMPOS, MKNPOS, MAKPRM, MAKPMT 32 : C FUSPRM 33 : C APPELES (UTIL.) : FIMOTS, RSETXI, CUNIQ, CREPER, IUNIQ, ISETI 34 : C APPELES (STAT.) : INMSTA, PRMSTA 35 : C APPELE PAR : KRES2 36 : C*********************************************************************** 37 : C ENTREES : MRENU, MMULAG 38 : C ENTREES/SORTIES : MATELE 39 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 40 : C*********************************************************************** 41 : C VERSION : v1, 24/11/99, nouvelle version initiale 42 : C HISTORIQUE : v1, 30/09/99, création 43 : C HISTORIQUE : 05/01/00 : modif. appel fixmel 44 : C HISTORIQUE : 13/01/00 : Rajout d'une méthode de renumérotation avec 45 : C placement des multiplicateurs de Lagrange plus efficace 46 : C (cf. subroutine calnu2). 47 : C HISTORIQUE : 06/04/04 : Renumerotation 48 : C*********************************************************************** 49 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 50 : C en cas de modification de ce sous-programme afin de faciliter 51 : C la maintenance ! 52 : C*********************************************************************** 53 : * MATASS est une matrice de préconditionnement déjà assemblée 54 : * permettant de sauter des étapes de l'assemblage 55 : -INC CCOPTIO 56 : -INC SMCOORD 57 : -INC SMLENTI 58 : INTEGER JG 59 : POINTEUR KRSPGT.MLENTI 60 : POINTEUR KRSPGD.MLENTI 61 : C! POINTEUR KRILAG.MLENTI 62 : POINTEUR KRINCP.MLENTI 63 : POINTEUR KRINCD.MLENTI 64 : POINTEUR KRIPUN.MLENTI 65 : POINTEUR KRIDUN.MLENTI 66 : POINTEUR NEWNUM.MLENTI 67 : POINTEUR IWORK.MLENTI 68 : POINTEUR LITYP.MLENTI 69 : POINTEUR LINIV.MLENTI 70 : -INC SMLMOTS 71 : INTEGER JGM,JGN 72 : C! POINTEUR GPINCS.MLMOTS 73 : C! POINTEUR GPILAG.MLMOTS 74 : POINTEUR LITOT.MLMOTS 75 : C!*-INC SMLLOGI 76 : C! SEGMENT MLLOGI 77 : C! LOGICAL LOGI(JG) 78 : C! ENDSEGMENT 79 : C! POINTEUR LILAG.MLLOGI 80 : -INC SMELEME 81 : POINTEUR MELPRI.MELEME 82 : POINTEUR MELDUA.MELEME 83 : POINTEUR MELPR2.MELEME 84 : POINTEUR MELDU2.MELEME 85 : POINTEUR MLPPRI.MELEME 86 : POINTEUR MLPDUA.MELEME 87 : POINTEUR KJSPGT.MELEME 88 : -INC SMMATRIK 89 : POINTEUR MATELE.MATRIK 90 : POINTEUR IMATEL.IMATRI 91 : INTEGER NBI,NPT 92 : POINTEUR KMINCT.MINC 93 : INTEGER NTT,NJA 94 : POINTEUR PMTOT.PMORS 95 : INTEGER NBVA 96 : POINTEUR IZATOT.IZA 97 : POINTEUR PMTO2.PMORS 98 : POINTEUR IZATO2.IZA 99 : POINTEUR PMCOU.PMORS 100 : POINTEUR PMCO2.PMORS 101 : INTEGER NBLK 102 : POINTEUR IDMTOT.IDMAT 103 : * 104 : * Includes persos 105 : * 106 : * Segment avec diverses statistiques mémoire et CPU 107 : *STAT -INC SMSTAT 108 : *STAT POINTEUR MSTOT.MSTAT 109 : *STAT POINTEUR MSPRM.MSTAT 110 : *STAT POINTEUR MSMAT.MSTAT 111 : * Liste de MELEME 112 : INTEGER NBMEL 113 : SEGMENT MELS 114 : POINTEUR LISMEL(NBMEL).MELEME 115 : ENDSEGMENT 116 : POINTEUR GPMELS.MELS 117 : POINTEUR GPMLPP.MELS 118 : POINTEUR GPMLPD.MELS 119 : * 120 : INTEGER IMPR,IRET 121 : * 122 : REAL*8 RDUMMY(1) 123 : INTEGER IBI 124 : C! INTEGER NBMTOT,NBM,NBM2 125 : INTEGER IMATE 126 : INTEGER NMATE 127 : INTEGER NPOPRI,NPODUA 128 : INTEGER ITTDDL 129 : INTEGER NTOGPO,NTOTPO,NTOTIN,NTTDDL 130 : INTEGER NNZTOT 131 : INTEGER LNM,NME 132 : INTEGER NMEUNI 133 : INTEGER IPROFI,JOB 134 : LOGICAL LASEM,LSYM 135 : * 136 : C 137 : C Définition des options 138 : C 139 : INTEGER LNOPT 140 : PARAMETER (LNOPT=4) 141 : C algorithmes utilisés pour la renumérotation 142 : C * 'RIEN' : pas de renumérotation 143 : C * 'SLOA' : algorithme de chez Sloan 144 : C * 'GIPR' : Gibbs-King (profile reduction) 145 : C * 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction) 146 : CHARACTER*(LNOPT) MRENU 147 : INTEGER IRENU,NRENU 148 : PARAMETER (NRENU=4) 149 : POINTEUR LRENU.MLMOTS 150 : C algorithmes utilisés pour la prise en compte des mult.lag. 151 : C! a supprimmer 152 : C! * 'ECHA' : on renumérote tout puis on change 153 : C! de place les mulag pour les mettre après 154 : C! les ddl qui leur correspondent 155 : C! * 'APRE' : on renumérote sans les mult.lag. PUIS 156 : C! on les place après les ddl qui leur correspondent 157 : C! * 'APR2' : on renumérote avec les mult.lag. PUIS on les extrait 158 : C! on les replace après les ddl qui leur correspondent 159 : C * 'RIEN' : on ne fait rien de particulier pour les 160 : C multiplicateurs de lagrange 161 : C * 'APR3' : on ne fait rien de particulier pour les 162 : C multiplicateurs de lagrange 163 : 164 : CHARACTER*(LNOPT) MMULAG 165 : INTEGER IMULAG,NMULAG 166 : C! PARAMETER (NMULAG=6) 167 : PARAMETER (NMULAG=5) 168 : POINTEUR LMULAG.MLMOTS 169 : C 170 : C Initialisation des tableaux d'options 171 : C 172 : JGN=LNOPT 173 : JGM=NRENU 174 : SEGINI LRENU 175 : LRENU.MOTS(1)='RIEN' 176 : LRENU.MOTS(2)='SLOA' 177 : LRENU.MOTS(3)='GIPR' 178 : LRENU.MOTS(4)='GIBA' 179 : JGN=LNOPT 180 : JGM=NMULAG 181 : SEGINI LMULAG 182 : C! LMULAG.MOTS(1)='ECHA' 183 : C! LMULAG.MOTS(2)='APRE' 184 : C! LMULAG.MOTS(3)='APR2' 185 : C! LMULAG.MOTS(4)='RIEN' 186 : C! LMULAG.MOTS(5)='APR3' 187 : C! LMULAG.MOTS(6)='APR4' 188 : LMULAG.MOTS(1)='RIEN' 189 : LMULAG.MOTS(2)='APR2' 190 : LMULAG.MOTS(3)='APR3' 191 : LMULAG.MOTS(4)='APR4' 192 : LMULAG.MOTS(5)='APR5' 193 : * 194 : * Executable statements 195 : * 196 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans prasem' 197 : * 198 : * Lecture des données (options renumérotation et mult.lag) 199 : * 199 : CALL FIMOTS(MRENU,LRENU,IRENU,IMPR,IRET) 200 : IF (IRET.NE.0) GOTO 9999 200 : CALL FIMOTS(MMULAG,LMULAG,IMULAG,IMPR,IRET) 201 : IF (IRET.NE.0) GOTO 9999 202 : SEGSUP LMULAG 203 : SEGSUP LRENU 203 : *STAT CALL INMSTA(MSTAT,IMPR) 203 : *STAT CALL INMSTA(MSTOT,0) 204 : * 205 : * Quelques tests 206 : * 207 : SEGACT MATELE 208 : NMATE=MATELE.IRIGEL(/2) 209 : IF (NMATE.LE.0) THEN 210 : WRITE(IOIMP,*) 'Pas de matrices élémentaires à assembler' 211 : GOTO 9999 212 : ENDIF 213 : PMTOT=MATELE.KIDMAT(4) 214 : LASEM=(PMTOT.NE.0) 215 : IF (LASEM.AND.IMPR.GT.0) THEN 216 : WRITE(IOIMP,*) 'Les matrices élémentaires sont déjà assemblées' 217 : ENDIF 218 : SEGDES MATELE 219 : IF (LASEM) GOTO 9998 219 : *STAT CALL PRMSTA(' Après les tests',MSTAT,IMPR) 220 : * 221 : * Correction des maillages (à supprimmer dès que possible) 222 : * 223 : SEGACT MATELE*MOD 224 : DO 11 IMATE=1,NMATE 225 : MELPRI=MATELE.IRIGEL(1,IMATE) 226 : MELDUA=MATELE.IRIGEL(2,IMATE) 226 : CALL FIXMEL(MELPRI,MELDUA, 227 : $ MELPR2,MELDU2, 228 : $ IMPR,IRET) 229 : IF (IRET.NE.0) GOTO 9999 230 : MATELE.IRIGEL(1,IMATE)=MELPR2 231 : MATELE.IRIGEL(2,IMATE)=MELDU2 232 : 11 CONTINUE 233 : SEGDES MATELE 233 : *STAT CALL PRMSTA(' Après fixmel',MSTAT,IMPR) 234 : * 235 : * Construire l'ensemble des points primaux et duaux pour chaque 236 : * matrice élémentaire (on ne veut plus utiliser les KSPGPs et KSPGDs 237 : * des IMATRI). 238 : * 239 : SEGACT MATELE 240 : NBMEL=NMATE 241 : SEGINI GPMLPP 242 : NBMEL=NMATE 243 : SEGINI GPMLPD 244 : NBMEL=1 245 : SEGINI GPMELS 246 : * In 12 : SEGINI GPMLPP.LISMEL(*) 247 : * In 12 : SEGINI GPMLPD.LISMEL(*) 248 : DO 12 IMATE=1,NMATE 249 : SEGACT GPMELS*MOD 250 : GPMELS.LISMEL(1)=MATELE.IRIGEL(1,IMATE) 251 : SEGDES GPMELS 251 : CALL MLUNIQ(GPMELS,MLPPRI,IMPR,IRET) 252 : IF (IRET.NE.0) GOTO 9999 253 : GPMLPP.LISMEL(IMATE)=MLPPRI 254 : SEGACT GPMELS*MOD 255 : GPMELS.LISMEL(1)=MATELE.IRIGEL(2,IMATE) 256 : SEGDES GPMELS 256 : CALL MLUNIQ(GPMELS,MLPDUA,IMPR,IRET) 257 : IF (IRET.NE.0) GOTO 9999 258 : GPMLPD.LISMEL(IMATE)=MLPDUA 259 : 12 CONTINUE 260 : SEGSUP GPMELS 261 : SEGDES MATELE 262 : * 263 : * Construire l'ensemble des points sur lesquels sont localisées des 264 : * inconnues (KJSPGT). 265 : * 266 : NBMEL=NMATE*2 267 : SEGINI GPMELS 268 : DO 1 IMATE=1,NMATE 269 : GPMELS.LISMEL(2*IMATE-1)=GPMLPP.LISMEL(IMATE) 270 : GPMELS.LISMEL(2*IMATE) =GPMLPD.LISMEL(IMATE) 271 : 1 CONTINUE 271 : CALL MLUNIQ(GPMELS,KJSPGT,IMPR,IRET) 272 : IF (IRET.NE.0) GOTO 9999 273 : SEGSUP GPMELS 274 : IF (IMPR.GT.3) THEN 275 : WRITE(IOIMP,*) 'L''ensemble des points est :' 276 : SEGPRT,KJSPGT 277 : ENDIF 278 : * Construire la liste de correspondance pour KJSPGT 279 : SEGACT KJSPGT 280 : NTOTPO=KJSPGT.NUM(/2) 281 : NTOGPO=XCOOR(/1)/(IDIM+1) 282 : JG=NTOGPO 283 : SEGINI KRSPGT 284 : * SEGACT KRSPGT 284 : CALL RSETXI(KRSPGT.LECT,KJSPGT.NUM,NTOTPO) 284 : *STAT CALL PRMSTA(' Construction KJSPGT et KRSPGT',MSTAT,IMPR) 285 : SEGDES KRSPGT 286 : SEGDES KJSPGT 287 : * 288 : * Construction de l'ensemble des noms d'inconnues possibles LITOT 289 : * et attribution d'un ordre. 290 : * On voudra qu'un ddl d'ordre i soit après au moins un ddl d'ordre 291 : * i-1 avec lequel il a une relation 292 : * LITOT : liste des noms d'inconnues 293 : * In INCOR2 : SEGINI LITOT SEGDES LITOT 294 : * SEGINI LINIV 295 : * SEGINI LITYP 295 : C!* CALL INCORD(MATELE,LITOT,LIORD,IMPR,IRET) 295 : CALL INCOR2(MATELE,IMULAG,LITOT,LITYP,LINIV,IMPR,IRET) 296 : IF (IRET.NE.0) GOTO 9999 297 : IF (IMPR.GT.3) THEN 298 : WRITE(IOIMP,*) 'L''ensemble des inconnues est :' 299 : SEGPRT,LITOT 300 : WRITE(IOIMP,*) 'Type :' 301 : SEGPRT,LITYP 302 : WRITE(IOIMP,*) 'Niveau :' 303 : SEGPRT,LINIV 304 : ENDIF 304 : *STAT CALL PRMSTA(' Construction LITOT',MSTAT,IMPR) 305 : * 306 : * Construire le repérage des inconnues KMINCT 307 : * 308 : SEGACT LITOT 309 : NTOTIN=LITOT.MOTS(/2) 310 : NPT=NTOTPO 311 : NBI=NTOTIN 312 : SEGINI KMINCT 313 : * Initialisation de la liste des noms d'inconnues (LISINC) 314 : DO 48 IBI=1,NBI 315 : KMINCT.LISINC(IBI)=LITOT.MOTS(IBI)(1:8) 316 : 48 CONTINUE 317 : SEGSUP LITOT 318 : * Construction de MPOS 319 : SEGACT KRSPGT 320 : SEGACT MATELE 321 : DO 5 IMATE=1,NMATE 322 : IMATEL=MATELE.IRIGEL(4,IMATE) 323 : SEGACT IMATEL 324 : * On parcourt la primale 325 : LNM=IMATEL.LISPRI(/1) 326 : NME=IMATEL.LISPRI(/2) 327 : JG=NME 328 : SEGINI KRINCP 328 : CALL CREPER(LNM,NME,NTOTIN,IMATEL.LISPRI,KMINCT.LISINC, 329 : $ KRINCP.LECT, 330 : $ IMPR,IRET) 331 : IF (IRET.NE.0) THEN 332 : WRITE(IOIMP,*) '1' 333 : GOTO 9999 334 : ENDIF 335 : * On supprimme les doublons dans KRINCP 336 : JG=NME 337 : SEGINI KRIPUN 337 : CALL IUNIQ(KRINCP.LECT,NME, 338 : $ KRIPUN.LECT,NMEUNI, 339 : $ IMPR,IRET) 340 : IF (IRET.NE.0) GOTO 9999 341 : SEGSUP KRINCP 342 : MLPPRI=GPMLPP.LISMEL(IMATE) 343 : SEGACT MLPPRI 344 : NPOPRI=MLPPRI.NUM(/2) 344 : CALL MKMPOS(NMEUNI,NPOPRI,NTOGPO,NTOTPO,NTOTIN, 345 : $ KRIPUN.LECT,MLPPRI.NUM,KRSPGT.LECT, 346 : $ KMINCT.MPOS, 347 : $ IMPR,IRET) 348 : SEGDES MLPPRI 349 : SEGSUP KRIPUN 350 : * On parcourt la duale 351 : LNM=IMATEL.LISDUA(/1) 352 : NME=IMATEL.LISDUA(/2) 353 : JG=NME 354 : SEGINI KRINCD 354 : CALL CREPER(LNM,NME,NTOTIN, 355 : $ IMATEL.LISDUA,KMINCT.LISINC, 356 : $ KRINCD.LECT, 357 : $ IMPR,IRET) 358 : IF (IRET.NE.0) THEN 359 : WRITE(IOIMP,*) '2' 360 : GOTO 9999 361 : ENDIF 362 : * On supprime les doublons dans KRINCD 363 : JG=NME 364 : SEGINI KRIDUN 364 : CALL IUNIQ(KRINCD.LECT,NME, 365 : $ KRIDUN.LECT,NMEUNI, 366 : $ IMPR,IRET) 367 : IF (IRET.NE.0) GOTO 9999 368 : SEGSUP KRINCD 369 : MLPDUA=GPMLPD.LISMEL(IMATE) 370 : SEGACT MLPDUA 371 : NPODUA=MLPDUA.NUM(/2) 371 : CALL MKMPOS(NMEUNI,NPODUA,NTOGPO,NTOTPO,NTOTIN, 372 : $ KRIDUN.LECT,MLPDUA.NUM,KRSPGT.LECT, 373 : $ KMINCT.MPOS, 374 : $ IMPR,IRET) 375 : IF (IRET.NE.0) GOTO 9999 376 : SEGDES MLPDUA 377 : SEGSUP KRIDUN 378 : SEGDES IMATEL 379 : 5 CONTINUE 380 : SEGDES KRSPGT 381 : * 382 : * Remplissage de NPOS(IPT) repérage dans le nb. total de ddl 383 : * 383 : CALL MKNPOS(NTOTPO,NTOTIN,KMINCT.MPOS, 384 : $ KMINCT.NPOS, 385 : $ IMPR,IRET) 386 : IF (IRET.NE.0) GOTO 9999 387 : IF (IMPR.GT.3) THEN 388 : WRITE(IOIMP,*) 'Le repérage des inconnues est :' 389 : SEGPRT,KMINCT 390 : ENDIF 391 : SEGDES KMINCT 391 : *STAT CALL PRMSTA(' Construction KMINCT',MSTAT,IMPR) 392 : * 393 : * On change de stratégie : on construit d'abord le profil Morse total 394 : * Puis, on le remplit avec le contenu des matrices élémentaires 395 : * 396 : * On construit le profil Morse diagonale pour initialiser 397 : * 398 : SEGACT KMINCT 399 : NTTDDL=KMINCT.NPOS(NTOTPO+1)-1 400 : SEGDES KMINCT 401 : NTT=NTTDDL 402 : NJA=NTTDDL 403 : SEGINI PMTOT 403 : CALL ISETI(PMTOT.IA,NTTDDL+1) 403 : CALL ISETI(PMTOT.JA,NTTDDL) 404 : SEGDES PMTOT 405 : DO 7 IMATE=1,NMATE 405 : *STAT CALL INMSTA(MSPRM,0) 406 : MELPRI=MATELE.IRIGEL(1,IMATE) 407 : MELDUA=MATELE.IRIGEL(2,IMATE) 408 : IMATEL=MATELE.IRIGEL(4,IMATE) 409 : SEGACT IMATEL 410 : SEGACT KMINCT 411 : * repérage dans la primale 412 : LNM=IMATEL.LISPRI(/1) 413 : NME=IMATEL.LISPRI(/2) 414 : JG=NME 415 : SEGINI KRINCP 415 : CALL CREPER(LNM,NME,NTOTIN, 416 : $ IMATEL.LISPRI,KMINCT.LISINC, 417 : $ KRINCP.LECT, 418 : $ IMPR,IRET) 419 : IF (IRET.NE.0) THEN 420 : WRITE(IOIMP,*) '3' 421 : GOTO 9999 422 : ENDIF 423 : * repérage dans la duale 424 : LNM=IMATEL.LISDUA(/1) 425 : NME=IMATEL.LISDUA(/2) 426 : JG=NME 427 : SEGINI KRINCD 427 : CALL CREPER(LNM,NME,NTOTIN, 428 : $ IMATEL.LISDUA,KMINCT.LISINC, 429 : $ KRINCD.LECT, 430 : $ IMPR,IRET) 431 : IF (IRET.NE.0) THEN 432 : WRITE(IOIMP,*) '4' 433 : GOTO 9999 434 : ENDIF 435 : SEGDES KMINCT 436 : MLPDUA=GPMLPD.LISMEL(IMATE) 437 : SEGACT MLPDUA 438 : NPODUA=MLPDUA.NUM(/2) 439 : NTOGPO=XCOOR(/1)/(IDIM+1) 440 : JG=NTOGPO 441 : SEGINI KRSPGD 441 : CALL RSETXI(KRSPGD.LECT,MLPDUA.NUM,NPODUA) 442 : SEGDES MLPDUA 443 : * 444 : * Construire le profil Morse 445 : * 446 : * SEGINI PMCOU 446 : CALL MAKPRM(MELPRI,KRINCP, 447 : $ MELDUA,NPODUA,MLPDUA,KRSPGD,KRINCD, 448 : $ KMINCT,KRSPGT, 449 : $ PMCOU, 450 : $ IMPR,IRET) 451 : IF (IRET.NE.0) GOTO 9999 452 : SEGSUP KRSPGD 453 : SEGSUP KRINCD 454 : SEGSUP KRINCP 455 : SEGDES IMATEL 456 : * 457 : * Cas particulier : celui des matrices CCt 458 : * 459 : ITYMAT=MATELE.IRIGEL(7,IMATE) 460 : * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN 461 : IF (ITYMAT.EQ.4) THEN 462 : * In MAKPMT : SEGINI PMCO2 462 : CALL MAKPMT(PMCOU, 463 : $ PMCO2, 464 : $ IMPR,IRET) 465 : IF (IRET.NE.0) GOTO 9999 466 : SEGSUP PMCOU 467 : PMCOU=PMCO2 468 : ENDIF 469 : IF (IMPR.GT.3) THEN 470 : WRITE(IOIMP,*) 'Le ',IMATE,'eme profil Morse est :' 471 : SEGPRT,PMCOU 472 : ENDIF 472 : *STAT CALL PRMSTA(' Assemblage profil Morse élémentaire',MSPRM 473 : *STAT $ ,IMPR) 474 : * 475 : * on effectue le ET sur les profils Morse 476 : * 477 : * In FUSPRM : SEGINI PMTO2 478 : IF (METASS.EQ.1) THEN 478 : CALL FUSPRM(PMTOT,PMCOU, 479 : $ PMTO2, 480 : $ IMPR,IRET) 481 : IF (IRET.NE.0) GOTO 9999 482 : ELSEIF (METASS.EQ.2) THEN 482 : CALL FUSPR2(PMTOT,PMCOU,NTTDDL, 483 : $ PMTO2, 484 : $ IMPR,IRET) 485 : IF (IRET.NE.0) GOTO 9999 486 : ELSE 487 : WRITE(IOIMP,*) 'Programming error' 488 : GOTO 9999 489 : ENDIF 490 : SEGSUP PMCOU 491 : SEGSUP PMTOT 492 : PMTOT=PMTO2 492 : *STAT CALL PRMSTA(' Fusion profil Morse élémentaire',MSPRM,IMPR) 493 : 7 CONTINUE 493 : *STAT CALL PRMSTA(' Assemblage du profil Morse total',MSTAT,IMPR) 494 : * 495 : * Ordonnancement du profil Morse total 496 : * 497 : SEGACT PMTOT*MOD 498 : NTTDDL=PMTOT.IA(/1)-1 499 : NNZTOT=PMTOT.JA(/1) 500 : JG=MAX(NTTDDL+1,2*NNZTOT) 501 : SEGINI IWORK 501 : CALL CSORT(PMTOT.IA(/1)-1,RDUMMY,PMTOT.JA,PMTOT.IA, 502 : $ IWORK.LECT,.FALSE.) 503 : SEGSUP IWORK 504 : SEGDES PMTOT 504 : *STAT CALL PRMSTA(' Ordonnancement du profil Morse total',MSTAT,IMPR) 505 : * 506 : * Assemblage des matrices élémentaires 507 : * 508 : NBVA=NNZTOT 509 : SEGINI IZATOT 510 : SEGDES IZATOT 511 : DO 77 IMATE=1,NMATE 511 : *STAT CALL INMSTA(MSMAT,0) 512 : MELPRI=MATELE.IRIGEL(1,IMATE) 513 : MELDUA=MATELE.IRIGEL(2,IMATE) 514 : IMATEL=MATELE.IRIGEL(4,IMATE) 515 : SEGACT IMATEL 516 : SEGACT KMINCT 517 : * repérage dans la primale 518 : LNM=IMATEL.LISPRI(/1) 519 : NME=IMATEL.LISPRI(/2) 520 : JG=NME 521 : SEGINI KRINCP 521 : CALL CREPER(LNM,NME,NTOTIN, 522 : $ IMATEL.LISPRI,KMINCT.LISINC, 523 : $ KRINCP.LECT, 524 : $ IMPR,IRET) 525 : IF (IRET.NE.0) THEN 526 : WRITE(IOIMP,*) '5' 527 : GOTO 9999 528 : ENDIF 529 : * repérage dans la duale 530 : LNM=IMATEL.LISDUA(/1) 531 : NME=IMATEL.LISDUA(/2) 532 : JG=NME 533 : SEGINI KRINCD 533 : CALL CREPER(LNM,NME,NTOTIN, 534 : $ IMATEL.LISDUA,KMINCT.LISINC, 535 : $ KRINCD.LECT, 536 : $ IMPR,IRET) 537 : IF (IRET.NE.0) THEN 538 : WRITE(IOIMP,*) '6' 539 : GOTO 9999 540 : ENDIF 541 : SEGDES KMINCT 541 : CALL MKIZA(MELDUA,MELPRI,IMATEL, 542 : $ KRINCD,KRINCP,KMINCT,KRSPGT, 543 : $ PMTOT, 544 : $ IZATOT, 545 : $ IMPR,IRET) 546 : IF (IRET.NE.0) GOTO 9999 547 : * 548 : * Cas particulier : celui des matrices CCt 549 : * 550 : ITYMAT=MATELE.IRIGEL(7,IMATE) 551 : * IF (ITYMAT.EQ.4.OR.ITYMAT.EQ.-4) THEN 552 : IF (ITYMAT.EQ.4) THEN 552 : CALL MKIZAT(MELDUA,MELPRI,IMATEL, 553 : $ KRINCD,KRINCP,KMINCT,KRSPGT, 554 : $ PMTOT, 555 : $ IZATOT, 556 : $ IMPR,IRET) 557 : IF (IRET.NE.0) GOTO 9999 558 : ENDIF 559 : SEGSUP KRINCD 560 : SEGSUP KRINCP 561 : SEGDES IMATEL 561 : * CALL PRMSTA(' Assemblage mat. élémentaire',MSMAT,IMPR) 562 : 77 CONTINUE 563 : SEGSUP KRSPGT 563 : *STAT CALL PRMSTA(' Assemblage mat. élém. total',MSTAT,IMPR) 564 : * 565 : * Renumérotation 566 : * 567 : IF (IMPR.GT.3) THEN 567 : CALL PROFI2(PMTOT,IPROFI,IMPR,IRET) 568 : IF (IRET.NE.0) GOTO 9999 569 : WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI 570 : ENDIF 571 : C!* Calcul 572 : C! IF (IMULAG.EQ.1) THEN 572 : C! CALL RENUME(PMTOT,IRENU, 573 : C! $ NEWNUM, 574 : C! $ IMPR,IRET) 575 : C! IF (IRET.NE.0) GOTO 9999 576 : C!* Modification de la nouvelle numérotation 577 : C!* pour placer les multiplicateurs de Lagrange 578 : C!* après les inconnues auxquelles ils se rapportent 578 : C! CALL MODNUM(LILAG,KMINCT,PMTOT, 579 : C! $ NEWNUM, 580 : C! $ IMPR,IRET) 581 : C! IF (IRET.NE.0) GOTO 9999 582 : C! ELSEIF (IMULAG.EQ.2) THEN 583 : C!* Autre facon de calculer la renumerotation 583 : C! CALL CALNUM(LILAG,KMINCT,PMTOT, 584 : C! $ IRENU, 585 : C! $ NEWNUM, 586 : C! $ IMPR,IRET) 587 : C! IF (IRET.NE.0) GOTO 9999 588 : C! ELSEIF (IMULAG.EQ.3) THEN 589 : C!* Dernière facon de calculer la renumerotation 589 : C! CALL CALNU2(LILAG,KMINCT,PMTOT, 590 : C! $ IRENU, 591 : C! $ NEWNUM, 592 : C! $ IMPR,IRET) 593 : C! IF (IRET.NE.0) GOTO 9999 594 : *!! ELSEIF (IMULAG.EQ.4) THEN 595 : IF (IMULAG.EQ.1) THEN 595 : CALL RENUME(PMTOT,IRENU, 596 : $ NEWNUM, 597 : $ IMPR,IRET) 598 : IF (IRET.NE.0) GOTO 9999 599 : C! ELSEIF (IMULAG.EQ.5) THEN 599 : C! CALL CALNU3(LIORD,KMINCT,PMTOT, 600 : C! $ IRENU, 601 : C! $ NEWNUM, 602 : C! $ IMPR,IRET) 603 : C! IF (IRET.NE.0) GOTO 9999 604 : ELSEIF (IMULAG.EQ.2.OR.IMULAG.EQ.4) THEN 604 : CALL CALNU4(LITYP,LINIV,KMINCT,PMTOT, 605 : $ IRENU, 606 : $ NEWNUM, 607 : $ IMPR,IRET) 608 : IF (IRET.NE.0) GOTO 9999 609 : ELSEIF (IMULAG.EQ.3.OR.IMULAG.EQ.5) THEN 609 : CALL CALNU5(LITYP,LINIV,KMINCT,PMTOT, 610 : $ IRENU, 611 : $ NEWNUM, 612 : $ IMPR,IRET) 613 : IF (IRET.NE.0) GOTO 9999 614 : ELSE 615 : WRITE(IOIMP,*) 'Erreur dans la programmation' 616 : WRITE(IOIMP,*) 'IMULAG=',IMULAG 617 : ENDIF 618 : SEGSUP LITYP 619 : SEGSUP LINIV 619 : *STAT CALL PRMSTA(' Calcul de la renumérotation',MSTAT,IMPR) 620 : * Permutation de la matrice 621 : SEGACT PMTOT 622 : SEGACT IZATOT 623 : NTT=PMTOT.IA(/1)-1 624 : NJA=PMTOT.JA(/1) 625 : SEGINI PMTO2 626 : NBVA=IZATOT.A(/1) 627 : SEGINI IZATO2 628 : SEGACT NEWNUM 629 : JOB=1 629 : CALL DPERM(PMTOT.IA(/1)-1,IZATOT.A,PMTOT.JA,PMTOT.IA, 630 : $ IZATO2.A,PMTO2.JA,PMTO2.IA,NEWNUM.LECT,NEWNUM.LECT, 631 : $ JOB) 632 : SEGDES NEWNUM 633 : SEGDES IZATO2 634 : SEGDES PMTO2 635 : SEGSUP PMTOT 636 : SEGSUP IZATOT 637 : PMTOT=PMTO2 638 : IZATOT=IZATO2 638 : *STAT CALL PRMSTA(' Permutation de la matrice',MSTAT,IMPR) 639 : * Ordonnancement des colonnes 640 : SEGACT PMTOT*MOD 641 : SEGACT IZATOT*MOD 642 : JG=MAX(PMTOT.IA(/1),2*PMTOT.JA(/1)) 643 : SEGINI IWORK 643 : CALL CSORT(PMTOT.IA(/1)-1,IZATOT.A,PMTOT.JA,PMTOT.IA, 644 : $ IWORK.LECT,.TRUE.) 645 : SEGSUP IWORK 646 : SEGDES IZATOT 647 : SEGDES PMTOT 647 : *STAT CALL PRMSTA(' Ordonnancement des colonnes',MSTAT,IMPR) 648 : * Sauvegarde de la renumérotation 649 : NTT=0 650 : NPT=NTTDDL 651 : NBLK=0 652 : SEGACT NEWNUM 653 : SEGINI,IDMTOT 654 : DO 8 ITTDDL=1,NTTDDL 655 : IDMTOT.NUAN(ITTDDL)=NEWNUM.LECT(ITTDDL) 656 : 8 CONTINUE 657 : DO 9 ITTDDL=1,NTTDDL 658 : IDMTOT.NUNA(NEWNUM.LECT(ITTDDL))=ITTDDL 659 : 9 CONTINUE 660 : SEGDES IDMTOT 661 : SEGSUP NEWNUM 662 : * Suppression des supports de points primaux et duaux 663 : SEGSUP,GPMLPD.LISMEL(*) 664 : SEGSUP,GPMLPP.LISMEL(*) 665 : SEGSUP GPMLPD 666 : SEGSUP GPMLPP 667 : * 668 : * Affichage des infos sur la Matrice Morse 669 : * 670 : IF (IMPR.GT.3) THEN 670 : CALL PROFI2(PMTOT,IPROFI,IMPR,IRET) 671 : IF (IRET.NE.0) GOTO 9999 672 : WRITE(IOIMP,*) 'Profil (tri. inf.) = ',IPROFI 673 : ENDIF 674 : * 675 : * Remplissage du chapeau 676 : * 677 : SEGDES MATELE 677 : CALL ISMSYM(MATELE, 678 : $ LSYM, 679 : $ IMPR,IRET) 680 : IF (IRET.NE.0) GOTO 9999 681 : SEGACT MATELE*MOD 682 : IF (LSYM) THEN 683 : MATELE.KSYM=0 684 : ELSE 685 : MATELE.KSYM=2 686 : ENDIF 687 : MATELE.KMINC=KMINCT 688 : MATELE.KMINCP=KMINCT 689 : MATELE.KMINCD=KMINCT 690 : * MATELE.KIZM =MCONEC 691 : MATELE.KISPGT=KJSPGT 692 : MATELE.KISPGP=KJSPGT 693 : MATELE.KISPGD=KJSPGT 694 : SEGACT KMINCT 695 : NTTDDL=KMINCT.NPOS(NTOTPO+1)-1 696 : SEGDES KMINCT 697 : MATELE.KNTTT=NTTDDL 698 : MATELE.KNTTP=NTTDDL 699 : MATELE.KNTTD=NTTDDL 700 : MATELE.KIDMAT(1)=IDMTOT 701 : MATELE.KIDMAT(2)=IDMTOT 702 : MATELE.KIDMAT(4)=PMTOT 703 : MATELE.KIDMAT(5)=IZATOT 704 : SEGDES MATELE 704 : *STAT CALL PRMSTA(' Fin de l''assemblage',MSTAT,IMPR) 704 : *STAT CALL PRMSTA('Total de l''assemblage',MSTOT,IMPR) 705 : * 706 : * Normal termination 707 : * 708 : 9998 CONTINUE 709 : IRET=0 710 : RETURN 711 : * 712 : * Format handling 713 : * 714 : * 715 : * Error handling 716 : * 717 : 9999 CONTINUE 718 : IRET=1 719 : WRITE(IOIMP,*) 'An error was detected in subroutine prasem' 720 : RETURN 721 : * 722 : * End of subroutine PRASEM 723 : * 724 : END 725 : 726 : 727 : 728 : 729 : 730 : 731 :
© Cast3M 2003 - All rights reserved.
Disclaimer