From 149583f728b9d5f395788e0ba31190705696b23f Mon Sep 17 00:00:00 2001
From: odemirel <odemirel@7c7fe9aa-52eb-4d9e-b0a8-ba7d787348e9>
Date: Mon, 26 Apr 2010 03:47:04 +0000
Subject: [PATCH] -multigrid stuff was reverted back to the trunk and then
updated to fit the new topology -compiled with gnu and intel, no errors
occured.
git-svn-id: https://ppm.inf.ethz.ch/svn/ppmnumerics/branches/ngtopo/libppmnumerics@610 7c7fe9aa-52eb-4d9e-b0a8-ba7d787348e9
---
src/ppm_mg_alloc_field.f | 32 +-
src/ppm_mg_finalize.f | 9 -
src/ppm_mg_init.f | 2268 ++++++++++++++++--------------------
src/ppm_mg_res_coarse.f | 349 ++----
src/ppm_mg_res_fine.f | 222 +---
src/ppm_mg_restrict.f | 1422 ++++++++++------------
src/ppm_mg_smooth_coarse.f | 2169 ++++++++++++++--------------------
src/ppm_mg_smooth_fine.f | 879 +++++---------
src/ppm_mg_solv.f | 687 +++++------
src/ppm_module_data_mg.f | 75 +-
src/ppm_module_mg_core.f | 4 +-
11 files changed, 3259 insertions(+), 4857 deletions(-)
diff --git a/src/ppm_mg_alloc_field.f b/src/ppm_mg_alloc_field.f
index 19c7e8c..dcacdbf 100644
--- a/src/ppm_mg_alloc_field.f
+++ b/src/ppm_mg_alloc_field.f
@@ -27,8 +27,11 @@
! Revisions :
!-------------------------------------------------------------------------
! $Log: ppm_mg_alloc_field.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
- ! initial import
+ ! 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.7 2004/10/01 16:33:39 ivos
! cosmetics.
@@ -145,7 +148,7 @@
!-------------------------------------------------------------------------
! Local variables
!-------------------------------------------------------------------------
- INTEGER :: i,j
+ INTEGER :: i,j
INTEGER, DIMENSION(2) :: ldc
REAL(MK) :: t0
@@ -311,8 +314,6 @@
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
@@ -327,13 +328,10 @@
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
@@ -367,24 +365,6 @@
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
diff --git a/src/ppm_mg_finalize.f b/src/ppm_mg_finalize.f
index 71e8ec3..abf4f73 100644
--- a/src/ppm_mg_finalize.f
+++ b/src/ppm_mg_finalize.f
@@ -218,15 +218,6 @@
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 9b92f80..647fd3a 100644
--- a/src/ppm_mg_init.f
+++ b/src/ppm_mg_init.f
@@ -1,1448 +1,1174 @@
- !-------------------------------------------------------------------------
- ! 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
- !-------------------------------------------------------------------------
-
+ !------------------------------------------------------------------------
+ ! 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
+ !------------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_sca_s(topo_id,equation,iorder,smoother,ibcdef,&
- & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_2d_sca_s(topo_id,equation,ighostsize,smoother,ibcdef,&
+ & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_sca_d(topo_id,equation,iorder,smoother,ibcdef,&
- & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_2d_sca_d(topo_id,equation,ighostsize,smoother,ibcdef,&
+ & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_sca_s(topo_id,equation,iorder,smoother,ibcdef,&
- & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_3d_sca_s(topo_id,equation,ighostsize,smoother,ibcdef,&
+ & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_sca_d(topo_id,equation,iorder,smoother,ibcdef,&
- & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_3d_sca_d(topo_id,equation,ighostsize,smoother,ibcdef,&
+ & bcvalue,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(topo_id,equation,iorder,smoother,lda,ibcdef,&
- & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_2d_vec_s(topo_id,equation,ighostsize,smoother,lda,ibcdef,&
+ & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_vec_d(topo_id,equation,iorder,smoother,lda,ibcdef,&
- & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_2d_vec_d(topo_id,equation,ighostsize,smoother,lda,ibcdef,&
+ & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_vec_s(topo_id,equation,iorder,smoother,lda,ibcdef,&
- & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_3d_vec_s(topo_id,equation,ighostsize,smoother,lda,ibcdef,&
+ & bcvalue,mesh_id,limlev,wcycle,lprint,omega,info)
#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_vec_d(topo_id,equation,iorder,smoother,lda,ibcdef,&
- & bcvalue,EPSU,mesh_id,limlev,wcycle,lprint,omega,info)
+ SUBROUTINE ppm_mg_init_3d_vec_d(topo_id,equation,ighostsize,smoother,lda,ibcdef,&
+ & bcvalue,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_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
+ !----------------------------------------------------------------------
+ ! Modules
+ !----------------------------------------------------------------------
+ USE ppm_module_data
+ USE ppm_module_data_mesh
+ USE ppm_module_data_mg
+ USE ppm_module_mg_alloc
+ 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, INTENT(IN) :: iorder
- INTEGER, INTENT(IN) :: smoother
+ !----------------------------------------------------------------------
+ ! Arguments
+ !----------------------------------------------------------------------
+ INTEGER, INTENT(IN) :: equation
+ INTEGER,DIMENSION(:),INTENT(IN) :: ighostsize
+ 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,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
+ INTEGER, INTENT(IN) :: mesh_id,topo_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
+ 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(topo_id)%t%nsubs) &
- & :: min_sub,max_sub
- INTEGER :: iopt,topoid
-
-
+ 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
+ !----------------------------------------------------------------------
-
- !-----------------------------------------------------------------------
- ! Externals
- !-----------------------------------------------------------------------
-
- !-----------------------------------------------------------------------
- ! Initialize
- !-----------------------------------------------------------------------
-
- CALL substart('ppm_mg_init',t0,info)
-
-
- !-----------------------------------------------------------------------
- ! Check arguments
- !-----------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
+ !----------------------------------------------------------------------
+ ! 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
- 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
- !---------------------------------------------------------------------
+ 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
-
- 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
-
-
+ w_cycle=wcycle
+ l_print=lprint
+
+ topoid = topo_id
+ topo => ppm_topo(topo_id)%t
+ mesh => topo%mesh(mesh_id)
+ 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(:,:)
- EPSU_s = EPSU
- omega_s=omega
- lmyeps=ppm_myepss
+ 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(:,:)
- EPSU_d = EPSU
- omega_d=omega
- lmyeps=ppm_myepsd
+ 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))/(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)
+ 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)
#elif __KIND == __DOUBLE_PRECISION
- dx_d = (max_phys(1)-min_phys(1))/(Nml(1)-1)
- dy_d = (max_phys(2)-min_phys(2))/(Nml(2)-1)
+ 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)
- rdx2_d = 1/(dx_d*dx_d)
- rdy2_d = 1/(dy_d*dy_d)
+ rdx2_d = 1.0_MK/(dx_d*dx_d)
+ rdy2_d = 1.0_MK/(dy_d*dy_d)
#endif
#elif __MESH_DIM == __3D
- Nml(1) = mesh%Nm(1)
+ 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))
+ 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 (maxlev.GT.limlev) THEN
+ maxlev=limlev
+ ENDIF
#if __KIND == __SINGLE_PRECISION
- 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)
+ 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)
#elif __KIND == __DOUBLE_PRECISION
- 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)
+ 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)
#endif
#endif
-
-
#if __DIM == __SFIELD
-!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
-
- !----------------------------------------------------------------------
- ! 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)
+ 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
- !----------------------------------------------------------------------
- ! 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
+ bcdef_sca(:,:)=0
+ 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
+ !---------------------------------------------------------------------
+ ! 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
ENDDO
- 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
#elif __DIM == __VFIELD
-!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)
+ 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
-
- !----------------------------------------------------------------------
- ! 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)
+ 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
+ !---------------------------------------------------------------------
+ ! 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
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)
+ 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
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)
+ !----------------------------------------------------------------------------
+ !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
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_vec(ilda,isub,5)=ibcdef(ilda,5)
+ !----------------------------------------------------------------------------
+ !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
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)
+ 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(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
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
-
- 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
- !-----------------------------------------------------------------------
-
+ lboundary(:,:)=.FALSE.
+ start(:,:,:)=1
+ !----------------------------------------------------------------------
+ ! Derive coarser meshes
+ !----------------------------------------------------------------------
DO mlev=1,maxlev
-
-
#if __MESH_DIM == __2D
-
- !--------------------------------------------------------------------
- ! 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
+ !-------------------------------------------------------------------
+ ! 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
idom=topo%isublist(i)
-
- stop(:,i,mlev)= mesh%nnodes(:,idom)
-
+ istop(:,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)
+ IF (max_node(j,mlev).LT.istop(j,i,mlev)) THEN
+ max_node(j,mlev)=istop(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
-
-
- !------------------------------------------------------------------
- !MICHAEL
- !------------------------------------------------------------------
+ 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
!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(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
-
- 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
-
-#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_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)
- 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
+ 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
-
- 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)
+ 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,jpoint)=bcvalue(iface,ipoint,jpoint)
-
-
- ELSE
+ 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,jpoint)=&
- & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(2*ipoint-1,2*jpoint-1)
+ 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,jpoint)=0.0_MK
-! If (mlev.EQ.5) then
-! Print *,ipoint,jpoint,mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint,jpoint)
-! endif
- ENDIF
+ !NO CORRECTIONS FOR THE DIRICHLET
+ 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
+ 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
+#endif
+ 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
- enddo
- ENDDO!faces
- endif !lperiodic
+ 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) = ppm_cart_mesh(meshid,topoid)%nnodes(1,idom)+ghostsize(1)
+ ldu3(2) = ppm_cart_mesh(meshid,topoid)%nnodes(2,idom)+ghostsize(2)
+ ldu3(3) = ppm_cart_mesh(meshid,topoid)%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) = ppm_cart_mesh(meshid,topoid)%nnodes(1,idom)
+ ldu3(2) = ppm_cart_mesh(meshid,topoid)%nnodes(2,idom)
+ ldu3(3) = ppm_cart_mesh(meshid,topoid)%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) = ppm_cart_mesh(meshid,topoid)%nnodes(1,idom)+ghostsize(1)
+ ldu3(2) = ppm_cart_mesh(meshid,topoid)%nnodes(2,idom)+ghostsize(2)
+ ldu3(3) = ppm_cart_mesh(meshid,topoid)%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
+ 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
#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
+ 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
info = ppm_error_fatal
CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the function corr. alloc.',__LINE__,info)
+ & 'Problem with the BOUNDARY 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!!)
- !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
-
+ 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
- !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
-
+ 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
#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_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
-
+ 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
- !Print *,'dfj',meshid,ppm_param_mesh_coarsen,factor,newmeshid
- CALL ppm_mesh_derive(topoid,meshid,newmeshid,&
+ 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,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
+ 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 b212e6f..df1139e 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,10 +16,13 @@
! References :
!
! Revisions :
-!-------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
! $Log: ppm_mg_res_coarse.f,v $
-! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
-! initial import
+! 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.6 2006/02/08 19:56:24 kotsalie
! fixed multiple domains
@@ -39,14 +42,12 @@
! 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
@@ -80,33 +81,29 @@
#endif
#endif
#endif
-
- !----------------------------------------------------------------------
- ! Includes
!----------------------------------------------------------------------
+ ! 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
!-------------------------------------------------------------------
+ ! Arguments
+ !-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: mlev, topo_id
REAL(MK), INTENT(OUT) :: E
#if __MESH_DIM == __2D
@@ -115,9 +112,9 @@
REAL(MK), INTENT(IN) :: c1,c2,c3,c4,c5
#endif
INTEGER, INTENT(INOUT) :: info
- !---------------------------------------------------------------------
- ! Local variables
!---------------------------------------------------------------------
+ ! Local variables
+ !-----------------------------------------------------------------------
CHARACTER(LEN=256) :: cbuf
INTEGER :: i,j,isub,color
INTEGER :: ilda,isweep,count
@@ -165,7 +162,19 @@
#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
!-----------------------------------------------------------------------
@@ -173,13 +182,11 @@
!-----------------------------------------------------------------------
!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
!-----------------------------------------------------------------------
@@ -215,8 +222,6 @@
!Definition of necessary variables and allocation of arrays
!-----------------------------------------------------------------------
topoid=topo_id
-
-
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -246,101 +251,42 @@
#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,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 - &
+ 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 - &
& 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
-
- DO isub=1,nsubs
- aa=0
- bb=0
- cc=0
- dd=0
- ee=0
- gg=0
-
- IF (.NOT.lperiodic) THEN
+ 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 iface=1,6
- IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
!DO NOTHING
- ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
IF (iface.EQ.1) THEN
aa=1
ELSEIF (iface.EQ.2) THEN
@@ -353,81 +299,47 @@
ee=1
ELSEIF (iface.EQ.6) Then
gg=1
- ENDIF
+ ENDIF
ENDIF
ENDDO !iface
- endif !periodic
- ENDDO
+ endif !periodic
!-----------------------------------------------------------------------
!Implementation
- !-----------------------------------------------------------------------
- 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 - &
+ !----------------------------------------------------------------------
+ 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 - &
& 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
- DO j=start(2,isub,mlev)+cc,stop(2,isub,mlev)-dd
- DO i=start(1,isub,mlev)+aa,stop(1,isub,mlev)-bb
+ 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 ilda=1,vecdim
- 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 - &
+ 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 - &
& mgfield(isub,mlev)%fc(ilda,i,j)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(ilda,i,j)=-res
@@ -435,26 +347,20 @@
ENDDO
ENDDO
ENDDO
-
-
-
#elif __MESH_DIM == __3D
-
!-----------------------------------------------------------------------
!Implementation
- !-----------------------------------------------------------------------
-
- IF (order.EQ.ppm_param_order_2) THEN
-
- DO isub=1,nsubs
+ !----------------------------------------------------------------------
+ E=-HUGE(E)
+ DO isub=1,nsubs
+ tuc=>mgfield(isub,mlev)%uc
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
@@ -472,61 +378,54 @@
ee=1
ELSEIF (iface.EQ.6) Then
gg=1
- ENDIF
+ ENDIF
ENDIF
ENDDO !iface
- endif !periodic
+ endif !periodic
ENDDO
- !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
+ 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
#ifdef __VECTOR
- 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 - &
+ 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 - &
& mgfield(isub,mlev)%fc(1,i,j,k)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(1,i,j,k)=-res
-
- 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 - &
+ 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 - &
& mgfield(isub,mlev)%fc(2,i,j,k)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(2,i,j,k)=-res
-
- 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 - &
+ 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 - &
& 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 =(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 - &
+ 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 - &
& mgfield(isub,mlev)%fc(ilda,i,j,k)
E=MAX(ABS(res),E)
mgfield(isub,mlev)%err(ilda,i,j,k)=-res
@@ -536,21 +435,15 @@
ENDDO
ENDDO
ENDDO
- ELSEIF (order.EQ.ppm_param_order_4) THEN
-
-
- ENDIF
-
#endif
#endif
-
-
- !----------------------------------------------------------------------
- ! Return
!----------------------------------------------------------------------
+ ! Return
+ !-----------------------------------------------------------------------
9999 CONTINUE
CALL substop('ppm_mg_res',t0,info)
RETURN
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -580,7 +473,3 @@
#endif
#endif
#endif
-
-
-
-
diff --git a/src/ppm_mg_res_fine.f b/src/ppm_mg_res_fine.f
index c01bfbf..e8d82e9 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,10 +15,13 @@
! References :
!
! Revisions :
-!-------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
! $Log: ppm_mg_res_fine.f,v $
-! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
-! initial import
+! 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.5 2006/02/08 19:56:02 kotsalie
! fixed multiple domains
@@ -35,12 +38,12 @@
! 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
@@ -75,32 +78,29 @@
#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_data_mesh
-
IMPLICIT NONE
#if __KIND == __SINGLE_PRECISION
INTEGER, PARAMETER :: MK = ppm_kind_single
#else
INTEGER, PARAMETER :: MK = ppm_kind_double
#endif
- !-------------------------------------------------------------------
- ! Arguments
!-------------------------------------------------------------------
+ ! Arguments
+ !-----------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
REAL(MK),DIMENSION(:,:,:),POINTER :: u
@@ -126,9 +126,9 @@
REAL(MK), INTENT(OUT) :: E
INTEGER, INTENT(INOUT) :: info
INTEGER, INTENT(IN ) :: topo_id
- !---------------------------------------------------------------------
- ! Local variables
!---------------------------------------------------------------------
+ ! Local variables
+ !-----------------------------------------------------------------------
CHARACTER(LEN=256) :: cbuf
INTEGER :: i,j,isub,color
INTEGER :: ilda,isweep,count
@@ -176,7 +176,6 @@
#endif
#endif
#endif
-
!-----------------------------------------------------------------------
!Externals
!-----------------------------------------------------------------------
@@ -184,10 +183,7 @@
!-----------------------------------------------------------------------
!Initialize
!-----------------------------------------------------------------------
-
CALL substart('ppm_mg_res',t0,info)
-
-
!-----------------------------------------------------------------------
! Check arguments
!-----------------------------------------------------------------------
@@ -229,8 +225,6 @@
!Definition of necessary variables and allocation of arrays
!-----------------------------------------------------------------------
topoid=topo_id
-
-
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -260,90 +254,29 @@
#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)+cc,stop(2,isub,1)-dd
- DO i=start(1,isub,1)+aa,stop(1,isub,1)-bb
+ DO j=start(2,isub,1),istop(2,isub,1)
+ DO i=start(1,isub,1),istop(1,isub,1)
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
@@ -351,12 +284,11 @@
dd=0
ee=0
gg=0
-
IF (.NOT.lperiodic) THEN
DO iface=1,6
- IF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_periodic) THEN
+ IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_periodic) THEN
!DO NOTHING
- ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
+ ELSEIF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
IF (iface.EQ.1) THEN
aa=1
ELSEIF (iface.EQ.2) THEN
@@ -369,17 +301,13 @@
ee=1
ELSEIF (iface.EQ.6) Then
gg=1
- ENDIF
+ ENDIF
ENDIF
ENDDO !iface
ENDIF !periodic
- 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
+ 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
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 - &
@@ -391,51 +319,20 @@
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)+cc,stop(2,isub,1)-dd
- DO i=start(1,isub,1)+aa,stop(1,isub,1)-bb
+ DO j=start(2,isub,1),istop(2,isub,1)
+ DO i=start(1,isub,1),istop(1,isub,1)
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)
@@ -443,18 +340,11 @@
ENDDO
ENDDO
ENDDO
-
-
-
#elif __MESH_DIM == __3D
-
!-----------------------------------------------------------------------
!Implementation
- !-----------------------------------------------------------------------
-
-
- IF (order.EQ.ppm_param_order_2) THEN
-
+ !----------------------------------------------------------------------
+ E =-HUGE(E)
DO isub=1,nsubs
aa=0
bb=0
@@ -463,7 +353,6 @@
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
@@ -481,60 +370,43 @@
ee=1
ELSEIF (iface.EQ.6) Then
gg=1
- ENDIF
+ ENDIF
ENDIF
ENDDO !iface
ENDIF !periodic
ENDDO
- !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
+ 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
#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
@@ -543,21 +415,15 @@
ENDDO
ENDDO
ENDDO
-
- ELSEIF (order.EQ.ppm_param_order_4) THEN
-
- ENDIF
-
#endif
#endif
-
-
- !----------------------------------------------------------------------
- ! Return
!----------------------------------------------------------------------
+ ! Return
+ !-----------------------------------------------------------------------
9999 CONTINUE
CALL substop('ppm_mg_res',t0,info)
RETURN
+
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -587,7 +453,3 @@
#endif
#endif
#endif
-
-
-
-
diff --git a/src/ppm_mg_restrict.f b/src/ppm_mg_restrict.f
index cf042e0..f5f635b 100644
--- a/src/ppm_mg_restrict.f
+++ b/src/ppm_mg_restrict.f
@@ -1,57 +1,64 @@
- !-----------------------------------------------------------------------
- ! 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
- !-----------------------------------------------------------------------
-
+ !----------------------------------------------------------------------
+ ! 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
+ !----------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -81,38 +88,32 @@
#endif
#endif
#endif
- !---------------------------------------------------------------------
+ !-----------------------------------------------------------------------
! Includes
- !-----------------------------------------------------------------
+ !-----------------------------------------------------------------------
#include "ppm_define.h"
-
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------
USE ppm_module_data
- 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
-
-
+ USE ppm_module_substart
+ USE ppm_module_substop
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, topo_id
INTEGER, INTENT(INOUT) :: info
- !----------------------------------------------------------------------
+ !-----------------------------------------------------------------------
! Local variables
- !---------------------------------------------------------------------
+ !-----------------------------------------------------------------------
CHARACTER(LEN=256) :: cbuf
INTEGER :: isub,j,j2,i,i2
INTEGER :: mlevm1,ilda,iface
@@ -120,100 +121,92 @@
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
@@ -243,709 +236,580 @@
#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=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))
+ !----------------------------------------------------------------------
+ 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
+ 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))
+ ENDDO
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
-
+ 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=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
+ 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
- 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
- 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
+ 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)
+ 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
+ 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
+ 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
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
!----------------------------------------------------------------------
!Restriction using a 9-point operator(bilinear interpolation)
!linear is not accurate enough
- !----------------------------------------------------------------------
-
-
- 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
+ !---------------------------------------------------------------------
+ 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
+ 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
- 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
+ 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)
+ 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
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=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)
+ 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
- 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
+ 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
#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
+ 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
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
-
+ 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 4b5000d..e9f6f62 100644
--- a/src/ppm_mg_smooth_coarse.f
+++ b/src/ppm_mg_smooth_coarse.f
@@ -1,67 +1,74 @@
-!-----------------------------------------------------------------------
-! 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
-!-------------------------------------------------------------------------
-
+ !------------------------------------------------------------------------------
+ ! 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
+ !-----------------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -99,1414 +106,990 @@
#endif
#endif
#endif
-
- !----------------------------------------------------------------------
- ! Includes
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
+ ! Includes
+ !----------------------------------------------------------------------
#include "ppm_define.h"
-
- !-------------------------------------------------------------------
- ! 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
+ !------------------------------------------------------------------
+ ! 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
- !-------------------------------------------------------------------
- INTEGER, INTENT(IN) :: nsweep
- INTEGER, INTENT(IN) :: mlev, topo_id
+ !------------------------------------------------------------------
+ ! 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,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
+ 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
#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 __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
+ !----------------------------------------------------------------------
+ !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 __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
#endif
- ENDIF
- !-----------------------------------------------------------------------
- !Definition of necessary variables and allocation of arrays
- !-----------------------------------------------------------------------
- topoid=topo_id
-
-
+ 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
-
-
- 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
-
+ !----------------------------------------------------------------------
+ !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
DO isub=1,nsubs
- mask_red=>mgfield(isub,mlev)%mask_red
- mask_dummy_2d(:,:,&
- & isub)=mask_red(:,:)
-
- tuc=>mgfield(isub,mlev)%uc
- uc_dummy(:,:,isub)=tuc(:,:)
- ENDDO
+ tuc=>mgfield(isub,mlev)%uc
+ uc_dummy(:,:,isub)=tuc(:,:)
+ ENDDO
+ ENDIF
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
-
+ 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
#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
-
- 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
-
+ !----------------------------------------------------------------------
+ !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
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)
+ 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
-
- 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!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
- 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,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)
+ 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)
tuc(i,j,k)=0.0_MK
+ ENDDO
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
+ 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
- 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)
-
+ 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
- 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)
+ 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
+ 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
+ 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
- ENDDO
- ENDDO!isub
+ ENDDO!isub
ENDIF
ENDIF
-
- 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!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
- 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!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
-
-
- 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(:,:,:)
+ !----------------------------------------------------------------------
+ !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
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
- 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
+ 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
#elif __MESH_DIM == __3D
-
- !-----------------------------------------------------------------------
- !Implementation
- !-----------------------------------------------------------------------
-
+ !----------------------------------------------------------------------
+ !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
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)
+ 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', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'moldu',__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
-
-
-
- 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 isweep=1,nsweep
+ DO color=0,1
+ DO isub=1,nsubs
+ !-------------------------------------------------------------
+ !Impose boundaries
+ !-------------------------------------------------------------
+ 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)
-
- 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
-
- 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
-
- 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)
+ 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)
-
+ 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
+ DO ilda=1,vecdim
+ tuc(ilda,i,j,k)=uc_dummy(ilda,i,j,k,isub)
+ ENDDO
#endif
+ ENDDO
ENDDO
- 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
- !IF (color.EQ.0) THEN
- b(isub)=1
- IF (bcdef_vec(ilda,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)
+ 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
- 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
+ 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)
+ 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
+ g(isub)=-1
ENDIF
- k=1
- DO i=1,max_node(1,mlev)
- Do j=1,max_node(2,mlev)
+ 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
+ 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
+ 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
#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
-
- 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))
+ 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))
#else
- 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
+ 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
#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
- 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
+ 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
- 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)
+ 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
ENDDO
ENDDO
ENDDO
- ENDDO
- ENDIF
-
- ENDDO!Do isweep
-
+ 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
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)
+ 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', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
+ info = ppm_error_fatal
+ CALL ppm_error(ppm_err_alloc,'GSsolv', &
+ & 'moldu',__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 ba01d48..0ccef03 100644
--- a/src/ppm_mg_smooth_fine.f
+++ b/src/ppm_mg_smooth_fine.f
@@ -1,61 +1,68 @@
-!-----------------------------------------------------------------------
-! 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
-!-------------------------------------------------------------------------
-
+ !------------------------------------------------------------------------------
+ ! 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
+ !-----------------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -93,76 +100,71 @@
#endif
#endif
#endif
-
- !----------------------------------------------------------------------
- ! Includes
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
+ ! Includes
+ !----------------------------------------------------------------------
#include "ppm_define.h"
-
- !-------------------------------------------------------------------
- ! 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
+ !------------------------------------------------------------------
+ ! 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, topo_id
+ 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
+ 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
@@ -200,13 +202,6 @@
#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
@@ -233,23 +228,17 @@
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
@@ -290,13 +279,10 @@
ENDIF
#endif
ENDIF
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
!Definition of necessary variables and allocation of arrays
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
topoid=topo_id
-
-
-
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -326,7 +312,6 @@
#endif
#endif
#endif
-
#if __KIND == __SINGLE_PRECISION
omega=omega_s
dx=dx_s
@@ -342,7 +327,6 @@ dy=dy_d
dz=dz_d
#endif
#endif
-
iopt = ppm_param_alloc_fit
ldl1(1) = 1
ldu1(1) = nsubs
@@ -358,218 +342,85 @@ 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
- 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
- !-----------------------------------------------------------------
+ !----------------------------------------------------------------
+ !Communicate
+ !----------------------------------------------------------------
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info,mask_dummy_2d)
+ & ghostsize,ppm_param_map_ghost_get,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
+ & ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
-
-
+ & ghostsize,ppm_param_map_pop,info)
DO isub=1,nsubs
-
- !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
-
+ 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
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,mask_dummy_2d)
+ & ghostsize,ppm_param_map_ghost_get,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info,mask_dummy_2d)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
+ & ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
-
- ENDIF
+ & ghostsize,ppm_param_map_pop,info)
+ ENDIF
ENDDO
-
-
-
#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(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 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
- !--------------------------------------------------------------
- a=0
- b=0
- c=0
- d=0
- e=0
- g=0
-
+ !-------------------------------------------------------------
+ !Impose boundaries on even if color=0 or odd if color=1
+ !-------------------------------------------------------------
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
- !IF (color.EQ.1) THEN
- a(isub)=1
- !ENDIF
+ 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)
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
- !ENDIF
+ 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)
@@ -577,7 +428,10 @@ dz=dz_d
ENDDO
enddo
ELSEIF (iface.EQ.3) THEN
- c(isub)=1
+ 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)
@@ -586,6 +440,9 @@ 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)
@@ -593,8 +450,11 @@ dz=dz_d
enddo
ENDDO
ELSEIF (iface.EQ.5) Then
- e(isub)=1
- k=1
+ 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)
u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i,j)
@@ -602,6 +462,9 @@ 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)
@@ -609,83 +472,31 @@ 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
- 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)
- CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info)
- CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info)
-
-#else
-
+ ENDDO!iface
+ ENDIF
+ ENDDO!DO isub
+ !----------------------------------------------------------------
+ !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,mask_dummy_3d)
+ & ghostsize,ppm_param_map_ghost_get,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info,mask_dummy_3d)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info,mask_dummy_3d)
+ & ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info,mask_dummy_3d)
-
-
-
-#endif
-
-
+ & ghostsize,ppm_param_map_pop,info)
DO isub=1,nsubs
- 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
-
+ 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
moldu=u(i,j,k,isub)
-
-
u(i,j,k,isub)=moldu+omega*&
& (&
& c1*((u(i-1,j,k,isub)+ &
@@ -694,198 +505,96 @@ 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
-
- 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!subs
ENDDO!DO color
-
IF (isweep.EQ.nsweep) THEN
-
-#ifdef __WITHOUTMASKS
-
- CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_ghost_get,info)
- CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info)
- CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & 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_ghost_get,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_push,info,mask_dummy_3d)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info,mask_dummy_3d)
+ & ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info,mask_dummy_3d)
-
-
-
-#endif
-
- ENDIF
- ENDDO
-
-
+ & ghostsize,ppm_param_map_pop,info)
+ 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
- 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
- !-----------------------------------------------------------------
-
-
+ !----------------------------------------------------------------
+ !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,mask_dummy_2d)
+ & 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,mask_dummy_2d)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
+ & ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
-
-
-
-
+ & ghostsize,ppm_param_map_pop,info)
DO isub=1,nsubs
- 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 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 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,mask_dummy_2d)
+ & 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,mask_dummy_2d)
+ & ghostsize,ppm_param_map_push,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_send,info,mask_dummy_2d)
+ & ghostsize,ppm_param_map_send,info)
CALL ppm_map_field_ghost(u,vecdim,topoid,mesh_id_g(mlev),&
- & ghostsize,ppm_param_map_pop,info,mask_dummy_2d)
-
+ & ghostsize,ppm_param_map_pop,info)
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
@@ -905,7 +614,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
@@ -919,7 +628,6 @@ 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
@@ -928,7 +636,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
@@ -939,7 +647,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
@@ -950,51 +658,38 @@ 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
- ELSEIF (bcdef_vec(ilda,isub,iface).EQ.ppm_param_bcdef_neumann) THEN
-
-
+ ENDIF
ENDIF
-
- ENddo !iface
- endif !periodic
- Enddo !ilda
- ENDDO!DO isub4
-
-
- !-----------------------------------------------------------------
- !Communicate red(even) if color==0 or communicate black(odd)
- !if color==1
- !-----------------------------------------------------------------
-
-
+ ENddo !iface
+ endif !periodic
+ Enddo !ilda
+ ENDDO!DO isub
+ !----------------------------------------------------------------
+ !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),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
-
-
+ 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
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)+ &
@@ -1002,8 +697,7 @@ 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)+ &
@@ -1011,9 +705,7 @@ 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)+ &
@@ -1021,40 +713,23 @@ 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),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 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 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)+ &
@@ -1062,23 +737,16 @@ 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!HACK
+ ENDIF
ENDDO
ENDDO
ENDDO
- !PRINT *,'AFTER:',u(1,:,:,17,6)
-
- ENDDO!subs
-
+ 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),&
@@ -1087,14 +755,11 @@ 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', &
@@ -1103,13 +768,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
@@ -1139,7 +804,3 @@ dz=dz_d
#endif
#endif
#endif
-
-
-
-
diff --git a/src/ppm_mg_solv.f b/src/ppm_mg_solv.f
index fbd83e8..ef0adce 100644
--- a/src/ppm_mg_solv.f
+++ b/src/ppm_mg_solv.f
@@ -1,76 +1,83 @@
- !-------------------------------------------------------------------------
- ! 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
- !-------------------------------------------------------------------------
-
+ !------------------------------------------------------------------------
+ ! 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
+ !------------------------------------------------------------------------
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
@@ -108,12 +115,10 @@
#endif
#endif
#endif
-
#include "ppm_define.h"
-
- !----------------------------------------------------------------------
- ! Modules
- !----------------------------------------------------------------------
+ !---------------------------------------------------------------------
+ ! Modules
+ !----------------------------------------------------------------------
USE ppm_module_data
USE ppm_module_data_mg
USE ppm_module_data_mesh
@@ -126,136 +131,134 @@
USE ppm_module_mg_res
USE ppm_module_mg_prolong
USE ppm_module_mg_smooth
- USE ppm_module_write
-
- IMPLICIT NONE
-
+ 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 ) :: 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
-
-
+ 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) :: EPSU
+ 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
#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
-
+ 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
+ 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
-
-
- !----------------------------------------------------------------------
- ! Externals
- !----------------------------------------------------------------------
-
- !----------------------------------------------------------------------
- ! Initialize
- !----------------------------------------------------------------------
-
- CALL substart('ppm_mg_solv',t0,info)
-
-
+#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
+ !----------------------------------------------------------------------
+
+ !----------------------------------------------------------------------
+ ! Initialize
+ !----------------------------------------------------------------------
+ CALL substart('ppm_mg_solv',t0,info)
#ifdef __MPI
IF (ppm_kind.EQ.ppm_kind_single) THEN
MPI_PREC = MPI_REAL
@@ -263,11 +266,10 @@
MPI_PREC = MPI_DOUBLE_PRECISION
ENDIF
#endif
- topo => ppm_topo(topo_id)%t
-
- !-----------------------------------------------------------------------
+ topo => ppm_topo(topo_id)%t
+ !----------------------------------------------------------------------
! Check arguments
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
IF (ppm_debug .GT. 0) THEN
#if __DIM == __SFIELD
#if __MESH_DIM == __2D
@@ -281,14 +283,14 @@
DO i=1,nsubs
idom=topo%isublist(i)
IF (SIZE(u(:,:,i),1).LT.ppm_cart_mesh(meshid_g(1), &
- & topoid)%nnodes(1,idom)+2) THEN
+ & topoid)%nnodes(1,idom)+2*ghostsize(1)) 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.ppm_cart_mesh(meshid_g(1), &
- & topoid)%nnodes(2,idom)+2) THEN
+ & topoid)%nnodes(2,idom)+2*ghostsize(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)
@@ -330,21 +332,21 @@
DO i=1,nsubs
idom=topo%isublist(i)
IF (SIZE(u(:,:,:,i),1).LT.ppm_cart_mesh(meshid_g(1), &
- & topoid)%nnodes(1,idom)+2) THEN
+ & topoid)%nnodes(1,idom)+2*ghostsize(1)) 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.ppm_cart_mesh(meshid_g(1), &
- & topoid)%nnodes(2,idom)+2) THEN
+ & topoid)%nnodes(2,idom)+2*ghostsize(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.ppm_cart_mesh(meshid_g(1), &
- & topoid)%nnodes(3,idom)+2) THEN
+ & topoid)%nnodes(3,idom)+2*ghostsize(3)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in z-dir!',__LINE__,info)
@@ -434,7 +436,6 @@
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', &
@@ -445,21 +446,21 @@
DO i=1,nsubs
idom=topo%isublist(i)
IF (SIZE(u(:,:,:,:,i),2).LT.ppm_cart_mesh(meshid_g(1), &
- & topoid)%nnodes(1,idom)+2) THEN
+ & topoid)%nnodes(1,idom)+2*ghostsize(1)) 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.ppm_cart_mesh(meshid_g(1), &
- & topoid)%nnodes(2,idom)+2) THEN
+ & topoid)%nnodes(2,idom)+2*ghostsize(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.ppm_cart_mesh(meshid_g(1), &
- & topoid)%nnodes(3,idom)+2) THEN
+ & topoid)%nnodes(3,idom)+2*ghostsize(3)) THEN
info = ppm_error_error
CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
& 'solution mess with mesh points in z-dir!',__LINE__,info)
@@ -500,10 +501,9 @@
#endif
#endif
ENDIF
-
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
!Definition of necessary variables and allocation of arrays
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
#if __MESH_DIM == __2D
#if __KIND == __SINGLE_PRECISION
#if __DIM == __SFIELD
@@ -515,7 +515,6 @@
rdy2=rdy2_s
dx=dx_s
dy=dy_s
- EPSU=EPSU_s
#elif __KIND == __DOUBLE_PRECISION
#if __DIM == __SFIELD
mgfield=>mgfield_2d_sca_d
@@ -526,7 +525,6 @@
rdy2=rdy2_d
dx=dx_d
dy=dy_d
- EPSU=EPSU_d
#endif
#elif __MESH_DIM == __3D
#if __KIND == __SINGLE_PRECISION
@@ -541,7 +539,6 @@
dx=dx_s
dy=dy_s
dz=dz_s
- EPSU=EPSU_s
#elif __KIND == __DOUBLE_PRECISION
#if __DIM == __SFIELD
mgfield=>mgfield_3d_sca_d
@@ -554,17 +551,12 @@
dx=dx_d
dy=dy_d
dz=dz_d
- EPSU=EPSU_d
#endif
#endif
-
- topoid=topo_id
-
+ 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
@@ -582,7 +574,6 @@
GOTO 9999
ENDIF
uc_dummy(:,:,:)=0.0_MK
-
#elif __MESH_DIM ==__3D
iopt = ppm_param_alloc_fit
ldl4(1) = 1-ghostsize(1)
@@ -600,16 +591,10 @@
& '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)
@@ -625,7 +610,6 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
-
#elif __MESH_DIM ==__3D
iopt = ppm_param_dealloc
ldl4(1) = 1-ghostsize(1)
@@ -643,7 +627,6 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
-
#endif
#elif __DIM == __VFIELD
#if __MESH_DIM == __2D
@@ -664,7 +647,6 @@
GOTO 9999
ENDIF
uc_dummy(:,:,:,:)=0.0_MK
-
#elif __MESH_DIM ==__3D
iopt = ppm_param_alloc_fit
ldl5(1) = 1
@@ -684,16 +666,10 @@
& '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)
@@ -709,7 +685,6 @@
& 'uc_dummy',__LINE__,info)
GOTO 9999
ENDIF
-
#elif __MESH_DIM ==__3D
iopt = ppm_param_dealloc
ldl5(1) = 1-ghostsize(1)
@@ -727,130 +702,81 @@
& '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(topo_id,u,f,itera,1,c1,c2,c3,info)
-
- !-----------------------------------------------------------------
+ !----------------------------------------------------------------------
! Compute residual
- !-----------------------------------------------------------------
-
+ !----------------------------------------------------------------------
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)
!---------------------------------------------------------------------
+ !Initiation of the function correction. (We start on purpose with lev=2)
+ !----------------------------------------------------------------------
DO mlev=2,maxlev
DO isub=1,nsubs
- 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
+ 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
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
- 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)
+ 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)
ENDDO
ENDDO
ENDDO
- ENDIF
-
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
!DO the final sweeps
- !-----------------------------------------------------------------------
- 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
@@ -859,46 +785,35 @@ ENDIF
#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(topo_id,u,f,itera,1,c1,c2,c3,c4,info)
-
- !-----------------------------------------------------------------
+ !----------------------------------------------------------------------
! Compute residual
- !-----------------------------------------------------------------
-
-
+ !----------------------------------------------------------------------
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
- 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
+ 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
ENDDO
ENDDO
ENDDO
@@ -906,54 +821,38 @@ ENDIF
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
- 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)
+ 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)
ENDDO
ENDDO
ENDDO
ENDDO
- ENDIF
-
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
!DO the final sweeps
- !-----------------------------------------------------------------------
+ !--------------------------------------------------------------------
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
@@ -963,45 +862,35 @@ ENDIF
#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(topo_id,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(topo_id,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
- DO j=start(2,isub,mlev),stop(2,isub,mlev)
- DO i=start(1,isub,mlev),stop(1,isub,mlev)
+ 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 ilda=1,vecdim
- mgfield(isub,mlev)%uc(ilda,i,j)=0.0_MK
+ tuc(ilda,i,j)=0.0_MK
ENDDO
ENDDO
ENDDO
@@ -1009,58 +898,38 @@ ENDIF
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
- DO j=start(2,isub,1),stop(2,isub,1)
- DO i=start(1,isub,1),stop(1,isub,1)
+ 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 ilda=1,vecdim
- u(ilda,i,j,isub)=mgfield(isub,1)%uc(ilda,i,j)
+ u(ilda,i,j,isub)=tuc(ilda,i,j)
ENDDO
ENDDO
ENDDO
ENDDO
- ENDIF
-
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
!DO the final sweeps
- !-----------------------------------------------------------------------
+ !--------------------------------------------------------------------
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_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)
@@ -1068,51 +937,42 @@ ENDIF
#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(topo_id,u,f,itera,1,c1,c2,c3,c4,info)
!-----------------------------------------------------------------
! Compute residual
!-----------------------------------------------------------------
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)
!---------------------------------------------------------------------
+ !Initiation of the function correction. (We start on purpose with lev=2)
+ !----------------------------------------------------------------------
DO mlev=2,maxlev
DO isub=1,nsubs
- 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)
+ 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)
#ifdef __VECTOR
- 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
+ tuc(1,i,j,k)=0.0_MK
+ tuc(2,i,j,k)=0.0_MK
+ tuc(3,i,j,k)=0.0_MK
#else
DO ilda=1,vecdim
- mgfield(isub,mlev)%uc(ilda,i,j,k)=0.0_MK
+ tuc(ilda,i,j,k)=0.0_MK
ENDDO
#endif
ENDDO
@@ -1122,63 +982,46 @@ ENDIF
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
- 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)
+ 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)
#ifdef __VECTOR
- 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)
+ 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)
#else
DO ilda=1,vecdim
- u(ilda,i,j,k,isub)=mgfield(isub,1)%uc(ilda,i,j,k)
+ u(ilda,i,j,k,isub)=tuc(ilda,i,j,k)
ENDDO
#endif
ENDDO
ENDDO
ENDDO
ENDDO
- ENDIF
-
- !-----------------------------------------------------------------------
+ !----------------------------------------------------------------------
!DO the final sweeps
- !-----------------------------------------------------------------------
+ !--------------------------------------------------------------------
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_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
@@ -1187,13 +1030,13 @@ ENDIF
#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 a78864b..ea57a0a 100644
--- a/src/ppm_module_data_mg.f
+++ b/src/ppm_module_data_mg.f
@@ -1,38 +1,41 @@
- !-------------------------------------------------------------------------
- ! 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
- !-------------------------------------------------------------------------
+ !------------------------------------------------------------------------
+ ! 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
+ !------------------------------------------------------------------------
#define __SINGLE_PRECISION 1
@@ -355,7 +358,7 @@ MODULE ppm_module_data_mg
!-----------------------------------------------------------------------------
!Stopping index for the iteration through the mesh points.
!-----------------------------------------------------------------------------
- INTEGER, DIMENSION(:,:,:), POINTER :: stop
+ INTEGER, DIMENSION(:,:,:), POINTER :: istop
!-----------------------------------------------------------------------------
!Factor for coarsening the mesh
!-----------------------------------------------------------------------------
diff --git a/src/ppm_module_mg_core.f b/src/ppm_module_mg_core.f
index 02434c6..aaef3fa 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 2006/07/25 15:18:20 menahel
- ! initial import
+ ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
+ ! CBL version of the PPM library
!
! Revision 1.1 2004/09/22 18:31:04 kotsalie
! MG new version
--
GitLab