C RELR20    SOURCE    GOUNAND   11/05/24    21:16:04     6976           
      SUBROUTINE RELR20(MATASS,
     $     MCON,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : RELR20
C DESCRIPTION : 
*
* Création d'une matrice de contraintes
*
C
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : 
C APPELES (E/S)    : 
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C ENTREES            :
C ENTREES/SORTIES    :
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 02/07/2003, version initiale
C HISTORIQUE : v1, 02/07/2003, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
-INC CCOPTIO
-INC SMCOORD
-INC CCHAMP
-INC SMRIGID
      POINTEUR MCON.MRIGID
      POINTEUR DESCON.DESCR
*      POINTEUR ICON.IMATRI
      POINTEUR XCON.XMATRI
-INC SMELEME
      POINTEUR MEL.MELEME
* Includes persos
CBEGININCLUDE SMMINC
      SEGMENT MINC
      INTEGER     NPOS(NPT+1)
      INTEGER     MPOS(NPT,NBI+1)
      ENDSEGMENT
      SEGMENT IMINC
      INTEGER LNUPO (NDDL)
      INTEGER LNUINC(NDDL)
      ENDSEGMENT
CENDINCLUDE SMMINC
      POINTEUR MINCP.MINC
      POINTEUR MINCD.MINC
      POINTEUR IMINCP.IMINC
      POINTEUR IMINCD.IMINC
CBEGININCLUDE SMPMORS
      SEGMENT PMORS
      INTEGER IA (NTT+1)
      INTEGER JA (NJA)
      ENDSEGMENT
CENDINCLUDE SMPMORS
      POINTEUR PROFM.PMORS
CBEGININCLUDE SMIZA
      SEGMENT IZA
      REAL*8  A(NBVA)
      ENDSEGMENT
CENDINCLUDE SMIZA
      POINTEUR VALM.IZA
CBEGININCLUDE SMMATASS
      SEGMENT MATASS
      POINTEUR KJPOPA.MLENTI
      POINTEUR LINCPA.MLMOTS
      POINTEUR MINCPA.MINC
      POINTEUR KJPODA.MLENTI
      POINTEUR LINCDA.MLMOTS
      POINTEUR MINCDA.MINC
      POINTEUR PROFMA.PMORS
      POINTEUR VALMA.IZA
      ENDSEGMENT
CENDINCLUDE SMMATASS
*
-INC SMLENTI
      POINTEUR KJSPGP.MLENTI
      POINTEUR KJSPGD.MLENTI
      POINTEUR KLSPGP.MLENTI
      POINTEUR KKSPGP.MLENTI
-INC SMLMOTS
      POINTEUR LINCP.MLMOTS
      POINTEUR LINCD.MLMOTS
*
      INTEGER IMPR,IRET
      CHARACTER*4 MYMOP,MYMOD
*     
* Executable statements
*
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr20.eso' 
*
* Lecture de MATASS
*
      SEGACT MATASS
      KJSPGP=MATASS.KJPOPA
      LINCP =MATASS.LINCPA
      MINCP =MATASS.MINCPA
      KJSPGD=MATASS.KJPODA
      LINCD =MATASS.LINCDA
      MINCD =MATASS.MINCDA
      PROFM =MATASS.PROFMA
      VALM  =MATASS.VALMA 
*
* Création de l'inverse des segments MINC 
* et suppression de ces derniers
*
* In relr21 : SEGINI IMINCP      
      CALL RELR21(MINCP,IMINCP,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
* In relr21 : SEGINI IMINCD
      CALL RELR21(MINCD,IMINCD,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
*      SEGPRT,IMINCP
*      SEGPRT,IMINCD
      SEGSUP MINCP
      SEGSUP MINCD
*     SEGDES MCOORD
      SEGACT MCOORD*MOD
      SEGACT KJSPGP
      SEGACT LINCP
      SEGACT IMINCP
      SEGACT KJSPGD
      SEGACT LINCD
      SEGACT IMINCD
      SEGACT PROFM
      SEGACT VALM
      NDDLDU=IMINCD.LNUPO(/1)
      NPOPRI=KJSPGP.LECT(/1)
* Il y a autant de rigidités à créer que de degrés de liberté duaux
      NRIGE=7
      NRIGEL=NDDLDU
      SEGINI MCON
      MCON.MTYMAT='CON.DIV.'
      JG=NPOPRI
      SEGINI KLSPGP
*        Ensemble des numéros de points primaux
      DO IDDLDU=1,NDDLDU
         MCON.COERIG(IDDLDU)=1.D0
         INZ=PROFM.IA(IDDLDU)
         LNZ=PROFM.IA(IDDLDU+1)-INZ
*
* Création de la géométrie pour la iddldueme matrice
*
*     Quels points de KJSPGP sont concernés par les
*     ddls INZ à INZ+LNZ-1.
*   degré et fin de la liste chaînée
         LDG=0
         LAST=-1
         DO JNZ=1,LNZ
            NUMPP=IMINCP.LNUPO(PROFM.JA(INZ+JNZ-1))
            IF (KLSPGP.LECT(NUMPP).EQ.0) THEN
               LDG=LDG+1
               KLSPGP.LECT(NUMPP)=LAST
               LAST=NUMPP
            ENDIF
         ENDDO
*   remplissage de KKSPGP
*   KLSPGP sert maintenant de repérage dans KKSPGP
*   (ouh la la quelle prise de risque !)
         JG=LDG
         SEGINI KKSPGP
         DO ILDG=1,LDG
            IPREC=KLSPGP.LECT(LAST)
            KKSPGP.LECT(ILDG)=LAST
            KLSPGP.LECT(LAST)=ILDG
*            KLSPGP.LECT(LAST)=0
            LAST=IPREC
         ENDDO
*   géométrie
         NBNN=LDG+2
         NBELEM=1
         NBSOUS=0
         NBREF=0
         SEGINI MEL
         MEL.ITYPEL=22
*   le premier point correspond à celui de IDDLDU
         NUPODU=KJSPGD.LECT(IMINCD.LNUPO(IDDLDU))
*!         MEL.NUM(1,1)=NUPODU
*! on crée deux ! nouveaux points
*   on crée un nouveau point de mêmes coordonnées 
*   support du multiplicateur de Lagrange
*         NBPTOT=XCOOR(/1)/(IDIM+1)
*         NBPTS=NBPTOT+1
*         SEGADJ MCOORD
*         DO IIDIM=1,IDIM
*            XCOOR((NBPTS-1)*(IDIM+1) + IIDIM)=
*     $           XCOOR((NUPODU-1)*(IDIM+1) + IIDIM)
*         ENDDO
*         MEL.NUM(2,1)=NBPTS
         NBPTOT=XCOOR(/1)/(IDIM+1)
         NBPTS=NBPTOT+2
         SEGADJ MCOORD
         DO IIDIM=1,IDIM
            XCOOR((NBPTS-1)*(IDIM+1) + IIDIM)=
     $           XCOOR((NUPODU-1)*(IDIM+1) + IIDIM)
            XCOOR((NBPTS-2)*(IDIM+1) + IIDIM)=
     $           XCOOR((NUPODU-1)*(IDIM+1) + IIDIM)
         ENDDO
         MEL.NUM(1,1)=NBPTS-1
         MEL.NUM(2,1)=NBPTS
*   les points suivants correspondent à ceux de KKSPGP
         DO ILDG=1,LDG
            MEL.NUM(2+ILDG,1)=KJSPGP.LECT(KKSPGP.LECT(ILDG))
         ENDDO
         SEGDES MEL
         MCON.IRIGEL(1,IDDLDU)=MEL
*
* Création du segment descripteur pour la iddldueme matrice
*
         NLIGRP=2+LNZ
         NLIGRD=2+LNZ
         SEGINI DESCON
* Les deux premiers indices
         DESCON.NOELEP(1)=1
         DESCON.NOELED(1)=1
         MYMOD=LINCD.MOTS(IMINCD.LNUINC(IDDLDU))
         CALL FICH4(MYMOD,NOMDU,LNOMDU,
     $        INOMDU,
     $        IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         DESCON.LISINC(1)=NOMDD(INOMDU)
         DESCON.LISDUA(1)=MYMOD
         DESCON.NOELEP(2)=2
         DESCON.NOELED(2)=2
         DESCON.LISINC(2)=NOMDD(INOMDU)
         DESCON.LISDUA(2)=MYMOD
* Les indices suivants
         DO JNZ=1,LNZ
            NUIPP=IMINCP.LNUINC(PROFM.JA(INZ+JNZ-1))
            MYMOP=LINCP.MOTS(NUIPP)
            CALL FICH4(MYMOP,NOMDD,LNOMDD,
     $           INOMDD,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            DESCON.LISINC(2+JNZ)=MYMOP
            DESCON.LISDUA(2+JNZ)=NOMDU(INOMDD)
            NUMPP=IMINCP.LNUPO(PROFM.JA(INZ+JNZ-1))
            NUMP2=KLSPGP.LECT(NUMPP)
            IF (NUMP2.EQ.0) THEN
               WRITE(IOIMP,*) 'Erreur grave no1'
               GOTO 9999
            ENDIF
            DESCON.NOELEP(2+JNZ)=2+NUMP2
            DESCON.NOELED(2+JNZ)=2+NUMP2
         ENDDO
         SEGDES DESCON
         MCON.IRIGEL(3,IDDLDU)=DESCON
* remise à zéro de KLSPGP et suppression de KKSPGP
         DO ILDG=1,LDG
            KLSPGP.LECT(KKSPGP.LECT(ILDG))=0
         ENDDO
         SEGSUP KKSPGP
*
* Création de la matrice élémentaire         
*
         NELRIG=1
*         SEGINI ICON
         NLIGRP=2+LNZ
         NLIGRD=2+LNZ
         SEGINI XCON
* Les deux premiers indices
         XCON.RE(1,1,1)=-1.D0
         XCON.RE(1,2,1)= 1.D0
         XCON.RE(2,1,1)= 1.D0
         XCON.RE(2,2,1)=-1.D0
* Les indices suivants
         DO JNZ=1,LNZ
            VAL=VALM.A(INZ+JNZ-1)
            XCON.RE(1,2+JNZ)=VAL
            XCON.RE(2,2+JNZ)=VAL
            XCON.RE(2+JNZ,1)=VAL
            XCON.RE(2+JNZ,2)=VAL
         ENDDO
         SEGDES XCON
*         ICON.IMATTT(1)=XCON
*         SEGDES ICON
*         MCON.IRIGEL(4,IDDLDU)=ICON
         MCON.IRIGEL(4,IDDLDU)=XCON
         MCON.IRIGEL(5,IDDLDU)=0
         MCON.IRIGEL(6,IDDLDU)=0
         MCON.IRIGEL(7,IDDLDU)=0
      ENDDO
      SEGSUP KLSPGP
      SEGDES MCON
* Suppression de tous les objets de MATASS
      SEGSUP VALM
      SEGSUP PROFM
      SEGSUP IMINCD
      SEGSUP LINCD
      SEGSUP KJSPGD
      SEGSUP IMINCP
      SEGSUP LINCP
      SEGSUP KJSPGP
*     SEGDES MCOORD
      SEGACT MCOORD
      SEGSUP MATASS
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine relr20'
      RETURN
*
* End of subroutine RELR20
*
      END