C OPTNUM    SOURCE    PV        10/09/28    21:15:00     6768           
      SUBROUTINE OPTNUM(MELEME,MEMJT1,memjt2,JMEM,JNT,NEWJT,JOINT,
     >      IDIFF,IPOME,ICPR,NODES,NOOPTI)
*
*   renumérotation des noeuds en vue de la résolution
*   par la méthode de Cuthill Mac Kee inversée
*
*
      IMPLICIT INTEGER(I-N)
-INC SMELEME
-INC CCOPTIO
      SEGMENT MEMJT1(0)
      SEGMENT MEMJT2(0)
      SEGMENT IPOME(0)
      SEGMENT JNT  (0)
      SEGMENT JMEM (0)
      SEGMENT NEWJT(0)
      SEGMENT JOINT(0)
      SEGMENT ICPR (0)
C  SEGMENT OU STOCKE LES ELEMENTS DEJA ESSAYES
      SEGMENT IDJFC(IDJFCL)
      SEGMENT IDJF(IDJFL)
C  SEGMENT OU STOCKER LES POINTS DE DEPARTS DEJA ESSAYES
      SEGMENT NPES(NODES)
      CHARACTER*4 MVAL(1)
      INTEGER IPASG
      SAVE IPASG                                                                
      DATA IPASG/0/
      DATA MVAL/'NOOP'/
      lasur0=0
      cout0=0.d0
      NOOPTI=0
      IPT1=MELEME
      CALL LIRMOT(MVAL,1,IRET,0)
      IF (IRET.EQ.0) GOTO 2
      NOOPTI=1
      DO 4 J=1,NODES
          JNT(J)=J
   4  CONTINUE
      RETURN
   2  CONTINUE
      SEGINI NPES
      DO 5 I=1,NODES
          NPES(I)=0
   5  CONTINUE
      IDJFCL=MAX(1,LISOUS(/1))
      SEGINI IDJFC
      IPT1=MELEME
      DO 6 ISOUS=1,IDJFCL
       IF (LISOUS(/1).NE.0) IPT1=LISOUS(ISOUS)
       IDJFL=IPT1.NUM(/2)
       SEGINI IDJF
       IDJFC(ISOUS)=IDJF
   6  CONTINUE
      MINMAX=500000
      ICON=1
      ITER=1
      IBOUT=1
      IK=1
      NK5=1
   1  CONTINUE
      NPES(IK)=1
      DO 230 IO=1,MAX(1,LISOUS(/1))
          IF(LISOUS(/1).NE.0) IPT1=LISOUS(IO)
          IF(IPT1.ITYPEL.NE.22) GO TO 230
          DO 240 LA=1,IPT1.NUM(/2)
              NPES(ICPR(IPT1.NUM(1,LA)))=1
              NPES(ICPR(IPT1.NUM(2,LA)))=1
  240     CONTINUE
 230  CONTINUE
      DO 20 J=1,NODES
          JOINT(J)=0
   20 NEWJT(J)=0
      LASURT=0
      MUX=0
      I=1
      NEWJT(1)=IK
      JOINT(IK)=1
      K=1
   30 IND=NEWJT(I)
      IND1=IND
      K4=JMEM(IND)
      JSUB=IPOME(NEWJT(I))
*  tentative tc
      DO 40 JJ=k4,1,-1
          IND=JSUB+JJ
          IAIA= memjt2(ind)
          K6=memjt1(ind)
          IDJF=IDJFC(MAX(1,IAIA))
          IF (IDJF(K6).EQ.1) GOTO 40
          IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
          IPOSL2=0
          DO 85 L=1,IPT1.NUM(/1)
              K5=ICPR(IPT1.NUM(L,K6))
              IF (JOINT(K5).GT.0) GO TO 85
              if (npes(k5).eq.0) nk5=k5
              K=K+1
              NEWJT(K)=K5
              JOINT(K5)=K
              NDIFF=ABS(I-K)
              MUX=MAX(MUX,NDIFF)
              IF(IPT1.ITYPEL.EQ.22.AND.IPT1.NUM(/1).NE.0)  GO TO 86
              GOTO 85
  86          CONTINUE
*  on insere le multiplicateur 1 avant i (deja atteint)
*  on insere le second apres le noeud le plus haut de l'element (type 22
*  on mettra celui-ci apres tous les autres
              IF (L.EQ.1) THEN
                  DO 87 M=K,I+1,-1
                      NEWJT(M)=NEWJT(M-1)
                      JOINT(NEWJT(M))=M
  87              CONTINUE
                  NEWJT(I)=K5
                  JOINT(K5)=I
                  I=I+1
              ELSEIF (L.EQ.2) THEN
                  IPOSL2=K
              ENDIF
  85      CONTINUE
          IDJF(K6)=1

          IF (IPT1.ITYPEL.EQ.22.AND.IPOSL2.NE.0) THEN
*  on s'occupe maintenant du 2eme multiplicateur de lagrange
              IHAUT=0
              DO 89 L=3,IPT1.NUM(/1)
                  K3=ICPR(IPT1.NUM(L,K6))
                  IHAUT=MAX(IHAUT,JOINT(K3))
  89          CONTINUE
              NEWSAU=NEWJT(IPOSL2)
              IF(IHAUT+1.EQ.IPOSL2) GO TO 40
              IF (IHAUT.LT.IPOSL2) THEN
                  DO 88 M=IPOSL2,IHAUT+2,-1
                      NEWJT(M)=NEWJT(M-1)
                      JOINT(NEWJT(M))=M
  88              CONTINUE
                  NEWJT(IHAUT+1)=NEWSAU
                  JOINT(NEWSAU)=IHAUT+1
              ELSE
                  DO 84 M=IPOSL2,IHAUT-1
                      NEWJT(M)=NEWJT(M+1)
                      JOINT(NEWJT(M))=M
  84              CONTINUE
                  NEWJT(IHAUT)=NEWSAU
                  JOINT(NEWSAU)=IHAUT
              ENDIF
          ENDIF
   40 CONTINUE
      IF(K.EQ.NODES) GO TO 50
      I=I+1
      IF (I.NE.K+1) GO TO 30
      K=K+1
      DO 23 L=1,NODES
          IF (JOINT(L).EQ.0) GO TO 24
  23  CONTINUE
      CALL ERREUR(9)
  24  CONTINUE
      NEWJT(K)=L
      JOINT(L)=K
      IBOUT=IBOUT+1
      GO TO 30
   50 CONTINUE
* 60  CONTINUE
      II=IK
      INTERR(1)=IBOUT
      IF(ITER.EQ.1.AND.IBOUT.NE.1.AND.IPASG.EQ.0) THEN
       IF(LOCERR(1:4).EQ.'RESO')     CALL ERREUR(754)
           IPASG = 1 
      ENDIF
      LASURT=0
      LASURF=0
      DO 46 IB=1,NODES
          LONG=IB
          LANG=IB
          IC=NEWJT(IB)
          K4=JMEM(IC)
          JSUB=IPOME(IC)
          DO 43 JJB=1,K4
              IND=JSUB+JJB
              IAIA= memjt2(ind)
              IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
              K6=memjt1(ind)
              DO 44 IKL=1,IPT1.NUM(/1)
                  JKL=JOINT(ICPR(IPT1.NUM(IKL,K6)))
                  LONG=MAX(LONG,JKL)
                  LANG=MIN(LANG,JKL)
  44          CONTINUE
  43      CONTINUE
          LASURT=LASURT+LONG-IB
          LASURF=LASURF+IB-LANG
  46  CONTINUE
**    IF (MINMAX.LE.MUX) GOTO 60
**    if (lasur0.ne.0.and.lasurt.gt.lasur0) goto 60
      cout=5.d0*log(real(mux))+log(real(lasurt))+log(real(lasurf))
      if (cout0.ne.0.d0.and.cout.ge.cout0) goto 60
      cout0=cout

      MINMAX=MIN(MINMAX,MUX)
      lasur0=lasurt
      IF(IIMPI.EQ.3)
     1WRITE (IOIMP,62) ITER,IK,MUX,LASURF,LASURT
   62 FORMAT(' ITERATION:',I3,' DEPART:',I8,' BANDE:',I6,' SURFACE: ',
     #I13,' SURF INV:',I13)
      DO 55 J=1,NODES
  55  JNT(J)=JOINT(J)
      ICON=0
      NVOIS=0
  60  CONTINUE
      IK=NK5
      DO 95 IO=1,IDJFC(/1)
          IDJF=IDJFC(IO)
          DO 97 LA=1,IDJF(/1)
  97      IDJF(LA)=0
  95  CONTINUE
      ICON=ICON+1
      ITER=ITER+1
      IF (ICON.LE.3.AND.NPES(IK).EQ.0) GOTO 1
      IF (NVOIS.GT.0) GO TO 101
      LH=0
      nvois=0
 101  continue
      do i=1,nodes
      newjt(jnt(i))=i
      enddo
 102  continue
      lh=lh+1
      if (lh.gt.nodes) goto 71
      if (nvois.gt.64) goto 71
      ik=newjt(lh)
      if (nvois.ge.128) ik=newjt(nodes+129-lh)
      if (npes(ik).eq.1) goto 102
      nvois=nvois+1
      goto 1
  71  CONTINUE
      IDIFF=MINMAX
      DO 105 J=1,IDJFC(/1)
       IDJF=IDJFC(J)
       SEGSUP IDJF
 105  CONTINUE
      SEGSUP IDJFC
      SEGSUP NPES
      RETURN
      END