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