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

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