1 : C PROMAT SOURCE MAGN 09/07/30 21:20:45 6458 2 : SUBROUTINE PROMAT(MPRIB,MDUAB,IMATB, 3 : $ MPRIC,MDUAC,IMATC, 4 : $ CHPOD, 5 : $ MPCDB,MDCDB,IMTCDB, 6 : $ IMPR,IRET) 7 : IMPLICIT INTEGER(I-N) 8 : IMPLICIT REAL*8 (A-H,O-Z) 9 : C*********************************************************************** 10 : C NOM : PROMAT 11 : C DESCRIPTION : Produit de matrices élémentaires. 12 : C 13 : C 14 : C LANGAGE : ESOPE 15 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF) 16 : C mél : gounand@semt2.smts.cea.fr 17 : C*********************************************************************** 18 : C APPELES : REPICO, INCCOM, KRIPEE 19 : C MELCOM, KRIPME 20 : C RPENEN, EXINCS, RPENLE, MKNBNC, MIPCDB, MIDCDB 21 : C RPELEN, ML2LIE, RPELLE, MKLBLC, MLDCDB 22 : C CP2LR, MA2LIR, PROLIS, LI2MAS 23 : C APPELES (STAT.) : PRMSTA, INMSTA 24 : C APPELE PAR : PRCMCT 25 : C*********************************************************************** 26 : C ENTREES : MPRIB, MDUAB, IMATB, MPRIC, MDUAC, IMATC, CHPOD 27 : C SORTIES : MPCDB, MDCDB, IMTCDB 28 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 29 : C*********************************************************************** 30 : C VERSION : v1, 12/05/99, version initiale 31 : C HISTORIQUE : v1, 12/05/99, création 32 : C HISTORIQUE : 33 : C HISTORIQUE : 34 : C*********************************************************************** 35 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 36 : C en cas de modification de ce sous-programme afin de faciliter 37 : C la maintenance ! 38 : C*********************************************************************** 39 : * 40 : * Il faudra faire les suppressions de segments en tenant 41 : * compte des exceptions. 42 : * 43 : -INC CCOPTIO 44 : -INC SMCOORD 45 : -INC SMELEME 46 : POINTEUR MPRIB.MELEME 47 : POINTEUR MDUAB.MELEME 48 : POINTEUR MPRIC.MELEME 49 : POINTEUR MDUAC.MELEME 50 : POINTEUR MPCDB.MELEME 51 : POINTEUR MDCDB.MELEME 52 : POINTEUR MAIPRI.MELEME 53 : -INC SMMATRIK 54 : POINTEUR IMATB.IMATRI 55 : POINTEUR IMATC.IMATRI 56 : POINTEUR IMTCDB.IMATRI 57 : -INC SMCHPOI 58 : POINTEUR CHPOD.MCHPOI 59 : -INC SMLMOTS 60 : POINTEUR ICOGLO.MLMOTS 61 : -INC SMLENTI 62 : POINTEUR ICPRIB.MLENTI 63 : POINTEUR ICDUAB.MLENTI 64 : POINTEUR ICPRIC.MLENTI 65 : POINTEUR ICDUAC.MLENTI 66 : POINTEUR ICPRID.MLENTI 67 : POINTEUR JCPRIB.MLENTI 68 : POINTEUR JCDUAB.MLENTI 69 : POINTEUR JCPRIC.MLENTI 70 : POINTEUR JCDUAC.MLENTI 71 : POINTEUR ICOPRI.MLENTI 72 : POINTEUR KRIPRI.MLENTI 73 : POINTEUR LNBMEB.MLENTI 74 : POINTEUR LNBMEC.MLENTI 75 : POINTEUR ICPCDB.MLENTI 76 : POINTEUR KRMPRI.MLENTI 77 : POINTEUR LELEMB.MLENTI 78 : POINTEUR LELEMC.MLENTI 79 : * 80 : * Includes persos 81 : * 82 : * 83 : * Segment LSTIND (liste séquentielle indexée) 84 : * 85 : SEGMENT LSTIND 86 : INTEGER IDX(NBM+1) 87 : INTEGER IVAL(NBTVAL) 88 : ENDSEGMENT 89 : * 90 : * LISTE SEQUENTIELLE INDEXEE D'ENTIERS 91 : * 92 : * NBM : NOMBRE DE MULTIPLETS 93 : * NBTVAL : NOMBRE TOTAL DE VALEURS 94 : * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME 95 : * MULTIPLET DANS LE TABLEAU IVAL 96 : * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET 97 : *-INC SLSTIND 98 : POINTEUR LIPNMC.LSTIND 99 : POINTEUR LINBNC.LSTIND 100 : POINTEUR ICDCDB.LSTIND 101 : POINTEUR LMDUAB.LSTIND 102 : POINTEUR LMPRIB.LSTIND 103 : POINTEUR LMPRIC.LSTIND 104 : POINTEUR LMDUAC.LSTIND 105 : POINTEUR LIPNLC.LSTIND 106 : POINTEUR LILBLC.LSTIND 107 : POINTEUR LMPCDB.LSTIND 108 : POINTEUR LMDCDB.LSTIND 109 : SEGMENT LSRIND 110 : INTEGER IDXX(NBM+1) 111 : REAL*8 XVAL(NBTVAL) 112 : ENDSEGMENT 113 : SEGMENT LLI 114 : POINTEUR LISLI(NBME).LSRIND 115 : ENDSEGMENT 116 : POINTEUR LMATRB.LLI 117 : POINTEUR LMATRC.LLI 118 : POINTEUR LMACDB.LLI 119 : -INC SMLREEL 120 : SEGMENT LLR 121 : POINTEUR LISLR(NBME).MLREEL 122 : ENDSEGMENT 123 : POINTEUR LCHPOD.LLR 124 : *STAT-INC SMSTAT 125 : *STAT POINTEUR MSTEMP.MSTAT 126 : * 127 : INTEGER IMPR,IRET 128 : * 129 : INTEGER NIUNIQ,NIPRI 130 : INTEGER NTOTPO,NPPRI,NELC 131 : * 132 : * Executable statements 133 : * 134 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans promat.eso' 134 : *STAT CALL INMSTA(MSTAT,0) 135 : * Repérage global des inconnues : ICOGLO (LISTMOTS) 136 : * Noms des inconnues primales et duales de B et C exprimées 137 : * dans ce repérage : IC{PRI,DUA}{B,C} 138 : * (Eventuellement, si CHPOD.NE.0) : 139 : * Noms des inconnues de CHPOD dans ce repérage 140 : * In REPICO : SEGINI ICOGLO 141 : * In REPICO : SEGINI ICPRIB 142 : * In REPICO : SEGINI ICDUAB 143 : * In REPICO : SEGINI ICPRIC 144 : * In REPICO : SEGINI ICDUAC 145 : * In REPICO : SEGINI ICPRID 145 : *STAT CALL INMSTA(MSTEMP,0) 146 : * WRITE(IOIMP,*) 'repico' 146 : CALL REPICO(IMATB,IMATC,CHPOD, 147 : $ ICOGLO,ICPRIB,ICDUAB,ICPRIC,ICDUAC,ICPRID, 148 : $ IMPR,IRET) 149 : IF (IRET.NE.0) GOTO 9999 150 : * SEGPRT,ICOGLO 150 : *STAT CALL PRMSTA(' repico',MSTEMP,1) 150 : *STAT CALL SUMSTA(MSTEMP,0) 151 : SEGACT ICOGLO 152 : NIUNIQ=ICOGLO.MOTS(/2) 153 : SEGDES ICOGLO 154 : * Construction de ICOPRI (LISTENTI), liste des inconnues 155 : * appartenant à la fois à ICPRIB, ICPRIC et ICPRID 156 : * In INCCOM : SEGINI ICOPRI 156 : *STAT CALL INMSTA(MSTEMP,0) 157 : * WRITE(IOIMP,*) 'inccom' 157 : CALL INCCOM(ICPRIB,ICPRIC,ICPRID,NIUNIQ, 158 : $ ICOPRI, 159 : $ IMPR,IRET) 160 : IF (IRET.NE.0) GOTO 9999 161 : * SEGPRT,ICOPRI 161 : *STAT CALL PRMSTA(' inccom',MSTEMP,1) 161 : *STAT CALL SUMSTA(MSTEMP,0) 162 : * Si ICOPRI est vide, on sort prématurément 163 : SEGACT ICOPRI 164 : NIPRI=ICOPRI.LECT(/1) 165 : SEGDES ICOPRI 166 : IF (NIPRI.EQ.0) THEN 167 : *! write(ioimp,*) 'pas d''inconnues communes' 168 : * SEGINI ICOPRI 169 : * SEGINI ICPRID 170 : * SEGINI ICDUAC 171 : * SEGINI ICPRIC (exception) 172 : * SEGINI ICDUAB 173 : * SEGINI ICPRIB 174 : * SEGINI ICOGLO 175 : SEGSUP ICOPRI 176 : SEGSUP ICPRID 177 : SEGSUP ICDUAC 178 : SEGSUP ICPRIC 179 : SEGSUP ICDUAB 180 : SEGSUP ICPRIB 181 : SEGSUP ICOGLO 182 : GOTO 9998 183 : ENDIF 184 : * Sinon, on construit KRIPRI où on a repéré les inconnues de ICOPRI 185 : * dans le segment des inconnues globales 186 : * In KRIPEE : SEGINI KRIPRI 186 : *STAT CALL INMSTA(MSTEMP,0) 187 : * WRITE(IOIMP,*) 'kripee' 187 : CALL KRIPEE(ICOPRI,NIUNIQ, 188 : $ KRIPRI, 189 : $ IMPR,IRET) 190 : IF (IRET.NE.0) GOTO 9999 191 : * SEGPRT,KRIPRI 191 : *STAT CALL PRMSTA(' kripee',MSTEMP,1) 191 : *STAT CALL SUMSTA(MSTEMP,0) 191 : *STAT CALL PRMSTA(' Inc. primales communes',MSTAT,1) 192 : SEGSUP ICOPRI 193 : * Construction du maillage des points communs au maillage 194 : * primal de B, au maillage primal de C et au maillage sous-tendant 195 : * CHPOD (si CHPOD.NE.0) 196 : NTOTPO=XCOOR(/1)/(IDIM+1) 197 : * In MELCOM : SEGINI MAIPRI 197 : *STAT CALL INMSTA(MSTEMP,0) 198 : * WRITE(IOIMP,*) 'melcom' 198 : CALL MELCOM(MPRIB,CHPOD,MPRIC, 199 : $ MAIPRI, 200 : $ IMPR,IRET) 201 : IF (IRET.NE.0) GOTO 9999 201 : *STAT CALL PRMSTA(' melcom',MSTEMP,1) 201 : *STAT CALL SUMSTA(MSTEMP,0) 202 : * Si MAIPRI est vide, on sort prématurément 203 : SEGACT MAIPRI 204 : NPPRI=MAIPRI.NUM(/2) 205 : SEGDES MAIPRI 206 : IF (NPPRI.EQ.0) THEN 207 : *! write(ioimp,*) 'pas de points communs' 208 : * SEGINI MAIPRI 209 : * SEGINI KRIPRI 210 : * SEGINI ICPRID 211 : * SEGINI ICDUAC (exception) 212 : * SEGINI ICPRIC 213 : * SEGINI ICDUAB 214 : * SEGINI ICPRIB 215 : * SEGINI ICOGLO 216 : SEGSUP MAIPRI 217 : SEGSUP KRIPRI 218 : SEGSUP ICPRID 219 : SEGSUP ICDUAC 220 : SEGSUP ICPRIC 221 : SEGSUP ICDUAB 222 : SEGSUP ICPRIB 223 : SEGSUP ICOGLO 224 : GOTO 9998 225 : ENDIF 226 : * Sinon, on construit le segment de repérage dans MAIPRI 227 : * In KRIPME : SEGINI KRMPRI 227 : *STAT CALL INMSTA(MSTEMP,0) 228 : * WRITE(IOIMP,*) 'kripme' 228 : CALL KRIPME(MAIPRI,NTOTPO, 229 : $ KRMPRI, 230 : $ IMPR,IRET) 231 : IF (IRET.NE.0) GOTO 9999 231 : *STAT CALL PRMSTA(' kripme',MSTEMP,1) 231 : *STAT CALL SUMSTA(MSTEMP,0) 231 : *STAT CALL PRMSTA(' Points primaux communs',MSTAT,1) 232 : SEGSUP MAIPRI 233 : * 234 : * Traitement des inconnues 235 : * 236 : * On repère les éléments de ICPRIB qui sont dans ICOPRI 237 : * In RPENEN : SEGINI LNBMEB 237 : *STAT CALL INMSTA(MSTEMP,0) 238 : * WRITE(IOIMP,*) 'rpenen1' 238 : CALL RPENEN(ICPRIB,KRIPRI, 239 : $ LNBMEB, 240 : $ IMPR,IRET) 241 : IF (IRET.NE.0) GOTO 9999 242 : * On repère les éléments de ICPRIC qui sont dans ICOPRI 243 : * In RPENEN : SEGINI LNBMEC 244 : * WRITE(IOIMP,*) 'rpenen2' 244 : CALL RPENEN(ICPRIC,KRIPRI, 245 : $ LNBMEC, 246 : $ IMPR,IRET) 247 : IF (IRET.NE.0) GOTO 9999 248 : * SEGPRT,LNBMEB 249 : * SEGPRT,LNBMEC 249 : *STAT CALL PRMSTA(' rpenen*2',MSTEMP,1) 249 : *STAT CALL SUMSTA(MSTEMP,0) 250 : * Extraction des inconnues qui vont servir 251 : * In EXINCS : SEGINI JCPRIB 252 : * In EXINCS : SEGINI JCDUAB 253 : * In EXINCS : SEGINI JCPRIC 254 : * In EXINCS : SEGINI JCDUAC 254 : *STAT CALL INMSTA(MSTEMP,0) 255 : * WRITE(IOIMP,*) 'exincs' 255 : CALL EXINCS(ICDUAB,ICPRIB,ICPRIC,ICDUAC, 256 : $ LNBMEB,LNBMEC, 257 : $ JCDUAB,JCPRIB,JCPRIC,JCDUAC, 258 : $ IMPR,IRET) 259 : IF (IRET.NE.0) GOTO 9999 259 : *STAT CALL PRMSTA(' exincs',MSTEMP,1) 259 : *STAT CALL SUMSTA(MSTEMP,0) 260 : SEGSUP ICDUAC 261 : SEGSUP ICPRIC 262 : SEGSUP ICDUAB 263 : SEGSUP ICPRIB 264 : * On crée la liste indexée de correspondance : 265 : * une inconnue de ICOPRI -> n°s(IBMEs) matrice C tels que 266 : * JCPRIC(IBME)=ICOPRI 267 : * In RPENLE : SEGINI LIPNMC 267 : *STAT CALL INMSTA(MSTEMP,0) 268 : * WRITE(IOIMP,*) 'rpenle' 268 : CALL RPENLE(JCPRIC,KRIPRI,NIPRI, 269 : $ LIPNMC, 270 : $ IMPR,IRET) 271 : IF (IRET.NE.0) GOTO 9999 272 : * SEGPRT,JCPRIC 273 : * SEGPRT,LIPNMC 273 : *STAT CALL PRMSTA(' rpenle',MSTEMP,1) 273 : *STAT CALL SUMSTA(MSTEMP,0) 274 : * On crée la liste indexée de correspondance : 275 : * n°(NBME) matrice B -> n°s(NBMEs) matrice C ayant la même inconnue 276 : * primale 277 : * In MKNBNC : SEGINI LINBNC 277 : *STAT CALL INMSTA(MSTEMP,0) 278 : * SEGPRT,JCPRIB 279 : * WRITE(IOIMP,*) 'mknbnc' 279 : CALL MKNBNC(JCPRIB,LIPNMC,KRIPRI, 280 : $ LINBNC, 281 : $ IMPR,IRET) 282 : IF (IRET.NE.0) GOTO 9999 282 : *STAT CALL PRMSTA(' mknbnc',MSTEMP,1) 282 : *STAT CALL SUMSTA(MSTEMP,0) 283 : * On construit la liste des inconnues primales de CD-1Bt 284 : * In MIPCDB : SEGINI ICPCDB 284 : *STAT CALL INMSTA(MSTEMP,0) 285 : * WRITE(IOIMP,*) 'mipcdb' 285 : CALL MIPCDB(JCDUAB,NIUNIQ, 286 : $ ICPCDB, 287 : $ IMPR,IRET) 288 : IF (IRET.NE.0) GOTO 9999 288 : *STAT CALL PRMSTA(' mipcdb',MSTEMP,1) 288 : *STAT CALL SUMSTA(MSTEMP,0) 289 : * On construit la liste indexée à la précédente des 290 : * inconnues duales de CD-1Bt. 291 : * In MIDCDB : SEGINI ICDCDB 291 : *STAT CALL INMSTA(MSTEMP,0) 292 : * WRITE(IOIMP,*) 'midcdb' 292 : CALL MIDCDB(ICPCDB,JCDUAB,LINBNC,JCDUAC,NIUNIQ, 293 : $ ICDCDB, 294 : $ IMPR,IRET) 295 : IF (IRET.NE.0) GOTO 9999 295 : *STAT CALL PRMSTA(' midcdb',MSTEMP,1) 295 : *STAT CALL SUMSTA(MSTEMP,0) 295 : *STAT CALL PRMSTA(' Traitement des inconnues',MSTAT,1) 296 : SEGSUP LINBNC 297 : * 298 : * Traitement des maillages 299 : * 300 : * Construction de la liste des éléments du maillage primal de B 301 : * qui contiennent un point de MAIPRI. 302 : * In RPELEN : SEGINI LELEMB 302 : *STAT CALL INMSTA(MSTEMP,0) 303 : * WRITE(IOIMP,*) 'rpelen1' 303 : CALL RPELEN(MPRIB,KRMPRI, 304 : $ LELEMB, 305 : $ IMPR,IRET) 306 : IF (IRET.NE.0) GOTO 9999 307 : * SEGPRT,LELEMB 308 : * Construction de la liste des éléments du maillage primal de C 309 : * qui contiennent un point de MAIPRI. 310 : * In RPELEN : SEGINI LELEMC 311 : * WRITE(IOIMP,*) 'rpelen2' 311 : CALL RPELEN(MPRIC,KRMPRI, 312 : $ LELEMC, 313 : $ IMPR,IRET) 314 : IF (IRET.NE.0) GOTO 9999 315 : * SEGPRT,LELEMC 315 : *STAT CALL PRMSTA(' rpelen*2',MSTEMP,1) 315 : *STAT CALL SUMSTA(MSTEMP,0) 316 : * Extraction des éléments des MELEMEs qui vont servir et 317 : * transformation en listes indexées plus faciles à manipuler 318 : * In ML2LIE : SEGINI LMDUAB 319 : * In ML2LIE : SEGINI LMPRIB 320 : * In ML2LIE : SEGINI LMPRIC 321 : * In ML2LIE : SEGINI LMDUAC 321 : *STAT CALL INMSTA(MSTEMP,0) 322 : * WRITE(IOIMP,*) 'ml2lie' 322 : CALL ML2LIE(MDUAB,MPRIB,MPRIC,MDUAC, 323 : $ LELEMB,LELEMC, 324 : $ LMDUAB,LMPRIB,LMPRIC,LMDUAC, 325 : $ IMPR,IRET) 326 : IF (IRET.NE.0) GOTO 9999 326 : *STAT CALL PRMSTA(' ml2lie',MSTEMP,1) 326 : *STAT CALL SUMSTA(MSTEMP,0) 327 : * On crée la liste indexée de correspondance : 328 : * un point de MAIPRI -> n°s des éléments de LMPRIC qui contiennent 329 : * ce point 330 : * In REPELLE : SEGINI LIPNLC 330 : *STAT CALL INMSTA(MSTEMP,0) 331 : * WRITE(IOIMP,*) 'rpelle' 331 : CALL RPELLE(LMPRIC,KRMPRI,NPPRI, 332 : $ LIPNLC, 333 : $ IMPR,IRET) 334 : IF (IRET.NE.0) GOTO 9999 334 : *STAT CALL PRMSTA(' rpelle',MSTEMP,1) 334 : *STAT CALL SUMSTA(MSTEMP,0) 335 : * On crée la liste indexée de correspondance : 336 : * n° matrice élémentaire B -> n°s matrices élémentaires C 337 : SEGACT LMPRIC 338 : NELC=LMPRIC.IDX(/1)-1 339 : SEGDES LMPRIC 340 : * In MKLBLC : SEGINI LILBLC 340 : *STAT CALL INMSTA(MSTEMP,0) 341 : * WRITE(IOIMP,*) 'mklblc' 341 : CALL MKLBLC(LMPRIB,KRMPRI,LIPNLC,NELC, 342 : $ LILBLC, 343 : $ IMPR,IRET) 344 : IF (IRET.NE.0) GOTO 9999 344 : *STAT CALL PRMSTA(' mklblc',MSTEMP,1) 344 : *STAT CALL SUMSTA(MSTEMP,0) 345 : SEGSUP LIPNLC 346 : * On construit la liste des éléments primaux de CD-1Bt. 347 : * C'est déjà fait, c'est LMDUAB 348 : LMPCDB=LMDUAB 349 : * On construit la liste des éléments duaux de CD-1Bt. 350 : * In MLDCDB : SEGINI LMDCDB 350 : *STAT CALL INMSTA(MSTEMP,0) 351 : * WRITE(IOIMP,*) 'mldcdb' 351 : CALL MLDCDB(LILBLC,LMDUAC,NTOTPO, 352 : $ LMDCDB, 353 : $ IMPR,IRET) 354 : IF (IRET.NE.0) GOTO 9999 354 : *STAT CALL PRMSTA(' mldcdb',MSTEMP,1) 354 : *STAT CALL SUMSTA(MSTEMP,0) 354 : *STAT CALL PRMSTA(' Traitement des maillages',MSTAT,1) 355 : * 356 : * Traitement (éventuel) du chpoint 357 : * 358 : * In CP2LR : SEGINI LCHPOD 359 : * In CP2LR : SEGINI LCHPOD.LISLR(*) 360 : * Attention, 2 segments supp. sont créés du fait du fonctionnement de 361 : * DTCHPO. 361 : *STAT CALL INMSTA(MSTEMP,0) 362 : * WRITE(IOIMP,*) 'cp2lr' 362 : CALL CP2LR(CHPOD, 363 : $ ICPRID,ICOGLO,KRIPRI,NIPRI, 364 : $ KRMPRI,NPPRI, 365 : $ LCHPOD, 366 : $ IMPR,IRET) 367 : IF (IRET.NE.0) GOTO 9999 367 : *STAT CALL PRMSTA(' cp2lr ',MSTEMP,1) 367 : *STAT CALL SUMSTA(MSTEMP,0) 367 : *STAT CALL PRMSTA(' Traitement du chpoint',MSTAT,1) 368 : IF (ICPRID.NE.0) THEN 369 : SEGSUP ICPRID 370 : ENDIF 371 : * 372 : * Traitement des matrices 373 : * 374 : * Extraction des éléments des IMATRIs qui vont servir et 375 : * transformation en listes indexées plus faciles à manipuler 376 : * In MA2LIR : SEGINI LMATRB 377 : * In MA2LIR : SEGINI LMATRB.LISLI(*) 378 : * In MA2LIR : SEGINI LMATRC 379 : * In MA2LIR : SEGINI LMATRC.LISLI(*) 379 : *STAT CALL INMSTA(MSTEMP,0) 380 : * WRITE(IOIMP,*) 'ma2lir' 380 : CALL MA2LIR(IMATB,IMATC, 381 : $ LNBMEB,LNBMEC,LELEMB,LELEMC, 382 : $ LMATRB,LMATRC, 383 : $ IMPR,IRET) 384 : IF (IRET.NE.0) GOTO 9999 385 : * SEGPRT,LMATRB 386 : * SEGPRT,LMATRC 386 : *STAT CALL PRMSTA(' ma2lir',MSTEMP,1) 386 : *STAT CALL SUMSTA(MSTEMP,0) 386 : *STAT CALL PRMSTA(' Traitement des matrices',MSTAT,1) 387 : SEGSUP LELEMC 388 : SEGSUP LELEMB 389 : SEGSUP LNBMEC 390 : SEGSUP LNBMEB 391 : * Produit des matrices stockées sous forme de listes indexées 392 : * In MA2LIR : SEGINI LMACDB 393 : * In MA2LIR : SEGINI LMACDB.LISLI(*) 393 : *STAT CALL INMSTA(MSTEMP,0) 394 : * WRITE(IOIMP,*) 'prolis' 394 : CALL PROLIS(JCDUAB,JCPRIB,JCPRIC,JCDUAC, 395 : $ LIPNMC, KRIPRI, 396 : $ LMDUAB,LMPRIB,LMPRIC,LMDUAC, 397 : $ LILBLC,KRMPRI, 398 : $ LCHPOD,LMATRB,LMATRC, 399 : $ ICPCDB,ICDCDB,NIUNIQ, 400 : $ LMPCDB,LMDCDB,NTOTPO, 401 : $ LMACDB, 402 : $ IMPR,IRET) 403 : IF (IRET.NE.0) GOTO 9999 404 : * WRITE(IOIMP,*) 'apres prolis' 404 : *STAT CALL PRMSTA(' prolis',MSTEMP,1) 404 : *STAT CALL SUMSTA(MSTEMP,0) 404 : *STAT CALL PRMSTA(' On effectue le produit',MSTAT,1) 405 : SEGACT LMATRC*MOD 406 : SEGSUP LMATRC.LISLI(*) 407 : * SEGDES LMATRC 408 : SEGSUP LMATRC 409 : SEGACT LMATRB*MOD 410 : SEGSUP LMATRB.LISLI(*) 411 : * SEGDES LMATRB 412 : SEGSUP LMATRB 413 : IF (LCHPOD.NE.0) THEN 414 : SEGACT LCHPOD*MOD 415 : SEGSUP LCHPOD.LISLR(*) 416 : * SEGDES LCHPOD 417 : SEGSUP LCHPOD 418 : ENDIF 419 : SEGSUP LILBLC 420 : SEGSUP LMDUAC 421 : SEGSUP LMPRIC 422 : SEGSUP LMPRIB 423 : SEGSUP LIPNMC 424 : SEGSUP JCDUAC 425 : SEGSUP JCPRIC 426 : SEGSUP JCDUAB 427 : SEGSUP JCPRIB 428 : SEGSUP KRMPRI 429 : SEGSUP KRIPRI 430 : * Transformation des listes indexées résultats en maillages et en 431 : * matrices. 431 : *STAT CALL INMSTA(MSTEMP,0) 432 : * WRITE(IOIMP,*) 'li2mas' 432 : CALL LI2MAS(ICPCDB,ICDCDB,ICOGLO, 433 : $ LMPCDB,LMDCDB,LMACDB, 434 : $ MPCDB,MDCDB,IMTCDB, 435 : $ IMPR,IRET) 436 : IF (IRET.NE.0) GOTO 9999 436 : *STAT CALL PRMSTA(' Traitement du produit',MSTAT,1) 436 : *STAT CALL PRMSTA(' li2mas',MSTEMP,1) 436 : *STAT CALL SUMSTA(MSTEMP,0) 437 : SEGACT LMACDB*MOD 438 : SEGSUP LMACDB.LISLI(*) 439 : * SEGDES LMACDB 440 : SEGSUP LMACDB 441 : SEGSUP LMDCDB 442 : SEGSUP LMPCDB 443 : SEGSUP ICDCDB 444 : SEGSUP ICPCDB 445 : SEGSUP ICOGLO 445 : *STAT CALL SUMSTA(MSTAT,0) 446 : * 447 : * Normal termination 448 : * 449 : IRET=0 450 : RETURN 451 : * 452 : * Format handling 453 : * 454 : * 455 : * Error handling 456 : * 457 : * Pas une erreur proprement dite, mais il n'y avait rien à multiplier 458 : 9998 CONTINUE 459 : MPCDB=0 460 : MDCDB=0 461 : IMTCDB=0 462 : IRET=0 463 : RETURN 464 : 9999 CONTINUE 465 : IRET=1 466 : WRITE(IOIMP,*) 'An error was detected in subroutine promat' 467 : RETURN 468 : * 469 : * End of subroutine PROMAT 470 : * 471 : END 472 : 473 : 474 : 475 : 476 :
© Cast3M 2003 - All rights reserved.
Disclaimer