Sources Esope | Cast3M

blopha
C BLOPHA    SOURCE    CB215821  26/05/29    21:15:05     12560          
      SUBROUTINE BLOPHA
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
* +------------------------------------------------------------------------+
* | création des matrices de bloquage pour le modele CHANGEMENT_PHASE      |
* |    RIGIDITE sont de type 2 avec des 'FLX' a mettre en face             |
* +------------------------------------------------------------------------+
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMMODEL
-INC SMRIGID
-INC SMCOORD
-INC SMCHPOI
-INC SMCHAML
 
* +------------------------------------------------------------------------+
      call LIROBJ('MMODEL  ',mmodel,1,iretou)
      call ACTOBJ('MMODEL  ',mmodel,1)
      if(ierr.ne.0) return
      nbsou =kmodel(/1)
      nrigel=0
      do 100 i=1,nbsou
        imodel=kmodel(i)
 
        nfor=imodel.formod(/2)
        call place(imodel.formod,nfor,iplac,'CHANGEMENT_PHASE')
        if  (iplac .eq. 0) goto 100
 
C       RAPPEL : RESO suppose un seul 'LX' par rigidite et il doit etre en premier
        IF    (imodel.matmod(1)(1:10) .EQ. 'PARFAIT   ')THEN
C         1 seule RIGIDITE suffit
          nrigel = nrigel + 1
        ELSEIF(imodel.matmod(1)(1:10) .EQ. 'SOLUBILITE')THEN
C         2 RIGIDITES pour les besoins de RESO
          nrigel = nrigel + 2
        ELSE
          CALL ERREUR(5)
        ENDIF
  100 continue
 
      segini,mrigid
      mtymat='BLO_PHAS'
      iforig = ifour
 
*     Boucle sur les sous zones du model pour creer les matrices de blocages
      nrigel = 0
      do 1 i=1,nbsou
        imodel=kmodel(i)
 
        nfor=imodel.formod(/2)
        call place(imodel.formod,nfor,iplac,'CHANGEMENT_PHASE')
        if  (iplac .eq. 0) goto 1
 
        IF    (imodel.matmod(1)(1:10) .EQ. 'PARFAIT   ')THEN
          ICAS = 1
          IF(tymode(2) .NE. 'MAILLAGE')THEN
            CALL ERREUR(5)
          ENDIF
          ipt2 = ivamod(2)
 
        ELSEIF(imodel.matmod(1)(1:10) .EQ. 'SOLUBILITE')THEN
          ICAS = 2
          DO ii=1,imodel.tymode(/2) - 1
            IF(imodel.tymode(ii+1) .NE. 'MAILLAGE')THEN
              CALL ERREUR(5)
            ENDIF
          ENDDO
          ipt2 = ivamod(2)
          ipt3 = ivamod(3)
 
        ELSE
          CALL ERREUR(5)
        ENDIF
 
C       Remplissage des objets rigidite
        IF    (ICAS .EQ. 1)THEN
          nrigel      = nrigel + 1
          nelrig      = ipt2.num(/2)
          nligrp      = 2
          nligrd      = 2
          rigrel      = 0
          segini,descr,xmatri
 
          coerig(nrigel)  = 1.D0
          irigel(1,nrigel)= ipt2
          irigel(3,nrigel)= descr
          irigel(4,nrigel)= xmatri
          irigel(5,nrigel)= nifour
          irigel(6,nrigel)= 2
          isym            = 0
          irigel(7,nrigel)= isym
          xmatri.SYMRE    = isym
 
          NOMID=lnomid(1)
          lisinc(1)='LX'
          lisinc(2)= nomid.lesobl(1)
 
          NOMID=lnomid(2)
          lisdua(1)='FLX'
          lisdua(2)= nomid.lesobl(1)
 
          noelep(1)=1
          noelep(2)=2
          noeled(1)=1
          noeled(2)=2
 
          do iou=1,nelrig
            re(1,1,iou)= 0.D0
            re(2,1,iou)= 1.D0
 
            re(1,2,iou)= 1.D0
            re(2,2,iou)= 0.D0
          enddo
          segdes,descr,xmatri
 
        ELSEIF(ICAS .EQ. 2)THEN
C         RIGIDITE n° 1
C         -------------
          nrigel      = nrigel + 1
          nelrig      = ipt2.num(/2)
          nligrp      = 3
          nligrd      = 3
          rigrel      = 0
          segini,descr,xmatri
          coerig(nrigel)  = 1.D0
          irigel(1,nrigel)= ipt2
          irigel(3,nrigel)= descr
          irigel(4,nrigel)= xmatri
          irigel(5,nrigel)= nifour
          irigel(6,nrigel)= 1
          isym            = 2
          irigel(7,nrigel)= isym
          xmatri.SYMRE    = isym
 
          NOMID    = lnomid(1)
          lisinc(1)='LX'
          lisinc(2)= nomid.lesobl(1)
          lisinc(3)= nomid.lesobl(2)
 
          NOMID    = lnomid(2)
          lisdua(1)='FLX'
          lisdua(2)= nomid.lesobl(1)
          lisdua(3)= nomid.lesobl(2)
 
          DO iel=1,nligrp
            noelep(iel)=iel
            noeled(iel)=iel
          ENDDO
 
          do iou=1,nelrig
            re(1,1,iou)= 0.D0
            re(2,1,iou)= 1.D0
            re(3,1,iou)=-1.D0
 
            re(1,2,iou)= 1.D0
            re(2,2,iou)= 0.D0
            re(3,2,iou)= 0.D0
 
            re(1,3,iou)= 0.D0
            re(2,3,iou)= 0.D0
            re(3,3,iou)= 0.D0
          enddo
          segdes,descr,xmatri
 
C         RIGIDITE n° 2
C         -------------
          nrigel     = nrigel + 1
          nelrig2    = ipt3.num(/2)
          IF(nelrig2 .NE. nelrig)THEN
            CALL ERREUR(5)
          ENDIF
          nelrig     = nelrig2
          nligrp     = 3
          nligrd     = 3
          rigrel     = 0
          segini,descr,xmatri
 
          coerig(nrigel)  = 1.D0
          irigel(1,nrigel)= ipt3
          irigel(3,nrigel)= descr
          irigel(4,nrigel)= xmatri
          irigel(5,nrigel)= nifour
          irigel(6,nrigel)=-1
          isym            = 2
          irigel(7,nrigel)= isym
          xmatri.SYMRE    = isym
 
          NOMID    = lnomid(1)
          lisinc(1)='LX'
          lisinc(2)= nomid.lesobl(1)
          lisinc(3)= nomid.lesobl(2)
 
          NOMID    = lnomid(2)
          lisdua(1)='FLX'
          lisdua(2)= nomid.lesobl(1)
          lisdua(3)= nomid.lesobl(2)
 
          DO iel=1,nligrp
            noelep(iel)=iel
            noeled(iel)=iel
          ENDDO
 
          do iou=1,nelrig
            re(1,1,iou)= 0.D0
            re(2,1,iou)=-1.D0
            re(3,1,iou)= 1.D0
 
            re(1,2,iou)= 0.D0
            re(2,2,iou)= 0.D0
            re(3,2,iou)= 0.D0
 
            re(1,3,iou)= 1.D0
            re(2,3,iou)= 0.D0
            re(3,3,iou)= 0.D0
          enddo
          segdes,descr,xmatri
 
        ELSE
          CALL ERREUR(5)
        ENDIF
   1  continue
      segdes,mrigid
 
      call ECROBJ('RIGIDITE',mrigid)
 
      end