Télécharger la plaquette Cast3M


fr en

Télécharger sepa2.eso

Retour à la liste

Numérotation des lignes : 

sepa2

  1. C SEPA2     SOURCE    PV090527  24/01/10    21:15:05     11818          
  2. C****************************************************************************
  3. C****************************************************************************
  4. C***************SEPAR...trouve separation************************************
  5. C****************************************************************************
  6. C****************************************************************************
  7.  
  8. C    SEPAR   trouve la separation a  partir du domaine defini  par
  9. C    MASQ=.TRUE. et du noeud appele PIVOT, renvoie DIMSEP,le nombre de
  10. C    noeuds contenant dans la separation, MASQ=.FALSE. pour les noeuds
  11. C    appartenant a la separation, renumerote celle-ci dans IADJ,
  12.  
  13.         SUBROUTINE SEPA2(IADJ,JADJC,PIVOTA,MASQUE,DIMSEP,N,IPOS,
  14.      &                   NODES,IPOSMAX,nrelong,noelon,noel2,
  15.      >                   londim,nbthr,icco)
  16.  
  17.       IMPLICIT INTEGER(I-N)
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC CCREEL
  22.       common/cnumop/fcout2c(64),fcoutc(64),iadjc,jadjcc,nrelongc,
  23.      > noelonc,isensc(64),dimlonc(64),masqc,nodesc,iposc,nbtotc,
  24.      > lfrontc(64),londimc,lpivc(64),ipointc,noel2c,
  25.      > boolc(64),ldim2c(64),nbthrc,pivotc(50,64),npointc(64),
  26.      > npoint2c(64),imaxc,lfronc(64),iccon,ncouch
  27.         integer iths(64)
  28.         external noepr2i,noepr2j
  29.         integer dimlonc,boolc
  30.         SEGMENT IADJ(0)
  31.         SEGMENT JADJC(0)
  32.         integer pivot(50),pivot2(50),pivota,pivots,pivotc,pivotb
  33.         SEGMENT MASQUE
  34.                 LOGICAL MASQ(0)
  35.         ENDSEGMENT
  36.         SEGMENT IPOS(0)
  37.         INTEGER NODES
  38.         INTEGER BOOL
  39.         INTEGER DIMSEP,N
  40.         REAL*8 FCOUT,FCOUT2,fcout2c,fcoutc
  41.         real*8 xran
  42.         INTEGER LONG,LONG2,L,DIMLON
  43. C       LONG2,LONG correspond au pseudo-diametre.
  44. C       L  determine les noeuds appartenant a la separation.
  45.  
  46.         SEGMENT NRELONG(NODES)
  47. C       NRELONG contient pour chaque noeud sa profondeur.
  48.  
  49.         SEGMENT NOELON(NODES)
  50.         SEGMENT NOEL2(NODES)
  51.         SEGMENT LONDIM(NODES)
  52. C       NOELON contient les noeuds de profondeur LONG.
  53. C       DIMLON= dimension de NOELON.
  54.  
  55. C       Initialisation des segments  de travail.
  56. *       write (6,*) ' entree dans sepa2 nbthr ',nbthr
  57. *  noepr2 travaille differamment suivant que nbtot est nul ou pas
  58. *  et aussi en fonction de iccon
  59.  
  60.         FCOUT=0.D0
  61.         FCOUT2=0.D0
  62.         iccon=icco
  63.         nbtot=0
  64.         lpiv=1
  65.         pivot(lpiv)=pivota
  66.         MDOMN=IPOS(PIVOTA+NODES)
  67.         CALL NOEPR2(IADJ(1),JADJC(1),PIVOT,NRELONG(1),NOELON(1),
  68.      >  isens,DIMLON,NODES,IPOS(1),NBTOT,lfront,lfron,
  69.      >  londim(1),fcout,lpiv,iccon,icouch)
  70.         do j=1,dimlon
  71.           noel2(j)=noelon(j)
  72.         enddo
  73. * insertion d'un deuxieme pivot pour faire les partitions par la suite
  74. * on part du point extreme et on reprend le nouveau point extreme
  75.         if (dimlon.ge.2) then
  76.         lpiv=1
  77.         pivot(lpiv)=noelon(dimlon)
  78.         do ix=1,dimlon
  79.           ii=noelon(ix)
  80.           if(ii.ne.0) nrelong(ii)=0
  81.         enddo
  82.          nbtot=0
  83.         CALL NOEPR2(IADJ(1),JADJC(1),PIVOT,NRELONG(1),NOELON(1),
  84.      >  isens,DIMLON,NODES,IPOS(1),NBTOT,lfront,lfron,
  85.      >  londim(1),fcout,lpiv,iccon,icouch)
  86.         ncouch=icouch
  87.         lpiv=2
  88.         pivot(lpiv)=noelon(dimlon)
  89.         endif
  90.         if (dimlon.eq.0) return
  91.  
  92.  
  93.  
  94. *       write (6,*) ' sepa2 apres noepr dimlon nbtot fcout ',dimlon,
  95. *    >    nbtot,fcout,pivot(lpiv)
  96. *
  97.         do ix=1,dimlon
  98.           ii=noelon(ix)
  99.           if(ii.ne.0) nrelong(ii)=0
  100.         enddo
  101.         if (fcout.lt.2) goto 11
  102.         if (dimlon.le.13) goto 11
  103.         ldim2=londim(2)
  104. *  recherche aleatoire
  105. *  prevoir 2 cases pour les nouveaux pivots car 2 zones
  106.         npoint=4
  107.         do i=lpiv+1,npoint
  108.          pivot(i)=0
  109.         enddo
  110.         lpiv=npoint
  111.         bool=2
  112.         ipoint=0
  113.         imax=0
  114.  499    continue
  115.         do 500 itent=1,igrand
  116.          if (fcout.lt.2) goto 510
  117.          if (bool.le.0 ) goto 510
  118.          bool=bool-1
  119.          ipoint=ipoint+1
  120.          if (ipoint.gt.npoint) then
  121.            imax=1
  122.            ipoint=1
  123.          endif
  124.          npoint2=npoint
  125.          nbthrl=min(nbthr,nbtot/16+1)
  126. **       nbthrl=1
  127.          pivots=pivot(ipoint)
  128.           iadjc=iadj
  129.           jadjcc=jadjc
  130.           nrelongc=nrelong
  131.           noelonc=noelon
  132.           masqc=masque
  133.           nodesc=nodes
  134.           iposc=ipos
  135.           nbtotc=nbtot
  136.           londimc=londim
  137.           ipointc=ipoint
  138.           noel2c=noel2
  139.           nbthrc=nbthrl
  140.           imaxc=imax
  141.          do 521 ith=1,nbthrl
  142.           isensc(ith)=isens
  143.           dimlonc(ith)=dimlon
  144.           lfrontc(ith)=lfront
  145.           lfronc(ith)=lfron
  146.           fcout2c(ith)=fcout2
  147.           lpivc(ith)=lpiv
  148.           boolc(ith)=bool
  149.           fcoutc(ith)=fcout
  150.           ldim2c(ith)=ldim2
  151.           npointc(ith)=npoint
  152.           npoint2c(ith)=npoint2
  153.           do jj=1,lfron
  154.            londim(jj+(ith-1)*nodes)=londim(jj)
  155.           enddo
  156.           do jj=1,npoint2
  157.             pivotc(jj,ith)=pivot(jj)
  158.           enddo
  159.           if (ith.ne.nbthrl.and.dimlon.gt.64 ) then
  160. *          write (6,*) ' appel threadid ',ith
  161.            iths(ith)=1
  162.            call threadid(ith,noepr2i)
  163.           else
  164.            call noepr2i(ith)
  165.            iths(ith)=0
  166.           endif
  167.  521     continue
  168.          isig=2*mod(ipoint,2)-1
  169.          do 522 ith=1,nbthrl
  170.           if (iths(ith).eq.1) call threadif(ith)
  171.           iths(ith)=0
  172.           if (fcoutc(ith).lt.fcout) then
  173.            if (fcoutc(ith).ne.fcout) bool=2
  174.            isens=isensc(ith)
  175.            fcout=fcoutc(ith)
  176.            ldim2=ldim2c(ith)
  177.            npoint=npointc(ith)
  178.            npoint2=npoint2c(ith)
  179.            pivot(ipoint)=pivotc(ipoint,ith)
  180.            pivot(npoint2)=0
  181.           endif
  182.  522     continue
  183.          if (ierr.ne.0) return
  184.          npoint=npoint2
  185.          lpiv=npoint
  186.  500    continue
  187.  510    continue
  188. *       write (6,*) ' nb pts maitres ',npoint
  189. *  petit gradient local parallelise +
  190. *  on garde la supression eventuelle
  191.         if(dimlon.lt.64) goto 570
  193.         ipoins=npoint
  194.         do 560 itent=1,igrand
  195.         if (isucc.eq.0) goto 570
  196.         if (fcout.lt.2) goto 570
  198.         do 550 ipoinu= npoint,1,-1
  199.         ipoint=mod(ipoins+ipoinu-2,npoint)+1
  200.         lpoint=pivot(ipoint)
  201.         if (lpoint.le.0) goto 550
  202.          iadh=iadj(lpoint+1)-1
  203.          iadb=iadj(lpoint)
  204. *  pour ne pas perdre trop de temps avec un super element
  205.          iadb=max(iadb,iadh-256)
  206.          do 580 kb=iadh,iadb,-nbthrl
  207.           iadjc=iadj
  208.           jadjcc=jadjc
  209.           nrelongc=nrelong
  210.           noelonc=noelon
  211.           masqc=masque
  212.           nodesc=nodes
  213.           iposc=ipos
  214.           nbtotc=nbtot
  215.           londimc=londim
  216.           ipointc=ipoint
  217.           noel2c=noel2
  218.           nbthrc=nbthrl
  219.           imaxc=imax
  220.          do 581 ith=nbthrl,1,-1
  221.           kk=kb-ith+1
  222.           if (kk.lt.iadj(lpoint)) goto 581
  223.           if (kk.eq.iadj(lpoint+1)) then
  224.             pivot(ipoint)=0
  225.           else
  226.             k=jadjc(kk)
  227.             if (k.eq.0) goto 581
  228.             if (IPOS(k+NODES).ne.mdomn) goto 581
  229.             pivot(ipoint)=k
  230.           endif
  231.           isensc(ith)=isens
  232.           dimlonc(ith)=dimlon
  233.           lfrontc(ith)=lfront
  234.           lfronc(ith)=lfron
  235.           fcout2c(ith)=fcout2
  236.           lpivc(ith)=lpiv
  237.           boolc(ith)=bool
  238.           fcoutc(ith)=fcout
  239.           ldim2c(ith)=ldim2
  240.           npointc(ith)=npoint
  241.           npoint2c(ith)=npoint2
  242.           do jj=1,lfron
  243.            londim(jj+(ith-1)*nodes)=londim(jj)
  244.           enddo
  245.           do jj=1,npoint2
  246.             pivotc(jj,ith)=pivot(jj)
  247.           enddo
  248.           if (ith.ne.1.and.dimlon.gt.64 ) then
  249. *          write (6,*) ' appel threadid ',ith
  250.            call threadid(ith,noepr2j)
  251.            iths(ith)=1
  252.           else
  253.            call noepr2j(ith)
  254.            iths(ith)=0
  255.           endif
  256.           pivot(ipoint)=lpoint
  257.  581     continue
  258.  583     continue
  259.          do 582 ith=nbthrl,1,-1
  260.           if (iths(ith).eq.1) then
  261.            call threadif(ith)
  262.            iths(ith)=0
  263.           endif
  264. **        write(6,*) ' apres noepr2j ',fcout,fcoutc(ith)
  265.           if (fcoutc(ith).lt.fcout) then
  266. **          write(6,*) 'amelioration gradient',fcout,
  267. **   >      fcoutc(ith),pivotc(ipoint,ith)
  268.            if (fcoutc(ith).ne.fcout) bool=2
  269.            isens=isensc(ith)
  270.            fcout=fcoutc(ith)
  271.            ldim2=ldim2c(ith)
  272.            npoint=npointc(ith)
  273.            npoint2=npoint2c(ith)
  274.            pivot(ipoint)=pivotc(ipoint,ith)
  275.            pivot(npoint2)=0
  277.           endif
  278.  582     continue
  279.          if (ierr.ne.0) return
  280.          npoint=npoint2
  281.          lpiv=npoint
  282.          if (isucc.eq.1) then
  283.            ipoins=ipoint
  284.            goto 560
  285.          endif
  286.  580    continue
  287.  550    continue
  288.  560    continue
  289.  570    continue
  290.  
  291.  11     continue
  292.         nbtot=0
  293. *       write (6,*) ' sepa2 avant noepr2 final ',pivot(1),pivot(2)
  294.         CALL NOEPR2(IADJ(1),JADJC(1),PIVOT,NRELONG(1),NOELON(1),
  295.      >   isens,DIMLON,NODES,IPOS(1),NBTOT,lfront,lfron,
  296.      >   londim(1),fcout,lpiv,iccon,icouch)
  297.  
  298. C       PIVOT correspond au noeud pseudo-peripherique.
  299. C       LONG2 correspond au pseudo-diametre.
  300. C
  301.  
  302.         DIMSEP=0
  303. C       MDOMN est le numéro de mon domaine
  304.  
  305. C       pour l'instant,aucun noeud n'appartient a la separation.
  306.  
  307.  
  308.         l=lfront
  309. C       L correspond a la distance moyenne pour aller d'un bout a l'autre
  310. C       du domaine.
  311.  
  312. C       on arrete de separer si LONG < = 5 ou icouch < = 6
  313. C       on masque alors tous les noeuds repondant a cette condition.
  314.  
  315. **      write (6,*) ' sepa2  icouch lfront nbtot  ',icouch,lfront,nbtot
  316.         IF(Lfront.le.1.OR.NBTOT.LE.16) THEN
  317. C       insertion d'une seule zone
  318.           IPOSV=IPOS(MDOMN+1)
  319. C       IPOSV est son rang
  320.           DO I=0,IPOSMAX
  321.            IF (IPOS(I+1).GT.IPOSV) IPOS(I+1)=IPOS(I+1)+1
  322.           ENDDO
  323.          IPOSMAX=IPOSMAX+1
  324.           if (iposmax.gt.nodes-1) then
  325. *          write (6,*) ' iposmax > modes '
  326.            iposmax=nodes-1
  327.           endif
  328.         IPOS(IPOSMAX+1-0)=IPOSV+1
  329. C         IPOSV est son rang
  330.               DO 40 IX=1,DIMLON
  331.               I=NOELON(IX)
  332.                 IF(MDOMN.EQ.IPOS(I+NODES).AND.NRELONG(I).NE.0) THEN
  333.                         MASQ(I)=.FALSE.
  334.                         IPOS(I+NODES)=IPOSMAX
  335.                         DIMSEP=DIMSEP+1
  336.                 ENDIF
  337.  40                CONTINUE
  338. *        do 41 i=1,nodes
  339. *         IF(MDOMN.EQ.IPOS(I+NODES).AND.NRELONG(I).EQ.0) THEN
  340. *            write (6,*) ' zone non connexe 1 ',mdomn,i
  341. *         endif
  342. *41      continue
  343. *         CALL CMG2(IADJ,JADJC,PIVOT,LONG,NRELONG,NOELON,
  344. *    *               DIMLON,MASQUE,NODES,IPOS,DIMSEP)
  345.                 GOTO 50
  346.         ENDIF
  347.  
  348. C       calcul des nouveaux indices de zones
  349.         IPOSV=IPOS(MDOMN+1)
  350. C       IPOSV est son rang
  351.         DO I=0,IPOSMAX
  352.          IF (IPOS(I+1).GT.IPOSV) IPOS(I+1)=IPOS(I+1)+3
  353.         ENDDO
  354.         IPOSMAX=IPOSMAX+3
  355.           if (iposmax.gt.nodes-1) then
  356. *          write (6,*) ' iposmax > modes '
  357.            iposmax=nodes-1
  358.           endif
  359.         isens=1
  360.         IPOS(IPOSMAX+1-2)=IPOSV+1
  361.         IPOS(IPOSMAX+1-1)=IPOSV+1+isens
  362.         IPOS(IPOSMAX+1-0)=IPOSV+4-isens
  363.  
  364. C       On calcule la position de chaque noeud I.
  365. C       si I a une profondeur L, I appartient a la separation.
  366.  
  367.         iwr=1
  368.         izcti1=igrand
  369.         izcti2=igrand
  370.         izcti3=igrand
  371.         izcti4=igrand
  372.         izcti5=igrand
  373.         izcti6=igrand
  374.         izcti7=igrand
  375.         izcti8=igrand
  376.         izcte1=igrand
  377.         izcte2=igrand
  378.         izcte3=igrand
  379.         izcte4=igrand
  380.         izcte5=igrand
  381.         izcte6=igrand
  382.         izcte7=igrand
  383.         izcte8=igrand
  384. *       dimseq=dimsep
  385.         DO 20 IX=1,DIMLON
  386.          I=NOELON(IX)
  387. *  L'intérieur
  388.              IF(MDOMN.EQ.IPOS(I+NODES).AND.(NRELONG(I).GT.0)) THEN
  389.                 IF((NRELONG(I).LT.L)) THEN
  390. *  recherche de izcti
  391.                do kk=iadj(i),iadj(i+1)-1
  392.                  k=jadjc(kk)
  393.                if (k.ne.0) then
  394.          if (nrelong(k).eq.0) then
  395.              ipkn=ipos(ipos(k+nodes)+1)
  396.              if (izcti1.eq.ipkn) then
  397.          elseif (izcti1.gt.ipkn) then
  398.                    izcti8=izcti7
  399.                    izcti7=izcti6
  400.                    izcti6=izcti5
  401.                    izcti5=izcti4
  402.                    izcti4=izcti3
  403.                    izcti3=izcti2
  404.                    izcti2=izcti1
  405.                    izcti1=ipkn
  406.          elseif (izcti2.eq.ipkn) then
  407.          elseif (izcti2.gt.ipkn) then
  408.                    izcti8=izcti7
  409.                    izcti7=izcti6
  410.                    izcti6=izcti5
  411.                    izcti5=izcti4
  412.                    izcti4=izcti3
  413.                    izcti3=izcti2
  414.                    izcti2=ipkn
  415.          ELSEIF (IZCTI3.EQ.IPkn) THEN
  416.          elseif (izcti3.gt.ipkn) then
  417.                    izcti8=izcti7
  418.                    izcti7=izcti6
  419.                    izcti6=izcti5
  420.                    izcti5=izcti4
  421.                    izcti4=izcti3
  422.                    izcti3=ipkn
  423.          elseif (izcti4.eq.ipkn) then
  424.          elseif (izcti4.gt.ipkn) then
  425.                    izcti8=izcti7
  426.                    izcti7=izcti6
  427.                    izcti6=izcti5
  428.                    izcti5=izcti4
  429.                    izcti4=ipkn
  430.          elseif (izcti5.eq.ipkn) then
  431.          elseif (izcti5.gt.ipkn) then
  432.                    izcti8=izcti7
  433.                    izcti7=izcti6
  434.                    izcti6=izcti5
  435.                    izcti5=ipkn
  436.          elseif (izcti6.eq.ipkn) then
  437.          elseif (izcti6.gt.ipkn) then
  438.                    izcti8=izcti7
  439.                    izcti7=izcti6
  440.                    izcti6=ipkn
  441.          elseif (izcti7.eq.ipkn) then
  442.          elseif (izcti7.gt.ipkn) then
  443.                    izcti8=izcti7
  444.                    izcti7=ipkn
  445.          elseif (izcti8.eq.ipkn) then
  446.          elseif (izcti8.gt.ipkn) then
  447.                    izcti8=ipkn
  448.          endif
  449.          endif
  450.                endif
  451.                enddo
  452.                         IPOS(I+NODES)=IPOSMAX-1
  453.                         IPOS(I+2*NODES)=IPOS(I+2*NODES)+1
  454. *                 write (6,*) ' zone ',i,IPOS(I+NODES)
  455.                         if (icouch.le.4) masq(i)=.false.
  456.                         GOTO 20
  457.                 ENDIF
  458.  
  459.                 IF(NRELONG(I).EQ.L) THEN
  460. *  pour que le noeud soit bien dans la separation, il faut qu'il soit
  461. *  connecter a un noeud de profondeur plus élevée (prob des noeuds milieux)
  462.                     DO 100 J=1,IADJ(I+1)-IADJ(I)
  463.                        K=JADJC(IADJ(I)+J-1)
  464. C  K:voisin de I
  465. *                      if (k.eq.0) write (6,*) ' k peut valoir 0 '
  466.                        IF(K.EQ.0) GOTO 100
  467.                        IF (NRELONG(K).EQ.0) GOTO 100
  468.                        IF(MDOMN.NE.IPOS(k+NODES).and.
  469.      >                    ipos(k+nodes).lt.iposmax-2) then
  470.                           write (6,*) ' sepa2 mauvais domaine ',mdomn,
  471.      >                    ipos(k+nodes),nrelong(k)
  472.                           GOTO 100
  473.                        endif
  474.                        IF(NRELONG(K).GT.L) GOTO 110
  475.  100                CONTINUE
  476. *  recherche de izcti
  477.                do kk=iadj(i),iadj(i+1)-1
  478.                  k=jadjc(kk)
  479.                if (k.ne.0) then
  480.          if (nrelong(k).eq.0) then
  481.              ipkn=ipos(ipos(k+nodes)+1)
  482.          if (izcti1.eq.ipkn) then
  483.          elseif (izcti1.gt.ipkn) then
  484.                    izcti8=izcti7
  485.                    izcti7=izcti6
  486.                    izcti6=izcti5
  487.                    izcti5=izcti4
  488.                    izcti4=izcti3
  489.                    izcti3=izcti2
  490.                    izcti2=izcti1
  491.                    izcti1=ipkn
  492.          elseif (izcti2.eq.ipkn) then
  493.          elseif (izcti2.gt.ipkn) then
  494.                    izcti8=izcti7
  495.                    izcti7=izcti6
  496.                    izcti6=izcti5
  497.                    izcti5=izcti4
  498.                    izcti4=izcti3
  499.                    izcti3=izcti2
  500.                    izcti2=ipkn
  501.          ELSEIF (IZCTI3.EQ.ipkn) THEN
  502.          elseif (izcti3.gt.ipkn) then
  503.                    izcti8=izcti7
  504.                    izcti7=izcti6
  505.                    izcti6=izcti5
  506.                    izcti5=izcti4
  507.                    izcti4=izcti3
  508.                    izcti3=ipkn
  509.          elseif (izcti4.eq.ipkn) then
  510.          elseif (izcti4.gt.ipkn) then
  511.                    izcti8=izcti7
  512.                    izcti7=izcti6
  513.                    izcti6=izcti5
  514.                    izcti5=izcti4
  515.                    izcti4=ipkn
  516.          elseif (izcti5.eq.ipkn) then
  517.          elseif (izcti5.gt.ipkn) then
  518.                    izcti8=izcti7
  519.                    izcti7=izcti6
  520.                    izcti6=izcti5
  521.                    izcti5=ipkn
  522.          elseif (izcti6.eq.ipkn) then
  523.          elseif (izcti6.gt.ipkn) then
  524.                    izcti8=izcti7
  525.                    izcti7=izcti6
  526.                    izcti6=ipkn
  527.          elseif (izcti7.eq.ipkn) then
  528.          elseif (izcti7.gt.ipkn) then
  529.                    izcti8=izcti7
  530.                    izcti7=ipkn
  531.          elseif (izcti8.eq.ipkn) then
  532.          elseif (izcti8.gt.ipkn) then
  533.                    izcti8=ipkn
  534.          endif
  535.          endif
  536.                endif
  537.                enddo
  538.                     IPOS(I+NODES)=IPOSMAX-1
  539.                         IPOS(I+2*NODES)=IPOS(I+2*NODES)+1
  540. *                 write (6,*) ' zone ',i,IPOS(I+NODES)
  541.                         if (icouch.le.4) masq(i)=.false.
  542.                     GOTO 20
  543.                 ENDIF
  544. *
  545. *  L'extérieur
  546.                 IF(NRELONG(I).GT.L) THEN
  547. *  recherche de izcte
  548.                do kk=iadj(i),iadj(i+1)-1
  549.                  k=jadjc(kk)
  550.                if (k.ne.0) then
  551.          if (nrelong(k).eq.0) then
  552.              ipkn=ipos(ipos(k+nodes)+1)
  553.          if (izcte1.eq.ipkn) then
  554.          elseif (izcte1.gt.ipkn) then
  555.                    izcte8=izcte7
  556.                    izcte7=izcte6
  557.                    izcte6=izcte5
  558.                    izcte5=izcte4
  559.                    izcte4=izcte3
  560.                    izcte3=izcte2
  561.                    izcte2=izcte1
  562.                    izcte1=ipkn
  563.          elseif (izcte2.eq.ipkn) then
  564.          elseif (izcte2.gt.ipkn) then
  565.                    izcte8=izcte7
  566.                    izcte7=izcte6
  567.                    izcte6=izcte5
  568.                    izcte5=izcte4
  569.                    izcte4=izcte3
  570.                    izcte3=izcte2
  571.                    izcte2=ipkn
  572.          elseif (izcte3.eq.ipkn) then
  573.          elseif (izcte3.gt.ipkn) then
  574.                    izcte8=izcte7
  575.                    izcte7=izcte6
  576.                    izcte6=izcte5
  577.                    izcte5=izcte4
  578.                    izcte4=izcte3
  579.                    izcte3=ipkn
  580.          elseif (izcte4.eq.ipkn) then
  581.          elseif (izcte4.gt.ipkn) then
  582.                    izcte8=izcte7
  583.                    izcte7=izcte6
  584.                    izcte6=izcte5
  585.                    izcte5=izcte4
  586.                    izcte4=ipkn
  587.          elseif (izcte5.eq.ipkn) then
  588.          elseif (izcte5.gt.ipkn) then
  589.                    izcte8=izcte7
  590.                    izcte7=izcte6
  591.                    izcte6=izcte5
  592.                    izcte5=ipkn
  593.          elseif (izcte6.eq.ipkn) then
  594.          elseif (izcte6.gt.ipkn) then
  595.                    izcte8=izcte7
  596.                    izcte7=izcte6
  597.                    izcte6=ipkn
  598.          elseif (izcte7.eq.ipkn) then
  599.          elseif (izcte7.gt.ipkn) then
  600.                    izcte8=izcte7
  601.                    izcte7=ipkn
  602.          elseif (izcte8.eq.ipkn) then
  603.          elseif (izcte8.gt.ipkn) then
  604.                    izcte8=ipkn
  605.          endif
  606.          endif
  607.                endif
  608.                enddo
  609.  
  610.                         IPOS(I+NODES)=IPOSMAX
  611.                         IPOS(I+2*NODES)=IPOS(I+2*NODES)+1
  612. *                 write (6,*) ' zone ',i,IPOS(I+NODES)
  613.                         if (icouch.le.4) masq(i)=.false.
  614.                         GOTO 20
  615.                 ENDIF
  616.                 GOTO 21
  617. *  la frontiere
  618.  110                    CONTINUE
  619. *                 write (6,*) ' zone ',i,IPOS(I+NODES)
  620.                         MASQ(I)=.FALSE.
  621.                         IPOS(I+NODES)=IPOSMAX-2
  622.                         DIMSEP=DIMSEP+1
  623.                         GOTO 20
  624.             ENDIF
  625. * mars
  626. 21      CONTINUE
  627.  
  628. 20      CONTINUE
  629. *        do 23 i=1,nodes
  630. *          IF(MDOMN.EQ.IPOS(I+NODES).AND.NRELONG(I).EQ.0) THEN
  631. *          write (6,*) ' zone non connexe 2 ',mdomn,i
  632. *          endif
  633. * 23     continue
  634.  
  635. *       write (6,*) ' taille de frontière ',dimsep-dimseq
  636. *       write (6,*) ' rang des zones ',izcti,izcte
  637.         ipos1=max(IPOS(IPOSMAX+1-1),IPOS(IPOSMAX+1+0))
  638.         ipos2=min(IPOS(IPOSMAX+1-1),IPOS(IPOSMAX+1+0))
  639.             if (izcti1.gt.izcte1) then
  640. *         write(6,*) 'sepa2 ordre 1 +'
  641.           IPOS(IPOSMAX+1-1)=ipos1
  642.           IPOS(IPOSMAX+1+0)=ipos2
  643.         elseif (izcti1.lt.izcte1) then
  644. *         write(6,*) 'sepa2 ordre 1 -'
  645.           IPOS(IPOSMAX+1-1)=ipos2
  646.           IPOS(IPOSMAX+1+0)=ipos1
  647.         elseif (izcti2.gt.izcte2) then
  648. *         write(6,*) 'sepa2 ordre 2 +'
  649.           IPOS(IPOSMAX+1-1)=ipos1
  650.           IPOS(IPOSMAX+1+0)=ipos2
  651.         elseif (izcti2.lt.izcte2) then
  652. *         write(6,*) 'sepa2 ordre 2 -'
  653.           IPOS(IPOSMAX+1-1)=ipos2
  654.           IPOS(IPOSMAX+1+0)=ipos1
  655.         elseif (izcti3.gt.izcte3) then
  656. *         write(6,*) 'sepa2 ordre 3 +'
  657.           IPOS(IPOSMAX+1-1)=ipos1
  658.           IPOS(IPOSMAX+1+0)=ipos2
  659.         elseif (izcti3.lt.izcte3) then
  660. *         write(6,*) 'sepa2 ordre 3 -'
  661.           IPOS(IPOSMAX+1-1)=ipos2
  662.           IPOS(IPOSMAX+1+0)=ipos1
  663.         elseif (izcti4.gt.izcte4) then
  664. *         write(6,*) 'sepa2 ordre 4 +'
  665.           IPOS(IPOSMAX+1-1)=ipos1
  666.           IPOS(IPOSMAX+1+0)=ipos2
  667.         elseif (izcti4.lt.izcte4) then
  668. *         write(6,*) 'sepa2 ordre 4 -'
  669.           IPOS(IPOSMAX+1-1)=ipos2
  670.           IPOS(IPOSMAX+1+0)=ipos1
  671.         elseif (izcti5.gt.izcte5) then
  672. *         write(6,*) 'sepa2 ordre 5 +'
  673.           IPOS(IPOSMAX+1-1)=ipos1
  674.           IPOS(IPOSMAX+1+0)=ipos2
  675.         elseif (izcti5.lt.izcte5) then
  676. *         write(6,*) 'sepa2 ordre 5 -'
  677.           IPOS(IPOSMAX+1-1)=ipos2
  678.           IPOS(IPOSMAX+1+0)=ipos1
  679.         elseif (izcti6.gt.izcte6) then
  680. *         write(6,*) 'sepa2 ordre 6 +'
  681.           IPOS(IPOSMAX+1-1)=ipos1
  682.           IPOS(IPOSMAX+1+0)=ipos2
  683.         elseif (izcti6.lt.izcte6) then
  684. *         write(6,*) 'sepa2 ordre 6 -'
  685.           IPOS(IPOSMAX+1-1)=ipos2
  686.           IPOS(IPOSMAX+1+0)=ipos1
  687.         elseif (izcti7.gt.izcte7) then
  688. *         write(6,*) 'sepa2 ordre 7 +'
  689.           IPOS(IPOSMAX+1-1)=ipos1
  690.           IPOS(IPOSMAX+1+0)=ipos2
  691.         elseif (izcti7.lt.izcte7) then
  692. *         write(6,*) 'sepa2 ordre 7 -'
  693.           IPOS(IPOSMAX+1-1)=ipos2
  694.           IPOS(IPOSMAX+1+0)=ipos1
  695.         elseif (izcti8.gt.izcte8) then
  696. *         write(6,*) 'sepa2 ordre 8 +'
  697.           IPOS(IPOSMAX+1-1)=ipos1
  698.           IPOS(IPOSMAX+1+0)=ipos2
  699.         elseif (izcti8.le.izcte8) then
  700. *         write(6,*) 'sepa2 ordre 8 -'
  701.           IPOS(IPOSMAX+1-1)=ipos2
  702.           IPOS(IPOSMAX+1+0)=ipos1
  703.         else
  704. *          write (6,*) ' ordonnancement impossible'
  705. *    > izcti1,izcti2,izcti3,izcti4,izcti5,izcti6,
  706. *    > izcte1,izcte2,izcte3,izcte4,izcte5,izcte6
  707.           IPOS(IPOSMAX+1-1)=ipos1
  708.           IPOS(IPOSMAX+1+0)=ipos2
  709.         endif
  710.  
  711. 50      continue
  712.          do ix=1,dimlon
  713.            ii=noelon(ix)
  714.            if(ii.ne.0) nrelong(ii)=0
  715.          enddo
  716.  
  717.         RETURN
  718.         END
  719.  
  720.  
  721.  
  722.  
  723.  
  724.  
  725.  
  726.  
  727.  
  728.  
  729.  
  730.  
  731.  
  732.  
  733.  
  734.  
  735.  
  736.  
  737.  
  738.  
  739.  
  740.  
  741.  
  742.  
  743.  
  744.  
  745.  
  746.  
  747.  
  748.  
  749.  
  750.  
  751.  
  752.  
  753.  
  754.  
  755.  
  756.  
  757.  
  758.  
  759.  
  760.  
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  
  768.  
  769.  
  770.  
  771.  
  772.  
  773.  
  774.  

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