1 : C MKPMO2 SOURCE MAGN 09/07/30 21:19:33 6458 2 : SUBROUTINE MKPMO2(LPDPP,KJSPGD,KRINCP,KRINCD, 3 : $ KRSPGT,KMINCT, 4 : $ LDDLDU,PMCOU, 5 : $ IMPR,IRET) 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8 (A-H,O-Z) 8 : C*********************************************************************** 9 : C NOM : MKPMO2 10 : C PROJET : Assemblage matrice élémentaire -> matrice Morse 11 : C DESCRIPTION : Matrice élémentaire + liste indexée d'entiers(popoin) => 12 : C Profil Morse de la matrice assemblée (les colonnes ne 13 : C sont pas ordonnées). 14 : C 15 : C LANGAGE : ESOPE 16 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 17 : C mél : gounand@semt2.smts.cea.fr 18 : C*********************************************************************** 19 : C APPELES : CORINC 20 : C APPELE PAR : MAKPRM 21 : C*********************************************************************** 22 : C ENTREES : LPDPP, KJSPGD, KRINCP, KRINCD, KRSPGT, KMINCT 23 : C SORTIES : PMCOU 24 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 25 : C*********************************************************************** 26 : C VERSION : v1, 06/10/99, version initiale 27 : C HISTORIQUE : v1, 06/10/99, création 28 : C HISTORIQUE : 29 : C HISTORIQUE : 30 : C*********************************************************************** 31 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 32 : C en cas de modification de ce sous-programme afin de faciliter 33 : C la maintenance ! 34 : C*********************************************************************** 35 : * 36 : * 37 : * On peut optimiser les boucles en sortant les NPOS 38 : * 39 : * 40 : -INC CCOPTIO 41 : -INC SMELEME 42 : POINTEUR KJSPGD.MELEME 43 : -INC SMMATRIK 44 : POINTEUR KMINCT.MINC 45 : INTEGER NTT,NJA 46 : POINTEUR PMCOU.PMORS 47 : -INC SMLENTI 48 : INTEGER JG 49 : POINTEUR KRINCD.MLENTI 50 : POINTEUR KRIDUN.MLENTI 51 : POINTEUR KRINCP.MLENTI 52 : POINTEUR KRSPGT.MLENTI 53 : POINTEUR DD2DP.MLENTI 54 : POINTEUR LDDLDU.MLENTI 55 : POINTEUR KDDLDU.MLENTI 56 : * 57 : * Includes perso 58 : * 59 : *-INC SLSTIND 60 : * 61 : * Segment LSTIND (liste séquentielle indexée) 62 : * 63 : SEGMENT LSTIND 64 : INTEGER IDX(NBM+1) 65 : INTEGER IVAL(NBTVAL) 66 : ENDSEGMENT 67 : * 68 : * LISTE SEQUENTIELLE INDEXEE D'ENTIERS 69 : * 70 : * NBM : NOMBRE DE MULTIPLETS 71 : * NBTVAL : NOMBRE TOTAL DE VALEURS 72 : * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME 73 : * MULTIPLET DANS LE TABLEAU IVAL 74 : * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET 75 : POINTEUR LIPUN.LSTIND 76 : POINTEUR LPDPP.LSTIND 77 : * 78 : INTEGER IMPR,IRET 79 : * 80 : LOGICAL LEXIST 81 : INTEGER IDEPA 82 : INTEGER IDUNIQ,IPUNIQ,IPDUA,IPPRI,ITTDDL 83 : INTEGER NDUNIQ,NPDUA, NTTDDL 84 : INTEGER NOPPR,NOPDU 85 : INTEGER NUTPPR,NUTPDU,NUTDPR,NUTDDU 86 : INTEGER NTOTCO,NTOTPO 87 : * 88 : * Executable statements 89 : * 90 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans mkpmo2' 91 : C Pour chaque composante primale distincte, il faudrait déterminer 92 : C avec quels composantes duales distinctes il est relié : 93 : C Par exemple, si on a : 94 : C KRINCD = 1 1 1 2 95 : C KRINCP = 2 2 3 4 96 : C On a : KRIDUN = 1 2 97 : C On veut : LIPUN = (2 3) (4) (c'est une liste indexée) 98 : C 98 : CALL CORINC(KRINCD,KRINCP, 99 : $ KRIDUN,LIPUN, 100 : $ IMPR,IRET) 101 : C - Construire la liste d'entiers suivante (DD2DP) : 102 : C * Nombre d'entiers = nb total de ddl (primaux) ; 103 : C * pour chaque ddl primal : nb. total de ddl duaux qui lui 104 : C sont reliés. 105 : SEGACT KRIDUN 106 : NDUNIQ=KRIDUN.LECT(/1) 107 : SEGACT LIPUN 108 : SEGACT KJSPGD 109 : SEGACT KRSPGT 110 : SEGACT KMINCT 111 : NTOTPO=KMINCT.NPOS(/1)-1 112 : NTTDDL=KMINCT.NPOS(NTOTPO+1)-1 113 : JG=NTTDDL 114 : SEGINI DD2DP 115 : SEGACT LPDPP 116 : NPDUA=KJSPGD.NUM(/2) 117 : DO 1 IPDUA=1,NPDUA 118 : NOPDU=KJSPGD.NUM(1,IPDUA) 119 : NUTPDU=KRSPGT.LECT(NOPDU) 120 : IF (NUTPDU.EQ.0) THEN 121 : WRITE(IOIMP,*) 'C''est dual grave...' 122 : GOTO 9999 123 : ENDIF 124 : DO 12 IDUNIQ=1,NDUNIQ 125 : LEXIST=(KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ)).NE.0) 126 : IF (.NOT.LEXIST) THEN 127 : WRITE(IOIMP,*) 'C''est comp. duale grave...' 128 : GOTO 9999 129 : ENDIF 130 : NUTDDU=KMINCT.NPOS(NUTPDU) 131 : $ +KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ))-1 132 : DD2DP.LECT(NUTDDU)=(LIPUN.IDX(IDUNIQ+1)-LIPUN.IDX(IDUNIQ)) 133 : $ *(LPDPP.IDX(IPDUA+1)-LPDPP.IDX(IPDUA)) 134 : 12 CONTINUE 135 : 1 CONTINUE 136 : C 137 : C - Dimensionner le profil Morse 138 : C 139 : NDDLDU=0 140 : NTOTCO=0 141 : DO 3 ITTDDL=1,NTTDDL 142 : NTERM=DD2DP.LECT(ITTDDL) 143 : IF (NTERM.GT.0) THEN 144 : NDDLDU=NDDLDU+1 145 : NTOTCO=NTOTCO+NTERM 146 : ENDIF 147 : 3 CONTINUE 148 : JG=NDDLDU 149 : SEGINI LDDLDU 150 : NTT=NDDLDU 151 : NJA=NTOTCO 152 : SEGINI PMCOU 153 : C 154 : C - Remplissage du profil de la matrice Morse : 155 : C * Le tableau IA : 156 : IDDLDU=0 157 : PMCOU.IA(1)=1 158 : DO 5 ITTDDL=1,NTTDDL 159 : NTERM=DD2DP.LECT(ITTDDL) 160 : IF (NTERM.GT.0) THEN 161 : IDDLDU=IDDLDU+1 162 : LDDLDU.LECT(IDDLDU)=ITTDDL 163 : PMCOU.IA(IDDLDU+1)=PMCOU.IA(IDDLDU) 164 : $ +DD2DP.LECT(ITTDDL) 165 : ENDIF 166 : 5 CONTINUE 167 : * SEGSUQ DD2DP 168 : KDDLDU=DD2DP 168 : CALL RSETXI(KDDLDU.LECT,LDDLDU.LECT,NDDLDU) 169 : C * Le tableau JA : 170 : DO 7 IPDUA=1,NPDUA 171 : NOPDU=KJSPGD.NUM(1,IPDUA) 172 : NUTPDU=KRSPGT.LECT(NOPDU) 173 : DO 72 IDUNIQ=1,NDUNIQ 174 : NUTDDU=KMINCT.NPOS(NUTPDU) 175 : $ +KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ))-1 176 : NUTDD2=KDDLDU.LECT(NUTDDU) 177 : IDEPA=PMCOU.IA(NUTDD2) 178 : DO 722 IPPRI=LPDPP.IDX(IPDUA),LPDPP.IDX(IPDUA+1)-1 179 : NOPPR=LPDPP.IVAL(IPPRI) 180 : NUTPPR=KRSPGT.LECT(NOPPR) 181 : DO 7222 IPUNIQ=LIPUN.IDX(IDUNIQ),LIPUN.IDX(IDUNIQ+1)-1 182 : NUTDPR=KMINCT.NPOS(NUTPPR) 183 : $ +KMINCT.MPOS(NUTPPR,LIPUN.IVAL(IPUNIQ))-1 184 : PMCOU.JA(IDEPA)=NUTDPR 185 : IDEPA=IDEPA+1 186 : 7222 CONTINUE 187 : 722 CONTINUE 188 : 72 CONTINUE 189 : 7 CONTINUE 190 : SEGSUP KDDLDU 191 : SEGDES LDDLDU 192 : SEGDES PMCOU 193 : SEGDES LPDPP 194 : SEGDES KMINCT 195 : SEGDES KRSPGT 196 : SEGDES KJSPGD 197 : SEGSUP LIPUN 198 : SEGSUP KRIDUN 199 : * 200 : * Normal termination 201 : * 202 : IRET=0 203 : RETURN 204 : * 205 : * Format handling 206 : * 207 : * 208 : * Error handling 209 : * 210 : 9999 CONTINUE 211 : IRET=1 212 : WRITE(IOIMP,*) 'An error was detected in subroutine mkpmo2' 213 : RETURN 214 : * 215 : * End of subroutine MKPMO2 216 : * 217 : END 218 : 219 : 220 : 221 : 222 :
© Cast3M 2003 - All rights reserved.
Disclaimer