TABLE OF CONTENTS
- 1. UTI/zorder
UTI/zorder [ Methods ]
NOM
zorder
DESCRIPTION
Ensemble de routines necessaires aux codes de Morton Set of routines required for Morton codes Interfaces: Subroutine ->zordercurve3D ->convertDecBin ->convetrBinDec ->mixBinXBinYBinZ Function ->GETSIZE ->COORD_REAL2INT
SOURCE
! Ce logiciel est regi par la licence [CeCILL-B] ! This software is governed by the [CeCILL-B] license !=========================== DEBUT DES DECLARATIONS ==================== !.1----- Implicit, Use implicit none !=========================== DEBUT DU CODE EXECUTABLE ================== contains SUBROUTINE zordercurve3d(nx,ny,nz,nt) !=========================== DOCUMENTATION ============================= ! ! zordercurve3d(nx,ny,nz,nt) ! ! A partir des coordonnees, calculer le numero (id) ! associe a celle-ci a l aide du code de Morton ! !=========================== DEBUT DES DECLARATIONS ==================== !.1----- Implicit, Use IMPLICIT NONE ; !.2----- Declaration INTEGER :: sizex,sizey,sizez,smax,sizet ! SIZEX : Number of bits of the binary number associated at NX ; smax = max (sizex,y,z) INTEGER, INTENT(IN) :: nx ,ny ,nz ! NX : Integer associated at the coordinate x (not in the routine) INTEGER(kind=16), INTENT(OUT) :: nt ! NT : Integer associated at the Morton s number LOGICAL,DIMENSION(:),ALLOCATABLE :: Tx ,Ty ,Tz , Tt ! TX : Table (= binary number) associated at the integer NX !=========================== DEBUT DU CODE EXECUTABLE ================== ! ************************************ ! *** INITIALISATION DES VARIABLES *** ! ************************************ ! ***** Trouver le nombre de fois que l on divise par 2, le nb x ***** sizex = getsize(nx) sizey = getsize(ny) sizez = getsize(nz) ! **** Trouver le plus grand entre sizex et sizey ******************** smax = max(sizex,sizey,sizez) ! **** Calculer la taille du tableau Tz ***************************** sizet = 3*smax ! ******************************** ! *** ALLOCATION DES VARIABLES *** ! ******************************** allocate(Tx(smax),Ty(smax),Tz(smax),Tt(sizet)) ! *************************** ! *** FONCTION PRINCIPALE *** ! *************************** ! ################################## ! ### Passer de Entier à Binaire ### ! ################################## call convertDecBin(nx,Tx,smax,sizex) call convertDecBin(ny,Ty,smax,sizey) call convertDecBin(nz,Tz,smax,sizez) ! ###################################################### ! ### Mixer les 2 binaires suivant le code de Morton ### ! ###################################################### call mixBinXBinYBinZ(Tx,Ty,Tz,smax, Tt) ! ################################## ! ### Passer de Binaire à Entier ### ! ################################## call convertBinDec(Tt,sizet,nt) ! *********************************** ! *** DESALLOCATION DES VARIABLES *** ! *********************************** deallocate(Tx,Ty,Tz,Tt) end subroutine zordercurve3d SUBROUTINE zordercurve2d(nx,ny,nt) !=========================== DOCUMENTATION ============================= ! ! zordercurve3d(nx,ny,nt) ! ! A partir des coordonnees, calculer le numero (id) ! associe a celle-ci a l aide du code de Morton !=========================== DEBUT DES DECLARATIONS ==================== !.1----- Implicit, Use implicit none !.2----- Declaration INTEGER :: sizex,sizey,smax,sizet ! SIZEX : Number of bits of the binary number associated at NX ; smax = max (sizex,y) INTEGER, INTENT(IN) :: nx, ny ! NX : Integer associated at the coordinate x (not in the routine) INTEGER(kind=16), INTENT(OUT) :: nt ! NT : Integer associated at the Morton s number LOGICAL,DIMENSION(:),ALLOCATABLE :: Tx, Ty, Tt ! TX : Table (= binary number) associated at the integer NX !=========================== DEBUT DU CODE EXECUTABLE ================== ! *** INITIALISATION DES VARIABLES *** sizex = getsize(nx) sizey = getsize(ny) smax = max(sizex,sizey) sizet = 2*smax allocate(Tx(smax),Ty(smax),Tt(sizet)) ! ### Passer de Entier à Binaire ### call convertDecBin(nx,Tx,smax,sizex) call convertDecBin(ny,Ty,smax,sizey) ! ### Mixer les 2 binaires suivant le code de Morton ### call mixBinXBinY(Tx,Ty,smax, Tt) ! ### Passer de Binaire à Entier ### call convertBinDec(Tt,sizet,nt) deallocate(Tx,Ty,Tt) END SUBROUTINE zordercurve2d ! ***************** ! *** FONCTIONS *** ! ***************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FUNCTION GETSIZE(N) ! What will be the size of the binary number associated at N ? INTEGER, INTENT(IN) :: N ! input INTEGER :: NTEST ! var integer::getsize GETSIZE = 0 NTEST = 0 DO WHILE( NTEST< N ) NTEST = NTEST + 2**GETSIZE GETSIZE = GETSIZE+1 ENDDO IF( N==0 ) GETSIZE = 1 END FUNCTION GETSIZE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ******************* ! *** SUBROUTINES *** ! ******************* ! **************************** ! *** Convertir en Binaire *** ! **************************** SUBROUTINE convertDecBin(x,Tx,smax,sizex) IMPLICIT NONE ; integer::i integer::smax,sizex,x,xcopie logical,dimension(smax)::Tx logical::r xcopie = x Tx(:) = .false. r = (mod(2,2)==1) i = smax DO WHILE( i>=(smax-sizex+1)) Tx(i) = (mod(xcopie,2) == 1) xcopie = (xcopie- mod(xcopie,2) ) /2 i = i - 1 ENDDO end subroutine convertDecBin ! **************************** ! *** Convertir en Decimal *** ! **************************** subroutine convertBinDec(Tz,sizez,numDec) implicit none integer::i,sizez integer(kind=16) :: numDec logical,dimension(sizez)::Tz numDec = 0 numdec=0 do i=1,sizez if(Tz(i))then numDec = numDec + (int(2,16))**(sizez - i) endif enddo !=========================== FIN DE LA ROUTINE ==================== end subroutine convertBinDec ! ******************************* ! *** Mixer selon code Morton *** ! ******************************* SUBROUTINE mixBinXBinYBinZ(Tx,Ty,Tz,smax,Tt) IMPLICIT NONE INTEGER, INTENT(IN) :: smax LOGICAL, DIMENSION(:), ALLOCATABLE, INTENT(IN) :: Tx, Ty, Tz LOGICAL, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: Tt INTEGER :: I, J, K ! loop I = 1 J = 0 K = 0 ! CHECK IF TX, TY, TZ, TT ALLOCATED IF( .NOT.ALLOCATED(TX) ) THEN WRITE(*,*) "ERROR 01 (mixBinXBinYBinZ) : TX NOT ALLOCATED " STOP ENDIF IF( .NOT.ALLOCATED(TY) ) THEN WRITE(*,*) "ERROR 02 (mixBinXBinYBinZ) : TY NOT ALLOCATED " STOP ENDIF IF( .NOT.ALLOCATED(TZ) ) THEN WRITE(*,*) "ERROR 03 (mixBinXBinYBinZ) : TZ NOT ALLOCATED " STOP ENDIF IF( .NOT.ALLOCATED(TT) ) ALLOCATE(TT(1:(3*SMAX))) !----------------------------------------- !--- Boucle pour remplir le tableau Tx --- !----------------------------------------- ! COMPUTE TT DO WHILE( ( (I+J+K)<=(3*SMAX) ).AND.( I<=SMAX ).AND.( J<=SMAX ).AND.( K<=SMAX) ) ! Car J et K debutent a 0 IF( MOD( (I+J+K),3 )==0 )THEN TT( I+J+K ) = TX( I ) !write(*,*) 'Tt(',i+j+k,') = ',TT(I+J+K) I = I + 1 ELSE IF( MOD( (I+J+K),3 )==2 )THEN TT( I+J+K ) = TY( J+1 ) ! CAR ON A DEBUTE A J = 0 !write(*,*) 'Tt(',i+j+k,') = ',TT(I+J+K) J = J + 1 ELSE TT( I+J+K ) = TZ( K+1 ) !write(*,*) 'Tt(',i+j+k,') = ',TT(I+J+K) K = K + 1 ENDIF END DO !write(*,*)'numero en binaire : ',TT end subroutine mixBinXBinYBinZ ! ******************************* ! *** Mixer selon code Morton en 2D*** ! ******************************* SUBROUTINE mixBinXBinY(Tx,Ty,smax,Tt) implicit none INTEGER, INTENT(IN) :: smax LOGICAL, DIMENSION(:), ALLOCATABLE, INTENT(IN) :: Tx, Ty LOGICAL, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: Tt INTEGER :: I, J, K ! loop I = 1 J = 0 K = 0 ! CHECK IF TX, TY, TZ, TT ALLOCATED IF( .NOT.ALLOCATED(TX) ) THEN WRITE(*,*) "ERROR 01 (mixBinXBinY) : TX NOT ALLOCATED " STOP ENDIF IF( .NOT.ALLOCATED(TY) ) THEN WRITE(*,*) "ERROR 02 (mixBinXBinY) : TY NOT ALLOCATED " STOP ENDIF IF( .NOT.ALLOCATED(TT) ) ALLOCATE(TT(1:(2*SMAX))) ! COMPUTE TT DO WHILE( ( (I+J)<=(2*SMAX) ).AND.( I<=SMAX ).AND.( J<=SMAX ) ) ! Car J debute a 0 IF( MOD( (I+J),2 )==0 )THEN TT( I+J ) = TX( I ) I = I + 1 ELSE TT( I+J ) = TY( J+1 ) ! CAR ON A DEBUTE A J = 0 J = J + 1 ENDIF END DO END SUBROUTINE mixBinXBinY FUNCTION COORD_REAL2INT(X, XMIN, DC) INTEGER::COORD_REAL2INT REAL(KIND = KIND(0.d0)), INTENT(IN) :: X, XMIN, DC ! DC = dimension caracteristique REAL(KIND=KIND(0.d0)), PARAMETER :: RAF=10.0 ! parametre de raffinage COORD_REAL2INT = 0 IF(DC == 0)THEN WRITE(*,*) "ERROR 01 (COORD_REAL2INT) : DeltaX = 0" STOP ENDIF COORD_REAL2INT = NINT((X-XMIN)*RAF/DC) ! 1/10 Dim caract : Vol/surf END FUNCTION COORD_REAL2INT subroutine parcoursR3(ch) use geo_typ implicit none Type(chaineR3), Pointer :: ch Type(chaineR3), Pointer :: dblech type (chaineR2), Pointer :: ch2 type (chaineR1), Pointer :: ch1 integer :: num num=0 dblech=>ch do while (associated(dblech%prec)) dblech=>dblech%prec end do do while (associated(dblech)) ch2=>dblech%cr2 do while (associated(ch2%prec)) ch2=>ch2%prec end do do while(associated(ch2)) ch1=>ch2%cr1 do while (associated(ch1%prec)) ch1=>ch1%prec end do do while(associated(ch1)) ch1%num=num num=num+1 ch1=>ch1%suiv end do ch2=>ch2%suiv end do dblech=>dblech%suiv end do end subroutine parcoursR3 ! !================================================================================================================ subroutine donne_num(x,y,z,R3,num,interieur) use geo_typ implicit none Type(chaineR3), Pointer :: R3 real*8, intent(in) :: x,y,z integer, intent(inout) :: num,interieur logical :: droite Type(chaineR3), Pointer :: temp ! interdit de rentrer dans cette routine si la chaine pointe sur null droite=.false. if (x>=R3%x-petit) droite=.true. do while (associated(R3)) temp=>R3 if (x>R3%x+petit) then if (droite) then R3=>R3%suiv else R3=>temp return end if else if (abs(x-R3%x)<petit) then ! print*,'avant R2' call donne_numR2(y,z,R3%cr2,num,interieur) return else if (droite) then R3=>temp return else R3=>R3%prec end if end if end if end do R3=>temp return end subroutine donne_num !----------------------------------------------- !----------------------------------------------- subroutine donne_numR2(y,z,R2,t,in) use geo_typ implicit none Type(chaineR2), Pointer :: R2 real*8, intent(in) :: y,z integer, intent(inout) :: t,in logical :: droite Type(chaineR2), Pointer :: temp ! interdit de rentrer dans cette routine si la chaine pointe sur null droite=.false. if (y>=R2%y-petit) droite=.true. do while (associated(R2)) temp=>R2 if (y>R2%y+petit) then if (droite) then R2=>R2%suiv else R2=>temp return end if else if (abs(y-R2%y)<petit) then call donne_numR1(z,R2%cr1,t,in) return else if (droite) then R2=>temp return else R2=>R2%prec end if end if end if end do R2=>temp return end subroutine donne_numR2 !-------------------------- !----------------------------------------------- subroutine donne_numR1(z,R1,t,in) use geo_typ implicit none Type(chaineR1), Pointer :: R1 real*8, intent(in) :: z integer, intent(inout) :: t,in logical :: droite Type(chaineR1), Pointer :: temp ! inrterdit de rentrer dans cette routine si la chaine pointe sur null droite=.false. if (z>=R1%z-petit) droite=.true. do while (associated(R1)) temp=>R1 if (z>R1%z+petit) then if (droite) then R1=>R1%suiv else R1=>temp return end if else if (abs(z-R1%z)<petit) then t=R1%num in=R1%interieur return else if (droite) then R1=>temp return else R1=>R1%prec end if end if end if end do R1=>temp !print*,'probleme' return end subroutine donne_numR1 !--------------------------- subroutine rangeR3(x,y,z,R3,t) use geo_typ implicit none Type(chaineR3), Pointer :: R3 real*8, intent(in) :: x,y,z integer, intent(inout) :: t logical :: droite Type(chaineR3), Pointer :: chloc,temp Type(chaineR2), Pointer :: locR2 Type(chaineR1), Pointer :: locR1 ! inrterdit de rentrer dans cette routine si la chaine pointe sur null droite=.false. if (x>=R3%x-petit) droite=.true. do while (associated(R3)) temp=>R3 if (x>R3%x+petit) then if (droite) then R3=>R3%suiv else t=t+1 call insertdroitex(x,y,z,R3) R3%cr2%cr1%num=t return end if else if (abs(x-R3%x).le.petit) then call rangeR2(y,z,R3%cr2,t) return else if (droite) then t=t+1 call insertgauchex(x,y,z,R3) R3%cr2%cr1%num=t return else R3=>R3%prec end if end if end if end do !cas du bout de liste droite ou gauche allocate (locR1) locR1%z=z Nullify(locR1%suiv) ; Nullify(locR1%prec) allocate (locR2) t=t+1 locR1%num=t locR2%y=y locR2%cr1=>locR1 nullify(locR2%suiv) nullify(locR2%prec) allocate(chloc) chloc%x=x chloc%cr2=>locR2 if (droite) then !ajout à droite de temp chloc%prec=>temp nullify(chloc%suiv) temp%suiv=>chloc else !ajout à gauche de temp chloc%suiv=>temp nullify(chloc%prec) temp%prec=>chloc end if !!!modif R3=>chloc ! R3=>temp ! print*,'dans range',R3%x return end subroutine rangeR3 !----------------------------------------------- subroutine rangeR2(y,z,R2,t) use geo_typ !use geo, only: insertdroitey, rangeR1, insertgauchey implicit none Type(chaineR2), Pointer :: R2 real*8, intent(in) :: y,z integer, intent(inout) :: t logical :: droite Type(chaineR2), Pointer :: chloc,temp Type(chaineR1), Pointer :: locR1 ! interdit de rentrer dans cette routine si la chaine pointe sur null droite=.false. if (y>=R2%y-petit) droite=.true. do while (associated(R2)) temp=>R2 if (y>R2%y+petit) then if (droite) then R2=>R2%suiv else t=t+1 call insertdroitey(y,z,R2) R2%cr1%num=t return end if else if (abs(y-R2%y).le.petit) then call rangeR1(z,R2%cr1,t) return else if (droite) then t=t+1 call insertgauchey(y,z,R2) R2%cr1%num=t return else R2=>R2%prec end if end if end if end do !cas du bout de liste droite ou gauche allocate (locR1) locR1%z=z Nullify(locR1%suiv) ; Nullify(locR1%prec) t=t+1 locR1%num=t allocate(chloc) chloc%y=y chloc%cr1=>locR1 if (droite) then !ajout à droite de temp chloc%prec=>temp nullify(chloc%suiv) temp%suiv=>chloc else !ajout à gauche de temp chloc%suiv=>temp nullify(chloc%prec) temp%prec=>chloc end if !modif R2=>chloc!temp return end subroutine rangeR2 !----------------------------------------------- subroutine rangeR1(z,R1,t) use geo_typ !use geo, only: insertdroitez, insertgauchez implicit none Type(chaineR1), Pointer :: R1 real*8, intent(in) :: z integer, intent(inout) :: t logical :: droite Type(chaineR1), Pointer :: chloc,temp ! interdit de rentrer dans cette routine si la chaine pointe sur null droite=.false. if (z>=R1%z-petit) droite=.true. do while (associated(R1)) temp=>R1 if (z>R1%z+petit) then if (droite) then R1=>R1%suiv else t=t+1 call insertdroitez(z,R1) R1%num=t return end if else if (abs(z-R1%z).le.petit) then return else if (droite) then t=t+1 call insertgauchez(z,R1) R1%num=t return else R1=>R1%prec end if end if end if end do !cas du bout de liste droite ou gauche t=t+1 allocate(chloc) chloc%z=z chloc%num=t if (droite) then !ajout à droite de temp chloc%prec=>temp nullify(chloc%suiv) temp%suiv=>chloc else !ajout à gauche de temp chloc%suiv=>temp nullify(chloc%prec) temp%prec=>chloc end if R1=>chloc!temp return end subroutine rangeR1 !----------------------------------------------- subroutine insertgauchex(x,y,z,ch) use geo_typ implicit none real*8, intent(in) :: x,y,z Type(chaineR3), Pointer :: ch ! Type(chaineR3), Pointer :: temp, locch type(chaineR2), Pointer :: locR2 type(chaineR1), Pointer :: locR1 ! !cas du bout de liste droite ou gauche temp=>ch%prec allocate (locch) locch%x=x allocate (locR2) locR2%y=y nullify(locR2%suiv) nullify(locR2%prec) allocate (locR1) locR1%z=z nullify(locR1%suiv) nullify(locR1%prec) locR2%cr1=>locR1 locch%cr2=>locR2 locch%suiv=>ch ch%prec=>locch locch%prec=>temp temp%suiv=>locch !modif ch=>locch return end subroutine insertgauchex !----------------------------------------------- subroutine insertdroitex(x,y,z,ch) use geo_typ implicit none real*8, intent(in) :: x,y,z Type(chaineR3), Pointer :: ch ! Type(chaineR3), Pointer :: temp, locch type(chaineR2), Pointer :: locR2 type(chaineR1), Pointer :: locR1 ! ! ! !cas du bout de liste droite ou gauche temp=>ch%suiv allocate (locch) locch%x=x allocate (locR2) locR2%y=y nullify(locR2%suiv) nullify(locR2%prec) allocate (locR1) locR1%z=z nullify(locR1%suiv) nullify(locR1%prec) locR2%cr1=>locR1 locch%cr2=>locR2 locch%suiv=>temp temp%prec=>locch locch%prec=>ch ch%suiv=>locch !modif ch=>locch return end subroutine insertdroitex !----------------------------------------------- subroutine insertgauchey(y,z,ch) use geo_typ implicit none real*8, intent(in) :: y,z Type(chaineR2), Pointer :: ch ! Type(chaineR2), Pointer :: temp, locch type(chaineR1), Pointer :: locR1 ! ! ! !cas du bout de liste droite ou gauche temp=>ch%prec allocate (locch) locch%y=y allocate (locR1) locR1%z=z nullify(locR1%suiv) nullify(locR1%prec) locch%cr1=>locR1 locch%suiv=>ch ch%prec=>locch locch%prec=>temp temp%suiv=>locch !modif ch=>locch return end subroutine insertgauchey !----------------------------------------------- subroutine insertdroitey(y,z,ch) use geo_typ implicit none real*8, intent(in) :: y,z Type(chaineR2), Pointer :: ch ! Type(chaineR2), Pointer :: temp, locch type(chaineR1), Pointer :: locR1 ! ! ! !cas du bout de liste droite ou gauche temp=>ch%suiv allocate (locch) locch%y=y allocate (locR1) locR1%z=z nullify(locR1%suiv) nullify(locR1%prec) locch%cr1=>locR1 locch%suiv=>temp temp%prec=>locch locch%prec=>ch ch%suiv=>locch !modif ch=>locch return end subroutine insertdroitey !----------------------------------------------- !----------------------------------------------- subroutine insertgauchez(z,ch) use geo_typ implicit none real*8, intent(in) :: z Type(chaineR1), Pointer :: ch ! Type(chaineR1), Pointer :: temp, locch ! ! ! !cas du bout de liste droite ou gauche temp=>ch%prec allocate (locch) locch%z=z locch%suiv=>ch ch%prec=>locch locch%prec=>temp temp%suiv=>locch !modif ch=>locch return end subroutine insertgauchez !----------------------------------------------- subroutine insertdroitez(z,ch) use geo_typ implicit none real*8, intent(in) :: z Type(chaineR1), Pointer :: ch ! Type(chaineR1), Pointer :: temp, locch ! ! ! !cas du bout de liste droite ou gauche temp=>ch%suiv allocate (locch) locch%z=z locch%suiv=>temp temp%prec=>locch locch%prec=>ch ch%suiv=>locch !modif ch=>locch return end subroutine insertdroitez !=========================== FIN DU MODULE ========================= END MODULE zorder