C CV2MAA    SOURCE    PV090527  26/04/30    21:15:25     12529          
      SUBROUTINE CV2MAA(CGEOMQ,TABVDC,TABMAT,
     $     MYFALS,
     $     MATLSA,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : CV2MAA
C DESCRIPTION : Transforme un MCHAEL (mon champ par éléments)
C               représentant un ensemble de matrices élémentaires en
C               RIGIDITE...
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          :
C APPELES (E/S)    :
C APPELE PAR       : CV2MCA
C***********************************************************************
C ENTREES            :
C ENTREES/SORTIES    : -
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 06/03/06, version initiale
C HISTORIQUE : v1, 06/03/06, 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 PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC SMLMOTS
      POINTEUR NCVAPR.MLMOTS
      POINTEUR NCVADU.MLMOTS
-INC SMELEME
      POINTEUR CGEOMQ.MELEME
      POINTEUR MYMEL.MELEME
      POINTEUR RIGMEL.MELEME
-INC SMLENTI
      POINTEUR LINCPR.MLENTI,LINCDU.MLENTI
      POINTEUR KINCPR.MLENTI,KINCDU.MLENTI
      POINTEUR LPOQUF.MLENTI,KPOQUF.MLENTI
      POINTEUR NOFSPR.MLENTI,NOFSDU.MLENTI
      POINTEUR COPRDU.MLENTI,LINCD2.MLENTI
-INC SMRIGID
-INC SMCOORD
      POINTEUR MATLSA.MRIGID
      POINTEUR MYDSCR.DESCR
      POINTEUR MYIMAT.IMATRI
      POINTEUR MYXMAT.XMATRI
*
* Includes persos
*
-INC TNLIN
*-INC SMTNLIN
*-INC SMCHAEL
      POINTEUR IMTLSA.MCHAEL
      POINTEUR JMTLSA.MCHEVA
      INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
*-INC SFALRF
      POINTEUR MYFALS.FALRFS
*-INC SELREF
      POINTEUR LRFPR.ELREF
      POINTEUR LRFDU.ELREF
*
      CHARACTER*4 MDISPR,MDISDU,MOPR,MODU
      INTEGER IMPR,IRET
*
      INTEGER IBNN,IBELEM
      INTEGER ITQUAF,NDDLPR,NDDLDU
      INTEGER        IDDLPR,IDDLDU
      INTEGER               NSOUS,NPOQUF
      INTEGER ISOUS
      LOGICAL LOK,LFOUND,LCORES,LEQ1,LEQ2,LFIRST

*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans cv2maa'
*
*      Vérification sur les inconnues
*
      SEGACT TABVDC
      SEGACT TABMAT
*      SEGPRT,TABVDC
*      SEGPRT,TABMAT

      NUMVPR=TABMAT.VMAT(/2)
      NUMVDU=TABMAT.VMAT(/1)
*
* Construction des listes d'inconnues primales et duales
* qui interviennent dans la matrice et dont la valeur n'est pas
* donnée
      JG=0
      SEGINI LINCPR
      SEGINI LINCDU
      DO IVARPR=1,NUMVPR
         IPR=TABVDC.VVARPR(IVARPR)
         IF (TABVDC.MVD(IPR).EQ.0) THEN
            DO IVARDU=1,NUMVDU
               IDU=TABVDC.VVARDU(IVARDU)
               IF (TABVDC.MVD(IDU).EQ.0) THEN
                  IF (TABMAT.VMAT(IVARDU,IVARPR).NE.0) THEN
                     LINCDU.LECT(**)=IDU
                     LINCPR.LECT(**)=IPR
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
      ENDDO
      NINCPR=LINCPR.LECT(/1)
      NINCDU=LINCDU.LECT(/1)
* Sortie anticipée s'il n'y a pas de matrices à construire
      IF (NINCPR.EQ.0.AND.NINCDU.EQ.0) THEN
*         SEGACT LINCPR
*         SEGACT LINCDU
         SEGSUP LINCPR
         SEGSUP LINCDU
         MATLSA=0
         RETURN
      ENDIF
*
*      WRITE(IOIMP,*) 'LINCPR et LINCDU'
*      SEGPRT,LINCPR
*      SEGPRT,LINCDU
* Suppression des doublons
      CALL IUNIQ(LINCPR.LECT,LINCPR.LECT(/1),
     $     LINCPR.LECT,NINCPR,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      JG=NINCPR
      SEGADJ,LINCPR
      CALL IUNIQ(LINCDU.LECT,LINCDU.LECT(/1),
     $     LINCDU.LECT,NINCDU,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      JG=NINCDU
      SEGADJ,LINCDU
*      WRITE(IOIMP,*) 'LINCPR et LINCDU sans doublons'
*      SEGPRT,LINCPR
*      SEGPRT,LINCDU
*
* Si les listes d'inconnues ont même taille, on se fatigue
* à chercher une permutation des inconnues duales qui les
* recollent sur les primales
* Ca ne marche pas pour l'instant : COPRDU n'est pas forcément
* une permutation ex : primale = 'TN' ; duale = 'SCAL'
*
      IF (.FALSE.) THEN
         IF (NINCPR.EQ.NINCDU) THEN
            JG=NINCPR
            SEGINI COPRDU
            LOK=.TRUE.
            IINCPR=0
 3          CONTINUE
            IF (LOK.AND.IINCPR.LT.NINCPR) THEN
               IINCPR=IINCPR+1
               JGVDPR=LINCPR.LECT(IINCPR)
               NCVAPR=TABVDC.NOMVD(JGVDPR)
               SEGACT NCVAPR
*            SEGPRT,NCVAPR
               NMOVPR=NCVAPR.MOTS(/2)
               IINCDU=0
               LFOUND=.FALSE.
 1             CONTINUE
*            WRITE(IOIMP,*) '1'
               IF (.NOT.LFOUND.AND.IINCDU.LT.NINCDU) THEN
                  IINCDU=IINCDU+1
                  JGVDDU=LINCDU.LECT(IINCDU)
                  NCVADU=TABVDC.NOMVD(JGVDDU)
                  SEGACT NCVADU
*               SEGPRT,NCVADU
                  NMOVDU=NCVADU.MOTS(/2)
                  LCORES=.FALSE.
                  IF (NMOVDU.EQ.NMOVPR) THEN
                     LCORES=.TRUE.
                     IMOV=0
 2                   CONTINUE
*                  WRITE(IOIMP,*) '2'
                     IF (LCORES.AND.IMOV.LT.NMOVDU) THEN

                        IMOV=IMOV+1
                        MOPR=NCVAPR.MOTS(IMOV)
                        MODU=NCVADU.MOTS(IMOV)
*                     WRITE(IOIMP,*) 'avant fimot2'
                        CALL FIMOT2(MOPR,NOMDD,LNOMDD,
     $                       IPR,IMPR,IRET)
                        IF (IRET.NE.0) GOTO 9999
*                     WRITE(IOIMP,*) 'apres fimot2'
                        LEQ1=MOPR.EQ.MODU
*                     WRITE(IOIMP,*) 'LEQ1=',LEQ1
*                     WRITE(IOIMP,*) 'IPR=',IPR
                        IF (IPR.NE.0) THEN
                           LEQ2=MODU.EQ.NOMDU(IPR)
                        ELSE
                           LEQ2=.FALSE.
                        ENDIF
*                     WRITE(IOIMP,*) 'LEQ2=',LEQ2
                        LCORES=LCORES.AND.(LEQ1.OR.LEQ2)
                        GOTO 2
                     ENDIF
                  ENDIF
                  SEGDES NCVADU
                  LFOUND=LCORES
                  GOTO 1
               ENDIF
               IF (LFOUND) THEN
                  COPRDU.LECT(IINCPR)=IINCDU
               ENDIF
               SEGDES NCVAPR
               LOK=LOK.AND.LFOUND
               GOTO 3
            ENDIF
*         SEGPRT,COPRDU
*
* On permute LINCDU
*
            LINCD2=LINCDU
            JG=NINCDU
            SEGINI LINCDU
            DO IINCDU=1,NINCDU
               LINCDU.LECT(IINCDU)=LINCD2.LECT(COPRDU.LECT(IINCDU))
            ENDDO
            SEGSUP LINCD2
            SEGSUP COPRDU
         ENDIF
*      WRITE(IOIMP,*) 'LINCDU permuté'
*      SEGPRT,LINCPR
*      SEGPRT,LINCDU
      ENDIF
*
* Maintenant on construit la table de repérage dans LINCPR et LINCDU
*
      JG=TABVDC.DJSVD(/1)
      SEGINI KINCPR
      CALL RSETXI(KINCPR.LECT,LINCPR.LECT,LINCPR.LECT(/1))
      SEGINI KINCDU
      CALL RSETXI(KINCDU.LECT,LINCDU.LECT,LINCDU.LECT(/1))
*      WRITE(IOIMP,*) 'KINCPR et KINCDU'
*      SEGPRT,KINCPR
*      SEGPRT,KINCDU
*
      SEGACT CGEOMQ
      NSOUS=CGEOMQ.LISOUS(/1)
*
* Initialisation de la matrice
*
      NRIGEL=NSOUS
      SEGINI,MATLSA
      MATLSA.MTYMAT='LEASTSQU'
* Parcours
      DO ISOUS=1,NSOUS
*         WRITE(IOIMP,*) 'ISOUS=',ISOUS
         MYMEL=CGEOMQ.LISOUS(ISOUS)
         SEGACT MYMEL
*         SEGPRT,MYMEL
         ITQUAF=MYMEL.ITYPEL
*
* Maintenant on construit :
* - L'objet géométrie
* - La table d'offset pour les variables primales et duales
* - Le segment descripteur
*
*   Liste des points du QUAF sur lequels il y a des ddl
         JG=0
         SEGINI LPOQUF
*   Tables d'offset
         JG=NINCPR+1
         SEGINI NOFSPR
         NOFSPR.LECT(1)=0
         JG=NINCDU+1
         SEGINI NOFSDU
         NOFSDU.LECT(1)=0
         NLIGRP=0
         NLIGRD=0
*       Primale
         DO IINCPR=1,NINCPR
            IJGVD=LINCPR.LECT(IINCPR)
            IKGVD=TABVDC.DJSVD(IJGVD)
            MDISPR=TABVDC.DISVD(IKGVD)
            CALL KEEF(ITQUAF,MDISPR,MYFALS,
     $           LRFPR,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            SEGACT LRFPR
            NDDLPR=LRFPR.NPQUAF(/1)
            DO IDDLPR=1,NDDLPR
               LPOQUF.LECT(**)=LRFPR.NPQUAF(IDDLPR)
            ENDDO
* Si le maillage donné à NLIN n'était pas QUAF au départ, il faut
* vérifier que tous les ddls peuvent s'appuyer sur les points du
* maillage donné
* Le test uniquement sur le 1er element doit etre suffisant
            IF (CGEOMQ.LISREF(ISOUS).NE.0) THEN
               DO IDDLPR=1,NDDLPR
                  NNQUA=LRFPR.NPQUAF(IDDLPR)
                  NNGLO=MYMEL.NUM(NNQUA,1)
                  IF (NNGLO.EQ.0) THEN
                     WRITE(IOIMP,*) 'A discretization space ',MDISPR,
     $                    ' is incompatible with the given mesh'
                     WRITE(IOIMP,*) 'Check its element type please'
                     GOTO 9999
                  ENDIF
               ENDDO
            ENDIF
            SEGDES LRFPR
            NLIGRP=NLIGRP+NDDLPR
            NOFSPR.LECT(IINCPR+1)=NLIGRP
         ENDDO
*       Duale
         DO IINCDU=1,NINCDU
            IJGVD=LINCDU.LECT(IINCDU)
            IKGVD=TABVDC.DJSVD(IJGVD)
            MDISDU=TABVDC.DISVD(IKGVD)
            CALL KEEF(ITQUAA,MDISDU,MYFALS,
     $           LRFDU,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            SEGACT LRFDU
            NDDLDU=LRFDU.NPQUAF(/1)
            DO IDDLDU=1,NDDLDU
               LPOQUF.LECT(**)=LRFDU.NPQUAF(IDDLDU)
            ENDDO
* Si le maillage donné à NLIN n'était pas QUAF au départ, il faut
* vérifier que tous les ddls peuvent s'appuyer sur les points du
* maillage donné
* Le test uniquement sur le 1er element doit etre suffisant
            IF (CGEOMQ.LISREF(ISOUS).NE.0) THEN
               DO IDDLDU=1,NDDLDU
                  NNQUA=LRFDU.NPQUAF(IDDLDU)
                  NNGLO=MYMEL.NUM(NNQUA,1)
                  IF (NNGLO.EQ.0) THEN
                     WRITE(IOIMP,*) 'A discretization space ',MDISDU,
     $                    ' is incompatible with the given mesh'
                     WRITE(IOIMP,*) 'Check its element type please'
                     GOTO 9999
                  ENDIF
               ENDDO
            ENDIF
            SEGDES LRFDU
            NLIGRD=NLIGRD+NDDLDU
            NOFSDU.LECT(IINCDU+1)=NLIGRD
         ENDDO
* Suppression des doublons de LPOQUF
         CALL IUNIQ(LPOQUF.LECT,LPOQUF.LECT(/1),
     $        LPOQUF.LECT,NPOQUF,
     $        IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         JG=NPOQUF
         SEGADJ,LPOQUF
* Segment de repérage dans LPOQUF
         JG=MYMEL.NUM(/1)
         SEGINI,KPOQUF
         CALL RSETXI(KPOQUF.LECT,LPOQUF.LECT,LPOQUF.LECT(/1))
*         SEGPRT,LPOQUF
*         SEGPRT,KPOQUF
*
* Remplissage de l'objet géométrie
*
         NBNN=NPOQUF
         NBELEM=MYMEL.NUM(/2)
         NBSOUS=0
         NBREF=0
         SEGINI,RIGMEL
* Type 32 POLY
         RIGMEL.ITYPEL=32
         DO IBELEM=1,NBELEM
            DO IBNN=1,NBNN
               RIGMEL.NUM(IBNN,IBELEM)=
     $              MYMEL.NUM(LPOQUF.LECT(IBNN),IBELEM)
            ENDDO
         ENDDO
         SEGDES RIGMEL
         SEGSUP LPOQUF
*        SEGPRT,RIGMEL
*
* Remplissage du segment DESCR
*
         SEGINI MYDSCR
*       Primale
         DO IINCPR=1,NINCPR
            IJGVD=LINCPR.LECT(IINCPR)
            IKGVD=TABVDC.DJSVD(IJGVD)
            MDISPR=TABVDC.DISVD(IKGVD)
            CALL KEEF(ITQUAA,MDISPR,MYFALS,
     $           LRFPR,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            SEGACT LRFPR
            NCVAPR=TABVDC.NOMVD(IJGVD)
            SEGACT NCVAPR
            NDDLPR=LRFPR.NPQUAF(/1)
            DO IDDLPR=1,NDDLPR
               ILIGPR=IDDLPR+NOFSPR.LECT(IINCPR)
               ICMPR=LRFPR.NUMCMP(IDDLPR)
               MYDSCR.LISINC(ILIGPR)=NCVAPR.MOTS(ICMPR)
               MYDSCR.NOELEP(ILIGPR)=
     $              KPOQUF.LECT(LRFPR.NPQUAF(IDDLPR))
            ENDDO
            SEGDES NCVAPR
            SEGDES LRFPR
         ENDDO
*       Duale
         DO IINCDU=1,NINCDU
            IJGVD=LINCDU.LECT(IINCDU)
            IKGVD=TABVDC.DJSVD(IJGVD)
            MDISDU=TABVDC.DISVD(IKGVD)
            CALL KEEF(ITQUAA,MDISDU,MYFALS,
     $           LRFDU,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            SEGACT LRFDU
            NCVADU=TABVDC.NOMVD(IJGVD)
            SEGACT NCVADU
            NDDLDU=LRFDU.NPQUAF(/1)
            DO IDDLDU=1,NDDLDU
               ILIGDU=IDDLDU+NOFSDU.LECT(IINCDU)
               ICMDU=LRFDU.NUMCMP(IDDLDU)
               MYDSCR.LISDUA(ILIGDU)=NCVADU.MOTS(ICMDU)
               MYDSCR.NOELED(ILIGDU)=
     $              KPOQUF.LECT(LRFDU.NPQUAF(IDDLDU))
            ENDDO
            SEGDES NCVADU
            SEGDES LRFDU
         ENDDO
         SEGDES MYDSCR
*         SEGPRT,MYDSCR
         SEGSUP KPOQUF
*
* Remplissage du IMATRI
*
         NELRIG=MYMEL.NUM(/2)
         SEGDES MYMEL
         SEGINI MYxMAT
*      NLIGRP et NLIGRD déjà calculés
         DO IVARPR=1,NUMVPR
*            write(ioimp,*) 'ivarpr=',ivarpr
            JGVDPR=TABVDC.VVARPR(IVARPR)
            IF (TABVDC.MVD(JGVDPR).EQ.0) THEN
               IINCPR=KINCPR.LECT(JGVDPR)
*               write(ioimp,*) 'iincpr=',iincpr
               DO IVARDU=1,NUMVDU
*                  write(ioimp,*) 'ivardu=',ivardu
                  JGVDDU=TABVDC.VVARDU(IVARDU)
                  IF (TABVDC.MVD(JGVDDU).EQ.0) THEN
                     IINCDU=KINCDU.LECT(JGVDDU)
*                     write(ioimp,*) 'iincdu=',iincdu
                     IMTLSA=TABMAT.VMAT(IVARDU,IVARPR)
                     IF (IMTLSA.NE.0) THEN
                        SEGACT IMTLSA
                        JMTLSA=IMTLSA.ICHEVA(ISOUS)
                        SEGACT JMTLSA
                        NBLIG=JMTLSA.WELCHE(/1)
                        NBCOL=JMTLSA.WELCHE(/2)
                        N2LIG=JMTLSA.WELCHE(/3)
                        N2COL=JMTLSA.WELCHE(/4)
                        NBPOI=JMTLSA.WELCHE(/5)
                        NBELM=JMTLSA.WELCHE(/6)
                        IOFSPR=NOFSPR.LECT(IINCPR)
                        IOFSDU=NOFSDU.LECT(IINCDU)
*                        write(ioimp,*) 'iofspr=',iofspr
*                        write(ioimp,*) 'iofsdu=',iofsdu
                        NDDLPR=NOFSPR.LECT(IINCPR+1)-IOFSPR
                        NDDLDU=NOFSDU.LECT(IINCDU+1)-IOFSDU
                        IF (NBLIG.NE.NDDLDU.OR.NBCOL.NE.NDDLPR.OR.N2LIG
     $                       .NE.1.OR.N2COL.NE.1.OR.NBPOI.NE.1.OR.NBELM
     $                       .NE.NELRIG) THEN
                           WRITE(IOIMP,*) 'NBLIG=',NBLIG
                           WRITE(IOIMP,*) 'NBCOL=',NBCOL
                           WRITE(IOIMP,*) 'NBELM=',NBELM
                           WRITE(IOIMP,*) 'NDDLDU=',NDDLDU
                           WRITE(IOIMP,*) 'NDDLPR=',NDDLPR
                           WRITE(IOIMP,*) 'NELRIG=',NELRIG


                           WRITE(IOIMP,*) 'Erreur dims JMTLSA'
                           GOTO 9999
                        ENDIF
*                        WRITE(IOIMP,*) 'IINCPR=',IINCPR
*                        WRITE(IOIMP,*) 'IINCDU=',IINCDU
                        DO IELRIG=1,NELRIG
*                           WRITE(IOIMP,*) 'IELRIG=',IELRIG
*                           MYXMAT=MYIMAT.IMATTT(IELRIG)
*                           IF (MYXMAT.EQ.0) THEN
*                              LFIRST=.TRUE.
*                              SEGINI MYXMAT
*                           ELSE
*                              LFIRST=.FALSE.
*                              SEGACT MYXMAT*MOD
*                           ENDIF
                           DO IDDLPR=1,NDDLPR
*                              write(ioimp,*) 'iddlpr=',iddlpr
                              DO IDDLDU=1,NDDLDU
*                                 write(ioimp,*) 'iddldu=',iddldu
                                 MYXMAT.RE(IOFSDU+IDDLDU,IOFSPR+IDDLPR
     $                                ,ielrig)=JMTLSA.WELCHE(IDDLDU
     $                                ,IDDLPR,1,1,1,IELRIG)
                              ENDDO
                           ENDDO
*                           IF (LFIRST) THEN
*                              SEGDES MYXMAT
*                              MYIMAT.IMATTT(IELRIG)=MYXMAT
*                           ELSE
*                              SEGDES MYXMAT
*                           ENDIF
*                           SEGPRT,MYXMAT
                        ENDDO
                        SEGDES JMTLSA
                        SEGDES IMTLSA
                     ENDIF
                  ENDIF
               ENDDO
            ENDIF
         ENDDO
         SEGSUP NOFSDU
         SEGSUP NOFSPR
         SEGDES MYxMAT
*         SEGPRT,MYIMAT
*
* Remplissage du chapeau
*
         MATLSA.COERIG(ISOUS)=1.D0
         MATLSA.IRIGEL(1,ISOUS)=RIGMEL
         MATLSA.IRIGEL(2,ISOUS)=0
         MATLSA.IRIGEL(3,ISOUS)=MYDSCR
         MATLSA.IRIGEL(4,ISOUS)=MYxMAT
         MATLSA.IRIGEL(5,ISOUS)=NIFOUR
         MATLSA.IRIGEL(6,ISOUS)=0
*
* la matrice ne possède pas de symétries (a priori...)
*
         MATLSA.IRIGEL(7,ISOUS)=2
      ENDDO
      SEGDES MATLSA
      IF (IMPR.GT.3) THEN
         WRITE(IOIMP,*) 'On a créé MATLSA=',MATLSA
         CALL ECROBJ('RIGIDITE',MATLSA)
         CALL PRLIST
      ENDIF

      SEGDES CGEOMQ
      SEGSUP KINCPR
      SEGSUP KINCDU
      SEGSUP LINCPR
      SEGSUP LINCDU
      SEGDES TABMAT
      SEGDES TABVDC
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine cv2maa'
      RETURN
*
* End of subroutine CV2MAA
*
      END