From d6103d352373c320d9febba98ae4256bf6372690 Mon Sep 17 00:00:00 2001
From: odemirel <odemirel@7c7fe9aa-52eb-4d9e-b0a8-ba7d787348e9>
Date: Wed, 10 Mar 2010 09:58:33 +0000
Subject: [PATCH] Jens' numerics is merged and modified for the new topology
git-svn-id: https://ppm.inf.ethz.ch/svn/ppmnumerics/branches/ngtopo/libppmnumerics@567 7c7fe9aa-52eb-4d9e-b0a8-ba7d787348e9
---
src/ppm_hamjac_ext_step_3d.f | 3 +-
src/ppm_hamjac_reinit_2d.f | 67 +-
src/ppm_hamjac_reinit_3d.f | 80 +-
src/ppm_hamjac_reinit_loc_3d.f | 257 +++
src/ppm_hamjac_reinit_loc_step_3d.f | 371 ++++
src/ppm_hamjac_reinit_ref_3d.f | 74 +-
src/ppm_hamjac_reinit_russo_3d.f | 38 +-
src/ppm_hamjac_reinit_russo_step_3d.f | 36 +-
src/ppm_hamjac_reinit_step_2d.f | 77 +-
src/ppm_hamjac_reinit_step_3d.f | 130 +-
src/ppm_hamjac_reinit_step_ref_3d.f | 84 +-
src/ppm_mg_alloc_field.f | 52 +-
src/ppm_mg_finalize.f | 11 +-
src/ppm_mg_init.f | 2290 ++++++++++++++-----------
src/ppm_mg_res_coarse.f | 377 ++--
src/ppm_mg_res_fine.f | 247 ++-
src/ppm_mg_restrict.f | 1437 +++++++++-------
src/ppm_mg_smooth_coarse.f | 2210 ++++++++++++++----------
src/ppm_mg_smooth_fine.f | 914 ++++++----
src/ppm_mg_solv.f | 849 +++++----
src/ppm_module_data_mg.f | 624 ++++---
src/ppm_module_mg_core.f | 4 +-
src/ppm_module_user_numerics.f | 2 +
23 files changed, 6379 insertions(+), 3855 deletions(-)
create mode 100644 src/ppm_hamjac_reinit_loc_3d.f
create mode 100644 src/ppm_hamjac_reinit_loc_step_3d.f
diff --git a/src/ppm_hamjac_ext_step_3d.f b/src/ppm_hamjac_ext_step_3d.f
index d83fc5f..733cd5e 100644
--- a/src/ppm_hamjac_ext_step_3d.f
+++ b/src/ppm_hamjac_ext_step_3d.f
@@ -120,7 +120,6 @@
meshid = mesh%ID
nsublist = topo%nsublist
ndata => mesh%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
min_phys => topo%min_physs
@@ -161,7 +160,7 @@
phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
sij = phi(i,j,k,isub) &
& /SQRT(phi(i,j,k,isub)**2+dxavg**2)
- n = phimid / SQRT(SUM(phimid**2)+1.0e-6_MK)
+ n = phimid / SQRT(SUM(phimid**2))
#if __MODE == __SCA
dphi_dt = &
& MAX(n(1)*sij,0.0_mk)*dxi(1)* &
diff --git a/src/ppm_hamjac_reinit_2d.f b/src/ppm_hamjac_reinit_2d.f
index 032e8d6..1eeeb01 100644
--- a/src/ppm_hamjac_reinit_2d.f
+++ b/src/ppm_hamjac_reinit_2d.f
@@ -18,11 +18,8 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_hamjac_reinit_2d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2006/06/29 11:56:00 pchatela
- ! Added a MPI_Allreduce for the loop exit
+ ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
+ ! initial import
!
! Revision 1.1 2005/07/25 00:34:02 ivos
! Initial check-in.
@@ -33,6 +30,8 @@
! ETH Zentrum, Hirschengraben 84
! CH-8092 Zurich, Switzerland
!-------------------------------------------------------------------------
+
+
#if __MODE == __SCA
#if __KIND == __SINGLE_PRECISION
SUBROUTINE ppm_hamjac_reinit_2ds (phi, trgt, tol, maxstep, &
@@ -44,25 +43,24 @@
#elif __MODE == __VEC
#error VECTOR NOT IMPLEMENTED
#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
+
USE ppm_module_data
USE ppm_module_data_mesh
- USE ppm_module_substart
- USE ppm_module_substop
USE ppm_module_error
+ USE ppm_module_write
+ USE ppm_module_substart
USE ppm_module_alloc
+ USE ppm_module_substop
+ USE ppm_module_map
USE ppm_module_typedef
IMPLICIT NONE
- INCLUDE 'mpif.h'
+
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
- INTEGER, PARAMETER :: MPTYPE = MPI_REAL
#elif __KIND == __DOUBLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_double
- INTEGER, PARAMETER :: MPTYPE = MPI_DOUBLE_PRECISION
#endif
+
!-----------------------------------------------------
! Arguments
!-----------------------------------------------------
@@ -72,6 +70,7 @@
INTEGER, INTENT(inout) :: info
INTEGER, INTENT(in) :: maxstep
REAL(mk), INTENT(in) :: tol, trgt
+
!-----------------------------------------------------
! Aliases
!-----------------------------------------------------
@@ -79,19 +78,22 @@
REAL(mk), DIMENSION(:,:,: ), POINTER :: tphi
INTEGER :: nsublist
INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
+ INTEGER :: topoid,meshid
+ REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
TYPE(ppm_t_topo), POINTER :: topo
TYPE(ppm_t_equi_mesh), POINTER :: mesh
+
!-----------------------------------------------------
! standard stuff
!-----------------------------------------------------
INTEGER :: isub,isubl,i,j,k,maptype,istep,iopt
INTEGER :: ldl(3), ldu(3), ndata_max(2)
REAL(mk) :: len_phys(2)
- REAL(mk) :: t0, lres, gres
+ REAL(mk) :: t0, res
CHARACTER(len=256) :: msg
+
CALL substart('ppm_hamjac_reinit_2d',t0,info)
+
!-----------------------------------------------------
! Get the mesh data
!-----------------------------------------------------
@@ -100,7 +102,6 @@
meshid = mesh%ID
nsublist = topo%nsublist
ndata => mesh%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
min_phys => topo%min_physs
@@ -109,6 +110,13 @@
min_phys => topo%min_physd
max_phys => topo%max_physd
#endif
+
+ !-----------------------------------------------------
+ ! RATIONALE Thu May 26 20:51:19 PDT 2005:
+ ! loop ghostmap doit. easy.
+ !-----------------------------------------------------
+
+
!-----------------------------------------------------
! allocate temporary storage
!-----------------------------------------------------
@@ -126,9 +134,11 @@
& 'temp storage for hamjac',__LINE__,info)
GOTO 9999
END IF
+
!--- ready to blast
maptype = ppm_param_map_init
CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
+
!--- COMMENT Thu May 26 21:05:23 PDT 2005: simple euler here, do TVD
DO istep=1,maxstep
!--- map the gowas
@@ -140,7 +150,8 @@
CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
maptype = ppm_param_map_pop
CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
- CALL ppm_hamjac_reinit_step(phi,tphi,trgt,lres,topo_id,mesh_id&
+
+ CALL ppm_hamjac_reinit_step(phi,tphi,trgt,res,topo_id,mesh_id&
&, ghostsize,info)
DO isub=1,nsublist
isubl = isublist(isub)
@@ -148,15 +159,18 @@
phi(i,j,isub) = tphi(i,j,isub)
END DO; END DO
END DO
- CALL MPI_Allreduce(lres,gres,1,MPTYPE,MPI_MAX,ppm_comm,info)
- WRITE(msg,*) 'iteration #',istep,' res=',gres
+ WRITE(msg,*) 'iteration #',istep,' res=',res
IF(MOD(istep,10).EQ.0) CALL ppm_write(ppm_Rank,'ppm_hamjac',msg,info)
- IF(gres.LT.tol) GOTO 666
+
+ IF(res.LT.tol) GOTO 666
END DO
+
info = ppm_error_warning
CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_2d', &
& 'failed to reach target residual',__LINE__,info)
+
666 CONTINUE
+
iopt = ppm_param_dealloc
CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
IF(info.NE.0) THEN
@@ -165,10 +179,21 @@
& 'temp storage for hamjac not freed',__LINE__,info)
GOTO 9999
END IF
+
+
9999 CONTINUE
CALL substop('ppm_hamjac_reinit_2d',t0,info)
+
#if __KIND == __SINGLE_PRECISION
END SUBROUTINE ppm_hamjac_reinit_2ds
#elif __KIND == __DOUBLE_PRECISION
END SUBROUTINE ppm_hamjac_reinit_2dd
#endif
+
+
+
+
+
+
+
+
diff --git a/src/ppm_hamjac_reinit_3d.f b/src/ppm_hamjac_reinit_3d.f
index a22c012..9dad18d 100644
--- a/src/ppm_hamjac_reinit_3d.f
+++ b/src/ppm_hamjac_reinit_3d.f
@@ -18,11 +18,8 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_hamjac_reinit_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2006/06/29 11:56:00 pchatela
- ! Added a MPI_Allreduce for the loop exit
+ ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
+ ! initial import
!
! Revision 1.2 2005/08/25 16:48:50 ivos
! Fixed format string. pgf90 barked.
@@ -36,6 +33,8 @@
! ETH Zentrum, Hirschengraben 84
! CH-8092 Zurich, Switzerland
!-------------------------------------------------------------------------
+
+
#if __MODE == __SCA
#if __KIND == __SINGLE_PRECISION
SUBROUTINE ppm_hamjac_reinit_3ds (phi, trgt, tol, maxstep, &
@@ -53,25 +52,24 @@
& topo_id, mesh_id, ghostsize, info)
#endif
#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
+
USE ppm_module_data
USE ppm_module_data_mesh
- USE ppm_module_substart
- USE ppm_module_substop
USE ppm_module_error
+ USE ppm_module_write
+ USE ppm_module_substart
USE ppm_module_alloc
+ USE ppm_module_substop
+ USE ppm_module_map
USE ppm_module_typedef
IMPLICIT NONE
- INCLUDE 'mpif.h'
+
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
- INTEGER, PARAMETER :: MPTYPE = MPI_REAL
-#elif __KIND == __DOUBLE_PRECISION
+#elif __KIND == __DOUBLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_double
- INTEGER, PARAMETER :: MPTYPE = MPI_DOUBLE_PRECISION
#endif
+
!-----------------------------------------------------
! Arguments
!-----------------------------------------------------
@@ -86,6 +84,7 @@
INTEGER, INTENT(inout) :: info
INTEGER, INTENT(in) :: maxstep
REAL(mk), INTENT(in) :: tol, trgt
+
!-----------------------------------------------------
! Aliases
!-----------------------------------------------------
@@ -93,10 +92,11 @@
REAL(mk), DIMENSION(:,:,:,:), POINTER :: tphi
INTEGER :: nsublist
INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
+ INTEGER :: topoid,meshid
+ REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
TYPE(ppm_t_topo), POINTER :: topo
TYPE(ppm_t_equi_mesh), POINTER :: mesh
+
!-----------------------------------------------------
! standard stuff
!-----------------------------------------------------
@@ -104,9 +104,11 @@
INTEGER :: maptype,istep,iopt
INTEGER :: ldl(4), ldu(4), ndata_max(3)
REAL(mk) :: len_phys(3)
- REAL(mk) :: t0, lres, gres
+ REAL(mk) :: t0, res
CHARACTER(LEN=ppm_char) :: cbuf
+
CALL substart('ppm_hamjac_reinit_3d',t0,info)
+
!-----------------------------------------------------
! Get the mesh data
!-----------------------------------------------------
@@ -115,7 +117,6 @@
meshid = mesh%ID
nsublist = topo%nsublist
ndata => mesh%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
min_phys => topo%min_physs
@@ -124,6 +125,12 @@
min_phys => topo%min_physd
max_phys => topo%max_physd
#endif
+
+ !-----------------------------------------------------
+ ! RATIONALE Thu May 26 20:51:19 PDT 2005:
+ ! loop ghostmap doit. easy.
+ !-----------------------------------------------------
+
!-----------------------------------------------------
! allocate temporary storage
!-----------------------------------------------------
@@ -143,6 +150,7 @@
& 'temp storage for hamjac',__LINE__,info)
GOTO 9999
END IF
+
!--- ready to blast
maptype = ppm_param_map_init
#if __MODE == __SCA
@@ -150,6 +158,10 @@
#elif __MODE == __VEC
CALL ppm_map_field_ghost(phi,lda,topo_id,mesh_id,ghostsize,maptype,info)
#endif
+
+ !-----------------------------------------------------
+ ! COMMENT Thu May 26 21:05:23 PDT 2005: simple euler here, DO TVD
+ !-----------------------------------------------------
DO istep=1,maxstep
!--- map the gowas
#if __MODE == __SCA
@@ -161,7 +173,7 @@
CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
maptype = ppm_param_map_pop
CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
- CALL ppm_hamjac_reinit_step(phi,tphi,trgt,lres,topo_id,mesh_id&
+ CALL ppm_hamjac_reinit_step(phi,tphi,trgt,res,topo_id,mesh_id&
&, ghostsize,info)
#elif __MODE == __VEC
maptype = ppm_param_map_ghost_get
@@ -176,9 +188,16 @@
maptype = ppm_param_map_pop
CALL ppm_map_field_ghost(phi,lda,topo_id,mesh_id,ghostsize, &
& maptype,info)
- CALL ppm_hamjac_reinit_step(phi,idx,tphi,trgt,lres,topo_id,mesh_id,&
+ CALL ppm_hamjac_reinit_step(phi,idx,tphi,trgt,res,topo_id,mesh_id,&
& ghostsize,info)
#endif
+ !-----------------------------------------------------
+ ! maybe put a if(debug)then
+ !-----------------------------------------------------
+ IF(ppm_debug.GT.0) THEN
+ WRITE(cbuf,'(A,I4,A,E12.5)') 'Iteration ',istep,' Residual: ',res
+ CALL ppm_write(ppm_rank,'ppm_hamjac_reinit_3d',cbuf,info)
+ END IF
!-----------------------------------------------------
! copy the data back
!-----------------------------------------------------
@@ -192,19 +211,16 @@
#endif
END DO; END DO; END DO
END DO
- CALL MPI_Allreduce(lres,gres,1,MPTYPE,MPI_MAX,ppm_comm,info)
- !-----------------------------------------------------
- ! maybe put a if(debug)then
- !-----------------------------------------------------
- WRITE(cbuf,'(A,I4,A,E12.5)') 'Iteration ',istep,' Residual: ',gres
- IF (ppm_rank.EQ.0) CALL ppm_write(ppm_rank,'ppm_hamjac_reinit_3d',cbuf,info)
- IF(gres.LT.tol) GOTO 666
+ IF(res.LT.tol) GOTO 666
END DO
+
info = ppm_error_warning
CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_3d', &
& 'failed to reach target residual',__LINE__,info)
info = ppm_param_success
+
666 CONTINUE
+
iopt = ppm_param_dealloc
CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
IF(info.NE.0) THEN
@@ -213,7 +229,10 @@
& 'temp storage for hamjac not freed',__LINE__,info)
GOTO 9999
END IF
+
+
9999 CONTINUE
+
#if __MODE == __SCA
#if __KIND == __SINGLE_PRECISION
END SUBROUTINE ppm_hamjac_reinit_3ds
@@ -227,3 +246,10 @@
END SUBROUTINE ppm_hamjac_reinit_3ddV
#endif
#endif
+
+
+
+
+
+
+
diff --git a/src/ppm_hamjac_reinit_loc_3d.f b/src/ppm_hamjac_reinit_loc_3d.f
new file mode 100644
index 0000000..9878e44
--- /dev/null
+++ b/src/ppm_hamjac_reinit_loc_3d.f
@@ -0,0 +1,257 @@
+ !-------------------------------------------------------------------------
+ ! Subroutine : ppm_hamjac_reinit_3d
+ !-------------------------------------------------------------------------
+ !
+ ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
+ !
+ ! Input :
+ !
+ ! Input/Output :
+ !
+ ! Output :
+ !
+ ! Remarks :
+ !
+ !
+ ! References :
+ !
+ ! Revisions :
+ !-------------------------------------------------------------------------
+ ! $Log: ppm_hamjac_reinit_loc_3d.f,v $
+ ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
+ ! initial import
+ !
+ ! Revision 1.2 2005/08/25 16:48:50 ivos
+ ! Fixed format string. pgf90 barked.
+ !
+ ! Revision 1.1 2005/07/25 00:34:02 ivos
+ ! Initial check-in.
+ !
+ !-------------------------------------------------------------------------
+ ! Parallel Particle Mesh Library (PPM)
+ ! Institute of Computational Science
+ ! ETH Zentrum, Hirschengraben 84
+ ! CH-8092 Zurich, Switzerland
+ !-------------------------------------------------------------------------
+
+
+#if __MODE == __SCA
+#if __KIND == __SINGLE_PRECISION
+ SUBROUTINE ppm_hamjac_reinit_loc_3ds (phi, iloc, np, trgt, tol, maxstep,&
+ & topo_id, mesh_id, ghostsize, info)
+#elif __KIND == __DOUBLE_PRECISION
+ SUBROUTINE ppm_hamjac_reinit_loc_3dd (phi, iloc, np, trgt, tol, maxstep,&
+ & topo_id, mesh_id, ghostsize, info)
+#endif
+#elif __MODE == __VEC
+#if __KIND == __SINGLE_PRECISION
+ SUBROUTINE ppm_hamjac_reinit_loc_3dsV(phi, lda, iloc, np, idx, trgt,tol,&
+ & maxstep,topo_id, mesh_id, ghostsize,info)
+#elif __KIND == __DOUBLE_PRECISION
+ SUBROUTINE ppm_hamjac_reinit_loc_3ddV(phi, lda, iloc, np, idx, trgt,tol,&
+ & maxstep,topo_id, mesh_id, ghostsize,info)
+#endif
+#endif
+
+ USE ppm_module_data
+ USE ppm_module_data_mesh
+ USE ppm_module_error
+ USE ppm_module_write
+ USE ppm_module_substart
+ USE ppm_module_alloc
+ USE ppm_module_substop
+ USE ppm_module_map
+ USE ppm_module_typedef
+ IMPLICIT NONE
+
+#if __KIND == __SINGLE_PRECISION
+ INTEGER, PARAMETER :: MK = ppm_kind_single
+#elif __KIND == __DOUBLE_PRECISION
+ INTEGER, PARAMETER :: MK = ppm_kind_double
+#endif
+
+ !-----------------------------------------------------
+ ! Arguments
+ !-----------------------------------------------------
+#if __MODE == __SCA
+ REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
+#elif __MODE == __VEC
+ REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: phi
+ INTEGER, INTENT(in) :: idx, lda
+#endif
+ INTEGER, INTENT(in) :: topo_id, mesh_id
+ INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
+ INTEGER, INTENT(inout) :: info
+ INTEGER, INTENT(in) :: maxstep
+ REAL(mk), INTENT(in) :: tol, trgt
+
+ !-----------------------------------------------------
+ ! Aliases
+ !-----------------------------------------------------
+ INTEGER, DIMENSION(:), POINTER :: isublist
+ INTEGER, DIMENSION(:,:), INTENT(in) :: iloc
+ INTEGER :: np, p
+ REAL(mk), DIMENSION(:,:,:,:), POINTER :: tphi
+ INTEGER :: nsublist
+ INTEGER, DIMENSION(:,:), POINTER :: ndata
+ INTEGER :: topoid,meshid
+ REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
+ TYPE(ppm_t_topo), POINTER :: topo
+ TYPE(ppm_t_equi_mesh), POINTER :: mesh
+
+ !-----------------------------------------------------
+ ! standard stuff
+ !-----------------------------------------------------
+ INTEGER :: isub,isubl,i,j,k
+ INTEGER :: maptype,istep,iopt
+ INTEGER :: ldl(4),ldu(4),ndata_max(3)
+ REAL(mk) :: len_phys(3)
+ REAL(mk) :: t0, res
+ CHARACTER(LEN=ppm_char) :: cbuf
+
+ CALL substart('ppm_hamjac_reinit_loc_3d',t0,info)
+
+ !-----------------------------------------------------
+ ! Get the mesh data
+ !-----------------------------------------------------
+ topo => ppm_topo(topo_id)%t
+ mesh => topo%mesh(mesh_id)
+ meshid = mesh%ID
+ nsublist = topo%nsublist
+ ndata => mesh%nnodes
+ isublist => topo%isublist
+#if __KIND == __SINGLE_PRECISION
+ min_phys => topo%min_physs
+ max_phys => topo%max_physs
+#elif __KIND == __DOUBLE_PRECISION
+ min_phys => topo%min_physd
+ max_phys => topo%max_physd
+#endif
+
+ !-----------------------------------------------------
+ ! RATIONALE Thu May 26 20:51:19 PDT 2005:
+ ! loop ghostmap doit. easy.
+ !-----------------------------------------------------
+
+ !-----------------------------------------------------
+ ! allocate temporary storage
+ !-----------------------------------------------------
+ ldl(1:3) = 1 - ghostsize(1:3); ldl(4) = 1
+ ndata_max(1) = MAXVAL(ndata(1,1:nsublist))
+ ndata_max(2) = MAXVAL(ndata(2,1:nsublist))
+ ndata_max(3) = MAXVAL(ndata(3,1:nsublist))
+ ldu(1) = ndata_max(1) + ghostsize(1)
+ ldu(2) = ndata_max(2) + ghostsize(2)
+ ldu(3) = ndata_max(3) + ghostsize(3)
+ ldu(4) = nsublist
+ iopt = ppm_param_alloc_fit
+ CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
+ IF(info.NE.0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_hamjac_reinit_loc_3d', &
+ & 'temp storage for hamjac',__LINE__,info)
+ GOTO 9999
+ END IF
+
+ !--- ready to blast
+ maptype = ppm_param_map_init
+#if __MODE == __SCA
+ CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
+#elif __MODE == __VEC
+ CALL ppm_map_field_ghost(phi,lda,topo_id,mesh_id,ghostsize,maptype,info)
+#endif
+
+ !-----------------------------------------------------
+ ! COMMENT Thu May 26 21:05:23 PDT 2005: simple euler here, DO TVD
+ !-----------------------------------------------------
+ DO istep=1,maxstep
+ !--- map the gowas
+#if __MODE == __SCA
+ maptype = ppm_param_map_ghost_get
+ CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
+ maptype = ppm_param_map_push
+ CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
+ maptype = ppm_param_map_send
+ CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
+ maptype = ppm_param_map_pop
+ CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
+ CALL ppm_hamjac_reinit_loc_step(phi,tphi,iloc,np,trgt,res,topo_id,&
+ & mesh_id,ghostsize,info)
+#elif __MODE == __VEC
+ maptype = ppm_param_map_ghost_get
+ CALL ppm_map_field_ghost(phi,lda,topo_id,mesh_id,ghostsize, &
+ & maptype,info)
+ maptype = ppm_param_map_push
+ CALL ppm_map_field_ghost(phi,lda,topo_id,mesh_id,ghostsize, &
+ & maptype,info)
+ maptype = ppm_param_map_send
+ CALL ppm_map_field_ghost(phi,lda,topo_id,mesh_id,ghostsize, &
+ & maptype,info)
+ maptype = ppm_param_map_pop
+ CALL ppm_map_field_ghost(phi,lda,topo_id,mesh_id,ghostsize, &
+ & maptype,info)
+ CALL ppm_hamjac_reinit_loc_step(phi,idx,tphi,iloc,np,trgt,res,topo_id,&
+ & mesh_id,ghostsize,info)
+#endif
+ !-----------------------------------------------------
+ ! maybe put a if(debug)then
+ !-----------------------------------------------------
+ WRITE(cbuf,'(A,I4,A,E12.5)') 'Iteration ',istep,' Residual: ',res
+ CALL ppm_write(ppm_rank,'ppm_hamjac_reinit_loc_3d',cbuf,info)
+
+ !-----------------------------------------------------
+ ! copy the data back
+ !-----------------------------------------------------
+ DO p=1,np
+ isub = iloc(4,p)
+ i = iloc(1,p)
+ j = iloc(2,p)
+ k = iloc(3,p)
+#if __MODE == __SCA
+ phi(i,j,k,isub) = tphi(i,j,k,isub)
+#elif __MODE == __VEC
+ phi(idx,i,j,k,isub) = tphi(i,j,k,isub)
+#endif
+ END DO
+ IF(res.LT.tol) GOTO 666
+ END DO
+
+ info = ppm_error_warning
+ CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_loc_3d', &
+ & 'failed to reach target residual',__LINE__,info)
+ info = ppm_param_success
+
+666 CONTINUE
+
+ iopt = ppm_param_dealloc
+ CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
+ IF(info.NE.0) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_dealloc,'ppm_hamjac_reinit_loc_3d', &
+ & 'temp storage for hamjac not freed',__LINE__,info)
+ GOTO 9999
+ END IF
+
+
+9999 CONTINUE
+
+#if __MODE == __SCA
+#if __KIND == __SINGLE_PRECISION
+ END SUBROUTINE ppm_hamjac_reinit_loc_3ds
+#elif __KIND == __DOUBLE_PRECISION
+ END SUBROUTINE ppm_hamjac_reinit_loc_3dd
+#endif
+#elif __MODE == __VEC
+#if __KIND == __SINGLE_PRECISION
+ END SUBROUTINE ppm_hamjac_reinit_loc_3dsV
+#elif __KIND == __DOUBLE_PRECISION
+ END SUBROUTINE ppm_hamjac_reinit_loc_3ddV
+#endif
+#endif
+
+
+
+
+
+
+
diff --git a/src/ppm_hamjac_reinit_loc_step_3d.f b/src/ppm_hamjac_reinit_loc_step_3d.f
new file mode 100644
index 0000000..d1b449d
--- /dev/null
+++ b/src/ppm_hamjac_reinit_loc_step_3d.f
@@ -0,0 +1,371 @@
+ !-------------------------------------------------------------------------
+ ! Subroutine : ppm_hamjac_reinit_step_3d
+ !-------------------------------------------------------------------------
+ !
+ ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
+ !
+ ! Input :
+ !
+ ! Input/Output :
+ !
+ ! Output :
+ !
+ ! Remarks :
+ !
+ !
+ ! References :
+ !
+ ! Revisions :
+ !-------------------------------------------------------------------------
+ ! $Log: ppm_hamjac_reinit_loc_step_3d.f,v $
+ ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
+ ! initial import
+ !
+ ! Revision 1.2 2005/08/12 14:38:01 ivos
+ ! bugfix: index bounds in loop corrected.
+ !
+ ! Revision 1.1 2005/07/25 00:34:05 ivos
+ ! Initial check-in.
+ !
+ !-------------------------------------------------------------------------
+ ! Parallel Particle Mesh Library (PPM)
+ ! Institute of Computational Science
+ ! ETH Zentrum, Hirschengraben 84
+ ! CH-8092 Zurich, Switzerland
+ !-------------------------------------------------------------------------
+
+#if __MODE == __SCA
+#if __KIND == __SINGLE_PRECISION
+ SUBROUTINE ppm_hamjac_reinit_loc_step_3ds(phi,tphi,iloc,np,trgt,res, &
+ & topo_id,mesh_id,ghostsize,info)
+#elif __KIND == __DOUBLE_PRECISION
+ SUBROUTINE ppm_hamjac_reinit_loc_step_3dd(phi,tphi,iloc,np,trgt,res, &
+ & topo_id,mesh_id,ghostsize,info)
+#endif
+#elif __MODE == __VEC
+#if __KIND == __SINGLE_PRECISION
+ SUBROUTINE ppm_hamjac_reinit_loc_step_3dsV(phi,idx,tphi,iloc,np,trgt,&
+ & res,topo_id,mesh_id,ghostsize,info)
+#elif __KIND == __DOUBLE_PRECISION
+ SUBROUTINE ppm_hamjac_reinit_loc_step_3ddV(phi,idx,tphi,iloc,np,trgt,&
+ & res,topo_id,mesh_id,ghostsize,info)
+#endif
+#endif
+
+ USE ppm_module_data
+ USE ppm_module_data_mesh
+ USE ppm_module_error
+ USE ppm_module_substart
+ USE ppm_module_substop
+ USE ppm_module_typedef
+ IMPLICIT NONE
+
+#if __KIND == __SINGLE_PRECISION
+ INTEGER, PARAMETER :: MK = ppm_kind_single
+#elif __KIND == __DOUBLE_PRECISION
+ INTEGER, PARAMETER :: MK = ppm_kind_double
+#endif
+
+ !-----------------------------------------------------
+ ! Arguments
+ !-----------------------------------------------------
+#if __MODE == __SCA
+ REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
+#elif __MODE == __VEC
+ REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: phi
+#endif
+ REAL(MK), DIMENSION(:,:,:,:), POINTER :: tphi
+ INTEGER, INTENT(in) :: topo_id, mesh_id
+ INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
+ INTEGER, INTENT(inout) :: info
+ REAL(mk), INTENT(out) :: res
+#if __MODE == __VEC
+ INTEGER, INTENT(in) :: idx
+#endif
+ REAL(mk), INTENT(in) :: trgt
+ INTEGER, DIMENSION(:,:), INTENT(in) :: iloc
+ INTEGER :: np, p
+ !-----------------------------------------------------
+ ! Aliases
+ !-----------------------------------------------------
+ INTEGER, DIMENSION(:), POINTER :: isublist
+ INTEGER :: nsublist
+ INTEGER, DIMENSION(:,:), POINTER :: ndata
+ INTEGER :: topoid, meshid
+ REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
+ TYPE(ppm_t_topo), POINTER :: topo
+ TYPE(ppm_t_equi_mesh), POINTER :: mesh
+
+ !-----------------------------------------------------
+ ! standard stuff
+ !-----------------------------------------------------
+ INTEGER :: isub,isubl,i,j,k
+ REAL(MK) :: len_phys(3)
+ !-----------------------------------------------------
+ ! WENO stuff
+ !-----------------------------------------------------
+ REAL(mk) :: oneg(3), opos(3), wenoeps, wenotau, pbs
+ REAL(mk) :: laps(-1:1,3), rpos(3), rneg(3), dx(3), dxi(3)
+ REAL(mk) :: phip(3), phin(3), phimid(3), rms, dphi_dt
+ INTEGER :: ilap
+ INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
+ & = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
+ REAL(mk) :: t0
+
+
+ CALL substart('ppm_hamjac_reinit_loc_step_3d',t0,info)
+
+ !-----------------------------------------------------
+ ! Get the mesh data
+ !-----------------------------------------------------
+ topo => ppm_topo(topo_id)%t
+ mesh => topo%mesh(mesh_id)
+ meshid = mesh%ID
+ nsublist = topo%nsublist
+ ndata => mesh%nnodes
+ isublist => topo%isublist
+#if __KIND == __SINGLE_PRECISION
+ min_phys => topo%min_physs
+ max_phys => topo%max_physs
+#elif __KIND == __DOUBLE_PRECISION
+ min_phys => topo%min_physd
+ max_phys => topo%max_physd
+#endif
+
+ len_phys(1) = max_phys(1) - min_phys(1)
+ len_phys(2) = max_phys(2) - min_phys(2)
+ len_phys(3) = max_phys(3) - min_phys(3)
+ dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
+ dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
+ dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
+ dxi(1) = 1.0_mk/dx(1)
+ dxi(2) = 1.0_mk/dx(2)
+ dxi(3) = 1.0_mk/dx(3)
+ wenoeps = 1.0e-6_mk
+ wenotau = 0.25_mk*MINVAL(dx)
+
+ rms = -HUGE(rms)
+
+ DO p=1,np
+ isub = iloc(4,p)
+ i = iloc(1,p)
+ j = iloc(2,p)
+ k = iloc(3,p)
+ ! hack
+#if __MODE == __SCA
+! IF(phi(i+1,j,k,isub).EQ.phi(i-1,j,k,isub).AND. &
+! & phi(i,j+1,k,isub).EQ.phi(i,j-1,k,isub).AND. &
+! & phi(i,j,k+1,isub).EQ.phi(i,j,k-1,isub).AND.ABS(phi(i&
+! &,j,k,isub)).LT.14.0_mk*dx(1)) CYCLE
+#endif
+#if __MODE == __SCA
+ phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
+ phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
+ phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
+#else
+ phimid(1) = phi(idx,i+1,j,k,isub)-phi(idx,i-1,j,k,isub)
+ phimid(2) = phi(idx,i,j+1,k,isub)-phi(idx,i,j-1,k,isub)
+ phimid(3) = phi(idx,i,j,k+1,isub)-phi(idx,i,j,k-1,isub)
+#endif
+
+#if __MODE == __SCA
+ laps(2-3,1) = phi(i+offs(1,3),j,k,isub) &
+ & -2.0_mk * phi(i+offs(2,3),j,k,isub) &
+ & + phi(i+offs(3,3),j,k,isub)
+ laps(2-3,2) = phi(i,j+offs(1,3),k,isub) &
+ & -2.0_mk * phi(i,j+offs(2,3),k,isub) &
+ & + phi(i,j+offs(3,3),k,isub)
+ laps(2-3,3) = phi(i,j,k+offs(1,3),isub) &
+ & -2.0_mk * phi(i,j,k+offs(2,3),isub) &
+ & + phi(i,j,k+offs(3,3),isub)
+ laps(2-2,1) = phi(i+offs(1,2),j,k,isub) &
+ & -2.0_mk * phi(i+offs(2,2),j,k,isub) &
+ & + phi(i+offs(3,2),j,k,isub)
+ laps(2-2,2) = phi(i,j+offs(1,2),k,isub) &
+ & -2.0_mk * phi(i,j+offs(2,2),k,isub) &
+ & + phi(i,j+offs(3,2),k,isub)
+ laps(2-2,3) = phi(i,j,k+offs(1,2),isub) &
+ & -2.0_mk * phi(i,j,k+offs(2,2),isub) &
+ & + phi(i,j,k+offs(3,2),isub)
+ laps(2-1,1) = phi(i+offs(1,1),j,k,isub) &
+ & -2.0_mk * phi(i+offs(2,1),j,k,isub) &
+ & + phi(i+offs(3,1),j,k,isub)
+ laps(2-1,2) = phi(i,j+offs(1,1),k,isub) &
+ & -2.0_mk * phi(i,j+offs(2,1),k,isub) &
+ & + phi(i,j+offs(3,1),k,isub)
+ laps(2-1,3) = phi(i,j,k+offs(1,1),isub) &
+ & -2.0_mk * phi(i,j,k+offs(2,1),isub) &
+ & + phi(i,j,k+offs(3,1),isub)
+#elif __MODE == __VEC
+ DO ilap=1,3
+ laps(2-ilap,1) = phi(idx,i+offs(1,ilap),j,k,isub) &
+ & -2.0_mk * phi(idx,i+offs(2,ilap),j,k,isub) &
+ & + phi(idx,i+offs(3,ilap),j,k,isub)
+ laps(2-ilap,2) = phi(idx,i,j+offs(1,ilap),k,isub) &
+ & -2.0_mk * phi(idx,i,j+offs(2,ilap),k,isub) &
+ & + phi(idx,i,j+offs(3,ilap),k,isub)
+ laps(2-ilap,3) = phi(idx,i,j,k+offs(1,ilap),isub) &
+ & -2.0_mk * phi(idx,i,j,k+offs(2,ilap),isub) &
+ & + phi(idx,i,j,k+offs(3,ilap),isub)
+ END DO
+#endif
+
+ rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
+ rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
+ rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
+ rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
+ rpos(3) = (wenoeps + laps( 1,3)**2)/(wenoeps + laps(0,3)**2)
+ rneg(3) = (wenoeps + laps(-1,3)**2)/(wenoeps + laps(0,3)**2)
+
+ opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
+ opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
+ opos(3) = 1.0_mk/(1.0_mk+2.0_mk*rpos(3)**2)
+ oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
+ oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
+ oneg(3) = 1.0_mk/(1.0_mk+2.0_mk*rneg(3)**2)
+
+#if __MODE == __SCA
+ phip(1) = 0.5_mk*(phimid(1) - &
+ & opos(1)*( &
+ & phi(i+2,j,k,isub) - &
+ & 3.0_mk*(phi(i+1,j,k,isub) - phi(i ,j,k,isub)) - &
+ & phi(i-1,j,k,isub)))*dxi(1)
+ phip(2) = 0.5_mk*(phimid(2) - &
+ & opos(2)*( &
+ & phi(i,j+2,k,isub) - &
+ & 3.0_mk*(phi(i,j+1,k,isub) - phi(i ,j,k,isub)) - &
+ & phi(i,j-1,k,isub)))*dxi(2)
+ phip(3) = 0.5_mk*(phimid(3) - &
+ & opos(3)*( &
+ & phi(i,j,k+2,isub) - &
+ & 3.0_mk*(phi(i,j,k+1,isub) - phi(i ,j,k,isub)) - &
+ & phi(i,j,k-1,isub)))*dxi(3)
+ phin(1) = 0.5_mk*(phimid(1) - &
+ & oneg(1)*( &
+ & phi(i+1,j,k,isub) - &
+ & 3.0_mk*(phi(i ,j,k,isub) - phi(i-1,j,k,isub)) - &
+ & phi(i-2,j,k,isub)))*dxi(1)
+ phin(2) = 0.5_mk*(phimid(2) - &
+ & oneg(2)*( &
+ & phi(i,j+1,k,isub) - &
+ & 3.0_mk*(phi(i,j ,k,isub) - phi(i,j-1,k,isub)) - &
+ & phi(i,j-2,k,isub)))*dxi(2)
+ phin(3) = 0.5_mk*(phimid(3) - &
+ & oneg(3)*( &
+ & phi(i,j,k+1,isub) - &
+ & 3.0_mk*(phi(i,j,k ,isub) - phi(i,j,k-1,isub)) - &
+ & phi(i,j,k-2,isub)))*dxi(3)
+#else
+ phip(1) = 0.5_mk*(phimid(1) - &
+ & opos(1)*( &
+ & phi(idx,i+2,j,k,isub) - &
+ & 3.0_mk*(phi(idx,i+1,j,k,isub)-phi(idx,i,j,k,isub))-&
+ & phi(idx,i-1,j,k,isub)))*dxi(1)
+ phip(2) = 0.5_mk*(phimid(2) - &
+ & opos(2)*( &
+ & phi(idx,i,j+2,k,isub) - &
+ & 3.0_mk*(phi(idx,i,j+1,k,isub)-phi(idx,i,j,k,isub))-&
+ & phi(idx,i,j-1,k,isub)))*dxi(2)
+ phip(3) = 0.5_mk*(phimid(3) - &
+ & opos(3)*( &
+ & phi(idx,i,j,k+2,isub) - &
+ & 3.0_mk*(phi(idx,i,j,k+1,isub)-phi(idx,i,j,k,isub))-&
+ & phi(idx,i,j,k-1,isub)))*dxi(3)
+ phin(1) = 0.5_mk*(phimid(1) - &
+ & oneg(1)*( &
+ & phi(idx,i+1,j,k,isub) - &
+ & 3.0_mk*(phi(idx,i ,j,k,isub)-phi(idx,i-1,j,k,isub))-&
+ & phi(idx,i-2,j,k,isub)))*dxi(1)
+ phin(2) = 0.5_mk*(phimid(2) - &
+ & oneg(2)*( &
+ & phi(idx,i,j+1,k,isub) - &
+ & 3.0_mk*(phi(idx,i,j ,k,isub)-phi(idx,i,j-1,k,isub))-&
+ & phi(idx,i,j-2,k,isub)))*dxi(2)
+ phin(3) = 0.5_mk*(phimid(3) - &
+ & oneg(3)*( &
+ & phi(idx,i,j,k+1,isub) - &
+ & 3.0_mk*(phi(idx,i,j,k ,isub)-phi(idx,i,j,k-1,isub))-&
+ & phi(idx,i,j,k-2,isub)))*dxi(3)
+#endif
+
+#if __MODE == __SCA
+ !--- collect
+ IF(phi(i,j,k,isub).GT.0.0_mk) THEN
+ pbs = SQRT( &
+ & MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))**2+&
+ & MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))**2+&
+ & MAX(-MIN(phip(3),0.0_mk),MAX(phin(3),0.0_mk))**2)&
+ & - trgt
+ ELSEIF(phi(i,j,k,isub).LT.0.0_mk) THEN
+ pbs = SQRT( &
+ & MAX(MAX(phip(1),0.0_mk),-MIN(phin(1),0.0_mk))**2+&
+ & MAX(MAX(phip(2),0.0_mk),-MIN(phin(2),0.0_mk))**2+&
+ & MAX(MAX(phip(3),0.0_mk),-MIN(phin(3),0.0_mk))**2)&
+ & - trgt
+ ELSE
+ pbs = 0.0_mk
+ END IF
+ dphi_dt = pbs * phi(i,j,k,isub) / &
+ & SQRT(phi(i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
+ tphi(i,j,k,isub) = phi(i,j,k,isub) - wenotau * dphi_dt
+
+#else
+ !--- collect
+ IF(phi(idx,i,j,k,isub).GT.0.0_mk) THEN
+ pbs = SQRT( &
+ & MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))**2+&
+ & MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))**2+&
+ & MAX(-MIN(phip(3),0.0_mk),MAX(phin(3),0.0_mk))**2)&
+ & - trgt
+ ELSEIF(phi(idx,i,j,k,isub).LT.0.0_mk) THEN
+ pbs = SQRT( &
+ & MAX(MAX(phip(1),0.0_mk),-MIN(phin(1),0.0_mk))**2+&
+ & MAX(MAX(phip(2),0.0_mk),-MIN(phin(2),0.0_mk))**2+&
+ & MAX(MAX(phip(3),0.0_mk),-MIN(phin(3),0.0_mk))**2)&
+ & - trgt
+ ELSE
+ pbs = 0.0_mk
+ END IF
+ dphi_dt = pbs * phi(idx,i,j,k,isub) / &
+ & SQRT(phi(idx,i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
+ tphi(i,j,k,isub) = phi(idx,i,j,k,isub) - wenotau * dphi_dt
+
+#endif
+
+ rms = MAX(rms,ABS(dphi_dt))
+
+
+
+ END DO
+
+ res = rms
+
+ CALL substop('ppm_hamjac_reinit_loc_step_3d',t0,info)
+#if __MODE == __SCA
+#if __KIND == __SINGLE_PRECISION
+ END SUBROUTINE ppm_hamjac_reinit_loc_step_3ds
+#elif __KIND == __DOUBLE_PRECISION
+ END SUBROUTINE ppm_hamjac_reinit_loc_step_3dd
+#endif
+#elif __MODE == __VEC
+#if __KIND == __SINGLE_PRECISION
+ END SUBROUTINE ppm_hamjac_reinit_loc_step_3dsV
+#elif __KIND == __DOUBLE_PRECISION
+ END SUBROUTINE ppm_hamjac_reinit_loc_step_3ddV
+#endif
+#endif
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/ppm_hamjac_reinit_ref_3d.f b/src/ppm_hamjac_reinit_ref_3d.f
index 3043ff8..8d822bf 100644
--- a/src/ppm_hamjac_reinit_ref_3d.f
+++ b/src/ppm_hamjac_reinit_ref_3d.f
@@ -18,8 +18,8 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_hamjac_reinit_ref_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
+ ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
+ ! initial import
!
! Revision 1.1 2005/07/25 00:34:03 ivos
! Initial check-in.
@@ -30,6 +30,8 @@
! ETH Zentrum, Hirschengraben 84
! CH-8092 Zurich, Switzerland
!-------------------------------------------------------------------------
+
+
#if __MODE == __SCA
#if __KIND == __SINGLE_PRECISION
SUBROUTINE ppm_hamjac_reinit_ref_3ds (phi, chi, trgt, tol, maxstep, &
@@ -41,22 +43,24 @@
#elif __MODE == __VEC
#error VECTOR NOT IMPLEMENTED
#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mesh
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
+
+ USE ppm_module_data
+ USE ppm_module_data_mesh
+ USE ppm_module_error
+ USE ppm_module_write
+ USE ppm_module_substart
+ USE ppm_module_alloc
+ USE ppm_module_substop
+ USE ppm_module_map
+ USE ppm_module_typedef
+ IMPLICIT NONE
+
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
#elif __KIND == __DOUBLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
+
!-----------------------------------------------------
! Arguments
!-----------------------------------------------------
@@ -67,6 +71,7 @@
INTEGER, INTENT(inout) :: info
INTEGER, INTENT(in) :: maxstep
REAL(mk), INTENT(in) :: tol, trgt
+
!-----------------------------------------------------
! Aliases
!-----------------------------------------------------
@@ -74,20 +79,22 @@
REAL(mk), DIMENSION(:,:,:,:), POINTER :: tphi
INTEGER :: nsublist
INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
+ INTEGER :: topoid,meshid
+ REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
TYPE(ppm_t_topo), POINTER :: topo
TYPE(ppm_t_equi_mesh), POINTER :: mesh
+
!-----------------------------------------------------
! standard stuff
!-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k,maptype
- INTEGER :: istep,iopt
- INTEGER :: ldl(4), ldu(4),ndata_max(3)
+ INTEGER :: isub,isubl,i,j,k,maptype,istep,iopt
+ INTEGER :: ldl(4), ldu(4), ndata_max(3)
REAL(mk) :: len_phys(3)
REAL(mk) :: t0, res
CHARACTER(LEN=ppm_char) :: cbuf
+
CALL substart('ppm_hamjac_reinit_ref_3d',t0,info)
+
!-----------------------------------------------------
! Get the mesh data
!-----------------------------------------------------
@@ -96,7 +103,6 @@
meshid = mesh%ID
nsublist = topo%nsublist
ndata => mesh%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
min_phys => topo%min_physs
@@ -105,6 +111,14 @@
min_phys => topo%min_physd
max_phys => topo%max_physd
#endif
+
+
+ !-----------------------------------------------------
+ ! RATIONALE Thu May 26 20:51:19 PDT 2005:
+ ! loop ghostmap doit. easy.
+ !-----------------------------------------------------
+
+
!-----------------------------------------------------
! allocate temporary storage
!-----------------------------------------------------
@@ -124,9 +138,11 @@
& 'temp storage for hamjac',__LINE__,info)
GOTO 9999
END IF
+
!--- ready to blast
maptype = ppm_param_map_init
CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
+
!--- map the map
maptype = ppm_param_map_ghost_get
CALL ppm_map_field_ghost(chi,3,topo_id,mesh_id,ghostsize,maptype,info)
@@ -136,6 +152,8 @@
CALL ppm_map_field_ghost(chi,3,topo_id,mesh_id,ghostsize,maptype,info)
maptype = ppm_param_map_pop
CALL ppm_map_field_ghost(chi,3,topo_id,mesh_id,ghostsize,maptype,info)
+
+
!--- COMMENT Thu May 26 21:05:23 PDT 2005: simple euler here, do TVD
DO istep=1,maxstep
!--- map the gowas
@@ -147,13 +165,16 @@
CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
maptype = ppm_param_map_pop
CALL ppm_map_field_ghost(phi,topo_id,mesh_id,ghostsize,maptype,info)
+
CALL ppm_hamjac_reinit_step_ref(phi,chi,tphi,trgt,res,topo_id, &
& mesh_id,ghostsize,info)
! IF (ppm_debug .GT. 0) THEN
- WRITE(cbuf,'(A,I4,A,E5.2)') 'Iteration ',istep,' Residual: ',res
+ !TODO Uncomment WRITE statement
+ !WRITE(cbuf,'(A,I4,A,ES)') 'Iteration ',istep,' Residual: ', res
CALL ppm_write(ppm_rank,'ppm_hamjac_reinit_ref_3d',cbuf,info)
! ENDIF
+
DO isub=1,nsublist
isubl = isublist(isub)
DO k=1,ndata(3,isubl);DO j=1,ndata(2,isubl);DO i=1,ndata(1,isubl)
@@ -162,11 +183,14 @@
END DO
IF(res.LT.tol) GOTO 666
END DO
+
info = ppm_error_warning
CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_ref_3d', &
& 'failed to reach target residual',__LINE__,info)
info = ppm_param_success
+
666 CONTINUE
+
iopt = ppm_param_dealloc
CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
IF(info.NE.0) THEN
@@ -175,6 +199,8 @@
& 'temp storage for hamjac not freed',__LINE__,info)
GOTO 9999
END IF
+
+
9999 CONTINUE
#if __KIND == __SINGLE_PRECISION
@@ -182,3 +208,11 @@
#elif __KIND == __DOUBLE_PRECISION
END SUBROUTINE ppm_hamjac_reinit_ref_3dd
#endif
+
+
+
+
+
+
+
+
diff --git a/src/ppm_hamjac_reinit_russo_3d.f b/src/ppm_hamjac_reinit_russo_3d.f
index 9fbd1a5..b4f9d1f 100644
--- a/src/ppm_hamjac_reinit_russo_3d.f
+++ b/src/ppm_hamjac_reinit_russo_3d.f
@@ -82,9 +82,11 @@
INTEGER :: nsublist
INTEGER, DIMENSION(:,:), POINTER :: ndata
INTEGER :: topoid,meshid
- REAL(mk), DIMENSION(:,:), POINTER :: min_phys, max_phys
- INTEGER, DIMENSION(6) :: orgbcdef
+ REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
+ INTEGER, DIMENSION(6) :: orgbcdef
INTEGER :: s2didx, mpi_prec
+ TYPE(ppm_t_topo), POINTER :: topo
+ TYPE(ppm_t_equi_mesh), POINTER :: mesh
!-----------------------------------------------------
! standard stuff
!-----------------------------------------------------
@@ -112,27 +114,27 @@
!-----------------------------------------------------
! Get the mesh data
!-----------------------------------------------------
- topoid = ppm_internal_topoid(topo_id)
- meshid = ppm_meshid(topoid)%internal(mesh_id)
- nsublist = ppm_nsublist(topoid)
- ndata => ppm_cart_mesh(meshid,topoid)%nnodes
-
- isublist => ppm_isublist(:,topoid)
+ topo => ppm_topo(topo_id)%t
+ mesh => topo%mesh(mesh_id)
+ meshid = mesh%ID
+ nsublist = topo%nsublist
+ ndata => mesh%nnodes
+ isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
- min_phys => ppm_min_physs
- max_phys => ppm_max_physs
+ min_phys => topo%min_physs
+ max_phys => topo%max_physs
#elif __KIND == __DOUBLE_PRECISION
- min_phys => ppm_min_physd
- max_phys => ppm_max_physd
+ min_phys => topo%min_physd
+ max_phys => topo%max_physd
#endif
- len_phys(1) = max_phys(1,topoid) - min_phys(1,topoid)
- len_phys(2) = max_phys(2,topoid) - min_phys(2,topoid)
- len_phys(3) = max_phys(3,topoid) - min_phys(3,topoid)
+ len_phys(1) = max_phys(1) - min_phys(1)
+ len_phys(2) = max_phys(2) - min_phys(2)
+ len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(ppm_cart_mesh(meshid,topoid)%nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(ppm_cart_mesh(meshid,topoid)%nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(ppm_cart_mesh(meshid,topoid)%nm(3)-1,mk)
+ dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
+ dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
+ dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
! timestep
tau = 0.25_mk*MINVAL(dx)
diff --git a/src/ppm_hamjac_reinit_russo_step_3d.f b/src/ppm_hamjac_reinit_russo_step_3d.f
index 2c0cbbd..079b6fc 100644
--- a/src/ppm_hamjac_reinit_russo_step_3d.f
+++ b/src/ppm_hamjac_reinit_russo_step_3d.f
@@ -76,7 +76,9 @@
INTEGER :: nsublist
INTEGER, DIMENSION(:,:), POINTER :: ndata
INTEGER :: topoid, meshid
- REAL(mk), DIMENSION(:,:), POINTER :: min_phys, max_phys
+ REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
+ TYPE(ppm_t_topo), POINTER :: topo
+ TYPE(ppm_t_equi_mesh), POINTER :: mesh
!-----------------------------------------------------
! standard stuff
@@ -101,27 +103,27 @@
!-----------------------------------------------------
! Get the mesh data
!-----------------------------------------------------
- topoid = ppm_internal_topoid(topo_id)
- meshid = ppm_meshid(topoid)%internal(mesh_id)
- nsublist = ppm_nsublist(topoid)
- ndata => ppm_cart_mesh(meshid,topoid)%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
- isublist => ppm_isublist(:,topoid)
+ topo => ppm_topo(topo_id)%t
+ mesh => topo%mesh(mesh_id)
+ meshid = mesh%ID
+ nsublist = topo%nsublist
+ ndata => mesh%nnodes
+ isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
- min_phys => ppm_min_physs
- max_phys => ppm_max_physs
+ min_phys => topo%min_physs
+ max_phys => topo%max_physs
#elif __KIND == __DOUBLE_PRECISION
- min_phys => ppm_min_physd
- max_phys => ppm_max_physd
+ min_phys => topo%min_physd
+ max_phys => topo%max_physd
#endif
- len_phys(1) = max_phys(1,topoid) - min_phys(1,topoid)
- len_phys(2) = max_phys(2,topoid) - min_phys(2,topoid)
- len_phys(3) = max_phys(3,topoid) - min_phys(3,topoid)
+ len_phys(1) = max_phys(1) - min_phys(1)
+ len_phys(2) = max_phys(2) - min_phys(2)
+ len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(ppm_cart_mesh(meshid,topoid)%nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(ppm_cart_mesh(meshid,topoid)%nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(ppm_cart_mesh(meshid,topoid)%nm(3)-1,mk)
+ dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
+ dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
+ dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
dxi(1) = 1.0_mk/dx(1)
dxi(2) = 1.0_mk/dx(2)
dxi(3) = 1.0_mk/dx(3)
diff --git a/src/ppm_hamjac_reinit_step_2d.f b/src/ppm_hamjac_reinit_step_2d.f
index f92091d..cce894a 100644
--- a/src/ppm_hamjac_reinit_step_2d.f
+++ b/src/ppm_hamjac_reinit_step_2d.f
@@ -18,8 +18,8 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_hamjac_reinit_step_2d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
+ ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
+ ! initial import
!
! Revision 1.1 2005/07/25 00:34:04 ivos
! Initial check-in.
@@ -30,6 +30,8 @@
! ETH Zentrum, Hirschengraben 84
! CH-8092 Zurich, Switzerland
!-------------------------------------------------------------------------
+
+
#if __MODE == __SCA
#if __KIND == __SINGLE_PRECISION
SUBROUTINE ppm_hamjac_reinit_step_2ds (phi, tphi, trgt, res, &
@@ -40,22 +42,22 @@
#elif __MODE == __VEC
#error VECTOR NOT IMPLEMENTED
#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mesh
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
+
+ USE ppm_module_data
+ USE ppm_module_data_mesh
+ USE ppm_module_error
+ USE ppm_module_substart
+ USE ppm_module_substop
+ USE ppm_module_typedef
+
+ IMPLICIT NONE
+
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
#elif __KIND == __DOUBLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
+
!-----------------------------------------------------
! Arguments
!-----------------------------------------------------
@@ -65,21 +67,23 @@
INTEGER, INTENT(inout) :: info
REAL(mk),INTENT(out) :: res
REAL(mk), INTENT(in) :: trgt
+
!-----------------------------------------------------
! Aliases
!-----------------------------------------------------
INTEGER, DIMENSION(:), POINTER :: isublist
INTEGER :: nsublist
INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
+ INTEGER :: topoid, meshid
+ REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
TYPE(ppm_t_topo), POINTER :: topo
TYPE(ppm_t_equi_mesh), POINTER :: mesh
+
!-----------------------------------------------------
! standard stuff
!-----------------------------------------------------
INTEGER :: isub,isubl,i,j,k
- REAL(mk) :: len_phys(2)
+ REAL(MK) :: len_phys(2)
!-----------------------------------------------------
! WENO stuff
!-----------------------------------------------------
@@ -90,7 +94,10 @@
INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
& = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
REAL(mk) :: t0
+
+
CALL substart('ppm_hamjac_reinit_step_2d',t0,info)
+
!-----------------------------------------------------
! Get the mesh data
!-----------------------------------------------------
@@ -99,7 +106,6 @@
meshid = mesh%ID
nsublist = topo%nsublist
ndata => mesh%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
min_phys => topo%min_physs
@@ -108,19 +114,23 @@
min_phys => topo%min_physd
max_phys => topo%max_physd
#endif
+
len_phys(1) = max_phys(1) - min_phys(1)
len_phys(2) = max_phys(2) - min_phys(2)
- dx(1) = len_phys(1)/REAL(mesh%nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%nm(2)-1,mk)
+ dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
+ dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
dxi(1) = 1.0_mk/dx(1)
dxi(2) = 1.0_mk/dx(2)
wenoeps = 1.0e-6_mk
wenotau = 0.25_mk*MINVAL(dx)
+
rms = -HUGE(rms)
+
DO isub=1,nsublist
isubl = isublist(isub)
DO j=1,ndata(2,isubl)
DO i=1,ndata(1,isubl)
+
!DO ilap=1,3
! laps(2-ilap,1) = phi(i+offs(1,ilap),j,isub) &
! & -2.0_mk * phi(i+offs(2,ilap),j,isub) &
@@ -147,16 +157,22 @@
laps(-1,2) = phi(i,j,isub) &
& -2.0_mk * phi(i,j-1,isub) &
& + phi(i,j-2,isub)
+
+
+
rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
+
opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
+
phimid(1) = phi(i+1,j,isub)-phi(i-1,j,isub)
phimid(2) = phi(i,j+1,isub)-phi(i,j-1,isub)
+
phip(1) = 0.5_mk*(phimid(1) - &
& opos(1)*( &
& phi(i+2,j,isub) - &
@@ -177,6 +193,7 @@
& phi(i,j+1,isub) - &
& 3.0_mk*(phi(i,j ,isub) - phi(i,j-1,isub)) - &
& phi(i,j-2,isub)))*dxi(2)
+
!--- collect
IF(phi(i,j,isub).GT.0.0_mk) THEN
pbs = SQRT( &
@@ -196,10 +213,17 @@
tphi(i,j,isub) = phi(i,j,isub) - wenotau * dphi_dt
rms = MAX(rms,ABS(dphi_dt))
+
END DO
+
END DO
+
END DO
+
+
+
res = rms
+
CALL substop('ppm_hamjac_reinit_step_2d',t0,info)
#if __KIND == __SINGLE_PRECISION
@@ -207,3 +231,18 @@
#elif __KIND == __DOUBLE_PRECISION
END SUBROUTINE ppm_hamjac_reinit_step_2dd
#endif
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/ppm_hamjac_reinit_step_3d.f b/src/ppm_hamjac_reinit_step_3d.f
index 55b163d..c21f053 100644
--- a/src/ppm_hamjac_reinit_step_3d.f
+++ b/src/ppm_hamjac_reinit_step_3d.f
@@ -18,8 +18,8 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_hamjac_reinit_step_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
+ ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
+ ! initial import
!
! Revision 1.2 2005/08/12 14:38:01 ivos
! bugfix: index bounds in loop corrected.
@@ -33,6 +33,7 @@
! ETH Zentrum, Hirschengraben 84
! CH-8092 Zurich, Switzerland
!-------------------------------------------------------------------------
+
#if __MODE == __SCA
#if __KIND == __SINGLE_PRECISION
SUBROUTINE ppm_hamjac_reinit_step_3ds (phi, tphi, trgt, res, &
@@ -50,22 +51,22 @@
& topo_id, mesh_id, ghostsize, info)
#endif
#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
+
USE ppm_module_data
USE ppm_module_data_mesh
+ USE ppm_module_error
USE ppm_module_substart
USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
USE ppm_module_typedef
+
IMPLICIT NONE
+
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
#elif __KIND == __DOUBLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
+
!-----------------------------------------------------
! Arguments
!-----------------------------------------------------
@@ -83,21 +84,23 @@
INTEGER, INTENT(in) :: idx
#endif
REAL(mk), INTENT(in) :: trgt
+
!-----------------------------------------------------
! Aliases
!-----------------------------------------------------
INTEGER, DIMENSION(:), POINTER :: isublist
INTEGER :: nsublist
INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
+ INTEGER :: topoid, meshid
+ REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
+ TYPE(ppm_t_topo), POINTER :: topo
+ TYPE(ppm_t_equi_mesh), POINTER :: mesh
+
!-----------------------------------------------------
! standard stuff
!-----------------------------------------------------
INTEGER :: isub,isubl,i,j,k
- REAL(mk) :: len_phys(3)
+ REAL(MK) :: len_phys(3)
!-----------------------------------------------------
! WENO stuff
!-----------------------------------------------------
@@ -108,7 +111,10 @@
INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
& = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
REAL(mk) :: t0
+
+
CALL substart('ppm_hamjac_reinit_step_3d',t0,info)
+
!-----------------------------------------------------
! Get the mesh data
!-----------------------------------------------------
@@ -117,7 +123,6 @@
meshid = mesh%ID
nsublist = topo%nsublist
ndata => mesh%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
min_phys => topo%min_physs
@@ -126,34 +131,72 @@
min_phys => topo%min_physd
max_phys => topo%max_physd
#endif
+
len_phys(1) = max_phys(1) - min_phys(1)
len_phys(2) = max_phys(2) - min_phys(2)
len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(mesh%nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%nm(3)-1,mk)
+ dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
+ dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
+ dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
dxi(1) = 1.0_mk/dx(1)
dxi(2) = 1.0_mk/dx(2)
dxi(3) = 1.0_mk/dx(3)
wenoeps = 1.0e-6_mk
wenotau = 0.25_mk*MINVAL(dx)
+
rms = -HUGE(rms)
+
DO isub=1,nsublist
isubl = isublist(isub)
DO k=1,ndata(3,isubl)
DO j=1,ndata(2,isubl)
DO i=1,ndata(1,isubl)
+ ! hack
+#if __MODE == __SCA
+! IF(phi(i+1,j,k,isub).EQ.phi(i-1,j,k,isub).AND. &
+! & phi(i,j+1,k,isub).EQ.phi(i,j-1,k,isub).AND. &
+! & phi(i,j,k+1,isub).EQ.phi(i,j,k-1,isub).AND.ABS(phi(i&
+! &,j,k,isub)).LT.14.0_mk*dx(1)) CYCLE
+#endif
+#if __MODE == __SCA
+ phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
+ phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
+ phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
+#else
+ phimid(1) = phi(idx,i+1,j,k,isub)-phi(idx,i-1,j,k,isub)
+ phimid(2) = phi(idx,i,j+1,k,isub)-phi(idx,i,j-1,k,isub)
+ phimid(3) = phi(idx,i,j,k+1,isub)-phi(idx,i,j,k-1,isub)
+#endif
+
DO ilap=1,3
#if __MODE == __SCA
- laps(2-ilap,1) = phi(i+offs(1,ilap),j,k,isub) &
- & -2.0_mk * phi(i+offs(2,ilap),j,k,isub) &
- & + phi(i+offs(3,ilap),j,k,isub)
- laps(2-ilap,2) = phi(i,j+offs(1,ilap),k,isub) &
- & -2.0_mk * phi(i,j+offs(2,ilap),k,isub) &
- & + phi(i,j+offs(3,ilap),k,isub)
- laps(2-ilap,3) = phi(i,j,k+offs(1,ilap),isub) &
- & -2.0_mk * phi(i,j,k+offs(2,ilap),isub) &
- & + phi(i,j,k+offs(3,ilap),isub)
+ laps(2-3,1) = phi(i+offs(1,3),j,k,isub) &
+ & -2.0_mk * phi(i+offs(2,3),j,k,isub) &
+ & + phi(i+offs(3,3),j,k,isub)
+ laps(2-3,2) = phi(i,j+offs(1,3),k,isub) &
+ & -2.0_mk * phi(i,j+offs(2,3),k,isub) &
+ & + phi(i,j+offs(3,3),k,isub)
+ laps(2-3,3) = phi(i,j,k+offs(1,3),isub) &
+ & -2.0_mk * phi(i,j,k+offs(2,3),isub) &
+ & + phi(i,j,k+offs(3,3),isub)
+ laps(2-2,1) = phi(i+offs(1,2),j,k,isub) &
+ & -2.0_mk * phi(i+offs(2,2),j,k,isub) &
+ & + phi(i+offs(3,2),j,k,isub)
+ laps(2-2,2) = phi(i,j+offs(1,2),k,isub) &
+ & -2.0_mk * phi(i,j+offs(2,2),k,isub) &
+ & + phi(i,j+offs(3,2),k,isub)
+ laps(2-2,3) = phi(i,j,k+offs(1,2),isub) &
+ & -2.0_mk * phi(i,j,k+offs(2,2),isub) &
+ & + phi(i,j,k+offs(3,2),isub)
+ laps(2-1,1) = phi(i+offs(1,1),j,k,isub) &
+ & -2.0_mk * phi(i+offs(2,1),j,k,isub) &
+ & + phi(i+offs(3,1),j,k,isub)
+ laps(2-1,2) = phi(i,j+offs(1,1),k,isub) &
+ & -2.0_mk * phi(i,j+offs(2,1),k,isub) &
+ & + phi(i,j+offs(3,1),k,isub)
+ laps(2-1,3) = phi(i,j,k+offs(1,1),isub) &
+ & -2.0_mk * phi(i,j,k+offs(2,1),isub) &
+ & + phi(i,j,k+offs(3,1),isub)
#elif __MODE == __VEC
laps(2-ilap,1) = phi(idx,i+offs(1,ilap),j,k,isub) &
& -2.0_mk * phi(idx,i+offs(2,ilap),j,k,isub) &
@@ -166,27 +209,21 @@
& + phi(idx,i,j,k+offs(3,ilap),isub)
#endif
END DO
+
rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
rpos(3) = (wenoeps + laps( 1,3)**2)/(wenoeps + laps(0,3)**2)
rneg(3) = (wenoeps + laps(-1,3)**2)/(wenoeps + laps(0,3)**2)
+
opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
opos(3) = 1.0_mk/(1.0_mk+2.0_mk*rpos(3)**2)
oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
oneg(3) = 1.0_mk/(1.0_mk+2.0_mk*rneg(3)**2)
-#if __MODE == __SCA
- phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
- phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
- phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
-#else
- phimid(1) = phi(idx,i+1,j,k,isub)-phi(idx,i-1,j,k,isub)
- phimid(2) = phi(idx,i,j+1,k,isub)-phi(idx,i,j-1,k,isub)
- phimid(3) = phi(idx,i,j,k+1,isub)-phi(idx,i,j,k-1,isub)
-#endif
+
#if __MODE == __SCA
phip(1) = 0.5_mk*(phimid(1) - &
& opos(1)*( &
@@ -250,6 +287,7 @@
& 3.0_mk*(phi(idx,i,j,k ,isub) - phi(idx,i,j,k-1,isub)) - &
& phi(idx,i,j,k-2,isub)))*dxi(3)
#endif
+
#if __MODE == __SCA
!--- collect
IF(phi(i,j,k,isub).GT.0.0_mk) THEN
@@ -270,6 +308,7 @@
dphi_dt = pbs * phi(i,j,k,isub) / &
& SQRT(phi(i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
tphi(i,j,k,isub) = phi(i,j,k,isub) - wenotau * dphi_dt
+
#else
!--- collect
IF(phi(idx,i,j,k,isub).GT.0.0_mk) THEN
@@ -290,13 +329,21 @@
dphi_dt = pbs * phi(idx,i,j,k,isub) / &
& SQRT(phi(idx,i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
tphi(i,j,k,isub) = phi(idx,i,j,k,isub) - wenotau * dphi_dt
+
#endif
+
rms = MAX(rms,ABS(dphi_dt))
+
END DO
+
END DO
+
END DO
+
END DO
+
res = rms
+
CALL substop('ppm_hamjac_reinit_step_3d',t0,info)
#if __MODE == __SCA
#if __KIND == __SINGLE_PRECISION
@@ -311,3 +358,18 @@
END SUBROUTINE ppm_hamjac_reinit_step_3ddV
#endif
#endif
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/ppm_hamjac_reinit_step_ref_3d.f b/src/ppm_hamjac_reinit_step_ref_3d.f
index a801351..6c65762 100644
--- a/src/ppm_hamjac_reinit_step_ref_3d.f
+++ b/src/ppm_hamjac_reinit_step_ref_3d.f
@@ -19,8 +19,8 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_hamjac_reinit_step_ref_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
+ ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
+ ! initial import
!
! Revision 1.2 2005/08/12 14:38:01 ivos
! bugfix: index bounds in loop corrected.
@@ -34,32 +34,33 @@
! ETH Zentrum, Hirschengraben 84
! CH-8092 Zurich, Switzerland
!-------------------------------------------------------------------------
+
#if __MODE == __SCA
#if __KIND == __SINGLE_PRECISION
SUBROUTINE ppm_hamjac_reinit_step_ref_3ds (phi, chi, tphi, trgt, res, &
- & topo_id, mesh_id, ghostsize, info)
+ & topo_id, mesh_id, ghostsize, info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_ref_3dd (phi, chi, tphi, trgt, res, topo_id, mesh_id, ghostsize, info)
+ SUBROUTINE ppm_hamjac_reinit_step_ref_3dd (phi, chi, tphi, trgt, res, &
+ & topo_id, mesh_id, ghostsize, info)
#endif
#elif __MODE == __VEC
#error VECTOR NOT IMPLEMENTED
#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mesh
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
+
+ USE ppm_module_data
+ USE ppm_module_data_mesh
+ USE ppm_module_error
+ USE ppm_module_substart
+ USE ppm_module_substop
+ USE ppm_module_typedef
+ IMPLICIT NONE
+
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
#elif __KIND == __DOUBLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
+
!-----------------------------------------------------
! Arguments
!-----------------------------------------------------
@@ -70,22 +71,23 @@
INTEGER, INTENT(inout) :: info
real(mk),INTENT(out) :: res
REAL(mk), INTENT(in) :: trgt
+
!-----------------------------------------------------
! Aliases
!-----------------------------------------------------
INTEGER, DIMENSION(:), POINTER :: isublist
INTEGER :: nsublist
INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
+ INTEGER :: topoid, meshid
+ REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
TYPE(ppm_t_topo), POINTER :: topo
TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
+
!-----------------------------------------------------
! standard stuff
!-----------------------------------------------------
INTEGER :: isub,isubl,i,j,k
- REAL(mk) :: len_phys(3)
+ REAL(MK) :: len_phys(3)
!-----------------------------------------------------
! WENO stuff
!-----------------------------------------------------
@@ -99,7 +101,10 @@
INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
& = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
REAL(mk) :: t0
+
+
CALL substart('ppm_hamjac_step_3d',t0,info)
+
!-----------------------------------------------------
! Get the mesh data
!-----------------------------------------------------
@@ -108,7 +113,6 @@
meshid = mesh%ID
nsublist = topo%nsublist
ndata => mesh%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
isublist => topo%isublist
#if __KIND == __SINGLE_PRECISION
min_phys => topo%min_physs
@@ -117,12 +121,13 @@
min_phys => topo%min_physd
max_phys => topo%max_physd
#endif
+
len_phys(1) = max_phys(1) - min_phys(1)
len_phys(2) = max_phys(2) - min_phys(2)
len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(mesh%nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%nm(3)-1,mk)
+ dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
+ dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
+ dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
dxi(1) = 1.0_mk/dx(1)
dxi(2) = 1.0_mk/dx(2)
dxi(3) = 1.0_mk/dx(3)
@@ -132,14 +137,18 @@
dxitwelve = dxi(1)/12.0_mk
dyitwelve = dxi(2)/12.0_mk
dzitwelve = dxi(3)/12.0_mk
+
wenoeps = 1.0e-6_mk
wenotau = 0.5_mk*MINVAL(dx)
+
rms = -HUGE(rms)
+
DO isub=1,nsublist
isubl = isublist(isub)
DO k=1,ndata(3,isubl)
DO j=1,ndata(2,isubl)
DO i=1,ndata(1,isubl)
+
DO ilap=1,3
laps(2-ilap,1) = phi(i+offs(1,ilap),j,k,isub) &
& -2.0_mk * phi(i+offs(2,ilap),j,k,isub) &
@@ -151,21 +160,25 @@
& -2.0_mk * phi(i,j,k+offs(2,ilap),isub) &
& + phi(i,j,k+offs(3,ilap),isub)
END DO
+
rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
rpos(3) = (wenoeps + laps( 1,3)**2)/(wenoeps + laps(0,3)**2)
rneg(3) = (wenoeps + laps(-1,3)**2)/(wenoeps + laps(0,3)**2)
+
opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
opos(3) = 1.0_mk/(1.0_mk+2.0_mk*rpos(3)**2)
oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
oneg(3) = 1.0_mk/(1.0_mk+2.0_mk*rneg(3)**2)
+
phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
+
phip(1) = 0.5_mk*(phimid(1) - &
& opos(1)*( &
& phi(i+2,j,k,isub) - &
@@ -199,12 +212,15 @@
jsub = isub
#include "ppm_gmm_jacobian.inc"
+
phinx(1) = jac(1,1)*phin(1)+jac(2,1)*phin(2)+jac(3,1)*phin(3)
phinx(2) = jac(1,2)*phin(1)+jac(2,2)*phin(2)+jac(3,2)*phin(3)
phinx(3) = jac(1,3)*phin(1)+jac(2,3)*phin(2)+jac(3,3)*phin(3)
phipx(1) = jac(1,1)*phip(1)+jac(2,1)*phip(2)+jac(3,1)*phip(3)
phipx(2) = jac(1,2)*phip(1)+jac(2,2)*phip(2)+jac(3,2)*phip(3)
phipx(3) = jac(1,3)*phip(1)+jac(2,3)*phip(2)+jac(3,3)*phip(3)
+
+
!--- collect
IF(phi(i,j,k,isub).GT.0.0_mk) THEN
pbs = SQRT( &
@@ -224,12 +240,19 @@
dphi_dt = pbs * phi(i,j,k,isub) / &
& SQRT(phi(i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
tphi(i,j,k,isub) = phi(i,j,k,isub) - wenotau * dphi_dt
+
rms = MAX(rms,ABS(dphi_dt))
+
END DO
+
END DO
+
END DO
+
END DO
+
res = rms
+
CALL substop('ppm_hamjac_step_3d',t0,info)
#if __KIND == __SINGLE_PRECISION
@@ -237,3 +260,18 @@
#elif __KIND == __DOUBLE_PRECISION
END SUBROUTINE ppm_hamjac_reinit_step_ref_3dd
#endif
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/ppm_mg_alloc_field.f b/src/ppm_mg_alloc_field.f
index 9f73850..19c7e8c 100644
--- a/src/ppm_mg_alloc_field.f
+++ b/src/ppm_mg_alloc_field.f
@@ -27,11 +27,8 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_mg_alloc_field.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.8 2006/07/21 11:30:57 kotsalie
- ! FRIDAY
+ ! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+ ! initial import
!
! Revision 1.7 2004/10/01 16:33:39 ivos
! cosmetics.
@@ -89,6 +86,7 @@
#endif
#endif
#endif
+
!-------------------------------------------------------------------------
! Includes
!-------------------------------------------------------------------------
@@ -101,7 +99,6 @@
USE ppm_module_substart
USE ppm_module_substop
USE ppm_module_error
- USE ppm_module_alloc
IMPLICIT NONE
#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
INTEGER, PARAMETER :: MK = ppm_kind_single
@@ -113,7 +110,6 @@
!-------------------------------------------------------------------------
INTEGER , DIMENSION(: ), INTENT(IN ) :: lda
INTEGER , INTENT(IN ) :: iopt
- INTEGER , INTENT( OUT) :: info
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND ==__SINGLE_PRECISION
@@ -143,13 +139,16 @@
#endif
#endif
#endif
+
+
+ INTEGER , INTENT( OUT) :: info
!-------------------------------------------------------------------------
! Local variables
!-------------------------------------------------------------------------
- INTEGER :: i,j
+ INTEGER :: i,j
INTEGER, DIMENSION(2) :: ldc
REAL(MK) :: t0
- LOGICAL :: lcopy,lalloc,lrealloc,ldealloc
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND ==__SINGLE_PRECISION
@@ -179,6 +178,8 @@
#endif
#endif
#endif
+
+ LOGICAL :: lcopy,lalloc,lrealloc,ldealloc
!-------------------------------------------------------------------------
! Externals
!-------------------------------------------------------------------------
@@ -187,6 +188,7 @@
! Initialise
!-------------------------------------------------------------------------
CALL substart('ppm_mg_alloc_field',t0,info)
+
!-------------------------------------------------------------------------
! Check arguments
!-------------------------------------------------------------------------
@@ -210,6 +212,7 @@
GOTO 9999
ENDIF
ENDIF
+
!-------------------------------------------------------------------------
! Check allocation type
!-------------------------------------------------------------------------
@@ -288,6 +291,7 @@
ldealloc = .TRUE.
ENDIF
ENDIF
+
!-------------------------------------------------------------------------
! Perform the actual alloc action
!-------------------------------------------------------------------------
@@ -307,10 +311,13 @@
NULLIFY(work_field(i,j)%uc)
NULLIFY(work_field(i,j)%fc)
NULLIFY(work_field(i,j)%err)
+ NULLIFY(work_field(i,j)%mask_red)
+ NULLIFY(work_field(i,j)%mask_black)
NULLIFY(work_field(i,j)%bcvalue)
ENDDO
ENDDO
ENDIF
+
IF (lcopy) THEN
!---------------------------------------------------------------------
! Save the old contents
@@ -320,10 +327,13 @@
work_field(i,j)%uc => field(i,j)%uc
work_field(i,j)%fc => field(i,j)%fc
work_field(i,j)%err => field(i,j)%err
+ work_field(i,j)%mask_red => field(i,j)%mask_red
+ work_field(i,j)%mask_black => field(i,j)%mask_black
work_field(i,j)%bcvalue => field(i,j)%bcvalue
ENDDO
ENDDO
ENDIF
+
IF (ldealloc) THEN
!---------------------------------------------------------------------
! Deallocate the old contents
@@ -357,6 +367,24 @@
ENDIF
NULLIFY(field(i,j)%err)
ENDIF
+ IF (ASSOCIATED(field(i,j)%mask_red)) THEN
+ DEALLOCATE(field(i,j)%mask_red,STAT=info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_field',&
+ & 'MASK FIELD%MASK_RED',__LINE__,info)
+ ENDIF
+ NULLIFY(field(i,j)%mask_red)
+ ENDIF
+ IF (ASSOCIATED(field(i,j)%mask_black)) THEN
+ DEALLOCATE(field(i,j)%mask_black,STAT=info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_field',&
+ & 'MASK FIELD%MASK_BLACK',__LINE__,info)
+ ENDIF
+ NULLIFY(field(i,j)%mask_black)
+ ENDIF
IF (ASSOCIATED(field(i,j)%bcvalue)) THEN
DEALLOCATE(field(i,j)%bcvalue,STAT=info)
IF (info .NE. 0) THEN
@@ -369,6 +397,7 @@
ENDDO
ENDDO
ENDIF
+
IF (lrealloc) THEN
!---------------------------------------------------------------------
! Deallocate old pointer array
@@ -381,19 +410,20 @@
ENDIF
NULLIFY(field)
ENDIF
+
IF (lalloc) THEN
!---------------------------------------------------------------------
! Point result to new array
!---------------------------------------------------------------------
field => work_field
ENDIF
+
!-------------------------------------------------------------------------
! Return
!-------------------------------------------------------------------------
9999 CONTINUE
CALL substop('ppm_mg_alloc_field',t0,info)
RETURN
-
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -423,3 +453,5 @@
#endif
#endif
#endif
+
+
diff --git a/src/ppm_mg_finalize.f b/src/ppm_mg_finalize.f
index eeaf382..71e8ec3 100644
--- a/src/ppm_mg_finalize.f
+++ b/src/ppm_mg_finalize.f
@@ -197,8 +197,6 @@
iopt = ppm_param_dealloc
CALL ppm_alloc(start,lda3,iopt,info)
istat=istat+info
- CALL ppm_alloc(istop,lda3,iopt,info)
- istat=istat+info
CALL ppm_alloc(lboundary,lda2,iopt,info)
istat=istat+info
CALL ppm_alloc(max_node,lda2,iopt,info)
@@ -220,6 +218,15 @@
istat=istat+info
CALL ppm_mg_alloc(mgfield,lda2,iopt,info)
istat = istat +info
+#if __DIM == __SFIELD
+#if __MESH_DIM == __2D
+ CALL ppm_alloc(mask_dummy_2d,lda3,iopt,info)
+ istat=istat+info
+#elif __MESH_DIM == __3D
+ CALL ppm_alloc(mask_dummy_3d,lda4,iopt,info)
+ istat=istat+info
+#endif
+#endif
IF (istat .NE. 0) THEN
WRITE(mesg,'(A,I3,A)') 'for ',istat,' mgr arrays.Pble memory leak.'
info = ppm_error_error
diff --git a/src/ppm_mg_init.f b/src/ppm_mg_init.f
index ab1dae0..fafb138 100644
--- a/src/ppm_mg_init.f
+++ b/src/ppm_mg_init.f
@@ -1,1176 +1,1448 @@
- !------------------------------------------------------------------------
- ! Subroutine : ppm_mg_init
- !------------------------------------------------------------------------
- !
- ! Purpose : This routine initializes the solver for
- ! 2D and 3D problems
- !
- ! Input : equation (I) : KIND OF EQUATION TO BE SOLVED
- ! FOR THE MOMENT ONLY POISSON
- ! ighostsize (I) : GHOSTSIZE
- !
- ! smoother (I) : NOW GAUSS-SEIDEL
- !
- ! [lda] (I) : LEADING DIMENSION, ONLY TO BE
- ! GIVEN FOR VECTOR CASES
- !
- ! ibcdef (I) : ARRAY OF BOUNDARY CONDITION
- !
- !
- ! bcvalue (F) : ARRAY WHERE THE VALUES OF THE BC
- ! ARE STORED.IN CASE OF PERIODIC
- ! JUST GIVE ANY KIND OF VALUE
- !
- ! limlev (I) :Number of levels that the user
- ! wants to coarse.
- !
- ! wcycle (L) : TRUE if the user wants W-cycle.
- ! OTHERWISE FALSE
- ! lprint (L) : TRUE IF YOU WANT TO DUMP OUT
- ! INFORMATION
- !
- ! omega (F) : relaxation parameter for SOR
- !
- !
- ! Input/output :
- !
- ! Output : info (I) return status. 0 upon success.
- !
- ! Remarks : PLEASE PAY ATTENTION THAT IN ORDER TO DIVIDE
- ! FURTHER A MESH IT SHOULD BE DIVISIBLE WITH 2.
- ! IF YOU WANT TO SOLVE DIFFERENT EQUATIONS
- ! THE WHOLE MACHINERY SHOULD BE CALLED TWICE.
- ! ALSO THE SOLVER IS NOW PROGRAMMED FOR THE POISSON
- ! PROBLEM. A FUTURE IMPROVEMENT WOULD BE
- ! TO USE A GENERAL STENCIL.
- !
- ! References :
- !
- ! Revisions :
- !------------------------------------------------------------------------
- ! $Log: ppm_mg_init.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.17 2006/09/26 16:01:22 ivos
- ! Fixed wrongly indented CPP directives. Remember: they have to start in
- ! Col 1, otherwise it does not compile on certain systems. In fact, this
- ! code did NOT compile as it was!!
- !
- ! Revision 1.16 2006/09/05 08:01:27 pchatela
- ! Proper scaling for REAL comparisons
- ! Added module_alloc to ppm_decomp_boxsplit
- !
- ! Revision 1.15 2006/07/21 11:30:54 kotsalie
- ! FRIDAY
- !
- ! Revision 1.13 2006/06/08 08:38:18 kotsalie
- ! Cosmetics
- !
- ! Revision 1.12 2006/06/08 08:27:37 kotsalie
- ! changed bcvalue to support different BCs on the same face but different sub
- !
- ! Revision 1.8 2006/05/15 14:44:26 kotsalie
- ! cosmetics
- !
- ! Revision 1.7 2006/02/03 09:34:03 ivos
- ! Fixed bug 00015: ppm_subs_bc was only allocated and stored for the
- ! local subs in topo_store. Several mapping routines however need the
- ! info about all (global) subs.
- ! Changed subs_bc to hold now the GLOBAL subid and adjusted all
- ! occurrences.
- !
- ! Revision 1.6 2005/12/08 12:43:16 kotsalie
- ! commiting dirichlet
- !
- ! Revision 1.5 2005/01/04 09:47:45 kotsalie
- ! ghostsize=2 for scalar case
- !
- ! Revision 1.4 2004/10/29 15:59:14 kotsalie
- ! RED BLACK SOR FOR 3d vec case. 2d will soon follow.
- !
- ! Revision 1.3 2004/09/28 14:04:49 kotsalie
- ! Changes concerning 4th order finite differences
- !
- ! Revision 1.2 2004/09/23 09:38:30 kotsalie
- ! added details in the header
- !
- ! Revision 1.1 2004/09/22 18:27:09 kotsalie
- ! MG new version
- !
- !------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
+ !-------------------------------------------------------------------------
+ ! Subroutine : ppm_mg_init
+ !-------------------------------------------------------------------------
+ !
+ ! Purpose : This routine initializes the solver for
+ ! 2D and 3D problems
+ !
+ ! Input : equation (I) : KIND OF EQUATION TO BE SOLVED
+ ! FOR THE MOMENT ONLY POISSON
+ ! order (I) : ORDER OF FINITE DIFFERENCES
+ ! NOW SECOND. THE GHOSTSIZE IS
+ ! AUTOMATICALLY ADJUSTED
+ ! smoother (I) : NOW GAUSS-SEIDEL
+ !
+ ! [lda] (I) : LEADING DIMENSION, ONLY TO BE
+ ! GIVEN FOR VECTOR CASES
+ !
+ ! ibcdef (I) : ARRAY OF BOUNDARY CONDITION
+ !
+ !
+ ! bcvalue (F) : ARRAY WHERE THE VALUES OF THE BC
+ ! ARE STORED.IN CASE OF PERIODIC
+ ! JUST GIVE ANY KIND OF VALUE
+ !
+ ! EPSU (F) : STOPPING CRITERIUM. DETAIL:SHOULD
+ ! BE SCALED WITH THE MAXIMUM VALUE ! OF THE RHS.
+ !
+ ! limlev (I) :Number of levels that the user
+ ! wants to coarse.
+ !
+ ! wcycle (L) : TRUE if the user wants W-cycle.
+ ! OTHERWISE FALSE
+ ! lprint (L) : TRUE IF YOU WANT TO DUMP OUT
+ ! INFORMATION
+ !
+ ! omega (F) : relaxation parameter for SOR
+ !
+ !
+ ! Input/output :
+ !
+ ! Output : info (I) return status. 0 upon success.
+ !
+ ! Remarks : PLEASE PAY ATTENTION THAT IN ORDER TO DIVIDE
+ ! FURTHER A MESH IT SHOULD BE DIVISIBLE WITH 2.
+ ! IF YOU WANT TO SOLVE DIFFERENT EQUATIONS
+ ! THE WHOLE MACHINERY SHOULD BE CALLED TWICE.
+ ! ALSO THE SOLVER IS NOW PROGRAMMED FOR THE POISSON
+ ! PROBLEM. A FUTURE IMPROVEMENT WOULD BE
+ ! TO USE A GENERAL STENCIL.
+ !
+ ! References :
+ !
+ ! Revisions :
+ !-------------------------------------------------------------------------
+ ! $Log: ppm_mg_init.f,v $
+ ! Revision 1.2 2006/08/22 15:54:37 pchatela
+ ! Added a hopefully appropriate scaling factor in the comparisons against
+ ! lmyeps
+ !
+ ! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+ ! initial import
+ !
+ ! Revision 1.7 2006/02/03 09:34:03 ivos
+ ! Fixed bug 00015: ppm_subs_bc was only allocated and stored for the
+ ! local subs in topo_store. Several mapping routines however need the
+ ! info about all (global) subs.
+ ! Changed subs_bc to hold now the GLOBAL subid and adjusted all
+ ! occurrences.
+ !
+ ! Revision 1.6 2005/12/08 12:43:16 kotsalie
+ ! commiting dirichlet
+ !
+ ! Revision 1.5 2005/01/04 09:47:45 kotsalie
+ ! ghostsize=2 for scalar case
+ !
+ ! Revision 1.4 2004/10/29 15:59:14 kotsalie
+ ! RED BLACK SOR FOR 3d vec case. 2d will soon follow.
+ !
+ ! Revision 1.3 2004/09/28 14:04:49 kotsalie
+ ! Changes concerning 4th order finite differences
+ !
+ ! Revision 1.2 2004/09/23 09:38:30 kotsalie
+ ! added details in the header
+ !
+ ! Revision 1.1 2004/09/22 18:27:09 kotsalie
+ ! MG new version
+ !
+ !-------------------------------------------------------------------------
+ ! Parallel Particle Mesh Library (PPM)
+ ! Institute of Computational Science
+ ! ETH Zentrum, Hirschengraben 84
+ ! CH-8092 Zurich, Switzerland
+ !-------------------------------------------------------------------------
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_sca_s(ft,equation,ighostsize,smoother,ibcdef,&
- & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_2d_sca_s(topo_id,equation,iorder,smoother,ibcdef,&
+ & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_sca_d(ft,equation,ighostsize,smoother,ibcdef,&
- & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_2d_sca_d(topo_id,equation,iorder,smoother,ibcdef,&
+ & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_sca_s(ft,equation,ighostsize,smoother,ibcdef,&
- & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_3d_sca_s(topo_id,equation,iorder,smoother,ibcdef,&
+ & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_sca_d(ft,equation,ighostsize,smoother,ibcdef,&
- & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_3d_sca_d(topo_id,equation,iorder,smoother,ibcdef,&
+ & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_vec_s(ft,equation,ighostsize,smoother,lda,&
- & ibcdef,bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_2d_vec_s(topo_id,equation,iorder,smoother,lda,ibcdef,&
+ & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_vec_d(ft,equation,ighostsize,smoother,lda,&
- & ibcdef,bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_2d_vec_d(topo_id,equation,iorder,smoother,lda,ibcdef,&
+ & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_vec_s(ft,equation,ighostsize,smoother,lda,&
- & ibcdef,bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_3d_vec_s(topo_id,equation,iorder,smoother,lda,ibcdef,&
+ & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_vec_d(ft,equation,ighostsize,smoother,lda,&
- & ibcdef,bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_3d_vec_d(topo_id,equation,iorder,smoother,lda,ibcdef,&
+ & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
#endif
#endif
#endif
- !----------------------------------------------------------------------
- ! Includes
- !----------------------------------------------------------------------
+
+ !----------------------------------------------------------------------
+ ! Includes
+ !----------------------------------------------------------------------
#include "ppm_define.h"
- !----------------------------------------------------------------------
- ! Modules
- !----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mesh
- USE ppm_module_data_mg
- USE ppm_module_mg_alloc
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
+
+ !-----------------------------------------------------------------------
+ ! Modules
+ !-----------------------------------------------------------------------
+ USE ppm_module_data
+ USE ppm_module_data_mesh
+ USE ppm_module_data_mg
+ USE ppm_module_alloc
+ USE ppm_module_mg_alloc
+ USE ppm_module_error
+ USE ppm_module_mesh_derive
+ USE ppm_module_substart
+ USE ppm_module_substop
+ USE ppm_module_typedef
+
+ IMPLICIT NONE
#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
+ INTEGER, PARAMETER :: MK = ppm_kind_single
#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
+ INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
- !----------------------------------------------------------------------
- ! Arguments
- !----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: equation
- INTEGER,DIMENSION(:),INTENT(IN) :: ighostsize
- INTEGER, INTENT(IN) :: smoother
- ! field topoid
- INTEGER, INTENT(IN) :: ft
-
+ !-----------------------------------------------------------------------
+ ! Arguments
+ !-----------------------------------------------------------------------
+ INTEGER, INTENT(IN) :: equation
+ INTEGER, INTENT(IN) :: iorder
+ INTEGER, INTENT(IN) :: smoother
#if __DIM == __VFIELD
- INTEGER, INTENT(IN) :: lda
+ INTEGER, INTENT(IN) :: lda
#endif
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- INTEGER,DIMENSION(:) :: ibcdef
- REAL(MK),DIMENSION(:,:,:) :: bcvalue
+ INTEGER,DIMENSION(:) :: ibcdef
+ REAL(MK),DIMENSION(:,:) :: bcvalue
#elif __MESH_DIM == __3D
- INTEGER,DIMENSION(:) :: ibcdef
- REAL(MK),DIMENSION(:,:,:,:) :: bcvalue
+ INTEGER,DIMENSION(:) :: ibcdef
+ REAL(MK),DIMENSION(:,:,:) :: bcvalue
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- INTEGER,DIMENSION(:,:) :: ibcdef
- REAL(MK),DIMENSION(:,:,:,:) :: bcvalue
+ INTEGER,DIMENSION(:,:) :: ibcdef
+ REAL(MK),DIMENSION(:,:,:) :: bcvalue
#elif __MESH_DIM == __3D
- INTEGER,DIMENSION(:,:) :: ibcdef
- REAL(MK),DIMENSION(:,:,:,:,:) :: bcvalue
+ INTEGER,DIMENSION(:,:) :: ibcdef
+ REAL(MK),DIMENSION(:,:,:,:) :: bcvalue
#endif
#endif
- INTEGER, INTENT(IN) :: mesh_id
- INTEGER,INTENT(IN) :: limlev
- LOGICAL,INTENT(IN) :: wcycle
- LOGICAL,INTENT(IN) :: lprint
- REAL(MK),INTENT(IN) :: omega
- INTEGER, INTENT(OUT) :: info
- !----------------------------------------------------------------------
- ! Local variables
- !----------------------------------------------------------------------
- REAL(MK) :: t0
- REAL(MK) :: lmyeps
- INTEGER :: meshid,mlev,isub
- INTEGER :: idom
- INTEGER :: count,ilda,iface
- INTEGER :: i,j,k
- INTEGER :: kk
+
+ INTEGER, INTENT(IN) :: mesh_id,topo_id
+ REAL(MK),INTENT(IN) :: EPSU
+ INTEGER,INTENT(IN) :: limlev
+ LOGICAL,INTENT(IN) :: wcycle
+ LOGICAL,INTENT(IN) :: lprint
+ REAL(MK),INTENT(IN) :: omega
+ INTEGER, INTENT(OUT) :: info
+ !--------------------------------------------------------------------
+ ! Local variables
+ !-----------------------------------------------------------------------
+ REAL(MK) :: t0
+ REAL(MK) :: lmyeps
+ INTEGER :: meshid,mlev,isub
+ INTEGER :: idom
+ INTEGER :: count,ilda,iface
+ INTEGER :: i,j,k
+ INTEGER :: kk
+ TYPE(ppm_t_topo), POINTER :: topo
+ TYPE(ppm_t_equi_mesh), POINTER :: mesh
#if __MESH_DIM == __2D
- INTEGER :: dir
+ INTEGER :: dir
#endif
- INTEGER :: iter1,iter2,ix,iy
- INTEGER :: ipoint,jpoint
- INTEGER :: newmeshid,lmesh_id
- INTEGER , DIMENSION(1) :: ldu1
- INTEGER , DIMENSION(2) :: ldu2,ldl2 ,direc
- INTEGER , DIMENSION(3) :: ldu3,ldl3
+ INTEGER :: iter1,iter2,ix,iy
+ INTEGER :: ipoint,jpoint
+ INTEGER :: newmeshid,lmesh_id
+ INTEGER , DIMENSION(1) :: ldu1
+ INTEGER , DIMENSION(2) :: ldu2,ldl2 ,direc
+ INTEGER , DIMENSION(3) :: ldu3,ldl3
#if __MESH_DIM == __3D
- INTEGER :: dir1,dir2,jj,iz
- INTEGER , DIMENSION(4) :: ldu4,ldl4
+ INTEGER :: dir1,dir2,jj,iz
+ INTEGER , DIMENSION(4) :: ldu4,ldl4
#endif
- INTEGER , DIMENSION(ppm_dim) :: Nml
- REAL(MK), DIMENSION(ppm_dim) :: min_phys,max_phys
- REAL(MK), DIMENSION(ppm_dim,ppm_topo(ft)%t%nsubs) &
- & :: min_sub,max_sub
- INTEGER :: iopt,topoid
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
+ INTEGER , DIMENSION(ppm_dim) :: Nml
+ REAL(MK), DIMENSION(ppm_dim) :: min_phys,max_phys
+ REAL(MK), DIMENSION(ppm_dim,ppm_topo(topo_id)%t%nsubs) &
+ & :: min_sub,max_sub
+ INTEGER :: iopt,topoid
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#endif
#endif
+
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:),POINTER :: terr
+REAL(MK),DIMENSION(:,:),POINTER :: tuc
+REAL(MK),DIMENSION(:,:),POINTER :: terr
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:,:),POINTER :: terr
+REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
+REAL(MK),DIMENSION(:,:,:),POINTER :: terr
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:,:),POINTER :: terr
+REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
+REAL(MK),DIMENSION(:,:,:),POINTER :: terr
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: terr
+REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc
+REAL(MK),DIMENSION(:,:,:,:),POINTER :: terr
#endif
#endif
- !----------------------------------------------------------------------
- ! Externals
- !----------------------------------------------------------------------
- !----------------------------------------------------------------------
- ! Initialize
- !----------------------------------------------------------------------
- CALL substart('ppm_mg_init',t0,info)
- topo => ppm_topo(ft)%t
- mesh => topo%mesh(mesh_id)
- !----------------------------------------------------------------------
- ! Check arguments
- !----------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
+
+ !-----------------------------------------------------------------------
+ ! Externals
+ !-----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! Initialize
+ !-----------------------------------------------------------------------
+
+ CALL substart('ppm_mg_init',t0,info)
+
+
+ !-----------------------------------------------------------------------
+ ! Check arguments
+ !-----------------------------------------------------------------------
+ IF (ppm_debug.GT.0) THEN
#if __DIM == __VFIELD
- IF (lda.LE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_poiss_mg_init', &
- & 'lda must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
+ IF (lda.LE.0) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_poiss_mg_init', &
+ & 'lda must be >0',__LINE__,info)
+ GOTO 9999
+ ENDIF
#endif
- ENDIF
- !----------------------------------------------------------------------
- ! Definition of necessary variables and allocation of arrays
- !----------------------------------------------------------------------
+ IF (EPSU.LE.0.0_MK) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_poiss_mg_init', &
+ & 'EPSU must be >0',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ ENDIF
+
+ !---------------------------------------------------------------------
+ ! Definition of necessary variables and allocation of arrays
+ !---------------------------------------------------------------------
#if __DIM == __SFIELD
- vecdim = 1
+ vecdim = 1
#elif __DIM == __VFIELD
- vecdim = lda
+ vecdim = lda
#endif
- w_cycle=wcycle
- l_print=lprint
+ w_cycle=wcycle
+ l_print=lprint
+
+ topoid = topo_id
+ topo => ppm_topo(topo_id)%t
+ mesh => topo%mesh(mesh_id)
+ nsubs = topo%nsublist
+ !PRINT *,'nsub:',nsubs
+ meshid = mesh%ID
+ lmesh_id = mesh_id
- topoid = ft
- nsubs = topo%nsublist
- meshid = mesh%ID
- lmesh_id = mesh_id
+
#if __KIND == __SINGLE_PRECISION
- min_phys(:)=topo%min_physs(:)
- max_phys(:)=topo%max_physs(:)
- min_sub = topo%min_subs
- max_sub = topo%max_subs
- omega_s=omega
- lmyeps=ppm_myepss
+ min_phys(:)=topo%min_physs(:)
+ max_phys(:)=topo%max_physs(:)
+ min_sub(:,:)=topo%min_subs(:,:)
+ max_sub(:,:)=topo%max_subs(:,:)
+ EPSU_s = EPSU
+ omega_s=omega
+ lmyeps=ppm_myepss
#elif __KIND == __DOUBLE_PRECISION
- min_phys(:)=topo%min_physd(:)
- max_phys(:)=topo%max_physd(:)
- min_sub = topo%min_subd
- max_sub = topo%max_subd
- omega_d=omega
- lmyeps=ppm_myepsd
+ min_phys(:)=topo%min_physd(:)
+ max_phys(:)=topo%max_physd(:)
+ min_sub(:,:)=topo%min_subd(:,:)
+ max_sub(:,:)=topo%max_subd(:,:)
+ EPSU_d = EPSU
+ omega_d=omega
+ lmyeps=ppm_myepsd
#endif
#if __MESH_DIM == __2D
- Nml(1) = mesh%Nm(1)
- Nml(2) = mesh%Nm(2)
- maxlev = INT(log10(Nml(1)*Nml(2)*REAL(ppm_nproc,MK))/log10(2.0_MK))
- IF (maxlev.GT.limlev) THEN
- maxlev=limlev
- ENDIF
+ Nml(1) = mesh%Nm(1)
+ Nml(2) = mesh%Nm(2)
+ maxlev = INT(log10(Nml(1)*Nml(2)*REAL(ppm_nproc,MK))/log10(2.0_MK))
+ IF (maxlev.GT.limlev) THEN
+ maxlev=limlev
+ ENDIF
#if __KIND == __SINGLE_PRECISION
- dx_s = (max_phys(1)-min_phys(1))/REAL((Nml(1)-1),MK)
- dy_s = (max_phys(2)-min_phys(2))/REAL((Nml(2)-1),MK)
- rdx2_s = 1.0_MK/(dx_s*dx_s)
- rdy2_s = 1.0_MK/(dy_s*dy_s)
+ dx_s = (max_phys(1)-min_phys(1))/(Nml(1)-1)
+ dy_s = (max_phys(2)-min_phys(2))/(Nml(2)-1)
+ rdx2_s = 1/(dx_s*dx_s)
+ rdy2_s = 1/(dy_s*dy_s)
#elif __KIND == __DOUBLE_PRECISION
- dx_d = (max_phys(1)-min_phys(1))/REAL((Nml(1)-1),MK)
- dy_d = (max_phys(2)-min_phys(2))/REAL((Nml(2)-1),MK)
+ dx_d = (max_phys(1)-min_phys(1))/(Nml(1)-1)
+ dy_d = (max_phys(2)-min_phys(2))/(Nml(2)-1)
- rdx2_d = 1.0_MK/(dx_d*dx_d)
- rdy2_d = 1.0_MK/(dy_d*dy_d)
+ rdx2_d = 1/(dx_d*dx_d)
+ rdy2_d = 1/(dy_d*dy_d)
#endif
#elif __MESH_DIM == __3D
- Nml(1) = mesh%Nm(1)
- Nml(2) = mesh%Nm(2)
- Nml(3) = mesh%Nm(3)
- maxlev = INT(log10(Nml(1)*Nml(2)*Nml(3)* &
- & REAL(ppm_nproc,MK))/log10(2.0_MK))
-
- IF (maxlev.GT.limlev) THEN
- maxlev=limlev
- ENDIF
+ Nml(1) = mesh%Nm(1)
+ Nml(2) = mesh%Nm(2)
+ Nml(3) = mesh%Nm(3)
+ maxlev = INT(log10(Nml(1)*Nml(2)*Nml(3)* &
+ & REAL(ppm_nproc,MK))/log10(2.0_MK))
+
+ IF (maxlev.GT.limlev) THEN
+ maxlev=limlev
+ ENDIF
#if __KIND == __SINGLE_PRECISION
- dx_s = (max_phys(1)-min_phys(1))/REAL((Nml(1)-1),MK)
- dy_s = (max_phys(2)-min_phys(2))/REAL((Nml(2)-1),MK)
- dz_s = (max_phys(3)-min_phys(3))/REAL((Nml(3)-1),MK)
- rdx2_s = 1.0_MK/(dx_s*dx_s)
- rdy2_s = 1.0_MK/(dy_s*dy_s)
- rdz2_s = 1.0_MK/(dz_s*dz_s)
+ dx_s = (max_phys(1)-min_phys(1))/(Nml(1)-1)
+ dy_s = (max_phys(2)-min_phys(2))/(Nml(2)-1)
+ dz_s = (max_phys(3)-min_phys(3))/(Nml(3)-1)
+ rdx2_s = 1/(dx_s*dx_s)
+ rdy2_s = 1/(dy_s*dy_s)
+ rdz2_s = 1/(dz_s*dz_s)
#elif __KIND == __DOUBLE_PRECISION
- dx_d = (max_phys(1)-min_phys(1))/REAL((Nml(1)-1),MK)
- dy_d = (max_phys(2)-min_phys(2))/REAL((Nml(2)-1),MK)
- dz_d = (max_phys(3)-min_phys(3))/REAL((Nml(3)-1),MK)
- rdx2_d = 1.0_MK/(dx_d*dx_d)
- rdy2_d = 1.0_MK/(dy_d*dy_d)
- rdz2_d = 1.0_MK/(dz_d*dz_d)
+ dx_d = (max_phys(1)-min_phys(1))/(Nml(1)-1)
+ dy_d = (max_phys(2)-min_phys(2))/(Nml(2)-1)
+ dz_d = (max_phys(3)-min_phys(3))/(Nml(3)-1)
+ rdx2_d = 1/(dx_d*dx_d)
+ rdy2_d = 1/(dy_d*dy_d)
+ rdz2_d = 1/(dz_d*dz_d)
#endif
#endif
+
+
#if __DIM == __SFIELD
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = 2*ppm_dim
- CALL ppm_alloc(bcdef_sca,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Boundary condiotions',__LINE__,info)
- GOTO 9999
+!Print *,'SField'
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = 2*ppm_dim
+ CALL ppm_alloc(bcdef_sca,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Boundary condiotions',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ bcdef_sca(:,:)=0
+
+ !---------------------------------------------------------
+ !MICHAEL
+ !--------------------------------------------------------
+ DO isub=1,nsubs
+ idom=topo%isublist(isub)
+ !----------------------------------------------------------------------
+ ! compare the west boundary
+ !----------------------------------------------------------------------
+ IF (ABS(min_sub(1,idom)-min_phys(1)) .LT. lmyeps*(max_sub(1,i)-min_sub(1,i))) THEN
+ bcdef_sca(isub,1)=ibcdef(1)
ENDIF
- bcdef_sca(:,:)=0
- DO isub=1,nsubs
- idom=ppm_topo(topoid)%t%isublist(isub)
- !---------------------------------------------------------------------
- ! compare the west boundary
- !---------------------------------------------------------------------
- IF (ABS(min_sub(1,idom)-min_phys(1)) .LT. &
- & lmyeps*(max_sub(1,i)-min_sub(1,i))) THEN
- bcdef_sca(isub,1)=ibcdef(1)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the east boundary
- !---------------------------------------------------------------------
- IF (ABS(max_sub(1,idom)-max_phys(1)) .LT. &
- & lmyeps*(max_sub(1,i)-min_sub(1,i))) THEN
- bcdef_sca(isub,2)=ibcdef(2)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the south boundary
- !---------------------------------------------------------------------
- IF (ABS(min_sub(2,idom)-min_phys(2)) .LT. &
- & lmyeps*(max_sub(2,i)-min_sub(2,i))) THEN
- bcdef_sca(isub,3)=ibcdef(3)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the north boundary
- !---------------------------------------------------------------------
- IF (ABS(max_sub(2,idom)-max_phys(2)) .LT. &
- & lmyeps*(max_sub(2,i)-min_sub(2,i))) THEN
- bcdef_sca(isub,4)=ibcdef(4)
- ENDIF
- !-----------------------------------------------------------------
- ! compare the south boundary
- !---------------------------------------------------------------------
-#if __MESH_DIM == __3D
- IF (ABS(min_sub(3,idom)-min_phys(3)) .LT. &
- & lmyeps*(max_sub(3,i)-min_sub(3,i))) THEN
- bcdef_sca(isub,5)=ibcdef(5)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the north boundary
- !---------------------------------------------------------------------
- IF (ABS(max_sub(3,idom)-max_phys(3)) .LT. &
- & lmyeps*(max_sub(3,i)-min_sub(3,i))) THEN
- bcdef_sca(isub,6)=ibcdef(6)
- ENDIF
-#endif
+
+ !----------------------------------------------------------------------
+ ! compare the east boundary
+ !----------------------------------------------------------------------
+ IF (ABS(max_sub(1,idom)-max_phys(1)) .LT. lmyeps*(max_sub(1,i)-min_sub(1,i))) THEN
+ bcdef_sca(isub,2)=ibcdef(2)
+ ENDIF
+
+ !----------------------------------------------------------------------
+ ! compare the south boundary
+ !----------------------------------------------------------------------
+ IF (ABS(min_sub(2,idom)-min_phys(2)) .LT. lmyeps*(max_sub(2,i)-min_sub(2,i))) THEN
+ bcdef_sca(isub,3)=ibcdef(3)
+ ENDIF
+
+ !----------------------------------------------------------------------
+ ! compare the north boundary
+ !----------------------------------------------------------------------
+ IF (ABS(max_sub(2,idom)-max_phys(2)) .LT. lmyeps*(max_sub(2,i)-min_sub(2,i))) THEN
+ bcdef_sca(isub,4)=ibcdef(4)
+ ENDIF
+ !----------------------------------------------------------------------
+ ! compare the south boundary
+ !----------------------------------------------------------------------
+ IF (ABS(min_sub(3,idom)-min_phys(3)) .LT. lmyeps*(max_sub(3,i)-min_sub(3,i))) THEN
+ bcdef_sca(isub,5)=ibcdef(5)
+ ENDIF
+
+ !----------------------------------------------------------------------
+ ! compare the north boundary
+ !----------------------------------------------------------------------
+ IF (ABS(max_sub(3,idom)-max_phys(3)) .LT. lmyeps*(max_sub(3,i)-min_sub(3,i))) THEN
+ bcdef_sca(isub,6)=ibcdef(6)
+ ENDIF
+ ENDDO
+ lperiodic=.TRUE.
+
+ DO isub=1,nsubs
+ DO i=1,2*ppm_dim
+ IF (bcdef_sca(isub,i).NE.ppm_param_bcdef_periodic) THEN
+ lperiodic=.FALSE.
+ EXIT
+ ENDIF
ENDDO
- lperiodic=.TRUE.
- DO isub=1,nsubs
- DO i=1,2*ppm_dim
- IF (bcdef_sca(isub,i).NE.ppm_param_bcdef_periodic) THEN
- lperiodic=.FALSE.
- EXIT
- ENDIF
- ENDDO
- ENDDO
+ ENDDO
+
#elif __DIM == __VFIELD
- iopt = ppm_param_alloc_fit
- ldu3(1) = vecdim
- ldu3(2) = nsubs
- ldu3(3) = 2*ppm_dim
- CALL ppm_alloc(bcdef_vec,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Boundary condiotions',__LINE__,info)
- GOTO 9999
- ENDIF
- bcdef_vec(:,:,:)=0
- DO isub=1,nsubs
- idom=ppm_topo(topoid)%t%isublist(isub)
- DO ilda=1,vecdim
- !------------------------------------------------------------------
- ! compare the west boundary
- !---------------------------------------------------------------------
- IF (ABS(min_sub(1,idom)-min_phys(1)) .LT. &
- & lmyeps*(max_sub(1,i)-min_sub(1,i))) THEN
- bcdef_vec(ilda,isub,1)=ibcdef(ilda,1)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the east boundary
- !---------------------------------------------------------------------
- IF (ABS(max_sub(1,idom)-max_phys(1)) .LT. &
- & lmyeps*(max_sub(1,i)-min_sub(1,i))) THEN
- bcdef_vec(ilda,isub,2)=ibcdef(ilda,2)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the south boundary
- !---------------------------------------------------------------------
- IF (ABS(min_sub(2,idom)-min_phys(2)) .LT. &
- & lmyeps*(max_sub(2,i)-min_sub(2,i))) THEN
- bcdef_vec(ilda,isub,3)=ibcdef(ilda,3)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the north boundary
- !---------------------------------------------------------------------
- IF (ABS(max_sub(2,idom)-max_phys(2)) .LT. &
- & lmyeps*(max_sub(2,i)-min_sub(2,i))) THEN
- bcdef_vec(ilda,isub,4)=ibcdef(ilda,4)
- ENDIF
-#if __MESH_DIM == __3D
- !-----------------------------------------------------------------
- ! compare the south boundary
- !---------------------------------------------------------------------
- IF (ABS(min_sub(3,idom)-min_phys(3)) .LT. &
- & lmyeps*(max_sub(3,i)-min_sub(3,i))) THEN
- bcdef_vec(ilda,isub,5)=ibcdef(ilda,5)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the north boundary
- !---------------------------------------------------------------------
- IF (ABS(max_sub(3,idom)-max_phys(3)) .LT. &
- & lmyeps*(max_sub(3,i)-min_sub(3,i))) THEN
- bcdef_vec(ilda,isub,6)=ibcdef(ilda,6)
- ENDIF
-#endif
- enddo
- enddo
- lperiodic=.TRUE.
- Do isub=1,nsubs
- DO i=1,2*ppm_dim
- DO ilda=1,vecdim
- IF (bcdef_vec(ilda,isub,i).NE.ppm_param_bcdef_periodic) Then
- lperiodic=.FALSE.
- EXIT
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-#endif
- !------------------------------------------------------------------------------
- !Allocation of the ghostsize
- !------------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu1(1) = ppm_dim
- CALL ppm_alloc(ghostsize,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'ghostsize',__LINE__,info)
- GOTO 9999
+!print *,'Vfiedl'
+ iopt = ppm_param_alloc_fit
+ ldu3(1) = vecdim
+ ldu3(2) = nsubs
+ ldu3(3) = 2*ppm_dim
+ CALL ppm_alloc(bcdef_vec,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Boundary condiotions',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ bcdef_vec(:,:,:)=0
+ Do isub=1,nsubs
+ idom=topo%isublist(isub)
+ Do ilda=1,vecdim
+
+ !----------------------------------------------------------------------
+ ! compare the west boundary
+ !----------------------------------------------------------------------
+ IF (ABS(min_sub(1,idom)-min_phys(1)) .LT. lmyeps*(max_sub(1,i)-min_sub(1,i))) THEN
+ bcdef_vec(ilda,isub,1)=ibcdef(ilda,1)
ENDIF
- ghostsize=ighostsize
- !----------------------------------------------------------------------------
- !ALLOCATIION OF THE FACTOR FOR COARSENING (LATER SET TO 2))
- !----------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu1(1) = ppm_dim
- CALL ppm_alloc(factor,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'factor',__LINE__,info)
- GOTO 9999
+
+ !----------------------------------------------------------------------
+ ! compare the east boundary
+ !----------------------------------------------------------------------
+ IF (ABS(max_sub(1,idom)-max_phys(1)) .LT. lmyeps*(max_sub(1,i)-min_sub(1,i))) THEN
+ bcdef_vec(ilda,isub,2)=ibcdef(ilda,2)
ENDIF
- !----------------------------------------------------------------------------
- !INTERNAL IDS FOR MESHES
- !----------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu1(1) = maxlev
- CALL ppm_alloc(meshid_g,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'meshid_g',__LINE__,info)
- GOTO 9999
+
+ !----------------------------------------------------------------------
+ ! compare the south boundary
+ !----------------------------------------------------------------------
+ IF (ABS(min_sub(2,idom)-min_phys(2)) .LT. lmyeps*(max_sub(2,i)-min_sub(2,i))) THEN
+ bcdef_vec(ilda,isub,3)=ibcdef(ilda,3)
ENDIF
- !----------------------------------------------------------------------------
- !USER IDS FOR MESHES
- !----------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu1(1) = maxlev
- CALL ppm_alloc(mesh_id_g,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'mesh_id_g',__LINE__,info)
- GOTO 9999
+
+ !----------------------------------------------------------------------
+ ! compare the north boundary
+ !----------------------------------------------------------------------
+ IF (ABS(max_sub(2,idom)-max_phys(2)) .LT. lmyeps*(max_sub(2,i)-min_sub(2,i))) THEN
+ bcdef_vec(ilda,isub,4)=ibcdef(ilda,4)
ENDIF
- iopt = ppm_param_alloc_fit
- ldu3(1) = ppm_dim
- ldu3(2) = nsubs
- ldu3(3) = maxlev
- CALL ppm_alloc(start,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'starting indices when updating the field',__LINE__,info)
- GOTO 9999
+ !----------------------------------------------------------------------
+ ! compare the south boundary
+ !----------------------------------------------------------------------
+ IF (ABS(min_sub(3,idom)-min_phys(3)) .LT. lmyeps*(max_sub(3,i)-min_sub(3,i))) THEN
+ bcdef_vec(ilda,isub,5)=ibcdef(ilda,5)
ENDIF
- iopt = ppm_param_alloc_fit
- ldu3(1) = ppm_dim
- ldu3(2) = nsubs
- ldu3(3) = maxlev
- CALL ppm_alloc(istop,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'istopping indices when updating the field',__LINE__,info)
- GOTO 9999
+
+ !----------------------------------------------------------------------
+ ! compare the north boundary
+ !----------------------------------------------------------------------
+ IF (ABS(max_sub(3,idom)-max_phys(3)) .LT. lmyeps*(max_sub(3,i)-min_sub(3,i))) THEN
+ bcdef_vec(ilda,isub,6)=ibcdef(ilda,6)
ENDIF
+ enddo
+ enddo
+ lperiodic=.TRUE.
+ Do isub=1,nsubs
+ DO i=1,2*ppm_dim
+ DO ilda=1,vecdim
+ IF (bcdef_vec(ilda,isub,i).NE.ppm_param_bcdef_periodic) Then
+ lperiodic=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+#endif
+
+
+ iopt = ppm_param_alloc_fit
+ ldu1(1) = ppm_dim
+ CALL ppm_alloc(ghostsize,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'ghostsize',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ IF (iorder.EQ.ppm_param_order_2) THEN
+ ghostsize(:)=1
+ order=iorder
+ ELSEIF (iorder.EQ.ppm_param_order_4) THEN
+ ghostsize(:)=2
+ order=ppm_param_order_4
+ ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldu1(1) = ppm_dim
+ CALL ppm_alloc(factor,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'factor',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldu1(1) = maxlev
+ CALL ppm_alloc(meshid_g,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'meshid_g',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldu1(1) = maxlev
+ CALL ppm_alloc(mesh_id_g,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'mesh_id_g',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldu3(1) = ppm_dim
+ ldu3(2) = nsubs
+ ldu3(3) = maxlev
+ CALL ppm_alloc(start,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'starting indices when updating the field',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+ iopt = ppm_param_alloc_fit
+ ldu3(1) = ppm_dim
+ ldu3(2) = nsubs
+ ldu3(3) = maxlev
+ CALL ppm_alloc(stop,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'stopping indices when updating the field',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = maxlev
- CALL ppm_mg_alloc(mgfield_2d_sca_s,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Multigrid fields used on the different levels',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield => mgfield_2d_sca_s
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = maxlev
+ CALL ppm_mg_alloc(mgfield_2d_sca_s,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Multigrid fields used on the different levels',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ mgfield => mgfield_2d_sca_s
+
#elif __KIND == __DOUBLE_PRECISION
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = maxlev
- CALL ppm_mg_alloc(mgfield_2d_sca_d,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Multigrid fields used on the different levels',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield => mgfield_2d_sca_d
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = maxlev
+ CALL ppm_mg_alloc(mgfield_2d_sca_d,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Multigrid fields used on the different levels',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ mgfield => mgfield_2d_sca_d
#endif
+
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = maxlev
- CALL ppm_mg_alloc(mgfield_3d_sca_s,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Multigrid fields used on the different levels',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield => mgfield_3d_sca_s
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = maxlev
+ CALL ppm_mg_alloc(mgfield_3d_sca_s,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Multigrid fields used on the different levels',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ mgfield => mgfield_3d_sca_s
+
#elif __KIND == __DOUBLE_PRECISION
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = maxlev
- CALL ppm_mg_alloc(mgfield_3d_sca_d,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Multigrid fields used on the different levels',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield => mgfield_3d_sca_d
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = maxlev
+ CALL ppm_mg_alloc(mgfield_3d_sca_d,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Multigrid fields used on the different levels',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ mgfield => mgfield_3d_sca_d
+
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = maxlev
- CALL ppm_mg_alloc(mgfield_2d_vec_s,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Multigrid fields used on the different levels',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield => mgfield_2d_vec_s
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = maxlev
+ CALL ppm_mg_alloc(mgfield_2d_vec_s,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Multigrid fields used on the different levels',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ mgfield => mgfield_2d_vec_s
+
#elif __KIND == __DOUBLE_PRECISION
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = maxlev
- CALL ppm_mg_alloc(mgfield_2d_vec_d,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Multigrid fields used on the different levels',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield => mgfield_2d_vec_d
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = maxlev
+ CALL ppm_mg_alloc(mgfield_2d_vec_d,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Multigrid fields used on the different levels',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ mgfield => mgfield_2d_vec_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = maxlev
- CALL ppm_mg_alloc(mgfield_3d_vec_s,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Multigrid fields used on the different levels',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield => mgfield_3d_vec_s
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = maxlev
+ CALL ppm_mg_alloc(mgfield_3d_vec_s,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Multigrid fields used on the different levels',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ mgfield => mgfield_3d_vec_s
+
#elif __KIND == __DOUBLE_PRECISION
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = maxlev
- CALL ppm_mg_alloc(mgfield_3d_vec_d,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Multigrid fields used on the different levels',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield => mgfield_3d_vec_d
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = nsubs
+ ldu2(2) = maxlev
+ CALL ppm_mg_alloc(mgfield_3d_vec_d,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Multigrid fields used on the different levels',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ mgfield => mgfield_3d_vec_d
+
#endif
#endif
#endif
- iopt = ppm_param_alloc_fit
- ldu2(1) = 2*ppm_dim
- ldu2(2) = nsubs
- CALL ppm_alloc(lboundary,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the boundary alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- iopt = ppm_param_alloc_fit
- ldu2(1) = ppm_dim
- ldu2(2) = maxlev
- CALL ppm_alloc(max_node,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with a maximum number alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- max_node(:,:)=0
- lboundary(:,:)=.FALSE.
- start(:,:,:)=1
- !----------------------------------------------------------------------
- ! Derive coarser meshes
- !----------------------------------------------------------------------
+
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = 2*ppm_dim
+ ldu2(2) = nsubs
+ CALL ppm_alloc(lboundary,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the boundary alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = ppm_dim
+ ldu2(2) = maxlev
+ CALL ppm_alloc(max_node,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with a maximum number alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ max_node(:,:)=0
+
+ lboundary(:,:)=.FALSE.
+ start(:,:,:)=1
+
+
+ !-----------------------------------------------------------------------
+ ! Derive coarser meshes
+ !-----------------------------------------------------------------------
+
DO mlev=1,maxlev
+
+
#if __MESH_DIM == __2D
- !-------------------------------------------------------------------
- ! Go through the subs, define the istopping indices on each mesh,
- ! check and store if it is on the boundary, allocate the
- ! multigrid fields, pass the boundary values.
- !-------------------------------------------------------------------
- DO i=1,nsubs
+
+ !--------------------------------------------------------------------
+ ! Go through the subs, define the stopping indices on each mesh,
+ ! check and store if it is on the boundary, allocate the
+ ! multigrid fields, pass the boundary values.
+ !--------------------------------------------------------------------
+ DO i=1,nsubs
idom=topo%isublist(i)
- istop(:,i,mlev)= mesh%nnodes(:,idom)
+
+ stop(:,i,mlev)= mesh%nnodes(:,idom)
+
DO j=1,ppm_dim
- IF (max_node(j,mlev).LT.istop(j,i,mlev)) THEN
- max_node(j,mlev)=istop(j,i,mlev)
+ IF (max_node(j,mlev).LT.stop(j,i,mlev)) THEN
+ max_node(j,mlev)=stop(j,i,mlev)
ENDIF
ENDDO
- !----------------------------------------------------------------
- ! Allocate the function correction, the restricted errors,
- ! the residuals and the values on the boundary on each level.
- !----------------------------------------------------------------
+
+
+ !-----------------------------------------------------------------
+ ! Allocate the function correction, the restricted errors,
+ ! the residuals and the values on the boundary on each level.
+ !----------------------------------------------------------------
#if __DIM == __SFIELD
- iopt = ppm_param_alloc_fit
- ldl2(1) = 1-ghostsize(1)
- ldl2(2) = 1-ghostsize(2)
- ldu2(1) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu2(2) = mesh%nnodes(2,idom)+ghostsize(2)
- CALL ppm_alloc(mgfield(i,mlev)%uc,ldl2,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the function corr. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- tuc=>mgfield(i,mlev)%uc
- tuc=0.0_MK
- iopt = ppm_param_alloc_fit
- ldu2(1) = mesh%nnodes(1,idom)
- ldu2(2) = mesh%nnodes(2,idom)
- CALL ppm_alloc(mgfield(i,mlev)%fc,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the restricted err. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
+ iopt = ppm_param_alloc_fit
+ ldl2(1) = 1-ghostsize(1)
+ ldl2(2) = 1-ghostsize(2)
+ ldu2(1) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu2(2) = mesh%nnodes(2,idom)+ghostsize(2)
+ CALL ppm_alloc(mgfield(i,mlev)%uc,ldl2,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the function corr. alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ tuc=>mgfield(i,mlev)%uc
+ tuc(:,:)=0.0_MK
+
+ iopt = ppm_param_alloc_fit
+ ldu2(1) = mesh%nnodes(1,idom)
+ ldu2(2) = mesh%nnodes(2,idom)
+ CALL ppm_alloc(mgfield(i,mlev)%fc,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the restricted err. alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
mgfield(i,mlev)%fc(:,:)=0.0_MK
- iopt = ppm_param_alloc_fit
- ldl2(1) = 1-ghostsize(1)
- ldl2(2) = 1-ghostsize(2)
- ldu2(1) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu2(2) = mesh%nnodes(2,idom)+ghostsize(2)
- CALL ppm_alloc(mgfield(i,mlev)%err,ldl2,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the residual alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- terr=>mgfield(i,mlev)%err
- terr(:,:)=0.0_MK
+
+ iopt = ppm_param_alloc_fit
+ ldl2(1) = 1-ghostsize(1)
+ ldl2(2) = 1-ghostsize(2)
+ ldu2(1) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu2(2) = mesh%nnodes(2,idom)+ghostsize(2)
+
+ CALL ppm_alloc(mgfield(i,mlev)%err,ldl2,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the residual alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ terr=>mgfield(i,mlev)%err
+ terr(:,:)=0.0_MK
+
+
+ !------------------------------------------------------------------
+ !MICHAEL
+ !------------------------------------------------------------------
!ALLOCATE THE BCVALUE(IT IS A TYPE!!)
- !PRINT *,'LPERIODIC:',lperiodic
- IF (.NOT.lperiodic) THEN
- iopt = ppm_param_alloc_fit
- ldu1(1) = 2*ppm_dim
- CALL ppm_mg_alloc(mgfield(i,mlev)%bcvalue,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the BOUNDARY alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
+ !PRINT *,'LPERIODIC:',lperiodic
+ IF (.NOT.lperiodic) THEN
+ iopt = ppm_param_alloc_fit
+ ldu1(1) = 2*ppm_dim
+ CALL ppm_mg_alloc(mgfield(i,mlev)%bcvalue,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the BOUNDARY alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
!ALLOCATE THE PBCVALUE
- DO iface=1,2*ppm_dim
- iopt = ppm_param_alloc_fit
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- ldu1(1) = max_node(2,mlev)
- ELSE
- ldu1(1) = max_node(1,mlev)
- ENDIF
- CALL ppm_alloc(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the BOUNDARY alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDDO
- DO iface=1,2*ppm_dim
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- direc(1)=2
- ELSEIF (iface.EQ.3.OR.iface.EQ.4) then
- direc(1)=1
- ENDIF
- DO ipoint=1,max_node(direc(1),mlev)
- IF (mlev.EQ.1) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint)=bcvalue(i,iface,ipoint)
- ELSE
- IF(bcdef_sca(i,iface).EQ.ppm_param_bcdef_neumann) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint)=&
- & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(2*ipoint-1)
- ELSE
- !NO CORRECTIONS FOR THE DIRICHLET
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint)=0.0_MK
- ENDIF
- ENDIF
- ENDDO
- ENDDO!faces
- ENDIF!lperiodic
+
+ DO iface=1,2*ppm_dim
+ iopt = ppm_param_alloc_fit
+ IF (iface.EQ.1.OR.iface.EQ.2) THEN
+ ldu1(1) = max_node(2,mlev)
+ ELSE
+ ldu1(1) = max_node(1,mlev)
+ ENDIF
+
+
+ CALL ppm_alloc(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the BOUNDARY alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ ENDDO
+
+
+ DO iface=1,2*ppm_dim
+ IF (iface.EQ.1.OR.iface.EQ.2) THEN
+ direc(1)=2
+ elseif (iface.EQ.3.OR.iface.EQ.4) then
+ direc(1)=1
+ endif
+ DO ipoint=1,max_node(direc(1),mlev)
+
+ IF (mlev.EQ.1) THEN
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint)=bcvalue(iface,ipoint)
+ ELSE
+ IF(bcdef_sca(i,iface).EQ.ppm_param_bcdef_neumann) THEN
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint)=&
+ & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(2*ipoint-1)
+ ELSE
+ !NO CORRECTIONS FOR THE DIRICHLET
+ ! mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint)=0.0_MK
+
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint)=0.0_MK
+ ENDIF
+ ENDIF
+ ENDDO
+ \
+ ENDDO!faces
+ ENDIF!lperiodic
#elif __DIM == __VFIELD
- iopt = ppm_param_alloc_fit
- ldl3(1) = 1
- ldl3(2) = 1-ghostsize(1)
- ldl3(3) = 1-ghostsize(2)
- ldu3(1) = vecdim
- ldu3(2) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu3(3) = mesh%nnodes(2,idom)+ghostsize(2)
- CALL ppm_alloc(mgfield(i,mlev)%uc,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the function corr. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- tuc=>mgfield(i,mlev)%uc
- tuc=0.0_MK
- iopt = ppm_param_alloc_fit
- ldu3(1) = vecdim
- ldu3(2) = mesh%nnodes(1,idom)
- ldu3(3) = mesh%nnodes(2,idom)
- CALL ppm_alloc(mgfield(i,mlev)%fc,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the restricted err. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1
+ ldl3(2) = 1-ghostsize(1)
+ ldl3(3) = 1-ghostsize(2)
+ ldu3(1) = vecdim
+ ldu3(2) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu3(3) = mesh%nnodes(2,idom)+ghostsize(2)
+ CALL ppm_alloc(mgfield(i,mlev)%uc,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the function corr. alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+ tuc=>mgfield(i,mlev)%uc
+ tuc(:,:,:)=0.0_MK
+
+ iopt = ppm_param_alloc_fit
+ ldu3(1) = vecdim
+ ldu3(2) = mesh%nnodes(1,idom)
+ ldu3(3) = mesh%nnodes(2,idom)
+ CALL ppm_alloc(mgfield(i,mlev)%fc,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the restricted err. alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
mgfield(i,mlev)%fc(:,:,:)=0.0_MK
- iopt = ppm_param_alloc_fit
- ldl3(1) = 1
- ldl3(2) = 1-ghostsize(1)
- ldl3(3) = 1-ghostsize(2)
- ldu3(1) = vecdim
- ldu3(2) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu3(3) = mesh%nnodes(2,idom)+ghostsize(2)
- CALL ppm_alloc(mgfield(i,mlev)%err,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the residual alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- terr=>mgfield(i,mlev)%err
- terr(:,:,:)=0.0_MK
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1
+ ldl3(2) = 1-ghostsize(1)
+ ldl3(3) = 1-ghostsize(2)
+ ldu3(1) = vecdim
+ ldu3(2) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu3(3) = mesh%nnodes(2,idom)+ghostsize(2)
+ CALL ppm_alloc(mgfield(i,mlev)%err,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the residual alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ terr=>mgfield(i,mlev)%err
+ terr(:,:,:)=0.0_MK
+
#endif
- ENDDO!DO 1,nsubs
+ iopt = ppm_param_alloc_fit
+ ldl2(1) = 1-ghostsize(1)
+ ldl2(2) = 1-ghostsize(2)
+ ldu2(1) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu2(2) = mesh%nnodes(2,idom)+ghostsize(2)
+ CALL ppm_alloc(mgfield(i,mlev)%mask_red,ldl2,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the mask alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldl2(1) = 1-ghostsize(1)
+ ldl2(2) = 1-ghostsize(2)
+ ldu2(1) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu2(2) = mesh%nnodes(2,idom)+ghostsize(2)
+ CALL ppm_alloc(mgfield(i,mlev)%mask_black,ldl2,ldu2,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with mask alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ !----------------------------------------------------------------
+ !Filling the mask for communication (red black)
+ !----------------------------------------------------------------
+ DO iy=1-ghostsize(2),mesh%nnodes(2,idom)+ghostsize(2)
+ DO ix=1-ghostsize(1),mesh%nnodes(1,idom)+ghostsize(1)
+
+ IF (MOD(ix+iy,2).EQ.0) THEN
+
+ mgfield(i,mlev)%mask_red(ix,iy)=.TRUE.
+ mgfield(i,mlev)%mask_black(ix,iy)=.FALSE.
+
+ ELSE
+
+ mgfield(i,mlev)%mask_red(ix,iy) = .FALSE.
+ mgfield(i,mlev)%mask_black(ix,iy) = .TRUE.
+
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO!DO 1,nsubs
+
+
+
#elif __MESH_DIM == __3D
- DO i=1,nsubs
- idom=topo%isublist(i)
- istop(:,i,mlev) = mesh%nnodes(:,idom)
- DO j=1,ppm_dim
- IF (max_node(j,mlev).LT.istop(j,i,mlev)) THEN
- max_node(j,mlev)=istop(j,i,mlev)
- ENDIF
- ENDDO
-
- IF (topo%subs_bc(1,idom).EQ.1) THEN
- lboundary(1,i)=.TRUE.
- ELSEIF (topo%subs_bc(3,idom).EQ.1) THEN
- lboundary(3,i)=.TRUE.
- ELSEIF (topo%subs_bc(2,idom).EQ.1) THEN
- lboundary(2,i)=.TRUE.
- ELSEIF (topo%subs_bc(4,idom).EQ.1) THEN
- lboundary(4,i)=.TRUE.
- ELSEIF (topo%subs_bc(5,idom).EQ.1) THEN
- lboundary(5,i)=.TRUE.
- ELSEIF (topo%subs_bc(6,idom).EQ.1) THEN
- lboundary(6,i)=.TRUE.
- ENDIF
- !----------------------------------------------------------------
- ! Allocate the function correction, the restricted errors and the
- !residuals on each level.
- !----------------------------------------------------------------
-#if __DIM == __SFIELD
- iopt = ppm_param_alloc_fit
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1-ghostsize(3)
- ldu3(1) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu3(2) = mesh%nnodes(2,idom)+ghostsize(2)
- ldu3(3) = mesh%nnodes(3,idom)+ghostsize(3)
- CALL ppm_alloc(mgfield(i,mlev)%uc,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the function corr. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- tuc=>mgfield(i,mlev)%uc
- tuc=0.0_MK
- iopt = ppm_param_alloc_fit
- ldu3(1) = mesh%nnodes(1,idom)
- ldu3(2) = mesh%nnodes(2,idom)
- ldu3(3) = mesh%nnodes(3,idom)
- CALL ppm_alloc(mgfield(i,mlev)%fc,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the restricted err. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield(i,mlev)%fc=0.0_MK
- iopt = ppm_param_alloc_fit
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1-ghostsize(3)
- ldu3(1) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu3(2) = mesh%nnodes(2,idom)+ghostsize(2)
- ldu3(3) = mesh%nnodes(3,idom)+ghostsize(3)
- CALL ppm_alloc(mgfield(i,mlev)%err,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the residual alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- terr=>mgfield(i,mlev)%err
- terr=0.0_MK
- !ALLOCATE THE BCVALUE(IT IS A TYPE!!)
- IF (.NOT.lperiodic) THEN
- iopt = ppm_param_alloc_fit
- ldu1(1) = 2*ppm_dim
- CALL ppm_mg_alloc(mgfield(i,mlev)%bcvalue,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the BOUNDARY alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- !ALLOCATE THE PBCVALUE
- DO iface=1,2*ppm_dim
- iopt = ppm_param_alloc_fit
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- ldu2(1) = max_node(2,mlev)
- ldu2(2)= max_node(3,mlev)
- ELSEif (iface.EQ.3.OR. iface.EQ.4) then
- ldu2(1) = max_node(1,mlev)
- ldu2(2)=max_node(3,mlev)
- else
- ldu2(1)=max_node(1,mlev)
- ldu2(2)=max_node(2,mlev)
- ENDIF
- CALL ppm_alloc(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,ldu2,iopt,info)
- !Print *,size(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,1)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the BOUNDARY alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
+
+
+ DO i=1,nsubs
+
+ idom=topo%isublist(i)
+ stop(:,i,mlev) = mesh%nnodes(:,idom)
+
+ DO j=1,ppm_dim
+ IF (max_node(j,mlev).LT.stop(j,i,mlev)) THEN
+ max_node(j,mlev)=stop(j,i,mlev)
+ ENDIF
ENDDO
- DO iface=1,2*ppm_dim
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- direc(1)=2
- direc(2)=3
- elseif (iface.EQ.3.OR.iface.EQ.4) THEN
- direc(1)=1
- direc(2)=3
- else
- direc(1)=1
- direc(2)=2
- endif
- DO ipoint=1,max_node(direc(1),mlev)
- DO jpoint=1,max_node(direc(2),mlev)
- IF (mlev.EQ.1) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)=bcvalue(i,iface,ipoint,jpoint)
- ELSE
- IF(bcdef_sca(i,iface).EQ.ppm_param_bcdef_neumann) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)=&
- & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(2*ipoint-1,2*jpoint-1)
- ELSE
- !NO CORRECTIONS FOR THE DIRICHLET
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)=0.0_MK
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDDO!faces
- endif !lperiodic
+
+ IF (topo%subs_bc(1,idom).EQ.1) THEN
+
+ lboundary(1,i)=.TRUE.
+
+
+ ELSEIF (topo%subs_bc(3,idom).EQ.1) THEN
+
+ lboundary(3,i)=.TRUE.
+
+ ELSEIF (topo%subs_bc(2,idom).EQ.1) THEN
+
+ lboundary(2,i)=.TRUE.
+
+
+ ELSEIF (topo%subs_bc(4,idom).EQ.1) THEN
+
+ lboundary(4,i)=.TRUE.
+
+ ELSEIF (topo%subs_bc(5,idom).EQ.1) THEN
+
+ lboundary(5,i)=.TRUE.
+
+
+ ELSEIF (topo%subs_bc(6,idom).EQ.1) THEN
+
+ lboundary(6,i)=.TRUE.
+
+
+ ENDIF
+
+
+ !----------------------------------------------------------------
+ ! Allocate the function correction, the restricted errors and the
+ !residuals on each level.
+ !----------------------------------------------------------------
+
+#if __DIM == __SFIELD
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1-ghostsize(3)
+ ldu3(1) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu3(2) = mesh%nnodes(2,idom)+ghostsize(2)
+ ldu3(3) = mesh%nnodes(3,idom)+ghostsize(3)
+ CALL ppm_alloc(mgfield(i,mlev)%uc,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the function corr. alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ tuc=>mgfield(i,mlev)%uc
+ tuc(:,:,:)=0.0_MK
+
+ iopt = ppm_param_alloc_fit
+ ldu3(1) = mesh%nnodes(1,idom)
+ ldu3(2) = mesh%nnodes(2,idom)
+ ldu3(3) = mesh%nnodes(3,idom)
+ CALL ppm_alloc(mgfield(i,mlev)%fc,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the restricted err. alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ mgfield(i,mlev)%fc(:,:,:)=0.0_MK
+
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1-ghostsize(3)
+ ldu3(1) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu3(2) = mesh%nnodes(2,idom)+ghostsize(2)
+ ldu3(3) = mesh%nnodes(3,idom)+ghostsize(3)
+ CALL ppm_alloc(mgfield(i,mlev)%err,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the residual alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ terr=>mgfield(i,mlev)%err
+ terr(:,:,:)=0.0_MK
+
+ !ALLOCATE THE BCVALUE(IT IS A TYPE!!)
+ !PRINT *,'LPERIODIC:',lperiodic
+ IF (.NOT.lperiodic) THEN
+ iopt = ppm_param_alloc_fit
+ ldu1(1) = 2*ppm_dim
+ CALL ppm_mg_alloc(mgfield(i,mlev)%bcvalue,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the BOUNDARY alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ !ALLOCATE THE PBCVALUE
+
+
+ DO iface=1,2*ppm_dim
+ iopt = ppm_param_alloc_fit
+ IF (iface.EQ.1.OR.iface.EQ.2) THEN
+ ldu2(1) = max_node(2,mlev)
+ ldu2(2)= max_node(3,mlev)
+ ELSEif (iface.EQ.3.OR. iface.EQ.4) then
+ ldu2(1) = max_node(1,mlev)
+ ldu2(2)=max_node(3,mlev)
+ else
+ ldu2(1)=max_node(1,mlev)
+ ldu2(2)=max_node(2,mlev)
+ ENDIF
+
+ CALL ppm_alloc(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,ldu2,iopt,info)
+ !Print *,size(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,1)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the BOUNDARY alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ ENDDO
+
+
+ DO iface=1,2*ppm_dim
+ IF (iface.EQ.1.OR.iface.EQ.2) THEN
+ direc(1)=2
+ direc(2)=3
+ elseif (iface.EQ.3.OR.iface.EQ.4) THEN
+ direc(1)=1
+ direc(2)=3
+ else
+ direc(1)=1
+ direc(2)=2
+ endif
+ DO ipoint=1,max_node(direc(1),mlev)
+ DO jpoint=1,max_node(direc(2),mlev)
+ IF (mlev.EQ.1) THEN
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)=bcvalue(iface,ipoint,jpoint)
+
+
+ ELSE
+ IF(bcdef_sca(i,iface).EQ.ppm_param_bcdef_neumann) THEN
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)=&
+ & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(2*ipoint-1,2*jpoint-1)
+ ELSE
+ !NO CORRECTIONS FOR THE DIRICHLET
+
+
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)=0.0_MK
+! If (mlev.EQ.5) then
+! Print *,ipoint,jpoint,mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)
+! endif
+ ENDIF
+ ENDIF
+ ENDDO
+ enddo
+ ENDDO!faces
+ endif !lperiodic
#elif __DIM == __VFIELD
- iopt = ppm_param_alloc_fit
- ldl4(1) = 1
- ldl4(2) = 1-ghostsize(1)
- ldl4(3) = 1-ghostsize(2)
- ldl4(4) = 1-ghostsize(3)
- ldu4(1) = vecdim
- ldu4(2) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu4(3) = mesh%nnodes(2,idom)+ghostsize(2)
- ldu4(4) = mesh%nnodes(3,idom)+ghostsize(3)
- CALL ppm_alloc(mgfield(i,mlev)%uc,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the function corr. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- tuc=>mgfield(i,mlev)%uc
- tuc=0.0_MK
- iopt = ppm_param_alloc_fit
- ldu4(1) = vecdim
- ldu4(2) = mesh%nnodes(1,idom)
- ldu4(3) = mesh%nnodes(2,idom)
- ldu4(4) = mesh%nnodes(3,idom)
- CALL ppm_alloc(mgfield(i,mlev)%fc,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the restricted err. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield(i,mlev)%fc=0.0_MK
- iopt = ppm_param_alloc_fit
- ldl4(1) = 1
- ldl4(2) = 1-ghostsize(1)
- ldl4(3) = 1-ghostsize(2)
- ldl4(4) = 1-ghostsize(3)
- ldu4(1) = vecdim
- ldu4(2) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu4(3) = mesh%nnodes(2,idom)+ghostsize(2)
- ldu4(4) = mesh%nnodes(3,idom)+ghostsize(3)
- CALL ppm_alloc(mgfield(i,mlev)%err,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the residual alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- terr=>mgfield(i,mlev)%err
- terr=0.0_MK
- !ALLOCATE THE BCVALUE(IT IS A TYPE!!)
- IF (.NOT.lperiodic) THEN
- iopt = ppm_param_alloc_fit
- ldu1=2*ppm_dim
- CALL ppm_mg_alloc(mgfield(i,mlev)%bcvalue,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the BOUNDARY alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- !ALLOCATE THE PBCVALUE
- DO iface=1,2*ppm_dim
- iopt = ppm_param_alloc_fit
- ldu3(1)=vecdim
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- ldu3(2) = max_node(2,mlev)
- ldu3(3)= max_node(3,mlev)
- ELSEIF (iface.EQ.3.OR. iface.EQ.4) then
- ldu3(2) = max_node(1,mlev)
- ldu3(3)=max_node(3,mlev)
- ELSE
- ldu3(2)=max_node(1,mlev)
- ldu3(3)=max_node(2,mlev)
- ENDIF
- CALL ppm_alloc(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,ldu3,iopt,info)
- IF (info .NE. 0) THEN
+
+ iopt = ppm_param_alloc_fit
+ ldl4(1) = 1
+ ldl4(2) = 1-ghostsize(1)
+ ldl4(3) = 1-ghostsize(2)
+ ldl4(4) = 1-ghostsize(3)
+ ldu4(1) = vecdim
+ ldu4(2) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu4(3) = mesh%nnodes(2,idom)+ghostsize(2)
+ ldu4(4) = mesh%nnodes(3,idom)+ghostsize(3)
+ CALL ppm_alloc(mgfield(i,mlev)%uc,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
info = ppm_error_fatal
CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the BOUNDARY alloc.',__LINE__,info)
+ & 'Problem with the function corr. alloc.',__LINE__,info)
GOTO 9999
- ENDIF
- ENDDO
- DO iface=1,2*ppm_dim
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- direc(1)=2
- direc(2)=3
- elseif (iface.EQ.3.OR.iface.EQ.4) THEN
- direc(1)=1
- direc(2)=3
- else
- direc(1)=1
- direc(2)=2
- endif
+ ENDIF
+
+ tuc=>mgfield(i,mlev)%uc
+ tuc(:,:,:,:)=0.0_MK
+
+
+ iopt = ppm_param_alloc_fit
+ ldu4(1) = vecdim
+ ldu4(2) = mesh%nnodes(1,idom)
+ ldu4(3) = mesh%nnodes(2,idom)
+ ldu4(4) = mesh%nnodes(3,idom)
+ CALL ppm_alloc(mgfield(i,mlev)%fc,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the restricted err. alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ mgfield(i,mlev)%fc(:,:,:,:)=0.0_MK
+
+
+ iopt = ppm_param_alloc_fit
+ ldl4(1) = 1
+ ldl4(2) = 1-ghostsize(1)
+ ldl4(3) = 1-ghostsize(2)
+ ldl4(4) = 1-ghostsize(3)
+ ldu4(1) = vecdim
+ ldu4(2) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu4(3) = mesh%nnodes(2,idom)+ghostsize(2)
+ ldu4(4) = mesh%nnodes(3,idom)+ghostsize(3)
+ CALL ppm_alloc(mgfield(i,mlev)%err,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the residual alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ terr=>mgfield(i,mlev)%err
+ terr(:,:,:,:)=0.0_MK
+
+ !ALLOCATE THE BCVALUE(IT IS A TYPE!!)
+ !PRINT *,'LPERIODIC:',lperiodic
+ IF (.NOT.lperiodic) THEN
+ iopt = ppm_param_alloc_fit
+ ldu1=2*ppm_dim
+ !ldu2(1)=vecdim
+ !ldu2(2) = 2*ppm_dim
+
+ !allocate(mgfield(i,mlev)%bcvalue(3,6))
+ CALL ppm_mg_alloc(mgfield(i,mlev)%bcvalue,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the BOUNDARY alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ !ALLOCATE THE PBCVALUE
+
+ DO iface=1,2*ppm_dim
+ iopt = ppm_param_alloc_fit
+ ldu3(1)=vecdim
+ IF (iface.EQ.1.OR.iface.EQ.2) THEN
+
+ ldu3(2) = max_node(2,mlev)
+ ldu3(3)= max_node(3,mlev)
+ ELSEif (iface.EQ.3.OR. iface.EQ.4) then
+ ldu3(2) = max_node(1,mlev)
+ ldu3(3)=max_node(3,mlev)
+ else
+ ldu3(2)=max_node(1,mlev)
+ ldu3(3)=max_node(2,mlev)
+ ENDIF
+
+ CALL ppm_alloc(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,ldu3,iopt,info)
+
+
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the BOUNDARY alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ ENDDO
+
+ DO iface=1,2*ppm_dim
+ IF (iface.EQ.1.OR.iface.EQ.2) THEN
+ direc(1)=2
+ direc(2)=3
+ elseif (iface.EQ.3.OR.iface.EQ.4) THEN
+ direc(1)=1
+ direc(2)=3
+ else
+ direc(1)=1
+ direc(2)=2
+ endif
+
DO ipoint=1,max_node(direc(1),mlev)
- DO jpoint=1,max_node(direc(2),mlev)
- DO ilda=1,vecdim
- IF (mlev.EQ.1) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint) &
- & =bcvalue(ilda,i,iface,ipoint,jpoint)
- ELSE
- IF(bcdef_vec(ilda,i,iface).EQ.ppm_param_bcdef_neumann) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint)=&
- & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(ilda,2*ipoint-1,2*jpoint-1)
- ELSE
- !NO CORRECTIONS FOR THE DIRICHLET
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint)=0.0_MK
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF !lperiodic
+ DO jpoint=1,max_node(direc(2),mlev)
+ DO ilda=1,vecdim
+
+ IF (mlev.EQ.1) THEN
+ !PRINT *,'bcef',ilda,iface,bcvalue(ilda,iface,ipoint,jpoint)
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint)=bcvalue(ilda,iface,ipoint,jpoint)
+ !PRINT *,ipoint,jpoint,iface,ilda,bcvalue(ilda,iface,ipoint,jpoint),mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint)
+
+ ! Print*,'Boundariu',bcvalue(ilda,iface,ipoint,jpoint)
+ ELSE
+ IF(bcdef_vec(ilda,i,iface).EQ.ppm_param_bcdef_neumann) THEN
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint)=&
+ & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(ilda,2*ipoint-1,2*jpoint-1)
+ ELSE
+ !NO CORRECTIONS FOR THE DIRICHLET
+
+
+ mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint)=0.0_MK
+! If (mlev.EQ.5) then
+! Print *,ipoint,jpoint,mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)
+! endif
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ enddo
+ ENDDO!faces
+ ENDIF !lperiodic
+
#endif
- ENDDO!DO i=1,nsubs
+
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1-ghostsize(3)
+ ldu3(1) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu3(2) = mesh%nnodes(2,idom)+ghostsize(2)
+ ldu3(3) = mesh%nnodes(3,idom)+ghostsize(3)
+ CALL ppm_alloc(mgfield(i,mlev)%mask_red,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with the mask alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1-ghostsize(3)
+ ldu3(1) = mesh%nnodes(1,idom)+ghostsize(1)
+ ldu3(2) = mesh%nnodes(2,idom)+ghostsize(2)
+ ldu3(3) = mesh%nnodes(3,idom)+ghostsize(3)
+ CALL ppm_alloc(mgfield(i,mlev)%mask_black,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
+ & 'Problem with mask alloc.',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+ !----------------------------------------------------------------
+ !Filling the mask for communication (red black)
+ !-----------------------------------------------------------------
+ DO iz=1-ghostsize(3),&
+ mesh%nnodes(3,idom)+ghostsize(3)
+
+ DO iy=1-ghostsize(2),&
+ & mesh%nnodes(2,idom)+ghostsize(2)
+ DO ix=1-ghostsize(1),&
+ & mesh%nnodes(1,idom)+ghostsize(1)
+
+ IF (MOD(ix+iy+iz,2).EQ.0) THEN
+
+ mgfield(i,mlev)%mask_red(ix,iy,iz)=.TRUE.
+ mgfield(i,mlev)%mask_black(ix,iy,iz)=.FALSE.
+ !mgfield(i,mlev)%mask_black(ix,iy,iz)=.TRUE.
+
+ ELSE
+
+ mgfield(i,mlev)%mask_red(ix,iy,iz) = .FALSE.
+ mgfield(i,mlev)%mask_black(ix,iy,iz) = .TRUE.
+
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+
+
+
+ ENDDO!DO i=1,nsubs
+
#endif
- factor(:)=2
- mesh_id_g(mlev)=lmesh_id
- meshid_g(mlev)=meshid
- newmeshid=-1
- IF (mlev.LT.maxlev) THEN
- CALL ppm_mesh_derive(topoid,meshid,ppm_param_mesh_coarsen,factor,&
- & newmeshid,info)
- lmesh_id = newmeshid
- meshid = ppm_meshid(topoid)%internal(lmesh_id)
- ENDIF
- ENDDO!DO mlev=1,maxlev
- !----------------------------------------------------------------------
- ! Return
- !----------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_mg_init',t0,info)
- RETURN
+
+
+ factor(:)=2
+ mesh_id_g(mlev)=lmesh_id
+ meshid_g(mlev)=meshid
+ newmeshid=-1
+
+ IF (mlev.LT.maxlev) THEN
+ !Print *,'dfj',meshid,ppm_param_mesh_coarsen,factor,newmeshid
+ CALL ppm_mesh_derive(topoid,meshid,newmeshid,&
+ & ppm_param_mesh_coarsen,factor,info)
+
+
+ lmesh_id = newmeshid
+ meshid = topo%mesh(lmesh_id)%ID
+
+ ENDIF
+
+ ENDDO!DO mlev=1,maxlev
+
+
+ !----------------------------------------------------------------------
+ ! Return
+ !----------------------------------------------------------------------
+ 9999 CONTINUE
+ CALL substop('ppm_mg_init',t0,info)
+ RETURN
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_init_2d_sca_s
+ END SUBROUTINE ppm_mg_init_2d_sca_s
#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_init_2d_sca_d
+ END SUBROUTINE ppm_mg_init_2d_sca_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_init_3d_sca_s
+ END SUBROUTINE ppm_mg_init_3d_sca_s
#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_init_3d_sca_d
+ END SUBROUTINE ppm_mg_init_3d_sca_d
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_init_2d_vec_s
+ END SUBROUTINE ppm_mg_init_2d_vec_s
#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_init_2d_vec_d
+ END SUBROUTINE ppm_mg_init_2d_vec_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_init_3d_vec_s
+ END SUBROUTINE ppm_mg_init_3d_vec_s
#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_init_3d_vec_d
+ END SUBROUTINE ppm_mg_init_3d_vec_d
#endif
#endif
#endif
diff --git a/src/ppm_mg_res_coarse.f b/src/ppm_mg_res_coarse.f
index a41f1c2..b212e6f 100644
--- a/src/ppm_mg_res_coarse.f
+++ b/src/ppm_mg_res_coarse.f
@@ -1,6 +1,6 @@
-!-------------------------------------------------------------------------------
+!-----------------------------------------------------------------------
! Subroutine : ppm_mg_res
-!-------------------------------------------------------------------------------
+!-----------------------------------------------------------------------
! Purpose : In this routine we compute the residula in each level
!
!
@@ -16,13 +16,10 @@
! References :
!
! Revisions :
-!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------
! $Log: ppm_mg_res_coarse.f,v $
-! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
-! CBL version of the PPM library
-!
-! Revision 1.8 2006/07/21 11:30:56 kotsalie
-! FRIDAY
+! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+! initial import
!
! Revision 1.6 2006/02/08 19:56:24 kotsalie
! fixed multiple domains
@@ -42,69 +39,75 @@
! Revision 1.1 2004/09/22 18:47:32 kotsalie
! MG new version
!
-!-----------------------------------------------------------------------------
+!
+!------------------------------------------------------------------------
! Parallel Particle Mesh Library (PPM)
! Institute of Computational Science
! ETH Zentrum, Hirschengraben 84
! CH-8092 Zurich, Switzerland
-!------------------------------------------------------------------------------
+!-------------------------------------------------------------------------
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_2D_sca_s(f_topoid,mlev,c1,c2,c3,c4,E,info)
+ SUBROUTINE ppm_mg_res_coarse_2D_sca_s(topo_id,mlev,c1,c2,c3,c4,E,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_2D_sca_d(f_topoid,mlev,c1,c2,c3,c4,E,info)
+ SUBROUTINE ppm_mg_res_coarse_2D_sca_d(topo_id,mlev,c1,c2,c3,c4,E,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_3D_sca_s(f_topoid,mlev,c1,c2,c3,c4,c5,&
- & E,info)
+ SUBROUTINE ppm_mg_res_coarse_3D_sca_s(topo_id,mlev,c1,c2,c3,c4,c5,&
+ & E,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_3D_sca_d(f_topoid,mlev,c1,c2,c3,c4,c5,&
- & E,info)
+ SUBROUTINE ppm_mg_res_coarse_3D_sca_d(topo_id,mlev,c1,c2,c3,c4,c5,&
+ & E,info)
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_2D_vec_s(f_topoid,mlev,c1,c2,c3,c4,E,info)
+ SUBROUTINE ppm_mg_res_coarse_2D_vec_s(topo_id,mlev,c1,c2,c3,c4,E,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_2D_vec_d(f_topoid,mlev,c1,c2,c3,c4,E,info)
+ SUBROUTINE ppm_mg_res_coarse_2D_vec_d(topo_id,mlev,c1,c2,c3,c4,E,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_3D_vec_s(f_topoid,mlev,c1,c2,c3,c4,c5,&
- & E,info)
+ SUBROUTINE ppm_mg_res_coarse_3D_vec_s(topo_id,mlev,c1,c2,c3,c4,c5,&
+ & E,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_3D_vec_d(f_topoid,mlev,c1,c2,c3,c4,c5,&
- & E,info)
+ SUBROUTINE ppm_mg_res_coarse_3D_vec_d(topo_id,mlev,c1,c2,c3,c4,c5,&
+ & E,info)
#endif
#endif
#endif
- !----------------------------------------------------------------------
+
+ !----------------------------------------------------------------------
! Includes
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
#include "ppm_define.h"
- !-------------------------------------------------------------------
+
+ !-------------------------------------------------------------------
! Modules
- !-----------------------------------------------------------------------
+ !--------------------------------------------------------------------
USE ppm_module_data
+ USE ppm_module_write
USE ppm_module_data_mg
- USE ppm_module_data_mesh
USE ppm_module_substart
USE ppm_module_substop
USE ppm_module_error
USE ppm_module_alloc
+ USE ppm_module_data_mesh
+
IMPLICIT NONE
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
#else
INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
- !-------------------------------------------------------------------
+ !-------------------------------------------------------------------
! Arguments
- !-----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: mlev, f_topoid
+ !-------------------------------------------------------------------
+ INTEGER, INTENT(IN) :: mlev, topo_id
REAL(MK), INTENT(OUT) :: E
#if __MESH_DIM == __2D
REAL(MK), INTENT(IN) :: c1,c2,c3,c4
@@ -112,9 +115,9 @@
REAL(MK), INTENT(IN) :: c1,c2,c3,c4,c5
#endif
INTEGER, INTENT(INOUT) :: info
- !---------------------------------------------------------------------
+ !---------------------------------------------------------------------
! Local variables
- !-----------------------------------------------------------------------
+ !---------------------------------------------------------------------
CHARACTER(LEN=256) :: cbuf
INTEGER :: i,j,isub,color
INTEGER :: ilda,isweep,count
@@ -162,19 +165,7 @@
#endif
#endif
#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: tuc
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc
-#endif
-#endif
+
!-----------------------------------------------------------------------
!Externals
!-----------------------------------------------------------------------
@@ -182,11 +173,13 @@
!-----------------------------------------------------------------------
!Initialize
!-----------------------------------------------------------------------
+
CALL substart('ppm_mg_res',t0,info)
IF (l_print) THEN
WRITE(cbuf,*) 'RESIDUAL in LEVEL:',mlev
CALL PPM_WRITE(ppm_rank,'mg_res_coarse',cbuf,info)
ENDIF
+
!-----------------------------------------------------------------------
! Check arguments
!-----------------------------------------------------------------------
@@ -221,7 +214,9 @@
!-----------------------------------------------------------------------
!Definition of necessary variables and allocation of arrays
!-----------------------------------------------------------------------
- topoid=f_topoid
+ topoid=topo_id
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -251,42 +246,101 @@
#endif
#endif
#endif
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
+
!-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+ IF (order.EQ.ppm_param_order_2) THEN
+ DO isub=1,nsubs
+ aa=0
+ bb=0
+ cc=0
+ dd=0
+
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,4
+ IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ IF (iface.EQ.1) THEN
+ aa=1
+ ELSEIF (iface.EQ.2) THEN
+ bb=1
+ ELSEIF (iface.EQ.3) THEN
+ cc=1
+ ELSEIF (iface.EQ.4) THEN
+ dd=1
+ ENDIF
+ ENDIF
+ ENDDO !iface
+ endif !periodic
+ ENDDO
E=-HUGE(E)
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- res =(tuc(i-1,j)+&
- & tuc(i+1,j))*c2 + &
- & (tuc(i,j-1)+ &
- & tuc(i,j+1))*c3 - &
- & tuc(i,j)*c4 - &
+ DO j=start(2,isub,mlev)+cc,stop(2,isub,mlev)-dd
+ DO i=start(1,isub,mlev)+aa,stop(1,isub,mlev)-bb
+ res =(mgfield(isub,mlev)%uc(i-1,j)+&
+ & mgfield(isub,mlev)%uc(i+1,j))*c2 + &
+ & (mgfield(isub,mlev)%uc(i,j-1)+ &
+ & mgfield(isub,mlev)%uc(i,j+1))*c3 - &
+ & mgfield(isub,mlev)%uc(i,j)*c4 - &
& mgfield(isub,mlev)%fc(i,j)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(i,j)=-res
ENDDO
ENDDO
ENDDO
+
+ ELSEIF (order.EQ.ppm_param_order_4) THEN
+
+
+ c22=c2/12.0_MK
+ c33=c3/12.0_MK
+ c44=c4*1.25_MK
+
+ E=-HUGE(E)
+ DO isub=1,nsubs
+ DO j=start(2,isub,mlev),stop(2,isub,mlev)
+ DO i=start(1,isub,mlev),stop(1,isub,mlev)
+ res =(16.0_MK*mgfield(isub,mlev)%uc(i-1,j)+&
+ & 16.0_MK*mgfield(isub,mlev)%uc(i+1,j)-&
+ & mgfield(isub,mlev)%uc(i-2,j)-&
+ & mgfield(isub,mlev)%uc(i+2,j))*c22 + &
+ & (16.0_MK*mgfield(isub,mlev)%uc(i,j-1)+ &
+ & 16.0_MK*mgfield(isub,mlev)%uc(i,j+1)-&
+ & mgfield(isub,mlev)%uc(i,j-2)-&
+ & mgfield(isub,mlev)%uc(i,j+2))*c33 - &
+ & mgfield(isub,mlev)%uc(i,j)*c44 - &
+ & mgfield(isub,mlev)%fc(i,j)
+ E=MAX(ABS(res),E)
+ mgfield(isub,mlev)%err(i,j)=-res
+ ENDDO
+ ENDDO
+ ENDDO
+
+
+
+ ENDIF
+
#elif __MESH_DIM == __3D
- E=-HUGE(E)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- aa=0
- bb=0
- cc=0
- dd=0
- ee=0
- gg=0
- IF (.NOT.lperiodic) THEN
+
+ DO isub=1,nsubs
+ aa=0
+ bb=0
+ cc=0
+ dd=0
+ ee=0
+ gg=0
+
+ IF (.NOT.lperiodic) THEN
DO iface=1,6
- IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
!DO NOTHING
- ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
IF (iface.EQ.1) THEN
aa=1
ELSEIF (iface.EQ.2) THEN
@@ -299,47 +353,81 @@
ee=1
ELSEIF (iface.EQ.6) Then
gg=1
- ENDIF
+ ENDIF
ENDIF
ENDDO !iface
- endif !periodic
+ endif !periodic
+ ENDDO
!-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
- DO k=start(3,isub,mlev)+ee,istop(3,isub,mlev)-gg
- DO j=start(2,isub,mlev)+cc,istop(2,isub,mlev)-dd
- DO i=start(1,isub,mlev)+aa,istop(1,isub,mlev)-bb
- res =(tuc(i-1,j,k)+&
- & tuc(i+1,j,k))*c2 + &
- & (tuc(i,j-1,k)+ &
- & tuc(i,j+1,k))*c3 +&
- & (tuc(i,j,k-1)+ &
- & tuc(i,j,k+1))*c4 -&
- & tuc(i,j,k)*c5 - &
+ !-----------------------------------------------------------------------
+ E=-HUGE(E)
+ DO isub=1,nsubs
+ DO k=start(3,isub,mlev)+ee,stop(3,isub,mlev)-gg
+ DO j=start(2,isub,mlev)+cc,stop(2,isub,mlev)-dd
+ DO i=start(1,isub,mlev)+aa,stop(1,isub,mlev)-bb
+ res =(mgfield(isub,mlev)%uc(i-1,j,k)+&
+ & mgfield(isub,mlev)%uc(i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(i,j-1,k)+ &
+ & mgfield(isub,mlev)%uc(i,j+1,k))*c3 +&
+ & (mgfield(isub,mlev)%uc(i,j,k-1)+ &
+ & mgfield(isub,mlev)%uc(i,j,k+1))*c4 -&
+ & mgfield(isub,mlev)%uc(i,j,k)*c5 - &
& mgfield(isub,mlev)%fc(i,j,k)
- E=MAX(ABS(res),E)
- mgfield(isub,mlev)%err(i,j,k)=-res
+ E=MAX(ABS(res),E)
+ mgfield(isub,mlev)%err(i,j,k)=-res
ENDDO
ENDDO
ENDDO
ENDDO
+
+
+
+
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
+
+ DO isub=1,nsubs
+ DO ilda=1,vecdim
+ aa=0
+ bb=0
+ cc=0
+ dd=0
+
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,4
+ IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ IF (iface.EQ.1) THEN
+ aa=1
+ ELSEIF (iface.EQ.2) THEN
+ bb=1
+ ELSEIF (iface.EQ.3) THEN
+ cc=1
+ ELSEIF (iface.EQ.4) THEN
+ dd=1
+ ENDIF
+ ENDIF
+ ENDDO !iface
+ endif !periodic
+ ENDDO
+ ENDDO
!-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
- E=-HUGE(E)
+ !-----------------------------------------------------------------------
+
+ E=-HUGE(E)
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
+ DO j=start(2,isub,mlev)+cc,stop(2,isub,mlev)-dd
+ DO i=start(1,isub,mlev)+aa,stop(1,isub,mlev)-bb
DO ilda=1,vecdim
- res =(tuc(ilda,i-1,j)+&
- & tuc(ilda,i+1,j))*c2 + &
- & (tuc(ilda,i,j-1)+ &
- & tuc(ilda,i,j+1))*c3 - &
- & tuc(ilda,i,j)*c4 - &
+ res =(mgfield(isub,mlev)%uc(ilda,i-1,j)+&
+ & mgfield(isub,mlev)%uc(ilda,i+1,j))*c2 + &
+ & (mgfield(isub,mlev)%uc(ilda,i,j-1)+ &
+ & mgfield(isub,mlev)%uc(ilda,i,j+1))*c3 - &
+ & mgfield(isub,mlev)%uc(ilda,i,j)*c4 - &
& mgfield(isub,mlev)%fc(ilda,i,j)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(ilda,i,j)=-res
@@ -347,20 +435,26 @@
ENDDO
ENDDO
ENDDO
+
+
+
#elif __MESH_DIM == __3D
+
!-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
- E=-HUGE(E)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
+ !-----------------------------------------------------------------------
+
+ IF (order.EQ.ppm_param_order_2) THEN
+
+ DO isub=1,nsubs
aa=0
bb=0
cc=0
dd=0
ee=0
gg=0
- DO ilda=1,vecdim
+ DO ilda=1,vecdim
+
IF (.NOT.lperiodic) THEN
DO iface=1,6
IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
@@ -378,54 +472,61 @@
ee=1
ELSEIF (iface.EQ.6) Then
gg=1
- ENDIF
+ ENDIF
ENDIF
ENDDO !iface
- endif !periodic
+ endif !periodic
ENDDO
- DO k=start(3,isub,mlev)+ee,istop(3,isub,mlev)-gg
- DO j=start(2,isub,mlev)+cc,istop(2,isub,mlev)-dd
- DO i=start(1,isub,mlev)+aa,istop(1,isub,mlev)-bb
+ !ENDDO
+
+ E=-HUGE(E)
+ !DO isub=1,nsubs
+ DO k=start(3,isub,mlev)+ee,stop(3,isub,mlev)-gg
+ DO j=start(2,isub,mlev)+cc,stop(2,isub,mlev)-dd
+ DO i=start(1,isub,mlev)+aa,stop(1,isub,mlev)-bb
#ifdef __VECTOR
- res =(tuc(1,i-1,j,k)+&
- & tuc(1,i+1,j,k))*c2 + &
- & (tuc(1,i,j-1,k)+ &
- & tuc(1,i,j+1,k))*c3 +&
- & (tuc(1,i,j,k-1)+ &
- & tuc(1,i,j,k+1))*c4 -&
- & tuc(1,i,j,k)*c5 - &
+ res =(mgfield(isub,mlev)%uc(1,i-1,j,k)+&
+ & mgfield(isub,mlev)%uc(1,i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(1,i,j-1,k)+ &
+ & mgfield(isub,mlev)%uc(1,i,j+1,k))*c3 +&
+ & (mgfield(isub,mlev)%uc(1,i,j,k-1)+ &
+ & mgfield(isub,mlev)%uc(1,i,j,k+1))*c4 -&
+ & mgfield(isub,mlev)%uc(1,i,j,k)*c5 - &
& mgfield(isub,mlev)%fc(1,i,j,k)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(1,i,j,k)=-res
- res =(tuc(2,i-1,j,k)+&
- & tuc(2,i+1,j,k))*c2 + &
- & (tuc(2,i,j-1,k)+ &
- & tuc(2,i,j+1,k))*c3 +&
- & (tuc(2,i,j,k-1)+ &
- & tuc(2,i,j,k+1))*c4 -&
- & tuc(2,i,j,k)*c5 - &
+
+ res =(mgfield(isub,mlev)%uc(2,i-1,j,k)+&
+ & mgfield(isub,mlev)%uc(2,i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(2,i,j-1,k)+ &
+ & mgfield(isub,mlev)%uc(2,i,j+1,k))*c3 +&
+ & (mgfield(isub,mlev)%uc(2,i,j,k-1)+ &
+ & mgfield(isub,mlev)%uc(2,i,j,k+1))*c4 -&
+ & mgfield(isub,mlev)%uc(2,i,j,k)*c5 - &
& mgfield(isub,mlev)%fc(2,i,j,k)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(2,i,j,k)=-res
- res =(tuc(3,i-1,j,k)+&
- & tuc(3,i+1,j,k))*c2 + &
- & (tuc(3,i,j-1,k)+ &
- & tuc(3,i,j+1,k))*c3 +&
- & (tuc(3,i,j,k-1)+ &
- & tuc(3,i,j,k+1))*c4 -&
- & tuc(3,i,j,k)*c5 - &
+
+ res =(mgfield(isub,mlev)%uc(3,i-1,j,k)+&
+ & mgfield(isub,mlev)%uc(3,i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(3,i,j-1,k)+ &
+ & mgfield(isub,mlev)%uc(3,i,j+1,k))*c3 +&
+ & (mgfield(isub,mlev)%uc(3,i,j,k-1)+ &
+ & mgfield(isub,mlev)%uc(3,i,j,k+1))*c4 -&
+ & mgfield(isub,mlev)%uc(3,i,j,k)*c5 - &
& mgfield(isub,mlev)%fc(3,i,j,k)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(3,i,j,k)=-res
+
#else
DO ilda=1,vecdim
- res =(tuc(ilda,i-1,j,k)+&
- & tuc(ilda,i+1,j,k))*c2 + &
- & (tuc(ilda,i,j-1,k)+ &
- & tuc(ilda,i,j+1,k))*c3 +&
- & (tuc(ilda,i,j,k-1)+ &
- & tuc(ilda,i,j,k+1))*c4 -&
- & tuc(ilda,i,j,k)*c5 - &
+ res =(mgfield(isub,mlev)%uc(ilda,i-1,j,k)+&
+ & mgfield(isub,mlev)%uc(ilda,i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(ilda,i,j-1,k)+ &
+ & mgfield(isub,mlev)%uc(ilda,i,j+1,k))*c3 +&
+ & (mgfield(isub,mlev)%uc(ilda,i,j,k-1)+ &
+ & mgfield(isub,mlev)%uc(ilda,i,j,k+1))*c4 -&
+ & mgfield(isub,mlev)%uc(ilda,i,j,k)*c5 - &
& mgfield(isub,mlev)%fc(ilda,i,j,k)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(ilda,i,j,k)=-res
@@ -435,15 +536,21 @@
ENDDO
ENDDO
ENDDO
+ ELSEIF (order.EQ.ppm_param_order_4) THEN
+
+
+ ENDIF
+
#endif
#endif
- !----------------------------------------------------------------------
+
+
+ !----------------------------------------------------------------------
! Return
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
9999 CONTINUE
CALL substop('ppm_mg_res',t0,info)
RETURN
-
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -473,3 +580,7 @@
#endif
#endif
#endif
+
+
+
+
diff --git a/src/ppm_mg_res_fine.f b/src/ppm_mg_res_fine.f
index 6c5c03b..c01bfbf 100644
--- a/src/ppm_mg_res_fine.f
+++ b/src/ppm_mg_res_fine.f
@@ -1,6 +1,6 @@
-!-------------------------------------------------------------------------------
+!-----------------------------------------------------------------------
! Subroutine : ppm_mg_res
-!-------------------------------------------------------------------------------
+!-----------------------------------------------------------------------
! Purpose : In this routine we compute the residual in each level
!
!
@@ -15,13 +15,10 @@
! References :
!
! Revisions :
-!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------
! $Log: ppm_mg_res_fine.f,v $
-! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
-! CBL version of the PPM library
-!
-! Revision 1.7 2006/07/21 11:30:56 kotsalie
-! FRIDAY
+! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+! initial import
!
! Revision 1.5 2006/02/08 19:56:02 kotsalie
! fixed multiple domains
@@ -38,67 +35,72 @@
! Revision 1.1 2004/09/22 18:46:21 kotsalie
! MG new version
!
-!-----------------------------------------------------------------------------
+!------------------------------------------------------------------------
! Parallel Particle Mesh Library (PPM)
! Institute of Computational Science
! ETH Zentrum, Hirschengraben 84
! CH-8092 Zurich, Switzerland
-!------------------------------------------------------------------------------
+!-------------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_2D_sca_s(f_topoid,u,f,c1,c2,c3,c4,E,info)
+ SUBROUTINE ppm_mg_res_fine_2D_sca_s(topo_id,u,f,c1,c2,c3,c4,E,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_2D_sca_d(f_topoid,u,f,c1,c2,c3,c4,E,info)
+ SUBROUTINE ppm_mg_res_fine_2D_sca_d(topo_id,u,f,c1,c2,c3,c4,E,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_3D_sca_s(f_topoid,u,f,c1,c2,c3,c4,c5,E,info)
+ SUBROUTINE ppm_mg_res_fine_3D_sca_s(topo_id,u,f,c1,c2,c3,c4,c5,&
+ & E,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_3D_sca_d(f_topoid,u,f,c1,c2,c3,c4,c5,E,info)
+ SUBROUTINE ppm_mg_res_fine_3D_sca_d(topo_id,u,f,c1,c2,c3,c4,c5,&
+ & E,info)
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_2D_vec_s(f_topoid,u,f,c1,c2,c3,c4,E,info)
+ SUBROUTINE ppm_mg_res_fine_2D_vec_s(topo_id,u,f,c1,c2,c3,c4,E,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_2D_vec_d(f_topoid,u,f,c1,c2,c3,c4,E,info)
+ SUBROUTINE ppm_mg_res_fine_2D_vec_d(topo_id,u,f,c1,c2,c3,c4,E,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_3D_vec_s(f_topoid,u,f,c1,c2,c3,c4,c5,E,info)
+ SUBROUTINE ppm_mg_res_fine_3D_vec_s(topo_id,u,f,c1,c2,c3,c4,c5,&
+ & E,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_3D_vec_d(f_topoid,u,f,c1,c2,c3,c4,c5,E,info)
+ SUBROUTINE ppm_mg_res_fine_3D_vec_d(topo_id,u,f,c1,c2,c3,c4,c5,&
+ & E,info)
#endif
#endif
#endif
- !----------------------------------------------------------------------
+
+ !----------------------------------------------------------------------
! Includes
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
#include "ppm_define.h"
- !-------------------------------------------------------------------
+
+ !-------------------------------------------------------------------
! Modules
- !-----------------------------------------------------------------------
+ !--------------------------------------------------------------------
USE ppm_module_data
USE ppm_module_data_mg
- USE ppm_module_data_mesh
USE ppm_module_substart
USE ppm_module_substop
USE ppm_module_error
USE ppm_module_alloc
- USE ppm_module_typedef
+ USE ppm_module_data_mesh
+
IMPLICIT NONE
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
#else
INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
- !-------------------------------------------------------------------
+ !-------------------------------------------------------------------
! Arguments
- !-----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: f_topoid
+ !-------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
REAL(MK),DIMENSION(:,:,:),POINTER :: u
@@ -123,9 +125,10 @@
#endif
REAL(MK), INTENT(OUT) :: E
INTEGER, INTENT(INOUT) :: info
- !---------------------------------------------------------------------
+ INTEGER, INTENT(IN ) :: topo_id
+ !---------------------------------------------------------------------
! Local variables
- !-----------------------------------------------------------------------
+ !---------------------------------------------------------------------
CHARACTER(LEN=256) :: cbuf
INTEGER :: i,j,isub,color
INTEGER :: ilda,isweep,count
@@ -173,6 +176,7 @@
#endif
#endif
#endif
+
!-----------------------------------------------------------------------
!Externals
!-----------------------------------------------------------------------
@@ -180,7 +184,10 @@
!-----------------------------------------------------------------------
!Initialize
!-----------------------------------------------------------------------
+
CALL substart('ppm_mg_res',t0,info)
+
+
!-----------------------------------------------------------------------
! Check arguments
!-----------------------------------------------------------------------
@@ -221,7 +228,9 @@
!-----------------------------------------------------------------------
!Definition of necessary variables and allocation of arrays
!-----------------------------------------------------------------------
- topoid=f_topoid
+ topoid=topo_id
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -251,29 +260,90 @@
#endif
#endif
#endif
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
+
!-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+ IF (order.EQ.ppm_param_order_2) THEN
+ DO isub=1,nsubs
+ aa=0
+ bb=0
+ cc=0
+ dd=0
+
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,4
+ IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ IF (iface.EQ.1) THEN
+ aa=1
+ ELSEIF (iface.EQ.2) THEN
+ bb=1
+ ELSEIF (iface.EQ.3) THEN
+ cc=1
+ ELSEIF (iface.EQ.4) THEN
+ dd=1
+ ENDIF
+ ENDIF
+ ENDDO !iface
+ ENDIF !periodic
+ ENDDO
E =-HUGE(E)
DO isub=1,nsubs
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1),istop(1,isub,1)
+ DO j=start(2,isub,1)+cc,stop(2,isub,1)-dd
+ DO i=start(1,isub,1)+aa,stop(1,isub,1)-bb
res = (u(i-1,j,isub)+u(i+1,j,isub))*c2 + &
& (u(i,j-1,isub)+u(i,j+1,isub))*c3 - &
& u(i,j,isub)*c4-f(i,j,isub)
+
+ E = MAX(E,abs(res))
+ mgfield(isub,1)%err(i,j)=-res
+ mgfield(isub,1)%uc(i,j)=u(i,j,isub)
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSEIF (order.EQ.ppm_param_order_4) THEN
+
+ c22=c2/12.0_MK
+ c33=c3/12.0_MK
+ c44=c4*1.25_MK
+
+
+ E =-HUGE(E)
+ DO isub=1,nsubs
+ DO j=start(2,isub,1),stop(2,isub,1)
+ DO i=start(1,isub,1),stop(1,isub,1)
+ res = (16.0_MK*u(i-1,j,isub)+&
+ & 16.0_MK*u(i+1,j,isub)-&
+ & u(i-2,j,isub)-u(i+2,j,isub))*c22 + &
+ & (16.0_MK*u(i,j-1,isub)+16.0_MK*u(i,j+1,isub)-&
+ & u(i,j-2,isub)-u(i,j+2,isub))*c33 - &
+ & u(i,j,isub)*c44-f(i,j,isub)
+
E = MAX(E,abs(res))
mgfield(isub,1)%err(i,j)=-res
mgfield(isub,1)%uc(i,j)=u(i,j,isub)
ENDDO
ENDDO
ENDDO
+
+
+ ENDIF
+
+
+
+
#elif __MESH_DIM == __3D
+
!-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
- E =-HUGE(E)
+ !-----------------------------------------------------------------------
+
DO isub=1,nsubs
aa=0
bb=0
@@ -281,11 +351,12 @@
dd=0
ee=0
gg=0
+
IF (.NOT.lperiodic) THEN
DO iface=1,6
- IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
!DO NOTHING
- ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
IF (iface.EQ.1) THEN
aa=1
ELSEIF (iface.EQ.2) THEN
@@ -298,13 +369,17 @@
ee=1
ELSEIF (iface.EQ.6) Then
gg=1
- ENDIF
+ ENDIF
ENDIF
ENDDO !iface
ENDIF !periodic
- DO k=start(3,isub,1)+ee,istop(3,isub,1)-gg
- DO j=start(2,isub,1)+cc,istop(2,isub,1)-dd
- DO i=start(1,isub,1)+aa,istop(1,isub,1)-bb
+ ENDDO
+
+ E =-HUGE(E)
+ DO isub=1,nsubs
+ DO k=start(3,isub,1)+ee,stop(3,isub,1)-gg
+ DO j=start(2,isub,1)+cc,stop(2,isub,1)-dd
+ DO i=start(1,isub,1)+aa,stop(1,isub,1)-bb
res = (u(i-1,j,k,isub)+u(i+1,j,k,isub))*c2 + &
& (u(i,j-1,k,isub)+u(i,j+1,k,isub))*c3 + &
& (u(i,j,k-1,isub)+u(i,j,k+1,isub))*c4 - &
@@ -316,20 +391,51 @@
ENDDO
ENDDO
ENDDO
+
+
+
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
+
+ DO isub=1,nsubs
+ DO ilda=1,vecdim
+ aa=0
+ bb=0
+ cc=0
+ dd=0
+
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,4
+ IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ IF (iface.EQ.1) THEN
+ aa=1
+ ELSEIF (iface.EQ.2) THEN
+ bb=1
+ ELSEIF (iface.EQ.3) THEN
+ cc=1
+ ELSEIF (iface.EQ.4) THEN
+ dd=1
+ ENDIF
+ ENDIF
+ ENDDO !iface
+ ENDIF !periodic
+ ENDDO
+ ENDDO
!-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
E =-HUGE(E)
DO isub=1,nsubs
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1),istop(1,isub,1)
+ DO j=start(2,isub,1)+cc,stop(2,isub,1)-dd
+ DO i=start(1,isub,1)+aa,stop(1,isub,1)-bb
DO ilda=1,vecdim
res = (u(ilda,i-1,j,isub)+u(ilda,i+1,j,isub))*c2 + &
& (u(ilda,i,j-1,isub)+u(ilda,i,j+1,isub))*c3 - &
& u(ilda,i,j,isub)*c4-f(ilda,i,j,isub)
+
E = MAX(E,abs(res))
mgfield(isub,1)%err(ilda,i,j)=-res
mgfield(isub,1)%uc(ilda,i,j)=u(ilda,i,j,isub)
@@ -337,11 +443,18 @@
ENDDO
ENDDO
ENDDO
+
+
+
#elif __MESH_DIM == __3D
+
!-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
- E =-HUGE(E)
+ !-----------------------------------------------------------------------
+
+
+ IF (order.EQ.ppm_param_order_2) THEN
+
DO isub=1,nsubs
aa=0
bb=0
@@ -350,6 +463,7 @@
ee=0
gg=0
DO ilda=1,vecdim
+
IF (.NOT.lperiodic) THEN
DO iface=1,6
IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
@@ -367,43 +481,60 @@
ee=1
ELSEIF (iface.EQ.6) Then
gg=1
- ENDIF
+ ENDIF
ENDIF
ENDDO !iface
ENDIF !periodic
ENDDO
- DO k=start(3,isub,1)+ee,istop(3,isub,1)-gg
- DO j=start(2,isub,1)+cc,istop(2,isub,1)-dd
- DO i=start(1,isub,1)+aa,istop(1,isub,1)-bb
+ !ENDDO
+
+
+ E =-HUGE(E)
+ !DO isub=1,nsubs
+ DO k=start(3,isub,1)+ee,stop(3,isub,1)-gg
+ DO j=start(2,isub,1)+cc,stop(2,isub,1)-dd
+ DO i=start(1,isub,1)+aa,stop(1,isub,1)-bb
#ifdef __VECTOR
res = (u(1,i-1,j,k,isub)+u(1,i+1,j,k,isub))*c2 +&
& (u(1,i,j-1,k,isub)+u(1,i,j+1,k,isub))*c3 +&
& (u(1,i,j,k-1,isub)+u(1,i,j,k+1,isub))*c4 -&
& u(1,i,j,k,isub)*c5-f(1,i,j,k,isub)
+
E = MAX(E,abs(res))
mgfield(isub,1)%err(1,i,j,k)=-res
mgfield(isub,1)%uc(1,i,j,k)=u(1,i,j,k,isub)
+
res = (u(2,i-1,j,k,isub)+u(2,i+1,j,k,isub))*c2 +&
& (u(2,i,j-1,k,isub)+u(2,i,j+1,k,isub))*c3 +&
& (u(2,i,j,k-1,isub)+u(2,i,j,k+1,isub))*c4 -&
& u(2,i,j,k,isub)*c5-f(2,i,j,k,isub)
+
E = MAX(E,abs(res))
mgfield(isub,1)%err(2,i,j,k)=-res
mgfield(isub,1)%uc(2,i,j,k)=u(2,i,j,k,isub)
+
+
res = (u(3,i-1,j,k,isub)+u(3,i+1,j,k,isub))*c2 +&
& (u(3,i,j-1,k,isub)+u(3,i,j+1,k,isub))*c3 +&
& (u(3,i,j,k-1,isub)+u(3,i,j,k+1,isub))*c4 -&
& u(3,i,j,k,isub)*c5-f(3,i,j,k,isub)
+
E = MAX(E,abs(res))
mgfield(isub,1)%err(3,i,j,k)=-res
mgfield(isub,1)%uc(3,i,j,k)=u(3,i,j,k,isub)
+
#else
DO ilda=1,vecdim
res = (u(ilda,i-1,j,k,isub)+u(ilda,i+1,j,k,isub))*c2 +&
& (u(ilda,i,j-1,k,isub)+u(ilda,i,j+1,k,isub))*c3 +&
& (u(ilda,i,j,k-1,isub)+u(ilda,i,j,k+1,isub))*c4 -&
& u(ilda,i,j,k,isub)*c5-f(ilda,i,j,k,isub)
+
E = MAX(E,abs(res))
+ IF (ilda.EQ.1.AND.ABS(res).GT.0.0) THEN
+
+ !PRINT *,'RES:',res,i,j,k,isub
+ ENDIF
mgfield(isub,1)%err(ilda,i,j,k)=-res
mgfield(isub,1)%uc(ilda,i,j,k)=u(ilda,i,j,k,isub)
ENDDO
@@ -412,15 +543,21 @@
ENDDO
ENDDO
ENDDO
+
+ ELSEIF (order.EQ.ppm_param_order_4) THEN
+
+ ENDIF
+
#endif
#endif
- !----------------------------------------------------------------------
+
+
+ !----------------------------------------------------------------------
! Return
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
9999 CONTINUE
CALL substop('ppm_mg_res',t0,info)
RETURN
-
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -450,3 +587,7 @@
#endif
#endif
#endif
+
+
+
+
diff --git a/src/ppm_mg_restrict.f b/src/ppm_mg_restrict.f
index 1a95e8f..cf042e0 100644
--- a/src/ppm_mg_restrict.f
+++ b/src/ppm_mg_restrict.f
@@ -1,120 +1,118 @@
- !----------------------------------------------------------------------
- ! Subroutine : ppm_mg_restrict
- !----------------------------------------------------------------------
- ! Purpose : In this routine we restrict the error from finer
- ! to coarser levels
- !
- !
- ! Input :
- !
- ! Input/output :
- !
- ! Output : info (I) return status. 0 upon success
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !----------------------------------------------------------------------
- ! $Log: ppm_mg_restrict.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.12 2006/09/26 16:01:23 ivos
- ! Fixed wrongly indented CPP directives. Remember: they have to start in
- ! Col 1, otherwise it does not compile on certain systems. In fact, this
- ! code did NOT compile as it was!!
- !
- ! Revision 1.11 2006/07/21 11:30:55 kotsalie
- ! FRIDAY
- !
- ! Revision 1.9 2006/02/08 19:55:29 kotsalie
- ! fixed multiple domains
- !
- ! Revision 1.8 2006/02/02 18:00:19 michaebe
- ! corrected bug in the log
- !
- ! Revision 1.7 2006/02/02 16:32:28 kotsalie
- ! corrected for mixed BC''s
- !
- ! Revision 1.6 2005/12/08 12:44:45 kotsalie
- ! commiting dirichlet
- !
- ! Revision 1.4 2005/03/14 13:18:22 kotsalie
- ! COMMITED THE VECTOR CASE. IT IS FOR LDA=3
- !
- ! Revision 1.3 2004/11/05 15:20:01 kotsalie
- ! Commited the changes for speedup
- !
- ! Revision 1.2 2004/09/23 12:16:50 kotsalie
- ! Added USE statement
- !
- ! Revision 1.1 2004/09/22 18:38:03 kotsalie
- ! MG new version
- !
- !----------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+ ! Subroutine : ppm_mg_restrict
+ !-----------------------------------------------------------------------
+ ! Purpose : In this routine we restrict the error from finer
+ ! to coarser levels
+ !
+ !
+ ! Input :
+ !
+ ! Input/output :
+ !
+ ! Output : info (I) return status. 0 upon success
+ !
+ ! Remarks :
+ !
+ ! References :
+ !
+ ! Revisions :
+ !-------------------------------------------------------------------------
+ ! $Log: ppm_mg_restrict.f,v $
+ ! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+ ! initial import
+ !
+ ! Revision 1.9 2006/02/08 19:55:29 kotsalie
+ ! fixed multiple domains
+ !
+ ! Revision 1.8 2006/02/02 18:00:19 michaebe
+ ! corrected bug in the log
+ !
+ ! Revision 1.7 2006/02/02 16:32:28 kotsalie
+ ! corrected for mixed BC''s
+ !
+ ! Revision 1.6 2005/12/08 12:44:45 kotsalie
+ ! commiting dirichlet
+ !
+ ! Revision 1.4 2005/03/14 13:18:22 kotsalie
+ ! COMMITED THE VECTOR CASE. IT IS FOR LDA=3
+ !
+ ! Revision 1.3 2004/11/05 15:20:01 kotsalie
+ ! Commited the changes for speedup
+ !
+ ! Revision 1.2 2004/09/23 12:16:50 kotsalie
+ ! Added USE statement
+ !
+ ! Revision 1.1 2004/09/22 18:38:03 kotsalie
+ ! MG new version
+ !
+ !-----------------------------------------------------------------------
+ ! Parallel Particle Mesh Library (PPM)
+ ! Institute of Computational Science
+ ! ETH Zentrum, Hirschengraben 84
+ ! CH-8092 Zurich, Switzerland
+ !-----------------------------------------------------------------------
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_restrict_2d_sca_s(field_topoid,mlev,info)
+ SUBROUTINE ppm_mg_restrict_2d_sca_s(topo_id,mlev,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_restrict_2d_sca_d(field_topoid,mlev,info)
+ SUBROUTINE ppm_mg_restrict_2d_sca_d(topo_id,mlev,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_restrict_3d_sca_s(field_topoid,mlev,info)
+ SUBROUTINE ppm_mg_restrict_3d_sca_s(topo_id,mlev,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_restrict_3d_sca_d(field_topoid,mlev,info)
+ SUBROUTINE ppm_mg_restrict_3d_sca_d(topo_id,mlev,info)
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_restrict_2d_vec_s(field_topoid,mlev,info)
+ SUBROUTINE ppm_mg_restrict_2d_vec_s(topo_id,mlev,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_restrict_2d_vec_d(field_topoid,mlev,info)
+ SUBROUTINE ppm_mg_restrict_2d_vec_d(topo_id,mlev,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_restrict_3d_vec_s(field_topoid,mlev,info)
+ SUBROUTINE ppm_mg_restrict_3d_vec_s(topo_id,mlev,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_restrict_3d_vec_d(field_topoid,mlev,info)
+ SUBROUTINE ppm_mg_restrict_3d_vec_d(topo_id,mlev,info)
#endif
#endif
#endif
- !-----------------------------------------------------------------------
+ !---------------------------------------------------------------------
! Includes
- !-----------------------------------------------------------------------
+ !-----------------------------------------------------------------
#include "ppm_define.h"
- !-----------------------------------------------------------------------
+
+ !----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------
USE ppm_module_data
- USE ppm_module_data_mg
+ USE ppm_module_write
USE ppm_module_substart
USE ppm_module_substop
+ USE ppm_module_data_mg
USE ppm_module_error
USE ppm_module_alloc
+ USE ppm_module_map
+
+
IMPLICIT NONE
#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
+ INTEGER, PARAMETER :: MK = ppm_kind_single
#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
+ INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
! Arguments
- !-----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: mlev,field_topoid
+ !----------------------------------------------------------------------
+ INTEGER, INTENT(IN) :: mlev, topo_id
INTEGER, INTENT(INOUT) :: info
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
! Local variables
- !-----------------------------------------------------------------------
+ !---------------------------------------------------------------------
CHARACTER(LEN=256) :: cbuf
INTEGER :: isub,j,j2,i,i2
INTEGER :: mlevm1,ilda,iface
@@ -122,92 +120,100 @@
INTEGER,DIMENSION(4) :: ldl4,ldu4
INTEGER,DIMENSION(3) :: ldl3,ldu3
INTEGER :: iopt,topoid
- INTEGER :: a,b,c,d,e,f,g
+ INTEGER :: a,b,c,d,e,f,g
#if __MESH_DIM == __3D
INTEGER :: k,k2
#endif
REAL(MK) :: t0
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#endif
#endif
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: uc_dummy
+ REAL(MK),DIMENSION(:,:,:),POINTER :: uc_dummy
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc_dummy
+ REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc_dummy
#endif
#endif
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: terr
- REAL(MK),DIMENSION(:,:),POINTER :: pfc
+ REAL(MK),DIMENSION(:,:),POINTER :: terr
+ REAL(MK),DIMENSION(:,:),POINTER :: pfc
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: terr
- REAL(MK),DIMENSION(:,:,:),POINTER :: pfc
+ REAL(MK),DIMENSION(:,:,:),POINTER :: terr
+ REAL(MK),DIMENSION(:,:,:),POINTER :: pfc
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: terr
- REAL(MK),DIMENSION(:,:,:),POINTER :: pfc
+ REAL(MK),DIMENSION(:,:,:),POINTER :: terr
+ REAL(MK),DIMENSION(:,:,:),POINTER :: pfc
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: terr
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: pfc
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: terr
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: pfc
#endif
#endif
- !----------------------------------------------------------------------
+
+
+ !-----------------------------------------------------------------------
!Externals
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
!Initialize
- !----------------------------------------------------------------------
- CALL substart('ppm_mg_restrict',t0,info)
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+
+ CALL substart('ppm_mg_restrict',t0,info)
+
+
+ !-----------------------------------------------------------------------
! Check arguments
- !----------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (mlev.LE.1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_restrict', &
- & 'level must be >1',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+ IF (ppm_debug .GT. 0) THEN
+ IF (mlev.LE.1) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_mg_restrict', &
+ & 'level must be >1',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ ENDIF
+ !-----------------------------------------------------------------------
!Definition of necessary variables and allocation of arrays
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -237,580 +243,709 @@
#endif
#endif
#endif
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
!Implementation
- !----------------------------------------------------------------------
- mlevm1=mlev-1
- IF (l_print) THEN
- WRITE(cbuf,*) 'WELCOME TO THE RESTRICTION LEVEL:',mlev
- CALL PPM_WRITE(ppm_rank,'mg_restrict',cbuf,info)
- ENDIF
+ !-----------------------------------------------------------------------
+
+ mlevm1=mlev-1
+ IF (l_print) THEN
+ WRITE(cbuf,*) 'WELCOME TO THE RESTRICTION LEVEL:',mlev
+ CALL PPM_WRITE(ppm_rank,'mg_restrict',cbuf,info)
+ ENDIF
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
!----------------------------------------------------------------------
!Restriction using a 9-point operator(bilinear interpolation)
!linear is not accurate enough
- !----------------------------------------------------------------------
- topoid=field_topoid
- iopt = ppm_param_alloc_fit
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1
- ldu3(1) = max_node(1,mlevm1)+ghostsize(1)
- ldu3(2) = max_node(2,mlevm1)+ghostsize(2)
- ldu3(3) = nsubs
- CALL ppm_alloc(uc_dummy,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'restrict', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isub=1,nsubs
- terr=>mgfield(isub,mlevm1)%err
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- uc_dummy(i,j,isub)=&
- & terr(i,j)
- ENDDO
- ENDDO
- ENDDO
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_pop,info)
- DO isub=1,nsubs
- terr=>mgfield(isub,mlevm1)%err
- pfc=>mgfield(isub,mlev)%fc
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- terr(i,j)=&
- & uc_dummy(i,j,isub)
- ENDDO
- ENDDO
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- j2=2*j
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- i2=2*i
- pfc(i,j)= &
- & 0.25_MK * terr(i2-1,j2-1) + &
- & 0.125_MK * (terr(i2,j2-1) + &
- & terr(i2-2,j2-1)+ &
- & terr(i2-1,j2) + &
- & terr(i2-1,j2-2))+&
- & 0.0625_MK * (terr(i2,j2-2)+&
- & terr(i2-2,j2) + &
- & terr(i2-2,j2-2)&
- & + terr(i2,j2))
+ !----------------------------------------------------------------------
+
+
+ topoid=topo_id
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1
+ ldu3(1) = max_node(1,mlevm1)+ghostsize(1)
+ ldu3(2) = max_node(2,mlevm1)+ghostsize(2)
+ ldu3(3) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'restrict', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ DO isub=1,nsubs
+
+ terr=>mgfield(isub,mlevm1)%err
+ uc_dummy(:,:,isub)=&
+ & terr(:,:)
+ ENDDO
+
+
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_ghost_get,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_push,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_pop,info)
+
+
+ DO isub=1,nsubs
+ terr=>mgfield(isub,mlevm1)%err
+ pfc=>mgfield(isub,mlev)%fc
+ terr(:,:)=uc_dummy(&
+ & :,:,isub)
+
+ !-----------------------------------------------------------------
+ !MICHAEL
+ !----------------------------------------------------------------
+ a=0
+ b=0
+ c=0
+ d=0
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,2*ppm_dim
+ IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+
+ IF (iface.EQ.1) THEN
+ a=1
+ ELSEIF (iface.EQ.2) THEN
+ b=1
+ ELSEIF (iface.EQ.3) THEN
+ c=1
+ ELSEIF (iface.EQ.4) THEN
+ d=1
+ ENDIF
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+ !DO NOTHING.HERE WE RESTRICT THE BOUNDARY AS WELL
+ ENDIF
+ ENDDO
+ ENDIF
+
+
+
+
+ DO j=start(2,isub,mlev)+c,stop(2,isub,mlev)-d
+ j2=2*j
+ DO i=start(1,isub,mlev)+a,stop(1,isub,mlev)-b
+ i2=2*i
+ pfc(i,j)= &
+ & 0.25_MK * terr(i2-1,j2-1) + &
+ & 0.125_MK * (terr(i2,j2-1) + &
+ & terr(i2-2,j2-1)+ &
+ & terr(i2-1,j2) + &
+ & terr(i2-1,j2-2))+&
+ & 0.0625_MK * (terr(i2,j2-2)+&
+ & terr(i2-2,j2) + &
+ & terr(i2-2,j2-2)&
+ & + terr(i2,j2))
- ENDDO
ENDDO
ENDDO
- iopt = ppm_param_dealloc
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1
- ldu3(1) = max_node(1,mlevm1)+ghostsize(1)
- ldu3(2) = max_node(2,mlevm1)+ghostsize(2)
- ldu3(3) = nsubs
- CALL ppm_alloc(uc_dummy,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'restrict', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+ ENDDO
+
+ iopt = ppm_param_dealloc
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1
+ ldu3(1) = max_node(1,mlevm1)+ghostsize(1)
+ ldu3(2) = max_node(2,mlevm1)+ghostsize(2)
+ ldu3(3) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'restrict', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
#elif __MESH_DIM == __3D
- topoid=field_topoid
- iopt = ppm_param_alloc_fit
- ldl4(1) = 1-ghostsize(1)
- ldl4(2) = 1-ghostsize(2)
- ldl4(3) = 1-ghostsize(3)
- ldl4(4) = 1
- ldu4(1) = max_node(1,mlevm1)+ghostsize(1)
- ldu4(2) = max_node(2,mlevm1)+ghostsize(2)
- ldu4(3) = max_node(3,mlevm1)+ghostsize(3)
- ldu4(4) = nsubs
- CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'restrict', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isub=1,nsubs
+
+ topoid=topo_id
+ iopt = ppm_param_alloc_fit
+ ldl4(1) = 1-ghostsize(1)
+ ldl4(2) = 1-ghostsize(2)
+ ldl4(3) = 1-ghostsize(3)
+ ldl4(4) = 1
+ ldu4(1) = max_node(1,mlevm1)+ghostsize(1)
+ ldu4(2) = max_node(2,mlevm1)+ghostsize(2)
+ ldu4(3) = max_node(3,mlevm1)+ghostsize(3)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'restrict', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ DO isub=1,nsubs
+
+ terr=>mgfield(isub,mlevm1)%err
+ uc_dummy(:,:,:,isub)=&
+ & terr(:,:,:)
+! DO k=1-ghostsize(3),max_node(3,mlevm1)+ghostsize(3)
+! DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
+! DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
+! uc_dummy(i,j,k,isub)=&
+! & terr(i,j,k)
+! ENDDO
+! ENDDO
+! ENDDO
+ ENDDO
+
+
+
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_ghost_get,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_push,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_pop,info)
+
+
+ DO isub=1,nsubs
terr=>mgfield(isub,mlevm1)%err
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- DO k=1-ghostsize(3),max_node(3,mlevm1)+ghostsize(3)
- uc_dummy(i,j,k,isub)=&
- & terr(i,j,k)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_pop,info)
-
-
- DO isub=1,nsubs
- terr=>mgfield(isub,mlevm1)%err
- pfc=>mgfield(isub,mlev)%fc
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- DO k=1-ghostsize(3),max_node(3,mlevm1)+ghostsize(3)
- terr(i,j,k)=&
- & uc_dummy(i,j,k,isub)
+ pfc=>mgfield(isub,mlev)%fc
+ terr(:,:,:)=uc_dummy(&
+ & :,:,:,isub)
+
+! DO k=1-ghostsize(3),max_node(3,mlevm1)+ghostsize(3)
+! DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
+! DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
+!
+! terr(i,j,k)=&
+! & uc_dummy(i,j,k,isub)
+!
+! ENDDO
+! ENDDO
+! ENDDO
+ ! Input Boundary conditions
+ a=0
+ b=0
+ c=0
+ d=0
+ e=0
+ f=0
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,2*ppm_dim
+ IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+
+ IF (iface.EQ.1) THEN
+ a=1
+ ELSEIF (iface.EQ.2) THEN
+ b=1
+ ELSEIF (iface.EQ.3) THEN
+ c=1
+ ELSEIF (iface.EQ.4) THEN
+ d=1
+ ELSEIF (iface.EQ.5) Then
+ e=1
+ ELSEIF (iface.EQ.6) THEN
+ f=1
+ ENDIF
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+ !DO NOTHING.HERE WE RESTRICT THE BOUNDARY AS WELL
+ ENDIF
ENDDO
- ENDDO
- ENDDO
- DO k=start(3,isub,mlev),istop(3,isub,mlev)
- k2=2*k
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- j2=2*j
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- i2=2*i
- pfc(i,j,k)= &
- & 0.125_MK * &
- & terr(i2-1,j2-1,k2-1) + &
- & 0.0625_MK * (&
- & terr(i2,j2-1,k2-1) +&
- & terr(i2-2,j2-1,k2-1)+ &
- & terr(i2-1,j2,k2-1) + &
- & terr(i2-1,j2-2,k2-1))+&
- & 0.03125_MK * (&
- & terr(i2,j2-2,k2-1)+ &
- & terr(i2-2,j2,k2-1) + &
- & terr(i2-2,j2-2,k2-1) +&
- & terr(i2,j2,k2-1))
-
- pfc(i,j,k)= &
- & pfc(i,j,k)+&
- & 0.0625_MK * &
- & terr(i2-1,j2-1,k2) + &
- & 0.03125_MK * (&
- terr(i2,j2-1,k2) +&
- & terr(i2-2,j2-1,k2)+ &
- & terr(i2-1,j2,k2) +&
- & terr(i2-1,j2-2,k2))+&
- & 0.015625_MK * (&
- & terr(i2,j2-2,k2)+ &
- & terr(i2-2,j2,k2) + &
- & terr(i2-2,j2-2,k2) + &
- & terr(i2,j2,k2))
-
- pfc(i,j,k)= &
- & pfc(i,j,k) +&
- & 0.0625_MK * &
- & terr(i2-1,j2-1,k2-2) + &
- & 0.03125_MK *(&
- & terr(i2,j2-1,k2-2) +&
- & terr(i2-2,j2-1,k2-2)+ &
- & terr(i2-1,j2,k2-2)+&
- & terr(i2-1,j2-2,k2-2))+&
- & 0.015625_MK*(&
- & terr(i2,j2-2,k2-2)+&
- & terr(i2-2,j2,k2-2) + &
- & terr(i2-2,j2-2,k2-2)+&
- & terr(i2,j2,k2-2))
- ENDDO
- ENDDO
+ ENDIF
+ DO k=start(3,isub,mlev)+a,stop(3,isub,mlev)-b
+ k2=2*k
+ DO j=start(2,isub,mlev)+c,stop(2,isub,mlev)-d
+ j2=2*j
+ DO i=start(1,isub,mlev)+e,stop(1,isub,mlev)-f
+ i2=2*i
+ pfc(i,j,k)= &
+ & 0.125_MK * &
+ & terr(i2-1,j2-1,k2-1) + &
+ & 0.0625_MK * (&
+ & terr(i2,j2-1,k2-1) +&
+ & terr(i2-2,j2-1,k2-1)+ &
+ & terr(i2-1,j2,k2-1) + &
+ & terr(i2-1,j2-2,k2-1))+&
+ & 0.03125_MK * (&
+ & terr(i2,j2-2,k2-1)+ &
+ & terr(i2-2,j2,k2-1) + &
+ & terr(i2-2,j2-2,k2-1) +&
+ & terr(i2,j2,k2-1))
+
+ pfc(i,j,k)= &
+ & pfc(i,j,k)+&
+ & 0.0625_MK * &
+ & terr(i2-1,j2-1,k2) + &
+ & 0.03125_MK * (&
+ terr(i2,j2-1,k2) +&
+ & terr(i2-2,j2-1,k2)+ &
+ & terr(i2-1,j2,k2) +&
+ & terr(i2-1,j2-2,k2))+&
+ & 0.015625_MK * (&
+ & terr(i2,j2-2,k2)+ &
+ & terr(i2-2,j2,k2) + &
+ & terr(i2-2,j2-2,k2) + &
+ & terr(i2,j2,k2))
+
+ pfc(i,j,k)= &
+ & pfc(i,j,k) +&
+ & 0.0625_MK * &
+ & terr(i2-1,j2-1,k2-2) + &
+ & 0.03125_MK *(&
+ & terr(i2,j2-1,k2-2) +&
+ & terr(i2-2,j2-1,k2-2)+ &
+ & terr(i2-1,j2,k2-2)+&
+ & terr(i2-1,j2-2,k2-2))+&
+ & 0.015625_MK*(&
+ & terr(i2,j2-2,k2-2)+&
+ & terr(i2-2,j2,k2-2) + &
+ & terr(i2-2,j2-2,k2-2)+&
+ & terr(i2,j2,k2-2))
+ ENDDO
ENDDO
ENDDO
- iopt = ppm_param_dealloc
- ldl4(1) = 1-ghostsize(1)
- ldl4(2) = 1-ghostsize(2)
- ldl4(3) = 1-ghostsize(3)
- ldl4(4) = 1
- ldu4(1) = max_node(1,mlevm1)+ghostsize(1)
- ldu4(2) = max_node(2,mlevm1)+ghostsize(2)
- ldu4(3) = max_node(3,mlevm1)+ghostsize(3)
- ldu4(4) = nsubs
- CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'restrict', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+ ENDDO
+
+ iopt = ppm_param_dealloc
+ ldl4(1) = 1-ghostsize(1)
+ ldl4(2) = 1-ghostsize(2)
+ ldl4(3) = 1-ghostsize(3)
+ ldl4(4) = 1
+ ldu4(1) = max_node(1,mlevm1)+ghostsize(1)
+ ldu4(2) = max_node(2,mlevm1)+ghostsize(2)
+ ldu4(3) = max_node(3,mlevm1)+ghostsize(3)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'restrict', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
!----------------------------------------------------------------------
!Restriction using a 9-point operator(bilinear interpolation)
!linear is not accurate enough
- !---------------------------------------------------------------------
- topoid=field_topoid
- iopt = ppm_param_alloc_fit
- ldl4(1) = 1
- ldl4(2) = 1-ghostsize(1)
- ldl4(3) = 1-ghostsize(2)
- ldl4(4) = 1
- ldu4(1) = vecdim
- ldu4(2) = max_node(1,mlevm1)+ghostsize(1)
- ldu4(3) = max_node(2,mlevm1)+ghostsize(2)
- ldu4(4) = nsubs
- CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'restrict', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isub=1,nsubs
- terr=>mgfield(isub,mlevm1)%err
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- DO ilda=1,vecdim
- uc_dummy(ilda,i,j,isub)=&
- & terr(ilda,i,j)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_pop,info)
- DO isub=1,nsubs
- terr=>mgfield(isub,mlevm1)%err
- pfc=>mgfield(isub,mlev)%fc
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- DO ilda=1,vecdim
- terr(ilda,i,j)=&
- & uc_dummy(ilda,i,j,isub)
- ENDDO
- ENDDO
- ENDDO
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- j2=2*j
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
+ !----------------------------------------------------------------------
+
+
+ topoid=topo_id
+ iopt = ppm_param_alloc_fit
+ ldl4(1) = 1
+ ldl4(2) = 1-ghostsize(1)
+ ldl4(3) = 1-ghostsize(2)
+ ldl4(4) = 1
+ ldu4(1) = vecdim
+ ldu4(2) = max_node(1,mlevm1)+ghostsize(1)
+ ldu4(3) = max_node(2,mlevm1)+ghostsize(2)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'restrict', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ DO isub=1,nsubs
+ terr=>mgfield(isub,mlevm1)%err
+ uc_dummy(:,:,:,isub)=&
+ & terr(:,:,:)
+ ENDDO
+
+
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_ghost_get,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_push,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_pop,info)
+
+
+ DO isub=1,nsubs
+ terr=>mgfield(isub,mlevm1)%err
+ pfc=>mgfield(isub,mlev)%fc
+ terr(:,:,:)=uc_dummy(&
+ & :,:,:,isub)
+
+
+
+ DO j=start(2,isub,mlev),stop(2,isub,mlev)
+ j2=2*j
+ DO i=start(1,isub,mlev),stop(1,isub,mlev)
i2=2*i
- DO ilda=1,vecdim
- pfc(ilda,i,j)= &
- & 0.25_MK * terr(ilda,i2-1,j2-1) + &
- & 0.125_MK * (terr(ilda,i2,j2-1) + &
- & terr(ilda,i2-2,j2-1)+ &
- & terr(ilda,i2-1,j2) + &
- & terr(ilda,i2-1,j2-2))+&
- & 0.0625_MK * (terr(ilda,i2,j2-2)+&
- & terr(ilda,i2-2,j2) + &
- & terr(ilda,i2-2,j2-2)&
- & + terr(ilda,i2,j2))
- ENDDO
+ DO ilda=1,vecdim
+ pfc(ilda,i,j)= &
+ & 0.25_MK * terr(ilda,i2-1,j2-1) + &
+ & 0.125_MK * (terr(ilda,i2,j2-1) + &
+ & terr(ilda,i2-2,j2-1)+ &
+ & terr(ilda,i2-1,j2) + &
+ & terr(ilda,i2-1,j2-2))+&
+ & 0.0625_MK * (terr(ilda,i2,j2-2)+&
+ & terr(ilda,i2-2,j2) + &
+ & terr(ilda,i2-2,j2-2)&
+ & + terr(ilda,i2,j2))
+
+ ENDDO
ENDDO
- ENDDO
- ENDDO
- iopt = ppm_param_dealloc
- ldl4(1) = 1
- ldl4(2) = 1-ghostsize(1)
- ldl4(3) = 1-ghostsize(2)
- ldl4(4) = 1
- ldu4(1) = vecdim
- ldu4(2) = max_node(1,mlevm1)+ghostsize(1)
- ldu4(3) = max_node(2,mlevm1)+ghostsize(2)
- ldu4(4) = nsubs
- CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'restrict', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+ ENDDO
+ ENDDO
+
+
+ iopt = ppm_param_dealloc
+ ldl4(1) = 1
+ ldl4(2) = 1-ghostsize(1)
+ ldl4(3) = 1-ghostsize(2)
+ ldl4(4) = 1
+ ldu4(1) = vecdim
+ ldu4(2) = max_node(1,mlevm1)+ghostsize(1)
+ ldu4(3) = max_node(2,mlevm1)+ghostsize(2)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'restrict', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
#elif __MESH_DIM == __3D
- topoid=field_topoid
- iopt = ppm_param_alloc_fit
- ldl5(1) = 1
- ldl5(2) = 1-ghostsize(1)
- ldl5(3) = 1-ghostsize(2)
- ldl5(4) = 1-ghostsize(3)
- ldl5(5) = 1
- ldu5(1) = vecdim
- ldu5(2) = max_node(1,mlevm1)+ghostsize(1)
- ldu5(3) = max_node(2,mlevm1)+ghostsize(2)
- ldu5(4) = max_node(3,mlevm1)+ghostsize(3)
- ldu5(5) = nsubs
- CALL ppm_alloc(uc_dummy,ldl5,ldu5,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'restrict', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isub=1,nsubs
- terr=>mgfield(isub,mlevm1)%err
- DO k=1-ghostsize(3),max_node(3,mlevm1)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
+
+ topoid=topo_id
+ iopt = ppm_param_alloc_fit
+ ldl5(1) = 1
+ ldl5(2) = 1-ghostsize(1)
+ ldl5(3) = 1-ghostsize(2)
+ ldl5(4) = 1-ghostsize(3)
+ ldl5(5) = 1
+ ldu5(1) = vecdim
+ ldu5(2) = max_node(1,mlevm1)+ghostsize(1)
+ ldu5(3) = max_node(2,mlevm1)+ghostsize(2)
+ ldu5(4) = max_node(3,mlevm1)+ghostsize(3)
+ ldu5(5) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl5,ldu5,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'restrict', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ DO isub=1,nsubs
+
+ terr=>mgfield(isub,mlevm1)%err
+ DO k=1-ghostsize(3),max_node(3,mlevm1)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
#ifdef __VECTOR
- uc_dummy(1,i,j,k,isub)=&
- & terr(1,i,j,k)
- uc_dummy(2,i,j,k,isub)=&
- & terr(2,i,j,k)
- uc_dummy(3,i,j,k,isub)=&
- & terr(3,i,j,k)
+ uc_dummy(1,i,j,k,isub)=&
+ & terr(1,i,j,k)
+ uc_dummy(2,i,j,k,isub)=&
+ & terr(2,i,j,k)
+ uc_dummy(3,i,j,k,isub)=&
+ & terr(3,i,j,k)
#else
- DO ilda=1,vecdim
- uc_dummy(ilda,i,j,k,isub)=&
- & terr(ilda,i,j,k)
+ DO ilda=1,vecdim
+ uc_dummy(ilda,i,j,k,isub)=&
+ & terr(ilda,i,j,k)
#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
- & ghostsize,ppm_param_map_pop,info)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+
+
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_ghost_get,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_push,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlevm1),&
+ & ghostsize,ppm_param_map_pop,info)
+
+
DO isub=1,nsubs
- terr=>mgfield(isub,mlevm1)%err
- pfc=>mgfield(isub,mlev)%fc
+ terr=>mgfield(isub,mlevm1)%err
+ pfc=>mgfield(isub,mlev)%fc
- DO k=1-ghostsize(3),max_node(3,mlevm1)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
+ DO k=1-ghostsize(3),max_node(3,mlevm1)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
#ifdef __VECTOR
- terr(1,i,j,k)=&
- & uc_dummy(1,i,j,k,isub)
- terr(2,i,j,k)=&
- & uc_dummy(2,i,j,k,isub)
- terr(3,i,j,k)=&
- & uc_dummy(3,i,j,k,isub)
+ terr(1,i,j,k)=&
+ & uc_dummy(1,i,j,k,isub)
+ terr(2,i,j,k)=&
+ & uc_dummy(2,i,j,k,isub)
+ terr(3,i,j,k)=&
+ & uc_dummy(3,i,j,k,isub)
#else
- DO ilda=1,vecdim
- terr(ilda,i,j,k)=&
- & uc_dummy(ilda,i,j,k,isub)
+ DO ilda=1,vecdim
+
+ terr(ilda,i,j,k)=&
+ & uc_dummy(ilda,i,j,k,isub)
#endif
- ENDDO
- ENDDO
- ENDDO
ENDDO
- DO k=start(3,isub,mlev),istop(3,isub,mlev)
- k2=2*k
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- j2=2*j
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- i2=2*i
+ ENDDO
+ ENDDO
+ ENDDO
+ a=0
+ b=0
+ c=0
+ d=0
+ e=0
+ g=0
+ Do ilda=1,vecdim
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,2*ppm_dim
+ IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+
+ IF (iface.EQ.1) THEN
+ a=0
+ ELSEIF (iface.EQ.2) THEN
+ b=0
+ ELSEIF (iface.EQ.3) THEN
+ c=0
+ ELSEIF (iface.EQ.4) THEN
+ d=0
+ ELSEIF (iface.EQ.5) Then
+ e=0
+ ELSEIF (iface.EQ.6) THEN
+ g=0
+ ENDIF
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ DO k=start(3,isub,mlev)+e,stop(3,isub,mlev)-g
+ k2=2*k
+ DO j=start(2,isub,mlev)+c,stop(2,isub,mlev)-d
+ j2=2*j
+ DO i=start(1,isub,mlev)+a,stop(1,isub,mlev)-b
+ i2=2*i
#ifdef __VECTOR
- pfc(1,i,j,k)= &
- & 0.125_MK * &
- & terr(1,i2-1,j2-1,k2-1) + &
- & 0.0625_MK * (&
- & terr(1,i2,j2-1,k2-1) +&
- & terr(1,i2-2,j2-1,k2-1)+ &
- & terr(1,i2-1,j2,k2-1) + &
- & terr(1,i2-1,j2-2,k2-1))+&
- & 0.03125_MK * (&
- & terr(1,i2,j2-2,k2-1)+ &
- & terr(1,i2-2,j2,k2-1) + &
- & terr(1,i2-2,j2-2,k2-1) +&
- & terr(1,i2,j2,k2-1))
- pfc(1,i,j,k)= &
- & pfc(1,i,j,k)+&
- & 0.0625_MK * &
- & terr(1,i2-1,j2-1,k2) + &
- & 0.03125_MK * (&
- terr(1,i2,j2-1,k2) +&
- & terr(1,i2-2,j2-1,k2)+ &
- & terr(1,i2-1,j2,k2) +&
- & terr(1,i2-1,j2-2,k2))+&
- & 0.015625_MK * (&
- & terr(1,i2,j2-2,k2)+ &
- & terr(1,i2-2,j2,k2) + &
- & terr(1,i2-2,j2-2,k2) + &
- & terr(1,i2,j2,k2))
- pfc(1,i,j,k)= &
- & pfc(1,i,j,k) +&
- & 0.0625_MK * &
- & terr(1,i2-1,j2-1,k2-2) + &
- & 0.03125_MK *(&
- & terr(1,i2,j2-1,k2-2) +&
- & terr(1,i2-2,j2-1,k2-2)+ &
- & terr(1,i2-1,j2,k2-2)+&
- & terr(1,i2-1,j2-2,k2-2))+&
- & 0.015625_MK*(&
- & terr(1,i2,j2-2,k2-2)+&
- & terr(1,i2-2,j2,k2-2) + &
- & terr(1,i2-2,j2-2,k2-2)+&
- & terr(1,i2,j2,k2-2))
- pfc(2,i,j,k)= &
- & 0.125_MK * &
- & terr(2,i2-1,j2-1,k2-1) + &
- & 0.0625_MK * (&
- & terr(2,i2,j2-1,k2-1) +&
- & terr(2,i2-2,j2-1,k2-1)+ &
- & terr(2,i2-1,j2,k2-1) + &
- & terr(2,i2-1,j2-2,k2-1))+&
- & 0.03125_MK * (&
- & terr(2,i2,j2-2,k2-1)+ &
- & terr(2,i2-2,j2,k2-1) + &
- & terr(2,i2-2,j2-2,k2-1) +&
- & terr(2,i2,j2,k2-1))
- pfc(2,i,j,k)= &
- & pfc(2,i,j,k)+&
- & 0.0625_MK * &
- & terr(2,i2-1,j2-1,k2) + &
- & 0.03125_MK * (&
- terr(2,i2,j2-1,k2) +&
- & terr(2,i2-2,j2-1,k2)+ &
- & terr(2,i2-1,j2,k2) +&
- & terr(2,i2-1,j2-2,k2))+&
- & 0.015625_MK * (&
- & terr(2,i2,j2-2,k2)+ &
- & terr(2,i2-2,j2,k2) + &
- & terr(2,i2-2,j2-2,k2) + &
- & terr(2,i2,j2,k2))
- pfc(2,i,j,k)= &
- & pfc(2,i,j,k) +&
- & 0.0625_MK * &
- & terr(2,i2-1,j2-1,k2-2) + &
- & 0.03125_MK *(&
- & terr(2,i2,j2-1,k2-2) +&
- & terr(2,i2-2,j2-1,k2-2)+ &
- & terr(2,i2-1,j2,k2-2)+&
- & terr(2,i2-1,j2-2,k2-2))+&
- & 0.015625_MK*(&
- & terr(2,i2,j2-2,k2-2)+&
- & terr(2,i2-2,j2,k2-2) + &
- & terr(2,i2-2,j2-2,k2-2)+&
- & terr(2,i2,j2,k2-2))
- pfc(3,i,j,k)= &
- & 0.125_MK * &
- & terr(3,i2-1,j2-1,k2-1) + &
- & 0.0625_MK * (&
- & terr(3,i2,j2-1,k2-1) +&
- & terr(3,i2-2,j2-1,k2-1)+ &
- & terr(3,i2-1,j2,k2-1) + &
- & terr(3,i2-1,j2-2,k2-1))+&
- & 0.03125_MK * (&
- & terr(3,i2,j2-2,k2-1)+ &
- & terr(3,i2-2,j2,k2-1) + &
- & terr(3,i2-2,j2-2,k2-1) +&
- & terr(3,i2,j2,k2-1))
- pfc(3,i,j,k)= &
- & pfc(3,i,j,k)+&
- & 0.0625_MK * &
- & terr(3,i2-1,j2-1,k2) + &
- & 0.03125_MK * (&
- terr(3,i2,j2-1,k2) +&
- & terr(3,i2-2,j2-1,k2)+ &
- & terr(3,i2-1,j2,k2) +&
- & terr(3,i2-1,j2-2,k2))+&
- & 0.015625_MK * (&
- & terr(3,i2,j2-2,k2)+ &
- & terr(3,i2-2,j2,k2) + &
- & terr(3,i2-2,j2-2,k2) + &
- & terr(3,i2,j2,k2))
- pfc(3,i,j,k)= &
- & pfc(3,i,j,k) +&
- & 0.0625_MK * &
- & terr(3,i2-1,j2-1,k2-2) + &
- & 0.03125_MK *(&
- & terr(3,i2,j2-1,k2-2) +&
- & terr(3,i2-2,j2-1,k2-2)+ &
- & terr(3,i2-1,j2,k2-2)+&
- & terr(3,i2-1,j2-2,k2-2))+&
- & 0.015625_MK*(&
- & terr(3,i2,j2-2,k2-2)+&
- & terr(3,i2-2,j2,k2-2) + &
- & terr(3,i2-2,j2-2,k2-2)+&
- & terr(3,i2,j2,k2-2))
+ pfc(1,i,j,k)= &
+ & 0.125_MK * &
+ & terr(1,i2-1,j2-1,k2-1) + &
+ & 0.0625_MK * (&
+ & terr(1,i2,j2-1,k2-1) +&
+ & terr(1,i2-2,j2-1,k2-1)+ &
+ & terr(1,i2-1,j2,k2-1) + &
+ & terr(1,i2-1,j2-2,k2-1))+&
+ & 0.03125_MK * (&
+ & terr(1,i2,j2-2,k2-1)+ &
+ & terr(1,i2-2,j2,k2-1) + &
+ & terr(1,i2-2,j2-2,k2-1) +&
+ & terr(1,i2,j2,k2-1))
+
+ pfc(1,i,j,k)= &
+ & pfc(1,i,j,k)+&
+ & 0.0625_MK * &
+ & terr(1,i2-1,j2-1,k2) + &
+ & 0.03125_MK * (&
+ terr(1,i2,j2-1,k2) +&
+ & terr(1,i2-2,j2-1,k2)+ &
+ & terr(1,i2-1,j2,k2) +&
+ & terr(1,i2-1,j2-2,k2))+&
+ & 0.015625_MK * (&
+ & terr(1,i2,j2-2,k2)+ &
+ & terr(1,i2-2,j2,k2) + &
+ & terr(1,i2-2,j2-2,k2) + &
+ & terr(1,i2,j2,k2))
+
+ pfc(1,i,j,k)= &
+ & pfc(1,i,j,k) +&
+ & 0.0625_MK * &
+ & terr(1,i2-1,j2-1,k2-2) + &
+ & 0.03125_MK *(&
+ & terr(1,i2,j2-1,k2-2) +&
+ & terr(1,i2-2,j2-1,k2-2)+ &
+ & terr(1,i2-1,j2,k2-2)+&
+ & terr(1,i2-1,j2-2,k2-2))+&
+ & 0.015625_MK*(&
+ & terr(1,i2,j2-2,k2-2)+&
+ & terr(1,i2-2,j2,k2-2) + &
+ & terr(1,i2-2,j2-2,k2-2)+&
+ & terr(1,i2,j2,k2-2))
+
+ pfc(2,i,j,k)= &
+ & 0.125_MK * &
+ & terr(2,i2-1,j2-1,k2-1) + &
+ & 0.0625_MK * (&
+ & terr(2,i2,j2-1,k2-1) +&
+ & terr(2,i2-2,j2-1,k2-1)+ &
+ & terr(2,i2-1,j2,k2-1) + &
+ & terr(2,i2-1,j2-2,k2-1))+&
+ & 0.03125_MK * (&
+ & terr(2,i2,j2-2,k2-1)+ &
+ & terr(2,i2-2,j2,k2-1) + &
+ & terr(2,i2-2,j2-2,k2-1) +&
+ & terr(2,i2,j2,k2-1))
+
+ pfc(2,i,j,k)= &
+ & pfc(2,i,j,k)+&
+ & 0.0625_MK * &
+ & terr(2,i2-1,j2-1,k2) + &
+ & 0.03125_MK * (&
+ terr(2,i2,j2-1,k2) +&
+ & terr(2,i2-2,j2-1,k2)+ &
+ & terr(2,i2-1,j2,k2) +&
+ & terr(2,i2-1,j2-2,k2))+&
+ & 0.015625_MK * (&
+ & terr(2,i2,j2-2,k2)+ &
+ & terr(2,i2-2,j2,k2) + &
+ & terr(2,i2-2,j2-2,k2) + &
+ & terr(2,i2,j2,k2))
+
+ pfc(2,i,j,k)= &
+ & pfc(2,i,j,k) +&
+ & 0.0625_MK * &
+ & terr(2,i2-1,j2-1,k2-2) + &
+ & 0.03125_MK *(&
+ & terr(2,i2,j2-1,k2-2) +&
+ & terr(2,i2-2,j2-1,k2-2)+ &
+ & terr(2,i2-1,j2,k2-2)+&
+ & terr(2,i2-1,j2-2,k2-2))+&
+ & 0.015625_MK*(&
+ & terr(2,i2,j2-2,k2-2)+&
+ & terr(2,i2-2,j2,k2-2) + &
+ & terr(2,i2-2,j2-2,k2-2)+&
+ & terr(2,i2,j2,k2-2))
+
+ pfc(3,i,j,k)= &
+ & 0.125_MK * &
+ & terr(3,i2-1,j2-1,k2-1) + &
+ & 0.0625_MK * (&
+ & terr(3,i2,j2-1,k2-1) +&
+ & terr(3,i2-2,j2-1,k2-1)+ &
+ & terr(3,i2-1,j2,k2-1) + &
+ & terr(3,i2-1,j2-2,k2-1))+&
+ & 0.03125_MK * (&
+ & terr(3,i2,j2-2,k2-1)+ &
+ & terr(3,i2-2,j2,k2-1) + &
+ & terr(3,i2-2,j2-2,k2-1) +&
+ & terr(3,i2,j2,k2-1))
+
+ pfc(3,i,j,k)= &
+ & pfc(3,i,j,k)+&
+ & 0.0625_MK * &
+ & terr(3,i2-1,j2-1,k2) + &
+ & 0.03125_MK * (&
+ terr(3,i2,j2-1,k2) +&
+ & terr(3,i2-2,j2-1,k2)+ &
+ & terr(3,i2-1,j2,k2) +&
+ & terr(3,i2-1,j2-2,k2))+&
+ & 0.015625_MK * (&
+ & terr(3,i2,j2-2,k2)+ &
+ & terr(3,i2-2,j2,k2) + &
+ & terr(3,i2-2,j2-2,k2) + &
+ & terr(3,i2,j2,k2))
+
+ pfc(3,i,j,k)= &
+ & pfc(3,i,j,k) +&
+ & 0.0625_MK * &
+ & terr(3,i2-1,j2-1,k2-2) + &
+ & 0.03125_MK *(&
+ & terr(3,i2,j2-1,k2-2) +&
+ & terr(3,i2-2,j2-1,k2-2)+ &
+ & terr(3,i2-1,j2,k2-2)+&
+ & terr(3,i2-1,j2-2,k2-2))+&
+ & 0.015625_MK*(&
+ & terr(3,i2,j2-2,k2-2)+&
+ & terr(3,i2-2,j2,k2-2) + &
+ & terr(3,i2-2,j2-2,k2-2)+&
+ & terr(3,i2,j2,k2-2))
+
#else
- DO ilda=1,vecdim
- pfc(ilda,i,j,k)= &
- & 0.125_MK * &
- & terr(ilda,i2-1,j2-1,k2-1) + &
- & 0.0625_MK * (&
- & terr(ilda,i2,j2-1,k2-1) +&
- & terr(ilda,i2-2,j2-1,k2-1)+ &
- & terr(ilda,i2-1,j2,k2-1) + &
- & terr(ilda,i2-1,j2-2,k2-1))+&
- & 0.03125_MK * (&
- & terr(ilda,i2,j2-2,k2-1)+ &
- & terr(ilda,i2-2,j2,k2-1) + &
- & terr(ilda,i2-2,j2-2,k2-1) +&
- & terr(ilda,i2,j2,k2-1))
- pfc(ilda,i,j,k)= &
- & pfc(ilda,i,j,k)+&
- & 0.0625_MK * &
- & terr(ilda,i2-1,j2-1,k2) + &
- & 0.03125_MK * (&
- terr(ilda,i2,j2-1,k2) +&
- & terr(ilda,i2-2,j2-1,k2)+ &
- & terr(ilda,i2-1,j2,k2) +&
- & terr(ilda,i2-1,j2-2,k2))+&
- & 0.015625_MK * (&
- & terr(ilda,i2,j2-2,k2)+ &
- & terr(ilda,i2-2,j2,k2) + &
- & terr(ilda,i2-2,j2-2,k2) + &
- & terr(ilda,i2,j2,k2))
- pfc(ilda,i,j,k)= &
- & pfc(ilda,i,j,k) +&
- & 0.0625_MK * &
- & terr(ilda,i2-1,j2-1,k2-2) + &
- & 0.03125_MK *(&
- & terr(ilda,i2,j2-1,k2-2) +&
- & terr(ilda,i2-2,j2-1,k2-2)+ &
- & terr(ilda,i2-1,j2,k2-2)+&
- & terr(ilda,i2-1,j2-2,k2-2))+&
- & 0.015625_MK*(&
- & terr(ilda,i2,j2-2,k2-2)+&
- & terr(ilda,i2-2,j2,k2-2) + &
- & terr(ilda,i2-2,j2-2,k2-2)+&
- & terr(ilda,i2,j2,k2-2))
- ENDDO
-#endif
- ENDDO
+ DO ilda=1,vecdim
+ pfc(ilda,i,j,k)= &
+ & 0.125_MK * &
+ & terr(ilda,i2-1,j2-1,k2-1) + &
+ & 0.0625_MK * (&
+ & terr(ilda,i2,j2-1,k2-1) +&
+ & terr(ilda,i2-2,j2-1,k2-1)+ &
+ & terr(ilda,i2-1,j2,k2-1) + &
+ & terr(ilda,i2-1,j2-2,k2-1))+&
+ & 0.03125_MK * (&
+ & terr(ilda,i2,j2-2,k2-1)+ &
+ & terr(ilda,i2-2,j2,k2-1) + &
+ & terr(ilda,i2-2,j2-2,k2-1) +&
+ & terr(ilda,i2,j2,k2-1))
+
+ pfc(ilda,i,j,k)= &
+ & pfc(ilda,i,j,k)+&
+ & 0.0625_MK * &
+ & terr(ilda,i2-1,j2-1,k2) + &
+ & 0.03125_MK * (&
+ terr(ilda,i2,j2-1,k2) +&
+ & terr(ilda,i2-2,j2-1,k2)+ &
+ & terr(ilda,i2-1,j2,k2) +&
+ & terr(ilda,i2-1,j2-2,k2))+&
+ & 0.015625_MK * (&
+ & terr(ilda,i2,j2-2,k2)+ &
+ & terr(ilda,i2-2,j2,k2) + &
+ & terr(ilda,i2-2,j2-2,k2) + &
+ & terr(ilda,i2,j2,k2))
+
+ pfc(ilda,i,j,k)= &
+ & pfc(ilda,i,j,k) +&
+ & 0.0625_MK * &
+ & terr(ilda,i2-1,j2-1,k2-2) + &
+ & 0.03125_MK *(&
+ & terr(ilda,i2,j2-1,k2-2) +&
+ & terr(ilda,i2-2,j2-1,k2-2)+ &
+ & terr(ilda,i2-1,j2,k2-2)+&
+ & terr(ilda,i2-1,j2-2,k2-2))+&
+ & 0.015625_MK*(&
+ & terr(ilda,i2,j2-2,k2-2)+&
+ & terr(ilda,i2-2,j2,k2-2) + &
+ & terr(ilda,i2-2,j2-2,k2-2)+&
+ & terr(ilda,i2,j2,k2-2))
+ ENDDO
+#endif
ENDDO
ENDDO
ENDDO
- iopt = ppm_param_dealloc
- ldl5(1) = 1
- ldl5(2) = 1-ghostsize(1)
- ldl5(3) = 1-ghostsize(2)
- ldl5(4) = 1-ghostsize(3)
- ldl5(5) = 1
- ldu5(1) = vecdim
- ldu5(2) = max_node(1,mlevm1)+ghostsize(1)
- ldu5(3) = max_node(2,mlevm1)+ghostsize(2)
- ldu5(4) = max_node(3,mlevm1)+ghostsize(3)
- ldu5(5) = nsubs
- CALL ppm_alloc(uc_dummy,ldl5,ldu5,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'restrict', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+ ENDDO
+ iopt = ppm_param_dealloc
+ ldl5(1) = 1
+ ldl5(2) = 1-ghostsize(1)
+ ldl5(3) = 1-ghostsize(2)
+ ldl5(4) = 1-ghostsize(3)
+ ldl5(5) = 1
+ ldu5(1) = vecdim
+ ldu5(2) = max_node(1,mlevm1)+ghostsize(1)
+ ldu5(3) = max_node(2,mlevm1)+ghostsize(2)
+ ldu5(4) = max_node(3,mlevm1)+ghostsize(3)
+ ldu5(5) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl5,ldu5,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'restrict', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
#endif
#endif
!----------------------------------------------------------------------
! Return
- !----------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_mg_restrict',t0,info)
- RETURN
-
+ !----------------------------------------------------------------------
+9999 CONTINUE
+ CALL substop('ppm_mg_restrict',t0,info)
+ RETURN
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
diff --git a/src/ppm_mg_smooth_coarse.f b/src/ppm_mg_smooth_coarse.f
index b529f7d..4b5000d 100644
--- a/src/ppm_mg_smooth_coarse.f
+++ b/src/ppm_mg_smooth_coarse.f
@@ -1,1106 +1,1512 @@
- !------------------------------------------------------------------------------
- ! Subroutine : ppm_mg_smooth_coarse
- !------------------------------------------------------------------------------
- ! Purpose : In this routine we compute the corrections for
- ! the function based on the Gauss-Seidel iteration
- !
- !
- ! Input : nsweep (I) number of iterations(sweeps)
- ! Input/output :
- !
- ! Output : info (I) return status. 0 upon success
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !------------------------------------------------------------------------------
- ! $Log: ppm_mg_smooth_coarse.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.15 2006/09/26 16:01:24 ivos
- ! Fixed wrongly indented CPP directives. Remember: they have to start in
- ! Col 1, otherwise it does not compile on certain systems. In fact, this
- ! code did NOT compile as it was!!
- !
- ! Revision 1.14 2006/07/21 11:30:55 kotsalie
- ! FRIDAY
- !
- ! Revision 1.12 2006/02/08 19:55:05 kotsalie
- ! fixed multiple subdomains
- !
- ! Revision 1.11 2006/02/02 17:59:45 michaebe
- ! corrected a bug in the log comment
- !
- ! Revision 1.10 2006/02/02 16:33:19 kotsalie
- ! corrected for mixed bc''s
- !
- ! Revision 1.9 2005/12/08 12:44:46 kotsalie
- ! commiting dirichlet
- !
- ! Revision 1.8 2005/03/14 13:27:32 kotsalie
- ! COMMITED THE VECTOR CASE. IT IS FOR LDA=3
- !
- ! Revision 1.7 2005/01/04 09:45:29 kotsalie
- ! ghostsize=2
- !
- ! Revision 1.6 2004/11/05 18:09:49 kotsalie
- ! FINAL FEATURE BEFORE TEST.I DO NOT USE MASKS
- !
- ! Revision 1.4 2004/10/29 15:59:31 kotsalie
- ! RED BLACK SOR
- !
- ! Revision 1.3 2004/09/28 14:05:31 kotsalie
- ! Changes concernig 4th order finite differences
- !
- ! Revision 1.2 2004/09/23 12:16:49 kotsalie
- ! Added USE statement
- !
- ! Revision 1.1 2004/09/22 18:42:39 kotsalie
- ! MG new version
- !
- !
- !----------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-----------------------------------------------------------------------------
+!-----------------------------------------------------------------------
+! Subroutine : ppm_mg_smooth_coarse
+!-----------------------------------------------------------------------
+! Purpose : In this routine we compute the corrections for
+! the function based on the Gauss-Seidel iteration
+!
+!
+! Input : nsweep (I) number of iterations(sweeps)
+! Input/output :
+!
+! Output : info (I) return status. 0 upon success
+!
+! Remarks :
+!
+! References :
+!
+! Revisions :
+!-------------------------------------------------------------------------
+! $Log: ppm_mg_smooth_coarse.f,v $
+! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+! initial import
+!
+! Revision 1.12 2006/02/08 19:55:05 kotsalie
+! fixed multiple subdomains
+!
+! Revision 1.11 2006/02/02 17:59:45 michaebe
+! corrected a bug in the log comment
+!
+! Revision 1.10 2006/02/02 16:33:19 kotsalie
+! corrected for mixed bc''s
+!
+! Revision 1.9 2005/12/08 12:44:46 kotsalie
+! commiting dirichlet
+!
+! Revision 1.8 2005/03/14 13:27:32 kotsalie
+! COMMITED THE VECTOR CASE. IT IS FOR LDA=3
+!
+! Revision 1.7 2005/01/04 09:45:29 kotsalie
+! ghostsize=2
+!
+! Revision 1.6 2004/11/05 18:09:49 kotsalie
+! FINAL FEATURE BEFORE TEST.I DO NOT USE MASKS
+!
+! Revision 1.4 2004/10/29 15:59:31 kotsalie
+! RED BLACK SOR
+!
+! Revision 1.3 2004/09/28 14:05:31 kotsalie
+! Changes concernig 4th order finite differences
+!
+! Revision 1.2 2004/09/23 12:16:49 kotsalie
+! Added USE statement
+!
+! Revision 1.1 2004/09/22 18:42:39 kotsalie
+! MG new version
+!
+!
+!------------------------------------------------------------------------
+! Parallel Particle Mesh Library (PPM)
+! Institute of Computational Science
+! ETH Zentrum, Hirschengraben 84
+! CH-8092 Zurich, Switzerland
+!-------------------------------------------------------------------------
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_2D_sca_s(field_topoid,nsweep,mlev,c1,&
- & c2,c3,info)
+ SUBROUTINE ppm_mg_smooth_coarse_2D_sca_s(topo_id,nsweep,mlev,&
+ & c1,c2,c3,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_2D_sca_d(field_topoid,nsweep,mlev,c1,&
- & c2,c3,info)
+ SUBROUTINE ppm_mg_smooth_coarse_2D_sca_d(topo_id,nsweep,mlev,&
+ & c1,c2,c3,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_3D_sca_s(field_topoid,nsweep,mlev,c1,&
- & c2,c3,c4,info)
+ SUBROUTINE ppm_mg_smooth_coarse_3D_sca_s(topo_id,nsweep,mlev,&
+ & c1,c2,c3,c4,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_3D_sca_d(field_topoid,nsweep,mlev,c1,&
- & c2,c3,c4,info)
+ SUBROUTINE ppm_mg_smooth_coarse_3D_sca_d(topo_id,nsweep,mlev,&
+ & c1,c2,c3,c4,info)
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_2D_vec_s(field_topoid,nsweep,mlev,c1,&
- & c2,c3,info)
+ SUBROUTINE ppm_mg_smooth_coarse_2D_vec_s(topo_id,nsweep,mlev,&
+ & c1,c2,c3,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_2D_vec_d(field_topoid,nsweep,mlev,c1,&
- & c2,c3,info)
+ SUBROUTINE ppm_mg_smooth_coarse_2D_vec_d(topo_id,nsweep,mlev,&
+ & c1,c2,c3,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_3D_vec_s(field_topoid,nsweep,mlev,c1,&
- & c2,c3,c4,info)
+ SUBROUTINE ppm_mg_smooth_coarse_3D_vec_s(topo_id,nsweep,mlev,&
+ & c1,c2,c3,c4,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_3D_vec_d(field_topoid,nsweep,mlev,c1,&
- & c2,c3,c4,info)
+ SUBROUTINE ppm_mg_smooth_coarse_3D_vec_d(topo_id,nsweep,mlev,&
+ & c1,c2,c3,c4,info)
#endif
#endif
#endif
- !---------------------------------------------------------------------
- ! Includes
- !----------------------------------------------------------------------
+
+ !----------------------------------------------------------------------
+ ! Includes
+ !----------------------------------------------------------------------
#include "ppm_define.h"
- !------------------------------------------------------------------
- ! Modules
- !----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_data_mesh
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
+
+ !-------------------------------------------------------------------
+ ! Modules
+ !--------------------------------------------------------------------
+ USE ppm_module_data
+ USE ppm_module_data_mg
+ USE ppm_module_substart
+ USE ppm_module_substop
+ USE ppm_module_error
+ USE ppm_module_alloc
+ USE ppm_module_map
+ USE ppm_module_data_mesh
+ USE ppm_module_write
+
+
+
+ IMPLICIT NONE
#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
+ INTEGER, PARAMETER :: MK = ppm_kind_single
#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
+ INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
- !------------------------------------------------------------------
- ! Arguments
- !----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: nsweep
- INTEGER, INTENT(IN) :: mlev
- INTEGER, INTENT(IN) :: field_topoid
+ !-------------------------------------------------------------------
+ ! Arguments
+ !-------------------------------------------------------------------
+ INTEGER, INTENT(IN) :: nsweep
+ INTEGER, INTENT(IN) :: mlev, topo_id
#if __MESH_DIM == __2D
- REAL(MK), INTENT(IN) :: c1,c2,c3
+ REAL(MK), INTENT(IN) :: c1,c2,c3
#elif __MESH_DIM == __3D
- REAL(MK), INTENT(IN) :: c1,c2,c3,c4
+ REAL(MK), INTENT(IN) :: c1,c2,c3,c4
#endif
- INTEGER, INTENT(INOUT) :: info
- !--------------------------------------------------------------------
- ! Local variables
- !----------------------------------------------------------------------
- CHARACTER(LEN=256) :: cbuf
- INTEGER :: i,j,isub,color
- INTEGER,DIMENSION(:),POINTER :: a,b,c,d,e,g
- REAL(MK) :: c11,c22,c33,c44
- INTEGER :: ilda,isweep,count
- INTEGER :: k,idom
- REAL(MK) :: x,y,dx,dy
- REAL(MK) :: omega
- INTEGER,DIMENSION(1) :: ldu1,ldl1
- LOGICAL :: valid
+ INTEGER, INTENT(INOUT) :: info
+ !---------------------------------------------------------------------
+ ! Local variables
+ !---------------------------------------------------------------------
+ CHARACTER(LEN=256) :: cbuf
+ INTEGER :: i,j,isub,color
+ INTEGER,DIMENSION(:),POINTER :: a,b,c,d,e,f,g
+ REAL(MK) :: c11,c22,c33,c44
+ INTEGER :: ilda,isweep,count
+ INTEGER :: k,idom
+ REAL(MK) :: x,y,dx,dy
+ REAL(MK) :: omega
+ INTEGER,DIMENSION(1) :: ldu1,ldl1
#if __MESH_DIM == __2D
- INTEGER,DIMENSION(4) :: ldl4,ldu4
- INTEGER,DIMENSION(3) :: ldl3,ldu3
+ INTEGER,DIMENSION(4) :: ldl4,ldu4
+ INTEGER,DIMENSION(3) :: ldl3,ldu3
#endif
#if __MESH_DIM == __3D
- INTEGER,DIMENSION(5) :: ldl5,ldu5
- INTEGER,DIMENSION(4) :: ldl4,ldu4
- REAL(MK) :: dz
+ INTEGER,DIMENSION(5) :: ldl5,ldu5
+ INTEGER,DIMENSION(4) :: ldl4,ldu4
+ REAL(MK) :: dz
#endif
- INTEGER :: iopt,iface,topoid
- REAL(MK) :: t0
+ INTEGER :: iopt,iface,topoid
+ REAL(MK) :: t0
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#endif
#endif
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: uc_dummy
+ REAL(MK),DIMENSION(:,:,:),POINTER :: uc_dummy
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc_dummy
+ REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc_dummy
#endif
#endif
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: oldu
+ REAL(MK),DIMENSION(:,:,:),POINTER :: oldu
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: oldu
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: oldu
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: oldu
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: oldu
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: oldu
+ REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: oldu
#endif
#endif
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK) :: moldu
+ REAL(MK) :: moldu
#elif __MESH_DIM == __3D
- REAL(MK) :: moldu
+ REAL(MK) :: moldu
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:),POINTER :: moldu
+ REAL(MK),DIMENSION(:),POINTER :: moldu
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:),POINTER :: moldu
+ REAL(MK),DIMENSION(:),POINTER :: moldu
#endif
#endif
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: tuc
+ REAL(MK),DIMENSION(:,:),POINTER :: tuc
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
+ REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
+ REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc
#endif
#endif
+
+#if __MESH_DIM == __2D
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_red
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_black
+#elif __MESH_DIM == __3D
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black
+#endif
+
+
#if __KIND == __SINGLE_PRECISION
- omega=omega_s
- dx=dx_s
- dy=dy_s
+ omega=omega_s
+ dx=dx_s
+ dy=dy_s
#if __MESH_DIM == __3D
- dz=dz_s
+ dz=dz_s
#endif
#elif __KIND == __DOUBLE_PRECISION
- omega=omega_d
- dx=dx_d
- dy=dy_d
+ omega=omega_d
+ dx=dx_d
+ dy=dy_d
#if __MESH_DIM == __3D
- dz=dz_d
+ dz=dz_d
#endif
#endif
- !----------------------------------------------------------------------
- !Externals
- !----------------------------------------------------------------------
-
- !----------------------------------------------------------------------
- !Initialize
- !----------------------------------------------------------------------
- CALL substart('ppm_mg_smooth_coarse',t0,info)
- IF (l_print) THEN
- WRITE (cbuf,*) 'SMOOTHER entering ','mlev:',mlev
- CALL PPM_WRITE(ppm_rank,'mg_smooth',cbuf,info)
- ENDIF
- !----------------------------------------------------------------------
- ! Check arguments
- !----------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (nsweep.LT.1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
- & 'nsweep must be >=1',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (mlev.LE.1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
- & 'level must be >1',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (c1.LE.0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
- & 'Factor c1 must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (c2.LE.0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
- & 'Factor c2 must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (c3.LE.0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
- & 'Factor c3 must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (field_topoid .NE. ppm_param_topo_undefined) THEN
- CALL ppm_check_topoid(field_topoid,valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_map_part', &
- & 'Topology ID (to_topo) is invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
+
+ !-----------------------------------------------------------------------
+ !Externals
+ !-----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ !Initialize
+ !-----------------------------------------------------------------------
+
+ CALL substart('ppm_mg_smooth_coarse',t0,info)
+ IF (l_print) THEN
+ WRITE (cbuf,*) 'SMOOTHER entering ','mlev:',mlev
+ CALL PPM_WRITE(ppm_rank,'mg_smooth',cbuf,info)
+ ENDIF
+
+ !-----------------------------------------------------------------------
+ ! Check arguments
+ !-----------------------------------------------------------------------
+ IF (ppm_debug .GT. 0) THEN
+ IF (nsweep.LT.1) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
+ & 'nsweep must be >=1',__LINE__,info)
+ GOTO 9999
ENDIF
-#if __MESH_DIM == __3D
- IF (c4.LE.0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
- & 'Factor c4 must be >0',__LINE__,info)
- GOTO 9999
+ IF (mlev.LE.1) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
+ & 'level must be >1',__LINE__,info)
+ GOTO 9999
ENDIF
-#endif
+ IF (c1.LE.0.0_MK) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
+ & 'Factor c1 must be >0',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ IF (c2.LE.0.0_MK) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
+ & 'Factor c2 must be >0',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ IF (c3.LE.0.0_MK) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
+ & 'Factor c3 must be >0',__LINE__,info)
+ GOTO 9999
+ ENDIF
+#if __MESH_DIM == __3D
+ IF (c4.LE.0.0_MK) THEN
+ info = ppm_error_error
+ CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_coarse', &
+ & 'Factor c4 must be >0',__LINE__,info)
+ GOTO 9999
ENDIF
- !----------------------------------------------------------------------
- !Definition of necessary variables and allocation of arrays
- !----------------------------------------------------------------------
- topoid=field_topoid
+#endif
+ ENDIF
+ !-----------------------------------------------------------------------
+ !Definition of necessary variables and allocation of arrays
+ !-----------------------------------------------------------------------
+ topoid=topo_id
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_sca_s
+ mgfield=>mgfield_2d_sca_s
#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_sca_d
+ mgfield=>mgfield_2d_sca_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_sca_s
+ mgfield=>mgfield_3d_sca_s
#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_sca_d
+ mgfield=>mgfield_3d_sca_d
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_vec_s
+ mgfield=>mgfield_2d_vec_s
#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_vec_d
+ mgfield=>mgfield_2d_vec_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_vec_s
+ mgfield=>mgfield_3d_vec_s
#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_vec_d
+ mgfield=>mgfield_3d_vec_d
#endif
#endif
#endif
- iopt = ppm_param_alloc_fit
- ldl1(1) = 1
- ldu1(1) = nsubs
- CALL ppm_alloc(a,ldl1,ldu1,iopt,info)
- CALL ppm_alloc(b,ldl1,ldu1,iopt,info)
- CALL ppm_alloc(c,ldl1,ldu1,iopt,info)
- CALL ppm_alloc(d,ldl1,ldu1,iopt,info)
- CALL ppm_alloc(e,ldl1,ldu1,iopt,info)
- CALL ppm_alloc(g,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'a',__LINE__,info)
- GOTO 9999
- ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldl1(1) = 1
+ ldu1(1) = nsubs
+ CALL ppm_alloc(a,ldl1,ldu1,iopt,info)
+ CALL ppm_alloc(b,ldl1,ldu1,iopt,info)
+ CALL ppm_alloc(c,ldl1,ldu1,iopt,info)
+ CALL ppm_alloc(d,ldl1,ldu1,iopt,info)
+ CALL ppm_alloc(e,ldl1,ldu1,iopt,info)
+ CALL ppm_alloc(g,ldl1,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'a',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1
- ldu3(1) = max_node(1,mlev)+ghostsize(1)
- ldu3(2) = max_node(2,mlev)+ghostsize(2)
- ldu3(3) = nsubs
- CALL ppm_alloc(uc_dummy,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isweep=1,nsweep
- DO color=0,1
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- uc_dummy(:,:,isub)=tuc(:,:)
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- tuc(:,:)=uc_dummy(&
- & :,:,isub)
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev)+mod(j+color,2),&
- &istop(1,isub,mlev),2
- tuc(i,j) = c1*(&
- & (tuc(i-1,j)+ &
- & tuc(i+1,j))*c2 + &
- & (tuc(i,j-1)+&
- & tuc(i,j+1))*c3-&
- & mgfield(isub,mlev)%fc(i,j))
- ENDDO
- ENDDO
- ENDDO!isub
- IF (isweep.EQ.nsweep) THEN
- IF (color.EQ.1) THEN
+
+ !-----------------------------------------------------------------------
+ !Implementation
+ !-----------------------------------------------------------------------
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1
+ ldu3(1) = max_node(1,mlev)+ghostsize(1)
+ ldu3(2) = max_node(2,mlev)+ghostsize(2)
+ ldu3(3) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+ count = 0
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1
+ ldu3(1) = max_node(1,mlev)+ghostsize(1)
+ ldu3(2) = max_node(2,mlev)+ghostsize(2)
+ ldu3(3) = nsubs
+ CALL ppm_alloc(mask_dummy_2d,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'mask_dummy_2d',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ DO isweep=1,nsweep
+ DO color=0,1
+
+ DO isub=1,nsubs
+
+ IF (color.EQ.0) THEN
+ mask_red=>mgfield(isub,mlev)%mask_red
+ mask_dummy_2d(:,:,&
+ & isub)=mask_red(:,:)
+ ELSE
+ mask_black=>mgfield(isub,mlev)%mask_black
+ mask_dummy_2d(:,:,&
+ & isub)=mask_black(:,:)
+ ENDIF
+ tuc=>mgfield(isub,mlev)%uc
+ uc_dummy(:,:,isub)=tuc(:,:)
+
+
+ ENDDO!DO isub
+
+ !-----------------------------------------------------------------
+ !Communicate red(even) if color==0 or communicate black(odd)
+ !if color==1
+ !-----------------------------------------------------------------
+
+
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
+
+
+
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
+ tuc(:,:)=uc_dummy(&
+ & :,:,isub)
+ !----------------------------------------------------------------
+ !IMPOSE BOUNDARY CONDITIONS(MICHAEL)
+ !----------------------------------------------------------------
+ !NEEDED FOR THE MAIN UPDATE LOOP
+ a=0
+ b=0
+ c=0
+ d=0
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,4
+ IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+
+ IF (iface.EQ.1) THEN
+ !IF (color.EQ.1) THEN
+ a(isub)=1
+ !ENDIF
+ i=1
+ DO j=1,max_node(2,mlev)
+ tuc(i,j)=0.0_MK
+ ENDDO
+ ELSEIF (iface.EQ.2) THEN
+ !IF (color.EQ.0) THEN
+ b(isub)=1
+ !ENDIF
+ i=max_node(1,mlev)
+ DO j=1,max_node(2,mlev)
+ tuc(i,j)=0.0_MK
+ ENDDO
+ ELSEIF (iface.EQ.3) THEN
+ c(isub)=1
+ j=1
+ DO i=1,max_node(1,mlev)
+ tuc(i,j)=0.0_MK
+ ENDDO
+ ELSEIF (iface.EQ.4) THEN
+ d(isub)=1
+ j=max_node(2,mlev)
+ DO j=1,max_node(2,mlev)
+ tuc(i,j)=0.0_MK
+ ENDDO
+ ENDIF
+
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+ !NOT IMPLEMENTED YET
+ !HERE AN EXTRAPOLATION SHOULD TAKE PLACE
+ ENDIF
+ ENDDO!iface
+ ENDIF
+
+ DO j=start(2,isub,mlev)+c(isub),stop(2,isub,mlev)-d(isub)
+ DO i=start(1,isub,mlev)+a(isub)+mod(j+color,2),&
+ &stop(1,isub,mlev)-b(isub)-mod(j+color,2),2
+ mgfield(isub,mlev)%uc(i,j) = c1*(&
+ & (mgfield(isub,mlev)%uc(i-1,j)+ &
+ & mgfield(isub,mlev)%uc(i+1,j))*c2 + &
+ & (mgfield(isub,mlev)%uc(i,j-1)+&
+ & mgfield(isub,mlev)%uc(i,j+1))*c3-&
+ & mgfield(isub,mlev)%fc(i,j))
+ !Print* ,j,i
+ ENDDO
+
+ ENDDO
+ ENDDO!isub
+
+ IF (isweep.EQ.nsweep) THEN
+ IF (color.EQ.1) THEN
+
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- uc_dummy(:,:,isub)=tuc(:,:)
- ENDDO
- ENDIF
+ mask_red=>mgfield(isub,mlev)%mask_red
+ mask_dummy_2d(:,:,&
+ & isub)=mask_red(:,:)
+
+ tuc=>mgfield(isub,mlev)%uc
+ uc_dummy(:,:,isub)=tuc(:,:)
+ ENDDO
ENDIF
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- tuc(:,:)=uc_dummy(&
- & :,:,isub)
- ENDDO
- ENDIF
- ENDDO!DO nsweep
- iopt = ppm_param_dealloc
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1
- ldu3(1) = max_node(1,mlev)+ghostsize(1)
- ldu3(2) = max_node(2,mlev)+ghostsize(2)
- ldu3(3) = nsubs
- CALL ppm_alloc(uc_dummy,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+ ENDIF
+
+ ENDDO!DO color
+
+ IF (isweep.EQ.nsweep) THEN
+
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
+
+
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
+ tuc(:,:)=uc_dummy(&
+ & :,:,isub)
+ ENDDO
+ ENDIF
+
+
+ ENDDO!DO nsweep
+
+
+
+ iopt = ppm_param_dealloc
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1
+ ldu3(1) = max_node(1,mlev)+ghostsize(1)
+ ldu3(2) = max_node(2,mlev)+ghostsize(2)
+ ldu3(3) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldl4(1) = 1-ghostsize(1)
- ldl4(2) = 1-ghostsize(2)
- ldl4(3) = 1-ghostsize(3)
- ldl4(4) = 1
- ldu4(1) = max_node(1,mlev)+ghostsize(1)
- ldu4(2) = max_node(2,mlev)+ghostsize(2)
- ldu4(3) = max_node(3,mlev)+ghostsize(3)
- ldu4(4) = nsubs
- CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isweep=1,nsweep
- DO color=0,1
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
+
+ !-----------------------------------------------------------------------
+ !Implementation
+ !-----------------------------------------------------------------------
+
+ iopt = ppm_param_alloc_fit
+ ldl4(1) = 1-ghostsize(1)
+ ldl4(2) = 1-ghostsize(2)
+ ldl4(3) = 1-ghostsize(3)
+ ldl4(4) = 1
+ ldu4(1) = max_node(1,mlev)+ghostsize(1)
+ ldu4(2) = max_node(2,mlev)+ghostsize(2)
+ ldu4(3) = max_node(3,mlev)+ghostsize(3)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+ iopt = ppm_param_alloc_fit
+ ldl4(1)=1-ghostsize(1)
+ ldl4(2)=1-ghostsize(2)
+ ldl4(3)=1-ghostsize(3)
+ ldl4(4)=1
+ ldu4(1) = max_node(1,mlev)+ghostsize(1)
+ ldu4(2) = max_node(2,mlev)+ghostsize(2)
+ ldu4(3) = max_node(3,mlev)+ghostsize(3)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(mask_dummy_3d,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'mask_dummy_3d',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+
+
+ DO isweep=1,nsweep
+ DO color=0,1
+
+
+ DO isub=1,nsubs
+
+ IF (color.EQ.0) THEN
+ mask_red=>mgfield(isub,mlev)%mask_red
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+
+ mask_dummy_3d(i,j,k,isub)= &
+ & mask_red(i,j,k)
+
+ ENDDO
+ ENDDO
+ ENDDO
+
+ ELSE
+ mask_black=>mgfield(isub,mlev)%mask_black
+
DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
- uc_dummy(i,j,k,isub)=tuc(i,j,k)
- ENDDO
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+
+ mask_dummy_3d(i,j,k,isub)= &
+ & mask_black(i,j,k)
ENDDO
ENDDO
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- a=0
- b=0
- c=0
- d=0
- e=0
- g=0
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
- tuc(i,j,k)=uc_dummy(i,j,k,isub)
- ENDDO
+ ENDDO
+
+ ENDIF
+ tuc=>mgfield(isub,mlev)%uc
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+ uc_dummy(i,j,k,isub)=tuc(i,j,k)
ENDDO
+ ENDDO
ENDDO
- IF (.NOT.lperiodic) THEN
- DO iface=1,6
- IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
- !DO NOTHING
- ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
- IF (iface.EQ.1) THEN
- a(isub)=1
- IF (bcdef_sca(isub,2).EQ.0) THEN
- b(isub)=-1
- ENDIF
- i=1
- DO j=1,max_node(2,mlev)
- DO k=1,max_node(3,mlev)
- tuc(i,j,k)=0.0_MK
- enddo
- ENDDO
- ELSEIF (iface.EQ.2) THEN
- b(isub)=1
- IF (bcdef_sca(isub,1).EQ.0) THEN
- a(isub)=-1
- ENDIF
- i=max_node(1,mlev)
- DO j=1,max_node(2,mlev)
- DO k=1,max_node(3,mlev)
+
+ ENDDO!DO isub
+
+
+ !-----------------------------------------------------------------
+ !Communicate red(even) if color==0 or communicate black(odd)
+ !if color==1
+ !-----------------------------------------------------------------
+
+#ifdef __WITHOUTMASKS
+
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info)
+
+#else
+
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_3d)
+
+
+#endif
+
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+ tuc(i,j,k)=uc_dummy(i,j,k,isub)
+ ENDDO
+ ENDDO
+ ENDDO
+ a=0
+ b=0
+ c=0
+ d=0
+ e=0
+ g=0
+ IF (.NOT.lperiodic) THEN
+ DO iface=1,6
+ IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+
+ IF (iface.EQ.1) THEN
+
+ a(isub)=1
+ i=1
+ DO j=1,max_node(2,mlev)
+ DO k=1,max_node(3,mlev)
tuc(i,j,k)=0.0_MK
- ENDDO
enddo
- ELSEIF (iface.EQ.3) THEN
- c(isub)=1
- IF (bcdef_sca(isub,4).EQ.0) THEN
- d(isub)=-1
- ENDIF
- j=1
- DO i=1,max_node(1,mlev)
- Do k=1,max_node(3,mlev)
- tuc(i,j,k)=0.0_MK
- enddo
- ENDDO
- ELSEIF (iface.EQ.4) THEN
- d(isub)=1
- IF (bcdef_sca(isub,3).EQ.0) THEN
- c(isub)=-1
- ENDIF
- j=max_node(2,mlev)
- DO i=1,max_node(1,mlev)
- Do k=1,max_node(3,mlev)
- tuc(i,j,k)=0.0_MK
- enddo
- ENDDO
- ELSEIF (iface.EQ.5) Then
- e(isub)=1
- IF (bcdef_sca(isub,6).EQ.0) THEN
- g(isub)=-1
- ENDIF
- k=1
- DO i=1,max_node(1,mlev)
- Do j=1,max_node(2,mlev)
- tuc(i,j,k)=0.0_MK
- enddo
- ENDDO
- ELSEIF (iface.EQ.6) Then
- g(isub)=1
- IF (bcdef_sca(isub,5).EQ.0) THEN
- e(isub)=-1
- ENDIF
- k=max_node(3,mlev)
- DO i=1,max_node(1,mlev)
- Do j=1,max_node(2,mlev)
- tuc(i,j,k)=0.0_MK
- enddo
+ ENDDO
+ ELSEIF (iface.EQ.2) THEN
+ b(isub)=1
+ i=max_node(1,mlev)
+ DO j=1,max_node(2,mlev)
+ DO k=1,max_node(3,mlev)
+
+ tuc(i,j,k)=0.0_MK
ENDDO
- endif
- ENDIF
- ENDDO!iface
- ENDIF
- DO k=start(3,isub,mlev)+e(isub),istop(3,isub,mlev)-g(isub)
- DO j=start(2,isub,mlev)+c(isub),istop(2,isub,mlev)-d(isub)
- DO i=start(1,isub,mlev)+mod(j+k+color,2)+a(isub), &
- & istop(1,isub,mlev)-b(isub)-mod(j+k+color,2),2
- IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND.(j.GE.1.AND.j.LE.max_node(2,mlev)) &
- & .AND.(k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
- moldu=tuc(i,j,k)
- tuc(i,j,k) = moldu+&
- & omega*(&
- & c1*((tuc(i-1,j,k)+ &
- & tuc(i+1,j,k))*c2 + &
- & (tuc(i,j-1,k)+&
- & tuc(i,j+1,k))*c3 + &
- & (tuc(i,j,k-1)+&
- & tuc(i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(i,j,k))&
- & -moldu)
- ENDIF
+ enddo
+ ELSEIF (iface.EQ.3) THEN
+ c(isub)=1
+ j=1
+ DO i=1,max_node(1,mlev)
+ Do k=1,max_node(3,mlev)
+ tuc(i,j,k)=0.0_MK
+ enddo
+ ENDDO
+ ELSEIF (iface.EQ.4) THEN
+ d(isub)=1
+ j=max_node(2,mlev)
+ DO i=1,max_node(1,mlev)
+ Do k=1,max_node(3,mlev)
+ tuc(i,j,k)=0.0_MK
+ enddo
+ ENDDO
+ ELSEIF (iface.EQ.5) Then
+ e(isub)=1
+ k=1
+ DO i=1,max_node(1,mlev)
+ Do j=1,max_node(2,mlev)
+ tuc(i,j,k)=0.0_MK
+ enddo
+ ENDDO
+ ELSEIF (iface.EQ.6) Then
+ g(isub)=1
+ DO i=1,max_node(1,mlev)
+ Do j=1,max_node(2,mlev)
+ tuc(i,j,k)=0.0_MK
+ enddo
+ ENDDO
+ endif
+
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+ !NOT IMPLEMENTED YET
+ !HERE AN EXTRAPOLATION SHOULD TAKE PLACE
+ ENDIF
+ ENDDO!iface
+ ENDIF
+ DO k=start(3,isub,mlev)+g(isub),stop(3,isub,mlev)-e(isub)
+ DO j=start(2,isub,mlev)+c(isub),stop(2,isub,mlev)-d(isub)
+ DO i=start(1,isub,mlev)+mod(j+k+color,2)+a(isub),&
+ & stop(1,isub,mlev)-b(isub)-mod(j+k+color,2),2
+
+ moldu=tuc(i,j,k)
+
+ mgfield(isub,mlev)%uc(i,j,k) = moldu+&
+ & omega*(&
+ & c1*((mgfield(isub,mlev)%uc(i-1,j,k)+ &
+ & mgfield(isub,mlev)%uc(i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(i,j-1,k)+&
+ & mgfield(isub,mlev)%uc(i,j+1,k))*c3 + &
+ & (mgfield(isub,mlev)%uc(i,j,k-1)+&
+ & mgfield(isub,mlev)%uc(i,j,k+1))*c4 - &
+ & mgfield(isub,mlev)%fc(i,j,k))&
+ & -moldu)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO!isubs
+
+ IF (isweep.EQ.nsweep) THEN
+
+ IF (color.EQ.1) THEN
+ DO isub=1,nsubs
+ mask_red=>mgfield(isub,mlev)%mask_red
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+
+ mask_dummy_3d(i,j,k,isub)= &
+ & mask_red(i,j,k)
+
ENDDO
- ENDDO
- ENDDO
- ENDDO!isubs
- IF (isweep.EQ.nsweep) THEN
- IF (color.EQ.1) THEN
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
- uc_dummy(i,j,k,isub)=tuc(i,j,k)
- ENDDO
+ ENDDO
+ ENDDO
+
+
+ tuc=>mgfield(isub,mlev)%uc
+
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+ uc_dummy(i,j,k,isub)=tuc(i,j,k)
ENDDO
ENDDO
+ ENDDO
- ENDDO!isub
+ ENDDO!isub
ENDIF
ENDIF
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- ENDIF
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
- tuc(i,j,k)=uc_dummy(i,j,k,isub)
- ENDDO
+
+ ENDDO!DO color
+
+ IF (isweep.EQ.nsweep) THEN
+
+#ifdef __WITHOUTMASKS
+
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info)
+
+#else
+
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_3d)
+
+
+#endif
+
+
+ ENDIF
+
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
+
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+ tuc(i,j,k)=uc_dummy(i,j,k,isub)
ENDDO
- ENDDO
- ENDDO!isub
- ENDDO!Do isweep
- iopt = ppm_param_dealloc
- ldl4(1) = 1-ghostsize(1)
- ldl4(2) = 1-ghostsize(2)
- ldl4(3) = 1-ghostsize(3)
- ldl4(4) = 1
- ldu4(1) = max_node(1,mlev)+ghostsize(1)
- ldu4(2) = max_node(2,mlev)+ghostsize(2)
- ldu4(3) = max_node(3,mlev)+ghostsize(3)
- ldu4(4) = nsubs
- CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO!isub
+ ENDDO!Do isweep
+
+ iopt = ppm_param_dealloc
+ ldl4(1) = 1-ghostsize(1)
+ ldl4(2) = 1-ghostsize(2)
+ ldl4(3) = 1-ghostsize(3)
+ ldl4(4) = 1
+ ldu4(1) = max_node(1,mlev)+ghostsize(1)
+ ldu4(2) = max_node(2,mlev)+ghostsize(2)
+ ldu4(3) = max_node(3,mlev)+ghostsize(3)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldl4(1) = 1
- ldl4(2) = 1-ghostsize(1)
- ldl4(3) = 1-ghostsize(2)
- ldl4(4) = 1
- ldu4(1) = vecdim
- ldu4(2) = max_node(1,mlev)+ghostsize(1)
- ldu4(3) = max_node(2,mlev)+ghostsize(2)
- ldu4(4) = nsubs
- CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isweep=1,nsweep
- DO color=0,1
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- uc_dummy(:,:,:,isub)=tuc(:,:,:)
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- tuc(:,:,:)=uc_dummy(&
- & :,:,:,isub)
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev)+mod(j+color,2),istop(1,isub,mlev),2
- DO ilda=1,vecdim
- tuc(ilda,i,j) = c1*(&
- & (tuc(ilda,i-1,j)+ &
- & tuc(ilda,i+1,j))*c2 + &
- & (tuc(ilda,i,j-1)+&
- & tuc(ilda,i,j+1))*c3-&
- & mgfield(isub,mlev)%fc(ilda,i,j))
- ENDDO
+
+ !-----------------------------------------------------------------------
+ !Implementation
+ !-----------------------------------------------------------------------
+
+ iopt = ppm_param_alloc_fit
+ ldl4(1) = 1
+ ldl4(2) = 1-ghostsize(1)
+ ldl4(3) = 1-ghostsize(2)
+ ldl4(4) = 1
+ ldu4(1) = vecdim
+ ldu4(2) = max_node(1,mlev)+ghostsize(1)
+ ldu4(3) = max_node(2,mlev)+ghostsize(2)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+ count = 0
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1
+ ldu3(1) = max_node(1,mlev)+ghostsize(1)
+ ldu3(2) = max_node(2,mlev)+ghostsize(2)
+ ldu3(3) = nsubs
+ CALL ppm_alloc(mask_dummy_2d,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'mask_dummy_2d',__LINE__,info)
+ GOTO 9999
+ ENDIF
+ DO isweep=1,nsweep
+ DO color=0,1
+
+ DO isub=1,nsubs
+
+ IF (color.EQ.0) THEN
+ mask_red=>mask_red
+ mask_dummy_2d(:,:,&
+ & isub)=mgfield(isub,mlev)%mask_red(:,:)
+ ELSE
+ mask_black=>mgfield(isub,mlev)%mask_black
+ mask_dummy_2d(:,:,&
+ & isub)=mask_black(:,:)
+ ENDIF
+ tuc=>mgfield(isub,mlev)%uc
+ uc_dummy(:,:,:,isub)=tuc(:,:,:)
+
+ ENDDO!DO isub
+
+ !-----------------------------------------------------------------
+ !Communicate red(even) if color==0 or communicate black(odd)
+ !if color==1
+ !-----------------------------------------------------------------
+
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
+
+
+
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
+ tuc(:,:,:)=uc_dummy(&
+ & :,:,:,isub)
+ DO j=start(2,isub,mlev),stop(2,isub,mlev)
+ DO i=start(1,isub,mlev)+mod(j+color,2),stop(1,isub,mlev),2
+ DO ilda=1,vecdim
+ mgfield(isub,mlev)%uc(ilda,i,j) = c1*(&
+ & (mgfield(isub,mlev)%uc(ilda,i-1,j)+ &
+ & mgfield(isub,mlev)%uc(ilda,i+1,j))*c2 + &
+ & (mgfield(isub,mlev)%uc(ilda,i,j-1)+&
+ & mgfield(isub,mlev)%uc(ilda,i,j+1))*c3-&
+ & mgfield(isub,mlev)%fc(ilda,i,j))
+
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ IF (isweep.EQ.nsweep) THEN
+ IF (color.EQ.1) THEN
+
+ DO isub=1,nsubs
+ mask_red=>mask_red
+ mask_dummy_2d(:,:,&
+ & isub)=mgfield(isub,mlev)%mask_red(:,:)
+
+ tuc=>mgfield(isub,mlev)%uc
+ uc_dummy(:,:,:,isub)=tuc(:,:,:)
ENDDO
- ENDDO
- ENDDO
- IF (isweep.EQ.nsweep) THEN
- IF (color.EQ.1) THEN
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- uc_dummy(:,:,:,isub)=tuc(:,:,:)
- ENDDO
- ENDIF
ENDIF
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- tuc(:,:,:)=uc_dummy(&
- & :,:,:,isub)
- ENDDO
- ENDIF
- ENDDO!DO nsweep
- iopt = ppm_param_dealloc
- ldl4(1) = 1
- ldl4(2) = 1-ghostsize(1)
- ldl4(3) = 1-ghostsize(2)
- ldl4(4) = 1
- ldu4(1) = vecdim
- ldu4(2) = max_node(1,mlev)+ghostsize(1)
- ldu4(3) = max_node(2,mlev)+ghostsize(2)
- ldu4(4) = nsubs
- CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+ ENDIF
+
+
+
+
+ ENDDO!DO color
+
+ IF (isweep.EQ.nsweep) THEN
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
+
+
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
+ tuc(:,:,:)=uc_dummy(&
+ & :,:,:,isub)
+ ENDDO
+ ENDIF
+
+ ENDDO!DO nsweep
+
+
+
+ iopt = ppm_param_dealloc
+ ldl4(1) = 1
+ ldl4(2) = 1-ghostsize(1)
+ ldl4(3) = 1-ghostsize(2)
+ ldl4(4) = 1
+ ldu4(1) = vecdim
+ ldu4(2) = max_node(1,mlev)+ghostsize(1)
+ ldu4(3) = max_node(2,mlev)+ghostsize(2)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
+ ENDIF
#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldl5(1) = 1
- ldl5(2) = 1-ghostsize(1)
- ldl5(3) = 1-ghostsize(2)
- ldl5(4) = 1-ghostsize(3)
- ldl5(5) = 1
- ldu5(1) = vecdim
- ldu5(2) = max_node(1,mlev)+ghostsize(1)
- ldu5(3) = max_node(2,mlev)+ghostsize(2)
- ldu5(4) = max_node(3,mlev)+ghostsize(3)
- ldu5(5) = nsubs
- CALL ppm_alloc(uc_dummy,ldl5,ldu5,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+
+ !-----------------------------------------------------------------------
+ !Implementation
+ !-----------------------------------------------------------------------
+
iopt = ppm_param_alloc_fit
- ldu1(1)=vecdim
- CALL ppm_alloc(moldu,ldu1,iopt,info)
+ ldl5(1) = 1
+ ldl5(2) = 1-ghostsize(1)
+ ldl5(3) = 1-ghostsize(2)
+ ldl5(4) = 1-ghostsize(3)
+ ldl5(5) = 1
+ ldu5(1) = vecdim
+ ldu5(2) = max_node(1,mlev)+ghostsize(1)
+ ldu5(3) = max_node(2,mlev)+ghostsize(2)
+ ldu5(4) = max_node(3,mlev)+ghostsize(3)
+ ldu5(5) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl5,ldu5,iopt,info)
IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'moldu',__LINE__,info)
- GOTO 9999
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
ENDIF
- DO isweep=1,nsweep
- DO color=0,1
- DO isub=1,nsubs
- !-------------------------------------------------------------
- !Impose boundaries
- !-------------------------------------------------------------
- tuc=>mgfield(isub,mlev)%uc
+
+
+
+ iopt = ppm_param_alloc_fit
+ ldl4(1)=1-ghostsize(1)
+ ldl4(2)=1-ghostsize(2)
+ ldl4(3)=1-ghostsize(3)
+ ldl4(4)=1
+ ldu4(1) = max_node(1,mlev)+ghostsize(1)
+ ldu4(2) = max_node(2,mlev)+ghostsize(2)
+ ldu4(3) = max_node(3,mlev)+ghostsize(3)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(mask_dummy_3d,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'mask_dummy_3d',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+
+ iopt = ppm_param_alloc_fit
+ ldu1(1)=vecdim
+ CALL ppm_alloc(moldu,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'moldu',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+
+ DO isweep=1,nsweep
+
+ DO color=0,1
+
+ DO isub=1,nsubs
+ !--------------------------------------------------------------
+ !Impose boundaries on even if color=0 or odd if color=1
+ !--------------------------------------------------------------
+
+ IF (color.EQ.0) THEN
+ mask_red=>mgfield(isub,mlev)%mask_red
DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+
+ mask_dummy_3d(i,j,k,isub)= &
+ & mask_red(i,j,k)
+
+ ENDDO
+ ENDDO
+ ENDDO
+
+ ELSE
+ mask_black=>mgfield(isub,mlev)%mask_black
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+
+ mask_dummy_3d(i,j,k,isub)= &
+ & mask_black(i,j,k)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ tuc=>mgfield(isub,mlev)%uc
+
+
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
#ifdef __VECTOR
- uc_dummy(1,i,j,k,isub)=tuc(1,i,j,k)
- uc_dummy(2,i,j,k,isub)=tuc(2,i,j,k)
- uc_dummy(3,i,j,k,isub)=tuc(3,i,j,k)
+ uc_dummy(1,i,j,k,isub)=tuc(1,i,j,k)
+ uc_dummy(2,i,j,k,isub)=tuc(2,i,j,k)
+ uc_dummy(3,i,j,k,isub)=tuc(3,i,j,k)
#else
- DO ilda=1,vecdim
- uc_dummy(ilda,i,j,k,isub)=tuc(ilda,i,j,k)
- ENDDO
+ DO ilda=1,vecdim
+ uc_dummy(ilda,i,j,k,isub)=tuc(ilda,i,j,k)
+ ENDDO
#endif
- ENDDO
ENDDO
- ENDDO
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- a=0
- b=0
- c=0
- d=0
- e=0
- g=0
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
-#ifdef __VECTOR
- tuc(1,i,j,k)=uc_dummy(1,i,j,k,isub)
- tuc(2,i,j,k)=uc_dummy(2,i,j,k,isub)
- tuc(3,i,j,k)=uc_dummy(3,i,j,k,isub)
+ ENDDO
+ ENDDO
+
+ ENDDO!DO isub
+
+
+
+
+ !-----------------------------------------------------------------
+ !Communicate red(even) if color==0 or communicate black(odd)
+ !if color==1
+ !-----------------------------------------------------------------
+
+#ifdef __WITHOUTMASKS
+
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info)
+
#else
- DO ilda=1,vecdim
- tuc(ilda,i,j,k)=uc_dummy(ilda,i,j,k,isub)
- ENDDO
+
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_3d)
+
+
#endif
+
+ a=0
+ b=0
+ c=0
+ d=0
+ e=0
+ g=0
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
+
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+#ifdef __VECTOR
+
+ tuc(1,i,j,k)=uc_dummy(1,i,j,k,isub)
+ tuc(2,i,j,k)=uc_dummy(2,i,j,k,isub)
+ tuc(3,i,j,k)=uc_dummy(3,i,j,k,isub)
+
+#else
+
+ DO ilda=1,vecdim
+ tuc(ilda,i,j,k)=uc_dummy(ilda,i,j,k,isub)
ENDDO
+#endif
ENDDO
- ENDDO
- DO ilda=1,vecdim
- IF (.NOT.lperiodic) THEN
- DO iface=1,6
- IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
- !DO NOTHING
- ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
- IF (iface.EQ.1) THEN
- a(isub)=1
- IF (bcdef_vec(ilda,isub,2).EQ.0) THEN
- b(isub)=-1
- ENDIF
- i=1
- DO j=1,max_node(2,mlev)
- DO k=1,max_node(3,mlev)
- tuc(ilda,i,j,k)=0.0_MK
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.2) THEN
- b(isub)=1
- IF (bcdef_vec(ilda,isub,1).EQ.0) THEN
- a(isub)=-1
- ENDIF
- i=max_node(1,mlev)
- DO j=1,max_node(2,mlev)
- DO k=1,max_node(3,mlev)
+ ENDDO
+ ENDDO
+
+ Do ilda=1,vecdim
+
+ IF (.NOT.lperiodic) THEN
+
+ DO iface=1,6
+ IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ IF (iface.EQ.1) THEN
+ a(isub)=1
+
+ IF (bcdef_vec(ilda,isub,2).EQ.0) THEN
+ b(isub)=-1
+ ENDIF
+
+ i=1
+ DO j=1,max_node(2,mlev)
+ DO k=1,max_node(3,mlev)
tuc(ilda,i,j,k)=0.0_MK
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.3) THEN
- c(isub)=1
- IF (bcdef_vec(ilda,isub,4).EQ.0) THEN
- d(isub)=-1
- ENDIF
- j=1
- DO i=1,max_node(1,mlev)
- Do k=1,max_node(3,mlev)
- tuc(ilda,i,j,k)=0.0_MK
-
- enddo
- ENDDO
- ELSEIF (iface.EQ.4) THEN
- d(isub)=1
- IF (bcdef_vec(ilda,isub,3).EQ.0) THEN
- c(isub)=-1
- ENDIF
- j=max_node(2,mlev)
- DO i=1,max_node(1,mlev)
- Do k=1,max_node(3,mlev)
- tuc(ilda,i,j,k)=0.0_MK
- enddo
- ENDDO
- ELSEIF (iface.EQ.5) Then
- e(isub)=1
- IF (bcdef_vec(ilda,isub,6).EQ.0) THEN
- g(isub)=-1
+ enddo
+ ENDDO
+ ELSEIF (iface.EQ.2) THEN
+ !IF (color.EQ.0) THEN
+ b(isub)=1
+ IF (bcdef_vec(ilda,isub,1).EQ.0) THEN
+ a(isub)=-1
ENDIF
- k=1
- DO i=1,max_node(1,mlev)
- DO j=1,max_node(2,mlev)
+ !ENDIF
+ i=max_node(1,mlev)
+ DO j=1,max_node(2,mlev)
+ DO k=1,max_node(3,mlev)
tuc(ilda,i,j,k)=0.0_MK
- ENDDO
ENDDO
- ELSEIF (iface.EQ.6) THEN
- g(isub)=1
- IF (bcdef_vec(ilda,isub,5).EQ.0) THEN
- e(isub)=-1
- ENDIF
- k=max_node(3,mlev)
- DO i=1,max_node(1,mlev)
- Do j=1,max_node(2,mlev)
+ enddo
+ ELSEIF (iface.EQ.3) THEN
+ c(isub)=1
+ IF (bcdef_vec(ilda,isub,4).EQ.0) THEN
+ d(isub)=-1
+ ENDIF
+ j=1
+ DO i=1,max_node(1,mlev)
+ Do k=1,max_node(3,mlev)
tuc(ilda,i,j,k)=0.0_MK
- ENDDO
- ENDDO
- ENDIF
- ENDIF
- ENDDO!face
- ENDIF
- ENDDO!ilda
- DO k=start(3,isub,mlev)+e(isub),istop(3,isub,mlev)-g(isub)
- DO j=start(2,isub,mlev)+c(isub),istop(2,isub,mlev)-d(isub)
- DO i=start(1,isub,mlev)+mod(j+k+color,2)+a(isub), &
- & istop(1,isub,mlev)-b(isub)-mod(j+k+color,2),2
- IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND.(j.GE.1.AND.j.LE.max_node(2,mlev)) &
- & .AND.(k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
+
+ enddo
+ ENDDO
+ ELSEIF (iface.EQ.4) THEN
+ d(isub)=1
+ IF (bcdef_vec(ilda,isub,3).EQ.0) THEN
+ c(isub)=-1
+ ENDIF
+ j=max_node(2,mlev)
+ DO i=1,max_node(1,mlev)
+ Do k=1,max_node(3,mlev)
+ tuc(ilda,i,j,k)=0.0_MK
+ enddo
+ ENDDO
+ ELSEIF (iface.EQ.5) Then
+ e(isub)=1
+ IF (bcdef_vec(ilda,isub,6).EQ.0) THEN
+ g(isub)=-1
+ ENDIF
+ k=1
+ DO i=1,max_node(1,mlev)
+ Do j=1,max_node(2,mlev)
+ tuc(ilda,i,j,k)=0.0_MK
+ enddo
+ ENDDO
+
+ elseif (iface.EQ.6) THEN
+ g(isub)=1
+ IF (bcdef_vec(ilda,isub,5).EQ.0) THEN
+ e(isub)=-1
+ ENDIF
+ k=max_node(3,mlev)
+ DO i=1,max_node(1,mlev)
+ Do j=1,max_node(2,mlev)
+ tuc(ilda,i,j,k)=0.0_MK
+ enddo
+ ENDDO
+ endif
+
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+
+
+ ENDIF
+ ENDDO!face
+ ENDIF
+ ENDDO!ilda
+ DO k=start(3,isub,mlev)+e(isub),stop(3,isub,mlev)-g(isub)
+ DO j=start(2,isub,mlev)+c(isub),stop(2,isub,mlev)-d(isub)
+ DO i=start(1,isub,mlev)+mod(j+k+color,2)+a(isub),stop(1,isub,mlev)-b(isub)-mod(j+k+color,2),2
+ IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND.&
+ & (j.GE.1.AND.j.LE.max_node(2,mlev)).AND.&
+ & (k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
#ifdef __VECTOR
- moldu(1) = tuc(1,i,j,k)
- moldu(2) = tuc(2,i,j,k)
- moldu(3) = tuc(3,i,j,k)
+
+ moldu(1) = tuc(1,i,j,k)
+ moldu(2) = tuc(2,i,j,k)
+ moldu(3) = tuc(3,i,j,k)
#else
- do ilda=1,vecdim
- moldu(ilda) = tuc(ilda,i,j,k)
- end do
+ do ilda=1,vecdim
+ moldu(ilda) = tuc(ilda,i,j,k)
+ end do
#endif
+
#ifdef __VECTOR
- tuc(1,i,j,k) = moldu(1)+&
- & omega*(&
- & c1*((tuc(1,i-1,j,k)+ &
- & tuc(1,i+1,j,k))*c2 + &
- & (tuc(1,i,j-1,k)+&
- & tuc(1,i,j+1,k))*c3 + &
- & (tuc(1,i,j,k-1)+&
- & tuc(1,i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(1,i,j,k))&
- & -moldu(1))
- tuc(2,i,j,k) = moldu(2)+&
- & omega*(&
- & c1*((tuc(2,i-1,j,k)+ &
- & tuc(2,i+1,j,k))*c2 + &
- & (tuc(2,i,j-1,k)+&
- & tuc(2,i,j+1,k))*c3 + &
- & (tuc(2,i,j,k-1)+&
- & tuc(2,i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(2,i,j,k))&
- & -moldu(2))
- tuc(3,i,j,k) = moldu(3)+&
- & omega*(&
- & c1*((tuc(3,i-1,j,k)+ &
- & tuc(3,i+1,j,k))*c2 + &
- & (tuc(3,i,j-1,k)+&
- & tuc(3,i,j+1,k))*c3 + &
- & (tuc(3,i,j,k-1)+&
- & tuc(3,i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(3,i,j,k))&
- & -moldu(3))
+
+ mgfield(isub,mlev)%uc(1,i,j,k) = moldu(1)+&
+ & omega*(&
+ & c1*((mgfield(isub,mlev)%uc(1,i-1,j,k)+ &
+ & mgfield(isub,mlev)%uc(1,i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(1,i,j-1,k)+&
+ & mgfield(isub,mlev)%uc(1,i,j+1,k))*c3 + &
+ & (mgfield(isub,mlev)%uc(1,i,j,k-1)+&
+ & mgfield(isub,mlev)%uc(1,i,j,k+1))*c4 - &
+ & mgfield(isub,mlev)%fc(1,i,j,k))&
+ & -moldu(1))
+
+
+ mgfield(isub,mlev)%uc(2,i,j,k) = moldu(2)+&
+ & omega*(&
+ & c1*((mgfield(isub,mlev)%uc(2,i-1,j,k)+ &
+ & mgfield(isub,mlev)%uc(2,i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(2,i,j-1,k)+&
+ & mgfield(isub,mlev)%uc(2,i,j+1,k))*c3 + &
+ & (mgfield(isub,mlev)%uc(2,i,j,k-1)+&
+ & mgfield(isub,mlev)%uc(2,i,j,k+1))*c4 - &
+ & mgfield(isub,mlev)%fc(2,i,j,k))&
+ & -moldu(2))
+
+ mgfield(isub,mlev)%uc(3,i,j,k) = moldu(3)+&
+ & omega*(&
+ & c1*((mgfield(isub,mlev)%uc(3,i-1,j,k)+ &
+ & mgfield(isub,mlev)%uc(3,i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(3,i,j-1,k)+&
+ & mgfield(isub,mlev)%uc(3,i,j+1,k))*c3 + &
+ & (mgfield(isub,mlev)%uc(3,i,j,k-1)+&
+ & mgfield(isub,mlev)%uc(3,i,j,k+1))*c4 - &
+ & mgfield(isub,mlev)%fc(3,i,j,k))&
+ & -moldu(3))
#else
- DO ilda=1,vecdim
- tuc(ilda,i,j,k) = moldu(ilda)+&
- & omega*(&
- & c1*((tuc(ilda,i-1,j,k)+ &
- & tuc(ilda,i+1,j,k))*c2 + &
- & (tuc(ilda,i,j-1,k)+&
- & tuc(ilda,i,j+1,k))*c3 + &
- & (tuc(ilda,i,j,k-1)+&
- & tuc(ilda,i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(ilda,i,j,k))&
- & -moldu(ilda))
- ENDDO!ilda
+ DO ilda=1,vecdim
+
+
+ mgfield(isub,mlev)%uc(ilda,i,j,k) = moldu(ilda)+&
+ & omega*(&
+ & c1*((mgfield(isub,mlev)%uc(ilda,i-1,j,k)+ &
+ & mgfield(isub,mlev)%uc(ilda,i+1,j,k))*c2 + &
+ & (mgfield(isub,mlev)%uc(ilda,i,j-1,k)+&
+ & mgfield(isub,mlev)%uc(ilda,i,j+1,k))*c3 + &
+ & (mgfield(isub,mlev)%uc(ilda,i,j,k-1)+&
+ & mgfield(isub,mlev)%uc(ilda,i,j,k+1))*c4 - &
+ & mgfield(isub,mlev)%fc(ilda,i,j,k))&
+ & -moldu(ilda))
+
+
+
+ ENDDO!ilda
#endif
- ENDIF
- ENDDO!i
- ENDDO!j
- ENDDO!k
- ENDDO!isubs
- IF (isweep.EQ.nsweep) THEN
- IF (color.EQ.1) THEN
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
- DO ilda=1,vecdim
- uc_dummy(ilda,i,j,k,isub)=tuc(ilda,i,j,k)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO!isub
+ ENDIF
+ ENDDO!i
+ ENDDO!j
+ ENDDO!k
- ENDIF
- ENDIF
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
- DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
- DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
- DO ilda=1,vecdim
- tuc(ilda,i,j,k)=uc_dummy(ilda,i,j,k,isub)
- ENDDO
+ ENDDO!isubs
+
+ IF (isweep.EQ.nsweep) THEN
+ IF (color.EQ.1) THEN
+ DO isub=1,nsubs
+
+ tuc=>mgfield(isub,mlev)%uc
+
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+ DO ilda=1,vecdim
+ uc_dummy(ilda,i,j,k,isub)=tuc(ilda,i,j,k)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO!isub
+
+ ENDIF
+ ENDIF
+
+
+ ENDDO!DO color
+
+
+ IF (isweep.EQ.nsweep) THEN
+ !IF (.FALSE.) THEN
+
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info)
+
+
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
+
+ DO k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ DO j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ DO i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+ DO ilda=1,vecdim
+ tuc(ilda,i,j,k)=uc_dummy(ilda,i,j,k,isub)
ENDDO
ENDDO
ENDDO
ENDDO
- ENDIF
- ENDDO!Do isweep
- iopt = ppm_param_dealloc
- ldl5(1) = 1
- ldl5(2) = 1-ghostsize(1)
- ldl5(3) = 1-ghostsize(2)
- ldl5(4) = 1-ghostsize(3)
- ldl5(5) = 1
- ldu5(1) = vecdim
- ldu5(2) = max_node(1,mlev)+ghostsize(1)
- ldu5(4) = max_node(2,mlev)+ghostsize(2)
- ldu5(4) = max_node(3,mlev)+ghostsize(3)
- ldu5(5) = nsubs
- CALL ppm_alloc(uc_dummy,ldl5,ldu5,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
+ ENDDO
+ ENDIF
+
+ ENDDO!Do isweep
+
iopt = ppm_param_dealloc
- ldu1(1)=vecdim
- CALL ppm_alloc(moldu,ldu1,iopt,info)
+ ldl5(1) = 1
+ ldl5(2) = 1-ghostsize(1)
+ ldl5(3) = 1-ghostsize(2)
+ ldl5(4) = 1-ghostsize(3)
+ ldl5(5) = 1
+ ldu5(1) = vecdim
+ ldu5(2) = max_node(1,mlev)+ghostsize(1)
+ ldu5(4) = max_node(2,mlev)+ghostsize(2)
+ ldu5(4) = max_node(3,mlev)+ghostsize(3)
+ ldu5(5) = nsubs
+ CALL ppm_alloc(uc_dummy,ldl5,ldu5,iopt,info)
IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'GSsolv', &
- & 'moldu',__LINE__,info)
- GOTO 9999
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'uc_dummy',__LINE__,info)
+ GOTO 9999
ENDIF
+
+ iopt = ppm_param_dealloc
+ ldu1(1)=vecdim
+ CALL ppm_alloc(moldu,ldu1,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'moldu',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
#endif
#endif
- !---------------------------------------------------------------------
- ! Return
- !----------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_mg_smooth_coarse',t0,info)
- RETURN
+
+ !----------------------------------------------------------------------
+ ! Return
+ !----------------------------------------------------------------------
+9999 CONTINUE
+ CALL substop('ppm_mg_smooth_coarse',t0,info)
+ RETURN
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_2D_sca_s
+ END SUBROUTINE ppm_mg_smooth_coarse_2D_sca_s
#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_2D_sca_d
+ END SUBROUTINE ppm_mg_smooth_coarse_2D_sca_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_3D_sca_s
+ END SUBROUTINE ppm_mg_smooth_coarse_3D_sca_s
#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_3D_sca_d
+ END SUBROUTINE ppm_mg_smooth_coarse_3D_sca_d
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_2D_vec_s
+ END SUBROUTINE ppm_mg_smooth_coarse_2D_vec_s
#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_2D_vec_d
+ END SUBROUTINE ppm_mg_smooth_coarse_2D_vec_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_3D_vec_s
+ END SUBROUTINE ppm_mg_smooth_coarse_3D_vec_s
#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_3D_vec_d
+ END SUBROUTINE ppm_mg_smooth_coarse_3D_vec_d
#endif
#endif
#endif
+
+
+
+
diff --git a/src/ppm_mg_smooth_fine.f b/src/ppm_mg_smooth_fine.f
index 9f496e6..ba01d48 100644
--- a/src/ppm_mg_smooth_fine.f
+++ b/src/ppm_mg_smooth_fine.f
@@ -1,171 +1,168 @@
- !------------------------------------------------------------------------------
- ! Subroutine : ppm_mg_smooth_fine
- !------------------------------------------------------------------------------
- ! Purpose : In this routine we compute the corrections for
- ! the function based on the Gauss-Seidel iteration
- !
- !
- ! Input/output :
- !
- ! Output : info (I) return status. 0 upon success
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !------------------------------------------------------------------------------
- ! $Log: ppm_mg_smooth_fine.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.14 2006/09/26 16:01:23 ivos
- ! Fixed wrongly indented CPP directives. Remember: they have to start in
- ! Col 1, otherwise it does not compile on certain systems. In fact, this
- ! code did NOT compile as it was!!
- !
- ! Revision 1.13 2006/07/21 11:30:55 kotsalie
- ! FRIDAY
- !
- ! Revision 1.11 2006/03/13 10:13:12 ivos
- ! Removed a quote character from the comments. CPP does not like those!
- !
- ! Revision 1.10 2006/02/08 19:54:32 kotsalie
- ! fixed difficult bug for multiple subdomains
- !
- ! Revision 1.9 2006/02/02 16:32:54 kotsalie
- ! corrected for mixed bcs
- !
- ! Revision 1.8 2005/12/08 12:44:46 kotsalie
- ! commiting dirichlet
- !
- ! Revision 1.7 2005/03/14 13:25:48 kotsalie
- ! COMMITED THE VECTOR CASE. IT IS FOR LDA=3
- !
- ! Revision 1.6 2005/01/04 09:45:13 kotsalie
- ! ghostsize=2
- !
- ! Revision 1.5 2004/11/05 18:10:11 kotsalie
- ! FINAL FEATURE BEFORE TEST
- !
- ! Revision 1.3 2004/10/29 15:59:46 kotsalie
- ! RED BLACK SOR
- !
- ! Revision 1.2 2004/09/28 14:05:55 kotsalie
- ! Changes concerning 4th order finite differences
- !
- ! Revision 1.1 2004/09/22 18:44:11 kotsalie
- ! MG new version
- !
- !----------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-----------------------------------------------------------------------------
+!-----------------------------------------------------------------------
+! Subroutine : ppm_mg_smooth_fine
+!-----------------------------------------------------------------------
+! Purpose : In this routine we compute the corrections for
+! the function based on the Gauss-Seidel iteration
+!
+!
+! Input/output :
+!
+! Output : info (I) return status. 0 upon success
+!
+! Remarks :
+!
+! References :
+!
+! Revisions :
+!-------------------------------------------------------------------------
+! $Log: ppm_mg_smooth_fine.f,v $
+! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+! initial import
+!
+! Revision 1.11 2006/03/13 10:13:12 ivos
+! Removed a quote character from the comments. CPP does not like those!
+!
+! Revision 1.10 2006/02/08 19:54:32 kotsalie
+! fixed difficult bug for multiple subdomains
+!
+! Revision 1.9 2006/02/02 16:32:54 kotsalie
+! corrected for mixed bcs
+!
+! Revision 1.8 2005/12/08 12:44:46 kotsalie
+! commiting dirichlet
+!
+! Revision 1.7 2005/03/14 13:25:48 kotsalie
+! COMMITED THE VECTOR CASE. IT IS FOR LDA=3
+!
+! Revision 1.6 2005/01/04 09:45:13 kotsalie
+! ghostsize=2
+!
+! Revision 1.5 2004/11/05 18:10:11 kotsalie
+! FINAL FEATURE BEFORE TEST
+!
+! Revision 1.3 2004/10/29 15:59:46 kotsalie
+! RED BLACK SOR
+!
+! Revision 1.2 2004/09/28 14:05:55 kotsalie
+! Changes concerning 4th order finite differences
+!
+! Revision 1.1 2004/09/22 18:44:11 kotsalie
+! MG new version
+!
+!------------------------------------------------------------------------
+! Parallel Particle Mesh Library (PPM)
+! Institute of Computational Science
+! ETH Zentrum, Hirschengraben 84
+! CH-8092 Zurich, Switzerland
+!-------------------------------------------------------------------------
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_2D_sca_s(field_topoid,u,f,nsweep,mlev, &
- & c1,c2,c3,info)
+ SUBROUTINE ppm_mg_smooth_fine_2D_sca_s(topo_id,u,f,nsweep,mlev,&
+ & c1,c2,c3,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_2D_sca_d(field_topoid,u,f,nsweep,mlev, &
- & c1,c2,c3,info)
+ SUBROUTINE ppm_mg_smooth_fine_2D_sca_d(topo_id,u,f,nsweep,mlev,&
+ & c1,c2,c3,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_3D_sca_s(field_topoid,u,f,nsweep,mlev, &
- & c1,c2,c3,c4,info)
+ SUBROUTINE ppm_mg_smooth_fine_3D_sca_s(topo_id,u,f,nsweep,mlev,&
+ & c1,c2,c3,c4,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_3D_sca_d(field_topoid,u,f,nsweep,mlev, &
- & c1,c2,c3,c4,info)
+ SUBROUTINE ppm_mg_smooth_fine_3D_sca_d(topo_id,u,f,nsweep,mlev,&
+ & c1,c2,c3,c4,info)
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_2D_vec_s(field_topoid,u,f,nsweep,mlev, &
- & c1,c2,c3,info)
+ SUBROUTINE ppm_mg_smooth_fine_2D_vec_s(topo_id,u,f,nsweep,mlev,&
+ & c1,c2,c3,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_2D_vec_d(field_topoid,u,f,nsweep,mlev, &
- & c1,c2,c3,info)
+ SUBROUTINE ppm_mg_smooth_fine_2D_vec_d(topo_id,u,f,nsweep,mlev,&
+ & c1,c2,c3,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_3D_vec_s(field_topoid,u,f,nsweep,mlev, &
- & c1,c2,c3,c4,info)
+ SUBROUTINE ppm_mg_smooth_fine_3D_vec_s(topo_id,u,f,nsweep,mlev,&
+ & c1,c2,c3,c4,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_3D_vec_d(field_topoid,u,f,nsweep,mlev, &
- & c1,c2,c3,c4,info)
+ SUBROUTINE ppm_mg_smooth_fine_3D_vec_d(topo_id,u,f,nsweep,mlev,&
+ & c1,c2,c3,c4,info)
#endif
#endif
#endif
- !---------------------------------------------------------------------
- ! Includes
- !----------------------------------------------------------------------
+
+ !----------------------------------------------------------------------
+ ! Includes
+ !----------------------------------------------------------------------
#include "ppm_define.h"
- !------------------------------------------------------------------
- ! Modules
- !----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_data_mesh
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
+
+ !-------------------------------------------------------------------
+ ! Modules
+ !--------------------------------------------------------------------
+ USE ppm_module_data
+ USE ppm_module_data_mg
+ USE ppm_module_substart
+ USE ppm_module_substop
+ USE ppm_module_error
+ USE ppm_module_alloc
+ USE ppm_module_map
+ USE ppm_module_data_mesh
+
+
+
+ IMPLICIT NONE
#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
+ INTEGER, PARAMETER :: MK = ppm_kind_single
#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
+ INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
- !------------------------------------------------------------------
- ! Arguments
- !----------------------------------------------------------------------
+ !-------------------------------------------------------------------
+ ! Arguments
+ !-------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:),POINTER :: f
+ REAL(MK),DIMENSION(:,:,:),POINTER :: u
+ REAL(MK),DIMENSION(:,:,:),POINTER :: f
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: f
+ REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: u
+ REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: f
#endif
#endif
- INTEGER, INTENT(IN) :: nsweep
- INTEGER, INTENT(IN) :: mlev
+ INTEGER, INTENT(IN) :: nsweep
+ INTEGER, INTENT(IN) :: mlev, topo_id
#if __MESH_DIM == __2D
- REAL(MK), INTENT(IN) :: c1,c2,c3
+ REAL(MK), INTENT(IN) :: c1,c2,c3
#elif __MESH_DIM == __3D
- REAL(MK), INTENT(IN) :: c1,c2,c3,c4
-#endif
- INTEGER, INTENT(INOUT) :: info
- !--------------------------------------------------------------------
- ! Local variables
- !----------------------------------------------------------------------
- CHARACTER(LEN=256) :: cbuf
- INTEGER :: i,j,isub,color
- INTEGER :: ilda,isweep,count
- REAL(MK) :: c11,c22,c33,c44
- REAL(MK) :: dx,dy
- INTEGER,DIMENSION(:),POINTER :: a,b,c,d,e,g
- INTEGER :: k,idom
- REAL(MK) :: x,y
- REAL(MK) :: omega
- INTEGER,DIMENSION(1) :: ldl1,ldu1
- INTEGER,INTENT(IN) :: field_topoid
+ REAL(MK), INTENT(IN) :: c1,c2,c3,c4
+#endif
+ INTEGER, INTENT(INOUT) :: info
+ !---------------------------------------------------------------------
+ ! Local variables
+ !---------------------------------------------------------------------
+ CHARACTER(LEN=256) :: cbuf
+ INTEGER :: i,j,isub,color
+ INTEGER :: ilda,isweep,count
+ REAL(MK) :: c11,c22,c33,c44
+ REAL(MK) :: dx,dy
+ INTEGER,DIMENSION(:),POINTER :: a,b,c,d,e,g
+ INTEGER :: k,idom
+ REAL(MK) :: x,y
+ REAL(MK) :: omega
+ INTEGER,DIMENSION(1) :: ldl1,ldu1
#if __MESH_DIM == __2D
- INTEGER,DIMENSION(4) :: ldl4,ldu4
- INTEGER,DIMENSION(3) :: ldl3,ldu3
+ INTEGER,DIMENSION(4) :: ldl4,ldu4
+ INTEGER,DIMENSION(3) :: ldl3,ldu3
#endif
#if __MESH_DIM == __3D
REAL(MK) :: dz
@@ -203,6 +200,13 @@
#endif
#endif
#endif
+#if __MESH_DIM == __2D
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_red
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_black
+#elif __MESH_DIM == __3D
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black
+#endif
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
REAL(MK),DIMENSION(:,:,:),POINTER :: oldu
@@ -229,17 +233,23 @@
REAL(MK),DIMENSION(:),POINTER :: moldu
#endif
#endif
- !----------------------------------------------------------------------
+
+
+
+ !-----------------------------------------------------------------------
!Externals
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
!Initialize
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+
CALL substart('ppm_mg_smooth_fine',t0,info)
- !----------------------------------------------------------------------
+
+
+ !-----------------------------------------------------------------------
! Check arguments
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
IF (ppm_debug .GT. 0) THEN
IF (nsweep.LT.1) THEN
info = ppm_error_error
@@ -280,10 +290,13 @@
ENDIF
#endif
ENDIF
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
!Definition of necessary variables and allocation of arrays
- !----------------------------------------------------------------------
- topoid=field_topoid
+ !-----------------------------------------------------------------------
+ topoid=topo_id
+
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -313,6 +326,7 @@
#endif
#endif
#endif
+
#if __KIND == __SINGLE_PRECISION
omega=omega_s
dx=dx_s
@@ -328,6 +342,7 @@ dy=dy_d
dz=dz_d
#endif
#endif
+
iopt = ppm_param_alloc_fit
ldl1(1) = 1
ldu1(1) = nsubs
@@ -343,85 +358,218 @@ dz=dz_d
& 'a',__LINE__,info)
GOTO 9999
ENDIF
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- !----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
!Implementation
- !---------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+
count = 0
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 1-ghostsize(1)
+ ldl3(2) = 1-ghostsize(2)
+ ldl3(3) = 1
+ ldu3(1) = max_node(1,mlev)+ghostsize(1)
+ ldu3(2) = max_node(2,mlev)+ghostsize(2)
+ ldu3(3) = nsubs
+ CALL ppm_alloc(mask_dummy_2d,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'mask_dummy_2d',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
DO isweep=1,nsweep
DO color=0,1
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
+ DO isub=1,nsubs
+
+ IF (color.EQ.0) THEN
+ mask_red=>mgfield(isub,mlev)%mask_red
+ mask_dummy_2d(:,:,&
+ & isub)=mask_red(:,:)
+ ELSE
+ mask_black=>mgfield(isub,mlev)%mask_black
+ mask_dummy_2d(:,:,&
+ & isub)=mask_black(:,:)
+ ENDIF
+ ENDDO!DO isub1
+
+
+ !-----------------------------------------------------------------
+ !Communicate red(even) if color==0 or communicate black(odd)
+ !if color==1
+ !-----------------------------------------------------------------
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
+ & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
+ & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
+
+
DO isub=1,nsubs
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1)+mod(j+color,2),istop(1,isub,1),2
+
+ !IMPOSE BOUNDARY CONDITIONS(MICHAEL)
+
+
+ a=0
+ b=0
+ c=0
+ d=0
+
+ IF (.NOT.lperiodic) THEN
+ !NEEDED FOR THE MAIN LOOP
+ DO iface=1,4
+ IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ !DO NOTHING
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+
+ IF (iface.EQ.1) THEN
+ a(isub)=1
+ i=1
+ DO j=1,max_node(2,1)
+ u(i,j,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(j)
+ ENDDO
+ ELSEIF (iface.EQ.2) THEN
+ b(isub)=1
+ i=max_node(2,1)
+ DO j=1,max_node(2,1)
+ u(i,j,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(j)
+ ENDDO
+
+ ELSEIF (iface.EQ.3) THEN
+ c(isub)=1
+ j=1
+ DO i=1,max_node(2,1)
+ u(i,j,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i)
+ ENDDO
+
+ ELSEIF (iface.EQ.4) THEN
+ d(isub)=1
+ j=max_node(2,1)
+ DO i=1,max_node(2,1)
+ u(i,j,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i)
+ ENDDO
+
+ ENDIF
+
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+ !NOT IMPLEMENTED YET
+ !HERE AN EXTRAPOLATION SHOULD TAKE PLACE
+ ENDIF
+ ENDDO
+ ENDIF
+
+
+
+ DO j=start(2,isub,1)+c(isub),stop(2,isub,1)-d(isub)
+ DO i=start(1,isub,1)+a(isub)+mod(j+color,2),stop(1,isub,1)-b(isub)-mod(j+color,2),2
+
u(i,j,isub)=c1*((u(i-1,j,isub)+&
& u(i+1,j,isub))*c2 &
& +(u(i,j-1,isub)+u(i,j+1,isub))*c3 - &
& f(i,j,isub))
+
ENDDO
ENDDO
ENDDO !isub
+
+
+
+ IF (isweep.EQ.nsweep) THEN
+ IF (color.EQ.1) THEN
+ DO isub=1,nsubs
+ mask_red=>mgfield(isub,mlev)%mask_red
+ mask_dummy_2d(:,:,&
+ & isub)=mask_red(:,:)
+ ENDDO
+ ENDIF
+ ENDIF
+
+
ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
+
+ IF (isweep.EQ.nsweep) THEN
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
+ & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
+ & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
+
+ ENDIF
- ENDIF
ENDDO
+
+
+
#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
!Implementation
- !---------------------------------------------------------------------
- DO isweep=1,nsweep
+ !-----------------------------------------------------------------------
+
+ iopt = ppm_param_alloc_fit
+ ldl4(1)=1-ghostsize(1)
+ ldl4(2)=1-ghostsize(2)
+ ldl4(3)=1-ghostsize(3)
+ ldl4(4)=1
+ ldu4(1) = max_node(1,mlev)+ghostsize(1)
+ ldu4(2) = max_node(2,mlev)+ghostsize(2)
+ ldu4(3) = max_node(3,mlev)+ghostsize(3)
+ ldu4(4) = nsubs
+ CALL ppm_alloc(mask_dummy_3d,ldl4,ldu4,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'mask_dummy_3d',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+ DO isweep=1,nsweep
DO color=0,1
- a=0
- b=0
- c=0
- d=0
- e=0
- g=0
+
+
DO isub=1,nsubs
- !-------------------------------------------------------------
- !Impose boundaries on even if color=0 or odd if color=1
- !-------------------------------------------------------------
+ !--------------------------------------------------------------
+ !Impose boundaries on even if color=0 or odd if color=1
+ !--------------------------------------------------------------
+ a=0
+ b=0
+ c=0
+ d=0
+ e=0
+ g=0
+
IF (.NOT.lperiodic) THEN
DO iface=1,6
IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
!DO NOTHING
ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
IF (iface.EQ.1) THEN
- a(isub)=1
- IF (bcdef_sca(isub,2).EQ.0) THEN
- b(isub)=-1
- ENDIF
+ !IF (color.EQ.1) THEN
+ a(isub)=1
+ !ENDIF
i=1
DO j=1,max_node(2,mlev)
DO k=1,max_node(3,mlev)
u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(j,k)
- ENDDO
+ enddo
ENDDO
ELSEIF (iface.EQ.2) THEN
+ !IF (color.EQ.0) THEN
b(isub)=1
- IF (bcdef_sca(isub,1).EQ.0) THEN
- a(isub)=-1
- ENDIF
+ !ENDIF
i=max_node(1,mlev)
DO j=1,max_node(2,mlev)
DO k=1,max_node(3,mlev)
@@ -429,10 +577,7 @@ dz=dz_d
ENDDO
enddo
ELSEIF (iface.EQ.3) THEN
- c(isub)= 1
- IF (bcdef_sca(isub,4).EQ.0) THEN
- d(isub)=-1
- ENDIF
+ c(isub)=1
j=1
DO i=1,max_node(1,mlev)
Do k=1,max_node(3,mlev)
@@ -441,9 +586,6 @@ dz=dz_d
ENDDO
ELSEIF (iface.EQ.4) THEN
d(isub)=1
- IF (bcdef_sca(isub,3).EQ.0) THEN
- c(isub)=-1
- ENDIF
j=max_node(2,mlev)
DO i=1,max_node(1,mlev)
Do k=1,max_node(3,mlev)
@@ -451,11 +593,8 @@ dz=dz_d
enddo
ENDDO
ELSEIF (iface.EQ.5) Then
- e(isub)=1
- IF (bcdef_sca(isub,6).EQ.0) THEN
- g(isub)=-1
- ENDIF
- k=1
+ e(isub)=1
+ k=1
DO i=1,max_node(1,mlev)
Do j=1,max_node(2,mlev)
u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i,j)
@@ -463,9 +602,6 @@ dz=dz_d
ENDDO
ELSEIF (iface.EQ.6) Then
g(isub)=1
- IF (bcdef_sca(isub,5).EQ.0) THEN
- e(isub)=-1
- ENDIF
k=max_node(3,mlev)
DO i=1,max_node(1,mlev)
Do j=1,max_node(2,mlev)
@@ -473,31 +609,83 @@ dz=dz_d
ENDDO
ENDDO
+
ENDIF
+
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+ !NOT IMPLEMENTED YET
+ !HERE AN EXTRAPOLATION SHOULD TAKE PLACE
ENDIF
- ENDDO!iface
- ENDIF
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate red(even) if color==0 or communicate black(odd)
- !if color==1
- !----------------------------------------------------------------
+ ENDDO!iface
+ End if
+ IF (color.EQ.0) THEN
+ mask_red=>mgfield(isub,mlev)%mask_red
+ do k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ do j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ do i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+
+ mask_dummy_3d(i,j,k,isub)= mask_red(i,j,k)
+
+ end do
+ end do
+ end do
+ ELSE
+ mask_black=>mgfield(isub,mlev)%mask_black
+ do k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ do j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ do i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+
+ mask_dummy_3d(i,j,k,isub)= mask_black(i,j,k)
+
+ end do
+ end do
+ end do
+
+ ENDIF
+
+ ENDDO!DO isub2
+
+
+ !-----------------------------------------------------------------
+ !Communicate red(even) if color==0 or communicate black(odd)
+ !if color==1
+ !-----------------------------------------------------------------
+
+#ifdef __WITHOUTMASKS
+
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
+ & ghostsize,ppm_param_map_ghost_get,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
+ & ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
+ & ghostsize,ppm_param_map_pop,info)
+
+#else
+
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_3d)
+
+
+
+#endif
+
+
DO isub=1,nsubs
- DO k=start(3,isub,1)+e(isub),istop(3,isub,1)-g(isub)
- DO j=start(2,isub,1)+c(isub),istop(2,isub,1)-d(isub)
- DO i=start(1,isub,1)+mod(j+k+color,2)+a(isub), &
- & istop(1,isub,1)-b(isub)-mod(j+k+color,2),2
- IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND. &
- & (j.GE.1.AND.j.LE.max_node(2,mlev)).AND.(k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
+ DO k=start(3,isub,1)+g(isub),stop(3,isub,1)-e(isub)
+ DO j=start(2,isub,1)+c(isub),stop(2,isub,1)-d(isub)
+ DO i=start(1,isub,1)+mod(j+k+color,2)+a(isub),stop(1,isub,1)-b(isub)-mod(j+k+color,2),2
+
moldu=u(i,j,k,isub)
+
+
u(i,j,k,isub)=moldu+omega*&
& (&
& c1*((u(i-1,j,k,isub)+ &
@@ -506,96 +694,198 @@ dz=dz_d
& +(u(i,j,k-1,isub)+u(i,j,k+1,isub))*c4- &
& f(i,j,k,isub))&
&-moldu)
- ENDIF
ENDDO
ENDDO
ENDDO
- ENDDO!subs
+
+ ENDDO!subs
+
+ IF (isweep.EQ.nsweep) THEN
+ IF(color.EQ.1) THEN
+ DO isub=1,nsubs
+ mask_red=>mgfield(isub,mlev)%mask_red
+ do k=1-ghostsize(3),max_node(3,mlev)+ghostsize(3)
+ do j=1-ghostsize(2),max_node(2,mlev)+ghostsize(2)
+ do i=1-ghostsize(1),max_node(1,mlev)+ghostsize(1)
+ mask_dummy_3d(i,j,k,isub)= mask_red(i,j,k)
+ end do
+ end do
+ end do
+ ENDDO
+ ENDIF
+ ENDIF
ENDDO!DO color
+
IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
+
+#ifdef __WITHOUTMASKS
+
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
+ & ghostsize,ppm_param_map_ghost_get,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
- ENDIF
- ENDDO
+ & ghostsize,ppm_param_map_send,info)
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info)
+
+#else
+
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_push,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_send,info,mask_dummy_3d)
+ CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_3d)
+
+
+
+#endif
+
+ ENDIF
+ ENDDO
+
+
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- !----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
!Implementation
- !---------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+
count = 0
+
+ iopt = ppm_param_alloc_fit
+ ldl3(1) = 0
+ ldl3(2) = 0
+ ldl3(3) = 1
+ ldu3(1) = max_node(1,mlev)+1
+ ldu3(2) = max_node(2,mlev)+1
+ ldu3(3) = nsubs
+ CALL ppm_alloc(mask_dummy_2d,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'mask_dummy_2d',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
DO isweep=1,nsweep
DO color=0,1
- !----------------------------------------------------------------
- !Communicate red(even) if color==0 or communicate black(odd)
- !if color==1
- !----------------------------------------------------------------
+ DO isub=1,nsubs
+ !-------------------------------------------------------------
+ !Impose boundaries on even if color=0 or odd if color=1
+ !-------------------------------------------------------------
+
+ IF (color.EQ.0) THEN
+ mask_red=>mgfield(isub,mlev)%mask_red
+ mask_dummy_2d(:,:,isub)=mask_red(:,:)
+ ELSE
+ mask_black=>mgfield(isub,mlev)%mask_black
+ mask_dummy_2d(:,:,isub)=mask_black(:,:)
+ ENDIF
+
+
+ ENDDO!DO isub3
+
+ !-----------------------------------------------------------------
+ !Communicate red(even) if color==0 or communicate black(odd)
+ !if color==1
+ !-----------------------------------------------------------------
+
+
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
+ & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
+ & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
+
+
+
+
DO isub=1,nsubs
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1)+mod(j+color,2),istop(1,isub,1),2
+ DO j=start(2,isub,1),stop(2,isub,1)
+ DO i=start(1,isub,1)+mod(j+color,2),stop(1,isub,1),2
DO ilda=1,vecdim
+
+
u(ilda,i,j,isub)=c1*((u(ilda,i-1,j,isub)+&
& u(ilda,i+1,j,isub))*c2 &
& +(u(ilda,i,j-1,isub)+u(ilda,i,j+1,isub))*c3 - &
& f(ilda,i,j,isub))
+
ENDDO
ENDDO
ENDDO
ENDDO
+ IF (isweep.EQ.nsweep) THEN
+ IF (color.EQ.1) THEN
+ DO isub=1,nsubs
+ mask_red=>mgfield(isub,mlev)%mask_red
+ mask_dummy_2d(:,:,isub)=mask_red(:,:)
+ ENDDO
+ ENDIF
+ ENDIF
+
ENDDO!DO color
IF (isweep.EQ.nsweep) THEN
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
+ & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
+ & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
+ & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
+ & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
+
ENDIF
- ENDDO
+
+ ENDDO
+
+
+
#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
!Implementation
- !---------------------------------------------------------------------
+ !-----------------------------------------------------------------------
+
+
iopt = ppm_param_alloc_fit
ldu1(1)=vecdim
- CALL ppm_alloc(moldu,ldu1,iopt,info)
+ CALL ppm_alloc(moldu,ldu1,iopt,info)
IF (info .NE. 0) THEN
info = ppm_error_fatal
CALL ppm_error(ppm_err_alloc,'GSsolv', &
& 'moldu',__LINE__,info)
GOTO 9999
ENDIF
- DO isweep=1,nsweep
+
+
+ DO isweep=1,nsweep
DO color=0,1
- a=0
- b=0
- c=0
- d=0
- e=0
- g=0
+
+ a=0
+ b=0
+ c=0
+ d=0
+ e=0
+ g=0
DO isub=1,nsubs
DO ilda=1,vecdim
+
IF (.NOT.lperiodic) THEN
DO iface=1,6
IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
!DO NOTHING
ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+
IF (iface.EQ.1) THEN
a(isub)=1
IF (bcdef_vec(ilda,isub,2).EQ.0) THEN
@@ -615,7 +905,7 @@ dz=dz_d
i=max_node(1,mlev)
DO j=1,max_node(2,mlev)
DO k=1,max_node(3,mlev)
- u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,j,k)
+ u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,j,k)
ENDDO
enddo
ELSEIF (iface.EQ.3) THEN
@@ -629,6 +919,7 @@ dz=dz_d
u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,k)
enddo
ENDDO
+
ELSEIF (iface.EQ.4) THEN
d(isub)=1
IF (bcdef_vec(ilda,isub,3).EQ.0) THEN
@@ -637,7 +928,7 @@ dz=dz_d
j=max_node(2,mlev)
DO i=1,max_node(1,mlev)
Do k=1,max_node(3,mlev)
- u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,k)
+ u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,k)
enddo
ENDDO
ELSEIF (iface.EQ.5) Then
@@ -648,7 +939,7 @@ dz=dz_d
k=1
DO i=1,max_node(1,mlev)
Do j=1,max_node(2,mlev)
- u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,j)
+ u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,j)
enddo
ENDDO
ELSEIF (iface.EQ.6) Then
@@ -659,38 +950,51 @@ dz=dz_d
k=max_node(3,mlev)
DO i=1,max_node(1,mlev)
Do j=1,max_node(2,mlev)
- u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,j)
+ u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,j)
ENDDO
ENDDO
- ENDIF
+
+ ENDIF
+ ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_neumann) THEN
+
+
ENDIF
- ENddo !iface
- endif !periodic
- Enddo !ilda
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate red(even) if color==0 or communicate black(odd)
- !if color==1
- !----------------------------------------------------------------
+
+ ENddo !iface
+ endif !periodic
+ Enddo !ilda
+ ENDDO!DO isub4
+
+
+ !-----------------------------------------------------------------
+ !Communicate red(even) if color==0 or communicate black(odd)
+ !if color==1
+ !-----------------------------------------------------------------
+
+
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
+ & ghostsize,ppm_param_map_ghost_get,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
+ & ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
+ & ghostsize,ppm_param_map_pop,info)
+
+
#ifdef __VECTOR
+
+
DO isub=1,nsubs
- DO k=start(3,isub,1)+e(isub),istop(3,isub,1)-g(isub)
- DO j=start(2,isub,1)+c(isub),istop(2,isub,1)-d(isub)
- DO i=start(1,isub,1)+mod(j+k+color,2)+a(isub), &
- & istop(1,isub,1)-b(isub)-mod(j+k+color,2),2
- IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND. &
- & (j.GE.1.AND.j.LE.max_node(2,mlev)).AND.(k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
+ DO k=start(3,isub,1)+e(isub),stop(3,isub,1)-g(isub)
+ DO j=start(2,isub,1)+c(isub),stop(2,isub,1)-d(isub)
+ DO i=start(1,isub,1)+mod(j+k+color,2)+a(isub),stop(1,isub,1)-b(isub)-mod(j+k+color,2),2
+
+
moldu(1) = u(1,i,j,k,isub)
moldu(2) = u(2,i,j,k,isub)
moldu(3) = u(3,i,j,k,isub)
+
u(1,i,j,k,isub)=moldu(1)+omega*&
& (&
&c1*((u(1,i-1,j,k,isub)+ &
@@ -698,7 +1002,8 @@ dz=dz_d
& +(u(1,i,j-1,k,isub)+u(1,i,j+1,k,isub))*c3 &
& +(u(1,i,j,k-1,isub)+u(1,i,j,k+1,isub))*c4- &
& f(1,i,j,k,isub))&
-&-moldu(1))
+&-moldu(1))
+
u(2,i,j,k,isub)=moldu(2)+omega*&
& (&
&c1*((u(2,i-1,j,k,isub)+ &
@@ -706,7 +1011,9 @@ dz=dz_d
& +(u(2,i,j-1,k,isub)+u(2,i,j+1,k,isub))*c3 &
& +(u(2,i,j,k-1,isub)+u(2,i,j,k+1,isub))*c4- &
& f(2,i,j,k,isub))&
-&-moldu(2))
+&-moldu(2))
+
+
u(3,i,j,k,isub)=moldu(3)+omega*&
& (&
&c1*((u(3,i-1,j,k,isub)+ &
@@ -714,23 +1021,40 @@ dz=dz_d
& +(u(3,i,j-1,k,isub)+u(3,i,j+1,k,isub))*c3 &
& +(u(3,i,j,k-1,isub)+u(3,i,j,k+1,isub))*c4- &
& f(3,i,j,k,isub))&
-&-moldu(3))
+&-moldu(3))
+
+
ENDDO
ENDDO
ENDDO
- ENDDO!subs
-#else
+ ENDDO!subs
+
+
+#else
+
DO isub=1,nsubs
- DO k=start(3,isub,1)+e(isub),istop(3,isub,1)-g(isub)
- DO j=start(2,isub,1)+c(isub),istop(2,isub,1)-d(isub)
- DO i=start(1,isub,1)+mod(j+k+color,2)+a(isub), &
- & istop(1,isub,1)-b(isub)-mod(j+k+color,2),2
- IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND. &
- & (j.GE.1.AND.j.LE.max_node(2,mlev)).AND.(k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
+ DO k=start(3,isub,1)+e(isub),stop(3,isub,1)-g(isub)
+ DO j=start(2,isub,1)+c(isub),stop(2,isub,1)-d(isub)
+ DO i=start(1,isub,1)+mod(j+k+color,2)+a(isub),stop(1,isub,1)-b(isub)-mod(j+k+color,2),2
+ IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND.&
+ & (j.GE.1.AND.j.LE.max_node(2,mlev)).AND.&
+ & (k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
+
+ !PRINT *,'ISUB:',isub,i,j,k,a(isub),b(isub),color
+
+
+
do ilda=1,vecdim
moldu(ilda) = u(ilda,i,j,k,isub)
end do
+
+ IF (isub.GT.4) THEN
+
+ !PRINT *,'k:',k
+
+ ENDIF
DO ilda=1,vecdim
+
u(ilda,i,j,k,isub)=moldu(ilda)+omega*&
& (&
&c1*((u(ilda,i-1,j,k,isub)+ &
@@ -738,16 +1062,23 @@ dz=dz_d
& +(u(ilda,i,j-1,k,isub)+u(ilda,i,j+1,k,isub))*c3 &
& +(u(ilda,i,j,k-1,isub)+u(ilda,i,j,k+1,isub))*c4- &
& f(ilda,i,j,k,isub))&
-&-moldu(ilda))
+ & -moldu(ilda))
ENDDO
- ENDIF
+ ENDIF!HACK
ENDDO
ENDDO
ENDDO
- ENDDO!subs
+ !PRINT *,'AFTER:',u(1,:,:,17,6)
+
+ ENDDO!subs
+
#endif
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
+
+
+
+ ENDDO!DO color
+ IF (isweep.EQ.nsweep) THEN
+
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
& ghostsize,ppm_param_map_ghost_get,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
@@ -756,11 +1087,14 @@ dz=dz_d
& ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
& ghostsize,ppm_param_map_pop,info)
+
ENDIF
ENDDO
+
+
iopt = ppm_param_dealloc
ldu1(1)=vecdim
- CALL ppm_alloc(moldu,ldu1,iopt,info)
+ CALL ppm_alloc(moldu,ldu1,iopt,info)
IF (info .NE. 0) THEN
info = ppm_error_fatal
CALL ppm_error(ppm_err_alloc,'GSsolv', &
@@ -769,13 +1103,13 @@ dz=dz_d
ENDIF
#endif
#endif
- !---------------------------------------------------------------------
- ! Return
+
+ !----------------------------------------------------------------------
+ ! Return
!----------------------------------------------------------------------
9999 CONTINUE
CALL substop('ppm_mg_smooth_fine',t0,info)
RETURN
-
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -805,3 +1139,7 @@ dz=dz_d
#endif
#endif
#endif
+
+
+
+
diff --git a/src/ppm_mg_solv.f b/src/ppm_mg_solv.f
index d769841..c5cd3f6 100644
--- a/src/ppm_mg_solv.f
+++ b/src/ppm_mg_solv.f
@@ -1,269 +1,261 @@
- !------------------------------------------------------------------------
- ! Subroutine : ppm_mg_solv
- !------------------------------------------------------------------------
- !
- ! Input : itera (I) : initial smoothing sweeps
- ! in the finest level.
- !
- ! iterf (I) : final smoothing sweeps
- ! in the finest level
- !
- ! iter1 (I) : AFTER EACH RESTRICTION
- ! SMOOTHING SWEEPS TAKE PLACE
- ! IMPORTANT PARAMETER
- !
- ! iter2 (I) : AFTER EACH PROLONGATION
- ! SMOOTHING SWEEPS TAKE PLACE
- !
- !
- ! Input/Output : u (F) : THE FIELD OF THE SOLUTION
- ! WITH GHOST VALUES!!
- ! f (F) : THE FIELD OF THE RHS (NO GHOST
- ! VALUES)
- ! Output : info (I)
- !
- ! Purpose :
- !
- !
- ! References :
- !
- ! Revisions :
- !------------------------------------------------------------------------
- ! $Log: ppm_mg_solv.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.17 2006/09/26 16:01:24 ivos
- ! Fixed wrongly indented CPP directives. Remember: they have to start in
- ! Col 1, otherwise it does not compile on certain systems. In fact, this
- ! code did NOT compile as it was!!
- !
- ! Revision 1.16 2006/07/21 11:30:54 kotsalie
- ! FRIDAY
- !
- ! Revision 1.14 2005/12/08 12:44:46 kotsalie
- ! commiting dirichlet
- !
- ! Revision 1.13 2005/05/30 13:03:22 kotsalie
- ! UPDATED FOR SERIAL VERSION WITHOUT MPI
- !
- ! Revision 1.12 2005/03/14 13:24:03 kotsalie
- ! COMMITED THE VECTOR CASE. IT IS FOR LDA=3
- !
- ! Revision 1.11 2005/01/04 09:48:21 kotsalie
- ! ghostsize=2 scalar case
- !
- ! Revision 1.10 2004/11/05 15:18:35 kotsalie
- ! Made independent the initial and final smoothing steps
- !
- ! Revision 1.9 2004/10/13 16:02:03 kotsalie
- ! Maximum residual between processors is communicated
- !
- ! Revision 1.8 2004/09/30 14:26:24 kotsalie
- ! *** empty log message ***
- !
- ! Revision 1.7 2004/09/29 10:47:36 kotsalie
- ! The user can now print the residual. THis should serve for him
- ! as a istopping criterium
- !
- ! Revision 1.6 2004/09/23 13:50:54 kotsalie
- ! Changed IF (w_cycle) to IF(.FALSE.) Now the recusrion goes up to level 2.
- !
- ! Revision 1.5 2004/09/23 12:41:16 kotsalie
- ! MG new version
- !
- !------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
+ !-------------------------------------------------------------------------
+ ! Subroutine : ppm_mg_solv
+ !-------------------------------------------------------------------------
+ !
+ ! Input : itera (I) : initial smoothing sweeps
+ ! in the finest level.
+ !
+ ! iterf (I) : final smoothing sweeps
+ ! in the finest level
+ !
+ ! iter1 (I) : AFTER EACH RESTRICTION
+ ! SMOOTHING SWEEPS TAKE PLACE
+ ! IMPORTANT PARAMETER
+ !
+ ! iter2 (I) : AFTER EACH PROLONGATION
+ ! SMOOTHING SWEEPS TAKE PLACE
+ !
+ !
+ ! Input/Output : u (F) : THE FIELD OF THE SOLUTION
+ ! WITH GHOST VALUES!!
+ ! f (F) : THE FIELD OF THE RHS (NO GHOST
+ ! VALUES)
+ ! Output : info (I)
+ !
+ ! Purpose :
+ !
+ !
+ ! References :
+ !
+ ! Revisions :
+ !-------------------------------------------------------------------------
+ ! $Log: ppm_mg_solv.f,v $
+ ! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+ ! initial import
+ !
+ ! Revision 1.14 2005/12/08 12:44:46 kotsalie
+ ! commiting dirichlet
+ !
+ ! Revision 1.13 2005/05/30 13:03:22 kotsalie
+ ! UPDATED FOR SERIAL VERSION WITHOUT MPI
+ !
+ ! Revision 1.12 2005/03/14 13:24:03 kotsalie
+ ! COMMITED THE VECTOR CASE. IT IS FOR LDA=3
+ !
+ ! Revision 1.11 2005/01/04 09:48:21 kotsalie
+ ! ghostsize=2 scalar case
+ !
+ ! Revision 1.10 2004/11/05 15:18:35 kotsalie
+ ! Made independent the initial and final smoothing steps
+ !
+ ! Revision 1.9 2004/10/13 16:02:03 kotsalie
+ ! Maximum residual between processors is communicated
+ !
+ ! Revision 1.8 2004/09/30 14:26:24 kotsalie
+ ! *** empty log message ***
+ !
+ ! Revision 1.7 2004/09/29 10:47:36 kotsalie
+ ! The user can now print the residual. THis should serve for him
+ ! as a stopping criterium
+ !
+ ! Revision 1.6 2004/09/23 13:50:54 kotsalie
+ ! Changed IF (w_cycle) to IF(.FALSE.) Now the recusrion goes up to level 2.
+ !
+ ! Revision 1.5 2004/09/23 12:41:16 kotsalie
+ ! MG new version
+ !
+ !-------------------------------------------------------------------------
+ ! Parallel Particle Mesh Library (PPM)
+ ! Institute of Computational Science
+ ! ETH Zentrum, Hirschengraben 84
+ ! CH-8092 Zurich, Switzerland
+ !-------------------------------------------------------------------------
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_solv_2d_sca_s(field_topoid,u,f,itera,iterf,iter1,&
- & iter2,Eu,info)
+ SUBROUTINE ppm_mg_solv_2d_sca_s(topo_id,u,f,itera,iterf,iter1,iter2,&
+ & Eu,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_solv_2d_sca_d(field_topoid,u,f,itera,iterf,iter1,&
- & iter2,Eu,info)
+ SUBROUTINE ppm_mg_solv_2d_sca_d(topo_id,u,f,itera,iterf,iter1,iter2,&
+ & Eu,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_solv_3d_sca_s(field_topoid,u,f,itera,iterf,iter1,&
- & iter2,Eu,info)
+ SUBROUTINE ppm_mg_solv_3d_sca_s(topo_id,u,f,itera,iterf,iter1,iter2,&
+ & Eu,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_solv_3d_sca_d(field_topoid,u,f,itera,iterf,iter1,&
- & iter2,Eu,info)
+ SUBROUTINE ppm_mg_solv_3d_sca_d(topo_id,u,f,itera,iterf,iter1,iter2,&
+ & Eu,info)
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_solv_2d_vec_s(field_topoid,u,f,lda,itera,iterf,iter1,&
- & iter2,Eu,info)
+ SUBROUTINE ppm_mg_solv_2d_vec_s(topo_id,u,f,lda,itera,iterf,iter1,iter2,&
+ & Eu,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_solv_2d_vec_d(field_topoid,u,f,lda,itera,iterf,iter1,&
- & iter2,Eu,info)
+ SUBROUTINE ppm_mg_solv_2d_vec_d(topo_id,u,f,lda,itera,iterf,iter1,iter2,&
+ & Eu,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_solv_3d_vec_s(field_topoid,u,f,lda,itera,iterf,iter1,&
- & iter2,Eu,info)
+ SUBROUTINE ppm_mg_solv_3d_vec_s(topo_id,u,f,lda,itera,iterf,iter1,iter2,&
+ & Eu,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_solv_3d_vec_d(field_topoid,u,f,lda,itera,iterf,iter1,&
- & iter2,Eu,info)
+ SUBROUTINE ppm_mg_solv_3d_vec_d(topo_id,u,f,lda,itera,iterf,iter1,iter2,&
+ & Eu,info)
#endif
#endif
#endif
+
#include "ppm_define.h"
- !---------------------------------------------------------------------
- ! Modules
- !----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_data_mesh
- USE ppm_module_mg_core
- USE ppm_module_mg_res
- USE ppm_module_mg_prolong
- USE ppm_module_mg_smooth
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
+
+ !----------------------------------------------------------------------
+ ! Modules
+ !----------------------------------------------------------------------
+ USE ppm_module_data
+ USE ppm_module_data_mg
+ USE ppm_module_data_mesh
+ USE ppm_module_substart
+ USE ppm_module_substop
+ USE ppm_module_error
+ USE ppm_module_alloc
+ USE ppm_module_map
+ USE ppm_module_mg_core
+ USE ppm_module_mg_res
+ USE ppm_module_mg_prolong
+ USE ppm_module_mg_smooth
+ USE ppm_module_write
+
+ IMPLICIT NONE
+
#ifdef __MPI
- INCLUDE 'mpif.h'
+ INCLUDE 'mpif.h'
#endif
+
#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
+ INTEGER, PARAMETER :: MK = ppm_kind_single
#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
+ INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
- !----------------------------------------------------------------------
- ! Arguments (for u and f index: local mesh locations and isub)
- !----------------------------------------------------------------------
+ !----------------------------------------------------------------------
+ ! Arguments (for u and f index: local mesh locations and isub)
+ !----------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:),POINTER :: f
+ REAL(MK),DIMENSION(:,:,:),POINTER :: u
+ REAL(MK),DIMENSION(:,:,:),POINTER :: f
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: f
+ REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: u
+ REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: f
#endif
#endif
#if __DIM == __VFIELD
- INTEGER,INTENT(IN) :: lda
+ INTEGER,INTENT(IN) :: lda
#endif
- INTEGER, INTENT(IN) :: itera,iterf,iter1,iter2
- REAL(MK), INTENT(OUT) :: Eu
- INTEGER, INTENT(INOUT):: info
- INTEGER, INTENT(IN) :: field_topoid
- !----------------------------------------------------------------------
- ! Local variables
- !----------------------------------------------------------------------
- REAL(MK) :: t0
- REAL(MK) :: E,res
- INTEGER :: iface,count,k
- INTEGER :: ix,iy
- CHARACTER(LEN=256) :: cbuf
- INTEGER :: mlev,color,it
- INTEGER :: ncalls=0
- REAL(MK) :: c1,c2,c3,c4
- INTEGER :: isub,i,j
- REAL(MK) :: x,y
- REAL(MK) :: gEu
- INTEGER :: MPI_PREC
+ INTEGER, INTENT(IN) :: itera,iterf,iter1,iter2
+ REAL(MK), INTENT(OUT) :: Eu
+ INTEGER, INTENT(INOUT) :: info
+ INTEGER, INTENT(IN ) :: topo_id
+ !----------------------------------------------------------------------
+ ! Local variables
+ !----------------------------------------------------------------------
+ REAL(MK) :: t0
+ REAL(MK) :: E,res
+ INTEGER :: iface,count,k
+ INTEGER :: ix,iy
+ CHARACTER(LEN=256) :: cbuf
+ INTEGER :: mlev,color,it
+ INTEGER :: ncalls=0
+ REAL(MK) :: c1,c2,c3,c4
+ INTEGER :: isub,i,j
+ REAL(MK) :: x,y
+ REAL(MK) :: gEu
+ INTEGER :: MPI_PREC
+ TYPE(ppm_t_topo), POINTER :: topo
+
+
#if __MESH_DIM == __3D
- REAL(MK) :: c5,dz,rdz2
- INTEGER,DIMENSION(4) :: ldl4,ldu4
- INTEGER,DIMENSION(5) :: ldl5,ldu5
-#endif
- INTEGER :: ilda
- REAL(MK) :: rdx2,rdy2
- REAL(MK) :: dx,dy
+ REAL(MK) :: c5,dz,rdz2
+ INTEGER,DIMENSION(4) :: ldl4,ldu4
+ INTEGER,DIMENSION(5) :: ldl5,ldu5
+#endif
+ INTEGER :: ilda
+ REAL(MK) :: rdx2,rdy2
+ REAL(MK) :: dx,dy
+ REAL(MK) :: EPSU
#if __MESH_DIM == __2D
- INTEGER,DIMENSION(3) :: ldl3,ldu3
- INTEGER,DIMENSION(4) :: ldl4,ldu4
+ INTEGER,DIMENSION(3) :: ldl3,ldu3
+ INTEGER,DIMENSION(4) :: ldl4,ldu4
#endif
- INTEGER :: topoid,iopt,idom
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
+ INTEGER :: topoid,iopt,idom
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield
+ TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield
#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: uc_dummy
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
+ TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc_dummy
#endif
#endif
+
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: tuc
+ REAL(MK),DIMENSION(:,:,:),POINTER :: uc_dummy
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
+ REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy
#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc
+ REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc_dummy
#endif
#endif
- !----------------------------------------------------------------------
- ! Externals
- !----------------------------------------------------------------------
- !----------------------------------------------------------------------
- ! Initialize
- !----------------------------------------------------------------------
- CALL substart('ppm_mg_solv',t0,info)
- topo => ppm_topo(field_topoid)%t
- mesh => topo%mesh(meshid_g(1))
+ !----------------------------------------------------------------------
+ ! Externals
+ !----------------------------------------------------------------------
+
+ !----------------------------------------------------------------------
+ ! Initialize
+ !----------------------------------------------------------------------
+
+ CALL substart('ppm_mg_solv',t0,info)
+
#ifdef __MPI
IF (ppm_kind.EQ.ppm_kind_single) THEN
MPI_PREC = MPI_REAL
@@ -271,9 +263,11 @@
MPI_PREC = MPI_DOUBLE_PRECISION
ENDIF
#endif
- !----------------------------------------------------------------------
+ topo => ppm_topo(topo_id)%t
+
+ !-----------------------------------------------------------------------
! Check arguments
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
IF (ppm_debug .GT. 0) THEN
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
@@ -283,18 +277,18 @@
& 'solution exist on nsubs subdomains',__LINE__,info)
GOTO 9999
ENDIF
- topoid=field_topoid
+ topoid=topo_id
DO i=1,nsubs
idom=topo%isublist(i)
- IF (SIZE(u(:,:,i),1).LT. mesh%nnodes(1,idom) &
- & +2*ghostsize(1)) THEN
+ IF (SIZE(u(:,:,i),1).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(1,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in x-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(u(:,:,i),2).LT.mesh%nnodes(2,idom) &
- & +2*ghostsize(2)) THEN
+ IF (SIZE(u(:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(2,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in y-dir!',__LINE__,info)
@@ -307,17 +301,18 @@
& 'rhs exist on nsubs subdomains!',__LINE__,info)
GOTO 9999
ENDIF
- topoid=field_topoid
-
+ topoid=topo_id
DO i=1,nsubs
idom=topo%isublist(i)
- IF (SIZE(f(:,:,i),1).LT.mesh%nnodes(1,idom)) THEN
+ IF (SIZE(f(:,:,i),1).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(1,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in x-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(f(:,:,i),2).LT.mesh%nnodes(2,idom)) THEN
+ IF (SIZE(f(:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(2,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in y-dir!',__LINE__,info)
@@ -331,25 +326,25 @@
& 'solution exist on nsubs subdomains!',__LINE__,info)
GOTO 9999
ENDIF
- topoid=field_topoid
+ topoid=topo_id
DO i=1,nsubs
idom=topo%isublist(i)
- IF (SIZE(u(:,:,:,i),1).LT.mesh%nnodes(1,idom) &
- & +2*ghostsize(1)) THEN
+ IF (SIZE(u(:,:,:,i),1).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(1,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in x-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(u(:,:,:,i),2).LT.mesh%nnodes(2,idom) &
- & +2*ghostsize(2)) THEN
+ IF (SIZE(u(:,:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(2,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in y-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(u(:,:,:,i),3).LT.mesh%nnodes(3,idom) &
- & +2*ghostsize(3)) THEN
+ IF (SIZE(u(:,:,:,i),3).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(3,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in z-dir!',__LINE__,info)
@@ -362,22 +357,25 @@
& 'rhs exist on nsubs subdomains!',__LINE__,info)
GOTO 9999
ENDIF
- topoid=field_topoid
+ topoid=topo_id
DO i=1,nsubs
idom=topo%isublist(i)
- IF (SIZE(f(:,:,:,i),1).LT.mesh%nnodes(1,idom)) THEN
+ IF (SIZE(f(:,:,:,i),1).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(1,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in x-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(f(:,:,:,i),2).LT.mesh%nnodes(2,idom)) THEN
+ IF (SIZE(f(:,:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(2,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in y-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(f(:,:,:,i),3).LT.mesh%nnodes(3,idom)) THEN
+ IF (SIZE(f(:,:,:,i),3).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(3,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in z-dir!',__LINE__,info)
@@ -393,16 +391,18 @@
& 'solution exist on nsubs subdomains',__LINE__,info)
GOTO 9999
ENDIF
- topoid=field_topoid
+ topoid=topo_id
DO i=1,nsubs
idom=topo%isublist(i)
- IF (SIZE(u(:,:,:,i),2).LT.mesh%nnodes(1,idom)+2) THEN
+ IF (SIZE(u(:,:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(1,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in x-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(u(:,:,:,i),3).LT.mesh%nnodes(2,idom)+2) THEN
+ IF (SIZE(u(:,:,:,i),3).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(2,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in y-dir!',__LINE__,info)
@@ -415,16 +415,18 @@
& 'rhs exist on nsubs subdomains!',__LINE__,info)
GOTO 9999
ENDIF
- topoid=field_topoid
+ topoid=topo_id
DO i=1,nsubs
idom=topo%isublist(i)
- IF (SIZE(f(:,:,:,i),2).LT.mesh%nnodes(1,idom)) THEN
+ IF (SIZE(f(:,:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(1,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in x-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(f(:,:,:,i),3).LT.mesh%nnodes(2,idom)) THEN
+ IF (SIZE(f(:,:,:,i),3).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(2,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in y-dir!',__LINE__,info)
@@ -432,31 +434,32 @@
ENDIF
ENDDO
#elif __MESH_DIM == __3D
+ PRINT *,'SIZE:',SIZE(u,5),nsubs,idom
IF (SIZE(u,5) .LT. nsubs) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution exist on nsubs subdomains!',__LINE__,info)
GOTO 9999
ENDIF
- topoid=field_topoid
+ topoid=topo_id
DO i=1,nsubs
idom=topo%isublist(i)
- IF (SIZE(u(:,:,:,:,i),2).LT.mesh%nnodes(1,idom)&
- & +2*ghostsize(1)) THEN
+ IF (SIZE(u(:,:,:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(1,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in x-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(u(:,:,:,:,i),3).LT.mesh%nnodes(2,idom)&
- & +2*ghostsize(2)) THEN
+ IF (SIZE(u(:,:,:,:,i),3).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(2,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in y-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(u(:,:,:,:,i),4).LT.mesh%nnodes(3,idom)&
- & +2*ghostsize(3)) THEN
+ IF (SIZE(u(:,:,:,:,i),4).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(3,idom)+2) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in z-dir!',__LINE__,info)
@@ -469,22 +472,25 @@
& 'rhs exist on nsubs subdomains!',__LINE__,info)
GOTO 9999
ENDIF
- topoid=field_topoid
+ topoid=topo_id
DO i=1,nsubs
idom=topo%isublist(i)
- IF (SIZE(f(:,:,:,:,i),2).LT.mesh%nnodes(1,idom)) THEN
+ IF (SIZE(f(:,:,:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(1,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in x-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(f(:,:,:,:,i),3).LT.mesh%nnodes(2,idom)) THEN
+ IF (SIZE(f(:,:,:,:,i),3).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(2,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in y-dir!',__LINE__,info)
GOTO 9999
ENDIF
- IF (SIZE(f(:,:,:,:,i),4).LT.mesh%nnodes(3,idom)) THEN
+ IF (SIZE(f(:,:,:,:,i),4).LT.ppm_cart_mesh(meshid_g(1), &
+ & topoid)%nnodes(3,idom)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'rhs mess with mesh points in z-dir!',__LINE__,info)
@@ -494,9 +500,10 @@
#endif
#endif
ENDIF
- !----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
!Definition of necessary variables and allocation of arrays
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
#if __DIM == __SFIELD
@@ -508,6 +515,7 @@
rdy2=rdy2_s
dx=dx_s
dy=dy_s
+ EPSU=EPSU_s
#elif __KIND == __DOUBLE_PRECISION
#if __DIM == __SFIELD
mgfield=>mgfield_2d_sca_d
@@ -518,6 +526,7 @@
rdy2=rdy2_d
dx=dx_d
dy=dy_d
+ EPSU=EPSU_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
@@ -532,6 +541,7 @@
dx=dx_s
dy=dy_s
dz=dz_s
+ EPSU=EPSU_s
#elif __KIND == __DOUBLE_PRECISION
#if __DIM == __SFIELD
mgfield=>mgfield_3d_sca_d
@@ -544,12 +554,17 @@
dx=dx_d
dy=dy_d
dz=dz_d
+ EPSU=EPSU_d
#endif
#endif
- topoid=field_topoid
+
+ topoid=topo_id
+
ncalls=ncalls+1
IF (ncalls.EQ.1) THEN
+
DO i=1,maxlev
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
iopt = ppm_param_alloc_fit
@@ -567,6 +582,7 @@
GOTO 9999
ENDIF
uc_dummy(:,:,:)=0.0_MK
+
#elif __MESH_DIM ==__3D
iopt = ppm_param_alloc_fit
ldl4(1) = 1-ghostsize(1)
@@ -584,10 +600,16 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
+
uc_dummy(:,:,:,:)=0.0_MK
#endif
+
CALL ppm_map_field_ghost(uc_dummy,topoid,mesh_id_g(i),&
& ghostsize,ppm_param_map_init,info)
+
+
+
+
#if __MESH_DIM == __2D
iopt = ppm_param_dealloc
ldl3(1) = 1-ghostsize(1)
@@ -603,6 +625,7 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
+
#elif __MESH_DIM ==__3D
iopt = ppm_param_dealloc
ldl4(1) = 1-ghostsize(1)
@@ -620,6 +643,7 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
+
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
@@ -640,6 +664,7 @@
GOTO 9999
ENDIF
uc_dummy(:,:,:,:)=0.0_MK
+
#elif __MESH_DIM ==__3D
iopt = ppm_param_alloc_fit
ldl5(1) = 1
@@ -659,10 +684,16 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
+
uc_dummy(:,:,:,:,:)=0.0_MK
#endif
+
CALL ppm_map_field_ghost(uc_dummy,vecdim,topoid,mesh_id_g(i),&
& ghostsize,ppm_param_map_init,info)
+
+
+
+
#if __MESH_DIM == __2D
iopt = ppm_param_dealloc
ldl4(1) = 1-ghostsize(1)
@@ -678,6 +709,7 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
+
#elif __MESH_DIM ==__3D
iopt = ppm_param_dealloc
ldl5(1) = 1-ghostsize(1)
@@ -695,121 +727,178 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
+
#endif
#endif
+
+
+
ENDDO
+
ncalls=ncalls+1
+
ENDIF
+
!----------------------------------------------------------------------
!DO n1 initial sweeps in the finest mesh with a GS-solver to get the
!initial solution
!----------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
+
+
c1 = 1.0_MK/(2.0_MK*(rdx2+rdy2))
c2 = rdx2
c3 = rdy2
c4 = 2.0_MK*c2+2.0_MK*c3
count = 0
- CALL ppm_mg_smooth_sca(ppm_param_topo_undefined,u,f,itera,1,c1,c2,c3,&
- & info)
- !----------------------------------------------------------------------
+
+
+ CALL ppm_mg_smooth_sca(topo_id,u,f,itera,1,c1,c2,c3,info)
+
+ !-----------------------------------------------------------------
! Compute residual
- !----------------------------------------------------------------------
- CALL ppm_mg_res_sca(ppm_param_topo_undefined,u,f,c1,c2,c3,c4,E,info)
+ !-----------------------------------------------------------------
+
+ CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,E,info)
+
#ifdef __MPI
CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
E=gEu
#endif
- IF (info .NE. 0) THEN
+
+ IF (info .NE. 0) THEN
GOTO 9999
- ENDIF
+ ENDIF
+
IF (l_print) THEN
WRITE(cbuf,*) 'Eu:',E
CALL PPM_WRITE(ppm_rank,'mg_solv',cbuf,info)
ENDIF
- !---------------------------------------------------------------------
+
+ IF (E.GT.EPSU) THEN
+ !----------------------------------------------------------------------
!Initiation of the function correction. (We start on purpose with lev=2)
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
DO mlev=2,maxlev
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- tuc(i,j)=0.0_MK
+ DO j=start(2,isub,mlev),stop(2,isub,mlev)
+ DO i=start(1,isub,mlev),stop(1,isub,mlev)
+ mgfield(isub,mlev)%uc(i,j)=0.0_MK
ENDDO
ENDDO
ENDDO
ENDDO
!----------------------------------------------------------------------
!CALL THE MULTIGRID TO DO NICE STUFF TO OUR FUNCTION
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
#if __KIND == __SINGLE_PRECISION
CALL ppm_mg_core_2d_sca_s(2,iter1,iter2,info)
+IF (.FALSE.) THEN
+ CALL ppm_mg_prolong_2d_sca_s(1,info)
+ CALL ppm_mg_smooth_sca(topo_id,u,f,iterf,1,c1,c2,c3,info)
+ CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,E,info)
+ CALL ppm_mg_core_2d_sca_s(2,iter1,iter2,info)
+ENDIF
#elif __KIND == __DOUBLE_PRECISION
CALL ppm_mg_core_2d_sca_d(2,iter1,iter2,info)
+IF (.FALSE.) THEN
+ CALL ppm_mg_prolong_2d_sca_d(1,info)
+ CALL ppm_mg_smooth_sca(topo_id,u,f,iterf,1,c1,c2,c3,info)
+ CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,E,info)
+ CALL ppm_mg_core_2d_sca_d(2,iter1,iter2,info)
+ENDIF
#endif
+
!----------------------------------------------------------------------
!PROLONG the solution to the finest grid
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
+
#if __KIND == __SINGLE_PRECISION
CALL ppm_mg_prolong_2d_sca_s(1,info)
#elif __KIND == __DOUBLE_PRECISION
CALL ppm_mg_prolong_2d_sca_d(1,info)
#endif
- !----------------------------------------------------------------------
+
+ !---------------------------------------------------------------------
!UPDATE THE FUNCTION
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1),istop(1,isub,1)
- u(i,j,isub)=tuc(i,j)
+ DO j=start(2,isub,1),stop(2,isub,1)
+ DO i=start(1,isub,1),stop(1,isub,1)
+ u(i,j,isub)=mgfield(isub,1)%uc(i,j)
ENDDO
ENDDO
ENDDO
- !----------------------------------------------------------------------
+ ENDIF
+
+ !-----------------------------------------------------------------------
!DO the final sweeps
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_sca(ppm_param_topo_undefined,u,f,iterf,1,c1,c2,c3,&
- & info)
- CALL ppm_mg_res_sca(ppm_param_topo_undefined,u,f,c1,c2,c3,c4,E,info)
+ !-----------------------------------------------------------------------
+ iopt=ppm_param_alloc_fit
+ ldl3(1)=0
+ ldl3(2)=0
+ ldl3(3)=1
+ ldu3(1)=max_node(1,1)+1
+ ldu3(2)=max_node(2,1)+1
+ ldu3(3)=nsubs
+ CALL ppm_alloc(mask_dummy_2d,ldl3,ldu3,iopt,info)
+ IF (info .NE. 0) THEN
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'ppm_mg_solv', &
+ & 'MASK',__LINE__,info)
+ GOTO 9999
+ ENDIF
+
+
+ CALL ppm_mg_smooth_sca(topo_id,u,f,iterf,1,c1,c2,c3,info)
+ CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,E,info)
#ifdef __MPI
CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
Eu=gEu
#else
Eu=E
#endif
+
+
#elif __MESH_DIM == __3D
+
+
+
c1 = 1.0_MK/(2.0_MK*(rdx2+rdy2+rdz2))
c2 = rdx2
c3 = rdy2
c4 = rdz2
c5 = 2.0_MK*c2+2.0_MK*c3+2.0_MK*c4
- CALL ppm_mg_smooth_sca(ppm_param_topo_undefined,u,f,itera,1,c1,c2,c3,&
- & c4,info)
- !----------------------------------------------------------------------
+
+ CALL ppm_mg_smooth_sca(topo_id,u,f,itera,1,c1,c2,c3,c4,info)
+
+ !-----------------------------------------------------------------
! Compute residual
- !----------------------------------------------------------------------
- CALL ppm_mg_res_sca(ppm_param_topo_undefined,u,f,c1,c2,c3,c4,c5,E,info)
+ !-----------------------------------------------------------------
+
+
+ CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
+
#ifdef __MPI
CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
E=gEu
#endif
+
IF (l_print) THEN
WRITE(cbuf,*) 'Eu:',E
CALL PPM_WRITE(ppm_rank,'mg_solv',cbuf,info)
ENDIF
- !---------------------------------------------------------------------
+ IF (E.GT.EPSU) THEN
+ !----------------------------------------------------------------------
!Initiation of the function correction. (We start on purpose with lev=2)
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
DO mlev=2,maxlev
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=start(3,isub,mlev),istop(3,isub,mlev)
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- tuc(i,j,k)=0.0_MK
+ DO k=start(3,isub,mlev),stop(3,isub,mlev)
+ DO j=start(2,isub,mlev),stop(2,isub,mlev)
+ DO i=start(1,isub,mlev),stop(1,isub,mlev)
+ mgfield(isub,mlev)%uc(i,j,k)=0.0_MK
ENDDO
ENDDO
ENDDO
@@ -817,40 +906,54 @@
ENDDO
!----------------------------------------------------------------------
!CALL THE MULTIGRID TO DO NICE STUFF TO OUR FUNCTION
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
#if __KIND == __SINGLE_PRECISION
CALL ppm_mg_core_3d_sca_s(2,iter1,iter2,info)
+ IF (.FALSE.) THEN
+ CALL ppm_mg_prolong_3d_sca_s(1,info)
+ CALL ppm_mg_smooth_sca(topo_id,u,f,iterf,1,c1,c2,c3,c4,info)
+ CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
+ CALL ppm_mg_core_3d_sca_s(2,iter1,iter2,info)
+ ENDIF
#elif __KIND == __DOUBLE_PRECISION
CALL ppm_mg_core_3d_sca_d(2,iter1,iter2,info)
+ IF (.FALSE.) THEN
+ CALL ppm_mg_prolong_3d_sca_d(1,info)
+ CALL ppm_mg_smooth_sca(topo_id,u,f,iterf,1,c1,c2,c3,c4,info)
+ CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
+ CALL ppm_mg_core_3d_sca_d(2,iter1,iter2,info)
+ ENDIF
#endif
!----------------------------------------------------------------------
!PROLONG the solution to the finest grid
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
+
#if __KIND == __SINGLE_PRECISION
CALL ppm_mg_prolong_3d_sca_s(1,info)
#elif __KIND == __DOUBLE_PRECISION
CALL ppm_mg_prolong_3d_sca_d(1,info)
#endif
- !----------------------------------------------------------------------
+
+ !---------------------------------------------------------------------
!UPDATE THE FUNCTION
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=start(3,isub,1),istop(3,isub,1)
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1),istop(1,isub,1)
- u(i,j,k,isub)=tuc(i,j,k)
+ DO k=start(3,isub,1),stop(3,isub,1)
+ DO j=start(2,isub,1),stop(2,isub,1)
+ DO i=start(1,isub,1),stop(1,isub,1)
+ u(i,j,k,isub)=mgfield(isub,1)%uc(i,j,k)
ENDDO
ENDDO
ENDDO
ENDDO
- !----------------------------------------------------------------------
+ ENDIF
+
+ !-----------------------------------------------------------------------
!DO the final sweeps
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_sca(ppm_param_topo_undefined,u,f,iterf,1,c1,c2,c3,&
- & c4,info)
- CALL ppm_mg_res_sca(ppm_param_topo_undefined,u,f,c1,c2,c3,c4,c5,&
- & E,info)
+ !-----------------------------------------------------------------------
+ CALL ppm_mg_smooth_sca(topo_id,u,f,iterf,1,c1,c2,c3,c4,info)
+ CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
+
#ifdef __MPI
CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
Eu=gEu
@@ -860,36 +963,45 @@
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
+
+
c1 = 1.0_MK/(2.0_MK*(rdx2+rdy2))
c2 = rdx2
c3 = rdy2
c4 = 2.0_MK*c2+2.0_MK*c3
count = 0
- CALL ppm_mg_smooth_vec(ppm_param_topo_undefined,u,f,itera,1,c1,c2,c3,&
- & info)
- !----------------------------------------------------------------------
+
+
+ CALL ppm_mg_smooth_vec(topo_id,u,f,itera,1,c1,c2,c3,info)
+
+
+ !-----------------------------------------------------------------
! Compute residual
- !----------------------------------------------------------------------
- CALL ppm_mg_res_vec(ppm_param_topo_undefined,u,f,c1,c2,c3,c4,E,info)
+ !-----------------------------------------------------------------
+
+ CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,E,info)
+
#ifdef __MPI
CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
E=gEu
#endif
+
+
IF (l_print) THEN
WRITE(cbuf,*) 'Eu:',E
CALL PPM_WRITE(ppm_rank,'mg_solv',cbuf,info)
ENDIF
- !---------------------------------------------------------------------
+ IF (E.GT.EPSU) THEN
+ !----------------------------------------------------------------------
!Initiation of the function correction. (We start on purpose with lev=2)
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
DO mlev=2,maxlev
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
+ DO j=start(2,isub,mlev),stop(2,isub,mlev)
+ DO i=start(1,isub,mlev),stop(1,isub,mlev)
DO ilda=1,vecdim
- tuc(ilda,i,j)=0.0_MK
+ mgfield(isub,mlev)%uc(ilda,i,j)=0.0_MK
ENDDO
ENDDO
ENDDO
@@ -897,39 +1009,58 @@
ENDDO
!----------------------------------------------------------------------
!CALL THE MULTIGRID TO DO NICE STUFF TO OUR FUNCTION
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
#if __KIND == __SINGLE_PRECISION
CALL ppm_mg_core_2d_vec_s(2,iter1,iter2,info)
+ IF (.FALSE.) THEN
+
+ CALL ppm_mg_prolong_2d_vec_s(1,info)
+ CALL ppm_mg_smooth_vec(topo_id,u,f,iterf,1,c1,c2,c3,info)
+ CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,E,info)
+ CALL ppm_mg_core_2d_vec_s(2,iter1,iter2,info)
+
+ ENDIF
#elif __KIND == __DOUBLE_PRECISION
CALL ppm_mg_core_2d_vec_d(2,iter1,iter2,info)
+
+ IF (.FALSE.) THEN
+
+ CALL ppm_mg_prolong_2d_vec_d(1,info)
+ CALL ppm_mg_smooth_vec(topo_id,u,f,iterf,1,c1,c2,c3,info)
+ CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,E,info)
+ CALL ppm_mg_core_2d_vec_d(2,iter1,iter2,info)
+
+ ENDIF
#endif
+
!----------------------------------------------------------------------
!PROLONG the solution to the finest grid
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
+
#if __KIND == __SINGLE_PRECISION
CALL ppm_mg_prolong_2d_vec_s(1,info)
#elif __KIND == __DOUBLE_PRECISION
CALL ppm_mg_prolong_2d_vec_d(1,info)
#endif
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
!UPDATE THE FUNCTION
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1),istop(1,isub,1)
+ DO j=start(2,isub,1),stop(2,isub,1)
+ DO i=start(1,isub,1),stop(1,isub,1)
DO ilda=1,vecdim
- u(ilda,i,j,isub)=tuc(ilda,i,j)
+ u(ilda,i,j,isub)=mgfield(isub,1)%uc(ilda,i,j)
ENDDO
ENDDO
ENDDO
ENDDO
- !----------------------------------------------------------------------
+ ENDIF
+
+ !-----------------------------------------------------------------------
!DO the final sweeps
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_vec(ppm_param_topo_undefined,u,f,iterf,1,c1,c2,c3,&
- & info)
- CALL ppm_mg_res_vec(ppm_param_topo_undefined,u,f,c1,c2,c3,c4,E,info)
+ !-----------------------------------------------------------------------
+ CALL ppm_mg_smooth_vec(topo_id,u,f,iterf,1,c1,c2,c3,info)
+ CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,E,info)
#ifdef __MPI
CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
@@ -937,42 +1068,51 @@
#else
Eu=E
#endif
+
#elif __MESH_DIM == __3D
+
+
+
c1 = 1.0_MK/(2.0_MK*(rdx2+rdy2+rdz2))
c2 = rdx2
c3 = rdy2
c4 = rdz2
c5 = 2.0_MK*c2+2.0_MK*c3+2.0_MK*c4
- CALL ppm_mg_smooth_vec(ppm_param_topo_undefined,u,f,itera,1,c1,c2,c3,&
- & c4,info)
- !----------------------------------------------------------------------
+
+
+ CALL ppm_mg_smooth_vec(topo_id,u,f,itera,1,c1,c2,c3,c4,info)
+ !-----------------------------------------------------------------
! Compute residual
- !----------------------------------------------------------------------
- CALL ppm_mg_res_vec(ppm_param_topo_undefined,u,f,c1,c2,c3,c4,c5,E,info)
+ !-----------------------------------------------------------------
+
+ CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
+
#ifdef __MPI
CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
E=gEu
#endif
+
IF (l_print) THEN
WRITE(cbuf,*) 'Eu:',E
CALL PPM_WRITE(ppm_rank,'mg_solv',cbuf,info)
ENDIF
- !---------------------------------------------------------------------
+
+ IF (E.GT.EPSU) THEN
+ !----------------------------------------------------------------------
!Initiation of the function correction. (We start on purpose with lev=2)
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
DO mlev=2,maxlev
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=start(3,isub,mlev),istop(3,isub,mlev)
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
+ DO k=start(3,isub,mlev),stop(3,isub,mlev)
+ DO j=start(2,isub,mlev),stop(2,isub,mlev)
+ DO i=start(1,isub,mlev),stop(1,isub,mlev)
#ifdef __VECTOR
- tuc(1,i,j,k)=0.0_MK
- tuc(2,i,j,k)=0.0_MK
- tuc(3,i,j,k)=0.0_MK
+ mgfield(isub,mlev)%uc(1,i,j,k)=0.0_MK
+ mgfield(isub,mlev)%uc(2,i,j,k)=0.0_MK
+ mgfield(isub,mlev)%uc(3,i,j,k)=0.0_MK
#else
DO ilda=1,vecdim
- tuc(ilda,i,j,k)=0.0_MK
+ mgfield(isub,mlev)%uc(ilda,i,j,k)=0.0_MK
ENDDO
#endif
ENDDO
@@ -982,48 +1122,63 @@
ENDDO
!----------------------------------------------------------------------
!CALL THE MULTIGRID TO DO NICE STUFF TO OUR FUNCTION
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
#if __KIND == __SINGLE_PRECISION
CALL ppm_mg_core_3d_vec_s(2,iter1,iter2,info)
+ IF (.FALSE.) THEN
+ CALL ppm_mg_prolong_3d_vec_s(1,info)
+ CALL ppm_mg_smooth_vec(topo_id,u,f,iterf,1,c1,c2,c3,c4,info)
+ CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
+ CALL ppm_mg_core_3d_vec_s(2,iter1,iter2,info)
+ ENDIF
#elif __KIND == __DOUBLE_PRECISION
CALL ppm_mg_core_3d_vec_d(2,iter1,iter2,info)
+ IF (.FALSE.) THEN
+ CALL ppm_mg_prolong_3d_vec_d(1,info)
+ CALL ppm_mg_smooth_vec(topo_id,u,f,iterf,1,c1,c2,c3,c4,info)
+ CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
+ CALL ppm_mg_core_3d_vec_d(2,iter1,iter2,info)
+ ENDIF
#endif
!----------------------------------------------------------------------
!PROLONG the solution to the finest grid
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
+
#if __KIND == __SINGLE_PRECISION
CALL ppm_mg_prolong_3d_vec_s(1,info)
#elif __KIND == __DOUBLE_PRECISION
CALL ppm_mg_prolong_3d_vec_d(1,info)
#endif
- !----------------------------------------------------------------------
+
+ !---------------------------------------------------------------------
!UPDATE THE FUNCTION
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=start(3,isub,1),istop(3,isub,1)
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1),istop(1,isub,1)
+ DO k=start(3,isub,1),stop(3,isub,1)
+ DO j=start(2,isub,1),stop(2,isub,1)
+ DO i=start(1,isub,1),stop(1,isub,1)
#ifdef __VECTOR
- u(1,i,j,k,isub)=tuc(1,i,j,k)
- u(2,i,j,k,isub)=tuc(2,i,j,k)
- u(3,i,j,k,isub)=tuc(3,i,j,k)
+ u(1,i,j,k,isub)=mgfield(isub,1)%uc(1,i,j,k)
+ u(2,i,j,k,isub)=mgfield(isub,1)%uc(2,i,j,k)
+ u(3,i,j,k,isub)=mgfield(isub,1)%uc(3,i,j,k)
#else
DO ilda=1,vecdim
- u(ilda,i,j,k,isub)=tuc(ilda,i,j,k)
+ u(ilda,i,j,k,isub)=mgfield(isub,1)%uc(ilda,i,j,k)
ENDDO
#endif
ENDDO
ENDDO
ENDDO
ENDDO
- !----------------------------------------------------------------------
+ ENDIF
+
+ !-----------------------------------------------------------------------
!DO the final sweeps
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_vec(ppm_param_topo_undefined,u,f,iterf,1,c1,c2,&
- & c3,c4,info)
- CALL ppm_mg_res_vec(ppm_param_topo_undefined,u,f,c1,c2,c3,c4,c5,&
- & E,info)
+ !-----------------------------------------------------------------------
+ CALL ppm_mg_smooth_vec(topo_id,u,f,iterf,1,c1,c2,c3,c4,info)
+ CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
+
+
#ifdef __MPI
CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
Eu=gEu
@@ -1032,13 +1187,13 @@
#endif
#endif
#endif
- !----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
! Return
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
9999 CONTINUE
CALL substop('ppm_mg_solv',t0,info)
RETURN
-
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
diff --git a/src/ppm_module_data_mg.f b/src/ppm_module_data_mg.f
index 57839e3..a78864b 100644
--- a/src/ppm_module_data_mg.f
+++ b/src/ppm_module_data_mg.f
@@ -1,41 +1,38 @@
- !------------------------------------------------------------------------
- ! Module : ppm_module_data_mg
- !------------------------------------------------------------------------
- !
- ! Purpose : multigrid data module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !------------------------------------------------------------------------
- ! $Log: ppm_module_data_mg.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:57 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.6 2006/07/21 11:30:57 kotsalie
- ! FRIDAY
- !
- ! Revision 1.5 2005/12/08 12:42:36 kotsalie
- ! commiting dirichlet
- !
- ! Revision 1.4 2004/10/29 16:00:47 kotsalie
- ! RED BLACK SOR
- !
- ! Revision 1.3 2004/09/28 14:18:19 kotsalie
- ! Added 4th order
- !
- ! Revision 1.2 2004/09/22 18:40:26 kotsalie
- ! MG new version
- !
- !------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
+ !-------------------------------------------------------------------------
+ ! Module : ppm_module_data_mg
+ !-------------------------------------------------------------------------
+ !
+ ! Purpose : multigrid data module
+ !
+ !
+ ! Remarks :
+ !
+ ! References :
+ !
+ ! Revisions :
+ !-------------------------------------------------------------------------
+ ! $Log: ppm_module_data_mg.f,v $
+ ! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+ ! initial import
+ !
+ ! Revision 1.5 2005/12/08 12:42:36 kotsalie
+ ! commiting dirichlet
+ !
+ ! Revision 1.4 2004/10/29 16:00:47 kotsalie
+ ! RED BLACK SOR
+ !
+ ! Revision 1.3 2004/09/28 14:18:19 kotsalie
+ ! Added 4th order
+ !
+ ! Revision 1.2 2004/09/22 18:40:26 kotsalie
+ ! MG new version
+ !
+ !-------------------------------------------------------------------------
+ ! Parallel Particle Mesh Library (PPM)
+ ! Institute of Computational Science
+ ! ETH Zentrum, Hirschengraben 84
+ ! CH-8092 Zurich, Switzerland
+ !-------------------------------------------------------------------------
#define __SINGLE_PRECISION 1
@@ -45,129 +42,161 @@
#define __2D 7
#define __3D 8
#define __SFIELD 9
-#define __VFIELD 10
-
- MODULE ppm_module_data_mg
- !----------------------------------------------------------------------------
- !Modules
- !----------------------------------------------------------------------------
- USE ppm_module_data,ONLY:ppm_kind_single,ppm_kind_double
- PRIVATE :: ppm_kind_single,ppm_kind_double
- !----------------------------------------------------------------------------
- !The boundary condition values!!
- !----------------------------------------------------------------------------
+#define __VFIELD 10
+
+MODULE ppm_module_data_mg
+ !--------------------------------------------------------------------------
+ !Modules
+ !-----------------------------------------------------------------------------
+ USE ppm_module_data,ONLY:ppm_kind_single,ppm_kind_double
+ PRIVATE :: ppm_kind_single,ppm_kind_double
+ !-----------------------------------------------------------------------------
+ !The boundary condition values!!
+ !-----------------------------------------------------------------------------
#define __DIM __SFIELD
#define __MESH_DIM __2D
#define __KIND __SINGLE_PRECISION
- TYPE bc_value_2d_sca_s
- ! 1st index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue
- END TYPE bc_value_2d_sca_s
+ TYPE bc_value_2d_sca_s
+ ! 1st index mesh position locally
+ REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue
+ END TYPE bc_value_2d_sca_s
#undef __KIND
#define __KIND == __DOUBLE_PRECISION
- TYPE bc_value_2d_sca_d
- !1st index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue
- END TYPE bc_value_2d_sca_d
+ TYPE bc_value_2d_sca_d
+ !1st index mesh position locally
+ REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue
+ END TYPE bc_value_2d_sca_d
#undef __KIND
#define __KIND == __SINGLE_PRECISION
- !----------------------------------------------------------------------------
- ! Our multigrid field with all its necessary components (Take a look at the
- ! theory)
- !----------------------------------------------------------------------------
- TYPE mg_field_2d_sca_s
- !function corrections, error restrictions, errors
- !1st and 2nd index: mesh position(local)
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: uc
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: fc
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: err
-
- !lets save the boundary condition.index:face of the subdomain(1:4)
- TYPE(bc_value_2d_sca_s), DIMENSION(:), POINTER :: bcvalue
- END TYPE mg_field_2d_sca_s
+ !-----------------------------------------------------------------------------
+ ! Our multigrid field with all its necessary components (Take a look at the
+ ! theory)
+ !-----------------------------------------------------------------------------
+ TYPE mg_field_2d_sca_s
+ !function corrections, error restrictions, errors
+ !1st and 2nd index: mesh position(local)
+ REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: uc
+ REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: fc
+ REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: err
+ !--------------------------------------------------------------------------
+ !TRUE FOR RED (EVEN) MESH POINTS
+ !-------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_red
+ !--------------------------------------------------------------------------
+ !TRUE FOR BLACK (ODD) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_black
+
+ !lets save the boundary condition.index:face of the subdomain(1:4)
+ TYPE(bc_value_2d_sca_s), DIMENSION(:), POINTER :: bcvalue
+ END TYPE mg_field_2d_sca_s
#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
-
- TYPE mg_field_2d_sca_d
- !function corrections, error restrictions, errors,
- !1st:3rd index: mesh position(local)
- REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: uc
- REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: fc
- REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: err
- !lets save the boundary condition.index:face of the subdomain(1:4)
- TYPE(bc_value_2d_sca_d), DIMENSION(:), POINTER :: bcvalue
- END TYPE mg_field_2d_sca_d
+#define __KIND == __DOUBLE_PRECISION
+
+ TYPE mg_field_2d_sca_d
+ !function corrections, error restrictions, errors,
+ !1st:3rd index: mesh position(local)
+ REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: uc
+ REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: fc
+ REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: err
+ !--------------------------------------------------------------------------
+ !TRUE FOR RED (EVEN) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_red
+ !--------------------------------------------------------------------------
+ !TRUE FOR BLACK (ODD) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_black
+ !lets save the boundary condition.index:face of the subdomain(1:4)
+ TYPE(bc_value_2d_sca_d), DIMENSION(:), POINTER :: bcvalue
+ END TYPE mg_field_2d_sca_d
#undef __KIND
#define __KIND == __SINGLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_2d_sca_s), DIMENSION(:,:), POINTER :: mgfield_2d_sca_s
+ !1st index: subdomain,2nd index : multigrid level
+ TYPE(mg_field_2d_sca_s), DIMENSION(:,:), POINTER :: mgfield_2d_sca_s
#undef __KIND
#define __KIND == __DOUBLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_2d_sca_d), DIMENSION(:,:), POINTER :: mgfield_2d_sca_d
+ !1st index: subdomain,2nd index : multigrid level
+ TYPE(mg_field_2d_sca_d), DIMENSION(:,:), POINTER :: mgfield_2d_sca_d
#undef __KIND
#undef __MESH_DIM
#define __MESH_DIM __3D
#define __KIND __SINGLE_PRECISION
- TYPE bc_value_3d_sca_s
- ! 1st-2nd index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: pbcvalue
- END TYPE bc_value_3d_sca_s
+ TYPE bc_value_3d_sca_s
+ ! 1st-2nd index mesh position locally
+ REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: pbcvalue
+ END TYPE bc_value_3d_sca_s
#undef __KIND
#define __KIND == __DOUBLE_PRECISION
- TYPE bc_value_3d_sca_d
- !1st-2nd index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: pbcvalue
- END TYPE bc_value_3d_sca_d
+ TYPE bc_value_3d_sca_d
+ !1st-2nd index mesh position locally
+ REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: pbcvalue
+ END TYPE bc_value_3d_sca_d
#undef __KIND
#define __KIND == __SINGLE_PRECISION
- !----------------------------------------------------------------------------
- ! Our multigrid field with all its necessary components (Take a look at the
- ! theory)
- !----------------------------------------------------------------------------
- TYPE mg_field_3d_sca_s
- !function corrections, error restrictions, errors
- !1st-3rd index: mesh position(local)
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: uc
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: fc
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: err
-
- !lets save the boundary condition.index:face of the subdomain(1:6)
- TYPE(bc_value_3d_sca_s), DIMENSION(:), POINTER :: bcvalue
- END TYPE mg_field_3d_sca_s
+ !-----------------------------------------------------------------------------
+ ! Our multigrid field with all its necessary components (Take a look at the
+ ! theory)
+ !-----------------------------------------------------------------------------
+ TYPE mg_field_3d_sca_s
+ !function corrections, error restrictions, errors
+ !1st-3rd index: mesh position(local)
+ REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: uc
+ REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: fc
+ REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: err
+ !--------------------------------------------------------------------------
+ !TRUE FOR RED (EVEN) MESH POINTS
+ !-------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red
+ !--------------------------------------------------------------------------
+ !TRUE FOR BLACK (ODD) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black
+
+ !lets save the boundary condition.index:face of the subdomain(1:6)
+ TYPE(bc_value_3d_sca_s), DIMENSION(:), POINTER :: bcvalue
+ END TYPE mg_field_3d_sca_s
#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
-
- TYPE mg_field_3d_sca_d
- !function corrections, error restrictions, errors,
- !1st:3rd index: mesh position(local)
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: uc
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: fc
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: err
- !lets save the boundary condition.index:face of the subdomain(1:6)
- TYPE(bc_value_3d_sca_d), DIMENSION(:), POINTER :: bcvalue
- END TYPE mg_field_3d_sca_d
+#define __KIND == __DOUBLE_PRECISION
+
+ TYPE mg_field_3d_sca_d
+ !function corrections, error restrictions, errors,
+ !1st:3rd index: mesh position(local)
+ REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: uc
+ REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: fc
+ REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: err
+ !--------------------------------------------------------------------------
+ !TRUE FOR RED (EVEN) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red
+ !--------------------------------------------------------------------------
+ !TRUE FOR BLACK (ODD) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black
+ !lets save the boundary condition.index:face of the subdomain(1:6)
+ TYPE(bc_value_3d_sca_d), DIMENSION(:), POINTER :: bcvalue
+ END TYPE mg_field_3d_sca_d
#undef __KIND
#define __KIND == __SINGLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_3d_sca_s), DIMENSION(:,:), POINTER :: mgfield_3d_sca_s
+ !1st index: subdomain,2nd index : multigrid level
+ TYPE(mg_field_3d_sca_s), DIMENSION(:,:), POINTER :: mgfield_3d_sca_s
#undef __KIND
#define __KIND == __DOUBLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_3d_sca_d), DIMENSION(:,:), POINTER :: mgfield_3d_sca_d
+ !1st index: subdomain,2nd index : multigrid level
+ TYPE(mg_field_3d_sca_d), DIMENSION(:,:), POINTER :: mgfield_3d_sca_d
#undef __KIND
#undef __MESH_DIM
@@ -176,208 +205,249 @@
#define __DIM __VFIELD
#define __MESH_DIM __2D
#define __KIND __SINGLE_PRECISION
- TYPE bc_value_2d_vec_s
- ! 1st index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue
- END TYPE bc_value_2d_vec_s
+ TYPE bc_value_2d_vec_s
+ ! 1st index mesh position locally
+ REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue
+ END TYPE bc_value_2d_vec_s
#undef __KIND
#define __KIND == __DOUBLE_PRECISION
- TYPE bc_value_2d_vec_d
- !1st index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue
- END TYPE bc_value_2d_vec_d
+ TYPE bc_value_2d_vec_d
+ !1st index mesh position locally
+ REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue
+ END TYPE bc_value_2d_vec_d
#undef __KIND
#define __KIND == __SINGLE_PRECISION
- !----------------------------------------------------------------------------
- ! Our multigrid field with all its necessary components (Take a look at the
- ! theory)
- !----------------------------------------------------------------------------
- TYPE mg_field_2d_vec_s
- !function corrections, error restrictions, errors
- !1st index component 2nd and 3rd index: mesh position(local)
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: uc
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: fc
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: err
-
- !lets save the boundary condition.index:component,face of the subdomain(1:4)
- TYPE(bc_value_2d_vec_s), DIMENSION(:,:), POINTER :: bcvalue
- END TYPE mg_field_2d_vec_s
+ !-----------------------------------------------------------------------------
+ ! Our multigrid field with all its necessary components (Take a look at the
+ ! theory)
+ !-----------------------------------------------------------------------------
+ TYPE mg_field_2d_vec_s
+ !function corrections, error restrictions, errors
+ !1st index component 2nd and 3rd index: mesh position(local)
+ REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: uc
+ REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: fc
+ REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: err
+ !--------------------------------------------------------------------------
+ !TRUE FOR RED (EVEN) MESH POINTS
+ !-------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_red
+ !--------------------------------------------------------------------------
+ !TRUE FOR BLACK (ODD) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_black
+
+ !lets save the boundary condition.index:component,face of the subdomain(1:4)
+ TYPE(bc_value_2d_vec_s), DIMENSION(:,:), POINTER :: bcvalue
+ END TYPE mg_field_2d_vec_s
#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- TYPE mg_field_2d_vec_d
- !function corrections, error restrictions, errors,
- !1st index: component 2nd:3rd index: mesh position(local)
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: uc
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: fc
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: err
- !lets save the boundary condition.index:component,face of the subdomain(1:4)
- TYPE(bc_value_2d_vec_d), DIMENSION(:), POINTER :: bcvalue
- END TYPE mg_field_2d_vec_d
+#define __KIND == __DOUBLE_PRECISION
+ TYPE mg_field_2d_vec_d
+ !function corrections, error restrictions, errors,
+ !1st index: component 2nd:3rd index: mesh position(local)
+ REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: uc
+ REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: fc
+ REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: err
+ !--------------------------------------------------------------------------
+ !TRUE FOR RED (EVEN) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_red
+ !--------------------------------------------------------------------------
+ !TRUE FOR BLACK (ODD) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:),POINTER :: mask_black
+ !lets save the boundary condition.index:component,face of the subdomain(1:4)
+ TYPE(bc_value_2d_vec_d), DIMENSION(:), POINTER :: bcvalue
+ END TYPE mg_field_2d_vec_d
#undef __KIND
#define __KIND == __SINGLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_2d_vec_s), DIMENSION(:,:), POINTER :: mgfield_2d_vec_s
+ !1st index: subdomain,2nd index : multigrid level
+ TYPE(mg_field_2d_vec_s), DIMENSION(:,:), POINTER :: mgfield_2d_vec_s
#undef __KIND
#define __KIND == __DOUBLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_2d_vec_d), DIMENSION(:,:), POINTER :: mgfield_2d_vec_d
+ !1st index: subdomain,2nd index : multigrid level
+ TYPE(mg_field_2d_vec_d), DIMENSION(:,:), POINTER :: mgfield_2d_vec_d
#undef __KIND
#undef __MESH_DIM
#define __MESH_DIM __3D
#define __KIND __SINGLE_PRECISION
- TYPE bc_value_3d_vec_s
- ! 1st-2nd index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: pbcvalue
- END TYPE bc_value_3d_vec_s
+ TYPE bc_value_3d_vec_s
+ ! 1st-2nd index mesh position locally
+ REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: pbcvalue
+ END TYPE bc_value_3d_vec_s
#undef __KIND
#define __KIND == __DOUBLE_PRECISION
- TYPE bc_value_3d_vec_d
- !1st-2nd index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: pbcvalue
- END TYPE bc_value_3d_vec_d
+ TYPE bc_value_3d_vec_d
+ !1st-2nd index mesh position locally
+ REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: pbcvalue
+ END TYPE bc_value_3d_vec_d
#undef __KIND
#define __KIND == __SINGLE_PRECISION
- !----------------------------------------------------------------------------
- ! Our multigrid field with all its necessary components (Take a look at the
- ! theory)
- !----------------------------------------------------------------------------
- TYPE mg_field_3d_vec_s
- !function corrections, error restrictions, errors
- !1st index: component 2nd-4th index: mesh position(local)
- REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: uc
- REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: fc
- REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: err
-
- !lets save the boundary condition.index:component,face of the subdomain(1:6)
- TYPE(bc_value_3d_vec_s), DIMENSION(:), POINTER :: bcvalue
- END TYPE mg_field_3d_vec_s
+ !-----------------------------------------------------------------------------
+ ! Our multigrid field with all its necessary components (Take a look at the
+ ! theory)
+ !-----------------------------------------------------------------------------
+ TYPE mg_field_3d_vec_s
+ !function corrections, error restrictions, errors
+ !1st index: component 2nd-4th index: mesh position(local)
+ REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: uc
+ REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: fc
+ REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: err
+ !--------------------------------------------------------------------------
+ !TRUE FOR RED (EVEN) MESH POINTS
+ !-------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red
+ !--------------------------------------------------------------------------
+ !TRUE FOR BLACK (ODD) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black
+
+ !lets save the boundary condition.index:component,face of the subdomain(1:6)
+ TYPE(bc_value_3d_vec_s), DIMENSION(:), POINTER :: bcvalue
+ END TYPE mg_field_3d_vec_s
#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
-
- TYPE mg_field_3d_vec_d
- !function corrections, error restrictions, errors,
- !1st index component,2nd:4th index: mesh position(local)
- REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: uc
- REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: fc
- REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: err
- !lets save the boundary condition.index:face of the subdomain(1:6)
- TYPE(bc_value_3d_vec_d), DIMENSION(:), POINTER :: bcvalue
- END TYPE mg_field_3d_vec_d
+#define __KIND == __DOUBLE_PRECISION
+
+ TYPE mg_field_3d_vec_d
+ !function corrections, error restrictions, errors,
+ !1st index component,2nd:4th index: mesh position(local)
+ REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: uc
+ REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: fc
+ REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: err
+ !--------------------------------------------------------------------------
+ !TRUE FOR RED (EVEN) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red
+ !--------------------------------------------------------------------------
+ !TRUE FOR BLACK (ODD) MESH POINTS
+ !--------------------------------------------------------------------------
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black
+ !lets save the boundary condition.index:face of the subdomain(1:6)
+ TYPE(bc_value_3d_vec_d), DIMENSION(:), POINTER :: bcvalue
+ END TYPE mg_field_3d_vec_d
#undef __KIND
#define __KIND == __SINGLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_3d_vec_s), DIMENSION(:,:), POINTER :: mgfield_3d_vec_s
+ !1st index: subdomain,2nd index : multigrid level
+ TYPE(mg_field_3d_vec_s), DIMENSION(:,:), POINTER :: mgfield_3d_vec_s
#undef __KIND
#define __KIND == __DOUBLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_3d_vec_d), DIMENSION(:,:), POINTER :: mgfield_3d_vec_d
+ !1st index: subdomain,2nd index : multigrid level
+ TYPE(mg_field_3d_vec_d), DIMENSION(:,:), POINTER :: mgfield_3d_vec_d
#undef __KIND
#undef __MESH_DIM
#undef __DIM
- !----------------------------------------------------------------------------
- !Starting index for the iteration through the mesh points.
- !----------------------------------------------------------------------------
- INTEGER, DIMENSION(:,:,:), POINTER :: start
- !----------------------------------------------------------------------------
- !Stopping index for the iteration through the mesh points.
- !----------------------------------------------------------------------------
- INTEGER, DIMENSION(:,:,:), POINTER :: istop
- !----------------------------------------------------------------------------
- !Factor for coarsening the mesh
- !----------------------------------------------------------------------------
- INTEGER, DIMENSION(:),POINTER :: factor
- !----------------------------------------------------------------------------
- !Array with internal meshids
- !----------------------------------------------------------------------------
- INTEGER, DIMENSION(:),POINTER :: meshid_g
- !----------------------------------------------------------------------------
- !Array with external mesh_ids
- !----------------------------------------------------------------------------
- INTEGER, DIMENSION(:),POINTER :: mesh_id_g
- !----------------------------------------------------------------------------
- !Size of the ghostlayer. It is 1 for the multigrid since we do
- !for the time being second order finite differences
- !----------------------------------------------------------------------------
- INTEGER, DIMENSION(:),POINTER :: ghostsize
- !----------------------------------------------------------------------------
- !BOUNDARY CONDITIONS of the computational domain.1st index:sub,2nd,face
- !----------------------------------------------------------------------------
+ !-----------------------------------------------------------------------------
+ !Starting index for the iteration through the mesh points.
+ !-----------------------------------------------------------------------------
+ INTEGER, DIMENSION(:,:,:), POINTER :: start
+ !-----------------------------------------------------------------------------
+ !Stopping index for the iteration through the mesh points.
+ !-----------------------------------------------------------------------------
+ INTEGER, DIMENSION(:,:,:), POINTER :: stop
+ !-----------------------------------------------------------------------------
+ !Factor for coarsening the mesh
+ !-----------------------------------------------------------------------------
+ INTEGER, DIMENSION(:),POINTER :: factor
+ !-----------------------------------------------------------------------------
+ !Array with internal meshids
+ !-----------------------------------------------------------------------------
+ INTEGER, DIMENSION(:),POINTER :: meshid_g
+ !-----------------------------------------------------------------------------
+ !Array with external mesh_ids
+ !-----------------------------------------------------------------------------
+ INTEGER, DIMENSION(:),POINTER :: mesh_id_g
+ !-----------------------------------------------------------------------------
+ !Size of the ghostlayer. It is 1 for the multigrid since we do
+ !for the time being second order finite differences
+ !-----------------------------------------------------------------------------
+ INTEGER, DIMENSION(:),POINTER :: ghostsize
+ !-----------------------------------------------------------------------------
+ !BOUNDARY CONDITIONS of the computational domain.1st index:sub,2nd,face
+ !-----------------------------------------------------------------------------
#define __DIM == __SFIELD
- INTEGER, DIMENSION(:,:),POINTER :: bcdef_sca
+ INTEGER, DIMENSION(:,:),POINTER :: bcdef_sca
#undef __DIM
#define __DIM == __VFIELD
- INTEGER, DIMENSION(:,:,:),POINTER :: bcdef_vec
+ INTEGER, DIMENSION(:,:,:),POINTER :: bcdef_vec
#undef __DIM
- !----------------------------------------------------------------------------
- !Is the face of the cell at the boundary? Yes or no?1st index face,2nd:isub
- !----------------------------------------------------------------------------
- LOGICAL, DIMENSION(:,:), POINTER :: lboundary
- !----------------------------------------------------------------------------
- !V_CYCLE OR W_CYCLE AND TO PRINT OR NOT TO PRINT
- !----------------------------------------------------------------------------
- LOGICAL :: w_cycle
- LOGICAL :: l_print
- !----------------------------------------------------------------------------
- !ARE ALL THE BOUNDARIES PERIODIC
- !----------------------------------------------------------------------------
- LOGICAL :: lperiodic
- !----------------------------------------------------------------------------
- !Order of the mg
- !----------------------------------------------------------------------------
- INTEGER :: order
- !----------------------------------------------------------------------------
- !number of levels (theoretical value)
- !----------------------------------------------------------------------------
- INTEGER :: maxlev
- !----------------------------------------------------------------------------
- !number of subs
- !----------------------------------------------------------------------------
- INTEGER :: nsubs
- !----------------------------------------------------------------------------
- !smoother
- !----------------------------------------------------------------------------
- INTEGER :: ismoother
- !----------------------------------------------------------------------------
- !number of dimensions in the problem(if scalar fields=> vecdim=1)
- !----------------------------------------------------------------------------
- INTEGER :: vecdim
-
- !----------------------------------------------------------------------------
- !Array with the maximum number of mesh points on each processor
- !Due to the load ballancing the waste of memory (if existed) is
- !minimal !!
- !----------------------------------------------------------------------------
- INTEGER,DIMENSION(:,:),POINTER :: max_node
+ !-----------------------------------------------------------------------------
+ !Is the face of the cell at the boundary? Yes or no?1st index face,2nd:isub
+ !-----------------------------------------------------------------------------
+ LOGICAL, DIMENSION(:,:), POINTER :: lboundary
+ !----------------------------------------------------------------------------
+ !V_CYCLE OR W_CYCLE AND TO PRINT OR NOT TO PRINT
+ !----------------------------------------------------------------------------
+ LOGICAL :: w_cycle
+ LOGICAL :: l_print
+ !----------------------------------------------------------------------------
+ !ARE ALL THE BOUNDARIES PERIODIC
+ !----------------------------------------------------------------------------
+ LOGICAL :: lperiodic
+ !----------------------------------------------------------------------------
+ !Order of the mg
+ !---------------------------------------------------------------------------
+ INTEGER :: order
+ !-----------------------------------------------------------------------------
+ !number of levels (theoretical value)
+ !-----------------------------------------------------------------------------
+ INTEGER :: maxlev
+ !-----------------------------------------------------------------------------
+ !number of subs
+ !-----------------------------------------------------------------------------
+ INTEGER :: nsubs
+ !----------------------------------------------------------------------------
+ !smoother
+ !--------------------------------------------------------------------------
+ INTEGER :: ismoother
+ !-----------------------------------------------------------------------------
+ !number of dimensions in the problem(if scalar fields=> vecdim=1)
+ !-----------------------------------------------------------------------------
+ INTEGER :: vecdim
+ !-----------------------------------------------------------------------------
+ !MASK DUMMY FOR COMPATIBILITY OF TYPE THAT I USE WITH FIELDS OF PPM
+ !-----------------------------------------------------------------------------
+#define __MESH_DIM == __2D
+ LOGICAL,DIMENSION(:,:,:),POINTER :: mask_dummy_2d
+#undef __MESH_DIM
+#define __MESH_DIM == __3D
+ LOGICAL,DIMENSION(:,:,:,:),POINTER :: mask_dummy_3d
+#undef __MESH_DIM
+ !-----------------------------------------------------------------------------
+ !Array with the maximum number of mesh points on each processor
+ !Due to the load ballancing the waste of memory (if existed) is
+ !minimal !!
+ !-----------------------------------------------------------------------------
+ INTEGER,DIMENSION(:,:),POINTER :: max_node
-#define __KIND __SINGLE_PRECISION
- REAL(ppm_kind_single) :: rdx2_s,rdy2_s,rdz2_s
- REAL(ppm_kind_single) :: dx_s,dy_s,dz_s
- REAL(ppm_kind_single) :: EPSU_s
- REAL(ppm_kind_single) :: omega_s
+
+#define __KIND __SINGLE_PRECISION
+ REAL(ppm_kind_single) :: rdx2_s,rdy2_s,rdz2_s
+ REAL(ppm_kind_single) :: dx_s,dy_s,dz_s
+ REAL(ppm_kind_single) :: EPSU_s
+ REAL(ppm_kind_single) :: omega_s
#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- REAL(ppm_kind_double) :: rdx2_d,rdy2_d,rdz2_d
- REAL(ppm_kind_double) :: dx_d,dy_d,dz_d
- REAL(ppm_kind_double) :: EPSU_d
- REAL(ppm_kind_double) :: omega_d
+#define __KIND __DOUBLE_PRECISION
+ REAL(ppm_kind_double) :: rdx2_d,rdy2_d,rdz2_d
+ REAL(ppm_kind_double) :: dx_d,dy_d,dz_d
+ REAL(ppm_kind_double) :: EPSU_d
+ REAL(ppm_kind_double) :: omega_d
#undef __KIND
- END MODULE ppm_module_data_mg
+END MODULE ppm_module_data_mg
diff --git a/src/ppm_module_mg_core.f b/src/ppm_module_mg_core.f
index aaef3fa..02434c6 100644
--- a/src/ppm_module_mg_core.f
+++ b/src/ppm_module_mg_core.f
@@ -12,8 +12,8 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_module_mg_core.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
+ ! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
+ ! initial import
!
! Revision 1.1 2004/09/22 18:31:04 kotsalie
! MG new version
diff --git a/src/ppm_module_user_numerics.f b/src/ppm_module_user_numerics.f
index e382ba1..3cd9560 100644
--- a/src/ppm_module_user_numerics.f
+++ b/src/ppm_module_user_numerics.f
@@ -31,5 +31,7 @@
USE ppm_module_ode
USE ppm_module_mg
USE ppm_module_fmm
+ USE ppm_module_gmm
+ USE ppm_module_hamjac
END MODULE ppm_module_user_numerics
--
GitLab