rcm.f

关于网格自动生成delaunay算法的

**********************************************************************
*     Reverse cuthill-mckee method                                   *
*     1997.7.12                                            Ver.1.0   *
**********************************************************************
      subroutine rcm(mpoin,msrch,mtail,npoin,nadrs,isrch
     $     ,ircm,ltail,ma,ir,iw,kfx,kfdx)
      implicit real*8(a-h,o-z)
      integer ma(0:mpoin),ir(mpoin),iw(mpoin)
      integer kfx(mpoin),kfdx(mpoin)
      integer isrch(2,msrch),ltail(mtail)
      if(ircm.eq.1) then
         call rcmmain(mpoin,msrch,mtail,npoin,nadrs,isrch
     $        ,ltail,ma,ir,iw,kfx,kfdx)
      else
         write(6,110)
         do 100 ipoin= 1,npoin
            kfx(ipoin)= ipoin
            kfdx(ipoin)= ipoin
 100     continue
      endif
 110  format(//5x,75('*'),
     $        /8x,'Message from RCM main!!!',
     $        /8x,'RCM option is not available !',
     $        /8x,'You shoud use RCM option by setting ircm=1 !!!',
     $        /5x,75('*'))
      return
      end
*
**********************************************************************
*     main program of Reverse cuthill-mckee method                   *
*     1997.7.10                                            Ver.1.0   *
**********************************************************************
      subroutine rcmmain(mpoin,msrch,mtail,npoin,nadrs,isrch
     $     ,ltail,ma,ir,iw,kfx,kfdx)
      implicit real*8(a-h,o-z)
      integer ma(0:mpoin),ir(mpoin),iw(mpoin)
      integer kfx(mpoin),kfdx(mpoin)
      integer isrch(2,msrch),ltail(mtail)
*
*---- finding root node
*
      min= 1000000
      irow= 0
      itotal= 0
      level= 0
      do 10 i= 1, npoin
         iw(i)= -1
         call search(msrch,npoin,i,nadrs,isrch,mtail,ltail)
         if(ltail(1).lt.min) then
            min= ltail(1)
            irow= i
         endif
 10   continue
      iw(irow)= level
      itotal= itotal+1
*
*--- setting level with each node and sorting each level
*
      ma(0) = 0
      ma(1) = 1
      ir(1) = irow
      do 100 while(.true.)
         level= level+1
         do i=ma(level-1)+1,ma(level)
            call search(msrch,npoin,ir(i),nadrs,isrch,mtail,ltail)
            do j=2,ltail(1)+1
               if(iw(ltail(j)).eq.-1) then
                  itotal = itotal + 1
                  iw(ltail(j)) = level
                  ir(itotal) = ltail(j)
               endif
            enddo
            ma(level+1) = itotal
         enddo
         if(itotal.eq.npoin) then
            goto 45
         endif
 100  continue
 45   continue
*
*--- renumbering nodes
*
      do 220 i= 1, npoin
         kfdx(i)= ir(npoin-i+1)
 220  continue
      do 230 i= 1,npoin
         kfx(kfdx(i))= i
 230  continue
      return
      end
*
**********************************************************************
*     returning renumbered nodes to the initial order
**********************************************************************
      subroutine renode(mpoin,ng,npoin,nszf,kfdx,tforc,pload)
      implicit real*8(a-h,o-z)
      dimension  kfdx(mpoin)
      dimension  tforc(mpoin*ng), pload(mpoin*ng)
      call zerod(npoin*ng,pload)
      do 100 i= 1, npoin
         ipoin= kfdx(i)
         do 110 ig= 1,ng
            pload((ipoin-1)*ng+ig)= tforc((i-1)*ng+ig)
 110     continue
 100  continue
      do 200 iszf= 1, nszf
         tforc(iszf)= pload(iszf)
 200  continue
      return
      end