Sources Esope | Cast3M

supcha
C SUPCHA    SOURCE    PV090527  24/10/23    21:15:08     12044          
      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 PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMRIGID
-INC SMSUPER
-INC SMMATRI
-INC SMVECTD
-INC SMCHPOI
-INC TMTRAV
-INC CCREEL
-INC SMLMOTS
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
 
      IF (MCROUT.EQ.0) then
*  si pas de super element on se contente d'enlever les FLX
       JGM=1         
       JGN=LOCOMP
       SEGINI MLMOTS
        MOTS(1)='FLX' 
        CALL ENLEV5(MCHPOI,MLMOTS,ipoin2)
        CALL ECROBJ('CHPOINT  ',ipoin2)
 
 
 
 
        RETURN 
      ENDIF
 
 
 
 
 
 
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))
      vecmax=0.d0
      DO 45 I = 1,IPNO(/1)
          VECTBB(I)=VECTBB(I)*DNOR(I)
          vecmax=max(vecmax,abs(vectbb(i)))
  45  CONTINUE
      vecref=vecmax*XZPREC*XZPREC
*     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)
          DO 2 J=1,NA
              IDEB=IPPVV(J)
              IFIN=IPPVV(J+1)-1
              AUX=0.D0
              DO 21 INDIC=IDEB,IFIN
                  IDEB2=IVPO(2*INDIC)
                  IFIN2=IVPO(2*(INDIC+1))-1
                  DO 23 K=IDEB2,IFIN2
                   icol=k-ivpo(2*indic)+ivpo(2*indic-1)+
     >                 ila-j -ivpo(2*(ifin)-1)+1
                      IF(ICOL.ge.ILA) GOTO 24
                      IF(ICOL.GT.NBNNMA) GOTO 24
                      AUX=AUX+val(k)*vectbb(icol)
 23               CONTINUE
 24               CONTINUE
 21           CONTINUE
 22           CONTINUE
              VECTBB(ILA)=VECTBB(ILA)-AUX
              if (abs(vectbb(ila)).lt.vecref) vectbb(ila)=0.d0
              ILA=ILA+1
 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
      if(ierr.ne.0) return
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