Sources Esope | Cast3M

part2
C PART2     SOURCE    CB215821  26/08/24    21:17:36     12622          
C   partition de domaine
C  
C       methode utilisee: Monte Carlo avec fonction de cout
C       dérivé de numop2
C
      SUBROUTINE PART2(MELEME,IPOS,NB,ICPR,IADJ,JADJC)
      IMPLICIT INTEGER(I-N)
-INC SMELEME
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO                       
-INC CCASSIS
 
 
        SEGMENT JMEM(NODES+1),JMEMN(NODES+1)
C       JMEM et JMEMN contiennent le nombre d'element auquel appartient un noeud
 
        SEGMENT JNT(NODES)
C       JNT contient la nouvelle numerotation
 
        SEGMENT ICPR(nbpts)
C       ICPR au debut contient l'ancienne numerotation ,
C                               a la fin la nouvelle.
 
        SEGMENT IADJ(NODES+1)
        SEGMENT JADJC(0)
C       IADJ(i) pointe sur JADJC qui contient les voisins de i entre 
C       IADJ(i) et IADJ(i+1)-1
 
        SEGMENT BOOLEEN
          LOGICAL BOOL(NODES)
        ENDSEGMENT
C       BOOL(i) = true si le noeud i a ete deja mentionne dans la liste 
C       des voisins JADJC.
 
        SEGMENT IMEMOIR(NBV),LMEMOIR(NBV)
C       contient les elements appartenant a chaque noeud,sous forme de liste.
 
        INTEGER ELEM
C       nom d'un element
 
        INTEGER N
 
 
        SEGMENT MASQUE
          LOGICAL MASQ(NODES)
        ENDSEGMENT
C       MASQ(X)=.TRUE. si le noeud X n'a pas ete renumerote;
C       .FALSE. si il l'a ete. 
 
        INTEGER DIM,DIMSEP
C       DIM= nombre de noeuds renumerotes.
 
        INTEGER PIVOT
C       PIVOT est le noeud utile a la division du domaine.
 
        SEGMENT IPOS(NODES*3)
C       est le vecteur contenant le numero de zone et le poid de la zone a NODES
C       puis de NODES+1 a 2* NODES, cf la subroutine SEPAR
C
C  segments utilisés dans sepa2
C
        SEGMENT NRELONG(NODES*nbthr)
C       NRELONG contient pour chaque noeud sa profondeur.
 
        SEGMENT NOELON(NODES*nbthr)
        SEGMENT NOEL2(NODES)
        SEGMENT LONDIM(NODES*nbthr)
C       NOELON contient les noeuds de profondeur LONG.
C       DIMLON= dimension de NOELON.
c
C**********************************
 
C debut du program 
 
C**********************************
 
 
 
C       initialisation
C*******************************
        IUN=1
        IENORM=2000000000
C       norme d'erreur
        SEGINI ICPR
        NODES=ICPR(/1)
        SEGACT MELEME
C       icpr: numero des noeuds.
 
        IPT1=MELEME
        IKOU=0
        NBV=0
        NB1=0
        NB2=0
 
        DO 100 IO=1,MAX(1,LISOUS(/1))
           IF (LISOUS(/1).GT.0) THEN
                IPT1=LISOUS(IO)
                SEGACT IPT1
           ENDIF
C          on cree la numerotation des noeuds.
C          'nb noeuds/element'=IPT1.NUM(/1) 
C          'nb element'=IPT1.NUM(/2)
           IF(IPT1.ITYPEL.EQ.22) THEN
             NB1=NB1+IPT1.NUM(/2) 
             NB2=MAX(NB2,IPT1.NUM(/1))
C            NB1= nbre d'éléments de type 22.
C            NB2=nbre de noeuds/élément maximum parmi
C                 les éléments de type 22.
           ENDIF
           DO 601 J=1,IPT1.NUM(/2)
           DO 150 I=1,IPT1.NUM(/1) 
               IJ=IPT1.NUM(I,J)
C              IJ est le Ième noeud du Jème élément.
               IF (ICPR(IJ).EQ.0) THEN
C              s'il est déjà numéroté, on ne fait rien.
                 IKOU=IKOU+1
                 ICPR(IJ)=IKOU
               ENDIF
150        CONTINUE
  601      CONTINUE
100     CONTINUE
 
        NODES=IKOU
 
C*****  initalisation des segments*********
 
        SEGINI IADJ,JADJC,JMEM,JMEMN
        SEGINI BOOLEEN,JNT
 
        DO 20 I=1,NODES+1                                            
                IADJ(I)=0 
                JMEM(I)=0
                JMEMN(I)=0
20      CONTINUE
 
C******************************************
 
        IPT1=MELEME
        NGRAND=0
        IADJ(1)=1
        INC=0
        DO 200 IO=1,MAX(1,LISOUS(/1))
 
            IF (LISOUS(/1).NE.0) THEN
               IPT1=LISOUS(IO)
            ENDIF
 
            DO 210 J=1,IPT1.NUM(/2)
 
            DO  230 I=1,IPT1.NUM(/1)
               IJ=ICPR(IPT1.NUM(I,J))+1
               JMEM(IJ)=JMEM(IJ)+1
C              JMEM(I+1): nb elements auquel le noeud I appartient
230         CONTINUE
210         CONTINUE
            NGRAND=MAX(NGRAND,IPT1.NUM(/2))
 
200     CONTINUE
 
        NGRAND=NGRAND+1
 
        JMEM(1)=1
        DO 30 I=1,NODES
            JMEM(I+1)=JMEM(I)+JMEM(I+1)
C           JMEM(I+1)=indice de depart des elements
C           auxquels le noeud I appartient.
30      CONTINUE
        NBV=JMEM(NODES+1)
C       NBV= dimension de IMEMOIR.
        SEGINI IMEMOIR,LMEMOIR
 
 
 
        IPT1=MELEME
 
        DO 300 IO=1,MAX(1,LISOUS(/1))
           IF (LISOUS(/1).NE.0) THEN 
                IPT1=LISOUS(IO)
           ENDIF
           DO 602 J=1,IPT1.NUM(/2)
           DO 350 I=1,IPT1.NUM(/1)
               IJ=ICPR(IPT1.NUM(I,J))
              JMEMN(IJ+1)=JMEMN(IJ+1)+1
              IMEMOIR(JMEM(IJ)+JMEMN(IJ+1)-1)=J
              LMEMOIR(JMEM(IJ)+JMEMN(IJ+1)-1)=IO
C             on range dans IMEMOIR tous les elements des sous-objets 
C             IO auxquels appartient le noeud ICPR(IPT1.NUM(I,J)).
C             On connait pour chaque element, le sous-objet auquel
C             il appartient.
350        CONTINUE
  602      CONTINUE
300     CONTINUE
 
           DO 410 J=1,NODES
                BOOL(J)=.FALSE.
410        CONTINUE
        DO 400 I=1,NODES
           IADJ(I+1)=IADJ(I)
           DO 420 J=JMEM(I),JMEM(I+1)-1
               ELEM=IMEMOIR(J)
C              ELEM=element auquel appartient le noeud I.
 
               IPT1=MELEME
               IF (LISOUS(/1).NE.0) IPT1=LISOUS(LMEMOIR(J))
               DO 430 K=1,IPT1.NUM(/1)
C              k representatif du nb de noeuds par elements.
                  IK=ICPR(IPT1.NUM(K,ELEM))
                  IF ((I.NE.IK).AND.
     &                 (.NOT.(BOOL(IK)))) THEN 
C                 si i n'est pas  egal a un des nouveaux numeros des noeuds
C                 de l'element ELEM et si il n'appartient pas deja  a l'ens des 
C                 voisins du noeud i(jadjc(i)),alors on le rajoute.
C                   JADJC(IADJ(I+1))=IK
                    JADJC(**)=IK
                    IADJ(I+1)=IADJ(I+1)+1
                    BOOL(IK)=.TRUE.
                  ENDIF
430            CONTINUE
420        CONTINUE
*  remise a faux de bool
           DO 412 J=IADJ(I),IADJ(I+1)-1
             IK=JADJC(J)
             BOOL(IK)=.FALSE.
412        CONTINUE
400     CONTINUE
 
        SEGSUP JMEM,JMEMN,IMEMOIR,LMEMOIR,BOOLEEN
 
 
 
C**************************************************************************
 
 
C       affectation
C************************
 
 
        SEGINI IPOS,MASQUE
        IPOSMAX=0
 
        DO 50 I=1,NODES
           MASQ(I)=.TRUE.
           IPOS(I)=0
           IPOS(NODES+I)=0
           IPOS(2*NODES+I)=0
50      CONTINUE
C       initialement, les noeuds ne sont pas masques,ont donc
C       une position nulle.
 
        DIM=0
C       le nombre de noeuds renumerotes  DIM est initialement egal a zero.
 
 
C               ****************************************
C                       boucle principale
        NS=NODES
 
        nbthr=max(1,nbthrs)
        nbthr=min(64,nbthr)
        if (nbthr.gt.1) call threadii
        SEGINI NRELONG,NOELON,noel2,londim
**      write (6,*) ' avant appel sepa2 '
        DO 500 I=1,NODES
 550      IF (ipos(i+2*nodes).eq.nb) masq(i)=.false.
**        write (6,*) ' part2 i ipos nb ',i,ipos(i+2*nodes),nb
          IF(.NOT.MASQ(I)) GOTO 500
C         si le noeud est masque alors ne rien faire: il est deja
C         renumerote. On passe au noeud suivant.
 
          PIVOT=I
          CALL SEPA2(IADJ,JADJC,PIVOT,MASQUE,DIMSEP,NS,
     >      IPOS,NODES,IPOSMAX,nrelong,noelon,noel2,
     >      londim,nbthr,IUN)
C         separe le domaine d'etude en 2 parties.
C         on decrit le domaine d'etude a partir du pivot et on cherche la
C         longueur maximale en decrivant les voisins de pivot, et leurs
C         voisins... jusqu'a rencontrer un voisin masque. On cree alors
C         une nouvelle separation.
C         les noeuds masques delimitent la separation du domaine.
          do ii=1,nodes
            IF (ipos(ii+2*nodes).eq.nb) masq(ii)=.false.
          enddo
 
          DIM=DIM+DIMSEP
          NS=NS-DIMSEP
C         la dimension de noeuds renumerotes est augmente de DIMSEP.
C         Celle de noeuds a renumeroter est diminue de DIMSEP.
 
*****     IF (DIM.GE.NODES) GOTO 600
C         si tous les noeuds ont ete renumerotes, on arrete.
 
          GOTO 550
 
500     CONTINUE
**      write (6,*) ' apres appel sepa2 '
 
        SEGSUP NRELONG,NOELON,noel2,londim
        if (nbthr.gt.1) call threadis
 
 
600     SEGSUP MASQUE
*
*       CALL SORTI2(IPOS,JNT,NODES)
**      write (6,*) ' apres sorti2 '
 
        SEGSUP JNT
 
 
        RETURN
        END