C KRES13    SOURCE    SP204843  26/02/03    21:15:26     12461          
      SUBROUTINE KRES13(MRIGID,KMORS,KIZA,ISMBR,IORINC,KTYPI,
     $     IPERM,JPERM,IPBLOC)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C     NOM         : KRES13
C     DESCRIPTION : - Reordonnancer par bloc pour le multigrille
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     VERSION    : v1, 10/04/2025, version initiale
C     HISTORIQUE : v1, 10/04/2025, création
C     HISTORIQUE :
C     HISTORIQUE :
C***********************************************************************

-INC PPARAM
-INC CCOPTIO
-INC CCREEL
C     On inclue SMCOORD car MCHSOL doit avoir la configuration courante
-INC SMCOORD
-INC SMCHPOI
      POINTEUR MCHSOL.MCHPOI
-INC SMRIGID
-INC SMVECTD
      POINTEUR ASMBR.MVECTD
      POINTEUR ISMBR.MVECTD
      POINTEUR INCX.MVECTD
      POINTEUR IR.MVECTD
-INC SMMATRI
      SEGMENT PMORS
      INTEGER IA (NTT+1)
      INTEGER JA (NJA)
      ENDSEGMENT
      POINTEUR PMS1.PMORS,PMS2.PMORS
      POINTEUR KMORS.PMORS,AMORS.PMORS
C     Segment de stokage
      SEGMENT IZA
      REAL*8  A(NBVA)
      ENDSEGMENT
      POINTEUR IZA1.IZA,IZA2.IZA,IZAU.IZA,IZAL.IZA,ISA.IZA
      POINTEUR KIZA.IZA,AIZA.IZA
-INC SMLENTI
      POINTEUR KTYINC.MLENTI
      POINTEUR KTYDDL.MLENTI
      POINTEUR KNODDL.MLENTI
      POINTEUR KRINC.MLENTI
      POINTEUR IWORK.MLENTI
      POINTEUR LAGRAN.MLENTI
      POINTEUR JORDRE.MLENTI,JORTMP.MLENTI
      POINTEUR IPERM.MLENTI,JPETMP.MLENTI
      POINTEUR JPERM.MLENTI
      POINTEUR IBLOCK.MLENTI,IPBLOC.MLENTI
-INC SMLOBJE
      POINTEUR IORINC.MLOBJE
-INC SMLMOTS
      POINTEUR JORINC.MLMOTS,JORINU.MLMOTS
-INC SMTABLE
      POINTEUR KTIME.MTABLE
      DIMENSION ITTIME(4)
      CHARACTER*(LOCHPO) CHCOMP
      CHARACTER*16 CHARI
      CHARACTER*1 CCOMP
      LOGICAL LTIME,LOGII,LNOD,LBLOCK,LOK
      REAL*8 GNRM2
C
C     Executable statements
C
      LNOD=(KTYPI.EQ.11)
      SEGACT MRIGID
      MMATRI=ICHOLE
      SEGACT MMATRI
      MINCPO=IINCPO
      SEGACT MINCPO
      NCOMP=INCPO(/1)
      NNOE=INCPO(/2)
      INC=ISMBR.VECTBB(/1)
      JG=INC
      SEGINI KTYDDL
      KNODDL=0
      IF (LNOD) SEGINI KNODDL
      MIMIK=IIMIK
*      write(ioimp,*) 'coucou mimik'
*      SEGACT,MIMIK
*      SEGPRT,MIMIK
*      WRITE(IOIMP,*) 'NCOMP,IORINC= ',NCOMP,IORINC
*
      IF (IORINC.NE.0) THEN
         SEGACT IORINC
         NTYINC=IORINC.LISOBJ(/1)
         JGN=0
         JGM=0
         DO ITYINC=1,NTYINC
            MLMOTS=IORINC.LISOBJ(ITYINC)
            SEGACT MLMOTS
            JGN=MAX(JGN,MOTS(/1))
            JGM=JGM+MOTS(/2)
         ENDDO
         SEGINI,JORINC
         SEGINI,JORINU
         JG=JGM
         IG=0
         SEGINI KTYINC
         DO ITYINC=1,NTYINC
            MLMOTS=IORINC.LISOBJ(ITYINC)
            DO J=1,MOTS(/2)
               IG=IG+1
               JORINC.MOTS(IG)=MOTS(J)
               KTYINC.LECT(IG)=ITYINC
            ENDDO
         ENDDO
*     write(ioimp,*) 'JGN,JGM=',JGN,JGM
         CALL CUNIQ(JORINC.MOTS,JGN,JGM,JORINU.MOTS,JGMU,IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         IF (JGM.NE.JGMU) THEN
            WRITE(IOIMP,*) 'IORINC ne doit pas avoir de doublons'
            GOTO 9999
         ENDIF
         SEGSUP JORINU
         IF (JGM.NE.NCOMP) THEN
            WRITE(IOIMP,*) 'IORINC doit referencer toutes'
     $           ,'les inconnues de la matrice'
            GOTO 9999
         ENDIF
         JG=NCOMP
         SEGINI KRINC
         CALL CREPER(JGN,NCOMP,JGM,MIMIK.IMIK,JORINC.MOTS,KRINC.LECT
     $        ,IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
      ELSE
         NTYINC=NCOMP
      ENDIF
      IF (IIMPI.NE.0) THEN
         WRITE(IOIMP,*) 'NCOMP= ',NCOMP
         WRITE(IOIMP,*) 'MIMIK.IMIK(1..',NCOMP,')= '
         WRITE(IOIMP,*)(MIMIK.IMIK(II),II=1,NCOMP)
         IF (IORINC.NE.0) THEN
            WRITE(IOIMP,*) 'JORINC.MOTS(1..',NCOMP,')= '
            WRITE(IOIMP,*)(JORINC.MOTS(II),II=1,NCOMP)
            WRITE(IOIMP,*) 'KRINC.LECT(1..',NCOMP,')= '
            WRITE(IOIMP,*)(KRINC.LECT(II),II=1,NCOMP)
         ENDIF
      ENDIF
*
*      segprt,mincpo
      DO ICOMP=1,NCOMP
         DO INOE=1,NNOE
            IG=INCPO(ICOMP,INOE)
            IF (IG.GT.0) THEN
               IF (IORINC.ne.0) then
                  KTYDDL.LECT(IG)=KTYINC.LECT(KRINC.LECT(ICOMP))
               ELSE
                  KTYDDL.LECT(IG)=ICOMP
               ENDIF
               IF (LNOD) KNODDL.LECT(IG)=INOE
            ENDIF
         ENDDO
      ENDDO
*      segprt,ktyddl
*      segprt,knoddl
*     1) Trouver le nombre de blocs
      NBLOCK=NTYINC
      ntt=inc
      nja=kiza.a(/1)
      if (iimpi.ne.0) then
         write(ioimp,*) 'Nb d''inconnues=',ntt
         write(ioimp,*) 'Nb de termes=',kmors.ja(/1)
         write(ioimp,*) 'Nb de termes 2=',nja
         write(ioimp,*) 'Nb de blocs detectes nblock=',nblock
      endif
      JG=NBLOCK+1
      SEGINI IBLOCK
      lblock=nblock.gt.1
 187  FORMAT (5X,10I8)
      if (lblock) then
         jg=ntt
         segini iperm
         segini jperm
*
*     2) Trouver le nombre d'inconnus par blocs
         DO i=1,ntt
            jblock=ktyddl.lect(i)
            iblock.lect(jblock)=iblock.lect(jblock)+1
         enddo
         if (iimpi.ne.0) then
            write(ioimp,*) 'Nb inconnues par blocs'
            write(ioimp,187)  (iblock.lect(I),I=1,iblock.lect(/1))
         endif
*     3) D'où le segment de repérage
         do i=nblock,1,-1
            iblock.lect(i+1)=iblock.lect(i)
         enddo
         if (iimpi.ne.0) then
            write(ioimp,*) 'Segment de repérage tmp'
            write(ioimp,187)  (iblock.lect(I),I=1,iblock.lect(/1))
         endif
         iblock.lect(1)=1
         do i=1,nblock
            iblock.lect(i+1)=iblock.lect(i+1)+iblock.lect(i)
         enddo
         if (iimpi.ne.0) then
            write(ioimp,*) 'Segment de repérage'
            write(ioimp,187)  (iblock.lect(I),I=1,iblock.lect(/1))
         endif
*     4) Construction des permutations
         ntt=kmors.ia(/1)-1
         if (iimpi.ne.0) then
            write(ioimp,*) 'Nb d''inconnues 2 ntt=',ntt
         endif
         ktt=0
         do kblock=1,nblock
            do itt=1,ntt
               jblock=ktyddl.lect(itt)
               if (kblock.eq.jblock) then
                  ktt=ktt+1
                  iperm.lect(itt)=ktt
                  jperm.lect(ktt)=itt
               endif
            enddo
         enddo
*         write(ioimp,*) 'Permutation i'
*         write(ioimp,187)  (iperm.lect(I),I=1,iperm.lect(/1))
*         write(ioimp,*) 'Permutation j'
*         write(ioimp,187)  (jperm.lect(I),I=1,jperm.lect(/1))
      else
         iperm=0
         jperm=0
         iblock.lect(1)=1
         iblock.lect(2)=ntt+1
         if (iimpi.ne.0) then
            write(ioimp,*) 'Segment de repérage'
            write(ioimp,187)  (iblock.lect(I),I=1,iblock.lect(/1))
         endif
      endif
*
* Changement automatique du signe des lignes de la matrice
* et du second membre si le terme diagonal est négatif.
*
*     segprt,kmors
*     segprt,kiza
      ICHNG=0
      DO I=1,NTT
         IFOUND=0
         DO J=KMORS.IA(I),(KMORS.IA(I+1)-1)
*            WRITE(IOIMP,*) 'I,J=',I,J
*            WRITE(IOIMP,*) 'JA(J)=',KMORS.JA(J)
            IF (KMORS.JA(J).EQ.I) THEN
*               WRITE(IOIMP,*) 'KIZA.A(J)=',KIZA.A(J)
               IF (KIZA.A(J).GT.XZERO) THEN
                  IFOUND=1
               ELSEIF (KIZA.A(J).LT.XZERO) THEN
                  IFOUND=-1
               ENDIF
               GOTO 10
            ENDIF
         ENDDO
 10      CONTINUE
*         WRITE(IOIMP,*) 'IFOUND=',IFOUND
         IF (IFOUND.EQ.0) THEN
            LOK=.FALSE.
*     Le pivot a le droit d'etre nul s'il s'agit du dernier bloc pour la
*     methode AGMGStokes
            IF (KTYPI.EQ.10) THEN
               IF (KTYDDL.LECT(I).EQ.NBLOCK) THEN
                  LOK=.TRUE.
               ENDIF
            ENDIF
            IF (.NOT.LOK) THEN
               WRITE(IOIMP,*) 'The ',I
     $              ,'th diagonal term of the matrix is nil'
               IF (LNOD) THEN
                  write(ioimp,*) 'Node =',KNODDL.LECT(I)
               ENDIF
               write(ioimp,*) 'Bloc =',KTYDDL.LECT(I)
               IRET=-3
               GOTO 9999
            ENDIF
         ELSEIF (IFOUND.EQ.-1) THEN
            ICHNG=ICHNG+1
            ISMBR.VECTBB(I)=-1.D0*ISMBR.VECTBB(I)
            DO J=KMORS.IA(I),(KMORS.IA(I+1)-1)
               KIZA.A(J)=-1.D0*KIZA.A(J)
            ENDDO
         ENDIF
      ENDDO
      IF (ICHNG.GT.0) THEN
         Write(ioimp,*) 'On a change le signe de ',ICHNG,' lignes'
      ENDIF
*
* Verifier que les blocs sont de meme taille pour NS
*
      if (ktypi.eq.10.or.ktypi.eq.11) then
         IF (.NOT.lblock) THEN
            write(ioimp,*) 'The AGMG Stokes and NS solvers need blocks'
            goto 9999
         ENDIF
         if (ktypi.eq.11) then
            nddl1=iblock.lect(2)-iblock.lect(1)
            do i=2,nblock
               nddl=iblock.lect(i+1)-iblock.lect(i)
               if (nddl.ne.nddl1) then
                  write(ioimp,*) 'Le bloc ',i,' de taille =',nddl
                  write(ioimp,*) 'na pas la meme taille que le bloc 1 ='
     $                 ,nddl1
                  goto 9999
               endif
            enddo
*
*     Verif que les inconnues sont dans le même ordre à l'intérieur de
*     chaque bloc
*
            do i=2,nblock
               nddl=iblock.lect(i+1)-iblock.lect(i)
               ideb=iblock.lect(i)
               do iddl=1,nddl
                  inod1=knoddl.lect(jperm.lect(iddl))
                  inodi=knoddl.lect(jperm.lect(ideb+iddl-1))
                  if (inodi.ne.inod1) then
                     write(ioimp,*) 'Dans le bloc ',i,' le ddl ',iddl
     $                    ,' porte sur le noeud inodi=',inodi
                     write(ioimp,*) 'Dans le bloc ',1,' le ddl ',iddl
     $                    ,' porte sur le noeud inod1=',inod1
                     write(ioimp,*) 'inod1 != inodi est une erreur !'
                     goto 9999
                  endif
               enddo
            enddo
         endif
      endif
*
      IF (IORINC.NE.0) THEN
         SEGSUP KRINC
         SEGSUP KTYINC
         SEGSUP JORINC
      ENDIF
      IF (LNOD) SEGSUP KNODDL
      SEGSUP KTYDDL


      IPBLOC=IBLOCK
C
C Normal termination
C
      RETURN
C
C Error Handling
C
 9999 CONTINUE
      MOTERR(1:8)='KRES13  '
      CALL ERREUR(1127)
      RETURN
C
C Format handling
C
 2022 FORMAT(10(1X,1PG12.5))
C
C End of subroutine KRES13
C
      END