C BSIGMA    SOURCE    OF166741  24/05/06    21:15:02     11082          

      SUBROUTINE BSIGMA

C_______________________________________________________________________
C
C    OPERATEUR FORCES INTERNES
C
C      FOR1 = BSIGMA  MODL1 SIG1 ( CAR1 ) ( HOO1 ) ( DEP1 ) ;
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      DEP1   CHPOINT de deplacements (facultatif / obligatoire si HHO)
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

      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
      IPCHE1 = 0
      IPCHE2 = 0
      IPCHE3 = 0
      IPCHP4 = 0

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*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
      IPCHA2 = 0
      CALL LIROBJ('MCHAML  ',IPIN,0,irt1)
      IF (IERR.NE.0) RETURN
      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
      IPCHA3 = 0
      CALL LIROBJ('MCHAML',IPIN,0,irt1)
      IF (IERR.NE.0) RETURN
      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- 4 EME CHAMP/POINT (FACULTATIF mais obligatoire si modele HHO)
C
      CALL LIROBJ('CHPOINT',IPCHP4,0,irt1)
      IF (IERR.NE.0) RETURN

C- Un peu de rangement des champs :
C- Si IPCHA2 = 0, normalement IPCHA3 = 0 aussi !
      IF (IPCHA2.NE.0) THEN
C- Il y a des cas (par ex. modele MELANGE) ou IPCHA2 n'a pas un des 
C- types recherches. d'ou le traitement ici :
        mchelm = IPCHA2
        if (mchelm.titche(1:16).eq.'CARACTERISTIQUES' .or.
     &      mchelm.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
      ENDIF

      IF (IPCHE2.NE.0) THEN
        IF (IPCHE3.EQ.0) THEN
          IMAT = 1
        ELSE
          IMAT = 2
        ENDIF
      ELSE
        IMAT   = 0
      ENDIF

      IRET = 0

      CALL BSIGMP(IPMODL,IPCHE1,IPCHE2,IPCHE3,IMAT,
     &            IPCHP4,IRET,NOER)

      if (noer.eq.195) goto 30
      IF (IERR.NE.0 .OR. IRET.NE.1) RETURN
      GOTO 20

C_______________________________________________________________________
C
C     CAS DES MODELES CHARGEMENT PRESSION
C_______________________________________________________________________
C
  10  CONTINUE
      IPCHE1 = 0
      IPCHE2 = 0
C
C-    1 ER   CHAMP/ELEMENT
C
      IPCHA1 = 0
      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
      IPCHA2 = 0
      CALL LIROBJ('MCHAML  ',IPIN,0,irt1)
      IF (IERR.NE.0) RETURN
      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
      CALL RNGCHA(IPCHA1,IPCHA2,'CONTRAINTES', 'CARACTERISTIQUES',
     &            IPCHE1,IPCHE2)
      IF (IERR.NE.0) RETURN
C IPCHE1 ou IPCHE2 est a minima fourni.

      CALL FEQPR(IPMODL,IPCHE1,IPCHE2,IPCHP4,IRET)
      IF (IERR.NE.0 .OR. IRET.NE.1) RETURN
C      GOTO 20
C_______________________________________________________________________
C
  20  CONTINUE

      CALL ACTOBJ('CHPOINT ',IPCHP4,1)
      CALL ECROBJ('CHPOINT ',IPCHP4)

c* C- ATTRIBUTION D'UNE NATURE DISCRETE AU CHPO QUI SORT
c*      MCHPOI = IPCHP4
c*      JATTRI(1) = 2

      RETURN

  30  continue
*  erreur changement de signe du jacobien si optio noer on rend un entier
      call ecrent(noer)
      call soucis(noer)

c      return
      END