C KRES24    SOURCE    GOUNAND   25/07/16    21:15:03     12325          
      SUBROUTINE KRES24(KMINCT,KMORS,NNUTOT,MLAG1,MLAG2,
     $        IPERM)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C     NOM         : KRES24
C     DESCRIPTION : - Placer correctement les multiplicateurs de
C                     Lagrange dans le MATRIK
C
C                     Ce source est une adaptation de KRES14
C
C     LANGAGE     : ESOPE
C     AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C     mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C     VERSION    : v1, 22/04/2025, version initiale
C     HISTORIQUE : v1, 22/04/2025, création
C     HISTORIQUE :
C     HISTORIQUE :
C***********************************************************************

-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC SMMATRIK
      POINTEUR KMINCT.MINC
      POINTEUR KMORS.PMORS

-INC SMLENTI
      POINTEUR KTYP.MLENTI
      POINTEUR KRINC.MLENTI
      POINTEUR LAGRAN.MLENTI
      POINTEUR JORDRE.MLENTI,JORTMP.MLENTI
      POINTEUR IPERM.MLENTI,JPETMP.MLENTI
      POINTEUR JPERM.MLENTI,NNUTOT.MLENTI
-INC SMLMOTS
      POINTEUR MLAG1.MLMOTS,MLAG2.MLMOTS
      CHARACTER*(LOCHPO) CHCOMP
      LOGICAL LTIME,LDBNUM,LVERIF
C
C     Executable statements
C
      LDBNUM=.FALSE.
      LVERIF=.FALSE.
*     Pour un non multigrille, il faut quand même placer les
*     multiplicateurs correctement avant et après les inconnues
*     KTYP=-1 multiplicateurs avant
*     KTYP=0  inconnues normales
*     KTYP=+1 multiplicateurs apres
*     IL faut distinguer les 'LX' qui ont deja ete renumerotes et les
*     LXP, MXP
      SEGACT KMINCT
      NCOMP=KMINCT.LISINC(/2)
      NNOE=KMINCT.MPOS(/1)
      INC=KMINCT.NPOS(NNOE+1)-1
      JG=INC
      SEGINI KTYP
*      SEGPRT,KMINCT
      NBLAG=0
      NBNLA=0
      if (mlag1.ne.0) segact mlag1
      if (mlag2.ne.0) segact mlag2
*
      DO ICOMP=1,NCOMP
         CHCOMP=KMINCT.LISINC(ICOMP)
         JTYP=0
         IF (CHCOMP(1:8).EQ.'LX      ') THEN
* Avec les MATRIK, on ne gère que les simples multiplicateurs
            JTYP=2
         ELSE
            if (mlag1.ne.0) then
               CALL PLACE(mlag1.mots,mlag1.mots(/2),imot,chcomp)
               if (imot.ne.0) then
                  JTYP=1
                  GOTO 33
               endif
            else
               IF (CHCOMP(1:2).EQ.'LX') THEN
                  JTYP=1
                  GOTO 33
               endif
            endif
            if (mlag2.ne.0) then
               CALL PLACE(mlag2.mots,mlag2.mots(/2),imot,chcomp)
               if (imot.ne.0) then
                  JTYP=-1
                  GOTO 33
               endif
            else
               IF (CHCOMP(1:2).EQ.'MX') THEN
                  JTYP=-1
                  GOTO 33
               endif
            endif
         ENDIF
 33      CONTINUE
         DO INOE=1,NNOE
            IPOS=KMINCT.MPOS(INOE,ICOMP)
            IF (IPOS.NE.0) THEN
               JPOS=KMINCT.NPOS(INOE)+IPOS-1
               KTYP.LECT(JPOS)=JTYP
               IF (JTYP.NE.0) THEN
                  NBLAG=NBLAG+1
               ELSE
                  NBNLA=NBNLA+1
               ENDIF
            ENDIF
         ENDDO
      ENDDO
*
      if (ldbnum) write(ioimp,*) 'avant tri ktyp=-3'
      if (ldbnum) segprt,ktyp
*
      IF (NBLAG.EQ.0) THEN
         IPERM=NNUTOT
         RETURN
      ENDIF
      NBDDL=NBLAG+NBNLA
      JG=NBLAG
      SEGINI LAGRAN
      ILAG=0
      DO IDDL=1,NBDDL
         ITYP=KTYP.LECT(IDDL)
         IF (ITYP.NE.0) THEN
            ILAG=ILAG+1
            LAGRAN.LECT(ILAG)=IDDL
         ENDIF
      ENDDO
      if (ldbnum) write(ioimp,*) 'apres tri ktyp=-3'
      if (ldbnum) SEGPRT,KTYP
      IF (NBLAG.NE.ILAG) GOTO 9999
*
*     Placement des multiplicateurs inspiré de NUMOP2
*
      segact nnutot
      iperm=nnutot
      IF (NBLAG.EQ.0) GOTO 2000
      JG=NBDDL
      SEGINI,JPERM
      DO I=1,NBDDL
         JPERM.LECT(NNUTOT.LECT(I))=I
      ENDDO
*      SEGINI,JPERM=NNUTOT
*     Il y a cinq types différents de -2 à 2 : il faut pouvoir placer
*     les multiplicateurs de lagrange entre les autres noeuds
      NTYP=5
      JG=NBDDL
      SEGINI JORDRE
      DO I=1,NBDDL
         JORDRE.LECT(I)=I*NTYP
      ENDDO
      JORMAX= (NBDDL+1)*NTYP

      if (ldbnum) write(ioimp,*) 'Avant mise a la bonne place'
      if (ldbnum) segprt,jordre
*     mise a la bonne place des multiplicateurs de Lagrange
      SEGACT KMORS
      NTT=KMORS.IA(/1)-1
      IF (NTT.NE.NBDDL) THEN
         write(ioimp,*) 'Pas egaux NTT,NBDDL=',NTT,NBDDL
         GOTO 9999
      ENDIF
      do 700 J=1,NBLAG
         IDDL=LAGRAN.LECT(J)
         ITYP=KTYP.LECT(IDDL)
         ICOLD=KMORS.IA(IDDL)
         ICOLF=KMORS.IA(IDDL+1)-1
         iddln=nnutot.lect(iddl)
*         if (ldbnum)write(ioimp,*) 'iddl,ityp,iddln=',iddl,ityp,iddln
*     write (6,*) 'kres24 ',(kmors.JA(icol),icol=icold,icolf)
         ipaur=-igrand
         ipaus=igrand
         do 800 ICOL=ICOLD,ICOLF
            JDDL=KMORS.JA(ICOL)
            JTYP=KTYP.LECT(JDDL)
            IF (ABS(ITYP).NE.ABS(JTYP)) THEN
               JDDLN=NNUTOT.LECT(JDDL)
*               write(ioimp,*) '  jddl,jtyp,jddln=',jddl,jtyp,jddln
*     deplacer les noeuds en relation en fin de zone
               jordre.lect(jddln)=-abs(jordre.lect(jddln))
               ipaur=max(ipaur,jordre.lect(jddln))
               ipaus=min(ipaus,jordre.lect(jddln))
            else
*               write(ioimp,*) '  jddl,jtyp=',jddl,jtyp
            endif
 800     continue
*
*     On va laisser comme ça
*     Ce cas peut arriver après élimination
*     Cela devrait revenir à placer les multiplicateurs en fin ou début
*     de matrice
         if (ipaur.eq.-igrand.or.ipaus.eq.igrand) then
*            Write(ioimp,*) 'mulag sans relations pas ok'
*            goto 9999
            ipaur=0
            ipaus=-jormax
         endif
         if (ldbnum) write(ioimp,*) 'iddl,ipaur,ipaus=',iddl,ipaur
     $        ,ipaus
*
*     le premier mult avant le premier noeud
         IF (ITYP.EQ.-2) THEN
            JORDRE.LECT(IDDLN)=ipaur+2
         ELSEIF (ITYP.EQ.-1) THEN
            JORDRE.LECT(IDDLN)=ipaur+1
*
*     le deuxieme mult apres le dernier noeud
         ELSEIF (ITYP.EQ.1) THEN
            JORDRE.LECT(IDDLN)= ipaus-1
         ELSEIF (ITYP.EQ.2) THEN
            JORDRE.LECT(IDDLN)= ipaus-2
         ELSEIF (ITYP.NE.0) THEN
            write(ioimp,*) 'ityp=',ityp,' non prevu'
            goto 9999
         ENDIF
*
 700  continue
*     WRITE(IOIMP,*) 'Avant chgt signe'
*     segprt,jordre
      DO I=1,NBDDL
         JORDRE.LECT(I)=-JORDRE.LECT(I)
      ENDDO
*     Avant tri
      if (ldbnum) WRITE(IOIMP,*) 'Avant TRIFUS'
      if (ldbnum) SEGPRT,JPERM
      if (ldbnum) SEGPRT,JORDRE
      JG=NBDDL
      SEGINI JORTMP
      SEGINI JPETMP
*     ok maintenant on trie
      CALL TRIFUS(NBDDL,JORDRE.LECT,JPERM.LECT,JORTMP.LECT
     $     ,JPETMP.LECT)
      SEGSUP JPETMP
      SEGSUP JORTMP
*     Apres tri
      if (ldbnum) WRITE(IOIMP,*) 'Apres TRIFUS'
      if (ldbnum) SEGPRT,JPERM
      if (ldbnum) SEGPRT,JORDRE
*     permutation inverse
      JG=NBDDL
      SEGINI IPERM
      DO I=1,NBDDL
         IPERM.LECT(JPERM.LECT(I))=I
      ENDDO
*     Verification que dans la nouvelle numerotation les multiplicateurs
*     sont correctement places...
      IF (LVERIF) THEN
         write(ioimp,*) 'VERIF KRES24'
         do 1700 J=1,NBLAG
            IDDL=LAGRAN.LECT(J)
            ITYP=KTYP.LECT(IDDL)
            ICOLD=KMORS.IA(IDDL)
            ICOLF=KMORS.IA(IDDL+1)-1
            iddln=iperm.lect(iddl)
            ipaur=-igrand
            ipaus=igrand
            do 1800 ICOL=ICOLD,ICOLF
               JDDL=KMORS.JA(ICOL)
               JTYP=KTYP.LECT(JDDL)
               IF (ABS(ITYP).NE.ABS(JTYP)) THEN
                  JDDLN=IPERM.LECT(JDDL)
                  ipaur=max(ipaur,jddln)
                  ipaus=min(ipaus,jddln)
               endif
 1800       continue
            if (ldbnum) write(ioimp,*) 'iddl,ipaur,ipaus=',iddl,ipaur
     $           ,ipaus
            if (ipaur.eq.-igrand.or.ipaus.eq.igrand) then
               goto 1700
*     Write(ioimp,*) 'mulag sans relations pas ok'
*     goto 9999
            endif
            if (ityp.lt.0) THEN
               if (ipaus.le.iddln) then
                  write(ioimp,*) 'Erreur numerotation'
                  write(ioimp,*) 'iddl,iddln,ipaus=',iddl,iddln,ipaus
                  goto 9999
               endif
            elseif (ityp.gt.0) THEN
               if (ipaur.ge.iddln) then
                  write(ioimp,*) 'Erreur numerotation'
                  write(ioimp,*) 'iddl,iddln,ipaur=',iddl,iddln,ipaur
                  goto 9999
               endif
            else
               write(ioimp,*) 'ityp=0 pas normal pour un lagrange'
               goto 9999
            endif
 1700    continue
      ENDIF
*
*     Menage
*
      SEGSUP,JPERM
 2000 CONTINUE
      SEGSUP JORDRE
      SEGSUP LAGRAN
      SEGSUP KTYP
*      iperm=jperm
*      write(ioimp,*) 'FIN KRES24'
      if (ldbnum) segprt,nnutot
      if (ldbnum) segprt,iperm
C
C     Normal termination
C
      RETURN
C
C     Error Handling
C
 9999 CONTINUE
      MOTERR(1:8)='KRES24  '
      CALL ERREUR(1127)
      RETURN
C
C     Format handling
C
C 2022 FORMAT(10(1X,1PG12.5))
C
C     End of subroutine KRES24
C
      END