C RIGIA     SOURCE    CHAT      11/03/16    21:31:15     6902           
      SUBROUTINE RIGIA(IMD,IPCHE1,IPCHE2,
     & IMAT,IPOI6,IPM,IPNS,IRET)
C=======================================================================C
C                                                                       C
C     OPERATEUR DE RIGIDITE POUR LES STRUCTURES EN BETON PRECONTRAINTES C
C                                                                       C
C     ENTREES :                                                         C
C                                                                       C
C        IPM(*)    Pointeurs sur les modeles                            C
C        IPCHE1    Pointeur sur le chamelem de carateristiques          C
C        IPCHE2    Pointeur sur le chamelem de matrice de HOOKE         C
C        IMAT     (2 il y a une matrice de HOOKE,1 non  )               C
C        IMD      Nombre de modeles dans IPM                            C
C                                                                       C
C     SORTIES :                                                         C
C                                                                       C
C        IPOI6    pointeur sur la rigidite construite                   C
C        IRET     (1 OK , 0 erreur  )                                   C
C                                                                       C
C=======================================================================C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
-INC CCOPTIO
-INC CCHAMP
-INC CCREEL
*- 
-INC SMCHAML
-INC SMINTE
-INC SMELEME
-INC SMRIGID
-INC SMMODEL
-INC SMCOORD
-INC SMLREEL
      DIMENSION IPDD(200),IPM(*)
C
      SEGMENT IPNN
        INTEGER IPNNUM(NSOU1)
      ENDSEGMENT
C
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
C
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
C
      SEGMENT NNUM
        INTEGER NNM(NBN,NBELE),NBEM(2,NBELE)
      ENDSEGMENT
      POINTEUR INN1.NNUM
C
      SEGMENT ICCOUN
        INTEGER INCOR(NBELEM)
      ENDSEGMENT
C
      segment icozon
      integer iztouc(nsous)
      endsegment
C
      SEGMENT WRK4
       REAL*8 XEC(3,NBN)
      ENDSEGMENT
C
      CHARACTER*4 CMOT
      CHARACTER*8 CMATE
      CHARACTER*(NCONCH) CONM
      PARAMETER ( INTTYP=3 )
C                 INTTYP DEFINIT LE TYPE DE POINTS D'INTEGRATION
C                                UTILISE PAR RIGI
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      LOGICAL lsupfo,lsupdp,lsupma
C
      IPNN=IPNS
      SEGACT IPNN
C
      MELVAL=0
      IRET = 0
      IPOI6 = 0
      IPMODB=IPM(1)
      DO 99999 IMMD=2,IMD
      IPMODC=IPM(IMMD)
C
C --- VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
C     ZZZZZZZZ  PEUT ETRE A FAIRE PLUTOT SUR LES SOUS-ZONES
C
      IF(IPCHE1.NE.0)THEN
       CALL QUESUP(IPMODC,IPCHE1,INTTYP,0,ISUP,IRETCA)
         IF (ISUP.GT.1) RETURN
      ENDIF
C
C --- VERIFICATION DU LIEU SUPPORT DU MCHAML DE HOOKE
C
      IF(IMAT.EQ.2.AND.IPCHE2.NE.0)THEN
        CALL QUESUP(IPMODC,IPCHE2,INTTYP,1,ISUP1,IRETHO)
        IF (ISUP1.NE.0) RETURN
      ENDIF
C
C --- ACTIVATION DU MODELE CABLE
C
      MMODEL = IPMODC
      SEGACT MMODEL
      NSOU1 = KMODEL(/1)
C
      DO 40 ISOU1=1,NSOU1
      IF(IMD.EQ.1) GOTO 45
      IF(ISOU1.GT.1) THEN
        MMODEL = IPM(IM-1)
        SEGACT MMODEL
      END IF
      IMODEL=KMODEL(ISOU1)
      SEGACT IMODEL
C
C --- INITIALISATIONS
C
      MELE  = NEFMOD
      MELEM=MELE
      IPMAIL= IMAMOD
      CONM  = CONMOD
      NFOR  = FORMOD(/2)
      NMAT  = MATMOD(/2)
      IVAMAC=0
******      IVACAR=0
      NMATR=0
      NMATF=0
      NCARA=0
      NCARF=0
      MOCARA=0
      MOMATR=0
      DESCR=0
      IMATRI=0
C
C --- VERIFICATION SUR LA FORMULATION
C
      CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
      IF(CMATE.EQ.' ')THEN
C       MESSERR = TENTATIVE D'UTILISATION D'1 OPTION NON IMPLANTE
        CALL ERREUR(251)
        SEGDES IMODEL,MMODEL
        SEGSUP MRIGID
        RETURN
      ENDIF
C
*      CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
*        IF ( IERR.NE.0 ) THEN
*          SEGDES IMODEL,MMODEL
*          SEGSUP MRIGID
*          RETURN
*        ENDIF
C
*         INFO  = IPINF
         LHOOK = INFELE(10)
         LHOO2 = LHOOK*LHOOK
         NSTRS = INFELE(16)
         MFR   = INFELE(13)
         LW    = INFELE(7)
         NDDL  = INFELE(15)
         IELE  = INFELE( 14)
         LRE   = INFELE(9)
         IPORE = INFELE(8)
C
        NBG  =INFELE(6)
*        IPMITC=INFELE(11)
         ipmitc=infmod(5)
*        IPMINT=INFELE(11)
         ipmint=infmod(5)
        MINTE=INFELE(11)
        SEGACT MINTE
        MELEME=IPMAIL
        SEGACT MELEME
        NBNN = NUM(/1)
        IPPORE=0
        IF(MFR.EQ.33) IPPORE=NBNN

        NNUMS=IPNNUM(ISOU1)
C        write(6,*) 'IPNN  NNUM' , ipnn,nnums
C
C ---   TRAITEMENT DES CHAMPS EN ENTREE
C
C ---   CREATION DU TABLEAU INFOS
C
        CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD)
        IF (IRTD.EQ.0) GOTO 19990

          IPCHOO=0
C
C ----    CHAMP DE MATERIAU
C
          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
C           write(6,*) 'MOMATR', (MOMATR(K),K=1,MOMATR(/1))
CC-----------------------------------------
            NBTYPE=1
            SEGINI NOTYPE
            TYPE(1)='REAL*8'
            MOTYPE=NOTYPE
C-------------------------------
C         write(6,*) ' constituant sous zone' ,CONM
C          write(6,*) ' composantes obl'
C          write(6,*) (LESOBL(I),I=1,LESOBL(/1))
C          write(6,*) ' composantes fac'
C          write(6,*) (LESFAC(I),I=1,LESFAC(/1))
C
          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAC)

C-------------------------------
C         write(6,*) 'cmate  ivamac ' , cmate, ivamac
C          write(6,*) ' nmatr nmatf ' ,nmatr,nmatf

C          mptval=ivamac
C            nmax = ival(/1)
C      do 9064 im=1,nmax
C          if (ival(im).ne.0) then
C          melval=ival(im)
C          ibmn=velche(/2)
C          igmn=velche(/1)
C          write(6,*) velche(igmn,ibmn)
C          endif
C 9064 continue
C          write(6,*)'***********'

C------------------------------
          SEGSUP NOTYPE
          IF (IERR.NE.0) GOTO 19991
          NMATC=NMATR+NMATF
          IF(ISUP.EQ.1)THEN
            CALL VALCHE(IVAMAC,NMATC,IPMINT,IPPORE)
            IF(IERR.NE.0)THEN
              ISUP=0
              GOTO 19991
            ENDIF
          ENDIF
C
          MPTVAL=IVAMAC
          NBGMAT = 0
          NELMAT = 0
          DO 11108 IM=1,NMATC
           IF(IVAL(IM).NE.0)THEN
            MELVAL=IVAL(IM)
            IF (CMATE.EQ.'SECTION') THEN
              NBGMAT=MAX(NBGMAT,IELCHE(/1))
              NELMAT=MAX(NELMAT,IELCHE(/2))
            ELSE
              NBGMAT=MAX(NBGMAT,VELCHE(/1))
              NELMAT=MAX(NELMAT,VELCHE(/2))
            ENDIF
           ENDIF
11108     CONTINUE
C        ENDIF
C
C ---      CHAMPS DE CARACTERISTIQUES
C
           NBROBL=0
           NBRFAC=0
           MOCARA=0
           IVECT=0
C
C ---      SECTION POUR LES BARRES ET LES CERCES
C
C          IF (MFR.EQ.27) THEN
             NBROBL=1
             nbrfac=1
             SEGINI NOMID
             MOCARA=NOMID
             LESOBL(1)='SECT'
             lesfac(1)='ALPH'
C
             NBTYPE=2
             SEGINI NOTYPE
             MOTYPE=NOTYPE
             TYPE(1)='REAL*8'
             TYPE(2)='REAL*8'
C
C ---      CARACTERISTIQUES POUR LES POUTRES
C

         NCARA=NBROBL
         NCARF=NBRFAC
         NCARR=NCARA+NCARF
C
         IF (IPCHE1.NE.0.AND.MOCARA.NE.0)  THEN
          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR)
          SEGSUP NOTYPE
          IF (IERR.NE.0) GOTO 19991
         ENDIF

         IF(ISUP.EQ.1.AND.(MOCARA.NE.0.AND.IPCHE1.NE.0))THEN
            CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE)
            IF(IERR.NE.0)THEN
              ISUP=0
              GOTO 19991
            ENDIF
        ENDIF
  45  CONTINUE
C
19990 CONTINUE
19991 CONTINUE
C============================================================
C                                                           =
C               ACTIVATION DU MODELE BETON                  =
C                                                           =
C============================================================
      MMODEL = IPMODB
      SEGACT MMODEL
      NSOUS = KMODEL(/1)

       nbsous = 0
C      do 1340 iz=1,nsous
C      nnum = IPNNUM(iz)
C     segact nnum
C      if(NBEM(/2).NE.0)  nbsous=nbsous+1
C1340  continue

      segini icozon
      nnum=nnums
      segact nnum

      do 1340 iel=1,nbem(/2)
      izi = nbem(2,iel)
      if(iztouc(izi).eq.0) then
      iztouc(izi)=1
      nbsous = nbsous+1
      endif
1340  continue

      NSOUS=nbsous
C
C --- INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE
C
      NRIGEL=NSOUS
      IRT6=1
      IRTD=1
      IF(IMMD.EQ.2) THEN
      SEGINI MRIGID
      IPOI6=MRIGID
      ELSE
      MRIGID=IPOI6
      SEGACT MRIGID
      END IF
        MTYMAT = 'RIGIDITE'
        DO 1002 I=1,NSOUS
           COERIG(I)=1.D0
           DO 1003 J=1,6
              IRIGEL(J,I)=0
1003       CONTINUE
1002    CONTINUE
        IFORIG=IFOMOD
        ICHOLE=0
        IMGEO1=0
        IMGEO2=0
        ISUPEQ=0
C-----------------------------------------------------------------
C --- BOUCLE SUR LES ZONES ELEMENTAIRES   BETON
C
C --- ETAT ACTUEL DES SEGMENTS : MRIGID ACTIF  ,  MMODEL ACTIF
C                               IPCHE1 INACTIF,  IPCHE2 INACTIF
C-----------------------------------------------------------------
      ipasou = 0

C
      DO 500 ISOUS=1,KMODEL(/1)

C      if(NBEM(/2).EQ.0)  goto  500
      if(iztouc(isous).eq.0) goto 500
      ipasou = ipasou + 1
      IMODEL=KMODEL(ISOUS)
      SEGACT IMODEL
C
C --- INITIALISATIONS
C
        MELE  = NEFMOD
        IPMAIL= IMAMOD
        CONM  = CONMOD
        NFOR  = FORMOD(/2)
        NMAT  = MATMOD(/2)
        IVAMAT=0
******        IVACAR=0
        NMATR=0
        NMATF=0
        NCARA=0
        NCARF=0
        MOCARA=0
        MOMATR=0
        DESCR=0
        IMATRI=0
C
C --- VERIFICATION SUR LA FORMULATION
C
        CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
        IF (CMATE.EQ.' ')THEN
C          MESSERR = TENTATIVE D'UTILISATION D'1 OPTION NON IMPLANTE
           CALL ERREUR(251)
           SEGDES IMODEL,MMODEL
           SEGSUP MRIGID
           RETURN
        ENDIF
C
Cרררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררר
C                        P H A S E   1
C
C         INFOS. ELEMENT FINI ET COMPOSANTES NECESSAIRES
C    DANS LES CHAMPS EN ENTREE ET EVENTUELLEMENT EN SORTIE
C
C    ON POURRAIT REGROUPER LA PLUS GROSSE PARTIE DE CETTE PHASE DANS
C           UN SOUS-PROGRAMME COMMUN A BEAUCOUP D'OPERATEURS
C
Cרררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררר
C
*         CALL ELQUOI(MELE,0,INTTYP,IPINF,IMODEL)
*         IF ( IERR.NE.0 ) THEN
*           SEGDES IMODEL,MMODEL
*           SEGSUP MRIGID
*           RETURN
*         ENDIF
C
*         INFO  = IPINF
         LHOOK = INFELE(10)
         LHOO2 = LHOOK*LHOOK
         NSTRS = INFELE(16)
         MFR   = INFELE(13)
         LW    = INFELE(7)
         NDDL  = INFELE(15)
         IELE  = INFELE( 14)
         LRE   = INFELE(9)
         IPORE = INFELE(8)
C
C ----   SEGMENTS D'INTEGRATION
C
C        Minte : 1er  segment d'integration, il existe pour tous les e.f.
C        Minte1: 2eme segment d'integration, uniquement pour certains e.f.
C                en particulier pour Coq6 et Coq8
C        nbpg: nb de points de gauss = nbpgau du segment minte
C        iele: no d'element geometrique associe a l'e.f. mele
C        nbff: nb de fonctions de forme = nbno du segment minte
C
         NBPGAU= INFELE(  6)
         ICARA = INFELE(  5)
*         MINTE = INFELE(11)
         MINTE=INFMOD(2+inttyp)
         MINTE1= INFMOD(8)
         SEGACT MINTE
         IPMINT=MINTE
         IPMIN1=MINTE1

Cרררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררר
C                          P H A S E   2
C
C                 PREPARATION DES OBJETS RESULTATS
C
Cרררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררררר
C
       MELEME=IPMAIL
       SEGACT MELEME

           NBNN=NUM(/1)
           NBELEM=NUM(/2)
C
         NLIGRP= LRE
         NLIGRD= LRE
           SEGINI DESCR
           IPDSCR=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
C
           IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
              CALL ERREUR(5)
              SEGSUP DESCR,MRIGID
              SEGDES MMODEL,MELEME,MINTE
              RETURN
           ENDIF
C
C ---      REMPLISSAGE DU SEGMENT DESCRIPTEUR
C
           IDDL=1
           NCOMP=NDEPL
           NBNNS=NBNN
           IF (MFR.EQ.33) NCOMP=NDEPL-1
           IF (IFOUR.EQ.-3) THEN
             NCOMP=NDEPL-3
             NBNNS=NBNN-1
           ENDIF
           IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2
           NOMID=MODEPL
           SEGACT NOMID
           NOMID=MOFORC
           SEGACT NOMID
           DO 1004 INOEUD=1,NBNNS
              DO 1005 ICOMP=1,NCOMP
                 NOMID=MODEPL
                 LISINC(IDDL)=LESOBL(ICOMP)
                 NOMID=MOFORC
                 LISDUA(IDDL)=LESOBL(ICOMP)
                 NOELEP(IDDL)=INOEUD
                 NOELED(IDDL)=INOEUD
                 IDDL=IDDL+1
1005          CONTINUE
1004       CONTINUE

           NOMID=MODEPL
           if(lsupdp)SEGsup NOMID
           NOMID=MOFORC
           if(lsupfo)SEGsup NOMID
         SEGDES DESCR
C
C ---    INITIALISATION DU SEGMENT CHAPEAU IMATRI
C    on ne veut des matrices que pour les elements contenant des cables

         segini iccoun

C         NNUM = NNUMS
C         segact nnum
         nbele=nnm(/2)
         nbn = nnm(/1)

         segini inn1
         inmo = inn1

C ----il faut connaitre le nombre d elements beton touches dans la zone
C       et en fabriquer le maillage   pour supporter la rigidite
         nbelem = nbele
         nbnn = NUM(/1)
         nbsous = 0
         nbref=0
         segini ipt4
         ipt4.itypel= itypel

         ibnew = 0
         do 7000 ic=1,nbele
         if(nbem(2,ic).ne.isous) goto 7000
         ib = nbem(1,IC)

         if (incor(ib).EQ.0 ) then
         ibnew = ibnew + 1
         incor(ib) = ibnew
         do 7001 in=1,nbnn
         ipt4.num(in,ibnew)= num(in,ib)
         ibnec=ibnew
 7001    continue
         else
         ibnec = incor(ib)
         endif

         inn1.nbem(1,ic) = ibnec
         inn1.nbem(2,ic) = isous

         do 6998 in = 1,nbn
         inn1.nnm(in,ic) = nnm(in,ic)
 6998    continue

 7000    continue

C         write(6,*) ' rigia elt cable dans elt beton  '
         do 6666 i2=1,nbele
C       write(6,2222) i2,(inn1.nbem(i1,i2),i1=1,nbn),nnm(1,i2),nnm(2,I2)
 6666    continue
 2222    format(i4,4X,2I4,3X,2I4)
         nbelem = ibnew
         segadj ipt4
         imaicab = ipt4
         NELRIG = ibnew
         segdes inn1,ipt4

         segsup iccoun
C
C         IF(IMMD.EQ.2.AND.ISOU1.EQ.1) THEN
C         if( ipasou.eq.1) then
         SEGINI xMATRI
         IPMATR=xMATRI
C         IPDD(ISOUS)=IPMATR
         IPDD(Ipasou)=IPMATR
C         ELSE
C        IMATRI=IPDD(ISOUS)
C         IMATRI=IPDD(ipasou )
C         IPMATR=IMATRI
C         SEGACT IMATRI
C         END IF
C# MC 19/01/98 : IPMADG n'est pas crיי ! voir rigi1
C         IF (IFOUR.EQ.-3) THEN
C           IRIGEL(1,ISO)=IPMADG
C         ELSE
*           IRIGEL(1,ISOUS)=IPMAIL
         irigel(1,ipasou)=ipt4
C         ENDIF
C         IRIGEL(2,ISOUS)=0
C         IRIGEL(3,ISOUS)=IPDSCR
C         IRIGEL(4,ISOUS)=xMATRI
C         IRIGEL(5,ISOUS)=NIFOUR
C         IRIGEL(6,ISOUS)=0

         IRIGEL(2,ipasou)=0
         IRIGEL(3,ipasou)=IPDSCR
         IRIGEL(4,ipasou)=xMATRI
         IRIGEL(5,ipasou)=NIFOUR
         IRIGEL(6,ipasou)=0

C      MOTERR(1:4)=NOMTP(MELE)
C      MOTERR(9:12)='RIGI1'
C      CALL ERREUR(86)
C     GOTO 9990
C
C --- MASSIF
C
   4  CONTINUE

C      write(6,*) 'ivamat ivacar ivamac nmatc',ivamat,ivacar,ivamac,nmatc
C      write(6,*) 'NNUMS' , nnums

       CALL RIGIB(MATE,MELE,MELEM,imaicab,IPMITC,NBG,LRE,NSTRS,
     &   IVACAR,IVAMAC,CMATE,MFR,NBGMAT,NELMAT,IMAT,NMATC,
     &   NDDL,IPMATR,ISOUS,ipasou,inmo,IMMD)

      segsup inn1
      SEGDES IMODEL

      meleme = imaicab
      segdes meleme

      SEGDES MINTE
*      SEGSUP INFO
C
C --- DANS LE CAS D'ERREUR
C
      IF(IERR.NE.0) THEN
         IF(DESCR.NE.0)SEGSUP DESCR
         IF(xMATRI.NE.0)SEGSUP xMATRI
         IRT6=0
         GOTO 888
      ENDIF
C  fin de la boucle sur les zones beton
  500 CONTINUE
  888 CONTINUE
       IF(ISUP.EQ.1.AND.IMAT.NE.2)THEN
         CALL DTMVAL(IVAMAT,3)
       ELSE
         CALL DTMVAL(IVAMAT,1)
       ENDIF
C
       IF(ISUP.EQ.1)THEN
         CALL DTMVAL(IVACAR,3)
       ELSE
         CALL DTMVAL(IVACAR,1)
       ENDIF
C
      IF (MOCARA.NE.0)THEN
         NOMID=MOCARA
         SEGSUP NOMID
      ENDIF
C
      IF(MOMATR.NE.0)THEN
         NOMID=MOMATR
         if(lsupma)SEGSUP NOMID
      ENDIF
C
      SEGDES MMODEL
C    fin de la boucle  sue les zones cables
  40  CONTINUE

      segsup icozon
      segdes nnum

      IF (IPCHE1.NE.0) THEN
        MCHELM=IPCHE1
        SEGDES MCHELM
      ENDIF
      IF (IPCHOO.NE.0) THEN
        MCHELM=IPCHOO
        SEGDES MCHELM
      ENDIF
      IF(IERR.NE.0)THEN
        SEGSUP MRIGID
      ELSE
        SEGDES MRIGID
      ENDIF
      IF(IRT6.EQ.0) IPOI6=0
99999 CONTINUE

*?    IF (IPOI6.NE.0) IRET = 1
      IF (IERR.EQ.0) IRET = 1
      RETURN
      END