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    PV090527  26/09/14    21:15:10     12625          
  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.           ITYPL=ABS(IPT1.ITYPEL)
  73.           IF(ITYPL.EQ.49) THEN
  74.           DO LA=1,IPT1.NUM(/2)
  75.               NPES(ICPR(IPT1.NUM(1,LA)))=1
  76.               NPES(ICPR(IPT1.NUM(2,LA)))=1
  77.           ENDDO      
  78.           ENDIF
  79.           IF(ITYPL.EQ.22) THEN
  80.           DO LA=1,IPT1.NUM(/2)
  81.               NPES(ICPR(IPT1.NUM(1,LA)))=1
  82.           ENDDO      
  83.           ENDIF
  84.  230  CONTINUE
  85.       DO    J=1,NODES
  86.           JOINT(J)=0
  87.       NEWJT(J)=0
  88.       enddo
  89.       LASURT=0
  90.       MUX=0
  91.       I=1
  92.       NEWJT(1)=IK
  93.       JOINT(IK)=1
  94.       K=1
  95.    30 IND=NEWJT(I)
  96.       IND1=IND
  97.       K4=JMEM(IND)
  98.       JSUB=IPOME(NEWJT(I))
  99. *  tentative tc
  100.       DO 40 JJ=k4,1,-1
  101. **    DO 40 JJ=1,k4
  102.           IND=JSUB+JJ
  103.           IAIA= memjt2(ind)
  104.           K6=memjt1(ind)
  105.           IDJF=IDJFC(MAX(1,IAIA))
  106.           IF (IDJF(K6).EQ.1) GOTO 40
  107.           IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  108.           ITYPL=ABS(IPT1.ITYPEL)
  109.           IPOSL2=0
  110. * pour avoir dans le bon sens le super element
  111.           DO 85 LT=1,IPT1.NUM(/1)
  112.               l=lt
  113.               lr=l
  114.               IF(ITYPL.EQ.49.or.ITYPL.EQ.22) then
  115.                l=lt+1
  116.                if (lt.eq.1) l=1
  117.                IF (LT.EQ.IPT1.NUM(/1)) L=2
  118.               endif
  119.               IF(ITYPL.EQ.22) then
  120.                if(lr.le.2) lr=3-lr
  121.               endif
  122.               K5=ICPR(IPT1.NUM(lr,K6))
  123.               IF (JOINT(K5).GT.0) GO TO 85
  124.               if (npes(k5).eq.0) nk5=k5
  125.               K=K+1
  126.               NEWJT(K)=K5
  127.               JOINT(K5)=K
  128.               NDIFF=ABS(I-K)
  129.               MUX=MAX(MUX,NDIFF)
  130.               IF((ITYPL.EQ.49.OR.ITYPL.EQ.22).AND.
  131.      >           IPT1.NUM(/1).NE.0)  GOTO 86
  132.               GOTO 85
  133.   86          CONTINUE
  134. *  on insere le multiplicateur 1 avant i (deja atteint)
  135. *  on insere le second apres le noeud le plus haut de l'element (type 49
  136. *  on mettra celui-ci apres tous les autres
  137.               IF (L.EQ.1) THEN
  138.                   DO 87 M=K,I+1,-1
  139.                       NEWJT(M)=NEWJT(M-1)
  140.                       JOINT(NEWJT(M))=M
  141.   87              CONTINUE
  142.                   NEWJT(I)=K5
  143.                   JOINT(K5)=I
  144.                   I=I+1
  145.               ELSEIF (L.EQ.2) THEN
  146.                   IPOSL2=K
  147.               ENDIF
  148.   85      CONTINUE
  149.           IDJF(K6)=1
  150.           LD=3
  151.           IF(ITYPL.EQ.22) LD=2
  152.           IF ((ITYPL.EQ.49.OR.ITYPL.EQ.22).AND.IPOSL2.NE.0) THEN
  153. *  on s'occupe maintenant du 2eme multiplicateur de lagrange
  154.               IHAUT=0
  155.               DO 89 L=LD,IPT1.NUM(/1)
  156.                   K3=ICPR(IPT1.NUM(L,K6))
  157.                   IHAUT=MAX(IHAUT,JOINT(K3))
  158.   89          CONTINUE
  159.               NEWSAU=NEWJT(IPOSL2)
  160.               IF(IHAUT+1.EQ.IPOSL2) GO TO 40
  161.               IF (IHAUT.LT.IPOSL2) THEN
  162.                   DO 88 M=IPOSL2,IHAUT+2,-1
  163.                       NEWJT(M)=NEWJT(M-1)
  164.                       JOINT(NEWJT(M))=M
  165.   88              CONTINUE
  166.                   NEWJT(IHAUT+1)=NEWSAU
  167.                   JOINT(NEWSAU)=IHAUT+1
  168.               ELSE
  169.                   DO 84 M=IPOSL2,IHAUT-1
  170.                       NEWJT(M)=NEWJT(M+1)
  171.                       JOINT(NEWJT(M))=M
  172.   84              CONTINUE
  173.                   NEWJT(IHAUT)=NEWSAU
  174.                   JOINT(NEWSAU)=IHAUT
  175.               ENDIF
  176.           ENDIF
  177.    40 CONTINUE
  178.       IF(K.EQ.NODES) GO TO 50
  179.       I=I+1
  180.       IF (I.NE.K+1) GO TO 30
  181.       K=K+1
  182.       DO 231 L=k5+1,NODES
  183.           IF (JOINT(l).eq.0) GO TO 24
  184.   231 CONTINUE
  185.       DO 232 L=1,k5
  186.           IF (JOINT(l).eq.0) GO TO 24
  187.   232 CONTINUE
  188.       CALL ERREUR(9)
  189.   24  CONTINUE
  190.       NEWJT(K)=L
  191.       JOINT(L)=K
  192.       IBOUT=IBOUT+1
  193.       GO TO 30
  194.    50 CONTINUE
  195. * 60  CONTINUE
  196.       II=IK
  197.       INTERR(1)=IBOUT
  198.       IF(ITER.EQ.1.AND.IBOUT.NE.1.AND.IPASG.EQ.0) THEN
  199.        IF(LOCERR(1:4).EQ.'RESO')     CALL ERREUR(754)
  200.            IPASG = 1
  201.       ENDIF
  202.       LASURT=0
  203.       LASURF=0
  204.       DO 46 IB=1,NODES
  205.           LONG=IB
  206.           LANG=IB
  207.           IC=NEWJT(IB)
  208.           K4=JMEM(IC)
  209.           JSUB=IPOME(IC)
  210.           DO 43 JJB=1,K4
  211.               IND=JSUB+JJB
  212.               IAIA= memjt2(ind)
  213.               IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  214.               K6=memjt1(ind)
  215.               DO 44 IKL=1,IPT1.NUM(/1)
  216.                   JKL=JOINT(ICPR(IPT1.NUM(IKL,K6)))
  217.                   LONG=MAX(LONG,JKL)
  218.                   LANG=MIN(LANG,JKL)
  219.   44          CONTINUE
  220.   43      CONTINUE
  221.           LASURT=LASURT+LONG-IB
  222.           LASURF=LASURF+IB-LANG
  223.   46  CONTINUE
  224.       if(nucro.eq.0.and.MINMAX.LE.MUX) GOTO 60
  225.       if (lasur0.ne.0.and.lasurt.gt.lasur0) goto 60
  226.       cout=5.d0*log(real(mux+1))+log(real(lasurt+1))+log(real(lasurf+1))
  227.       if (nucro.ne.0) then
  228.       if (cout0.ne.0.d0.and.cout.ge.cout0*0.999) goto 60
  229.       endif
  230.       cout0=cout
  231.  
  232.       MINMAX=MIN(MINMAX,MUX)
  233.       lasur0=lasurt
  234.       IF(IIMPI.ne.0 )
  235.      1WRITE (IOIMP,62) ITER,IK,MUX,LASURF,LASURT
  236.    62 FORMAT(' ITERATION:',I3,' DEPART:',I8,' BANDE:',I6,' SURFACE: ',
  237.      #I13,' SURF INV:',I13)
  238.       DO    J=1,NODES
  239.       JNT(J)=JOINT(J)
  240.       enddo
  241.       ICON=0
  242.       NVOIS=0
  243.   60  CONTINUE
  244.       IK=NK5
  245.       DO 95 IO=1,IDJFC(/1)
  246.           IDJF=IDJFC(IO)
  247.           DO    LA=1,IDJF(/1)
  248.           IDJF(LA)=0
  249.           enddo
  250.   95  CONTINUE
  251.       ICON=ICON+1
  252.       ITER=ITER+1
  253. ***   IF (ICON.LE.1.AND.NPES(IK).EQ.0) GOTO 1
  254.       IF (NVOIS.GT.0) GO TO 101
  255.       LH=0
  256.       nvois=0
  257.  101  continue
  258.       do i=1,nodes
  259.       newjt(jnt(i))=i
  260.       enddo
  261.  102  continue
  262.       lh=lh+1
  263.       if (lh.gt.nodes) goto 71
  264.       if (nvois.gt.nvoisl) goto 71
  265.       if (ipd.ne.0) goto 71
  266.       if(icon.gt.20) goto 71
  267.       ik=newjt(lh)
  268.       if (nvois.ge.512) ik=newjt(nodes+513-lh)
  269.       if (npes(ik).eq.1) goto 102
  270.       nvois=nvois+1
  271.       goto 1
  272.   71  CONTINUE
  273.       IDIFF=MINMAX
  274.       DO 105 J=1,IDJFC(/1)
  275.        IDJF=IDJFC(J)
  276.        SEGSUP IDJF
  277.  105  CONTINUE
  278.       SEGSUP IDJFC
  279.       SEGSUP NPES
  280.       RETURN
  281.       END
  282.  
  283.  
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  
  298.  
  299.  

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