Initial commit from Polytechnique Montreal

1 files changed, 150 insertions, 0 deletions

diff --git a/Dragon/src/g2s_generatingTrack.f90 b/Dragon/src/g2s_generatingTrack.f90
new file mode 100644
index 0000000..14501ee
--- /dev/null
+++ b/Dragon/src/g2s_generatingTrack.f90
@@ -0,0 +1,150 @@
+!
+!-----------------------------------------------------------------------
+!
+!Purpose:
+! Generate data relative to gigognes originating from nodes and generate
+! tracking indices assigned to them.
+!
+!Copyright:
+! Copyright (C) 2001 Ecole Polytechnique de Montreal.
+! This library is free software; you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public
+! License as published by the Free Software Foundation; either
+! version 2.1 of the License, or (at your option) any later version.
+!
+!Author(s):
+! G. Civario (CS-SI)
+!
+!Comments:
+! Ce module possede trois fonctions:
+!  - generateTrack : fonction d'entree du module
+!  - calculFinalMerge : calcul de la numerotation type dragon
+!  - ltVec : fonction d'ordre specifique pour des vecteurs d'entiers de tailles
+!            differentes
+!
+module track
+
+    use cellulePlaced
+    use segArc
+    use ptNodes
+    implicit none
+
+contains
+  subroutine generateTrack(szP,szSa,nbNode,lgMaxGig,gig,merg)
+    integer,intent(in) :: szP,szSa,nbNode,lgMaxGig
+    integer,dimension(lgMaxGig*nbNode),intent(out) :: gig
+    integer,dimension(nbNode),intent(inout) :: merg
+    
+    integer :: i,lgMaxMrg,s,d,lgMaxGigTest
+    integer,dimension(:,:),allocatable :: mrgMat
+    
+    lgMaxGigTest = 0
+    lgMaxMrg = 0
+    do i = 1,szP
+       lgMaxGigTest = max(lgMaxGigTest,size(tabCellulePlaced(i)%gig))
+       lgMaxMrg = max(lgMaxMrg,size(tabCellulePlaced(i)%mrg))
+    end do
+    if(lgMaxGigTest /= lgMaxGig) call XABORT('g2s_generatingTrack: lgMax error')
+    lgMaxMrg = lgMaxMrg + 1
+    allocate(mrgMat(lgMaxMrg,nbNode),stat=alloc_ok)
+    if (alloc_ok /= 0) call XABORT("G2S: generateTrack => allocation pb")
+    gig = 0
+    mrgMat = 0
+    do i = 1,szSa
+       if (tabSegArc(i)%nodeg>0.and.tabSegArc(i)%indCellPg>0) then
+          s = size(tabCellulePlaced(tabSegArc(i)%indCellPg)%gig)
+          d = (tabSegArc(i)%nodeg-1)*lgMaxGig+1
+          gig(d:d+s-1) = tabCellulePlaced(tabSegArc(i)%indCellPg)%gig(1:s)
+          s = size(tabCellulePlaced(tabSegArc(i)%indCellPg)%mrg)
+          d = tabSegArc(i)%nodeg
+          mrgMat(1:s,d) = tabCellulePlaced(tabSegArc(i)%indCellPg)%mrg(1:s)
+          mrgMat(s+1,d) = merg(d)
+       end if
+       if (tabSegArc(i)%noded>0.and.tabSegArc(i)%indCellPd>0) then
+          s = size(tabCellulePlaced(tabSegArc(i)%indCellPd)%gig)
+          d = (tabSegArc(i)%noded-1)*lgMaxGig+1
+          gig(d:d+s-1) = tabCellulePlaced(tabSegArc(i)%indCellPd)%gig(1:s)
+          s = size(tabCellulePlaced(tabSegArc(i)%indCellPd)%mrg)
+          d = tabSegArc(i)%noded
+          mrgMat(1:s,d) = tabCellulePlaced(tabSegArc(i)%indCellPd)%mrg(1:s)
+          mrgMat(s+1,d) = merg(d)
+       end if
+    end do
+    call calculFinalMerge(mrgMat,merg)
+    deallocate(mrgMat)
+  end subroutine generateTrack
+
+  subroutine calculFinalMerge(inMat,outVec)
+    integer,dimension(:,:),intent(in) :: inMat
+    integer,dimension(:),intent(out)  :: outVec
+    
+    integer :: i,j,d1,d2,maxD2
+    logical :: found,sorted
+    integer,dimension(:),allocatable   :: tmpVec
+    integer,dimension(:,:),allocatable :: workMat
+    
+    d1 = size(inMat,1) !profondeur max de gigogne + 1
+    d2 = size(inMat,2) !nombre de nodes
+    maxD2 = 0
+    allocate(workMat(d1,d2))
+    allocate(tmpVec(d1),stat=alloc_ok)
+    if (alloc_ok /= 0) call XABORT("G2S: calculFinalMerge => allocation pb")
+    workMat(:d1,:d2) = 0
+    !remplissage de workMat a l'aide d'occurences uniques de lignes de inMat
+    do i = 1,d2
+       found = .false.
+       do j = 1,maxD2
+          if (all(workMat(:d1,j)==inMat(:d1,i))) then
+             found = .true.
+             exit
+          end if
+       end do
+       if (.not. found) then
+          maxD2 = maxD2 + 1
+          workMat(:d1,maxD2) = inMat(:d1,i)
+       end if
+    end do
+    !classement des lignes de workMat en ordre croissant par bubble-sort
+    do j = maxD2,2,-1
+       sorted = .true.
+       do i = 1,j-1
+          if (ltVec(workMat(:d1,i+1),workMat(:d1,i))) then
+             tmpVec(:d1)      = workMat(:d1,i+1)
+             workMat(:d1,i+1) = workMat(:d1,i)
+             workMat(:d1,i)   = tmpVec(:d1)
+             sorted = .false.
+          end if
+       end do
+       if (sorted) exit
+    end do
+    !remplissage de outVec en fonction de l'egalite entre les lignes de workMat
+    !et inMat, apres le classement
+    do i = 1,d2
+       do j = 1,maxD2
+          if (all(workMat(:d1,j)==inMat(:d1,i))) then
+             outVec(i) = j
+             exit
+          end if
+       end do
+    end do
+    
+    deallocate(workMat,tmpVec)
+  end subroutine calculFinalMerge
+  
+  function ltVec(v1,v2)
+    integer,dimension(:),intent(in) :: v1,v2
+    logical :: ltVec
+    integer :: i
+    
+    do i = 1,size(v1)
+       if (v1(i) < v2(i)) then
+          ltVec = .true.
+          return
+       else if (v1(i) > v2(i)) then
+          ltVec = .false.
+          return
+       end if
+    end do
+    ltVec = .false.
+  end function ltVec
+end module track