C SUPCHA    SOURCE    PV        10/10/13    21:15:45     6781           
      SUBROUTINE SUPCHA
c
c   sous routine pour calculer le chargement 
c   sur les ddl maitres d'un super element
c   option CHAR de SUPE
c
c
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
c
-INC CCOPTIO
-INC SMELEME
-INC SMRIGID
-INC SMSUPER
-INC SMMATRI
-INC SMVECTD
-INC SMCHPOI
-INC TMTRAV
c
      CHARACTER*4 INC
      SEGMENT NOHAR(0)
      SEGMENT SNOMIN
      CHARACTER*4 NOMIN(0)
      ENDSEGMENT
      SEGMENT SNOMDU
      CHARACTER*4 NOMDU(0)
      ENDSEGMENT
c
c
c
      CALL LIROBJ ('SUPERELE',MSUPER,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIROBJ ('CHPOINT ',MCHPOI,1,IRETOU)
      IF(IERR.NE.0) RETURN
      SEGACT MSUPER
c
c
c *** mcrout contient la decomposition modifiee de la rigidite         
c
      MMATRI=MCROUT
c
c *** lecture de la geometrie et du descripteur lies a
c *** la matrice de rigidite condensee du superelement
c
      MRIGID=MSURAI
      SEGACT MRIGID
      nbelem=0
      nbnn=1
      nbsous=0
      nbref=0
      segini ipt5
      ipt5.itypel=1
      in=0
      do ir=2,irigel(/2)
       meleme=irigel(1,ir)
       segact meleme
       nbelem=nbelem+num(/2)
       segadj ipt5
       do ip=1,num(/2)
        in=in+1
        ipt5.num(1,in)=num(1,ip)
       enddo
      enddo
*     call ecmail(ipt5,0)
      segact ipt5
      ichr=0
      if (nbelem.ne.0) call reduir(mchpoi,ipt5,ichr)
      lagdua=msuper.islag
*     write (6,*) ' supcha msurai ',msurai,lagdua
      xMATRI=IRIGEL(4,1)
      IPT1=IRIGEL(1,1)
      segact ipt1
*     call ecmail(ipt1)
      DESCR=IRIGEL(3,1)
      SEGACT DESCR
      SEGINI SNOMIN,SNOMDU,NOHAR
      NOMIN(**)=LISINC(1)
      NOMDU(**)=LISDUA(1)
      NOHAR(**)=IRIGEL(5,1)
      DO 10 I=1,LISINC(/2)
          N=NOMIN(/2)
          DO 11  J=1,N
              IF(LISINC(I).EQ.NOMIN(J)) GO TO 10
   11     CONTINUE
          NOMIN(**)=LISINC(I)
          NOMDU(**)=LISDUA(I)
          NOHAR(**)=IRIGEL(5,1)
   10 CONTINUE
c
c *** dimension de la matrice condensee
c
      SEGACT xMATRI
*      XMATRI=IMATTT(1)
*      SEGACT XMATRI
      NLIGRA=RE(/1)
*      SEGDES XMATRI
      SEGDES xMATRI
c
c *** transformation du chpoint en vecteur
c
      mchpo1=mchpoi
      if (lagdua.ne.0) then
       call copie2(mchpoi,mchpo1)
       SEGACT MCHPO1
       DO 432 I=1,mchpo1.IPCHP(/1)
          MSOUPO=mchpo1.IPCHP(I)
          SEGACT MSOUPO*MOD
          IPT4=IGEOC
          SEGINI,ipt5=ipt4
          SEGDES ipt4 
          IGEOC=ipt5
 432   CONTINUE
       call dbbch(mchpo1,lagdua)
*      call ecmail(lagdua,0)
*      call ecchpo(mchpo1,0)
      endif
      CALL CHV2(MMATRI,MCHPO1,MVECTD,1)
c
c *** calcul du chargement condense
c

      SEGACT MVECTD*MOD
      SEGACT MMATRI      
      MILIGN=IILIGN
      SEGACT MILIGN
      NBNNMA=IPNO(/1)-NLIGRA
      NNOEU=ILIGN(/1)
      ILA=1


* attention à la normalisation
      MDNOR=IDNORM
      SEGACT MDNOR
*  boucle sur les ddl s
*     write (6,*) ' vectbb -0 ',(vectbb(i),i=1,ipno(/1))
*     write (6,*) ' dnor      ',(dnor  (i),i=1,ipno(/1))
      DO 45 I = 1,IPNO(/1)
          VECTBB(I)=VECTBB(I)*DNOR(I)
  45  CONTINUE
*     write (6,*) ' vectbb -1 ',(vectbb(i),i=1,ipno(/1))

* fin normalisation

c
      DO 1 I=1,NNOEU
          LIGN=ILIGN(I)
          SEGACT LIGN
          NA=IMMM(/1)
          IDEB=1
          LPREC=0
          DO 2 J=1,NA
              IFIN=IPPVV(J+1)-1
              IDEB2=IVPO(2*IDEB)
              LONG=IVPO(2*(IFIN+1)-1)-IVPO(2*IDEB-1)
              IPRECOL=ILA-LONG
              DO 21 INDIC=IDEB,IFIN
                  IFIN2=IVPO(2*(INDIC+1))-1
                  ICOL=IVPO(2*INDIC-1)+IPRECOL-LPREC
                  IF (ICOL.GT.NBNNMA) GOTO 22
                  AUX=0.D0
                  DO 23 K=IDEB2,IFIN2
                      IF(ICOL.EQ.ILA) GOTO 24
                      IF(ICOL.GT.NBNNMA) GOTO 24
                      AUX=AUX+VAL(K)*VECTBB(ICOL)
                      ICOL=ICOL+1
 23               CONTINUE
 24               CONTINUE
                  VECTBB(ILA)=VECTBB(ILA)-AUX
                  IDEB2=IFIN2+1
 21           CONTINUE
 22           CONTINUE
              ILA=ILA+1
              IDEB=IFIN+1
              LPREC=LPREC+LONG
 2        CONTINUE
          SEGDES LIGN
 1    CONTINUE
      SEGDES MILIGN
c
c *** creation du chpoint resultat
c
      SEGACT IPT1
      NNNOE=IPT1.NUM(/1)
      NNIN=NOMDU(/2)
      SEGINI MTRAV
      DO 4 I=1,NNNOE
          IGEO (I)=IPT1.NUM(I,1)
   4  CONTINUE
      DO 5 I=1,NNIN
          INCO(I)=NOMDU(I)
          NHAR(I)=NOHAR(I)
   5  CONTINUE
      DO 6 I=1,NLIGRA
          INOEU=NOELED(I)
          INC=LISDUA(I)
          DO 7 J=1,NNIN
              IF(INC.EQ.NOMDU(J)) GO TO 8
   7      CONTINUE
   8      CONTINUE
          IBIN(J,INOEU)=1
* on oublie pas de denormaliser si les ddl maitres 
* ont ete normalisés
          BB(J,INOEU)=VECTBB(NBNNMA+I)/DNOR(NBNNMA+I)
   6  CONTINUE
      CALL CRECHP(MTRAV,ISOLU)
      if (ichr.ne.0) then
        call adchpo(isolu,ichr,iret,1.d0,1.d0)
        isolu=iret
      endif
c
c     champ de nature discrete
c
      MCHPOI = ISOLU
      SEGACT, MCHPOI*MOD
      JATTRI(1)=2
*     call ecmail(lagdua)
*     write (6,*) ' avant dbbcf dans supcha '
*     call ecchpo(mchpoi)
      if (lagdua.ne.0) call dbbcf(mchpoi,lagdua)
*     write (6,*) ' apres dbbcf dans supcha '
*     call ecchpo(mchpoi)
                 
      SEGDES MCHPOI
c
      ISOLU = MCHPOI
      CALL ECROBJ('CHPOINT ',ISOLU)
      SEGDES MDNOR
      SEGDES DESCR
      SEGDES MMATRI
      SEGDES MSUPER
      SEGDES MRIGID
      SEGDES IPT1
      SEGSUP SNOMIN,SNOMDU,NOHAR,MVECTD,MTRAV
      RETURN
      END
c