Télécharger bsigma.eso

Retour à la liste

bsigma
C BSIGMA    SOURCE    CB215821  24/04/12    21:15:08     11897          
 
      SUBROUTINE BSIGMA
 
C_______________________________________________________________________
C
C    OPERATEUR FORCES INTERNES
C
C      FOR1 = BSIGMA  MODL1 SIG1 ( CAR1 ) (HOO1) ;
C
C      MODL1  objet de type MMODEL
C      SIG1   MCHAML de contraintes
C      CAR1   MCHAML de caract{ristiques (facultatif)
C      HOO1   MCHAML  DE MATERIAU OU DE HOOKE (FACULTATIF)
C      FOR1   CHPOINT donnant les foces nodales
C_______________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMCHAML
-INC SMMODEL
-INC SMCOORD
 
      character*4  mcle(1)
      data  mcle/'NOER'/
 
      segact mcoord
      IPCHE1 = 0
      IPCHE2 = 0
      IPCHE3 = 0
      IPCHP4 = 0
 
      IPCHA2 = 0
      IPCHA3 = 0
      noer=0
      call lirmot(mcle,1,noer,0)
 
      CALL LIROBJ('MMODEL  ',IPMODL,1,irt1)
      IF (IERR.NE.0) RETURN
      CALL ACTOBJ('MMODEL  ',IPMODL,1)
C
C     S'AGIT-IL D'UN MODELE CHARGEMENT PRESSION
C
      MMODEL = IPMODL
      IMODEL = KMODEL(1)
      IF (FORMOD(1).EQ.'CHARGEMENT') GOTO 10
C_______________________________________________________________________
C
C     CAS GENERAL
C_______________________________________________________________________
C
C- 1 ER  CHAMP/ELEMENT
C
      CALL LIROBJ('MCHAML  ',IPIN,1,irt1)
      IF (IERR.NE.0) RETURN
      CALL ACTOBJ('MCHAML  ',IPIN,1)
      CALL REDUAF(IPIN,IPMODL,IPCHE1,0,IR,KER)
      IF(IR   .NE. 1) CALL ERREUR(KER)
      IF(IERR .NE. 0) RETURN
 
* Test sur le type du mchelm = CONTRAINTES
C* On peut pas faire ce test a l'heure actuelle car les champs issus de
C* COMP n'ont pas ce type...
C*      mchelm = IPCHE1
C*      SEGACT,mchelm
C*      IF (mchelm.titche.NE.'CONTRAINTES') THEN
C*        MOTERR(1:16) = 'CONTRAINTES     '
C*        CALL ERREUR(291)
C*        RETURN
C*      ENDIF
 
C- 2 EME CHAMP/ELEMENT (FACULTATIF)
C
      CALL LIROBJ('MCHAML  ',IPIN,0,irt1)
      IF (IERR.NE.0) RETURN
      IPCHA2=0
      IF (irt1 .EQ. 1) THEN
        CALL ACTOBJ('MCHAML  ',IPIN,1)
        CALL REDUAF(IPIN,IPMODL,IPCHA2,0,IR,KER)
        IF(IR   .NE. 1) CALL ERREUR(KER)
        IF(IERR .NE. 0) RETURN
      ENDIF
 
C- 3 EME CHAMP/ELEMENT (FACULTATIF)
C
      CALL LIROBJ('MCHAML',IPIN,0,irt1)
      IF (IERR.NE.0) RETURN
      IPCHA3=0
      IF (irt1 .EQ. 1) THEN
        CALL ACTOBJ('MCHAML  ',IPIN,1)
        CALL REDUAF(IPIN,IPMODL,IPCHA3,0,IR,KER)
        IF(IR   .NE. 1) CALL ERREUR(KER)
        IF(IERR .NE. 0) RETURN
      ENDIF
C
        IMAT   = 0
        IPCHE2 = 0
        IPCHE3 = 0
      IF (IPCHA2.NE.0 .OR. IPCHA3.NE.0) THEN
        mchelm = ipcha2 
        if (titche(1:16).eq.'CARACTERISTIQUES'.or.
     &     titche(1:16).eq.'MATRICE DE HOOKE') then
        CALL RNGCHA(IPCHA2,             IPCHA3,
     &              'CARACTERISTIQUES', 'MATRICE DE HOOKE',
     &              IPCHE2,             IPCHE3)
        IF(IERR.NE.0) RETURN
        else
          ipche2 = ipcha2
        endif
 
        IF (IPCHE3.EQ.0) THEN
          IMAT = 1
        ELSE
          IMAT = 2
        ENDIF
      ELSE
        IMAT   = 0
        IPCHE2 = 0
        IPCHE3 = 0
      ENDIF
      IRET = 0
 
 
      CALL BSIGMP(IPMODL,IPCHE1,IPCHE2,IPCHE3,IMAT,
     &            IPCHP4,IRET,NOER)
      if (noer.eq.195) goto 30
C
      IF (IERR.NE.0 .OR. IRET.NE.1) RETURN
      GOTO 20
C_______________________________________________________________________
C
C     CAS DES MODELES CHARGEMENT PRESSION
C_______________________________________________________________________
C
  10  CONTINUE
C
C-    1 ER   CHAMP/ELEMENT
C
      CALL LIROBJ('MCHAML  ',IPIN,1,irt1)
      IF(IERR .NE. 0) RETURN
      CALL ACTOBJ('MCHAML  ',IPIN,1)
      CALL REDUAF(IPIN,IPMODL,IPCHA1,0,IR,KER)
      IF(IR   .NE. 1) CALL ERREUR(KER)
      IF(IERR .NE. 0) RETURN
C
C-    2 EME  CHAMP/ELEMENT (FACULTATIF)
C
      CALL LIROBJ('MCHAML  ',IPIN,0,irt1)
      IF (IERR.NE.0) RETURN
      IPCHA2=0
      IF (irt1 .EQ. 1) THEN        
        CALL ACTOBJ('MCHAML  ',IPIN,1)
        CALL REDUAF(IPIN,IPMODL,IPCHA2,0,IR,KER)
        IF(IR   .NE. 1) CALL ERREUR(KER)
        IF(IERR .NE. 0) RETURN
      ENDIF
C
C     ON TRIE LES MCHAML
C
      IF (IPCHA2.EQ.0) THEN
        MCHELM=IPCHA1
        IF (MCHELM.TITCHE.EQ.'CARACTERISTIQUES') THEN
          IPCHE2=IPCHA1
          IPCHE1=0
        ELSE IF (MCHELM.TITCHE.EQ.'CONTRAINTES') THEN
          IPCHE2=0
          IPCHE1=IPCHA1
        ELSE
          MOTERR(1:24)='CARACTERISTIQUES'
          MOTERR(25:48)='CONTRAINTES'
          CALL ERREUR(109)
          RETURN
        ENDIF
      ELSE
        CALL RNGCHA(IPCHA1,IPCHA2,'CONTRAINTES', 'CARACTERISTIQUES',
     &              IPCHE1,IPCHE2)
        IF (IPCHE1.EQ.0) THEN
          MOTERR(1:32)='CONTRAINTES'
          CALL ERREUR(565)
          RETURN
        ENDIF
        IF (IPCHE2.EQ.0) THEN
          MOTERR(1:32)='CARACTERISTIQUES'
          CALL ERREUR(565)
          RETURN
        ENDIF
      ENDIF
C
      CALL FEQPR(IPMODL,IPCHE1,IPCHE2,IPCHP4,IRET)
      IF (IERR.NE.0 .OR. IRET.NE.1) RETURN
C_______________________________________________________________________
C
  20  CONTINUE
      MCHPOI = IPCHP4
C
      CALL ACTOBJ('CHPOINT ',IPCHP4,1)
      CALL ECROBJ('CHPOINT ',IPCHP4)
C
      RETURN
 
  30  continue
*  erreur changement de signe du jacobien si optio noer on rend un entier
      call ecrent(noer)
      call soucis(noer)
 
      END
 
 
 
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales