C ORDON4 SOURCE CB215821 23/01/25 21:15:27 11573 SUBROUTINE ORDON4 (MELEME) ************************************************************************ * O R D O N N * ----------- * SOUS-PROGRAMME ASSOCIE A LA DIRECTIVE "ORDONNER" * FONCTION: * --------- * reordonner une ligne de seg2 ou seg3 * * on ordonne selon la proximite au premier pt pour des POI1 (PP 97) * C+PP IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION P(3) real*8 DIST2, P integer i, ia, ico, iCompl, ie1, ie2, iref, j, jg integer iPile,nbElem C+PP -INC PPARAM -INC CCOPTIO -INC COCOLL -INC SMELEME C+PP -INC SMLREEL -INC SMLENTI -INC SMCOORD -INC TMCOLAC SEGMENT TTRAV INTEGER ILIS(NNOE) ENDSEGMENT pointeur piles.LISPIL pointeur jcolac.ICOLAC pointeur jlisse.ILISSE pointeur jtlacc.ITLACC C+PP * * on verifie d'abord que l'objet est simple * icompl=0 SEGACT MELEME IF(LISOUS(/1).NE.0.OR.ITYPEL.GT.3) then CALL RENUEL(MELEME) return endif C+PP iun=1 IF(ITYPEL.EQ.1)THEN SEGACT,MELEME*MOD NBELEM=ICOLOR(/1) C Si le nombre d'éléments POI1 est inférieur ou égal à 2 C Il n'y a rien à faire IF(NBELEM.LE.2) GOTO 9998 IREF=NUM(1,1) IREF=(IDIM+1)*(IREF-1) SEGACT,MCOORD DO IE1=1,IDIM P(IE1)=XCOOR(IREF+IE1) ENDDO JG=NBELEM-1 SEGINI,MLREEL,MLENTI DO IE1=1,JG IREF=NUM(1,IE1+1) LECT(IE1)=IREF IREF=(IDIM+1)*(IREF-1) DIST2=0.D0 DO IE2=1,IDIM DIST2=DIST2+(P(IE2)-XCOOR(IREF+IE2))**2 ENDDO PROG(IE1)=DIST2 ENDDO CALL GENOS2(PROG,LECT,JG) DO IE1=1,JG NUM(1,IE1+1)=LECT(IE1) ENDDO SEGSUP,MLREEL,MLENTI ELSE C+PP CALL LIGMAI(MELEME,TTRAV,1) IF(IERR.NE.0) RETURN SEGACT TTRAV SEGACT MELEME*MOD IA=1 DO 1 I=1,NUM(/2) IA=IA-1 DO 2 J=1,NUM(/1) IA=IA+1 NUM(J,I)=ILIS(IA) 2 CONTINUE 1 CONTINUE SEGSUP TTRAV ENDIF 9998 CONTINUE c IF(IPSAUV.NE.0) THEN ICOLAC = IPSAUV SEGACT ICOLAC ILISSE=ILISSG SEGACT ILISSE*MOD CALL TYPFIL('MAILLAGE',ICO) ITLACC = KCOLA(ICO) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,MELEME,ILISSE,iun) SEGDES ICOLAC,ILISSE ENDIF C Suppression des piles d'objets communiques if(piComm.gt.0) then piles=piComm segact piles call typfil('MAILLAGE',ico) do ipile=1,piles.proc(/1) jcolac= piles.proc(ipile) if(jcolac.ne.0) then segact jcolac jlisse=jcolac.ilissg segact jlisse*mod jtlacc=jcolac.kcola(ico) segact jtlacc*mod call ajoun0(jtlacc,MELEME,jlisse,iun) segdes jtlacc segdes jlisse segdes jcolac endif enddo segdes piles endif RETURN END