1 : C INCOR2 SOURCE GOUNAND 11/04/29 21:15:27 6947 2 : SUBROUTINE INCOR2(MATELE,IMULAG,LITOT,LITYP,LINIV,IMPR,IRET) 3 : IMPLICIT REAL*8 (A-H,O-Z) 4 : IMPLICIT INTEGER (I-N) 5 : C*********************************************************************** 6 : C NOM : INCOR2 7 : C DESCRIPTION : 8 : C 9 : C Construction de l'ensemble des noms d'inconnues possibles LITOT 10 : C et attribution d'un ordre. 11 : C On voudra qu'un ddl d'ordre i soit après au moins un ddl d'ordre 12 : C i-1 avec lequel il a une relation 13 : C LITOT : liste des noms d'inconnues 14 : C LIORD : ordre pour chaque inconnue 15 : C LITYP : type d'inconnue 1 : trusted 16 : C 2 : untrusted 17 : C 3 : premier multiplicateur 18 : C 4 : deuxième multiplicateur 19 : C LINIV : niveau de multiplicateur 1 : n'est pas un multiplicateur 20 : C 2 : est un multiplicateur qui 21 : C porte au moins sur un 1 22 : C 3 : est un multiplicateur qui 23 : C porte au moins sur un 2 24 : C ... 25 : C 26 : C 27 : C LANGAGE : ESOPE 28 : C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF) 29 : C mél : gounand@semt2.smts.cea.fr 30 : C*********************************************************************** 31 : C SYNTAXE GIBIANE : 32 : C ENTREES : 33 : C ENTREES/SORTIES : 34 : C SORTIES : 35 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 36 : C*********************************************************************** 37 : C VERSION : v1, 24/03/2004, version initiale 38 : C HISTORIQUE : v1, 24/03/2004, création 39 : C HISTORIQUE : 40 : C HISTORIQUE : 41 : C*********************************************************************** 42 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 43 : C en cas de modification de ce sous-programme afin de faciliter 44 : C la maintenance ! 45 : C*********************************************************************** 46 : -INC CCOPTIO 47 : -INC SMMATRIK 48 : POINTEUR MATELE.MATRIK 49 : POINTEUR IMATEL.IMATRI 50 : -INC SMLMOTS 51 : POINTEUR GPINCS.MLMOTS 52 : POINTEUR LITOT.MLMOTS 53 : POINTEUR LITOT2.MLMOTS 54 : -INC SMLENTI 55 : POINTEUR LINIV.MLENTI 56 : POINTEUR LINIV2.MLENTI 57 : POINTEUR LITYP.MLENTI 58 : POINTEUR LITYP2.MLENTI 59 : POINTEUR LORD.MLENTI 60 : POINTEUR LIORD.MLENTI 61 : C! POINTEUR LIORD2.MLENTI 62 : POINTEUR LIPERM.MLENTI 63 : LOGICAL LOK 64 : * 65 : INTEGER LNMOTS 66 : PARAMETER (LNMOTS=8) 67 : CHARACTER*8 MONMOT,MONMOD,MONMOP 68 : LOGICAL LRELA 69 : LOGICAL LTYNU2,LTYP1 70 : * 71 : INTEGER IMPR,IRET 72 : * 73 : * Executable statements 74 : * 75 : IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans incor2.eso' 76 : LTYNU2=(IMULAG.EQ.4.OR.IMULAG.EQ.5) 77 : * 78 : SEGACT MATELE 79 : NMATE = MATELE.IRIGEL(/2) 80 : * 81 : * Construction de la liste des inconnues 82 : * 83 : NBMTOT=0 84 : DO 3 IMATE=1,NMATE 85 : IMATEL=MATELE.IRIGEL(4,IMATE) 86 : SEGACT IMATEL 87 : NBMTOT=NBMTOT+IMATEL.LISPRI(/2) 88 : SEGDES IMATEL 89 : 3 CONTINUE 90 : JGN=LNMOTS 91 : JGM=2*NBMTOT 92 : SEGINI GPINCS 93 : SEGINI LITOT 94 : NBM2=0 95 : DO 4 IMATE=1,NMATE 96 : IMATEL=MATELE.IRIGEL(4,IMATE) 97 : SEGACT IMATEL 98 : DO 42 IBME=1,IMATEL.LISPRI(/2) 99 : NBM2=NBM2+1 100 : GPINCS.MOTS(NBM2)=IMATEL.LISPRI(IBME) 101 : 42 CONTINUE 102 : DO 43 IBME=1,IMATEL.LISDUA(/2) 103 : NBM2=NBM2+1 104 : GPINCS.MOTS(NBM2)=IMATEL.LISDUA(IBME) 105 : 43 CONTINUE 106 : SEGDES IMATEL 107 : 4 CONTINUE 107 : CALL CUNIQ(GPINCS.MOTS,LNMOTS,NBM2, 108 : $ LITOT.MOTS,NBUNIQ, 109 : $ IMPR,IRET) 110 : IF (IRET.NE.0) GOTO 9999 111 : JGN=LNMOTS 112 : JGM=NBUNIQ 113 : SEGADJ LITOT 114 : SEGSUP GPINCS 115 : * 116 : * SEGPRT,LITOT 117 : * 118 : * Construction de la liste des types 119 : JG=LITOT.MOTS(/2) 120 : SEGINI LITYP 121 : * Par défaut, toutes les inconnues ont le type untrusted (2) 122 : DO IORD=1,LITYP.LECT(/1) 123 : LITYP.LECT(IORD)=2 124 : ENDDO 125 : * On parcourt la liste des noms pour donner un type trusted (1) 126 : * ou multiplicateur de Lagrange premier (3) ou deuxième (4). 127 : DO ITOT=1,LITOT.MOTS(/2) 128 : * IF (LITOT.MOTS(ITOT)(1:1).EQ.'$') THEN 129 : * LITYP.LECT(ITOT)=1 130 : * ELSEIF (LITOT.MOTS(ITOT)(1:2).EQ.'LX') THEN 131 : IF (LITOT.MOTS(ITOT)(1:2).EQ.'LX') THEN 132 : LITYP.LECT(ITOT)=3 133 : ENDIF 134 : ENDDO 135 : DO IMATE=1,NMATE 136 : IMATYP=MATELE.IRIGEL(7,IMATE) 137 : IF (IMATYP.EQ.4.OR.IMATYP.EQ.-3.OR.IMATYP.EQ.-4) THEN 138 : IMATEL=MATELE.IRIGEL(4,IMATE) 139 : SEGACT IMATEL 140 : DO IBME=1,IMATEL.LISDUA(/2) 141 : MONMOT=IMATEL.LISDUA(IBME) 141 : CALL FIMOTS(MONMOT,LITOT,IORD,IMPR,IRET) 142 : IF (IRET.NE.0) GOTO 9999 143 : IF (IMATYP.EQ.-4) THEN 144 : LITYP.LECT(IORD)=4 145 : ELSE 146 : LITYP.LECT(IORD)=3 147 : ENDIF 148 : ENDDO 149 : SEGDES IMATEL 150 : ENDIF 151 : ENDDO 152 : * SEGPRT,LITYP 153 : * 154 : * On construit LINIV 155 : * 156 : JG=LITOT.MOTS(/2) 157 : SEGINI LINIV 158 : * On fait d'abord les types trusted et untrusted 159 : DO ITYP=1,2 160 : DO IINC=1,LITOT.MOTS(/2) 161 : IF (LITYP.LECT(IINC).EQ.ITYP) THEN 162 : LINIV.LECT(IINC)=1 163 : ENDIF 164 : ENDDO 165 : ENDDO 166 : * Les inconnues qui ont le type muliplicateur de Lagrange 167 : * mais qui n'ont de relations qu'avec elles-memes 168 : * se font attribuer un niveau 1. 169 : DO ITYP=3,4 170 : DO IINC=1,LITOT.MOTS(/2) 171 : IF (LITYP.LECT(IINC).EQ.ITYP) THEN 172 : MONMOD=LITOT.MOTS(IINC) 173 : LRELA=.TRUE. 174 : DO IMATE=1,NMATE 175 : IMATEL=MATELE.IRIGEL(4,IMATE) 176 : SEGACT IMATEL 177 : DO IBME=1,IMATEL.LISDUA(/2) 178 : IF (IMATEL.LISDUA(IBME).EQ.MONMOD) THEN 179 : MONMOP=IMATEL.LISPRI(IBME) 180 : *rajout 10/04/2009 180 : CALL FIMOTS(MONMOP,LITOT,IORP,IMPR,IRET) 181 : IF (IRET.NE.0) GOTO 9999 182 : ITYPP=LITYP.LECT(IORP) 183 : IF (MONMOP.NE.MONMOD.AND.(ITYPP.NE.ITYP)) THEN 184 : * IF (.NOT.(MONMOP.EQ.MONMOD)) THEN 185 : LRELA=.FALSE. 186 : ENDIF 187 : ENDIF 188 : ENDDO 189 : SEGDES IMATEL 190 : ENDDO 191 : IF (LRELA) THEN 192 : * LIORD.LECT(IINC)=IORD 193 : * IORD=IORD+1 194 : LINIV.LECT(IINC)=1 195 : ENDIF 196 : ENDIF 197 : ENDDO 198 : ENDDO 199 : SEGDES LITYP 200 : * 201 : * WRITE(IOIMP,*) ' Coucou les gars' 202 : * 203 : * SEGPRT,LITOT 204 : * SEGPRT,LINIV 205 : * SEGPRT,LIORD 206 : * SEGPRT,LIORD 207 : * On s'occupe des inconnues n'ayant pas de niveau. 208 : NLAG=0 209 : DO IINC=1,LITOT.MOTS(/2) 210 : INIV=LINIV.LECT(IINC) 211 : IF (INIV.EQ.0) THEN 212 : NLAG=NLAG+1 213 : ENDIF 214 : ENDDO 215 : * 216 : * WRITE(IOIMP,*) 'NLAG=',NLAG 217 : * 218 : DO IBCL=1,LITOT.MOTS(/2) 219 : * 9 CONTINUE 220 : IF (NLAG.GT.0) THEN 221 : DO IINC=1,LITOT.MOTS(/2) 222 : INIV=LINIV.LECT(IINC) 223 : IF (INIV.EQ.0) THEN 224 : MONMOD=LITOT.MOTS(IINC) 225 : * WRITE(IOIMP,*) 'IINC=',IINC 226 : * WRITE(IOIMP,*) 'MONMOD=',MONMOD 227 : LOK=.FALSE. 228 : DO IMATE=1,NMATE 229 : IMATEL=MATELE.IRIGEL(4,IMATE) 230 : SEGACT IMATEL 231 : DO IBME=1,IMATEL.LISDUA(/2) 232 : IF (IMATEL.LISDUA(IBME).EQ.MONMOD) THEN 233 : MONMOP=IMATEL.LISPRI(IBME) 234 : IF (MONMOP.NE.MONMOD) THEN 234 : CALL FIMOTS(MONMOP,LITOT,JINC,IMPR,IRET) 235 : IF (IRET.NE.0) GOTO 9999 236 : KNIV=LINIV.LECT(JINC) 237 : * WRITE(IOIMP,*) 'MONMOP=',MONMOP 238 : * WRITE(IOIMP,*) 'KNIV=',KNIV 239 : IF (KNIV.NE.0) THEN 240 : * LOK=.FALSE. 241 : * ELSE 242 : LOK=.TRUE. 243 : INIV=MAX(INIV,KNIV+1) 244 : ENDIF 245 : ENDIF 246 : ENDIF 247 : ENDDO 248 : SEGDES IMATEL 249 : ENDDO 250 : * WRITE(IOIMP,*) 'LOK=',LOK 251 : IF (LOK) THEN 252 : NLAG=NLAG-1 253 : LINIV.LECT(IINC)=INIV 254 : ENDIF 255 : ENDIF 256 : ENDDO 257 : * GOTO 9 258 : ENDIF 259 : ENDDO 260 : SEGDES MATELE 261 : SEGDES LINIV 262 : * 263 : * Normal termination 264 : * 265 : IRET=0 266 : RETURN 267 : * 268 : * Format handling 269 : * 270 : * 271 : * Error handling 272 : * 273 : 9999 CONTINUE 274 : IRET=1 275 : WRITE(IOIMP,*) 'An error was detected in subroutine incor2' 276 : RETURN 277 : * 278 : * End of subroutine INCOR2 279 : * 280 : END 281 : 282 : 283 : 284 : 285 :
© Cast3M 2003 - All rights reserved.
Disclaimer