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