C INCOR2 SOURCE PV 20/09/26 21:17:24 10724 SUBROUTINE INCOR2(MATELE,IMULAG,LITOT,LITYP,LINIV,IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : INCOR2 C DESCRIPTION : C C Construction de l'ensemble des noms d'inconnues possibles LITOT C et attribution d'un ordre. C On voudra qu'un ddl d'ordre i soit après au moins un ddl d'ordre C i-1 avec lequel il a une relation C LITOT : liste des noms d'inconnues C LIORD : ordre pour chaque inconnue C LITYP : type d'inconnue 1 : trusted C 2 : untrusted C 3 : premier multiplicateur C 4 : deuxième multiplicateur C LINIV : niveau de multiplicateur 1 : n'est pas un multiplicateur C 2 : est un multiplicateur qui C porte au moins sur un 1 C 3 : est un multiplicateur qui C porte au moins sur un 2 C ... C C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C SYNTAXE GIBIANE : C ENTREES : C ENTREES/SORTIES : C SORTIES : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 24/03/2004, version initiale C HISTORIQUE : v1, 24/03/2004, création C HISTORIQUE : C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** -INC PPARAM -INC CCOPTIO -INC SMMATRIK POINTEUR MATELE.MATRIK POINTEUR IMATEL.IMATRI -INC SMLMOTS POINTEUR GPINCS.MLMOTS POINTEUR LITOT.MLMOTS POINTEUR LITOT2.MLMOTS -INC SMLENTI POINTEUR LINIV.MLENTI POINTEUR LINIV2.MLENTI POINTEUR LITYP.MLENTI POINTEUR LITYP2.MLENTI POINTEUR LORD.MLENTI POINTEUR LIORD.MLENTI C! POINTEUR LIORD2.MLENTI POINTEUR LIPERM.MLENTI LOGICAL LOK * INTEGER LNMOTS PARAMETER (LNMOTS=8) CHARACTER*8 MONMOT,MONMOD,MONMOP LOGICAL LRELA LOGICAL LTYNU2,LTYP1 * INTEGER IMPR,IRET * * Executable statements * IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans incor2.eso' LTYNU2=(IMULAG.EQ.4.OR.IMULAG.EQ.5) * SEGACT MATELE NMATE = MATELE.IRIGEL(/2) * * Construction de la liste des inconnues * NBMTOT=0 DO 3 IMATE=1,NMATE IMATEL=MATELE.IRIGEL(4,IMATE) SEGACT IMATEL NBMTOT=NBMTOT+IMATEL.LISPRI(/2) SEGDES IMATEL 3 CONTINUE JGN=LNMOTS JGM=2*NBMTOT SEGINI GPINCS SEGINI LITOT NBM2=0 DO 4 IMATE=1,NMATE IMATEL=MATELE.IRIGEL(4,IMATE) SEGACT IMATEL DO 42 IBME=1,IMATEL.LISPRI(/2) NBM2=NBM2+1 GPINCS.MOTS(NBM2)=IMATEL.LISPRI(IBME) 42 CONTINUE DO 43 IBME=1,IMATEL.LISDUA(/2) NBM2=NBM2+1 GPINCS.MOTS(NBM2)=IMATEL.LISDUA(IBME) 43 CONTINUE SEGDES IMATEL 4 CONTINUE CALL CUNIQ(GPINCS.MOTS,LNMOTS,NBM2, $ LITOT.MOTS,NBUNIQ, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 JGN=LNMOTS JGM=NBUNIQ SEGADJ LITOT SEGSUP GPINCS * * SEGPRT,LITOT * * Construction de la liste des types JG=LITOT.MOTS(/2) SEGINI LITYP * Par défaut, toutes les inconnues ont le type untrusted (2) DO IORD=1,LITYP.LECT(/1) LITYP.LECT(IORD)=2 ENDDO * On parcourt la liste des noms pour donner un type trusted (1) * ou multiplicateur de Lagrange premier (3) ou deuxième (4). DO ITOT=1,LITOT.MOTS(/2) * IF (LITOT.MOTS(ITOT)(1:1).EQ.'$') THEN * LITYP.LECT(ITOT)=1 * ELSEIF (LITOT.MOTS(ITOT)(1:2).EQ.'LX') THEN IF (LITOT.MOTS(ITOT)(1:2).EQ.'LX') THEN LITYP.LECT(ITOT)=3 ENDIF ENDDO DO IMATE=1,NMATE IMATYP=MATELE.IRIGEL(7,IMATE) IF (IMATYP.EQ.4.OR.IMATYP.EQ.-3.OR.IMATYP.EQ.-4) THEN IMATEL=MATELE.IRIGEL(4,IMATE) SEGACT IMATEL DO IBME=1,IMATEL.LISDUA(/2) MONMOT=IMATEL.LISDUA(IBME) CALL FIMOTS(MONMOT,LITOT,IORD,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (IMATYP.EQ.-4) THEN LITYP.LECT(IORD)=4 ELSE LITYP.LECT(IORD)=3 ENDIF ENDDO SEGDES IMATEL ENDIF ENDDO * SEGPRT,LITYP * * On construit LINIV * JG=LITOT.MOTS(/2) SEGINI LINIV * On fait d'abord les types trusted et untrusted DO ITYP=1,2 DO IINC=1,LITOT.MOTS(/2) IF (LITYP.LECT(IINC).EQ.ITYP) THEN LINIV.LECT(IINC)=1 ENDIF ENDDO ENDDO * Les inconnues qui ont le type muliplicateur de Lagrange * mais qui n'ont de relations qu'avec elles-memes * se font attribuer un niveau 1. DO ITYP=3,4 DO IINC=1,LITOT.MOTS(/2) IF (LITYP.LECT(IINC).EQ.ITYP) THEN MONMOD=LITOT.MOTS(IINC) LRELA=.TRUE. DO IMATE=1,NMATE IMATEL=MATELE.IRIGEL(4,IMATE) SEGACT IMATEL DO IBME=1,IMATEL.LISDUA(/2) IF (IMATEL.LISDUA(IBME).EQ.MONMOD) THEN MONMOP=IMATEL.LISPRI(IBME) *rajout 10/04/2009 CALL FIMOTS(MONMOP,LITOT,IORP,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ITYPP=LITYP.LECT(IORP) IF (MONMOP.NE.MONMOD.AND.(ITYPP.NE.ITYP)) THEN * IF (.NOT.(MONMOP.EQ.MONMOD)) THEN LRELA=.FALSE. ENDIF ENDIF ENDDO SEGDES IMATEL ENDDO IF (LRELA) THEN * LIORD.LECT(IINC)=IORD * IORD=IORD+1 LINIV.LECT(IINC)=1 ENDIF ENDIF ENDDO ENDDO SEGDES LITYP * * WRITE(IOIMP,*) ' Coucou les gars' * * SEGPRT,LITOT * SEGPRT,LINIV * SEGPRT,LIORD * SEGPRT,LIORD * On s'occupe des inconnues n'ayant pas de niveau. NLAG=0 DO IINC=1,LITOT.MOTS(/2) INIV=LINIV.LECT(IINC) IF (INIV.EQ.0) THEN NLAG=NLAG+1 ENDIF ENDDO * * WRITE(IOIMP,*) 'NLAG=',NLAG * DO IBCL=1,LITOT.MOTS(/2) * 9 CONTINUE IF (NLAG.GT.0) THEN DO IINC=1,LITOT.MOTS(/2) INIV=LINIV.LECT(IINC) IF (INIV.EQ.0) THEN MONMOD=LITOT.MOTS(IINC) * WRITE(IOIMP,*) 'IINC=',IINC * WRITE(IOIMP,*) 'MONMOD=',MONMOD LOK=.FALSE. DO IMATE=1,NMATE IMATEL=MATELE.IRIGEL(4,IMATE) SEGACT IMATEL DO IBME=1,IMATEL.LISDUA(/2) IF (IMATEL.LISDUA(IBME).EQ.MONMOD) THEN MONMOP=IMATEL.LISPRI(IBME) IF (MONMOP.NE.MONMOD) THEN CALL FIMOTS(MONMOP,LITOT,JINC,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 KNIV=LINIV.LECT(JINC) * WRITE(IOIMP,*) 'MONMOP=',MONMOP * WRITE(IOIMP,*) 'KNIV=',KNIV IF (KNIV.NE.0) THEN * LOK=.FALSE. * ELSE LOK=.TRUE. INIV=MAX(INIV,KNIV+1) ENDIF ENDIF ENDIF ENDDO SEGDES IMATEL ENDDO * WRITE(IOIMP,*) 'LOK=',LOK IF (LOK) THEN NLAG=NLAG-1 LINIV.LECT(IINC)=INIV ENDIF ENDIF ENDDO * GOTO 9 ENDIF ENDDO SEGDES MATELE SEGDES LINIV * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine incor2' RETURN * * End of subroutine INCOR2 * END