C SSTE1     SOURCE    CHAT      11/03/16    21:31:47     6902           

*************************************************************************
*************************************************************************
*************************************************************************
      SUBROUTINE SSTE1 (IPMODL,IPCHE1,IPCHE2,IPCHE4,IPCAR,
     .                    PRECIS,NITMAX,NMAXSSTEPS,NNUMER,DELTAX,
     .                    IPCHE7,IPCHE8,IPCHE9,IPRIGI)
*  entrees:
*  ipmodl = pointeur sur un objet mmodel
*  ipche1 = pointeur sur un mchaml de contraintes initiales
*  ipche2 = pointeur sur un mchaml de variables internes initiales
*  ipche4 = pointeur sur un mchaml d'increment elastique de deformations
*  ipcar  = pointeur sur un mchaml de caracteristiques
*  precis = precision des iterations internes
* sorties:
*  ipche7 = pointeur sur un mchaml de contraintes
*  ipche8 = pointeur sur un mchaml de variables internes
*  ipche9 = pointeur sur un mchaml de deformations
*  iprigi = pointeur sur l'objet de type rigidite
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*
-INC CCOPTIO   
-INC CCGEOME   
-INC SMCHAML   
-INC SMELEME   
-INC SMINTE    
-INC SMMODEL   
-INC SMRIGID   
      SEGMENT NOTYPE
         CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
      SEGMENT MPTVAL
         INTEGER      IPOS(NS)    
         INTEGER      NSOF(NS)
         INTEGER      IVAL(NCOSOU)
         CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT

      CHARACTER*8 CMATE
      CHARACTER*(NCONCH) CONM
      PARAMETER (NINF=3)
      INTEGER INFOS(NINF)
      LOGICAL lsupde,lsupfo,lsupva,lsupdp,lsupco,lsupma

      CALL  QUESUP(IPMODL,IPCHE1,5,0,ISUP1,IRET1)
      IF (ISUP1.GT.1) RETURN
      CALL  QUESUP(IPMODL,IPCHE2,5,0,ISUP2,IRET2)
      IF (ISUP2.GT.1) RETURN
      CALL  QUESUP(IPMODL,IPCHE4,5,0,ISUP4,IRET4)
      IF (ISUP4.GT.1) RETURN
      CALL  QUESUP(IPMODL,IPCAR,3,0,ISUP5,IRET5)
      IF (ISUP5.GT.1) RETURN
c
c Activar el modelo
c
      MMODEL=IPMODL
      SEGACT MMODEL    
      NSOUS=MMODEL.KMODEL(/1)
c
c Creation de los 3 mchelms de salida
c
      N1=NSOUS
      L1=11
      N3=6
      SEGINI MCHELM    
      MCHELM.TITCHE='CONTRAINTES'
      MCHELM.IFOCHE=IFOUR
      IPCHE7=MCHELM
      L1=18
      SEGINI MCHEL1    
      MCHEL1.TITCHE='VARIABLES INTERNES'
      MCHEL1.IFOCHE=IFOUR
      IPCHE8=MCHEL1
      L1=12            
      SEGINI MCHEL2
      MCHEL2.TITCHE='DEFORMATIONS'
      MCHEL2.IFOCHE=IFOUR
      IPCHE9=MCHEL2
c
c Creacion del objeto rigidite
c
      NRIGE =7
      NRIGEL=NSOUS
      SEGINI MRIGID   
      MRIGID.MTYMAT = 'RIGIDITE'
      MRIGID.ICHOLE=0
      MRIGID.IMGEO1=0
      MRIGID.IMGEO2=0
      MRIGID.IFORIG=IFOUR
      DO ISOUS=1,NSOUS
         MRIGID.COERIG(ISOUS)=1.D0
         MRIGID.IRIGEL(4,ISOUS)=0
      ENDDO
      IPRIGI=MRIGID
c
c     bucle sobre zonas
c
      DO 1000 ISOUS=1,NSOUS
         NSTR=0
         MOSTRS=0
         IVASTR=0
         MOVARI=0
         NVARI=0
         NVARF=0
         IVARI=0
         MOEPSI=0
         NDEF=0
         IVADEF=0
         IVADS=0
         NCARA=0
         NCARF=0
         MOCARA=0
         IVACAR=0
         NMATF=0
         NMATR=0
         MOMATR=0
         IVAMAT=0
         IVASTF=0
         IVARIF=0
         IVADEP=0
         KERRE=0
         KERR1=0
         MCHAML=0
         MCHAM1=0
         MCHAM2=0
c Recuperar la informacion general de la zona
c Activa el modelo de la zona
      IMODEL=KMODEL(ISOUS)
      SEGACT IMODEL  
      MELE  =IMODEL.NEFMOD
      MELEME=IMODEL.IMAMOD 
      CONM  =IMODEL.CONMOD 
c Activa la malla
      SEGACT MELEME  
      NBNN  =MELEME.NUM(/1)
      NBELEM=MELEME.NUM(/2)
c Tipo de material
      NFOR  =IMODEL.FORMOD(/2) 
      NMAT  =IMODEL.MATMOD(/2) 
      CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INPLAS)
ccc
c Controlar que sea uno de los materiales de trabajo
      IF ((INPLAS.lt.111).or.(INPLAS.gt.113)) then 
         write(*,*) ' Material no disponible'
      ENDIF
ccc
*  informacion de elementos finitos
*  activa un segmento q se llama luego INFO, q tiene INFELE
*      CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
*      INFO =IPINF
*      MELE =INFO.INFELE(1)  
*      NBGS =INFO.INFELE(4)  
*      NBG  =INFO.INFELE(6)  
*      IPORE=INFO.INFELE(8)  
*      LRE  =INFO.INFELE(9)  
*      LHOOK=INFO.INFELE(10) 
*      MINTE=INFO.INFELE(11)
*      MFR  =INFO.INFELE(13) 
*      NDDL =INFO.INFELE(15) 
*      NSTRS=INFO.INFELE(16) 
      MELE =INFELE(1)  
      NBGS =INFELE(4)  
      NBG  =INFELE(6)  
      IPORE=INFELE(8)  
      LRE  =INFELE(9)  
      LHOOK=INFELE(10) 
      MINTE=INFMOD(7) 
      MFR  =INFELE(13) 
      NDDL =INFELE(15) 
      NSTRS=INFELE(16) 
*  Controla que sean elementos masivos
      IF ((MFR.lt.1).or.(MFR.gt.1)) then 
         write(*,*) ' Tipo de elemento no disponible'
      ENDIF
* Llena informacion en los 3 campos de salida
      MCHELM.IMACHE(ISOUS)=MELEME
      MCHELM.CONCHE(ISOUS)=CONM
      MCHEL1.IMACHE(ISOUS)=MELEME
      MCHEL1.CONCHE(ISOUS)=CONM
      MCHEL2.IMACHE(ISOUS)=MELEME
      MCHEL2.CONCHE(ISOUS)=CONM
      MCHELM.INFCHE(ISOUS,1)=0
      MCHELM.INFCHE(ISOUS,2)=0
      MCHELM.INFCHE(ISOUS,3)=NIFOUR
      MCHELM.INFCHE(ISOUS,4)=MINTE
      MCHELM.INFCHE(ISOUS,5)=0
      MCHELM.INFCHE(ISOUS,6)=5
      MCHEL1.INFCHE(ISOUS,1)=0
      MCHEL1.INFCHE(ISOUS,2)=0
      MCHEL1.INFCHE(ISOUS,3)=NIFOUR
      MCHEL1.INFCHE(ISOUS,4)=MINTE
      MCHEL1.INFCHE(ISOUS,5)=0
      MCHEL1.INFCHE(ISOUS,6)=5
      MCHEL2.INFCHE(ISOUS,1)=0
      MCHEL2.INFCHE(ISOUS,2)=0
      MCHEL2.INFCHE(ISOUS,3)=NIFOUR
      MCHEL2.INFCHE(ISOUS,4)=MINTE
      MCHEL2.INFCHE(ISOUS,5)=0
      MCHEL2.INFCHE(ISOUS,6)=5
* Llena informacion la rigidite
*  Activa segmento MINTE
      NBNO=NBNN
      SEGACT MINTE   
      NBPGAU=MINTE.POIGAU(/1)
*  Inicializa segmento descr, descripcion incognitas matriz rigidite
      NLIGRP=LRE
      NLIGRD=LRE
      SEGINI DESCR   
      IPDESCR=DESCR
      if(lnomid(1).ne.0) then
         nomid=lnomid(1)
         segact nomid
         modepl=nomid
         ndepl=lesobl(/2)
         ndum=lesfac(/2)
         lsupdp=.false.
      else 
         lsupdp=.true.      
         CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,NDUM)
      endif
      if(lnomid(2).ne.0) then
        nomid=lnomid(2)
        segact nomid
        moforc=nomid
        nforc=lesobl(/2)
        lsupfo=.false.
        else
          lsupfo=.true.      
         CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NDUM)
        endif
*  Llena el segmento descr con los nombres de las incognitas 
      IDDL=1
      NCOMP=NDEPL
      NBNNS=NBNN
      NOMID=MODEPL
      SEGACT NOMID
      NOMID=MOFORC
      SEGACT NOMID
      DO INOEUD=1,NBNNS
          DO ICOMP=1,NCOMP
               NOMID=MODEPL
               DESCR.LISINC(IDDL)=LESOBL(ICOMP)
               NOMID=MOFORC
               DESCR.LISDUA(IDDL)=LESOBL(ICOMP)
               NOELEP(IDDL)=INOEUD
               NOELED(IDDL)=INOEUD
               IDDL=IDDL+1
          ENDDO
      ENDDO
      NOMID=MODEPL
      if(lsupdp)SEGsup NOMID
      NOMID=MOFORC
      if(lsupfo)SEGsup NOMID
      SEGDES DESCR
*  Inicializa segmento imatri, chapeau sur les segments
*      contenant les matrices de rigidite elementaires
      NELRIG =NBELEM
      SEGINI xMATRI   
*  Trata la rigidite 
      MRIGID.IRIGEL(1,ISOUS)=MELEME
      MRIGID.IRIGEL(2,ISOUS)=0
      MRIGID.IRIGEL(3,ISOUS)=IPDESCR
      MRIGID.IRIGEL(4,ISOUS)=xMATRI
      MRIGID.IRIGEL(5,ISOUS)=NIFOUR
      MRIGID.IRIGEL(6,ISOUS)=0
c     no simetricas = 2, simetricas = 0
      IRIGE7=2
      MRIGID.IRIGEL(7,ISOUS)=IRIGE7
* tratamiento de los 4 campos dados
      NBNO=NBNNE(NUMGEO(MELE))
      CALL IDENT(MELEME,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
      IF (IRTD.EQ.0)THEN
         write(*,*)' no compatibles'
         SEGDES IMODEL*NOMOD,MMODEL*NOMOD
         SEGSUP MCHELM,MCHEL1,MCHEL2
*         INFO=IPINF
*         SEGSUP INFO
         RETURN
      ENDIF
      NBTYPE =1
      SEGINI NOTYPE  
      NOTYPE.TYPE(1)='REAL*8'

*  contraintes: IVASTR
      if(lnomid(4).ne.0) then
         nomid=lnomid(4)
         segact nomid
         mostrs=nomid
         nstr=lesobl(/2)
         nfac=lesfac(/2)
         lsupco=.false.
      else 
         lsupco=.true.
         CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
      endif
      MOTYPE=NOTYPE
      CALL KOMCHA(IPCHE1,MELEME,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
      IPMINT=MINTE
      IF (ISUP1.EQ.1) THEN
       ippore=0
       CALL VALCHE(IVASTR,NSTR,IPMINT,ippore)
       SEGSUP NOTYPE
       goto 888
      ENDIF
*  variables internes: IVARI
      if(lnomid(10).ne.0) then
         nomid=lnomid(10)
         segact nomid
         movari=nomid
         nvari=lesobl(/2)
         nvarf=lesfac(/2)
         lsupva=.false.
      else
         lsupva=.true.
        CALL IDVARI(MFR,IMODEL,MOVARI,NVARI,NVARF)
      endif
      MOTYVA=NOTYPE
      CALL KOMCHA(IPCHE2,MELEME,CONM,MOVARI,MOTYVA,1,INFOS,3,IVARI)
      NVART=NVARI+NVARF
      IF (ISUP2.EQ.1) THEN
       ippore=0
       CALL VALCHE(IVARI,NVART,IPMINT,ippore)
       SEGSUP NOTYPE
       goto 888
      ENDIF
*  increments de deformations: IVADS
      if(lnomid(5).ne.0) then
        nomid=lnomid(5)
        segact nomid
        ndef=lesobl(/2)
        nfac=lesfac(/2)
        moepsi=nomid
        lsupde=.false.
      else 
        lsupde=.true.
        CALL IDDEFO(IMODEL,IFOUR,MOEPSI,NDEF,NFAC)
      endif
      CALL KOMCHA(IPCHE4,MELEME,CONM,MOEPSI,MOTYPE,1,INFOS,3,IVADS)
      IF (ISUP4.EQ.1) THEN
       ippore=0
       CALL VALCHE(IVADS,NDEF,IPMINT,ippore)
       SEGSUP NOTYPE
       goto 888
      ENDIF
*  caracteristiques materielles: IVAMAT
      if(lnomid(6).ne.0) then
         nomid=lnomid(6)
         segact nomid
         momatr=nomid
         nmatr=lesobl(/2)
         nmatf=lesfac(/2)
         lsupma=.false.
      else 
         lsupma=.true.
         CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF)
      endif
      CALL KOMCHA(IPCAR,MELEME,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
      SEGSUP NOTYPE
      NMATT=NMATR+NMATF
      IF (ISUP5.EQ.1) THEN
       ippore=0
       CALL VALCHE(IVAMAT,NMATT,IPMINT,ippore)
       goto 888
      ENDIF
* Creacion de los mchamls de las zonas
      NBPTEL=NBGS
      NEL   =NBELEM
      N1PTEL=NBPTEL
      N1EL  =NEL
*  contraintes
      N2    =NSTRS
      SEGINI MCHAML  
      MCHELM.ICHAML(ISOUS)=MCHAML
      mchelm.conche(isous) = conmod
      NS    =1
      NCOSOU=NSTRS
      SEGINI MPTVAL  
      IVASTF=MPTVAL
      NOMID =MOSTRS
      SEGACT NOMID   
      DO ICOMP=1,NSTRS
         MCHAML.NOMCHE(ICOMP)=NOMID.LESOBL(ICOMP)
         MCHAML.TYPCHE(ICOMP)='REAL*8'
         N2PTEL=0
         N2EL=0
         SEGINI MELVAL  
         MCHAML.IELVAL(ICOMP)=MELVAL
         IVAL(ICOMP)=MELVAL
      enddo
      SEGDES NOMID
*  variables internes
      N2    =NVART
      SEGINI MCHAM1
      MCHEL1.ICHAML(ISOUS)=MCHAM1
      mchel1.conche(isous) = conmod
      NS    =1
      NCOSOU=NVART
      SEGINI MPTVAL
      IVARIF=MPTVAL
      NOMID=MOVARI
      SEGACT NOMID
      DO ICOMP=1,NVARI
         MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
         MCHAM1.TYPCHE(ICOMP)='REAL*8'
         N2PTEL=0
         N2EL=0
         SEGINI MELVAL
         MCHAM1.IELVAL(ICOMP)=MELVAL
         IVAL(ICOMP)=MELVAL
      enddo
      DO ICOMP=NVARI+1,NVART
         MCHAM1.NOMCHE(ICOMP)=LESFAC(ICOMP)
         MCHAM1.TYPCHE(ICOMP)='REAL*8'
         N2PTEL=0
         N2EL=0
         SEGINI MELVAL
         MCHAM1.IELVAL(ICOMP)=MELVAL
         IVAL(ICOMP)=MELVAL
      enddo
      SEGDES NOMID
      N1PTEL=NBPTEL
      N1EL=NEL
      N2=NDEF
      SEGINI MCHAM2
      MCHEL2.ICHAML(ISOUS)=MCHAM2
      mchel2.conche(isous) = conmod
      NS=1
      NCOSOU=NDEF
      SEGINI MPTVAL
      IVADEP=MPTVAL
      NOMID=MOEPSI
      SEGACT NOMID
      DO ICOMP=1,NDEF
         MCHAM2.NOMCHE(ICOMP)=LESOBL(ICOMP)
         MCHAM2.TYPCHE(ICOMP)='REAL*8'
         N2PTEL=0
         N2EL=0
         SEGINI MELVAL
         MCHAM2.IELVAL(ICOMP)=MELVAL
         IVAL(ICOMP)=MELVAL
      enddo
      SEGDES NOMID
      CALL SSTE2(MATE,INPLAS,MELE,MELEME,MINTE,xMATRI,
     .     NBELEM,NBPTEL,NBNN,LRE,MFR,
     .     IVASTR,IVARI,IVADS,IVAMAT,NSTRS,NVARI,NMATT,
     .     IVASTF,IVARIF,IVADEP,LHOOK,IRIGE7,
     .     PRECIS,NITMAX,NMAXSSTEPS,NNUMER,DELTAX,KERRE)

* Desactivar segmentos
         SEGDES MELEME,IMODEL,descr,xmatri

         IF(ISUP1.EQ.1)THEN
            CALL DTMVAL (IVASTR,3)
         ELSE
            CALL DTMVAL (IVASTR,1)
         ENDIF
         IF(ISUP2.EQ.1)THEN
            CALL DTMVAL (IVARI,3)
         ELSE
            CALL DTMVAL (IVARI,1)
         ENDIF
         IF(ISUP4.EQ.1)THEN
            CALL DTMVAL (IVADS,3)
         ELSE
            CALL DTMVAL (IVADS,1)
         ENDIF
         IF(ISUP5.EQ.1)THEN
            CALL DTMVAL (IVAMAT,3)
         ELSE
            CALL DTMVAL (IVAMAT,1)
         ENDIF
         IF (KERRE.EQ.0) THEN
            CALL DTMVAL (IVASTF,1)
            CALL DTMVAL (IVARIF,1)
            CALL DTMVAL (IVADEP,1)
            SEGDES MCHAML,MCHAM1,MCHAM2,MINTE
         ELSE
            CALL DTMVAL (IVASTF,3)
            CALL DTMVAL (IVARIF,3)
            CALL DTMVAL (IVADEP,3)
            SEGSUP MCHAML,MCHAM1,MCHAM2,MINTE
            GO TO 888
         END IF
         IF (MOSTRS.NE.0) THEN
            NOMID=MOSTRS
            if(lsupco)SEGSUP NOMID
         END IF
         IF (lsupva.and.MOVARI.NE.0) THEN
            NOMID=MOVARI
            SEGSUP NOMID
         END IF
         IF (lsupde.and.MOEPSI.NE.0) THEN
            NOMID=MOEPSI
            SEGSUP NOMID
         END IF
         IF (MOMATR.NE.0) THEN
            NOMID=MOMATR
            if(lsupma)SEGSUP NOMID
         END IF
*         IF (IPINF .NE.0) THEN
*            INFO=IPINF
*            SEGSUP INFO
*         END IF
1000  continue
 888  CONTINUE
      SEGDES MMODEL*NOMOD
      IF(KERRE.EQ.0)THEN
         SEGDES MCHELM,MCHEL1,MCHEL2,MRIGID,xMATRI,DESCR
      ELSE
         SEGSUP MCHELM,MCHEL1,MCHEL2,MRIGID,xMATRI,DESCR
      ENDIF
      RETURN
      END