Télécharger la plaquette Cast3M


fr en

Télécharger optnum.eso

Retour à la liste

Numérotation des lignes : 

optnum

  1. C OPTNUM    SOURCE    PV        22/03/04    21:15:02     11305          
  2.       SUBROUTINE OPTNUM(MELEME,MEMJT1,memjt2,JMEM,JNT,NEWJT,JOINT,
  3.      >      IDIFF,IPOME,ICPR,NODES,NOOPTI,ipd,nucro)
  4. *
  5. *   renumérotation des noeuds en vue de la résolution
  6. *   par la méthode de Cuthill Mac Kee inversée
  7. *
  8. *   si ipd non nul, on 'n'inverse pas et on commence par ipd
  9. *
  10. *
  11.       IMPLICIT INTEGER(I-N)
  12. -INC SMELEME
  13.  
  14. -INC PPARAM
  15. -INC CCOPTIO
  16.       SEGMENT MEMJT1(0)
  17.       SEGMENT MEMJT2(0)
  18.       SEGMENT IPOME(0)
  19.       SEGMENT JNT  (0)
  20.       SEGMENT JMEM (0)
  21.       SEGMENT NEWJT(0)
  22.       SEGMENT JOINT(0)
  23.       SEGMENT ICPR (0)
  24. C  SEGMENT OU STOCKE LES ELEMENTS DEJA ESSAYES
  25.       SEGMENT IDJFC(IDJFCL)
  26.       SEGMENT IDJF(IDJFL)
  27. C  SEGMENT OU STOCKER LES POINTS DE DEPARTS DEJA ESSAYES
  28.       SEGMENT NPES(NODES)
  29.       CHARACTER*4 MVAL(1)
  30.       INTEGER IPASG
  31.       SAVE IPASG
  32.       DATA IPASG/0/
  33.       DATA MVAL/'NOOP'/
  34.       lasur0=0
  35.       cout0=0.d0
  36.       NOOPTI=0
  37.       IPT1=MELEME
  38.       CALL LIRMOT(MVAL,1,IRET,0)
  39.       IF (IRET.EQ.0) GOTO 2
  40.       NOOPTI=1
  41.       DO 4 J=1,NODES
  42.           JNT(J)=J
  43.    4  CONTINUE
  44.       RETURN
  45.    2  CONTINUE
  46.       nvoisl=64
  47.       if (nucro.eq.0) nvoisl=256
  48.       SEGINI NPES
  49.       DO 5 I=1,NODES
  50.           NPES(I)=0
  51.    5  CONTINUE
  52.       IDJFCL=MAX(1,LISOUS(/1))
  53.       SEGINI IDJFC
  54.       IPT1=MELEME
  55.       DO 6 ISOUS=1,IDJFCL
  56.        IF (LISOUS(/1).NE.0) IPT1=LISOUS(ISOUS)
  57.        IDJFL=IPT1.NUM(/2)
  58.        SEGINI IDJF
  59.        IDJFC(ISOUS)=IDJF
  60.    6  CONTINUE
  61.       MINMAX=50000000
  62.       ICON=1
  63.       ITER=1
  64.       IBOUT=1
  65.       IK=1
  66.       if (ipd.ne.0) ik=ipd
  67.       NK5=1
  68.    1  CONTINUE
  69.       NPES(IK)=1
  70.       DO 230 IO=1,MAX(1,LISOUS(/1))
  71.           IF(LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  72.           IF(IPT1.ITYPEL.NE.49) GO TO 230
  73.           DO 240 LA=1,IPT1.NUM(/2)
  74.               NPES(ICPR(IPT1.NUM(1,LA)))=1
  75.               NPES(ICPR(IPT1.NUM(2,LA)))=1
  76.   240     CONTINUE
  77.  230  CONTINUE
  78.       DO    J=1,NODES
  79.           JOINT(J)=0
  80.       NEWJT(J)=0
  81.       enddo
  82.       LASURT=0
  83.       MUX=0
  84.       I=1
  85.       NEWJT(1)=IK
  86.       JOINT(IK)=1
  87.       K=1
  88.    30 IND=NEWJT(I)
  89.       IND1=IND
  90.       K4=JMEM(IND)
  91.       JSUB=IPOME(NEWJT(I))
  92. *  tentative tc
  93.       DO 40 JJ=k4,1,-1
  94. **    DO 40 JJ=1,k4
  95.           IND=JSUB+JJ
  96.           IAIA= memjt2(ind)
  97.           K6=memjt1(ind)
  98.           IDJF=IDJFC(MAX(1,IAIA))
  99.           IF (IDJF(K6).EQ.1) GOTO 40
  100.           IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  101.           IPOSL2=0
  102. * pour avoir dans le bon sens le super element
  103.           DO 85 LT=1,IPT1.NUM(/1)
  104.               l=lt
  105.               IF(IPT1.ITYPEL.EQ.49) then
  106.                l=lt+1
  107.                if (lt.eq.1) l=1
  108.                if (lt.eq.ipt1.num(/1)) l=2
  109.               endif
  110.               K5=ICPR(IPT1.NUM(l,K6))
  111.               IF (JOINT(K5).GT.0) GO TO 85
  112.               if (npes(k5).eq.0) nk5=k5
  113.               K=K+1
  114.               NEWJT(K)=K5
  115.               JOINT(K5)=K
  116.               NDIFF=ABS(I-K)
  117.               MUX=MAX(MUX,NDIFF)
  118.               IF(IPT1.ITYPEL.EQ.49.AND.IPT1.NUM(/1).NE.0)  GO TO 86
  119.               GOTO 85
  120.   86          CONTINUE
  121. *  on insere le multiplicateur 1 avant i (deja atteint)
  122. *  on insere le second apres le noeud le plus haut de l'element (type 49
  123. *  on mettra celui-ci apres tous les autres
  124.               IF (L.EQ.1) THEN
  125.                   DO 87 M=K,I+1,-1
  126.                       NEWJT(M)=NEWJT(M-1)
  127.                       JOINT(NEWJT(M))=M
  128.   87              CONTINUE
  129.                   NEWJT(I)=K5
  130.                   JOINT(K5)=I
  131.                   I=I+1
  132.               ELSEIF (L.EQ.2) THEN
  133.                   IPOSL2=K
  134.               ENDIF
  135.   85      CONTINUE
  136.           IDJF(K6)=1
  137.  
  138.           IF (IPT1.ITYPEL.EQ.49.AND.IPOSL2.NE.0) THEN
  139. *  on s'occupe maintenant du 2eme multiplicateur de lagrange
  140.               IHAUT=0
  141.               DO 89 L=3,IPT1.NUM(/1)
  142.                   K3=ICPR(IPT1.NUM(L,K6))
  143.                   IHAUT=MAX(IHAUT,JOINT(K3))
  144.   89          CONTINUE
  145.               NEWSAU=NEWJT(IPOSL2)
  146.               IF(IHAUT+1.EQ.IPOSL2) GO TO 40
  147.               IF (IHAUT.LT.IPOSL2) THEN
  148.                   DO 88 M=IPOSL2,IHAUT+2,-1
  149.                       NEWJT(M)=NEWJT(M-1)
  150.                       JOINT(NEWJT(M))=M
  151.   88              CONTINUE
  152.                   NEWJT(IHAUT+1)=NEWSAU
  153.                   JOINT(NEWSAU)=IHAUT+1
  154.               ELSE
  155.                   DO 84 M=IPOSL2,IHAUT-1
  156.                       NEWJT(M)=NEWJT(M+1)
  157.                       JOINT(NEWJT(M))=M
  158.   84              CONTINUE
  159.                   NEWJT(IHAUT)=NEWSAU
  160.                   JOINT(NEWSAU)=IHAUT
  161.               ENDIF
  162.           ENDIF
  163.    40 CONTINUE
  164.       IF(K.EQ.NODES) GO TO 50
  165.       I=I+1
  166.       IF (I.NE.K+1) GO TO 30
  167.       K=K+1
  168.       DO 231 L=k5+1,NODES
  169.           IF (JOINT(l).eq.0) GO TO 24
  170.   231 CONTINUE
  171.       DO 232 L=1,k5
  172.           IF (JOINT(l).eq.0) GO TO 24
  173.   232 CONTINUE
  174.       CALL ERREUR(9)
  175.   24  CONTINUE
  176.       NEWJT(K)=L
  177.       JOINT(L)=K
  178.       IBOUT=IBOUT+1
  179.       GO TO 30
  180.    50 CONTINUE
  181. * 60  CONTINUE
  182.       II=IK
  183.       INTERR(1)=IBOUT
  184.       IF(ITER.EQ.1.AND.IBOUT.NE.1.AND.IPASG.EQ.0) THEN
  185.        IF(LOCERR(1:4).EQ.'RESO')     CALL ERREUR(754)
  186.            IPASG = 1
  187.       ENDIF
  188.       LASURT=0
  189.       LASURF=0
  190.       DO 46 IB=1,NODES
  191.           LONG=IB
  192.           LANG=IB
  193.           IC=NEWJT(IB)
  194.           K4=JMEM(IC)
  195.           JSUB=IPOME(IC)
  196.           DO 43 JJB=1,K4
  197.               IND=JSUB+JJB
  198.               IAIA= memjt2(ind)
  199.               IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  200.               K6=memjt1(ind)
  201.               DO 44 IKL=1,IPT1.NUM(/1)
  202.                   JKL=JOINT(ICPR(IPT1.NUM(IKL,K6)))
  203.                   LONG=MAX(LONG,JKL)
  204.                   LANG=MIN(LANG,JKL)
  205.   44          CONTINUE
  206.   43      CONTINUE
  207.           LASURT=LASURT+LONG-IB
  208.           LASURF=LASURF+IB-LANG
  209.   46  CONTINUE
  210.       if(nucro.eq.0.and.MINMAX.LE.MUX) GOTO 60
  211.       if (lasur0.ne.0.and.lasurt.gt.lasur0) goto 60
  212.       cout=5.d0*log(real(mux+1))+log(real(lasurt+1))+log(real(lasurf+1))
  213.       if (nucro.ne.0) then
  214.       if (cout0.ne.0.d0.and.cout.ge.cout0*0.999) goto 60
  215.       endif
  216.       cout0=cout
  217.  
  218.       MINMAX=MIN(MINMAX,MUX)
  219.       lasur0=lasurt
  220.       IF(IIMPI.ne.0 )
  221.      1WRITE (IOIMP,62) ITER,IK,MUX,LASURF,LASURT
  222.    62 FORMAT(' ITERATION:',I3,' DEPART:',I8,' BANDE:',I6,' SURFACE: ',
  223.      #I13,' SURF INV:',I13)
  224.       DO    J=1,NODES
  225.       JNT(J)=JOINT(J)
  226.       enddo
  227.       ICON=0
  228.       NVOIS=0
  229.   60  CONTINUE
  230.       IK=NK5
  231.       DO 95 IO=1,IDJFC(/1)
  232.           IDJF=IDJFC(IO)
  233.           DO    LA=1,IDJF(/1)
  234.           IDJF(LA)=0
  235.           enddo
  236.   95  CONTINUE
  237.       ICON=ICON+1
  238.       ITER=ITER+1
  239. ***   IF (ICON.LE.1.AND.NPES(IK).EQ.0) GOTO 1
  240.       IF (NVOIS.GT.0) GO TO 101
  241.       LH=0
  242.       nvois=0
  243.  101  continue
  244.       do i=1,nodes
  245.       newjt(jnt(i))=i
  246.       enddo
  247.  102  continue
  248.       lh=lh+1
  249.       if (lh.gt.nodes) goto 71
  250.       if (nvois.gt.nvoisl) goto 71
  251.       if (ipd.ne.0) goto 71
  252.       if(icon.gt.20) goto 71
  253.       ik=newjt(lh)
  254.       if (nvois.ge.512) ik=newjt(nodes+513-lh)
  255.       if (npes(ik).eq.1) goto 102
  256.       nvois=nvois+1
  257.       goto 1
  258.   71  CONTINUE
  259.       IDIFF=MINMAX
  260.       DO 105 J=1,IDJFC(/1)
  261.        IDJF=IDJFC(J)
  262.        SEGSUP IDJF
  263.  105  CONTINUE
  264.       SEGSUP IDJFC
  265.       SEGSUP NPES
  266.       RETURN
  267.       END
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales