MODULE domain_mod USE domain_param TYPE t_domain INTEGER :: face INTEGER :: iim INTEGER :: jjm INTEGER :: ii_begin INTEGER :: jj_begin INTEGER :: ii_end INTEGER :: jj_end INTEGER :: ii_nb INTEGER :: jj_nb INTEGER :: ii_begin_glo INTEGER :: jj_begin_glo INTEGER :: ii_end_glo INTEGER :: jj_end_glo INTEGER,POINTER :: assign_domain(:,:) INTEGER,POINTER :: assign_i(:,:) INTEGER,POINTER :: assign_j(:,:) INTEGER,POINTER :: edge_assign_domain(:,:,:) INTEGER,POINTER :: edge_assign_i(:,:,:) INTEGER,POINTER :: edge_assign_j(:,:,:) INTEGER,POINTER :: edge_assign_pos(:,:,:) REAL,POINTER :: xyz(:,:,:) REAL,POINTER :: neighbour(:,:,:,:) INTEGER,POINTER :: delta(:,:) REAL,POINTER :: vertex(:,:,:,:) LOGICAL,POINTER :: own(:,:) INTEGER,POINTER :: ne(:,:,:) INTEGER :: t_right INTEGER :: t_rup INTEGER :: t_lup INTEGER :: t_left INTEGER :: t_ldown INTEGER :: t_rdown INTEGER :: u_right INTEGER :: u_rup INTEGER :: u_lup INTEGER :: u_left INTEGER :: u_ldown INTEGER :: u_rdown INTEGER :: z_rup INTEGER :: z_up INTEGER :: z_lup INTEGER :: z_ldown INTEGER :: z_down INTEGER :: z_rdown INTEGER :: t_pos(6) INTEGER :: u_pos(6) INTEGER :: z_pos(6) END TYPE t_domain TYPE(t_domain),SAVE,ALLOCATABLE,TARGET :: domain(:) INTEGER :: ndomain CONTAINS SUBROUTINE create_domain USE grid_param IMPLICIT NONE INTEGER :: ind,nf,ni,nj,i,j INTEGER :: quotient, rest TYPE(t_domain),POINTER :: d ndomain=nsplit_i*nsplit_j*nb_face ALLOCATE(domain(ndomain)) ind=0 DO nf=1,nb_face DO nj=1,nsplit_j DO ni=1,nsplit_i ind=ind+1 d=>domain(ind) quotient=(iim_glo/nsplit_i) rest=MOD(iim_glo,nsplit_i) IF (ni-1 < rest) THEN d%ii_nb=quotient+1 d%ii_begin_glo=(quotient+1)*(ni-1)+1 ELSE d%ii_nb=quotient d%ii_begin_glo=(quotient+1)*rest+(ni-1-rest) * quotient+1 ENDIF d%ii_end_glo=d%ii_begin_glo+d%ii_nb-1 IF (ni/=nsplit_i) THEN d%ii_nb=d%ii_nb+1 d%ii_end_glo=d%ii_end_glo+1 ENDIF quotient=(jjm_glo/nsplit_j) rest=MOD(jjm_glo,nsplit_j) IF (nj-1 < rest) THEN d%jj_nb=quotient+1 d%jj_begin_glo=(quotient+1)*(nj-1)+1 ELSE d%jj_nb=quotient d%jj_begin_glo=(quotient+1)*rest+(nj-1-rest) * quotient+1 ENDIF d%jj_end_glo=d%jj_begin_glo+d%jj_nb-1 IF (nj/=nsplit_j) THEN d%jj_nb=d%jj_nb+1 d%jj_end_glo=d%jj_end_glo+1 ENDIF d%iim=d%ii_nb+2*halo d%jjm=d%jj_nb+2*halo d%ii_begin=halo+1 d%jj_begin=halo+1 d%ii_end=d%ii_begin+d%ii_nb-1 d%jj_end=d%jj_begin+d%jj_nb-1 d%face=nf ALLOCATE(d%assign_domain(d%iim,d%jjm)) ALLOCATE(d%assign_i(d%iim,d%jjm)) ALLOCATE(d%assign_j(d%iim,d%jjm)) ALLOCATE(d%edge_assign_domain(0:5,d%iim,d%jjm)) ALLOCATE(d%edge_assign_i(0:5,d%iim,d%jjm)) ALLOCATE(d%edge_assign_j(0:5,d%iim,d%jjm)) ALLOCATE(d%edge_assign_pos(0:5,d%iim,d%jjm)) ALLOCATE(d%delta(d%iim,d%jjm)) ALLOCATE(d%xyz(3,d%iim,d%jjm)) ALLOCATE(d%vertex(3,0:5,d%iim,d%jjm)) ALLOCATE(d%neighbour(3,0:5,d%iim,d%jjm)) ALLOCATE(d%own(d%iim,d%jjm)) ALLOCATE(d%ne(0:5,d%iim,d%jjm)) END DO END DO END DO END SUBROUTINE create_domain SUBROUTINE assign_cell USE metric IMPLICIT NONE INTEGER :: ind_d,ind,ind2,e INTEGER :: nf INTEGER :: i,j,k,ii,jj TYPE(t_domain),POINTER :: d INTEGER :: delta DO ind_d=1,ndomain d=>domain(ind_d) nf=d%face DO j=d%jj_begin,d%jj_end DO i=d%ii_begin,d%ii_end ii=d%ii_begin_glo-d%ii_begin+i jj=d%jj_begin_glo-d%jj_begin+j ind=vertex_glo(ii,jj,nf)%ind delta=vertex_glo(ii,jj,nf)%delta IF (cell_glo(ind)%assign_face==nf) THEN cell_glo(ind)%assign_domain=ind_d cell_glo(ind)%assign_i=i cell_glo(ind)%assign_j=j ENDIF IF ( i+1 <= d%ii_end ) CALL assign_edge(ind_d,ind,i,j,delta,0) IF ( j+1 <= d%jj_end ) CALL assign_edge(ind_d,ind,i,j,delta,1) IF ( i-1 >= d%ii_begin .AND. j+1<=d%jj_end ) CALL assign_edge(ind_d,ind,i,j,delta,2) IF ( i-1 >= d%ii_begin ) CALL assign_edge(ind_d,ind,i,j,delta,3) IF ( j-1 >= d%jj_begin ) CALL assign_edge(ind_d,ind,i,j,delta,4) IF ( i+1 <= d%ii_end .AND. j-1 >=d%jj_begin ) CALL assign_edge(ind_d,ind,i,j,delta,5) ENDDO ENDDO ENDDO DO ind_d=1,ndomain d=>domain(ind_d) nf=d%face DO j=d%jj_begin-1,d%jj_end+1 DO i=d%ii_begin-1,d%ii_end+1 ii=d%ii_begin_glo-d%ii_begin+i jj=d%jj_begin_glo-d%jj_begin+j ind=vertex_glo(ii,jj,nf)%ind d%assign_domain(i,j)=cell_glo(ind)%assign_domain d%assign_i(i,j)=cell_glo(ind)%assign_i d%assign_j(i,j)=cell_glo(ind)%assign_j delta=vertex_glo(ii,jj,nf)%delta d%delta(i,j)=vertex_glo(ii,jj,nf)%delta DO k=0,5 ind2=vertex_glo(ii,jj,nf)%neighbour(k) d%neighbour(:,k,i,j)=cell_glo(ind2)%xyz(:) d%ne(k,i,j)=vertex_glo(ii,jj,nf)%ne(k) e=cell_glo(ind)%edge(MOD(k+delta+6,6)) d%edge_assign_domain(k,i,j)=edge_glo(e)%assign_domain d%edge_assign_i(k,i,j)=edge_glo(e)%assign_i d%edge_assign_j(k,i,j)=edge_glo(e)%assign_j d%edge_assign_pos(k,i,j)=edge_glo(e)%assign_pos ENDDO d%xyz(:,i,j)=cell_glo(ind)%xyz(:) IF (d%assign_domain(i,j)==ind_d) THEN d%own(i,j)=.TRUE. ELSE d%own(i,j)=.FALSE. ENDIF ENDDO ENDDO ENDDO CONTAINS SUBROUTINE assign_edge(ind_d,ind,i,j,delta,k) INTEGER :: ind_d,ind,i,j,delta,k INTEGER :: e e=cell_glo(ind)%edge(MOD(k+delta+6,6)) edge_glo(e)%assign_domain=ind_d edge_glo(e)%assign_i=i edge_glo(e)%assign_j=j edge_glo(e)%assign_pos=k ! PRINT*,"Assign_edge",ind_d,ind,i,j,k,e END SUBROUTINE assign_edge END SUBROUTINE assign_cell SUBROUTINE compute_boundary USE spherical_geom_mod IMPLICIT NONE INTEGER :: ind_d INTEGER :: i,j,k TYPE(t_domain),POINTER :: d REAL(rstd) :: ng1(3),ng2(3) DO ind_d=1,ndomain d=>domain(ind_d) DO j=d%jj_begin-1,d%jj_end+1 DO i=d%ii_begin-1,d%ii_end+1 DO k=0,5 ng1=d%neighbour(:,MOD(k,6),i,j) ng2=d%neighbour(:,MOD(k+1,6),i,j) IF (sqrt(sum((ng1-ng2)**2))<1e-16) ng2=d%neighbour(:,MOD(k+2,6),i,j) CALL circumcenter(d%xyz(:,i,j),ng1,ng2,d%vertex(:,k,i,j)) ENDDO ENDDO ENDDO ENDDO END SUBROUTINE compute_boundary SUBROUTINE set_neighbour_indice USE metric IMPLICIT NONE INTEGER :: ind_d TYPE(t_domain),POINTER :: d DO ind_d=1,ndomain d=>domain(ind_d) d%t_right=1 d%t_left=-1 d%t_rup=d%iim d%t_lup=d%iim-1 d%t_ldown=-d%iim d%t_rdown=-d%iim+1 d%u_right=0 d%u_lup=d%iim*d%jjm d%u_ldown=2*d%iim*d%jjm d%u_rup=d%t_rup+d%u_ldown d%u_left=d%t_left+d%u_right d%u_rdown=d%t_rdown+d%u_lup d%z_up=0 d%z_down=d%iim*d%jjm d%z_rup=d%t_rup+d%z_down d%z_lup=d%t_lup+d%z_down d%z_ldown=d%t_ldown+d%z_up d%z_rdown=d%t_rdown+d%z_up d%t_pos(right)=d%t_right d%t_pos(rup)=d%t_rup d%t_pos(lup)=d%t_lup d%t_pos(left)=d%t_left d%t_pos(ldown)=d%t_ldown d%t_pos(rdown)=d%t_rdown d%u_pos(right)=d%u_right d%u_pos(rup)=d%u_rup d%u_pos(lup)=d%u_lup d%u_pos(left)=d%u_left d%u_pos(ldown)=d%u_ldown d%u_pos(rdown)=d%u_rdown d%z_pos(vrup)=d%z_rup d%z_pos(vup)=d%z_up d%z_pos(vlup)=d%z_lup d%z_pos(vldown)=d%z_ldown d%z_pos(vdown)=d%z_down d%z_pos(vrdown)=d%z_rdown ENDDO END SUBROUTINE set_neighbour_indice SUBROUTINE compute_domain IMPLICIT NONE CALL create_domain CALL assign_cell CALL compute_boundary CALL set_neighbour_indice END SUBROUTINE compute_domain END MODULE domain_mod