!----------------------------------------------------------------------- ! SUBROUTINE tree_sort ! ! !----------------------------------------------------------------------- ! ! ! Subroutine to insert the bodies into the tree up to the l_end level ! Bodies are re-arranged in pos_sort and vel_sort arrays that ! are sorted following the tree schema. ! !----------------------------------------------------------------------- USE fly_h INCLUDE 'mpif.h' ! Declaration of local variables. ! ------------------------------- REAL(KIND=8), DIMENSION (nsubcell,ndim) :: pm1 REAL(KIND=8), DIMENSION (ndim):: pl,pcl,pcl_par REAL(KIND=8) :: cl_size INTEGER(KIND=4) :: nbodlist,ip_pr INTEGER(KIND=4), DIMENSION (1) :: n_sort INTEGER(KIND=4) :: n_sort_PE0 INTEGER(KIND=4), DIMENSION (nb_loc) :: sub_temp1,par_temp1 INTEGER(KIND=4), DIMENSION (ndim) :: nindex INTEGER(KIND=4), DIMENSION (nsubcell) ::isub INTEGER :: i,j,k,ind_cl,ic,tag,istatus(MPI_STATUS_SIZE) CHARACTER(LEN=4) ::ifl CHARACTER(LEN=256) :: name_file DATA pm1/4*-1.,4*1.,2*-1.,2*1.,2*-1.,2*1.,-1.,1.,-1.,1., & & -1.,1.,-1.,1./,nindex/4,2,1/ !----------------------------------------------------------------------- #ifdef SORT root=nbodsmax+1 pos_sort=0.0 vel_sort=0.0 IF(l_end.gt.4) l_end=4 IF(l_end.lt.2) l_end=2 CALL MPI_BARRIER(MPI_COMM_WORLD,ierror) !---------------------------------------------------------------------- ! Compute coordinates of center of root cell. !---------------------------------------------------------------------- subp=0 !zeroing all the tree DO k=1,ndim pos_cell(k,1)=rmin(k)+0.5*rsize ENDDO IF(me.eq.0) write(uterm,*) 'FLY_SORT: nbodies=',nbodies,' Ending level=', l_end !----------------------------------------------------------------------- ! Place all bodies on active body list, having root as parent; place ! root on active cell list. !----------------------------------------------------------------------- par_temp1(1:nb_res_loc(me+1))=root nbodlist=nb_res_loc(me+1) lmax=1 cell_ss(1,1)=root cell_ss(1,2)=root size_level(1)=rsize !----------------------------------------------------------------------- ! Create local complete tree structure !----------------------------------------------------------------------- CALL MPI_BARRIER(MPI_COMM_WORLD,ierror) DO i=1,l_end ip_pr=cell_ss(i,2) cl_size=size_level(i)*0.5 DO j=cell_ss(i,1),cell_ss(i,2) DO k=1,nsubcell ind_cl=j-nbodsmax ip_pr=ip_pr+1 pcl_par(1:3)=pos_cell(1:3,ind_cl) subp(k,ind_cl)=ip_pr pcl(1)=pcl_par(1)+pm1(k,1)*0.5*cl_size pcl(2)=pcl_par(2)+pm1(k,2)*0.5*cl_size pcl(3)=pcl_par(3)+pm1(k,3)*0.5*cl_size ind_loc_2=ip_pr-nbodsmax pos_cell(1:3,ind_loc_2)=pcl(1:3) ENDDO !k ENDDO !j cell_ss(i+1,1)=cell_ss(i,2)+1 cell_ss(i+1,2)=ip_pr size_level(i+1)=size_level(i)*0.5 ENDDO !i !----------------------------------------------------------------------- ! Compute parent for each local body !----------------------------------------------------------------------- DO i=1,nbodlist pl(1:3)= pos(1:3,i) DO j=1,l_end sub_temp1(i)=1 ind_loc=par_temp1(i)-nbodsmax pcl(1:ndim)=pos_cell(1:ndim,ind_loc) DO k=1,ndim IF(pl(k).GE.pcl(k)) sub_temp1(i)=sub_temp1(i)+nindex(k) ENDDO ic=sub_temp1(i) ind_cl=par_temp1(i)-nbodsmax par_temp1(i)=subp(ic,ind_cl) ENDDO !j ENDDO !i !----------------------------------------------------------------------- ! Place bodies in sorted arraies and output data !----------------------------------------------------------------------- CALL MPI_BARRIER(MPI_COMM_WORLD, ierror) IF(me.eq.0) THEN ! Open output binary body data file. ! ---------------------------------- name_file=ibodfile IF(tstep.GT.1000) WRITE(ifl,'(I4.4)') tstep IF(tstep.GE.100 .AND. tstep .LT. 1000) WRITE(ifl,'(I3.3)') tstep IF(tstep.GE.10 .AND. tstep .LT. 100) WRITE(ifl,'(I2.2)') tstep IF(tstep.LT. 10) WRITE(ifl,'(I1.1)') tstep name_file=TRIM(name_file)//TRIM(ifl) //'_sort' IF(ouasc.eq.'A') THEN OPEN(UNIT=ubodsasc,FILE=name_file,STATUS='UNKNOWN') ELSE call c_open_so_bin(name_file) ENDIF ENDIF !if me.eq.0 ! Loop on all the cells of the last level ! ---------------------------------------- lmax=l_end+1 n_acc=0 n_acc1=0 DO j=cell_ss(lmax,1),cell_ss(lmax,2) n_sort(1)=0 DO i=1,nbodlist IF(par_temp1(i).ne.j) CYCLE n_sort(1)=n_sort(1)+1 pos_sort(1:3,n_sort(1))=pos(1:3,i) ENDDO ! do i n_acc=n_acc+n_sort(1) CALL MPI_BARRIER(MPI_COMM_WORLD, ierror) !----------------------------------------------------------------------- ! For this cell write output !----------------------------------------------------------------------- IF(me.eq.0) THEN n_sort_PE0=n_sort(1) nlong=n_sort_PE0*3 n_acc1=0 IF(nlong.gt.0) THEN IF(ouasc.eq.'A') THEN DO p=1,n_sort_PE0 WRITE(ubodsasc,1000) pos_sort(1,p),pos_sort(2,p),pos_sort(3,p) ENDDO ELSE call c_write_so_bin(pos_sort(1,1),nlong) ENDIF !if ouasc ENDIF pos_sort=0 n_acc1=n_acc1+n_sort(1) DO PE_indx=1,NPES-1 ! read and transmit tag=1 nlong=1 CALL MPI_RECV(n_sort(1), nlong, MPI_INTEGER4, PE_indx, tag, MPI_COMM_WORLD, istatus, ierror) tag=2 nlong=n_sort(1)*3 IF(nlong.gt.0) THEN CALL MPI_RECV(pos_sort(1,1), nlong, MPI_REAL8, PE_indx, tag, MPI_COMM_WORLD, istatus, ierror) IF(ouasc.eq.'A') THEN DO p=1,n_sort(1) WRITE(ubodsasc,1000) pos_sort(1,p),pos_sort(2,p),pos_sort(3,p) ENDDO ELSE call c_write_so_bin(pos_sort(1,1),nlong) ENDIF !if ouasc ENDIF pos_sort=0 n_acc1=n_acc1+n_sort(1) ENDDO ELSE ! if me.eq.0 tag=1 nlong=1 CALL MPI_SEND(n_sort(1), nlong, MPI_INTEGER4, PE0, tag, MPI_COMM_WORLD, ierror) tag=2 nlong=n_sort(1)*3 IF(nlong.gt.0) THEN CALL MPI_SEND(pos_sort(1,1), nlong, MPI_REAL8, PE0, tag, MPI_COMM_WORLD, ierror) ENDIF ENDIF ! if me.eq.0 !----------------------------------------------------------------------- ! Next cell of the last level !----------------------------------------------------------------------- CALL MPI_BARRIER(MPI_COMM_WORLD, ierror) ENDDO !do j !----------------------------------------------------------------------- ! Place velocities in sorted arraies and output data !----------------------------------------------------------------------- ! Loop on all the cells of the last level ! ---------------------------------------- ! lmax=l_end+1 DO j=cell_ss(lmax,1),cell_ss(lmax,2) n_sort(1)=0 DO i=1,nbodlist IF(par_temp1(i).ne.j) CYCLE n_sort(1)=n_sort(1)+1 vel_sort(1:3,n_sort(1))=vel(1:3,i) ENDDO ! do i n_acc=n_acc+n_sort(1) CALL MPI_BARRIER(MPI_COMM_WORLD, ierror) !----------------------------------------------------------------------- ! For this cell write output !----------------------------------------------------------------------- IF(me.eq.0) THEN n_sort_PE0=n_sort(1) nlong=n_sort_PE0*3 IF(nlong.gt.0) THEN IF(ouasc.eq.'A') THEN DO p=1,n_sort_PE0 WRITE(ubodsasc,1000) vel_sort(1,p),vel_sort(2,p),vel_sort(3,p) ENDDO ELSE call c_write_so_bin(vel_sort(1,1),nlong) ENDIF !if ouasc ENDIF vel_sort=0 DO PE_indx=1,NPES-1 ! read and transmit tag=3 nlong=1 CALL MPI_RECV(n_sort(1), nlong, MPI_INTEGER4, PE_indx, tag, MPI_COMM_WORLD, istatus, ierror) tag=4 nlong=n_sort(1)*3 IF(nlong.gt.0) THEN CALL MPI_RECV(vel_sort(1,1), nlong, MPI_REAL8, PE_indx, tag, MPI_COMM_WORLD, istatus, ierror) IF(ouasc.eq.'A') THEN DO p=1,n_sort(1) WRITE(ubodsasc,1000) vel_sort(1,p),vel_sort(2,p),vel_sort(3,p) ENDDO ELSE call c_write_so_bin(vel_sort(1,1),nlong) ENDIF !if ouasc ENDIF ENDDO ELSE ! if me.eq.0 tag=3 nlong=1 CALL MPI_SEND(n_sort(1), nlong, MPI_INTEGER4, PE0, tag, MPI_COMM_WORLD, ierror) tag=4 nlong=n_sort(1)*3 IF(nlong.gt.0) THEN CALL MPI_SEND(vel_sort(1,1), nlong, MPI_REAL8, PE0, tag, MPI_COMM_WORLD, ierror) ENDIF ENDIF ! if me.eq.0 !----------------------------------------------------------------------- ! Next cell of the last level !----------------------------------------------------------------------- CALL MPI_BARRIER(MPI_COMM_WORLD, ierror) ENDDO !do j 1000 FORMAT(3(1X,F20.10)) IF(me.eq.0) THEN IF(ouasc.eq.'A') THEN CLOSE(ubodsout) ELSE call c_close_so_bin() ENDIF write(uterm,*) 'FLY_SORT. Output sorted file ',TRIM(name_file),' is written.' call flush(6) ENDIF #endif RETURN END