Sources Esope | Cast3M

ordon4
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