C OPTNUM SOURCE PV 22/03/04 21:15:02 11305 SUBROUTINE OPTNUM(MELEME,MEMJT1,memjt2,JMEM,JNT,NEWJT,JOINT, > IDIFF,IPOME,ICPR,NODES,NOOPTI,ipd,nucro) * * renumérotation des noeuds en vue de la résolution * par la méthode de Cuthill Mac Kee inversée * * si ipd non nul, on 'n'inverse pas et on commence par ipd * * IMPLICIT INTEGER(I-N) -INC SMELEME -INC PPARAM -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 nvoisl=64 if (nucro.eq.0) nvoisl=256 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=50000000 ICON=1 ITER=1 IBOUT=1 IK=1 if (ipd.ne.0) ik=ipd 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.49) 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 J=1,NODES JOINT(J)=0 NEWJT(J)=0 enddo 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 ** DO 40 JJ=1,k4 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 * pour avoir dans le bon sens le super element DO 85 LT=1,IPT1.NUM(/1) l=lt IF(IPT1.ITYPEL.EQ.49) then l=lt+1 if (lt.eq.1) l=1 if (lt.eq.ipt1.num(/1)) l=2 endif 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.49.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 49 * 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.49.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 231 L=k5+1,NODES IF (JOINT(l).eq.0) GO TO 24 231 CONTINUE DO 232 L=1,k5 IF (JOINT(l).eq.0) GO TO 24 232 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(nucro.eq.0.and.MINMAX.LE.MUX) GOTO 60 if (lasur0.ne.0.and.lasurt.gt.lasur0) goto 60 cout=5.d0*log(real(mux+1))+log(real(lasurt+1))+log(real(lasurf+1)) if (nucro.ne.0) then if (cout0.ne.0.d0.and.cout.ge.cout0*0.999) goto 60 endif cout0=cout MINMAX=MIN(MINMAX,MUX) lasur0=lasurt IF(IIMPI.ne.0 ) 1WRITE (IOIMP,62) ITER,IK,MUX,LASURF,LASURT 62 FORMAT(' ITERATION:',I3,' DEPART:',I8,' BANDE:',I6,' SURFACE: ', #I13,' SURF INV:',I13) DO J=1,NODES JNT(J)=JOINT(J) enddo ICON=0 NVOIS=0 60 CONTINUE IK=NK5 DO 95 IO=1,IDJFC(/1) IDJF=IDJFC(IO) DO LA=1,IDJF(/1) IDJF(LA)=0 enddo 95 CONTINUE ICON=ICON+1 ITER=ITER+1 *** IF (ICON.LE.1.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.nvoisl) goto 71 if (ipd.ne.0) goto 71 if(icon.gt.20) goto 71 ik=newjt(lh) if (nvois.ge.512) ik=newjt(nodes+513-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