C RGLILI    SOURCE    PV090527  26/04/30    21:16:14     12529          
      SUBROUTINE RGLILI(ISOLS,ISTRU,IRIG,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C CE SUBROUTINE CALCULE POUR LES SOLUTIONS STATIQUES ISOLS DE TYPE :
C  1-MECA OU FLUI
C LES RIGIDITES DE COUPLAGE DES LIAISONS ENTRE ELLES (FORMALISME GIBERT)
C DE SOUS TYPE MASSE SI IRIG=1, DE SOUS TYPE RIGIDITE SI IRIG=2
C ECRIT PAR FARVACQUE
C  2-DEPI
C UNE MATRICE DE RIGIDITE NULLE ET UNE MATRICE DE MASSE IDENTITE
C (FORMALISME DEPLACEMENTS IMPOSES SUR MODES BLOQUES POUR DEVO)
C ECRIT PAR GUILBAUD
C
C ELLES S'APPUIENT SUR L ELEMENT QUI CONTIENT TOUS LES POINTS ASSOCIES
C AUX LIAISONS MJONCT.
C
C APPELE PAR RIGI,RGBASE
C APPELLE : ETALPR,MUCPRI,ETALCH,YTMX,ERREUR(235,108)
C=======================================================================

-INC PPARAM
-INC CCOPTIO
-INC SMSOLUT
-INC SMRIGID
-INC SMCOORD
-INC SMATTAC
-INC SMELEME
-INC SMSTRUC
-INC CCHAMP
      SEGMENT ICPR(nbpts)
      
      SEGMENT IINC
       CHARACTER*(LOCOMP) CIINC(0)
      ENDSEGMENT
      SEGMENT IIDU
       CHARACTER*(LOCOMP) CIIDU(NNI1)
      ENDSEGMENT
      
      SEGMENT ITRMEC(NJONC)
      SEGMENT ITRDEP(NJONC)
      SEGMENT ITRAV(6)
      SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA
      SEGMENT/ICONTR/(MCONTR(NNI1,IPR1))
      SEGMENT IPB(IPR1)
      DATA KZERO/0/
      
      CHARACTER*(LOCOMP) IDDL
C
      IRET=0
      IF(IRIG.NE.1.AND.IRIG.NE.2) GOTO 8000
      MSOSTU=ISTRU
      MSOLUT=ISOLS
      SEGACT MSOLUT
      NIPO=MSOLIS(/1)
      KJONC=MSOLIS(10)
      KDEPL=MSOLIS(5)
      IF(KDEPL.NE.0) GO TO 12
      MOTERR(1:8)='SOLUTION'
      MOTERR(9:26)='SOLUTION'
      MOTERR(30:38)='DEPL'
      SEGDES MSOLUT
      CALL ERREUR(235)
C     ON NE TROUVE PAS LES DEPL
      GO TO 8000
 12   CONTINUE
      SEGDES MSOLUT
      MSOLE1=KJONC
      SEGACT MSOLE1
      NJONC=MSOLE1.ISOLEN(/1)
      SEGDES MSOLE1
      IF(NJONC.EQ.0) GO TO 8000
C
      SEGINI ITRMEC,ITRDEP
      SEGACT MSOLE1
      NJOMEC=0
      NJODEP=0
      DO 20 I=1,NJONC
      MJONCT=MSOLE1.ISOLEN(I)
      SEGACT MJONCT
      IF(MJOTYP.EQ.'MECA'.OR.MJOTYP.EQ.'FLUI') THEN
        NJOMEC=NJOMEC+1
        ITRMEC(NJOMEC)=I
      ELSEIF(MJOTYP.EQ.'DEPI'.AND.IRIG.EQ.1) THEN
        NJODEP=NJODEP+1
        ITRDEP(NJODEP)=I
      ENDIF
      SEGDES MJONCT
 20   CONTINUE
      SEGDES MSOLE1
      IF(NJOMEC.EQ.0.AND.NJODEP.EQ.0) GOTO 7000
      IF(NJOMEC.EQ.0) GO TO 5000
C
C  **** INITIALISATION DE LA GEOMETRIE(1 ELEMENT QUI CONTIENT TOUS LES
C  **** POINT-LIAISONS) ET DE LA MATRICE ASSOCIEE XMATRI
C  **** INITIALISATION DE IMATRI ET DE DESCR
C
      NJONC=NJOMEC
      LVAL=NJONC*(NJONC+1)/2
      NLIGRP=NJONC
      NLIGRD=NJONC
      nelrig=1
      rigrel=0
      SEGINI XMATRI
*      NLIGRE=NJONC
      SEGINI DESCR
      NELRIG=1
*      SEGINI IMATRI
*      IMATTT(1)=XMATRI
*      SEGDES IMATRI
      SEGACT MSOLUT
      IPT1=MSOLIS(3)
      SEGACT IPT1
      NBSOUS=0
      NBREF=0
      NBNN=NJONC
      NBELEM=1
      SEGINI MELEME
      ITYPEL=27
      MSOLEN=KDEPL
C
C  **** PREPARATION DES OPERATIONS : A IPM ON DONNE LA FORME RECTANGLE
C
      SEGACT MSOLEN
      IPM=ISOLEN(1)
      CALL ETALPR(IPM,KIINC,KICPR,KCONTR)
      ICONTR=KCONTR
      SEGACT ICONTR
      IPR1=MCONTR(/2)
      NNI1=MCONTR(/1)
      SEGINI MVA
      KMVA=MVA
      SEGINI MVA
      KMVB=MVA
      SEGINI IPB
      KIPB=IPB
      IINC=KIINC
      SEGACT IINC
      SEGINI IIDU
      DO 50 I=1,NNI1
      IDDL=CIINC(I)
      DO 51 J=1,LNOMDD
      IF(IDDL.NE.NOMDD(J)) GOTO 51
      CIIDU(I)=NOMDU(J)
      GOTO 50
 51   CONTINUE
      MOTERR=IDDL
      CALL ERREUR(108)
C     ON NE TROUVE PAS IDDL DANS CCHAMP
      GOTO 7000
 50   CONTINUE
      KINCDU=IIDU
      IF(IIMPI.NE.0)WRITE(6,8883)(CIINC(I),CIIDU(I),I=1,NNI1)
 8883 FORMAT(20(1X,A4))
C
C  **** CAS IRIG=1 : TERMES DANS LA MATRICE MASSE : UT.M.U
C
      IF(IRIG.NE.1) GO TO 100
      SEGACT MSOSTU
      MATMAS=ISMASS
      SEGDES MSOSTU
      SEGACT MSOLE1,MSOLEN
      LTAB=ISOLEN(/1)
      DO 9 I=1,NJONC
      MJONCT=MSOLE1.ISOLEN(ITRMEC(I))
      SEGACT MJONCT
      NOELEP(I)=I
      NOELED(I)=I
      IF(MJODDL.EQ.'LX  ') GO TO 16
      LISINC(I)='FBET'
      LISDUA(I)='BETA'
      GO TO 17
 16   LISINC(I)='BETA'
      LISDUA(I)='FBET'
 17   CONTINUE
      SEGDES MJONCT
      NUM(I,1)=IPT1.NUM(1,ITRMEC(I))
 9    CONTINUE
C
      KZERO=0
      DO 10 I=1,NJONC
      IP1=ISOLEN(I)
      CALL MUCPRI(IP1,MATMAS,MUI)
      IF(IERR.NE.0) GOTO 8000
      CALL ETALCH(MUI,KINCDU,KICPR,KCONTR,KMVB,KIPB,NPR2,1)
      IF(IERR.NE.0) GO TO 8000
C
      IF(IIMPI.EQ.0) GOTO 804
      MVA=KMVB
      IPB=KIPB
      SEGACT MVA,IPB
      WRITE(IOIMP,7878)I
 7878 FORMAT('  ************* DANS RGLILI CALCUL DE UJ.M.UI ****',
     1 /,' ========== I=',I4,' ECRITURE DE M.UI SOUS LA FORME VA
     1 PUIS IPB')
      WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
      WRITE(IOIMP,8882)(IPB(KJ2),KJ2=1,IPR1)
 804  CONTINUE
C
      DO 11 J=I,NJONC
      IP2=ISOLEN(J)
      CALL ETALCH(IP2,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID,1)
      IF(IERR.NE.0) GOTO 8000
C
      IF(IIMPI.EQ.0) GO TO 803
      MVA=KMVA
      SEGACT MVA
      WRITE(IOIMP,7879)J
 7879 FORMAT(' ========== J=',I4,' ECRITURE DE UJ SOUS LA FORME VA')
      WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
 803  CONTINUE
C
C  **** OPERATION UT . ( M.U )
C
      MVA=KMVA
      MVA1=KMVB
      IPB=KIPB
C      SEGACT MVA,MVA1,IPB
      XRET=0.
      DO    J1=1,NPR2
      JJ1=IPB(J1)
      DO    I1=1,NNI1
      XRET=XRET+VA(I1,JJ1)*MVA1.VA(I1,JJ1)
      enddo    
      enddo    
C
      IF(IIMPI.EQ.0) GOTO 805
      CALL YTMX(IP1,IP2,MATMAS,WW)
      WRITE(IOIMP,7877)XRET,WW
 7877 FORMAT(' UI.M.UJ = ',E12.5,'   PAR L''OPERATEUR YTMX ON TROUVE '
     1 ,E12.5)
  805 CONTINUE
C
*      K=(J*(J-1)/2)+I
      RE(J,I,1)=XRET
      RE(I,J,1)=XRET
 11   CONTINUE
 10   CONTINUE
      GO TO 6
C
C  ****  CAS IRIG=2 : MATRICE RAIDEUR : LIGNE J COLONNE I: UI ET PJ
C
 100  CONTINUE
C
C  **** PREMIERE BOUCLE SUR LESMJONCT. ON EN SORT MCHPOI QU ON ETALE
C  **** DANS MVA . C EST UI
C
      SEGACT MSOLEN,MSOLE1
      LTAB=ISOLEN(/1)
      DO 30 IJO1=1,NJONC
      MJONCT=MSOLE1.ISOLEN(ITRMEC(IJO1))
      SEGACT MJONCT
      RLIBRE=1.
      IF(MJODDL.EQ.'FLX ') RLIBRE=-1.
      NOELEP(IJO1)=IJO1
      NOELED(IJO1)=IJO1
      IF(MJODDL.EQ.'LX  ') GO TO 18
      LISINC(IJO1)='FBET'
      LISDUA(IJO1)='BETA'
      GO TO 19
 18   LISINC(IJO1)='BETA'
      LISDUA(IJO1)='FBET'
 19   CONTINUE
      NUM(IJO1,1)=IPT1.NUM(1,ITRMEC(IJO1))
      SEGDES MJONCT
      IP1=ISOLEN(ITRMEC(IJO1))
      KZERO=0
      CALL ETALCH(IP1,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID,1)
      IF(IERR.NE.0) GO TO 8000
      IF(IIMPI.EQ.0) GO TO 800
      MVA=KMVA
      SEGACT MVA
      WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
 8880 FORMAT(8(2X,E12.5))
 800  CONTINUE
C
C  **** 2IEME BOUCLE SUR LES MJONCT: ON EN TIRE PJ QU ON ETALE DANS MVB
C
      DO 31 IJO2=IJO1,NJONC
      MJONCT=MSOLE1.ISOLEN(ITRMEC(IJO2))
      SEGACT MJONCT
      NST=ISTRJO(/1)
      DO 32 IS=1,NST
      IF(ISTRJO(IS).NE.MSOSTU) GO TO 32
      IPP2=IPCHJO(IS)
      CALL ETALCH(IPP2,KIINC,KICPR,KCONTR,KMVB,KIPB,NPR2,1)
      IF(IERR.NE.0) GO TO 8000
      IF(IIMPI.EQ.0) GO TO 801
      MVA=KMVB
      IPB=KIPB
      SEGACT MVA,IPB
      WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
      WRITE(IOIMP,8882)(IPB(KJ2),KJ2=1,IPR1)
 8882 FORMAT( 10I6)
 801  CONTINUE
C
C  **** OPERATION VA*VB
C
      MVA=KMVA
      MVA1=KMVB
      IPB=KIPB
C      SEGACT MVA,MVA1,IPB
C
      XRET=0.
      DO    J1=1,NPR2
      JJ1=IPB(J1)
      DO    I1=1,NNI1
      XRET=XRET+VA(I1,JJ1)*MVA1.VA(I1,JJ1)
      enddo    
      enddo    
C
*      K=(IJO2*(IJO2-1)/2)+IJO1
      RE(IJO2,IJO1,1)=RE(IJO2,IJO1,1)+XRET*RLIBRE
      RE(IJO1,IJO2,1)=RE(IJO2,IJO1,1)
 32   CONTINUE
      SEGDES MJONCT
 31   CONTINUE
 30   CONTINUE
      SEGDES MSOLE1
C
 6    CONTINUE
      IINC=KIINC
      SEGSUP IINC
      IIDU=KINCDU
      SEGSUP IIDU
      ICPR=KICPR
      SEGSUP ICPR
      SEGSUP ICONTR
      SEGSUP MVA,MVA1,IPB
      SEGDES DESCR,MELEME,XMATRI,IPT1,MSOLUT
      SEGINI ITRAV
      ITRAV(1)=MELEME
      ITRAV(2)=0
      ITRAV(3)=DESCR
      ITRAV(4)=xMATRI
      ITRAV(5)=NIFOUR
      ITRAV(6)=0
 5000 CONTINUE
C
C   LIAISON POUR DEPLACEMENT IMPOSE
C
      IF(NJODEP.EQ.0) GO TO 6000
C
C  **** INITIALISATION DE LA GEOMETRIE(1 ELEMENT QUI CONTIENT TOUS LES
C  **** POINT-LIAISONS) ET DE LA MATRICE ASSOCIEE XMATRI
C  **** INITIALISATION DE IMATRI ET DE DESCR
C
      NJONC=NJODEP
*      LVAL=NJONC*(NJONC+1)/2
      NLIGRP=NJONC
      NLIGRD=NJONC
      nelrig=1
      rigrel=0
      SEGINI XMATRI
*      DO 40 K=1,LVAL
*      RE(K)=0.D0
*  40  CONTINUE
      SEGINI DESCR
      NELRIG=1
*      SEGINI IMATRI
*      IMATTT(1)=XMATRI
*      SEGDES IMATRI
      SEGACT MSOLUT
      IPT1=MSOLIS(3)
      SEGACT IPT1
      NBSOUS=0
      NBREF=0
      NBNN=NJONC
      NBELEM=1
      SEGINI MELEME
      ITYPEL=27
      DO 41 I=1,NJONC
      NOELEP(I)=I
      NOELED(I)=I
      LISINC(I)='FBET'
      LISDUA(I)='BETA'
      NUM(I,1)=IPT1.NUM(1,ITRDEP(I))
      RE(I,I,1)=1.D0
   41 CONTINUE
      SEGSUP ITRDEP
      SEGDES DESCR,MELEME,XMATRI,MSOLUT,IPT1
C
C   CREATION DE MRIGID
C
 6000 CONTINUE
      NRIGEL=1
      IF(NJOMEC.NE.0.AND.NJODEP.NE.0) NRIGEL=2
      NRIGE=6
      SEGINI MRIGID
      ICHOLE=0
      IMGEO1=0
      IMGEO2=0
      IFORIG=IFOUR
      IF(IRIG.EQ.1) THEN
           MTYMAT='MASSE   '
      ELSE
           MTYMAT='RIGIDITE'
      ENDIF
        I=0
      IF(NJOMEC.NE.0) THEN
        I=I+1
        COERIG(I)=1.D0
        IRIGEL(1,I)=ITRAV(1)
        IRIGEL(2,I)=ITRAV(2)
        IRIGEL(3,I)=ITRAV(3)
        IRIGEL(4,I)=ITRAV(4)
        IRIGEL(5,I)=ITRAV(5)
        IRIGEL(6,I)=ITRAV(6)
        xmatr1=itrav(4)
        segdes xmatr1
        SEGSUP ITRAV

      ENDIF
      IF(NJODEP.NE.0) THEN
        I=I+1
        COERIG(I)=1.D0
        IRIGEL(1,I)=MELEME
        IRIGEL(2,I)=0
        IRIGEL(3,I)=DESCR
        IRIGEL(4,I)=xMATRI
        IRIGEL(5,I)=NIFOUR
        IRIGEL(6,I)=0
        segdes xmatri
      ENDIF

      SEGDES MRIGID
      IRET=MRIGID
 7000 CONTINUE
      SEGSUP ITRMEC,ITRDEP
 8000 CONTINUE
      RETURN
      END