C DESCAR    SOURCE    GOUNAND   25/06/11    21:15:07     12278          
      SUBROUTINE DESCAR(DES1,IPRI,DES3)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : DESCAR
C DESCRIPTION : A partir d'un descripteur DES1 en entree, on construit
C     un descripteur carre, soit base sur les inconnues
C     primales (ipri=1), soit sur les inconnues duales (ipri=2)
C     Si le descripteur est deja carre, on le renvoie
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
C               mel : gounand@semt2.smts.cea.fr
C***********************************************************************
C ENTREES            : DES1 IPRI
C ENTREES/SORTIES    :
C SORTIES            : DES3
C***********************************************************************
C VERSION    : v1, 26/05/2025, version initiale
C HISTORIQUE : v1, 26/05/2025, creation
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC SMRIGID
      logical lcar
      CHARACTER*(LOCHPO) NOMINC,NOMDUA
*
* Executable statements
*
      nligrp=des1.noelep(/1)
      nligrd=des1.noeled(/1)
      if (nligrp.ne.nligrd) goto 13
      do ilig=1,nligrp
         if (des1.noelep(ilig).ne.des1.noeled(ilig)) goto 13
      enddo
      do ilig=1,nligrp
         nominc=des1.lisinc(ilig)
         CALL PLACE(NOMDD,LNOMDD,IPLA,NOMINC)
         IF (IPLA.EQ.0) THEN
            nomdua=nominc
         ELSE
            nomdua=nomdu(ipla)
         ENDIF
         if (des1.lisdua(ilig).ne.nomdua) goto 13
      enddo
* Carré
      des3=des1
      return
 13   CONTINUE
* Pas carré
      if (ipri.eq.1) then
         nligrp=des1.noelep(/1)
         nligrd=nligrp
         segini des3
         do iligrp=1,nligrp
            nno=des1.noelep(iligrp)
            des3.noelep(iligrp)=nno
            des3.noeled(iligrp)=nno
            nominc=des1.lisinc(iligrp)
            des3.lisinc(iligrp)=nominc
            CALL PLACE(NOMDD,LNOMDD,IPLA,NOMINC)
            IF (IPLA.EQ.0) THEN
               des3.lisdua(iligrp)=nominc
            ELSE
               des3.lisdua(iligrp)=nomdu(ipla)
            ENDIF
         enddo
      elseif (ipri.eq.2) then
         nligrd=des1.noeled(/1)
         nligrp=nligrd
         segini des3
         do iligrd=1,nligrd
            nno=des1.noeled(iligrd)
            des3.noeled(iligrd)=nno
            des3.noelep(iligrd)=nno
            nomdua=des1.lisdua(iligrd)
            des3.lisdua(iligrd)=nomdua
            CALL PLACE(NOMDU,LNOMDU,IPLA,NOMDUA)
            IF (IPLA.EQ.0) THEN
               des3.lisinc(iligrd)=nomdua
            ELSE
               des3.lisinc(iligrd)=nomdd(ipla)
            ENDIF
         enddo

      else
         write(ioimp,*) 'ipri=',ipri
         call erreur(5)
         return
      endif
*
* Normal termination
*
      RETURN
*
* Format handling
*
*
* Error handling
*
*
* End of subroutine DESCAR
*
      END