C REDFOR    SOURCE    GOUNAND   25/04/30    21:15:36     12258          
      subroutine redfor(mchpoi,ri4,mchpo1)

*  élimination des ddls supprimés dans le second membre réduit
* inspiré de transr et mschp1 (MASQ)
*     mchpoi : entree = second membre réduit avec ddls supprimés
*     ri4    : entree = matrice de relation
*     mchpo1 : sortie = second membre réduit sans ddls supprimés

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

-INC SMCHPOI
-INC SMRIGID
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC SMCOORD
-INC SMELEME
-INC TMTRAV

      SEGMENT/MTRA/(NOPOIN(nbpts))

      SEGMENT MTR1
        CHARACTER*(LOCOMP) IPCOM(0)
      ENDSEGMENT

      SEGMENT/MTR4/(IPHAR(0))

      CHARACTER*(LOCOMP) nomp,nomd

      SEGINI MTRA,MTR1,MTR4
*
* Initialisation de MTRAV, MTRA, MTR1, MTR4 (repris de mschp1.eso)
*
      SEGACT MCHPOI
      IK=0
      NSOUPO=IPCHP(/1)
      DO 20 IA=1,NSOUPO
         MSOUPO=IPCHP(IA)
         SEGACT MSOUPO
         MELEME=IGEOC
         SEGACT MELEME
         NBELEM=NUM(/2)
         DO 30 IB=1,NBELEM
            K=NUM(1,IB)
            IF(NOPOIN(K).NE.0) GO TO 30
            IK=IK+1
            NOPOIN(K)=IK
 30      CONTINUE
         NCBBB=NOCOMP(/2)
         DO 40 IB=1,NCBBB
            NC=IPCOM(/2)
            DO 50 IC=1,NC
               IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 50
               IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 40
 50         CONTINUE
            IPCOM(**)=NOCOMP(IB)
            IPHAR(**)=NOHARM(IB)
 40      CONTINUE
 20   CONTINUE
C
      NNIN=IPCOM(/2)
      NNNOE=IK
      SEGINI MTRAV
      DO 70 IA=1,NNIN
         INCO(IA)=IPCOM(IA)
         NHAR(IA)=IPHAR(IA)
 70   CONTINUE
C
C CREATION DE BB,IBIN,IGEO
C
      NSOUPO=IPCHP(/1)
      DO 80 IA=1,NSOUPO
         MSOUPO=IPCHP(IA)
         SEGACT MSOUPO
         MELEME=IGEOC
         MPOVAL=IPOVAL
         SEGACT MELEME,MPOVAL
         NBELEM=NUM(/2)
         NC=VPOCHA(/2)
         NC1=NOCOMP(/2)
C
         DO 90 IB=1,NC1
            DO 100 IC=1,NNIN
               IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 100
               IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 110
 100        CONTINUE
* Pas de composante trouvée, ce n'est pas normal
            goto 9999
 110        CONTINUE
            DO 120 ID=1,NBELEM
               KI=NOPOIN(NUM(1,ID))
               IGEO(KI)=NUM(1,ID)
               IBIN(IC,KI)=1
               BB(IC,KI)=VPOCHA(ID,IB)
 120        CONTINUE
 90      CONTINUE
 80   CONTINUE

*  on balaye les raideurs de dependances, on supprime les ddl dependants
*  dans le MTRAV
      segact ri4
      do 1100 irig=1,ri4.irigel(/2)
         if (ri4.irigel(8,irig).ne.0) then
            descr=ri4.irigel(3,irig)
            meleme=ri4.irigel(1,irig)
            Xmatri=ri4.irigel(4,irig)
            segact descr,meleme,xmatri
            do 1110 iligrp=1,lisinc(/2)
               if (lisinc(iligrp).eq.'LX  ') goto 1120
 1110       continue
            goto 1100
 1120       continue
* Le multiplicateur de lagrange n'est pas en première position
* dans le descripteur de la matrice, ce n'est pas prévu
            if (iligrp.ne.1) goto 9999
            nbelem=num(/2)
* on supprime le multiplicateur de lagrange et le ddl dépendant
            do idep=1,2
               nomp=lisinc(idep)
* on trouve le nom dual correspondant (si non trouvé dual=primal)
               nomd=nomp
               do ipri=1,lnomdd
                  if (nomp.eq.nomdd(ipri)) nomd=nomdu(ipri)
               enddo
               iharm=ri4.irigel(5,irig)
               inin=0
               do ii=1,nhar(/1)
                  if (inco(ii).eq.nomd.and.nhar(ii).eq.iharm) inin=ii
               enddo
               if (inin.ne.0) then
                  do 1130 i=1,nbelem
*               write(ioimp,*) 'ddl a eliminer ',iharm,nomd,' ',
*     $                    num(noelep(idep),i)
                     ik=nopoin(num(noelep(idep),i))
                     if (ik.ne.0) ibin(inin,ik)=0
 1130             continue
               endif
            enddo
         endif
 1100 continue
      segsup MTRA,MTR1,MTR4
*
* On reconstruit le chpoint nettoyé et on lui donne les mêmes
* caractéristiques que l'original
*
      CALL CRECHP(mtrav,mchpo1)
      segsup mtrav
      mchpo1.mochde='CHPOINT cree par redfor'
      mchpo1.ifopoi=ifopoi
      do i=1,min(mchpo1.jattri(/1),jattri(/1))
         mchpo1.jattri(i)=jattri(i)
      enddo
      return

 9999 continue
      MOTERR='REDFOR  '
      CALL ERREUR(1039)
      RETURN
      end