diff --git a/src/fft/ppm_fft_exec_3d_vec_bc2r_xy.f b/src/fft/ppm_fft_exec_3d_vec_bc2r_xy.f
deleted file mode 100644
index 53b5727653a0ce01ad665402af2ae9e171c2f7e3..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_exec_3d_vec_bc2r_xy.f
+++ /dev/null
@@ -1,121 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_exec_3d_vec_bc2r_xy
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! FFTW execute wrapper for 3d arrays, 2d complex to real
- ! (backward) FFT in the xy directions
- ! The routine does not work with fields that include ghost layers
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_exec_3d_vec_bc2r_xy_s
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_exec_3d_vec_bc2r_xy_d
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,outfield,info)
- !!! FFTW execute wrapper for 3d arrays, 2d complex to real
- !!! (backward) FFT in the xy directions
- !!! Before calling this routine a ppm_fft_plan_ routine must be called
- !!! The routine does not work with fields that include ghost layers
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: infield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!output field for the result of the fourier transform
- !REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: outfield
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: outfield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(__PREC) :: t0
- INTEGER :: i,k
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_exec',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_exec','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- !-------------------------------------------------------------------------
- ! Execute plan
- !-------------------------------------------------------------------------
- DO isub=1,nsubs
- isubl=isublist(isub)
- DO k=1,mesh%nnodes(3,isubl) !@ add '-1' to exclude n+1 slabs
- CALL dfftw_execute_dft_c2r(ppmplan%plan(isub),&
- & infield(1,1,1,k,isub),outfield(1,1,1,k,isub))
- IF (topology%bcdef(1) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- !-------------------------------------------------------------------
- ! Copy periodic layer back - only for periodic 'N' vertex points
- !-------------------------------------------------------------------
- DO i=1,mesh%nnodes(1,isubl)
- outfield(1,i,mesh%nnodes(2,isubl),k,isub) = outfield(1,i,1,k,isub)
- outfield(2,i,mesh%nnodes(2,isubl),k,isub) = outfield(2,i,1,k,isub)
- outfield(3,i,mesh%nnodes(2,isubl),k,isub) = outfield(3,i,1,k,isub)
- END DO
- DO i=1,mesh%nnodes(2,isubl)
- outfield(1,mesh%nnodes(1,isubl),i,k,isub) = outfield(1,1,i,k,isub)
- outfield(2,mesh%nnodes(1,isubl),i,k,isub) = outfield(2,1,i,k,isub)
- outfield(3,mesh%nnodes(1,isubl),i,k,isub) = outfield(3,1,i,k,isub)
- END DO
- END IF
- END DO
- END DO
-
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_exec',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/fft/ppm_fft_exec_3d_vec_c2c_z.f b/src/fft/ppm_fft_exec_3d_vec_c2c_z.f
deleted file mode 100644
index bc72551003e84903d5f1ce1a765ba67c35e964e3..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_exec_3d_vec_c2c_z.f
+++ /dev/null
@@ -1,126 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_exec_3d_vec_c2c_z
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! FFTW execute wrapper for 3d arrays, 1d complex to complex
- ! (forward and backward) FFT in the z direction
- ! The routine does not work with fields that include ghost layers
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_exec_3d_vec_c2c_z_s
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_exec_3d_vec_c2c_z_d
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,outfield,info)
- !!! FFTW execute wrapper for 3d arrays, 1d complex to complex
- !!! (forward and backward) FFT in the z direction
- !!! Before calling this routine a ppm_fft_plan_ routine must be called
- !!! The routine does not work with fields that include ghost layers
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: infield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!output field for the result of the fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: outfield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: outfield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(__PREC) :: t0
- INTEGER :: i,j
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_exec',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_exec','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- !outfield = 0.0_ppm_kind_double !@
- !-------------------------------------------------------------------------
- ! Execute plan
- !-------------------------------------------------------------------------
- DO isub=1,nsubs
- isubl=isublist(isub)
- DO j=1,mesh%nnodes(2,isubl) !@ add '-1' to exclude n+1 points
- DO i=1,mesh%nnodes(1,isubl) !@ add '-1' to exclude n+1 points
- CALL dfftw_execute_dft(ppmplan%plan(isub),&
- & infield(1,i,j,1,isub),outfield(1,i,j,1,isub))
- END DO
- END DO
- END DO
-
- !-------------------------------------------------------------------------
- ! Copy periodic - this is only for the periodic 'N+1' vertex points
- !-------------------------------------------------------------------------
- IF (topology%bcdef(3) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- IF (ppmplan%sign .EQ. FFTW_BACKWARD) THEN
- DO isub=1,nsubs
- isubl=isublist(isub)
- DO j=1,mesh%nnodes(2,isubl) !@ add '-1' to exclude n+1 points
- DO i=1,mesh%nnodes(1,isubl) !@ add '-1' to exclude n+1 points
- outfield(1,i,j,mesh%nnodes(3,isubl),isub) = outfield(1,i,j,1,isub)
- outfield(2,i,j,mesh%nnodes(3,isubl),isub) = outfield(2,i,j,1,isub)
- outfield(3,i,j,mesh%nnodes(3,isubl),isub) = outfield(3,i,j,1,isub)
- END DO
- END DO
- END DO
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_exec',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/fft/ppm_fft_exec_3d_vec_fr2c_xy.f b/src/fft/ppm_fft_exec_3d_vec_fr2c_xy.f
deleted file mode 100644
index 888f602b4e5e2bbb691eef1213a51f5de9efab98..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_exec_3d_vec_fr2c_xy.f
+++ /dev/null
@@ -1,105 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_exec_3d_vec_fr2c_xy
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! FFTW execute wrapper for 3d arrays, 2d real to complex
- ! (forward) FFT in the xy directions
- ! The routine does not work with fields that include ghost layers
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_exec_3d_vec_fr2c_xy_s
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_exec_3d_vec_fr2c_xy_d
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,outfield,info)
- !!! FFTW execute wrapper for 3d arrays, 2d real to complex
- !!! (forward) FFT in the xy directions
- !!! Before calling this routine a ppm_fft_plan_ routine must be called
- !!! The routine does not work with fields that include ghost layers
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to fourier transform
- !REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: infield
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!output field for the result of the fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: outfield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: outfield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(__PREC) :: t0
- INTEGER :: k
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_exec',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_exec','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- !-------------------------------------------------------------------------
- ! Execute plan
- !-------------------------------------------------------------------------
- DO isub=1,nsubs
- isubl=isublist(isub)
- DO k=1,mesh%nnodes(3,isubl) !@ add '-1' to exclude n+1 slabs
- CALL dfftw_execute_dft_r2c(ppmplan%plan(isub),&
- & infield(1,1,1,k,isub),outfield(1,1,1,k,isub))
- END DO
- END DO
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_exec',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/fft/ppm_fft_normalize_c.f b/src/fft/ppm_fft_normalize_c.f
deleted file mode 100644
index fed11977d13eaa0b09e1c783f9e16aa239074508..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_normalize_c.f
+++ /dev/null
@@ -1,129 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_normalize_c
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! The routine does not work with fields that include ghost layers.
- ! Fields are noralized in the 1/N - fashion that scales fields to the
- ! proper level after being FFTed and iFFTed
- ! The routines are not meant for production code as the normalization can
- ! be done for all dimensions in one pass - which may and should be done
- ! in a routine (looping through the data anyway) following the FFTs.
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_normalize_cs
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_normalize_cd
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,info)
- !!! The routine does not work with fields that include ghost layers.
- !!! Fields are noralized in the 1/N - fashion that scales fields to the
- !!! proper level after being FFTed and iFFTed
- !!! The routines are not meant for production code as the normalization
- !!! can be done for all dimensions in one pass - which may and should be
- !!! done in a routine (looping through the data anyway) following the FFTs
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to normalize
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- !timer
- INTEGER,PARAMETER :: MK = ppm_kind_double
- REAL(__PREC) :: t0
- !normalization factor
- REAL(MK) :: fac
- INTEGER :: i,j,k
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_normalize',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- DO isub=1,nsubs
- isubl=isublist(isub)
- !determine normalization factor
- IF (ppmplan%rank .EQ. 1) THEN
- IF (topology%bcdef(3) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- fac = 1.0_MK/REAL((mesh%nm(3)-1),MK)
- ELSE
- fac = 1.0_MK/REAL((mesh%nm(3)),MK)
- ENDIF
- ELSE IF (ppmplan%rank .EQ. 2) THEN
- IF (topology%bcdef(1) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- fac = 1.0_MK/REAL((mesh%nm(1)-1)*(mesh%nm(2)-1),MK)
- ELSE
- fac = 1.0_MK/REAL((mesh%nm(1) )*(mesh%nm(2) ),MK)
- ENDIF
- ENDIF
-
- DO k=1,mesh%nnodes(3,isubl)
- DO j=1,mesh%nnodes(2,isubl)
- DO i=1,mesh%nnodes(1,isubl)
- infield(1,i,j,k,isub) = fac*infield(1,i,j,k,isub)
- infield(2,i,j,k,isub) = fac*infield(2,i,j,k,isub)
- infield(3,i,j,k,isub) = fac*infield(3,i,j,k,isub)
- END DO
- END DO
- END DO
- END DO
-
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_normalize',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/fft/ppm_fft_normalize_r.f b/src/fft/ppm_fft_normalize_r.f
deleted file mode 100644
index 7739b55faaf7eb8c5f5e96815e50ebc100fb8c14..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_normalize_r.f
+++ /dev/null
@@ -1,130 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_normalize_r
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! The routine does not work with fields that include ghost layers.
- ! Fields are noralized in the 1/N - fashion that scales fields to the
- ! proper level after being FFTed and iFFTed
- ! The routines are not meant for production code as the normalization can
- ! be done for all dimensions in one pass - which may and should be done
- ! in a routine (looping through the data anyway) following the FFTs.
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_normalize_rs
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_normalize_rd
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,info)
- !!! The routine does not work with fields that include ghost layers.
- !!! Fields are noralized in the 1/N - fashion that scales fields to the
- !!! proper level after being FFTed and iFFTed
- !!! The routines are not meant for production code as the normalization
- !!! can be done for all dimensions in one pass - which may and should be
- !!! done in a routine (looping through the data anyway) following the FFTs
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to normalize
- !REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: infield
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- !timer
- INTEGER,PARAMETER :: MK = ppm_kind_double
- REAL(__PREC) :: t0
- !normalization factor
- REAL(MK) :: fac
- INTEGER :: i,j,k
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_normalize',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- DO isub=1,nsubs
- isubl=isublist(isub)
- !determine normalization factor
- IF (ppmplan%rank .EQ. 1) THEN
- IF (topology%bcdef(3) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- fac = 1.0_MK/REAL((mesh%nm(3)-1),MK)
- ELSE
- fac = 1.0_MK/REAL((mesh%nm(3)),MK)
- ENDIF
- ELSE IF (ppmplan%rank .EQ. 2) THEN
- IF (topology%bcdef(1) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- fac = 1.0_MK/REAL((mesh%nm(1)-1)*(mesh%nm(2)-1),MK)
- ELSE
- fac = 1.0_MK/REAL((mesh%nm(1) )*(mesh%nm(2) ),MK)
- ENDIF
- ENDIF
-
- DO k=1,mesh%nnodes(3,isubl)
- DO j=1,mesh%nnodes(2,isubl)
- DO i=1,mesh%nnodes(1,isubl)
- infield(1,i,j,k,isub) = fac*infield(1,i,j,k,isub)
- infield(2,i,j,k,isub) = fac*infield(2,i,j,k,isub)
- infield(3,i,j,k,isub) = fac*infield(3,i,j,k,isub)
- END DO
- END DO
- END DO
- END DO
-
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_normalize',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/fft/ppm_fft_plan_3d_vec_bc2c_z.f b/src/fft/ppm_fft_plan_3d_vec_bc2c_z.f
deleted file mode 100644
index ba19e1e19f2b5b68eb3d4689eaaad0c38238f6e4..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_plan_3d_vec_bc2c_z.f
+++ /dev/null
@@ -1,151 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_plan_3d_vec_bc2c_z
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! FFTW plan wrapper for 3d arrays, 1d complex to complex
- ! (backward) FFT in the z direction
- ! The routine does not work with fields that include ghost layers
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_plan_3d_vec_bc2c_z_s
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_plan_3d_vec_bc2c_z_d
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,outfield,info)
- !!! FFTW plan wrapper for 3d arrays, 1d complex to complex
- !!! (backward) FFT in the z direction
- !!! The routine does not work with fields that include ghost layers
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: infield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!output field for the result of the fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: outfield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: outfield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(__PREC) :: t0
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_plan',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- !-------------------------------------------------------------------------
- ! Setup parameters for this particular routine
- !-------------------------------------------------------------------------
- !the dimension of the FFT (1D/2D/3D)
- ppmplan%rank=1
- !the number of points along each direction of the piece to be transformed
- ALLOCATE(ppmplan%nx(ppmplan%rank,nsubs))
- !the direction of the transform
- ppmplan%sign=FFTW_BACKWARD
- !the method to setup the optimal plan
- ppmplan%flag=FFTW_MEASURE
- !the number of components to transform - 3 component vector
- ppmplan%howmany=3
- !the size of the input array - full size (assuming LBOUND=1 thus UBOUND)
- ALLOCATE(ppmplan%inembed(ppmplan%rank))
- ppmplan%inembed(1) = UBOUND(infield,4)
- !the size of the output array - full size (assuming LBOUND=1 thus UBOUND)
- ALLOCATE(ppmplan%onembed(ppmplan%rank))
- ppmplan%onembed(1) = UBOUND(outfield,4)
- !istride tells how the same componenet data points are spaced in memory
- !e.g. z values recur every x-dim*y-dim*component values
- ppmplan%istride = UBOUND(infield,2) *UBOUND(infield,3)*3
- ppmplan%ostride = UBOUND(outfield,2)*UBOUND(outfield,3)*3
- !idist tells how multiple arrays are spaced in memory. I.e. a memory
- !offset. e.g. vector components (idist=1) or scalar 2D arrays in
- !3D array(idist=NxNy)
- ppmplan%idist = 1
- ppmplan%odist = 1
-
- !-------------------------------------------------------------------------
- ! Allocate plan array
- !-------------------------------------------------------------------------
- IF(ASSOCIATED(ppmplan%plan)) THEN
- DEALLOCATE(ppmplan%plan,stat=info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to deallocate plan-array.',isub)
- GOTO 9999
- ENDIF
- END IF
- ALLOCATE(ppmplan%plan(nsubs))
-
- DO isub=1,nsubs
- isubl=isublist(isub)
- !@ maybe the -1 needs to be removed when doing cell data
- !we subtract the -1 to avoid the periodic vertex point
- IF (topology%bcdef(3) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- ppmplan%nx(1,isub) = mesh%nm(3)-1
- ELSE
- ppmplan%nx(1,isub) = mesh%nm(3)
- ENDIF
-
- CALL dfftw_plan_many_dft(ppmplan%plan(isub),ppmplan%rank,&
- & ppmplan%nx(:,isub),ppmplan%howmany,infield(1,1,1,1,isub),&
- & ppmplan%inembed(1),ppmplan%istride,ppmplan%idist,&
- & outfield(1,1,1,1,isub),ppmplan%onembed(1),ppmplan%ostride,&
- & ppmplan%odist,ppmplan%sign,ppmplan%flag)
- END DO
-
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_plan',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/fft/ppm_fft_plan_3d_vec_bc2r_xy.f b/src/fft/ppm_fft_plan_3d_vec_bc2r_xy.f
deleted file mode 100644
index ac954c3c94e769af8481352aa9c3df98213e6191..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_plan_3d_vec_bc2r_xy.f
+++ /dev/null
@@ -1,156 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_plan_3d_vec_bc2r_xy
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! FFTW plan wrapper for 3d arrays, 2d complex to real
- ! (backward) FFT in the xy directions
- ! The routine does not work with fields that include ghost layers
- !
- ! For the C2R inverse transform FFTW always destroys the input data
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_plan_3d_vec_bc2r_xy_s
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_plan_3d_vec_bc2r_xy_d
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,outfield,info)
- !!! FFTW plan wrapper for 3d arrays, 2d complex to real
- !!! (backward) FFT in the xy directions
- !!! The routine does not work with fields that include ghost layers
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: infield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!output field for the result of the fourier transform
- !REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: outfield
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: outfield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(__PREC) :: t0
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_plan',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- !-------------------------------------------------------------------------
- ! Setup parameters for this particular routine
- !-------------------------------------------------------------------------
- !the dimension of the FFT (1D/2D/3D)
- ppmplan%rank=2
- !the number of points along each direction of the piece to be transformed
- ALLOCATE(ppmplan%nx(ppmplan%rank,nsubs))
- !the direction of the transform
- ppmplan%sign=FFTW_BACKWARD
- !the method to setup the optimal plan
- ppmplan%flag=FFTW_MEASURE
- !the number of components to transform - 3 component vector
- ppmplan%howmany=3
- !the size of the input array - full size (assuming LBOUND=1 thus UBOUND)
- ALLOCATE(ppmplan%inembed(ppmplan%rank))
- ppmplan%inembed(1) = UBOUND(infield,2)
- ppmplan%inembed(2) = UBOUND(infield,3)
- !the size of the output array - full size (assuming LBOUND=1 thus UBOUND)
- ALLOCATE(ppmplan%onembed(ppmplan%rank))
- ppmplan%onembed(1) = UBOUND(outfield,2)
- ppmplan%onembed(2) = UBOUND(outfield,3)
- !istride tells how the same componenet data points are spaced in memory
- !e.g. for 2/3 component vector istride = 2/3 or for scalar istride = 1
- ppmplan%istride = 3
- ppmplan%ostride = 3
- !idist tells how multiple arrays are spaced in memory. I.e. a memory
- !offset. e.g. vector components (idist=1) or scalar 2D arrays
- !in 3D array(idist=NxNy)
- ppmplan%idist = 1
- ppmplan%odist = 1
- !-------------------------------------------------------------------------
- ! Allocate plan array
- !-------------------------------------------------------------------------
- IF(ASSOCIATED(ppmplan%plan)) THEN
- DEALLOCATE(ppmplan%plan,stat=info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to deallocate plan-array.',isub)
- GOTO 9999
- ENDIF
- END IF
- ALLOCATE(ppmplan%plan(nsubs))
-
- DO isub=1,nsubs
- isubl=isublist(isub)
- !@ maybe the -1 needs to be removed when doing cell data
- !the number of points in each direction of the piece to be transformed
- !we subtract the -1 to avoid the periodic vertex point
- IF (topology%bcdef(1) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- ppmplan%nx(1,isub) = mesh%nm(1)-1
- ppmplan%nx(2,isub) = mesh%nm(2)-1
- ELSE
- ppmplan%nx(1,isub) = mesh%nm(1)
- ppmplan%nx(2,isub) = mesh%nm(2)
- ENDIF
-
- CALL dfftw_plan_many_dft_c2r(ppmplan%plan(isub),ppmplan%rank,&
- & ppmplan%nx,ppmplan%howmany,infield(1,1,1,1,isub),ppmplan%inembed(1),&
- & ppmplan%istride,ppmplan%idist,outfield(1,1,1,1,isub),&
- & ppmplan%onembed(1),ppmplan%ostride,ppmplan%odist,ppmplan%flag)
- END DO
-
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_plan',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/fft/ppm_fft_plan_3d_vec_fc2c_z.f b/src/fft/ppm_fft_plan_3d_vec_fc2c_z.f
deleted file mode 100644
index f27904387c9b1f2982745adcf8eea31e08319a86..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_plan_3d_vec_fc2c_z.f
+++ /dev/null
@@ -1,151 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_plan_3d_vec_fc2c_z
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! FFTW plan wrapper for 3d arrays, 1d complex to complex
- ! (forward) FFT in the xy directions
- ! The routine does not work with fields that include ghost layers
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_plan_3d_vec_fc2c_z_s
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_plan_3d_vec_fc2c_z_d
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,outfield,info)
- !!! FFTW plan wrapper for 3d arrays, 1d complex to complex
- !!! (forward) FFT in the xy directions
- !!! The routine does not work with fields that include ghost layers
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: infield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!output field for the result of the fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: outfield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: outfield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(__PREC) :: t0
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_plan',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- !-------------------------------------------------------------------------
- ! Setup parameters for this particular routine
- !-------------------------------------------------------------------------
- !the dimension of the FFT (1D/2D/3D)
- ppmplan%rank=1
- !the number of points along each direction of the piece to be transformed
- ALLOCATE(ppmplan%nx(ppmplan%rank,nsubs))
- !the direction of the transform
- ppmplan%sign=FFTW_FORWARD
- !the method to setup the optimal plan
- ppmplan%flag=FFTW_MEASURE
- !the number of components to transform - 3 component vector
- ppmplan%howmany=3
- !the size of the input array - full size (assuming LBOUND=1 thus UBOUND)
- ALLOCATE(ppmplan%inembed(ppmplan%rank))
- ppmplan%inembed(1) = UBOUND(infield,4)
- !the size of the output array - full size (assuming LBOUND=1 thus UBOUND)
- ALLOCATE(ppmplan%onembed(ppmplan%rank))
- ppmplan%onembed(1) = UBOUND(outfield,4)
- !istride tells how the same componenet data points are spaced in memory
- !e.g. for 2/3 component vector istride = 2/3 or for scalar istride = 1
- ppmplan%istride = UBOUND(infield,2) *UBOUND(infield,3)*3
- ppmplan%ostride = UBOUND(outfield,2)*UBOUND(outfield,3)*3
- !idist tells how multiple arrays are spaced in memory. I.e. a memory
- !offset. e.g. vector components (idist=1) or scalar 2D arrays in
- !3D array(idist=NxNy)
- ppmplan%idist = 1
- ppmplan%odist = 1
-
- !-------------------------------------------------------------------------
- ! Allocate plan array
- !-------------------------------------------------------------------------
- IF(ASSOCIATED(ppmplan%plan)) THEN
- DEALLOCATE(ppmplan%plan,stat=info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to deallocate plan-array.',isub)
- GOTO 9999
- ENDIF
- END IF
- ALLOCATE(ppmplan%plan(nsubs))
-
- DO isub=1,nsubs
- isubl=isublist(isub)
- !@ maybe the -1 needs to be removed when doing cell data
- !we subtract the -1 to avoid the periodic vertex point
- IF (topology%bcdef(3) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- ppmplan%nx(1,isub) = mesh%nm(3)-1
- ELSE
- ppmplan%nx(1,isub) = mesh%nm(3)
- ENDIF
-
- CALL dfftw_plan_many_dft(ppmplan%plan(isub),ppmplan%rank,&
- & ppmplan%nx(:,isub),ppmplan%howmany,infield(1,1,1,1,isub),&
- & ppmplan%inembed(1),ppmplan%istride,ppmplan%idist,&
- & outfield(1,1,1,1,isub),ppmplan%onembed(1),ppmplan%ostride,&
- & ppmplan%odist,ppmplan%sign,ppmplan%flag)
- END DO
-
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_plan',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/fft/ppm_fft_plan_3d_vec_fr2c_xy.f b/src/fft/ppm_fft_plan_3d_vec_fr2c_xy.f
deleted file mode 100644
index cd18504953584a058cf64dbc3cb86a927eb8b3fa..0000000000000000000000000000000000000000
--- a/src/fft/ppm_fft_plan_3d_vec_fr2c_xy.f
+++ /dev/null
@@ -1,155 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fft_plan_3d_vec_fr2c_xy
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! FFTW plan wrapper for 3d arrays, 2d real to complex
- ! (forward) FFT in the xy directions
- ! The routine does not work with fields that include ghost layers
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE
-#define __ROUTINE ppm_fft_plan_3d_vec_fr2c_xy_s
-#define __PREC ppm_kind_single
-#elif __KIND == __DOUBLE
-#define __ROUTINE ppm_fft_plan_3d_vec_fr2c_xy_d
-#define __PREC ppm_kind_double
-#endif
- SUBROUTINE __ROUTINE(topoid,meshid,ppmplan,infield,outfield,info)
- !!! FFTW plan wrapper for 3d arrays, 2d real to complex
- !!! (forward) FFT in the xy directions
- !!! The routine does not work with fields that include ghost layers
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- USE ppm_module_topo_get
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double
-
- IMPLICIT NONE
-
- INCLUDE 'fftw3.f'
-
- ! if debug check if dimensions are 2a 3b 5c 7d 11e 13f
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- !!!topology identifier of target
- INTEGER,INTENT(IN) :: topoid
- !!!id of the mesh
- INTEGER,INTENT(IN) :: meshid
- !!!ppm fft plan type
- TYPE(ppm_fft_plan),INTENT(INOUT) :: ppmplan
- !!!input field to fourier transform
- !REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: infield
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: infield
- !!!output field for the result of the fourier transform
- !COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER,INTENT(INOUT) :: outfield
- COMPLEX(__PREC),DIMENSION(:,:,:,:,:),POINTER :: outfield
- !!!Returns status, 0 upon success
- INTEGER,INTENT(OUT) :: info
- !in time perhaps an argument for alternate directions
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(__PREC) :: t0
- INTEGER :: isub,isubl
- INTEGER :: nsubs
- INTEGER,DIMENSION(:),POINTER :: isublist
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_fft_plan',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- nsubs = topology%nsublist
- ALLOCATE(isublist(nsubs))
- DO isub=1,nsubs
- isublist(isub) = topology%isublist(isub)
- ENDDO
- mesh = topology%mesh(meshid)
-
- !-------------------------------------------------------------------------
- ! Setup parameters for this particular routine
- !-------------------------------------------------------------------------
- !the dimension of the FFT (1D/2D/3D)
- ppmplan%rank=2
- !the number of points along each direction of the piece to be transformed
- ALLOCATE(ppmplan%nx(ppmplan%rank,nsubs))
- !the direction of the transform
- ppmplan%sign=FFTW_FORWARD
- !the method to setup the optimal plan
- ppmplan%flag=FFTW_MEASURE
- !the number of components to transform - 3 component vector
- ppmplan%howmany=3
- !the size of the input array - full size (assuming LBOUND=1 thus UBOUND)
- ALLOCATE(ppmplan%inembed(ppmplan%rank))
- ppmplan%inembed(1) = UBOUND(infield,2)
- ppmplan%inembed(2) = UBOUND(infield,3)
- !the size of the output array - full size (assuming LBOUND=1 thus UBOUND)
- ALLOCATE(ppmplan%onembed(ppmplan%rank))
- ppmplan%onembed(1) = UBOUND(outfield,2)
- ppmplan%onembed(2) = UBOUND(outfield,3)
- !istride tells how the same componenet data points are spaced in memory
- !e.g. for 2/3 component vector istride = 2/3 or for scalar istride = 1
- ppmplan%istride = 3
- ppmplan%ostride = 3
- !idist tells how multiple arrays are spaced in memory. I.e. a memory
- !offset. e.g. vector components (idist=1) or scalar 2D arrays in
- !3D array(idist=NxNy)
- ppmplan%idist = 1
- ppmplan%odist = 1
-
- !-------------------------------------------------------------------------
- ! Allocate plan array
- !-------------------------------------------------------------------------
- IF(ASSOCIATED(ppmplan%plan)) THEN
- DEALLOCATE(ppmplan%plan,stat=info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fft_plan','Failed to deallocate plan-array.',isub)
- GOTO 9999
- ENDIF
- END IF
- ALLOCATE(ppmplan%plan(nsubs))
-
- DO isub=1,nsubs
- isubl=isublist(isub)
- !@ maybe the -1 needs to be removed when doing cell data
- !we subtract the -1 to avoid the periodic vertex point
- IF (topology%bcdef(1) .EQ. ppm_param_bcdef_periodic) THEN !vertex
- ppmplan%nx(1,isub) = mesh%nm(1)-1
- ppmplan%nx(2,isub) = mesh%nm(2)-1
- ELSE
- ppmplan%nx(1,isub) = mesh%nm(1)
- ppmplan%nx(2,isub) = mesh%nm(2)
- ENDIF
-
- CALL dfftw_plan_many_dft_r2c(ppmplan%plan(isub),ppmplan%rank,&
- & ppmplan%nx(:,isub),ppmplan%howmany,infield(1,1,1,1,isub),&
- & ppmplan%inembed(1),ppmplan%istride,ppmplan%idist,&
- & outfield(1,1,1,1,isub),ppmplan%onembed(1),ppmplan%ostride,&
- & ppmplan%odist,ppmplan%flag)
- END DO
-
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fft_plan',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-#undef __ROUTINE
-#undef __PREC
diff --git a/src/mg/ppm_mg_alloc_bc.f b/src/mg/ppm_mg_alloc_bc.f
deleted file mode 100644
index 1a601fae79d5997f60085c5568cd064667ffaff1..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_alloc_bc.f
+++ /dev/null
@@ -1,396 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_mg_alloc_bc
- !-------------------------------------------------------------------------
- !
- ! Purpose : Does the (re)allocation of arrays of type
- ! bc_value. It offers the same allocation
- ! types as ppm_alloc for regular arrays.
- !
- ! Input : lda(:) (I) number of subdomains +
- ! numbers of levels
- ! iopt (I) alloc action. One of:
- ! ppm_param_alloc_fit_preserve
- ! ppm_param_alloc_fit
- ! ppm_param_alloc_grow_preserve
- ! ppm_param_alloc_grow
- ! ppm_param_dealloc
- !
- ! Input/output : field (T) array of TYPE(bc_value)
- ! which is to be (re)allocated.
- !
- ! Output : info (I) Return status. 0 if everything OK.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_mg_alloc_bc.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.7 2004/10/01 16:33:38 ivos
- ! cosmetics.
- !
- ! Revision 1.6 2004/10/01 16:09:10 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.5 2004/09/22 18:25:08 kotsalie
- ! MG new version
- !
- ! Revision 1.4 2004/07/26 13:49:18 ivos
- ! Removed Routines sections from the header comment.
- !
- ! Revision 1.3 2004/07/26 11:59:39 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.2 2004/07/26 07:46:37 ivos
- ! Changed to use single-interface modules. Updated all USE statements.
- !
- ! Revision 1.1 2004/06/29 14:43:14 kotsalie
- ! Needed for my type allocation
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_alloc_bc_2d_sca_s(field,lda,iopt,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_alloc_bc_2d_sca_d(field,lda,iopt,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_alloc_bc_3d_sca_s(field,lda,iopt,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_alloc_bc_3d_sca_d(field,lda,iopt,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_alloc_bc_2d_vec_s(field,lda,iopt,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_alloc_bc_2d_vec_d(field,lda,iopt,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_alloc_bc_3d_vec_s(field,lda,iopt,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_alloc_bc_3d_vec_d(field,lda,iopt,info)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Module
- !-------------------------------------------------------------------------
- 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_write
-
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(bc_value_2d_sca_s), DIMENSION(:), POINTER :: field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(bc_value_2d_sca_d), DIMENSION(:), POINTER :: field
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(bc_value_3d_sca_s), DIMENSION(:), POINTER :: field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(bc_value_3d_sca_d), DIMENSION(:), POINTER :: field
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(bc_value_2d_vec_s), DIMENSION(:), POINTER :: field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(bc_value_2d_vec_d), DIMENSION(:), POINTER :: field
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(bc_value_3d_vec_s), DIMENSION(:), POINTER :: field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(bc_value_3d_vec_d), DIMENSION(:), POINTER :: field
-#endif
-#endif
-#endif
- INTEGER, DIMENSION(: ), INTENT(IN ) :: lda
- INTEGER, INTENT(IN ) :: iopt
- INTEGER, INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i
- INTEGER, DIMENSION(1) :: ldc
- REAL(MK) :: t0
- LOGICAL :: lcopy,lalloc,lrealloc,ldealloc
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(bc_value_2d_sca_s), DIMENSION(:), POINTER :: work_field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(bc_value_2d_sca_d), DIMENSION(:), POINTER :: work_field
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(bc_value_3d_sca_s), DIMENSION(:), POINTER :: work_field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(bc_value_3d_sca_d), DIMENSION(:), POINTER :: work_field
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(bc_value_2d_vec_s), DIMENSION(:), POINTER :: work_field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(bc_value_2d_vec_d), DIMENSION(:), POINTER :: work_field
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(bc_value_3d_vec_s), DIMENSION(:), POINTER :: work_field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(bc_value_3d_vec_d), DIMENSION(:), POINTER :: work_field
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_mg_alloc_bc',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0 .AND. iopt .NE. ppm_param_dealloc) THEN
- IF (SIZE(lda,1) .LT. 1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_alloc_field', &
- & 'lda must be at least of length 1',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(1) .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_alloc_field', &
- & 'lda(1) must be >= 0',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Check allocation type
- !-------------------------------------------------------------------------
- lcopy = .FALSE.
- lalloc = .FALSE.
- lrealloc = .FALSE.
- ldealloc = .FALSE.
- IF (iopt .EQ. ppm_param_alloc_fit_preserve) THEN
- !---------------------------------------------------------------------
- ! Fit memory and preserve the present contents
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- IF (ldc(1) .NE. lda(1)) THEN
- lalloc = .TRUE.
- lrealloc = .TRUE.
- lcopy = .TRUE.
- ENDIF
- ELSE
- lalloc = .TRUE.
- ENDIF
- ELSEIF (iopt .EQ. ppm_param_alloc_fit) THEN
- !---------------------------------------------------------------------
- ! Fit memory and discard the present contents
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- IF (ldc(1) .NE. lda(1)) THEN
- lalloc = .TRUE.
- lrealloc = .TRUE.
- ldealloc = .TRUE.
- ENDIF
- ELSE
- lalloc = .TRUE.
- ENDIF
- ELSEIF (iopt .EQ. ppm_param_alloc_grow_preserve) THEN
- !---------------------------------------------------------------------
- ! Fit memory and preserve the present contents
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- IF (ldc(1) .LT. lda(1)) THEN
- lalloc = .TRUE.
- lrealloc = .TRUE.
- lcopy = .TRUE.
- ENDIF
- ELSE
- lalloc = .TRUE.
- ENDIF
- ELSEIF (iopt .EQ. ppm_param_alloc_grow) THEN
- !---------------------------------------------------------------------
- ! Fit memory and discard the present contents
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- IF (ldc(1) .LT. lda(1)) THEN
- lalloc = .TRUE.
- lrealloc = .TRUE.
- ldealloc = .TRUE.
- ENDIF
- ELSE
- lalloc = .TRUE.
- ENDIF
- ELSEIF (iopt .EQ. ppm_param_dealloc) THEN
- !---------------------------------------------------------------------
- ! Deallocate
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- lrealloc = .TRUE.
- ldealloc = .TRUE.
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Perform the actual alloc action
- !-------------------------------------------------------------------------
- IF (lalloc) THEN
- !---------------------------------------------------------------------
- ! Allocate new array with new size and nullify all members
- !---------------------------------------------------------------------
- ALLOCATE(work_field(lda(1)),STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_alloc_field', &
- & 'new mgfield WORK_MESH',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i=1,lda(1)
- NULLIFY(work_field(i)%pbcvalue)
- ENDDO
- ENDIF
- IF (lcopy) THEN
- !---------------------------------------------------------------------
- ! Save the old contents
- !---------------------------------------------------------------------
- DO i=1,MIN(ldc(1),lda(1))
- work_field(i)%pbcvalue => field(i)%pbcvalue
- ENDDO
- ENDIF
- IF (ldealloc) THEN
- !---------------------------------------------------------------------
- ! Deallocate the old contents
- !---------------------------------------------------------------------
- DO i=1,ldc(1)
- IF (ASSOCIATED(field(i)%pbcvalue)) THEN
- DEALLOCATE(field(i)%pbcvalue,STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_bc',&
- & 'field correction FIELD%PBCVALUE',__LINE__,info)
- ENDIF
- NULLIFY(field(i)%pbcvalue)
- ENDIF
- ENDDO
- ENDIF
- IF (lrealloc) THEN
- !---------------------------------------------------------------------
- ! Deallocate old pointer array
- !---------------------------------------------------------------------
- DEALLOCATE(field,STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_bc', &
- & 'mgfield data FIELD',__LINE__,info)
- ENDIF
- NULLIFY(field)
- ENDIF
- IF (lalloc) THEN
- !---------------------------------------------------------------------
- ! Point result to new array
- !---------------------------------------------------------------------
- field => work_field
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_mg_alloc_bc',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_bc_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_bc_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_bc_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_bc_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_bc_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_bc_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_bc_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_bc_3d_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_alloc_field.f b/src/mg/ppm_mg_alloc_field.f
deleted file mode 100644
index fda4b232301189cbc93606d1402c9e2dbac41944..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_alloc_field.f
+++ /dev/null
@@ -1,428 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_mg_alloc_field
- !-------------------------------------------------------------------------
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
- !
- ! Purpose : Does the (re)allocation of arrays of type
- ! mg_field. It offers the same allocation
- ! types as ppm_alloc for regular arrays.
- !
- ! Input : lda(:) (I) number of subdomains +
- ! numbers of levels
- ! iopt (I) alloc action. One of:
- ! ppm_param_alloc_fit_preserve
- ! ppm_param_alloc_fit
- ! ppm_param_alloc_grow_preserve
- ! ppm_param_alloc_grow
- ! ppm_param_dealloc
- !
- ! Input/output : field (T) array of TYPE(mg_field)
- ! which is to be (re)allocated.
- !
- ! Output : info (I) Return status. 0 if everything OK.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !
- !
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_alloc_field_2d_sca_s(field,lda,iopt,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_alloc_field_2d_sca_d(field,lda,iopt,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_alloc_field_3d_sca_s(field,lda,iopt,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_alloc_field_3d_sca_d(field,lda,iopt,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_alloc_field_2d_vec_s(field,lda,iopt,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_alloc_field_2d_vec_d(field,lda,iopt,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_alloc_field_3d_vec_s(field,lda,iopt,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_alloc_field_3d_vec_d(field,lda,iopt,info)
-#endif
-#endif
-#endif
-
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Module
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_write
-
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER , DIMENSION(: ), INTENT(IN ) :: lda
- INTEGER , INTENT(IN ) :: iopt
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s), DIMENSION(:,:), POINTER :: field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d), DIMENSION(:,:), POINTER :: field
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(mg_field_3d_sca_s), DIMENSION(:,:), POINTER :: field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d),DIMENSION(:,:), POINTER :: field
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s), DIMENSION(:,:), POINTER :: field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d), DIMENSION(:,:), POINTER :: field
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s), DIMENSION(:,:), POINTER :: field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:), POINTER :: field
-#endif
-#endif
-#endif
-
-
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,j
- INTEGER, DIMENSION(2) :: ldc
- REAL(MK) :: t0
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s), DIMENSION(:,:), POINTER :: work_field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d), DIMENSION(:,:), POINTER :: work_field
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(mg_field_3d_sca_s), DIMENSION(:,:), POINTER :: work_field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d), DIMENSION(:,:), POINTER :: work_field
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s), DIMENSION(:,:), POINTER :: work_field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d), DIMENSION(:,:), POINTER :: work_field
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND ==__SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s), DIMENSION(:,:), POINTER :: work_field
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d), DIMENSION(:,:), POINTER :: work_field
-#endif
-#endif
-#endif
-
- LOGICAL :: lcopy,lalloc,lrealloc,ldealloc
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_mg_alloc_field',t0,info)
-
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0 .AND. iopt .NE. ppm_param_dealloc) THEN
- IF (SIZE(lda,1) .LT. 2) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_alloc_field', &
- & 'lda must be at least of length 2',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(1) .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_alloc_field', &
- & 'lda(1) must be >= 0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(2) .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_alloc_field', &
- & 'lda(2) must be >= 0',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Check allocation type
- !-------------------------------------------------------------------------
- lcopy = .FALSE.
- lalloc = .FALSE.
- lrealloc = .FALSE.
- ldealloc = .FALSE.
- IF (iopt .EQ. ppm_param_alloc_fit_preserve) THEN
- !---------------------------------------------------------------------
- ! Fit memory and preserve the present contents
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- ldc(2) = SIZE(field,2)
- IF ((ldc(1) .NE. lda(1)) .OR. (ldc(2) .NE. lda(2))) THEN
- lalloc = .TRUE.
- lrealloc = .TRUE.
- lcopy = .TRUE.
- ENDIF
- ELSE
- lalloc = .TRUE.
- ENDIF
- ELSEIF (iopt .EQ. ppm_param_alloc_fit) THEN
- !---------------------------------------------------------------------
- ! Fit memory and discard the present contents
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- ldc(2) = SIZE(field,2)
- IF ((ldc(1) .NE. lda(1)) .OR. (ldc(2) .NE. lda(2))) THEN
- lalloc = .TRUE.
- lrealloc = .TRUE.
- ldealloc = .TRUE.
- ENDIF
- ELSE
- lalloc = .TRUE.
- ENDIF
- ELSEIF (iopt .EQ. ppm_param_alloc_grow_preserve) THEN
- !---------------------------------------------------------------------
- ! Fit memory and preserve the present contents
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- ldc(2) = SIZE(field,2)
- IF ((ldc(1) .LT. lda(1)) .OR. (ldc(2) .LT. lda(2))) THEN
- lalloc = .TRUE.
- lrealloc = .TRUE.
- lcopy = .TRUE.
- ENDIF
- ELSE
- lalloc = .TRUE.
- ENDIF
- ELSEIF (iopt .EQ. ppm_param_alloc_grow) THEN
- !---------------------------------------------------------------------
- ! Fit memory and discard the present contents
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- ldc(2) = SIZE(field,2)
- IF ((ldc(1) .LT. lda(1)) .OR. (ldc(2) .LT. lda(2))) THEN
- lalloc = .TRUE.
- lrealloc = .TRUE.
- ldealloc = .TRUE.
- ENDIF
- ELSE
- lalloc = .TRUE.
- ENDIF
- ELSEIF (iopt .EQ. ppm_param_dealloc) THEN
- !---------------------------------------------------------------------
- ! Deallocate
- !---------------------------------------------------------------------
- IF (ASSOCIATED(field)) THEN
- ldc(1) = SIZE(field,1)
- ldc(2) = SIZE(field,2)
- lrealloc = .TRUE.
- ldealloc = .TRUE.
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Perform the actual alloc action
- !-------------------------------------------------------------------------
- IF (lalloc) THEN
- !---------------------------------------------------------------------
- ! Allocate new array with new size and nullify all members
- !---------------------------------------------------------------------
- ALLOCATE(work_field(lda(1),lda(2)),STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_alloc_field', &
- & 'new mgfield WORK_MESH',__LINE__,info)
- GOTO 9999
- ENDIF
- DO j=1,lda(2)
- DO i=1,lda(1)
- NULLIFY(work_field(i,j)%uc)
- NULLIFY(work_field(i,j)%fc)
- NULLIFY(work_field(i,j)%err)
- NULLIFY(work_field(i,j)%bcvalue)
- ENDDO
- ENDDO
- ENDIF
-
- IF (lcopy) THEN
- !---------------------------------------------------------------------
- ! Save the old contents
- !---------------------------------------------------------------------
- DO j=1,MIN(ldc(2),lda(2))
- DO i=1,MIN(ldc(1),lda(1))
- 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)%bcvalue => field(i,j)%bcvalue
- ENDDO
- ENDDO
- ENDIF
- IF (ldealloc) THEN
- !---------------------------------------------------------------------
- ! Deallocate the old contents
- !---------------------------------------------------------------------
- DO j=1,ldc(2)
- DO i=1,ldc(1)
- IF (ASSOCIATED(field(i,j)%uc)) THEN
- DEALLOCATE(field(i,j)%uc,STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_field',&
- & 'field correction FIELD%UC',__LINE__,info)
- ENDIF
- NULLIFY(field(i,j)%uc)
- ENDIF
- IF (ASSOCIATED(field(i,j)%fc)) THEN
- DEALLOCATE(field(i,j)%fc,STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_field',&
- & 'error restriction FIELD%FC',__LINE__,info)
- ENDIF
- NULLIFY(field(i,j)%fc)
- ENDIF
- IF (ASSOCIATED(field(i,j)%err)) THEN
- DEALLOCATE(field(i,j)%err,STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_field',&
- & 'residual FIELD%ERR',__LINE__,info)
- ENDIF
- NULLIFY(field(i,j)%err)
- ENDIF
- IF (ASSOCIATED(field(i,j)%bcvalue)) THEN
- DEALLOCATE(field(i,j)%bcvalue,STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_field',&
- & 'boundary values FIELD%BCVALUE',__LINE__,info)
- ENDIF
- NULLIFY(field(i,j)%bcvalue)
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-
- IF (lrealloc) THEN
- !---------------------------------------------------------------------
- ! Deallocate old pointer array
- !---------------------------------------------------------------------
- DEALLOCATE(field,STAT=info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_mg_alloc_field', &
- & 'mgfield data FIELD',__LINE__,info)
- ENDIF
- NULLIFY(field)
- ENDIF
-
- IF (lalloc) THEN
- !---------------------------------------------------------------------
- ! Point result to new array
- !---------------------------------------------------------------------
- field => work_field
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_mg_alloc_field',t0,info)
- RETURN
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_field_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_field_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_field_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_field_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_field_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_field_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_field_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_alloc_field_3d_vec_d
-#endif
-#endif
-#endif
-
-
diff --git a/src/mg/ppm_mg_core.f b/src/mg/ppm_mg_core.f
deleted file mode 100644
index 072d6d3b909474240103c25ec0131bf4df0fc3e7..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_core.f
+++ /dev/null
@@ -1,592 +0,0 @@
- !-----------------------------------------------------------------------
- ! Subroutine : ppm_mg_core
- !-----------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- RECURSIVE SUBROUTINE ppm_mg_core_2d_sca_s(topo_id,mlev,iter1,iter2,info)
-#elif __KIND == __DOUBLE_PRECISION
- RECURSIVE SUBROUTINE ppm_mg_core_2d_sca_d(topo_id,mlev,iter1,iter2,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- RECURSIVE SUBROUTINE ppm_mg_core_3d_sca_s(topo_id,mlev,iter1,iter2,info)
-#elif __KIND == __DOUBLE_PRECISION
- RECURSIVE SUBROUTINE ppm_mg_core_3d_sca_d(topo_id,mlev,iter1,iter2,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- RECURSIVE SUBROUTINE ppm_mg_core_2d_vec_s(topo_id,mlev,iter1,iter2,info)
-#elif __KIND == __DOUBLE_PRECISION
- RECURSIVE SUBROUTINE ppm_mg_core_2d_vec_d(topo_id,mlev,iter1,iter2,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- RECURSIVE SUBROUTINE ppm_mg_core_3d_vec_s(topo_id,mlev,iter1,iter2,info)
-#elif __KIND == __DOUBLE_PRECISION
- RECURSIVE SUBROUTINE ppm_mg_core_3d_vec_d(topo_id,mlev,iter1,iter2,info)
-#endif
-#endif
-#endif
- !-----------------------------------------------------------------------
- ! Includes
- !-----------------------------------------------------------------------
-#include "ppm_define.h"
- !-----------------------------------------------------------------------
- ! Modules
- !-----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_mg_prolong
- USE ppm_module_mg_restrict
- USE ppm_module_mg_smooth
- USE ppm_module_mg_res
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_write
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !----------------------------------------------------------------------
- ! Arguments
- !----------------------------------------------------------------------
- INTEGER, INTENT(IN ) :: topo_id
- INTEGER, INTENT(IN ) :: mlev
- INTEGER, INTENT(IN ) :: iter1
- INTEGER, INTENT(IN ) :: iter2
- INTEGER, INTENT(INOUT) :: info
- !----------------------------------------------------------------------
- ! Local variables
- !----------------------------------------------------------------------
- REAL(MK) :: t0
- REAL(MK) :: scale1,scale2
- REAL(MK) :: E,res
- INTEGER :: isub,i,j
- INTEGER :: ilda
- CHARACTER(LEN=256) :: cbuf
- REAL(MK) :: c1,c2,c3,c4
- INTEGER :: ncalls=0
- REAL(MK) :: rdx2,rdy2
- REAL(MK) :: dxl,dyl
- REAL(MK) :: dx,dy
-#if __MESH_DIM == __3D
- REAL(MK) :: c5,dzl,scale3
- REAL(MK) :: dz,rdz2
- INTEGER :: k
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
-#endif
-#endif
-#endif
- !-----------------------------------------------------------------------
- !Externals
- !-----------------------------------------------------------------------
-
- !-----------------------------------------------------------------------
- !Initialize
- !-----------------------------------------------------------------------
- CALL substart('ppm_mg_core',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_core', &
- & 'level must be >1',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-----------------------------------------------------------------------
- !Definition of necessary variables and allocation of arrays
- !-----------------------------------------------------------------------
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
-#if __DIM == __SFIELD
- mgfield=>mgfield_2d_sca_s
-#elif __DIM == __VFIELD
- mgfield=>mgfield_2d_vec_s
-#endif
- rdx2=rdx2_s
- rdy2=rdy2_s
- dx = dx_s
- dy = dy_s
-#elif __KIND == __DOUBLE_PRECISION
-#if __DIM == __SFIELD
- mgfield=>mgfield_2d_sca_d
-#elif __DIM == __VFIELD
- mgfield=>mgfield_2d_vec_d
-#endif
- rdx2=rdx2_d
- rdy2=rdy2_d
- dx = dx_d
- dy = dy_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
-#if __DIM == __SFIELD
- mgfield=>mgfield_3d_sca_s
-#elif __DIM == __VFIELD
- mgfield=>mgfield_3d_vec_s
-#endif
- rdx2=rdx2_s
- rdy2=rdy2_s
- rdz2=rdz2_s
- dx = dx_s
- dy = dy_s
- dz = dz_s
-#elif __KIND == __DOUBLE_PRECISION
-#if __DIM == __SFIELD
- mgfield=>mgfield_3d_sca_d
-#elif __DIM == __VFIELD
- mgfield=>mgfield_3d_vec_d
-#endif
- rdx2=rdx2_d
- rdy2=rdy2_d
- rdz2=rdz2_d
- dx = dx_d
- dy = dy_d
- dz = dz_d
-#endif
-#endif
- !-------------------------------------------------------------------
- ! restrict the solution from the previous fine grid to the current
- ! coarser grid
- !------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_restrict_2d_sca_s(topo_id,mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_restrict_2d_sca_d(topo_id,mlev,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_restrict_3d_sca_s(topo_id,mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_restrict_3d_sca_d(topo_id,mlev,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_restrict_2d_vec_s(topo_id,mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_restrict_2d_vec_d(topo_id,mlev,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_restrict_3d_vec_s(topo_id,mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_restrict_3d_vec_d(topo_id,mlev,info)
-#endif
-#endif
-#endif
- !------------------------------------------------------------------
- !Initiation
- !------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- scale1=REAL((factor(1)*factor(1))**(mlev-1),MK)
- scale2=REAL((factor(2)*factor(2))**(mlev-1),MK)
- c2 = rdx2/scale1
- c3 = rdy2/scale2
- c1 = 1.0_MK/(2.0_MK*(c2+c3))
- c4 = 1.0_MK/c1
- dxl = dx*SQRT(scale1)
- dyl = dy*SQRT(scale2)
- !--------------------------------------------------------------------
- !Compute correction using gauss-seidel algorithm
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_sca(topo_id,iter1,mlev,c1,c2,c3,info)
- !-------------------------------------------------------------------
- !Compute residual
- !-------------------------------------------------------------------
- CALL ppm_mg_res_sca(topo_id,mlev,c1,c2,c3,c4,E,info)
- !--------------------------------------------------------------------
- !Go to the next (coarser) multigrid level if the solution is
- !not converged
- !--------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
- WRITE(cbuf,*) 'E:',E
- CALL PPM_WRITE(ppm_rank,'mg_core',cbuf,info)
- ENDIF
- IF (mlev.LT.maxlev) THEN
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_core_2d_sca_s(topo_id,mlev+1,iter1,iter2,info)
- IF (w_cycle) THEN
- CALL ppm_mg_prolong_2d_sca_s(mlev,info)
- CALL ppm_mg_smooth_sca(topo_id,iter2,mlev,c1,&
- & c2,c3,info)
- CALL ppm_mg_res_sca(topo_id,mlev,c1,c2,c3,c4,&
- & E,info)
- CALL ppm_mg_core_2d_sca_s(topo_id,mlev+1,iter1,iter2,info)
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_core_2d_sca_d(topo_id,mlev+1,iter1,iter2,info)
- IF (w_cycle) THEN
- CALL ppm_mg_prolong_2d_sca_d(mlev,info)
- CALL ppm_mg_smooth_sca(topo_id,iter2,mlev,c1,&
- & c2,c3,info)
- CALL ppm_mg_res_sca(topo_id,mlev,c1,c2,c3,c4,&
- & E,info)
- CALL ppm_mg_core_2d_sca_d(topo_id,mlev+1,iter1,iter2,info)
- ENDIF
-#endif
- ELSE
- GOTO 9999
- ENDIF
- !---------------------------------------------------------------------
- !else GO BACK TO A FINER LEVEL AND CONTINUE RECUSRSIVELY TO
- !THE NEXT FINER LEVELS
- !---------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_prolong_2d_sca_s(mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_prolong_2d_sca_d(mlev,info)
-#endif
- scale1=REAL((factor(1)*factor(1))**(mlev-1),MK)
- scale2=REAL((factor(2)*factor(2))**(mlev-1),MK)
- c2 = rdx2/scale1
- c3 = rdy2/scale2
- c1 = 1.0_MK/(2.0_MK*(c2+c3))
- dxl = dx*SQRT(scale1)
- dyl = dy*SQRT(scale2)
- !--------------------------------------------------------------------
- !Solve for the prolongated corrections
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_sca(topo_id,iter2,mlev,c1,c2,c3,&
- & info)
- !--------------------------------------------------------------------
- !Return
- !--------------------------------------------------------------------
-#elif __MESH_DIM == __3D
- scale1=REAL((factor(1)*factor(1))**(mlev-1),MK)
- scale2=REAL((factor(2)*factor(2))**(mlev-1),MK)
- scale3=REAL((factor(3)*factor(3))**(mlev-1),MK)
- c2 = rdx2/scale1
- c3 = rdy2/scale2
- c4 = rdz2/scale3
- c1 = 1.0_MK/(2.0_MK*(c2+c3+c4))
- c5 = 1.0_MK/c1
- dxl = dx*SQRT(scale1)
- dyl = dy*SQRT(scale2)
- dzl = dz*SQRT(scale3)
- !--------------------------------------------------------------------
- !Compute correction using gauss-seidel algorithm
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_sca(topo_id,iter1,mlev,c1,c2,c3,&
- & c4,info)
- !-------------------------------------------------------------------
- !Compute residual
- !-------------------------------------------------------------------
- CALL ppm_mg_res_sca(topo_id,mlev,c1,c2,c3,c4,c5,E,&
- & info)
- !--------------------------------------------------------------------
- !Go to the next (coarser) multigrid level if the solution is
- !not converged
- !--------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
- WRITE(cbuf,*) 'E:',E
- CALL PPM_WRITE(ppm_rank,'mg_core',cbuf,info)
- ENDIF
- IF (mlev.LT.maxlev) THEN
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_core_3d_sca_s(topo_id,mlev+1,iter1,iter2,info)
- IF (w_cycle) THEN
- CALL ppm_mg_prolong_3d_sca_s(mlev,info)
- CALL ppm_mg_smooth_sca(topo_id,iter2,mlev,c1,&
- & c2,c3,c4,info)
- CALL ppm_mg_res_sca(topo_id,mlev,c1,c2,c3,c4,&
- & c5,E,info)
- CALL ppm_mg_core_3d_sca_s(topo_id,mlev+1,iter1,iter2,info)
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_core_3d_sca_d(topo_id,mlev+1,iter1,iter2,info)
- IF (w_cycle) THEN
- CALL ppm_mg_prolong_3d_sca_d(mlev,info)
- CALL ppm_mg_smooth_sca(topo_id,iter2,mlev,c1,&
- & c2,c3,c4,info)
- CALL ppm_mg_res_sca(topo_id,mlev,c1,c2,c3,c4,&
- & c5,E,info)
- CALL ppm_mg_core_3d_sca_d(topo_id,mlev+1,iter1,iter2,info)
- ENDIF
-#endif
- ELSE
- GOTO 9999
- ENDIF
- !---------------------------------------------------------------------
- !ELSE GO BACK TO A FINER LEVEL AND CONTINUE RECUSRSIVELY TO
- !THE NEXT FINER LEVELS
- !---------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_prolong_3d_sca_s(mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_prolong_3d_sca_d(mlev,info)
-#endif
- scale1=REAL((factor(1)*factor(1))**(mlev-1),MK)
- scale2=REAL((factor(2)*factor(2))**(mlev-1),MK)
- scale3=REAL((factor(3)*factor(3))**(mlev-1),MK)
- c2 = rdx2/scale1
- c3 = rdy2/scale2
- c4 = rdz2/scale3
- c1 = 1.0_MK/(2.0_MK*(c2+c3+c4))
- dxl = dx*SQRT(scale1)
- dyl = dy*SQRT(scale2)
- dzl = dz*SQRT(scale3)
- !--------------------------------------------------------------------
- !Solve for the prolongated corrections
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_sca(topo_id,iter2,mlev,c1,c2,c3,&
- & c4,info)
- !--------------------------------------------------------------------
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- scale1=REAL((factor(1)*factor(1))**(mlev-1),MK)
- scale2=REAL((factor(2)*factor(2))**(mlev-1),MK)
- c2 = rdx2/scale1
- c3 = rdy2/scale2
- c1 = 1.0_MK/(2.0_MK*(c2+c3))
- c4 = 1.0_MK/c1
- dxl = dx*SQRT(scale1)
- dyl = dy*SQRT(scale2)
- !--------------------------------------------------------------------
- !Compute correction using gauss-seidel algorithm
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_vec(topo_id,iter1,mlev,c1,c2,c3,&
- & info)
- !-------------------------------------------------------------------
- !Compute residual
- !-------------------------------------------------------------------
- CALL ppm_mg_res_vec(topo_id,mlev,c1,c2,c3,c4,E,info)
- !--------------------------------------------------------------------
- !Go to the next (coarser) multigrid level if the solution is
- !not converged
- !--------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
- WRITE(cbuf,*) 'E:',E
- CALL PPM_WRITE(ppm_rank,'mg_core',cbuf,info)
- ENDIF
- IF (mlev.LT.maxlev) THEN
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_core_2d_vec_s(topo_id,mlev+1,iter1,iter2,info)
- IF (w_cycle) THEN
- CALL ppm_mg_prolong_2d_vec_s(mlev,info)
- CALL ppm_mg_smooth_vec(topo_id,iter2,mlev,c1,&
- & c2,c3,info)
- CALL ppm_mg_res_vec(topo_id,mlev,c1,c2,c3,c4,&
- & E,info)
- CALL ppm_mg_core_2d_vec_s(topo_id,mlev+1,iter1,iter2,info)
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_core_2d_vec_d(topo_id,mlev+1,iter1,iter2,info)
- IF (w_cycle) THEN
- CALL ppm_mg_prolong_2d_vec_d(mlev,info)
- CALL ppm_mg_smooth_vec(topo_id,iter2,mlev,c1,&
- & c2,c3,info)
- CALL ppm_mg_res_vec(topo_id,mlev,c1,c2,c3,c4,&
- & E,info)
- CALL ppm_mg_core_2d_vec_d(topo_id,mlev+1,iter1,iter2,info)
- ENDIF
-#endif
- ELSE
- GOTO 9999
- ENDIF
- !---------------------------------------------------------------------
- !else GO BACK TO A FINER LEVEL AND CONTINUE RECUSRSIVELY TO
- !THE NEXT FINER LEVELS
- !---------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_prolong_2d_vec_s(mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_prolong_2d_vec_d(mlev,info)
-#endif
- scale1=REAL((factor(1)*factor(1))**(mlev-1),MK)
- scale2=REAL((factor(2)*factor(2))**(mlev-1),MK)
- c2 = rdx2/scale1
- c3 = rdy2/scale2
- c1 = 1.0_MK/(2.0_MK*(c2+c3))
- dxl = dx*SQRT(scale1)
- dyl = dy*SQRT(scale2)
- !--------------------------------------------------------------------
- !Solve for the prolongated corrections
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_vec(topo_id,iter2,mlev,c1,c2,&
- & c3,info)
- !--------------------------------------------------------------------
- !Return
- !--------------------------------------------------------------------
-#elif __MESH_DIM == __3D
- scale1=REAL((factor(1)*factor(1))**(mlev-1),MK)
- scale2=REAL((factor(2)*factor(2))**(mlev-1),MK)
- scale3=REAL((factor(3)*factor(3))**(mlev-1),MK)
- c2 = rdx2/scale1
- c3 = rdy2/scale2
- c4 = rdz2/scale3
- c1 = 1.0_MK/(2.0_MK*(c2+c3+c4))
- c5 = 1.0_MK/c1
- dxl = dx*SQRT(scale1)
- dyl = dy*SQRT(scale2)
- dzl = dz*SQRT(scale3)
- !--------------------------------------------------------------------
- !Compute correction using gauss-seidel algorithm
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_vec(topo_id,iter1,mlev,c1,c2,&
- & c3,c4,info)
- !-------------------------------------------------------------------
- !Compute residual
- !-------------------------------------------------------------------
- CALL ppm_mg_res_vec(topo_id,mlev,c1,c2,c3,c4,c5,E,&
- & info)
-
- !--------------------------------------------------------------------
- !Go to the next (coarser) multigrid level if the solution is
- !not converged
- !--------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
- WRITE(cbuf,*) 'E:',E
- CALL PPM_WRITE(ppm_rank,'mg_core',cbuf,info)
- ENDIF
- IF (mlev.LT.maxlev) THEN
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_core_3d_vec_s(topo_id,mlev+1,iter1,iter2,info)
- IF (w_cycle) THEN
- CALL ppm_mg_prolong_3d_vec_s(mlev,info)
- CALL ppm_mg_smooth_vec(topo_id,iter2,mlev,c1,&
- & c2,c3,c4,info)
- CALL ppm_mg_res_vec(topo_id,mlev,c1,c2,c3,c4,&
- & c5,E,info)
- CALL ppm_mg_core_3d_vec_s(topo_id,mlev+1,iter1,iter2,info)
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_core_3d_vec_d(topo_id,mlev+1,iter1,iter2,info)
- IF (w_cycle) THEN
- CALL ppm_mg_prolong_3d_vec_d(mlev,info)
- CALL ppm_mg_smooth_vec(topo_id,iter2,mlev,c1,c2,&
- & c3,c4,info)
- CALL ppm_mg_res_vec(topo_id,mlev,c1,c2,c3,c4,&
- & c5,E,info)
- CALL ppm_mg_core_3d_vec_d(topo_id,mlev+1,iter1,iter2,info)
- ENDIF
-#endif
- ELSE
- GOTO 9999
- ENDIF
- !---------------------------------------------------------------------
- !ELSE GO BACK TO A FINER LEVEL AND CONTINUE RECUSRSIVELY TO
- !THE NEXT FINER LEVELS
- !---------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_prolong_3d_vec_s(mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_prolong_3d_vec_d(mlev,info)
-#endif
- scale1=REAL((factor(1)*factor(1))**(mlev-1),MK)
- scale2=REAL((factor(2)*factor(2))**(mlev-1),MK)
- scale3=REAL((factor(3)*factor(3))**(mlev-1),MK)
- c2 = rdx2/scale1
- c3 = rdy2/scale2
- c4 = rdz2/scale3
- c1 = 1.0_MK/(2.0_MK*(c2+c3+c4))
- dxl = dx*SQRT(scale1)
- dyl = dy*SQRT(scale2)
- dzl = dz*SQRT(scale3)
- !--------------------------------------------------------------------
- !Solve for the prolongated corrections
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_vec(topo_id,iter2,mlev,c1,c2,c3,&
- & c4,info)
- !--------------------------------------------------------------------
-#endif
-#endif
-9999 CONTINUE
- CALL substop('ppm_mg_core',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_core_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_core_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_core_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_core_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_core_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_core_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_core_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_core_3d_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_finalize.f b/src/mg/ppm_mg_finalize.f
deleted file mode 100644
index 1a08667712909ebe0bdfb62ffcf07899da0f883d..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_finalize.f
+++ /dev/null
@@ -1,284 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_mg_finalize
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine deallocates all the arrays
- !
- !
- ! Input :
- !
- ! Input/output :
- !
- ! Output : info (I) 0 on success.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_mg_finalize.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.5 2006/07/21 11:30:55 kotsalie
- ! FRIDAY
- !
- ! Revision 1.3 2004/10/01 16:33:39 ivos
- ! cosmetics.
- !
- ! Revision 1.2 2004/10/01 16:09:11 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.1 2004/09/23 09:56:40 kotsalie
- ! Mg new version
- !
- ! Revision 1.4 2004/07/26 13:49:19 ivos
- ! Removed Routines sections from the header comment.
- !
- ! Revision 1.3 2004/07/26 11:59:40 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.2 2004/07/26 07:42:39 ivos
- ! Changed to single-interface modules and adapted all USE statements.
- !
- ! Revision 1.1 2004/06/29 14:36:49 kotsalie
- ! Commiting multigrid for further use
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_finalize_2d_sca_s(info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_finalize_2d_sca_d(info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_finalize_3d_sca_s(info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_finalize_3d_sca_d(info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_finalize_2d_vec_s(info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_finalize_2d_vec_d(info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_finalize_3d_vec_s(info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_finalize_3d_vec_d(info)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_mg_alloc
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_write
-
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT(INOUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER, DIMENSION(1) :: lda1
- INTEGER, DIMENSION(2) :: lda2
- INTEGER, DIMENSION(3) :: lda3
- INTEGER, DIMENSION(4) :: lda4
- INTEGER, DIMENSION(5) :: lda5
- INTEGER :: iopt,i
- INTEGER :: istat,j
- REAL(MK) :: t0
- CHARACTER(LEN=ppm_char) :: mesg
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_mg_finalize',t0,info)
- lda1(1)=0
- lda2(1:2) = 0
- lda3(1:3) = 0
- lda4(1:4) = 0
- lda5(1:5) = 0
- !-------------------------------------------------------------------------
- !Definition of necessary variables and allocation of arrays
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_vec_d
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Deallocate global arrays (from ppm_module_multigrid)
- !-------------------------------------------------------------------------
- istat = 0
- iopt = ppm_param_dealloc
- CALL ppm_alloc(start,lda3,iopt,info)
- istat=istat+info
- CALL ppm_alloc(lboundary,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(max_node,lda2,iopt,info)
- istat=istat+info
-#if __DIM == __SFIELD
- CALL ppm_alloc(bcdef_sca,lda1,iopt,info)
- istat=istat+info
-#elif __DIM == __VFIELD
- CALL ppm_alloc(bcdef_vec,lda1,iopt,info)
- istat=istat+info
-#endif
- CALL ppm_alloc(ghostsize,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(factor,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(mg_meshid,lda1,iopt,info)
- istat=istat+info
- CALL ppm_mg_alloc(mgfield,lda2,iopt,info)
- istat = istat +info
- IF (istat .NE. 0) THEN
- WRITE(mesg,'(A,I3,A)') 'for ',istat,' mgr arrays.Pble memory leak.'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_mg_finalize',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_mg_finalize',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_finalize_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_finalize_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_finalize_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_finalize_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_finalize_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_finalize_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_finalize_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_finalize_3d_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_init.f b/src/mg/ppm_mg_init.f
deleted file mode 100644
index 7a9d252a5b551f54c8c762d31696df4d67ae48d1..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_init.f
+++ /dev/null
@@ -1,1158 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_mg_init
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_sca_s(topo_id,mesh_id,equation,ighostsize,&
- & smoother,ibcdef,bcvalue,limlev,wcycle,omega,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_sca_d(topo_id,mesh_id,equation,ighostsize,&
- & smoother,ibcdef,bcvalue,limlev,wcycle,omega,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_sca_s(topo_id,mesh_id,equation,ighostsize,&
- & smoother,ibcdef,bcvalue,limlev,wcycle,omega,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_sca_d(topo_id,mesh_id,equation,ighostsize,&
- & smoother,ibcdef,bcvalue,limlev,wcycle,omega,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_vec_s(topo_id,mesh_id,equation,ighostsize,&
- & smoother,lda,ibcdef,bcvalue,limlev,wcycle,omega,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_2d_vec_d(topo_id,mesh_id,equation,ighostsize,&
- & smoother,lda,ibcdef,bcvalue,limlev,wcycle,omega,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_vec_s(topo_id,mesh_id,equation,ighostsize,&
- & smoother,lda,ibcdef,bcvalue,limlev,wcycle,omega,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_init_3d_vec_d(topo_id,mesh_id,equation,ighostsize,&
- & smoother,lda,ibcdef,bcvalue,limlev,wcycle,omega,info)
-#endif
-#endif
-#endif
- !!! This routine initializes the multigrid solver for 2D and 3D
- !!! problems
- !!!
- !!! [NOTE]
- !!! Please pay attention that in order to be able to coarsen the 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 currently programmed for the
- !!! Poisson problem. A future improvement woudl be to use a general
- !!! stencil.
- !----------------------------------------------------------------------
- ! Includes
- !----------------------------------------------------------------------
-#include "ppm_define.h"
- !----------------------------------------------------------------------
- ! Modules
- !----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_mg_alloc
- USE ppm_module_alloc
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_mesh
- 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
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !----------------------------------------------------------------------
- ! Arguments
- !----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: topo_id
- !!! ID of current topology
- INTEGER, INTENT(IN) :: mesh_id
- !!! ID of mesh of data fields
- INTEGER, INTENT(IN) :: equation
- !!! Kind of equation to be solved.
- !!!
- !!! Currently only ppm_param_eq_poisson supported
- INTEGER,DIMENSION(:),INTENT(IN) :: ighostsize
- !!! Ghostlayer size
- INTEGER, INTENT(IN) :: smoother
- !!! Smoother to be used.
- !!!
- !!! Currently only ppm_param_smooth_rbsor supported
-#if __DIM == __VFIELD
- INTEGER, INTENT(IN) :: lda
- !!! Leading dimension
-#endif
-#if __DIM == __SFIELD
- INTEGER,DIMENSION(:) :: ibcdef
- !!! Boundary condition types. Any of
- !!!
- !!! * ppm_param_bcdef_periodic
- !!! * ppm_param_bcdef_dirichlet
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:) :: bcvalue
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:) :: bcvalue
-#endif
- !!! Boundary condition values to be used.
- !!!
- !!! In the case of periodic BC, the content of bcvalue is ignored
- !!! The indeces (and their sizes) are (4. only in 3D):
- !!!
- !!! 1. isub (nsublist)
- !!! 2. dim (2*ppm_dim) (west,east,south,north,bottom,top)
- !!! 3. index1 (maximum extent of field in any direction)
- !!! 4. (index2 (maximum extent of field in any direction))
-#elif __DIM == __VFIELD
- INTEGER,DIMENSION(:,:) :: ibcdef
- !!! Boundary condition types. Any of
- !!!
- !!! * ppm_param_bcdef_periodic
- !!! * ppm_param_bcdef_dirichlet
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:) :: bcvalue
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:) :: bcvalue
-#endif
- !!! Boundary condition values to be used.
- !!!
- !!! In the case of periodic BC, the content of bcvalue is ignored
- !!! The indeces (and their sizes) are (5. only in 3D):
- !!!
- !!! 1. vector index
- !!! 2. isub (nsublist)
- !!! 3. dim (2*ppm_dim) (west,east,south,north,bottom,top)
- !!! 4. index1 (maximum extent of field in any direction)
- !!! 5. (index2 (maximum extent of field in any direction))
-#endif
- INTEGER,INTENT(IN) :: limlev
- !!! Number of levels to coarsen.
- LOGICAL,INTENT(IN) :: wcycle
- !!! TRUE if the user wants W-cycle otherwise FALSE
- REAL(MK),INTENT(IN) :: omega
- !!! relaxation parameter for SOR
- INTEGER, INTENT(OUT) :: info
- !!! return status. 0 upon success.
- !----------------------------------------------------------------------
- ! Local variables
- !----------------------------------------------------------------------
- REAL(MK) :: t0
- REAL(MK) :: lmyeps
- INTEGER :: mlev,isub
- INTEGER :: idom
- INTEGER :: count,ilda,iface
- INTEGER :: i,j,k
- INTEGER :: kk
- TYPE(ppm_t_topo), POINTER :: topo => NULL()
- TYPE(ppm_t_equi_mesh), POINTER :: mesh => NULL()
-#if __MESH_DIM == __2D
- INTEGER :: dir
-#endif
- INTEGER :: iter1,iter2,ix,iy
- INTEGER :: ipoint,jpoint
- INTEGER :: meshid,newmeshid
- 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
-#endif
- INTEGER , DIMENSION(ppm_dim) :: Nml
- REAL(MK), DIMENSION(ppm_dim) :: min_phys,max_phys
- REAL(MK), DIMENSION(:,:), POINTER :: min_sub => NULL()
- REAL(MK), DIMENSION(:,:), POINTER :: max_sub => NULL()
- INTEGER :: iopt,topoid
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:),POINTER :: terr
-#elif __MESH_DIM == __3D
- 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
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: terr
-#endif
-#endif
- !----------------------------------------------------------------------
- ! Externals
- !----------------------------------------------------------------------
-
- !----------------------------------------------------------------------
- ! Initialize
- !----------------------------------------------------------------------
- CALL substart('ppm_mg_init',t0,info)
- !----------------------------------------------------------------------
- ! Check arguments
- !----------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
-#if __DIM == __VFIELD
- IF (lda.LE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_poiss_mg_init', &
- & 'lda must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF
- !----------------------------------------------------------------------
- ! Definition of necessary variables and allocation of arrays
- !----------------------------------------------------------------------
-#if __DIM == __SFIELD
- vecdim = 1
-#elif __DIM == __VFIELD
- vecdim = lda
-#endif
- w_cycle=wcycle
-
- topoid = topo_id
- meshid = mesh_id
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- nsubs = topo%nsublist
-#if __KIND == __SINGLE_PRECISION
- min_phys(:)=topo%min_physs(:)
- max_phys(:)=topo%max_physs(:)
- min_sub => topo%min_subs(:,:)
- max_sub => topo%max_subs(:,:)
- omega_s=omega
- lmyeps=ppm_myepss
-#elif __KIND == __DOUBLE_PRECISION
- min_phys(:)=topo%min_physd(:)
- max_phys(:)=topo%max_physd(:)
- min_sub => topo%min_subd(:,:)
- max_sub => topo%max_subd(:,:)
- omega_d=omega
- lmyeps=ppm_myepsd
-#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
-#if __KIND == __SINGLE_PRECISION
- dx_s = (max_phys(1)-min_phys(1))/REAL((Nml(1)-1),MK)
- dy_s = (max_phys(2)-min_phys(2))/REAL((Nml(2)-1),MK)
- rdx2_s = 1.0_MK/(dx_s*dx_s)
- rdy2_s = 1.0_MK/(dy_s*dy_s)
-#elif __KIND == __DOUBLE_PRECISION
- dx_d = (max_phys(1)-min_phys(1))/REAL((Nml(1)-1),MK)
- dy_d = (max_phys(2)-min_phys(2))/REAL((Nml(2)-1),MK)
-
- 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(2) = mesh%Nm(2)
- Nml(3) = mesh%Nm(3)
- maxlev = INT(log10(Nml(1)*Nml(2)*Nml(3)* &
- & REAL(ppm_nproc,MK))/log10(2.0_MK))
-
- IF (maxlev.GT.limlev) THEN
- maxlev=limlev
- ENDIF
-#if __KIND == __SINGLE_PRECISION
- dx_s = (max_phys(1)-min_phys(1))/REAL((Nml(1)-1),MK)
- dy_s = (max_phys(2)-min_phys(2))/REAL((Nml(2)-1),MK)
- dz_s = (max_phys(3)-min_phys(3))/REAL((Nml(3)-1),MK)
- rdx2_s = 1.0_MK/(dx_s*dx_s)
- rdy2_s = 1.0_MK/(dy_s*dy_s)
- rdz2_s = 1.0_MK/(dz_s*dz_s)
-#elif __KIND == __DOUBLE_PRECISION
- dx_d = (max_phys(1)-min_phys(1))/REAL((Nml(1)-1),MK)
- dy_d = (max_phys(2)-min_phys(2))/REAL((Nml(2)-1),MK)
- dz_d = (max_phys(3)-min_phys(3))/REAL((Nml(3)-1),MK)
- rdx2_d = 1.0_MK/(dx_d*dx_d)
- rdy2_d = 1.0_MK/(dy_d*dy_d)
- rdz2_d = 1.0_MK/(dz_d*dz_d)
-#endif
-#endif
-#if __DIM == __SFIELD
- iopt = ppm_param_alloc_fit
- ldu2(1) = nsubs
- ldu2(2) = 2*ppm_dim
- CALL ppm_alloc(bcdef_sca,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Boundary condiotions',__LINE__,info)
- GOTO 9999
- 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,idom)-min_sub(1,idom))) 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,idom)-min_sub(1,idom))) 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,idom)-min_sub(2,idom))) 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,idom)-min_sub(2,idom))) THEN
- bcdef_sca(isub,4)=ibcdef(4)
- ENDIF
-#if __MESH_DIM == __3D
- !-----------------------------------------------------------------
- ! compare the bottom boundary
- !---------------------------------------------------------------------
- IF (ABS(min_sub(3,idom)-min_phys(3)) .LT. &
- & lmyeps*(max_sub(3,idom)-min_sub(3,idom))) THEN
- bcdef_sca(isub,5)=ibcdef(5)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the top boundary
- !---------------------------------------------------------------------
- IF (ABS(max_sub(3,idom)-max_phys(3)) .LT. &
- & lmyeps*(max_sub(3,idom)-min_sub(3,idom))) THEN
- bcdef_sca(isub,6)=ibcdef(6)
- ENDIF
-#endif
- ENDDO
- lperiodic=.TRUE.
- DO isub=1,nsubs
- DO i=1,2*ppm_dim
- IF (bcdef_sca(isub,i).NE.ppm_param_bcdef_periodic) THEN
- lperiodic=.FALSE.
- EXIT
- ENDIF
- ENDDO
- ENDDO
-#elif __DIM == __VFIELD
- iopt = ppm_param_alloc_fit
- ldu3(1) = vecdim
- ldu3(2) = nsubs
- ldu3(3) = 2*ppm_dim
- CALL ppm_alloc(bcdef_vec,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Boundary condiotions',__LINE__,info)
- GOTO 9999
- ENDIF
- bcdef_vec(:,:,:)=0
- DO isub=1,nsubs
- idom=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,idom)-min_sub(1,idom))) 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,idom)-min_sub(1,idom))) 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,idom)-min_sub(2,idom))) 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,idom)-min_sub(2,idom))) THEN
- bcdef_vec(ilda,isub,4)=ibcdef(ilda,4)
- ENDIF
-#if __MESH_DIM == __3D
- !-----------------------------------------------------------------
- ! compare the bottom boundary
- !---------------------------------------------------------------------
- IF (ABS(min_sub(3,idom)-min_phys(3)) .LT. &
- & lmyeps*(max_sub(3,idom)-min_sub(3,idom))) THEN
- bcdef_vec(ilda,isub,5)=ibcdef(ilda,5)
- ENDIF
- !---------------------------------------------------------------------
- ! compare the top boundary
- !---------------------------------------------------------------------
- IF (ABS(max_sub(3,idom)-max_phys(3)) .LT. &
- & lmyeps*(max_sub(3,idom)-min_sub(3,idom))) 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
- ghostsize=ighostsize
- !----------------------------------------------------------------------
- ! Allocation 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
- factor(:) = 2
- !----------------------------------------------------------------------
- ! IDs for the meshes on the different levels
- !----------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu1(1) = maxlev
- CALL ppm_alloc(mg_meshid,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'mg_meshid',__LINE__,info)
- GOTO 9999
- ENDIF
-
- !----------------------------------------------------------------------
- ! Allocating the start index for the iteration through the mesh points.
- !----------------------------------------------------------------------
- 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
- !----------------------------------------------------------------------
- ! Allocating the stop index for the iteration through the mesh points.
- !----------------------------------------------------------------------
- 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
-
- !----------------------------------------------------------------------
- ! Allocating the multigrid fields used on the different levels
- !----------------------------------------------------------------------
-#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
-#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
-#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
-#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
-#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
-#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
-#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
-#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
-#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
- ldu3(1) = ppm_dim
- ldu3(2) = nsubs
- ldu3(3) = maxlev
- CALL ppm_alloc(istart,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with istart alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- max_node(:,:) = 0
-
- lboundary(:,:) = .FALSE.
- start(:,:,:) = 1
- !----------------------------------------------------------------------
- ! Derive coarser meshes
- !----------------------------------------------------------------------
- DO mlev=1,maxlev
-#if __MESH_DIM == __2D
- !-------------------------------------------------------------------
- ! Go through the subs, define the istopping indices on each mesh,
- ! check and store if it is on the boundary, allocate the
- ! multigrid fields and pass the boundary values.
- !-------------------------------------------------------------------
- DO i=1,nsubs
- idom=topo%isublist(i)
- istop(:,i,mlev)= mesh%nnodes(:,idom)
- istart(:,i,mlev) = mesh%istart(:,isub)
- 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
- !----------------------------------------------------------------
- ! 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
- 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
- ! 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
- 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 !iface
- DO iface=1,2*ppm_dim
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- direc(1)=2
- ELSEIF (iface.EQ.3.OR.iface.EQ.4) then
- direc(1)=1
- ENDIF
- DO ipoint=1,max_node(direc(1),mlev)
- IF (mlev.EQ.1) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint) = &
- & bcvalue(i,iface,ipoint)
- ELSE
- IF(bcdef_sca(i,iface).EQ.ppm_param_bcdef_neumann) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint) = &
- & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(2*ipoint-1)
- ELSE
- ! NO CORRECTIONS FOR THE DIRICHLET
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ipoint)=0.0_MK
- ENDIF
- ENDIF
- ENDDO !ipoint
- 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)
- istart(:,i,mlev) = mesh%istart(:,isub)
- DO j=1,ppm_dim
- IF (max_node(j,mlev).LT.istop(j,i,mlev)) THEN
- max_node(j,mlev)=istop(j,i,mlev)
- ENDIF
- ENDDO
- IF (topo%subs_bc(1,idom).EQ.1) THEN
- lboundary(1,i)=.TRUE.
- ELSEIF (topo%subs_bc(3,idom).EQ.1) THEN
- lboundary(3,i)=.TRUE.
- ELSEIF (topo%subs_bc(2,idom).EQ.1) THEN
- lboundary(2,i)=.TRUE.
- ELSEIF (topo%subs_bc(4,idom).EQ.1) THEN
- lboundary(4,i)=.TRUE.
- ELSEIF (topo%subs_bc(5,idom).EQ.1) THEN
- lboundary(5,i)=.TRUE.
- ELSEIF (topo%subs_bc(6,idom).EQ.1) THEN
- lboundary(6,i)=.TRUE.
- ENDIF
- !----------------------------------------------------------------
- ! Allocate the function correction, the restricted errors and the
- !residuals on each level.
- !----------------------------------------------------------------
-#if __DIM == __SFIELD
- iopt = ppm_param_alloc_fit
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1-ghostsize(3)
- ldu3(1) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu3(2) = mesh%nnodes(2,idom)+ghostsize(2)
- ldu3(3) = mesh%nnodes(3,idom)+ghostsize(3)
- CALL ppm_alloc(mgfield(i,mlev)%uc,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the function corr. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- tuc=>mgfield(i,mlev)%uc
- tuc=0.0_MK
- iopt = ppm_param_alloc_fit
- ldu3(1) = mesh%nnodes(1,idom)
- ldu3(2) = mesh%nnodes(2,idom)
- ldu3(3) = mesh%nnodes(3,idom)
- CALL ppm_alloc(mgfield(i,mlev)%fc,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the restricted err. alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- mgfield(i,mlev)%fc=0.0_MK
- iopt = ppm_param_alloc_fit
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1-ghostsize(3)
- ldu3(1) = mesh%nnodes(1,idom)+ghostsize(1)
- ldu3(2) = mesh%nnodes(2,idom)+ghostsize(2)
- ldu3(3) = mesh%nnodes(3,idom)+ghostsize(3)
- CALL ppm_alloc(mgfield(i,mlev)%err,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the residual alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- terr=>mgfield(i,mlev)%err
- terr=0.0_MK
- !ALLOCATE THE BCVALUE(IT IS A TYPE!!)
- IF (.NOT.lperiodic) THEN
- iopt = ppm_param_alloc_fit
- ldu1(1) = 2*ppm_dim
- CALL ppm_mg_alloc(mgfield(i,mlev)%bcvalue,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_poiss_mg_init', &
- & 'Problem with the BOUNDARY alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- !ALLOCATE THE PBCVALUE
- DO iface=1,2*ppm_dim
- iopt = ppm_param_alloc_fit
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- ldu2(1) = max_node(2,mlev)
- ldu2(2)= max_node(3,mlev)
- ELSEIF (iface.EQ.3.OR. iface.EQ.4) then
- ldu2(1) = max_node(1,mlev)
- ldu2(2)=max_node(3,mlev)
- ELSE
- ldu2(1)=max_node(1,mlev)
- ldu2(2)=max_node(2,mlev)
- ENDIF
- CALL ppm_alloc(mgfield(i,mlev)%bcvalue(iface)%pbcvalue,&
- & ldu2,iopt,info)
- 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
- 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 BOUNDARY alloc.',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDDO
- DO iface=1,2*ppm_dim
- IF (iface.EQ.1.OR.iface.EQ.2) THEN
- direc(1)=2
- direc(2)=3
- ELSEIF (iface.EQ.3.OR.iface.EQ.4) THEN
- direc(1)=1
- direc(2)=3
- ELSE
- direc(1)=1
- direc(2)=2
- ENDIF
- DO ipoint=1,max_node(direc(1),mlev)
- DO jpoint=1,max_node(direc(2),mlev)
- DO ilda=1,vecdim
- IF (mlev.EQ.1) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint) &
- & =bcvalue(ilda,i,iface,ipoint,jpoint)
- ELSE
- IF(bcdef_vec(ilda,i,iface).EQ.ppm_param_bcdef_neumann) THEN
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint)=&
- & mgfield(i,mlev-1)%bcvalue(iface)%pbcvalue(ilda,2*ipoint-1,2*jpoint-1)
- ELSE
- !NO CORRECTIONS FOR THE DIRICHLET
- mgfield(i,mlev)%bcvalue(iface)%pbcvalue(ilda,ipoint,jpoint)=0.0_MK
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF !lperiodic
-#endif
- ENDDO!DO i=1,nsubs
-#endif
- mg_meshid(mlev)=meshid
- newmeshid=-1
- IF (mlev.LT.maxlev) THEN
- CALL ppm_mesh_derive(topoid,meshid,newmeshid,&
- & ppm_param_mesh_coarsen,factor,info)
- meshid = newmeshid
- mesh => topo%mesh(meshid)
- 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_init_3d_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_prolong.f b/src/mg/ppm_mg_prolong.f
deleted file mode 100644
index 8a16c75286c3cf48c78eda867457265a1359cfa0..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_prolong.f
+++ /dev/null
@@ -1,564 +0,0 @@
- !-----------------------------------------------------------------------
- ! Subroutine : ppm_mg_prolong
- !-----------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_prolong_2d_sca_s(mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_prolong_2d_sca_d(mlev,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_prolong_3d_sca_s(mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_prolong_3d_sca_d(mlev,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_prolong_2d_vec_s(mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_prolong_2d_vec_d(mlev,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_prolong_3d_vec_s(mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_prolong_3d_vec_d(mlev,info)
-#endif
-#endif
-#endif
- !!! In this routine we prolong the corrections from coarser to
- !!! finer levels
- !----------------------------------------------------------------------
- ! 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_write
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !----------------------------------------------------------------------
- ! Arguments
- !----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: mlev
- !!! current level in V-cycle
- INTEGER, INTENT(INOUT) :: info
- !----------------------------------------------------------------------
- ! Local variables
- !----------------------------------------------------------------------
- CHARACTER(LEN=256) :: cbuf
- INTEGER :: isub,j,j2,i,i2
- INTEGER,DIMENSION(5) :: ldl5,ldu5
- INTEGER,DIMENSION(4) :: ldl4,ldu4
- INTEGER,DIMENSION(4) :: ldl3,ldu3
- INTEGER :: iopt,topoid
- INTEGER :: aa,bb,cc,dd,ee,gg,iface
-#if __MESH_DIM == __3D
- INTEGER :: k,k2
-#endif
- INTEGER :: mlevp1,ilda
- REAL(MK) :: t0
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:),POINTER :: puc
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:,:),POINTER :: puc
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:,:),POINTER :: puc
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: puc
-#endif
-#endif
- !----------------------------------------------------------------------
- !Externals
- !----------------------------------------------------------------------
-
- !----------------------------------------------------------------------
- !Initialize
- !----------------------------------------------------------------------
- CALL substart('ppm_mg_prolong',t0,info)
- !----------------------------------------------------------------------
- ! Check arguments
- !----------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (mlev.LT.1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_prolong', &
- & 'level must be >0',__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
- mgfield=>mgfield_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_vec_d
-#endif
-#endif
-#endif
- !----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- mlevp1 = mlev + 1
- IF (ppm_debug.GT.0) THEN
- WRITE(cbuf,*) 'WELCOME TO THE PROLONG LEVEL:',mlev
- CALL PPM_WRITE(ppm_rank,'mg_prolong',cbuf,info)
- ENDIF
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- !----------------------------------------------------------------------
- !prolongation using a 9-point operator
- !----------------------------------------------------------------------
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlevp1)%uc
- puc=>mgfield(isub,mlev)%uc
- DO j=1,max_node(2,mlevp1)
- j2=2*j
- DO i=1,max_node(1,mlevp1)
- i2=2*i
- puc(i2-1,j2-1) = &
- & puc(i2-1,j2-1) + &
- & tuc(i,j)
- puc(i2,j2-1) = &
- & puc(i2,j2-1) + &
- & 0.5_MK * (tuc(i,j)+&
- & tuc(i+1,j))
- puc(i2-1,j2) = &
- & puc(i2-1,j2) + &
- & 0.5_MK * ( tuc(i,j) + &
- & tuc(i,j+1))
- puc(i2,j2) = &
- & puc(i2,j2) + &
- & 0.25_MK * ( tuc(i,j)+&
- & tuc(i+1,j) + &
- & tuc(i+1,j+1)+&
- & tuc(i,j+1))
- ENDDO
- ENDDO
- ENDDO
-#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
- !prolongation using a 27-point operator
- !----------------------------------------------------------------------
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlevp1)%uc
- puc=>mgfield(isub,mlev)%uc
- DO k=1,max_node(3,mlevp1)
- k2=2*k
- DO j=1,max_node(2,mlevp1)
- j2=2*j
- DO i=1,max_node(1,mlevp1)
- i2=2*i
- puc(i2-1,j2-1,k2-1) = &
- & puc(i2-1,j2-1,k2-1) + &
- & tuc(i,j,k)
- puc(i2,j2-1,k2-1) = &
- & puc(i2,j2-1,k2-1) + &
- & 0.5_MK * (tuc(i,j,k)+&
- & tuc(i+1,j,k))
- puc(i2-1,j2,k2-1) = &
- & puc(i2-1,j2,k2-1) + &
- & 0.5_MK * ( tuc(i,j,k) + &
- & tuc(i,j+1,k))
- puc(i2,j2,k2-1) = &
- & puc(i2,j2,k2-1) + &
- & 0.25_MK * ( tuc(i,j,k)+&
- & tuc(i+1,j,k) + &
- & tuc(i+1,j+1,k)+&
- & tuc(i,j+1,k))
- puc(i2-1,j2-1,k2) = &
- & puc(i2-1,j2-1,k2) + &
- & 0.5_MK * (tuc(i,j,k)+&
- & tuc(i,j,k+1))
- puc(i2,j2-1,k2) = &
- & puc(i2,j2-1,k2) + &
- & 0.25_MK * ( tuc(i,j,k)+&
- & tuc(i+1,j,k) + &
- & tuc(i+1,j,k+1)+&
- & tuc(i,j,k+1))
- puc(i2-1,j2,k2) = &
- & puc(i2-1,j2,k2) + &
- & 0.25_MK * ( tuc(i,j,k)+&
- & tuc(i,j+1,k) + &
- & tuc(i,j,k+1)+&
- & tuc(i,j+1,k+1))
- puc(i2,j2,k2) = &
- & puc(i2,j2,k2) + &
- & 0.125_MK * (tuc(i,j,k)+&
- & tuc(i+1,j,k) + &
- & tuc(i+1,j+1,k)+&
- & tuc(i,j+1,k)+&
- & tuc(i,j,k+1) + &
- & tuc(i+1,j,k+1)+&
- & tuc(i,j+1,k+1)+&
- & tuc(i+1,j+1,k+1))
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- !----------------------------------------------------------------------
- !prolongation using a 9-point operator
- !----------------------------------------------------------------------
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlevp1)%uc
- puc=>mgfield(isub,mlev)%uc
- DO j=1,max_node(2,mlevp1)
- j2=2*j
- DO i=1,max_node(1,mlevp1)
- i2=2*i
- DO ilda=1,vecdim
- puc(ilda,i2-1,j2-1) = &
- & puc(ilda,i2-1,j2-1) + &
- & tuc(ilda,i,j)
- puc(ilda,i2,j2-1) = &
- & puc(ilda,i2,j2-1) + &
- & 0.5_MK * (tuc(ilda,i,j)+&
- & tuc(ilda,i+1,j))
- puc(ilda,i2-1,j2) = &
- & puc(ilda,i2-1,j2) + &
- & 0.5_MK * ( tuc(ilda,i,j) + &
- & tuc(ilda,i,j+1))
- puc(ilda,i2,j2) = &
- & puc(ilda,i2,j2) + &
- & 0.25_MK * ( tuc(ilda,i,j)+&
- & tuc(ilda,i+1,j) + &
- & tuc(ilda,i+1,j+1)+&
- & tuc(ilda,i,j+1))
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
- !prolongation using a 27-point operator
- !----------------------------------------------------------------------
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlevp1)%uc
- puc=>mgfield(isub,mlev)%uc
- DO k=1,max_node(3,mlevp1)
- k2=2*k
- DO j=1,max_node(2,mlevp1)
- j2=2*j
- DO i=1,max_node(1,mlevp1)
- i2=2*i
-#ifdef __VECTOR
- puc(1,i2-1,j2-1,k2-1) = &
- & puc(1,i2-1,j2-1,k2-1) + &
- & tuc(1,i,j,k)
- puc(1,i2,j2-1,k2-1) = &
- & puc(1,i2,j2-1,k2-1) + &
- & 0.5_MK * (tuc(1,i,j,k)+&
- & tuc(1,i+1,j,k))
- puc(1,i2-1,j2,k2-1) = &
- & puc(1,i2-1,j2,k2-1) + &
- & 0.5_MK * ( tuc(1,i,j,k) + &
- & tuc(1,i,j+1,k))
- puc(1,i2,j2,k2-1) = &
- & puc(1,i2,j2,k2-1) + &
- & 0.25_MK * ( tuc(1,i,j,k)+&
- & tuc(1,i+1,j,k) + &
- & tuc(1,i+1,j+1,k)+&
- & tuc(1,i,j+1,k))
- puc(1,i2-1,j2-1,k2) = &
- & puc(1,i2-1,j2-1,k2) + &
- & 0.5_MK * (tuc(1,i,j,k)+&
- & tuc(1,i,j,k+1))
- puc(1,i2,j2-1,k2) = &
- & puc(1,i2,j2-1,k2) + &
- & 0.25_MK * ( tuc(1,i,j,k)+&
- & tuc(1,i+1,j,k) + &
- & tuc(1,i+1,j,k+1)+&
- & tuc(1,i,j,k+1))
- puc(1,i2-1,j2,k2) = &
- & puc(1,i2-1,j2,k2) + &
- & 0.25_MK * ( tuc(1,i,j,k)+&
- & tuc(1,i,j+1,k) + &
- & tuc(1,i,j,k+1)+&
- & tuc(1,i,j+1,k+1))
- puc(1,i2,j2,k2) = &
- & puc(1,i2,j2,k2) + &
- & 0.125_MK * (tuc(1,i,j,k)+&
- & tuc(1,i+1,j,k) + &
- & tuc(1,i+1,j+1,k)+&
- & tuc(1,i,j+1,k)+&
- & tuc(1,i,j,k+1) + &
- & tuc(1,i+1,j,k+1)+&
- & tuc(1,i,j+1,k+1)+&
- & tuc(1,i+1,j+1,k+1))
- puc(2,i2-1,j2-1,k2-1) = &
- & puc(2,i2-1,j2-1,k2-1) + &
- & tuc(2,i,j,k)
- puc(2,i2,j2-1,k2-1) = &
- & puc(2,i2,j2-1,k2-1) + &
- & 0.5_MK * (tuc(2,i,j,k)+&
- & tuc(2,i+1,j,k))
- puc(2,i2-1,j2,k2-1) = &
- & puc(2,i2-1,j2,k2-1) + &
- & 0.5_MK * ( tuc(2,i,j,k) + &
- & tuc(2,i,j+1,k))
- puc(2,i2,j2,k2-1) = &
- & puc(2,i2,j2,k2-1) + &
- & 0.25_MK * ( tuc(2,i,j,k)+&
- & tuc(2,i+1,j,k) + &
- & tuc(2,i+1,j+1,k)+&
- & tuc(2,i,j+1,k))
- puc(2,i2-1,j2-1,k2) = &
- & puc(2,i2-1,j2-1,k2) + &
- & 0.5_MK * (tuc(2,i,j,k)+&
- & tuc(2,i,j,k+1))
- puc(2,i2,j2-1,k2) = &
- & puc(2,i2,j2-1,k2) + &
- & 0.25_MK * ( tuc(2,i,j,k)+&
- & tuc(2,i+1,j,k) + &
- & tuc(2,i+1,j,k+1)+&
- & tuc(2,i,j,k+1))
- puc(2,i2-1,j2,k2) = &
- & puc(2,i2-1,j2,k2) + &
- & 0.25_MK * ( tuc(2,i,j,k)+&
- & tuc(2,i,j+1,k) + &
- & tuc(2,i,j,k+1)+&
- & tuc(2,i,j+1,k+1))
- puc(2,i2,j2,k2) = &
- & puc(2,i2,j2,k2) + &
- & 0.125_MK * (tuc(2,i,j,k)+&
- & tuc(2,i+1,j,k) + &
- & tuc(2,i+1,j+1,k)+&
- & tuc(2,i,j+1,k)+&
- & tuc(2,i,j,k+1) + &
- & tuc(2,i+1,j,k+1)+&
- & tuc(2,i,j+1,k+1)+&
- & tuc(2,i+1,j+1,k+1))
- puc(3,i2-1,j2-1,k2-1) = &
- & puc(3,i2-1,j2-1,k2-1) + &
- & tuc(3,i,j,k)
- puc(3,i2,j2-1,k2-1) = &
- & puc(3,i2,j2-1,k2-1) + &
- & 0.5_MK * (tuc(3,i,j,k)+&
- & tuc(3,i+1,j,k))
- puc(3,i2-1,j2,k2-1) = &
- & puc(3,i2-1,j2,k2-1) + &
- & 0.5_MK * ( tuc(3,i,j,k) + &
- & tuc(3,i,j+1,k))
- puc(3,i2,j2,k2-1) = &
- & puc(3,i2,j2,k2-1) + &
- & 0.25_MK * ( tuc(3,i,j,k)+&
- & tuc(3,i+1,j,k) + &
- & tuc(3,i+1,j+1,k)+&
- & tuc(3,i,j+1,k))
- puc(3,i2-1,j2-1,k2) = &
- & puc(3,i2-1,j2-1,k2) + &
- & 0.5_MK * (tuc(3,i,j,k)+&
- & tuc(3,i,j,k+1))
- puc(3,i2,j2-1,k2) = &
- & puc(3,i2,j2-1,k2) + &
- & 0.25_MK * ( tuc(3,i,j,k)+&
- & tuc(3,i+1,j,k) + &
- & tuc(3,i+1,j,k+1)+&
- & tuc(3,i,j,k+1))
- puc(3,i2-1,j2,k2) = &
- & puc(3,i2-1,j2,k2) + &
- & 0.25_MK * ( tuc(3,i,j,k)+&
- & tuc(3,i,j+1,k) + &
- & tuc(3,i,j,k+1)+&
- & tuc(3,i,j+1,k+1))
- puc(3,i2,j2,k2) = &
- & puc(3,i2,j2,k2) + &
- & 0.125_MK * (tuc(3,i,j,k)+&
- & tuc(3,i+1,j,k) + &
- & tuc(3,i+1,j+1,k)+&
- & tuc(3,i,j+1,k)+&
- & tuc(3,i,j,k+1) + &
- & tuc(3,i+1,j,k+1)+&
- & tuc(3,i,j+1,k+1)+&
- & tuc(3,i+1,j+1,k+1))
-#else
- DO ilda=1,vecdim
- puc(ilda,i2-1,j2-1,k2-1) = &
- & puc(ilda,i2-1,j2-1,k2-1) + &
- & tuc(ilda,i,j,k)
- puc(ilda,i2,j2-1,k2-1) = &
- & puc(ilda,i2,j2-1,k2-1) + &
- & 0.5_MK * (tuc(ilda,i,j,k)+&
- & tuc(ilda,i+1,j,k))
- puc(ilda,i2-1,j2,k2-1) = &
- & puc(ilda,i2-1,j2,k2-1) + &
- & 0.5_MK * ( tuc(ilda,i,j,k) + &
- & tuc(ilda,i,j+1,k))
- puc(ilda,i2,j2,k2-1) = &
- & puc(ilda,i2,j2,k2-1) + &
- & 0.25_MK * ( tuc(ilda,i,j,k)+&
- & tuc(ilda,i+1,j,k) + &
- & tuc(ilda,i+1,j+1,k)+&
- & tuc(ilda,i,j+1,k))
- puc(ilda,i2-1,j2-1,k2) = &
- & puc(ilda,i2-1,j2-1,k2) + &
- & 0.5_MK * (tuc(ilda,i,j,k)+&
- & tuc(ilda,i,j,k+1))
- puc(ilda,i2,j2-1,k2) = &
- & puc(ilda,i2,j2-1,k2) + &
- & 0.25_MK * ( tuc(ilda,i,j,k)+&
- & tuc(ilda,i+1,j,k) + &
- & tuc(ilda,i+1,j,k+1)+&
- & tuc(ilda,i,j,k+1))
- puc(ilda,i2-1,j2,k2) = &
- & puc(ilda,i2-1,j2,k2) + &
- & 0.25_MK * ( tuc(ilda,i,j,k)+&
- & tuc(ilda,i,j+1,k) + &
- & tuc(ilda,i,j,k+1)+&
- & tuc(ilda,i,j+1,k+1))
- puc(ilda,i2,j2,k2) = &
- & puc(ilda,i2,j2,k2) + &
- & 0.125_MK * (tuc(ilda,i,j,k)+&
- & tuc(ilda,i+1,j,k) + &
- & tuc(ilda,i+1,j+1,k)+&
- & tuc(ilda,i,j+1,k)+&
- & tuc(ilda,i,j,k+1) + &
- & tuc(ilda,i+1,j,k+1)+&
- & tuc(ilda,i,j+1,k+1)+&
- & tuc(ilda,i+1,j+1,k+1))
- ENDDO
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#endif
-#endif
- !----------------------------------------------------------------------
- !RETURN
- !----------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_mg_prolong',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_prolong_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_prolong_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_prolong_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_prolong_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_prolong_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_prolong_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_prolong_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_prolong_3d_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_res_coarse.f b/src/mg/ppm_mg_res_coarse.f
deleted file mode 100644
index 102b8e827fe155386c32089f231d14841008251f..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_res_coarse.f
+++ /dev/null
@@ -1,481 +0,0 @@
- !-----------------------------------------------------------------------
- ! Subroutine : ppm_mg_res
- !-----------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_2D_sca_s(topo_id,mlev,c1,c2,c3,c4,E,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_2D_sca_d(topo_id,mlev,c1,c2,c3,c4,E,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_3D_sca_s(topo_id,mlev,c1,c2,c3,c4,c5,&
- & E,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_3D_sca_d(topo_id,mlev,c1,c2,c3,c4,c5,&
- & E,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_2D_vec_s(topo_id,mlev,c1,c2,c3,c4,E,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_2D_vec_d(topo_id,mlev,c1,c2,c3,c4,E,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_3D_vec_s(topo_id,mlev,c1,c2,c3,c4,c5,&
- & E,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_coarse_3D_vec_d(topo_id,mlev,c1,c2,c3,c4,c5,&
- & E,info)
-#endif
-#endif
-#endif
- !!! In this routine we compute the residula in each level
- !----------------------------------------------------------------------
- ! Includes
- !-----------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------
- ! Modules
- !-----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------
- ! Arguments
- !-----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: mlev, topo_id
- REAL(MK), INTENT(OUT) :: E
-#if __MESH_DIM == __2D
- REAL(MK), INTENT(IN) :: c1,c2,c3,c4
-#elif __MESH_DIM == __3D
- REAL(MK), INTENT(IN) :: c1,c2,c3,c4,c5
-#endif
- INTEGER, INTENT(INOUT) :: info
- !---------------------------------------------------------------------
- ! Local variables
- !-----------------------------------------------------------------------
- CHARACTER(LEN=256) :: cbuf
- INTEGER :: i,j,isub,color
- INTEGER :: ilda,isweep,count
- INTEGER :: aa,bb,cc,dd,ee,gg
- REAL(MK) :: c11,c22,c33,c44,c55
- INTEGER :: k,idom
- REAL(MK) :: x,y
- REAL(MK) :: res
-#if __MESH_DIM == __2D
- 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
-#endif
- 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: 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_res',t0,info)
- IF (ppm_debug.GT.0) THEN
- WRITE(cbuf,*) 'RESIDUAL in LEVEL:',mlev
- CALL PPM_WRITE(ppm_rank,'mg_res_coarse',cbuf,info)
- ENDIF
- !-----------------------------------------------------------------------
- ! Check arguments
- !-----------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (c1.LE.0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth', &
- & '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', &
- & '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', &
- & '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', &
- & 'Factor c4 must be >0',__LINE__,info)
- GOTO 9999
- 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
- mgfield=>mgfield_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_vec_d
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- !-----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- E=-HUGE(E)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- aa=0
- bb=0
- cc=0
- dd=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
- 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
- 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)+&
- & 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
-#elif __MESH_DIM == __3D
- E=-HUGE(E)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- aa=0
- bb=0
- cc=0
- dd=0
- ee=0
- gg=0
- IF (.NOT.lperiodic) THEN
- DO 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
- aa=1
- ELSEIF (iface.EQ.2) THEN
- bb=1
- ELSEIF (iface.EQ.3) THEN
- cc=1
- ELSEIF (iface.EQ.4) THEN
- dd=1
- ELSEIF (iface.EQ.5) Then
- ee=1
- ELSEIF (iface.EQ.6) Then
- gg=1
- ENDIF
- ENDIF
- ENDDO !iface
- endif !periodic
- !-----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- DO k=start(3,isub,mlev)+ee,istop(3,isub,mlev)-gg
- DO j=start(2,isub,mlev)+cc,istop(2,isub,mlev)-dd
- DO i=start(1,isub,mlev)+aa,istop(1,isub,mlev)-bb
- res =(tuc(i-1,j,k)+&
- & tuc(i+1,j,k))*c2 + &
- & (tuc(i,j-1,k)+ &
- & tuc(i,j+1,k))*c3 +&
- & (tuc(i,j,k-1)+ &
- & tuc(i,j,k+1))*c4 -&
- & tuc(i,j,k)*c5 - &
- & mgfield(isub,mlev)%fc(i,j,k)
- 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
- !-----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- E=-HUGE(E)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- DO ilda=1,vecdim
- res =(tuc(ilda,i-1,j)+&
- & tuc(ilda,i+1,j))*c2 + &
- & (tuc(ilda,i,j-1)+ &
- & tuc(ilda,i,j+1))*c3 - &
- & tuc(ilda,i,j)*c4 - &
- & mgfield(isub,mlev)%fc(ilda,i,j)
- E=MAX(ABS(res),E)
- mgfield(isub,mlev)%err(ilda,i,j)=-res
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#elif __MESH_DIM == __3D
- !-----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- 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
- 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
- aa=1
- ELSEIF (iface.EQ.2) THEN
- bb=1
- ELSEIF (iface.EQ.3) THEN
- cc=1
- ELSEIF (iface.EQ.4) THEN
- dd=1
- ELSEIF (iface.EQ.5) Then
- ee=1
- ELSEIF (iface.EQ.6) Then
- gg=1
- ENDIF
- ENDIF
- ENDDO !iface
- endif !periodic
- ENDDO
- DO k=start(3,isub,mlev)+ee,istop(3,isub,mlev)-gg
- DO j=start(2,isub,mlev)+cc,istop(2,isub,mlev)-dd
- DO i=start(1,isub,mlev)+aa,istop(1,isub,mlev)-bb
-#ifdef __VECTOR
- res =(tuc(1,i-1,j,k)+&
- & tuc(1,i+1,j,k))*c2 + &
- & (tuc(1,i,j-1,k)+ &
- & tuc(1,i,j+1,k))*c3 +&
- & (tuc(1,i,j,k-1)+ &
- & tuc(1,i,j,k+1))*c4 -&
- & tuc(1,i,j,k)*c5 - &
- & mgfield(isub,mlev)%fc(1,i,j,k)
- E=MAX(ABS(res),E)
- mgfield(isub,mlev)%err(1,i,j,k)=-res
- res =(tuc(2,i-1,j,k)+&
- & tuc(2,i+1,j,k))*c2 + &
- & (tuc(2,i,j-1,k)+ &
- & tuc(2,i,j+1,k))*c3 +&
- & (tuc(2,i,j,k-1)+ &
- & tuc(2,i,j,k+1))*c4 -&
- & tuc(2,i,j,k)*c5 - &
- & mgfield(isub,mlev)%fc(2,i,j,k)
- E=MAX(ABS(res),E)
- mgfield(isub,mlev)%err(2,i,j,k)=-res
- res =(tuc(3,i-1,j,k)+&
- & tuc(3,i+1,j,k))*c2 + &
- & (tuc(3,i,j-1,k)+ &
- & tuc(3,i,j+1,k))*c3 +&
- & (tuc(3,i,j,k-1)+ &
- & tuc(3,i,j,k+1))*c4 -&
- & tuc(3,i,j,k)*c5 - &
- & mgfield(isub,mlev)%fc(3,i,j,k)
- E=MAX(ABS(res),E)
- mgfield(isub,mlev)%err(3,i,j,k)=-res
-#else
- DO ilda=1,vecdim
- res =(tuc(ilda,i-1,j,k)+&
- & tuc(ilda,i+1,j,k))*c2 + &
- & (tuc(ilda,i,j-1,k)+ &
- & tuc(ilda,i,j+1,k))*c3 +&
- & (tuc(ilda,i,j,k-1)+ &
- & tuc(ilda,i,j,k+1))*c4 -&
- & tuc(ilda,i,j,k)*c5 - &
- & mgfield(isub,mlev)%fc(ilda,i,j,k)
- E=MAX(ABS(res),E)
- mgfield(isub,mlev)%err(ilda,i,j,k)=-res
- ENDDO
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#endif
-#endif
- !----------------------------------------------------------------------
- ! Return
- !-----------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_mg_res',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_res_coarse_2D_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_res_coarse_2D_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_res_coarse_3D_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_res_coarse_3D_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_res_coarse_2D_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_res_coarse_2D_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_res_coarse_3D_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_res_coarse_3D_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_res_fine.f b/src/mg/ppm_mg_res_fine.f
deleted file mode 100644
index c5020c66b2975b74d115275e5634b9ba82196403..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_res_fine.f
+++ /dev/null
@@ -1,465 +0,0 @@
- !-----------------------------------------------------------------------
- ! Subroutine : ppm_mg_res
- !-----------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_2D_sca_s(topo_id,u,f,c1,c2,c3,c4,E,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_2D_sca_d(topo_id,u,f,c1,c2,c3,c4,E,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_3D_sca_s(topo_id,u,f,c1,c2,c3,c4,c5,&
- & E,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_3D_sca_d(topo_id,u,f,c1,c2,c3,c4,c5,&
- & E,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_2D_vec_s(topo_id,u,f,c1,c2,c3,c4,E,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_2D_vec_d(topo_id,u,f,c1,c2,c3,c4,E,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_3D_vec_s(topo_id,u,f,c1,c2,c3,c4,c5,&
- & E,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_res_fine_3D_vec_d(topo_id,u,f,c1,c2,c3,c4,c5,&
- & E,info)
-#endif
-#endif
-#endif
- !!! In this routine we compute the residual in each level
- !----------------------------------------------------------------------
- ! Includes
- !-----------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------
- ! Modules
- !-----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------
- ! Arguments
- !-----------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:),POINTER :: f
-#elif __MESH_DIM == __3D
- 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
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: f
-#endif
-#endif
-#if __MESH_DIM == __2D
- REAL(MK), INTENT(IN) :: c1,c2,c3,c4
-#elif __MESH_DIM == __3D
- REAL(MK), INTENT(IN) :: c1,c2,c3,c4,c5
-#endif
- REAL(MK), INTENT(OUT) :: E
- INTEGER, INTENT(INOUT) :: info
- INTEGER, INTENT(IN ) :: topo_id
- !---------------------------------------------------------------------
- ! Local variables
- !-----------------------------------------------------------------------
- CHARACTER(LEN=256) :: cbuf
- INTEGER :: i,j,isub,color
- INTEGER :: ilda,isweep,count
- INTEGER :: aa,bb,cc,dd,ee,gg
- REAL(MK) :: c11,c22,c33,c44,c55
- INTEGER :: k,idom
- REAL(MK) :: x,y
- REAL(MK) :: res
-#if __MESH_DIM == __2D
- 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
-#endif
- 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
-#endif
-#endif
-#endif
- !-----------------------------------------------------------------------
- !Externals
- !-----------------------------------------------------------------------
-
- !-----------------------------------------------------------------------
- !Initialize
- !-----------------------------------------------------------------------
- CALL substart('ppm_mg_res',t0,info)
- !-----------------------------------------------------------------------
- ! Check arguments
- !-----------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (c1.LE.0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_res', &
- & '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_res', &
- & '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_res', &
- & 'Factor c3 must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (c4.LE.0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_res', &
- & 'Factor c4 must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __MESH_DIM == __3D
- IF (c5.LE.0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_res', &
- & 'Factor c5 must be >0',__LINE__,info)
- GOTO 9999
- 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
- mgfield=>mgfield_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_vec_d
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- !-----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- E =-HUGE(E)
- DO isub=1,nsubs
- aa=0
- bb=0
- cc=0
- dd=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
- 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
- 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,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
-#elif __MESH_DIM == __3D
- !-----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- E =-HUGE(E)
- DO isub=1,nsubs
- aa=0
- bb=0
- cc=0
- dd=0
- ee=0
- gg=0
- IF (.NOT.lperiodic) THEN
- DO iface=1,6
- IF (bcdef_sca(isub,iface).EQ.&
- & ppm_param_bcdef_periodic) THEN
- !DO NOTHING
- ELSEIF (bcdef_sca(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
- ELSEIF (iface.EQ.5) Then
- ee=1
- ELSEIF (iface.EQ.6) Then
- gg=1
- ENDIF
- ENDIF
- ENDDO !iface
- ENDIF !periodic
- DO k=start(3,isub,1)+ee,istop(3,isub,1)-gg
- DO j=start(2,isub,1)+cc,istop(2,isub,1)-dd
- DO i=start(1,isub,1)+aa,istop(1,isub,1)-bb
- 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 - &
- & u(i,j,k,isub)*c5-f(i,j,k,isub)
- E = MAX(E,abs(res))
- mgfield(isub,1)%err(i,j,k)=-res
- mgfield(isub,1)%uc(i,j,k)=u(i,j,k,isub)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- !-----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- E =-HUGE(E)
- DO isub=1,nsubs
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1),istop(1,isub,1)
- DO 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)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#elif __MESH_DIM == __3D
- !-----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- E =-HUGE(E)
- DO isub=1,nsubs
- aa=0
- bb=0
- cc=0
- dd=0
- 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
- !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
- ELSEIF (iface.EQ.5) Then
- ee=1
- ELSEIF (iface.EQ.6) Then
- gg=1
- ENDIF
- ENDIF
- ENDDO !iface
- ENDIF !periodic
- ENDDO
- DO k=start(3,isub,1)+ee,istop(3,isub,1)-gg
- DO j=start(2,isub,1)+cc,istop(2,isub,1)-dd
- DO i=start(1,isub,1)+aa,istop(1,isub,1)-bb
-#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))
- mgfield(isub,1)%err(ilda,i,j,k)=-res
- mgfield(isub,1)%uc(ilda,i,j,k)=u(ilda,i,j,k,isub)
- ENDDO
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#endif
-#endif
- !----------------------------------------------------------------------
- ! Return
- !-----------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_mg_res',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_res_fine_2D_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_res_fine_2D_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_res_fine_3D_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_res_fine_3D_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_res_fine_2D_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_res_fine_2D_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_res_fine_3D_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_res_fine_3D_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_restrict.f b/src/mg/ppm_mg_restrict.f
deleted file mode 100644
index 30168d6df515b0a838c20e4babcf034470ee6034..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_restrict.f
+++ /dev/null
@@ -1,775 +0,0 @@
- !----------------------------------------------------------------------
- ! Subroutine : ppm_mg_restrict
- !-----------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_restrict_2d_sca_s(topo_id,mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_restrict_2d_sca_d(topo_id,mlev,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_restrict_3d_sca_s(topo_id,mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_restrict_3d_sca_d(topo_id,mlev,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_restrict_2d_vec_s(topo_id,mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_restrict_2d_vec_d(topo_id,mlev,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_restrict_3d_vec_s(topo_id,mlev,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_restrict_3d_vec_d(topo_id,mlev,info)
-#endif
-#endif
-#endif
- !!! In this routine we restrict the error from finer to coarser levels
- !-----------------------------------------------------------------------
- ! Includes
- !-----------------------------------------------------------------------
-#include "ppm_define.h"
- !-----------------------------------------------------------------------
- ! Modules
- !-----------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_mg
- USE ppm_module_alloc
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_map
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-----------------------------------------------------------------------
- ! Arguments
- !-----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: mlev, topo_id
- INTEGER, INTENT(INOUT) :: info
- !-----------------------------------------------------------------------
- ! Local variables
- !-----------------------------------------------------------------------
- CHARACTER(LEN=256) :: cbuf
- INTEGER :: isub,j,j2,i,i2
- INTEGER :: mlevm1,ilda,iface
- INTEGER,DIMENSION(5) :: ldl5,ldu5
- INTEGER,DIMENSION(4) :: ldl4,ldu4
- INTEGER,DIMENSION(3) :: ldl3,ldu3
- INTEGER :: iopt,topoid
- 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 => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: uc_dummy => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy => NULL()
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc_dummy => NULL()
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: terr => NULL()
- REAL(MK),DIMENSION(:,:),POINTER :: pfc => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: terr => NULL()
- REAL(MK),DIMENSION(:,:,:),POINTER :: pfc => NULL()
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: terr => NULL()
- REAL(MK),DIMENSION(:,:,:),POINTER :: pfc => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: terr => NULL()
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: pfc => NULL()
-#endif
-#endif
- !----------------------------------------------------------------------
- !Externals
- !----------------------------------------------------------------------
-
- !----------------------------------------------------------------------
- !Initialize
- !----------------------------------------------------------------------
- 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
- !----------------------------------------------------------------------
- !Definition of necessary variables and allocation of arrays
- !----------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_vec_d
-#endif
-#endif
-#endif
- !----------------------------------------------------------------------
- !Implementation
- !----------------------------------------------------------------------
- mlevm1=mlev-1
- IF (ppm_debug.GT.0) 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
- 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_get(topoid,mg_meshid(mlevm1),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlevm1),uc_dummy,&
- & info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlevm1),uc_dummy,&
- & ghostsize,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
- 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
- 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_get(topoid,mg_meshid(mlevm1),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlevm1),uc_dummy,&
- & info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlevm1),uc_dummy,&
- & ghostsize,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
- 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-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
- 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_get(topoid,mg_meshid(mlevm1),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlevm1),uc_dummy,&
- & vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlevm1),uc_dummy,&
- & vecdim,ghostsize,info)
- DO isub=1,nsubs
- terr=>mgfield(isub,mlevm1)%err
- pfc=>mgfield(isub,mlev)%fc
- DO i=1-ghostsize(1),max_node(1,mlevm1)+ghostsize(1)
- DO j=1-ghostsize(2),max_node(2,mlevm1)+ghostsize(2)
- DO ilda=1,vecdim
- terr(ilda,i,j) = uc_dummy(ilda,i,j,isub)
- ENDDO
- ENDDO
- ENDDO
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- j2=2*j
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- 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
-#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)
-#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)
-#else
- 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_get(topoid,mg_meshid(mlevm1),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlevm1),uc_dummy,&
- & vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlevm1),uc_dummy,&
- & vecdim,ghostsize,info)
- DO isub=1,nsubs
- 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)
-#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)
-#else
- DO ilda=1,vecdim
- terr(ilda,i,j,k) = uc_dummy(ilda,i,j,k,isub)
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- DO k=start(3,isub,mlev),istop(3,isub,mlev)
- k2=2*k
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- j2=2*j
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- i2=2*i
-#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))
-#else
- DO ilda=1,vecdim
- pfc(ilda,i,j,k)= &
- & 0.125_MK * &
- & terr(ilda,i2-1,j2-1,k2-1) + &
- & 0.0625_MK * (&
- & terr(ilda,i2,j2-1,k2-1) +&
- & terr(ilda,i2-2,j2-1,k2-1)+ &
- & terr(ilda,i2-1,j2,k2-1) + &
- & terr(ilda,i2-1,j2-2,k2-1))+&
- & 0.03125_MK * (&
- & terr(ilda,i2,j2-2,k2-1)+ &
- & terr(ilda,i2-2,j2,k2-1) + &
- & terr(ilda,i2-2,j2-2,k2-1) +&
- & terr(ilda,i2,j2,k2-1))
- pfc(ilda,i,j,k)= &
- & pfc(ilda,i,j,k)+&
- & 0.0625_MK * &
- & terr(ilda,i2-1,j2-1,k2) + &
- & 0.03125_MK * (&
- & terr(ilda,i2,j2-1,k2) +&
- & terr(ilda,i2-2,j2-1,k2)+ &
- & terr(ilda,i2-1,j2,k2) +&
- & terr(ilda,i2-1,j2-2,k2))+&
- & 0.015625_MK * (&
- & terr(ilda,i2,j2-2,k2)+ &
- & terr(ilda,i2-2,j2,k2) + &
- & terr(ilda,i2-2,j2-2,k2) + &
- & terr(ilda,i2,j2,k2))
- pfc(ilda,i,j,k)= &
- & pfc(ilda,i,j,k) +&
- & 0.0625_MK * &
- & terr(ilda,i2-1,j2-1,k2-2) + &
- & 0.03125_MK *(&
- & terr(ilda,i2,j2-1,k2-2) +&
- & terr(ilda,i2-2,j2-1,k2-2)+ &
- & terr(ilda,i2-1,j2,k2-2)+&
- & terr(ilda,i2-1,j2-2,k2-2))+&
- & 0.015625_MK*(&
- & terr(ilda,i2,j2-2,k2-2)+&
- & terr(ilda,i2-2,j2,k2-2) + &
- & terr(ilda,i2-2,j2-2,k2-2)+&
- & terr(ilda,i2,j2,k2-2))
- ENDDO
-#endif
- ENDDO
- 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
-#endif
-#endif
- !----------------------------------------------------------------------
- ! Return
- !----------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_mg_restrict',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_restrict_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_restrict_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_restrict_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_restrict_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_restrict_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_restrict_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_restrict_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_restrict_3d_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_smooth_coarse.f b/src/mg/ppm_mg_smooth_coarse.f
deleted file mode 100644
index 3161aa120bf346b87f25520bf29453e76cb1b91d..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_smooth_coarse.f
+++ /dev/null
@@ -1,1112 +0,0 @@
-
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_mg_smooth_coarse
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_2D_sca_s(topo_id,nsweep,mlev,&
- & c1,c2,c3,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_2D_sca_d(topo_id,nsweep,mlev,&
- & c1,c2,c3,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_3D_sca_s(topo_id,nsweep,mlev,&
- & c1,c2,c3,c4,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_3D_sca_d(topo_id,nsweep,mlev,&
- & c1,c2,c3,c4,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_2D_vec_s(topo_id,nsweep,mlev,&
- & c1,c2,c3,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_2D_vec_d(topo_id,nsweep,mlev,&
- & c1,c2,c3,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_3D_vec_s(topo_id,nsweep,mlev,&
- & c1,c2,c3,c4,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_coarse_3D_vec_d(topo_id,nsweep,mlev,&
- & c1,c2,c3,c4,info)
-#endif
-#endif
-#endif
- !!! In this routine we compute the corrections for the function
- !!! based on the Gauss-Seidel iteration
- !----------------------------------------------------------------------
- ! 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
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !------------------------------------------------------------------
- ! Arguments
- !----------------------------------------------------------------------
- INTEGER, INTENT(IN) :: nsweep
- INTEGER, INTENT(IN) :: mlev, topo_id
-#if __MESH_DIM == __2D
- 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,colos
- INTEGER,DIMENSION(:,:),POINTER :: lorig => NULL()
- INTEGER,DIMENSION(:,:),POINTER :: lext => NULL()
- INTEGER,DIMENSION(:),POINTER :: a => NULL()
- INTEGER,DIMENSION(:),POINTER :: b => NULL()
- INTEGER,DIMENSION(:),POINTER :: c => NULL()
- INTEGER,DIMENSION(:),POINTER :: d => NULL()
- INTEGER,DIMENSION(:),POINTER :: e => NULL()
- INTEGER,DIMENSION(:),POINTER :: g => NULL()
- 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,DIMENSION(2) :: ldu2
-#if __MESH_DIM == __2D
- 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
-#endif
- 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 => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: uc => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc => NULL()
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc => NULL()
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: oldu => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: oldu => NULL()
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: oldu => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: oldu => NULL()
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK) :: moldu
-#elif __MESH_DIM == __3D
- REAL(MK) :: moldu
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:),POINTER :: moldu => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:),POINTER :: moldu => NULL()
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: tuc => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc => NULL()
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc => NULL()
-#endif
-#endif
-#if __KIND == __SINGLE_PRECISION
- omega=omega_s
- dx=dx_s
- dy=dy_s
-#if __MESH_DIM == __3D
- dz=dz_s
-#endif
-#elif __KIND == __DOUBLE_PRECISION
- omega=omega_d
- dx=dx_d
- dy=dy_d
-#if __MESH_DIM == __3D
- dz=dz_d
-#endif
-#endif
- !----------------------------------------------------------------------
- !Externals
- !----------------------------------------------------------------------
-
- !----------------------------------------------------------------------
- !Initialize
- !----------------------------------------------------------------------
- CALL substart('ppm_mg_smooth_coarse',t0,info)
- IF (ppm_debug.GT.0) 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
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_vec_d
-#endif
-#endif
-#endif
- iopt = ppm_param_alloc_fit
- ldu2(1) = ppm_dim
- ldu2(2) = nsubs
- CALL ppm_alloc(lorig,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'origi',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(lext,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'origi',__LINE__,info)
- GOTO 9999
- ENDIF
- iopt = ppm_param_alloc_fit
- ldl1(1) = 1
- ldu1(1) = nsubs
- CALL ppm_alloc(a,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'a',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(b,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'b',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(c,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'c',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(d,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'd',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(e,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'e',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(g,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'g',__LINE__,info)
- GOTO 9999
- ENDIF
- lorig=0
- lext=0
- !-------------------------------------------------------------
- ! set up counter origin and extents
- !-------------------------------------------------------------
- DO isub=1,nsubs
- DO iface=1,ppm_dim
- IF (bcdef_sca(isub,2*iface-1).EQ.ppm_param_bcdef_periodic) THEN
- lorig(iface,isub)=1
- ELSEIF (bcdef_sca(isub,2*iface-1).EQ.ppm_param_bcdef_dirichlet) THEN
- lorig(iface,isub)=2
- ELSEIF (bcdef_sca(isub,2*iface-1).EQ.0) THEN
- lorig(iface,isub)=0
- ENDIF
- ENDDO!iface
- DO iface=1,ppm_dim
- IF (bcdef_sca(isub,2*iface).EQ.ppm_param_bcdef_periodic) THEN
- lext(iface,isub)=istop(iface,isub,mlev)
- ELSEIF (bcdef_sca(isub,2*iface).EQ.ppm_param_bcdef_dirichlet) THEN
- lext(iface,isub)=istop(iface,isub,mlev)-1
- ELSEIF (bcdef_sca(isub,2*iface).EQ.0) THEN
- lext(iface,isub)=istop(iface,isub,mlev)+1
- ENDIF
- ENDDO!iface
- ENDDO!DO isub
-#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,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'uc',__LINE__,info)
- GOTO 9999
- ENDIF
- ! write data from mgfield DS to temporary uc field
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- uc(:,:,isub)=tuc(:,:)
- ENDDO
- DO isweep=1,nsweep
- DO color=0,1
- DO isub=1,nsubs
- DO iface=1,4
- IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
- IF (iface.EQ.1) THEN
- i=1
- DO j=1,max_node(2,mlev)
- uc(i,j,isub)=0.0_MK
- ENDDO
- ELSEIF (iface.EQ.2) THEN
- i=max_node(1,mlev)
- DO j=1,max_node(2,mlev)
- uc(i,j,isub)=0.0_MK
- enddo
- ELSEIF (iface.EQ.3) THEN
- j=1
- DO i=1,max_node(1,mlev)
- uc(i,j,isub)=0.0_MK
- ENDDO
- ELSEIF (iface.EQ.4) THEN
- j=max_node(2,mlev)
- DO i=1,max_node(1,mlev)
- uc(i,j,isub)=0.0_MK
- ENDDO
- ENDIF !iface
- ENDIF !bckind
- ENDDO!iface
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
-
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),uc,&
- & info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),uc,&
- & ghostsize,info)
- DO isub=1,nsubs
- DO j=lorig(2,isub),lext(2,isub)
- DO i=lorig(1,isub)+mod(j+color,2), &
- & lext(1,isub)-mod(j+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))) THEN
- uc(i,j,isub) = uc(i,j,isub)+omega*(c1*( &
- & (uc(i-1,j,isub)+uc(i+1,j,isub))*c2 + &
- & (uc(i,j-1,isub)+uc(i,j+1,isub))*c3 - &
- & mgfield(isub,mlev)%fc(i,j)) &
- & -uc(i,j,isub))
-! ENDIF
- ENDDO
- ENDDO
- ENDDO!isub
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),uc,&
- & info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),uc,&
- & ghostsize,info)
- ENDIF
- ENDDO!DO nsweep
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- tuc(:,:)=uc(:,:,isub)
- ENDDO
- iopt = ppm_param_dealloc
- CALL ppm_alloc(uc,ldl3,ldu3,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'uc',__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,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'uc',__LINE__,info)
- GOTO 9999
- ENDIF
- ! write data from mgfield DS to temporary uc field
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- uc(:,:,:,isub)=tuc(:,:,:)
- ENDDO
- DO isweep=1,nsweep
- DO color=0,1
- DO isub=1,nsubs
- DO iface=1,6
- IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
- IF (iface.EQ.1) THEN
- i=1
- DO k=1,max_node(3,mlev)
- DO j=1,max_node(2,mlev)
- uc(i,j,k,isub)=0.0_MK
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.2) THEN
- i=max_node(1,mlev)
- DO k=1,max_node(3,mlev)
- DO j=1,max_node(2,mlev)
- uc(i,j,k,isub)=0.0_MK
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.3) THEN
- j=1
- DO k=1,max_node(3,mlev)
- DO i=1,max_node(1,mlev)
- uc(i,j,k,isub)=0.0_MK
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.4) THEN
- j=max_node(2,mlev)
- DO k=1,max_node(3,mlev)
- DO i=1,max_node(1,mlev)
- uc(i,j,k,isub)=0.0_MK
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.5) THEN
- k=1
- DO j=1,max_node(2,mlev)
- DO i=1,max_node(1,mlev)
- uc(i,j,k,isub)=0.0_MK
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.6) THEN
- k=max_node(3,mlev)
- DO j=1,max_node(2,mlev)
- DO i=1,max_node(1,mlev)
- uc(i,j,k,isub)=0.0_MK
- ENDDO
- ENDDO
- ENDIF !iface
- ENDIF !bckind
- ENDDO!iface
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),uc,&
- & info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),uc,&
- & ghostsize,info)
-
- DO isub=1,nsubs
- DO k=lorig(3,isub),lext(3,isub)
- DO j=lorig(2,isub),lext(2,isub)
- DO i=lorig(1,isub)+mod(j+k+color,2), &
- & lext(1,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
- uc(i,j,k,isub) = uc(i,j,k,isub)+omega*(c1*( &
- & (uc(i-1,j,k,isub)+uc(i+1,j,k,isub))*c2 + &
- & (uc(i,j-1,k,isub)+uc(i,j+1,k,isub))*c3 + &
- & (uc(i,j,k-1,isub)+uc(i,j,k+1,isub))*c4 - &
- & mgfield(isub,mlev)%fc(i,j,k)) &
- & -uc(i,j,k,isub))
-! ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO!isub
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),uc,&
- & info)
- CALL ppm_map_field_send(info)
-
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),uc,&
- & ghostsize,info)
- ENDIF
- ENDDO!Do isweep
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- tuc(:,:,:)=uc(:,:,:,isub)
- ENDDO
- iopt = ppm_param_dealloc
- CALL ppm_alloc(uc,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'uc',__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,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'uc',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isweep=1,nsweep
- DO color=0,1
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- uc(:,:,:,isub)=tuc(:,:,:)
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),uc,&
- & vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),uc,&
- & vecdim,ghostsize,info)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- tuc(:,:,:)=uc(&
- & :,:,:,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(:,:,:,isub)=tuc(:,:,:)
- ENDDO
- ENDIF
- ENDIF
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),uc,&
- & vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),uc,&
- & vecdim,ghostsize,info)
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- tuc(:,:,:)=uc(:,:,:,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,ldl4,ldu4,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'uc',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldl5(1) = 1
- ldl5(2) = 1-ghostsize(1)
- ldl5(3) = 1-ghostsize(2)
- ldl5(4) = 1-ghostsize(3)
- ldl5(5) = 1
- ldu5(1) = vecdim
- ldu5(2) = max_node(1,mlev)+ghostsize(1)
- ldu5(3) = max_node(2,mlev)+ghostsize(2)
- ldu5(4) = max_node(3,mlev)+ghostsize(3)
- ldu5(5) = nsubs
- CALL ppm_alloc(uc,ldl5,ldu5,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'uc',__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,'ppm_mg_smooth_coarse', &
- & 'moldu',__LINE__,info)
- GOTO 9999
- ENDIF
- 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)
-#ifdef __VECTOR
- uc(1,i,j,k,isub)=tuc(1,i,j,k)
- uc(2,i,j,k,isub)=tuc(2,i,j,k)
- uc(3,i,j,k,isub)=tuc(3,i,j,k)
-#else
- DO ilda=1,vecdim
- uc(ilda,i,j,k,isub)=tuc(ilda,i,j,k)
- ENDDO
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),uc,&
- & vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),uc,&
- & vecdim,ghostsize,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(1,i,j,k,isub)
- tuc(2,i,j,k)=uc(2,i,j,k,isub)
- tuc(3,i,j,k)=uc(3,i,j,k,isub)
-#else
- DO ilda=1,vecdim
- tuc(ilda,i,j,k)=uc(ilda,i,j,k,isub)
- ENDDO
-#endif
- 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
- 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
- ENDIF
- k=1
- DO i=1,max_node(1,mlev)
- DO j=1,max_node(2,mlev)
- tuc(ilda,i,j,k)=0.0_MK
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.6) THEN
- g(isub)=1
- IF (bcdef_vec(ilda,isub,5).EQ.0) THEN
- e(isub)=-1
- ENDIF
- k=max_node(3,mlev)
- DO i=1,max_node(1,mlev)
- Do j=1,max_node(2,mlev)
- tuc(ilda,i,j,k)=0.0_MK
- ENDDO
- ENDDO
- ENDIF
- 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)
-#else
- do ilda=1,vecdim
- moldu(ilda) = tuc(ilda,i,j,k)
- end do
-#endif
-#ifdef __VECTOR
- tuc(1,i,j,k) = moldu(1)+&
- & omega*(&
- & c1*((tuc(1,i-1,j,k)+ &
- & tuc(1,i+1,j,k))*c2 + &
- & (tuc(1,i,j-1,k)+&
- & tuc(1,i,j+1,k))*c3 + &
- & (tuc(1,i,j,k-1)+&
- & tuc(1,i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(1,i,j,k))&
- & -moldu(1))
- tuc(2,i,j,k) = moldu(2)+&
- & omega*(&
- & c1*((tuc(2,i-1,j,k)+ &
- & tuc(2,i+1,j,k))*c2 + &
- & (tuc(2,i,j-1,k)+&
- & tuc(2,i,j+1,k))*c3 + &
- & (tuc(2,i,j,k-1)+&
- & tuc(2,i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(2,i,j,k))&
- & -moldu(2))
- tuc(3,i,j,k) = moldu(3)+&
- & omega*(&
- & c1*((tuc(3,i-1,j,k)+ &
- & tuc(3,i+1,j,k))*c2 + &
- & (tuc(3,i,j-1,k)+&
- & tuc(3,i,j+1,k))*c3 + &
- & (tuc(3,i,j,k-1)+&
- & tuc(3,i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(3,i,j,k))&
- & -moldu(3))
-#else
- DO ilda=1,vecdim
- tuc(ilda,i,j,k) = moldu(ilda)+&
- & omega*(&
- & c1*((tuc(ilda,i-1,j,k)+ &
- & tuc(ilda,i+1,j,k))*c2 + &
- & (tuc(ilda,i,j-1,k)+&
- & tuc(ilda,i,j+1,k))*c3 + &
- & (tuc(ilda,i,j,k-1)+&
- & tuc(ilda,i,j,k+1))*c4 - &
- & mgfield(isub,mlev)%fc(ilda,i,j,k))&
- & -moldu(ilda))
- ENDDO!ilda
-#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(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
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),uc,&
- & vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),uc,&
- & vecdim,ghostsize,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(ilda,i,j,k,isub)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDDO!Do isweep
- iopt = ppm_param_dealloc
- ldl5(1) = 1
- ldl5(2) = 1-ghostsize(1)
- ldl5(3) = 1-ghostsize(2)
- ldl5(4) = 1-ghostsize(3)
- ldl5(5) = 1
- ldu5(1) = vecdim
- ldu5(2) = max_node(1,mlev)+ghostsize(1)
- ldu5(4) = max_node(2,mlev)+ghostsize(2)
- ldu5(4) = max_node(3,mlev)+ghostsize(3)
- ldu5(5) = nsubs
- CALL ppm_alloc(uc,ldl5,ldu5,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_coarse', &
- & 'uc',__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,'ppm_mg_smooth_coarse', &
- & 'moldu',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
-#endif
- !---------------------------------------------------------------------
- ! Deallocate local work arrays
- !----------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(a,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'a',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(b,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'b',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(c,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'c',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(d,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'd',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(e,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'e',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(g,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'g',__LINE__,info)
- GOTO 9999
- ENDIF
- !---------------------------------------------------------------------
- ! 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_coarse_3D_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_smooth_fine.f b/src/mg/ppm_mg_smooth_fine.f
deleted file mode 100644
index 46a97a76b74cadaafd428165bf3f5df93af1ed92..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_smooth_fine.f
+++ /dev/null
@@ -1,887 +0,0 @@
- !-----------------------------------------------------------------------
- ! Subroutine : ppm_mg_smooth_fine
- !-----------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_2D_sca_s(topo_id,u,f,nsweep,mlev,&
- & c1,c2,c3,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_2D_sca_d(topo_id,u,f,nsweep,mlev,&
- & c1,c2,c3,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_3D_sca_s(topo_id,u,f,nsweep,mlev,&
- & c1,c2,c3,c4,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_3D_sca_d(topo_id,u,f,nsweep,mlev,&
- & c1,c2,c3,c4,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_2D_vec_s(topo_id,u,f,nsweep,mlev,&
- & c1,c2,c3,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_2D_vec_d(topo_id,u,f,nsweep,mlev,&
- & c1,c2,c3,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_3D_vec_s(topo_id,u,f,nsweep,mlev,&
- & c1,c2,c3,c4,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_smooth_fine_3D_vec_d(topo_id,u,f,nsweep,mlev,&
- & c1,c2,c3,c4,info)
-#endif
-#endif
-#endif
- !!! In this routine we compute the corrections for the function based
- !!! on the Gauss-Seidel iteration
- !----------------------------------------------------------------------
- ! 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
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !------------------------------------------------------------------
- ! Arguments
- !----------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:),POINTER :: f
-#elif __MESH_DIM == __3D
- 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
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: u
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: f
-#endif
-#endif
- INTEGER, INTENT(IN) :: nsweep
- INTEGER, INTENT(IN) :: mlev, topo_id
-#if __MESH_DIM == __2D
- 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,colos
- INTEGER :: ilda,isweep,count
- REAL(MK) :: c11,c22,c33,c44
- REAL(MK) :: dx,dy
- INTEGER,DIMENSION(:,:),POINTER :: lorig => NULL()
- INTEGER,DIMENSION(:,:),POINTER :: lext => NULL()
- INTEGER,DIMENSION(:),POINTER :: a => NULL()
- INTEGER,DIMENSION(:),POINTER :: b => NULL()
- INTEGER,DIMENSION(:),POINTER :: c => NULL()
- INTEGER,DIMENSION(:),POINTER :: d => NULL()
- INTEGER,DIMENSION(:),POINTER :: e => NULL()
- INTEGER,DIMENSION(:),POINTER :: g => NULL()
- INTEGER :: k,idom
- REAL(MK) :: x,y
- REAL(MK) :: omega
- INTEGER,DIMENSION(1) :: ldl1,ldu1
- INTEGER,DIMENSION(2) :: ldu2
-#if __MESH_DIM == __2D
- INTEGER,DIMENSION(4) :: ldl4,ldu4
- INTEGER,DIMENSION(3) :: ldl3,ldu3
-#endif
-#if __MESH_DIM == __3D
- REAL(MK) :: dz
- INTEGER,DIMENSION(5) :: ldl5,ldu5
- INTEGER,DIMENSION(4) :: ldl4,ldu4
-#endif
- 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
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield
-#elif __KIND == __DOUBLE_PRECISION
- 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
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: oldu
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: oldu
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: oldu
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: oldu
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK) :: moldu
-#elif __MESH_DIM == __3D
- REAL(MK) :: moldu
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:),POINTER :: moldu
-#elif __MESH_DIM == __3D
- 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
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_fine', &
- & 'nsweep must be >=1',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (mlev.LT.1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_smooth_fine', &
- & '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_fine', &
- & '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_fine', &
- & '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_fine', &
- & '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_fine', &
- & 'Factor c4 must be >0',__LINE__,info)
- GOTO 9999
- 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
- mgfield=>mgfield_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- mgfield=>mgfield_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- mgfield=>mgfield_3d_vec_d
-#endif
-#endif
-#endif
-#if __KIND == __SINGLE_PRECISION
-omega=omega_s
-dx=dx_s
-dy=dy_s
-#if __MESH_DIM == __3D
-dz=dz_s
-#endif
-#elif __KIND == __DOUBLE_PRECISION
-omega=omega_d
-dx=dx_d
-dy=dy_d
-#if __MESH_DIM == __3D
-dz=dz_d
-#endif
-#endif
- iopt = ppm_param_alloc_fit
- ldu2(1) = ppm_dim
- ldu2(2) = nsubs
- CALL ppm_alloc(lorig,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'origi',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(lext,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'origi',__LINE__,info)
- GOTO 9999
- ENDIF
- iopt = ppm_param_alloc_fit
- ldl1(1) = 1
- ldu1(1) = nsubs
- CALL ppm_alloc(a,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'a',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(b,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'b',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(c,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'c',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(d,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'd',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(e,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'e',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(g,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'g',__LINE__,info)
- GOTO 9999
- ENDIF
-
- lorig=0
- lext=0
- !-------------------------------------------------------------
- ! set up counter origin and extents
- !-------------------------------------------------------------
- DO isub=1,nsubs
- DO iface=1,ppm_dim
- IF (bcdef_sca(isub,2*iface-1).EQ.ppm_param_bcdef_periodic) THEN
- lorig(iface,isub)=1
- ELSEIF (bcdef_sca(isub,2*iface-1).EQ.ppm_param_bcdef_dirichlet) THEN
- lorig(iface,isub)=2
- ELSEIF (bcdef_sca(isub,2*iface-1).EQ.0) THEN
- lorig(iface,isub)=0
- ENDIF
- ENDDO!iface
- DO iface=1,ppm_dim
- IF (bcdef_sca(isub,2*iface).EQ.ppm_param_bcdef_periodic) THEN
- lext(iface,isub)=istop(iface,isub,1)
- ELSEIF (bcdef_sca(isub,2*iface).EQ.ppm_param_bcdef_dirichlet) THEN
- lext(iface,isub)=istop(iface,isub,1)-1
- ELSEIF (bcdef_sca(isub,2*iface).EQ.0) THEN
- lext(iface,isub)=istop(iface,isub,1)+1
- ENDIF
- ENDDO!iface
- ENDDO!DO isub
-
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- count = 0
- DO isweep=1,nsweep
- DO color=0,1
- !-------------------------------------------------------------
- !Impose boundaries on even if color=0 or odd if color=1
- !-------------------------------------------------------------
- DO isub=1,nsubs
- DO iface=1,4
- IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
- IF (iface.EQ.1) THEN
- i=1
- DO j=1,max_node(2,mlev)
- u(i,j,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(j)
- ENDDO
- ELSEIF (iface.EQ.2) THEN
- i=max_node(1,mlev)
- DO j=1,max_node(2,mlev)
- u(i,j,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(j)
- enddo
- ELSEIF (iface.EQ.3) THEN
- j=1
- DO i=1,max_node(1,mlev)
- u(i,j,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i)
- ENDDO
- ELSEIF (iface.EQ.4) THEN
- j=max_node(2,mlev)
- DO i=1,max_node(1,mlev)
- u(i,j,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i)
- ENDDO
- ENDIF !iface
- ENDIF !bcdef
- ENDDO!iface
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate
- !----------------------------------------------------------------
-
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),u,info)
- CALL ppm_map_field_send(info)
-
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),u,ghostsize,info)
- DO isub=1,nsubs
- DO j=lorig(2,isub),lext(2,isub)
- DO i=lorig(1,isub)+mod(j+color,2), &
- & lext(1,isub)-mod(j+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))) THEN
- u(i,j,isub)=u(i,j,isub) + omega*(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)) - u(i,j,isub))
-! ENDIF
- ENDDO
- ENDDO
- ENDDO !isub
- ENDDO!DO color
-
-
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),u,info)
- CALL ppm_map_field_send(info)
-
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),u,ghostsize,info)
-
- ENDIF
- ENDDO
-#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- DO isweep=1,nsweep
- DO color=0,1
- !-------------------------------------------------------------
- !Impose boundaries on even if color=0 or odd if color=1
- !-------------------------------------------------------------
- DO isub=1,nsubs
- DO iface=1,6
- IF (bcdef_sca(isub,iface).EQ.ppm_param_bcdef_dirichlet) THEN
- IF (iface.EQ.1) THEN
- i=1
- DO k=1,max_node(3,mlev)
- DO j=1,max_node(2,mlev)
- u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(j,k)
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.2) THEN
- i=max_node(1,mlev)
- DO k=1,max_node(3,mlev)
- DO j=1,max_node(2,mlev)
- u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(j,k)
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.3) THEN
- j=1
- DO k=1,max_node(3,mlev)
- DO i=1,max_node(1,mlev)
- u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i,k)
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.4) THEN
- j=max_node(2,mlev)
- DO k=1,max_node(3,mlev)
- DO i=1,max_node(1,mlev)
- u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i,k)
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.5) THEN
- k=1
- DO j=1,max_node(2,mlev)
- DO i=1,max_node(1,mlev)
- u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i,j)
- ENDDO
- ENDDO
- ELSEIF (iface.EQ.6) THEN
- k=max_node(3,mlev)
- DO j=1,max_node(2,mlev)
- DO i=1,max_node(1,mlev)
- u(i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(i,j)
- ENDDO
- ENDDO
- ENDIF !iface
- ENDIF !bcdef
- ENDDO!iface
- ENDDO!DO isub
- !----------------------------------------------------------------
- !Communicate red(even) if color==0 or communicate black(odd)
- !if color==1
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),u,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),u,ghostsize,info)
- DO isub=1,nsubs
- DO k=lorig(3,isub),lext(3,isub)
- DO j=lorig(2,isub),lext(2,isub)
- DO i=lorig(1,isub)+mod(j+k+color,2), &
- & lext(1,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
- u(i,j,k,isub) = u(i,j,k,isub)+omega*(&
- & c1*((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- &
- & f(i,j,k,isub))-u(i,j,k,isub))
-! ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO!subs
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),u,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),u,ghostsize,info)
- ENDIF
- ENDDO
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- count = 0
- DO isweep=1,nsweep
- DO color=0,1
- !----------------------------------------------------------------
- !Communicate red(even) if color==0 or communicate black(odd)
- !if color==1
- !----------------------------------------------------------------
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),u,vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),u,&
- & vecdim,ghostsize,info)
- DO isub=1,nsubs
- DO j=start(2,isub,1),istop(2,isub,1)
- DO i=start(1,isub,1)+mod(j+color,2),istop(1,isub,1),2
- DO 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
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),u,vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),u,&
- & vecdim,ghostsize,info)
- ENDIF
- ENDDO
-#elif __MESH_DIM == __3D
- !----------------------------------------------------------------------
- !Implementation
- !---------------------------------------------------------------------
- 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,'ppm_mg_smooth_fine', &
- & 'moldu',__LINE__,info)
- GOTO 9999
- ENDIF
- DO isweep=1,nsweep
- DO color=0,1
- a=0
- b=0
- c=0
- d=0
- e=0
- g=0
- DO isub=1,nsubs
- 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)
- u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,j,k)
- enddo
- ENDDO
- ELSEIF (iface.EQ.2) THEN
- b(isub)=1
- IF (bcdef_vec(ilda,isub,1).EQ.0) THEN
- a(isub)=-1
- ENDIF
- i=max_node(1,mlev)
- DO j=1,max_node(2,mlev)
- DO k=1,max_node(3,mlev)
- u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,j,k)
- 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)
- 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
- c(isub)=-1
- ENDIF
- 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)
- enddo
- ENDDO
- ELSEIF (iface.EQ.5) Then
- e(isub)=1
- IF (bcdef_vec(ilda,isub,6).EQ.0) THEN
- g(isub)=-1
- ENDIF
- k=1
- DO i=1,max_node(1,mlev)
- Do j=1,max_node(2,mlev)
- u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,j)
- 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)
- u(ilda,i,j,k,isub)=mgfield(isub,1)%bcvalue(iface)%pbcvalue(ilda,i,j)
- ENDDO
- ENDDO
- ENDIF
- ENDIF
- 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_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),u,vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),u,&
- & vecdim,ghostsize,info)
-#ifdef __VECTOR
- DO isub=1,nsubs
- DO k=start(3,isub,1)+e(isub),istop(3,isub,1)-g(isub)
- DO j=start(2,isub,1)+c(isub),istop(2,isub,1)-d(isub)
- DO i=start(1,isub,1)+mod(j+k+color,2)+a(isub), &
- & istop(1,isub,1)-b(isub)-mod(j+k+color,2),2
- IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND. &
- & (j.GE.1.AND.j.LE.max_node(2,mlev)).AND.(k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
- 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)+ &
- & 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- &
- & f(1,i,j,k,isub))&
-&-moldu(1))
- u(2,i,j,k,isub)=moldu(2)+omega*&
- & (&
- &c1*((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- &
- & f(2,i,j,k,isub))&
-&-moldu(2))
- u(3,i,j,k,isub)=moldu(3)+omega*&
- & (&
- &c1*((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- &
- & f(3,i,j,k,isub))&
-&-moldu(3))
- ENDDO
- ENDDO
- ENDDO
- ENDDO!subs
-#else
- DO isub=1,nsubs
- DO k=start(3,isub,1)+e(isub),istop(3,isub,1)-g(isub)
- DO j=start(2,isub,1)+c(isub),istop(2,isub,1)-d(isub)
- DO i=start(1,isub,1)+mod(j+k+color,2)+a(isub), &
- & istop(1,isub,1)-b(isub)-mod(j+k+color,2),2
- IF ((i.GE.1.AND.i.LE.max_node(1,mlev)).AND. &
- & (j.GE.1.AND.j.LE.max_node(2,mlev)).AND.(k.GE.1.AND.k.LE.max_node(3,mlev))) THEN
- do ilda=1,vecdim
- moldu(ilda) = u(ilda,i,j,k,isub)
- end do
- DO ilda=1,vecdim
- u(ilda,i,j,k,isub)=moldu(ilda)+omega*&
- & (&
- &c1*((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- &
- & f(ilda,i,j,k,isub))&
-&-moldu(ilda))
- ENDDO
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO!subs
-#endif
- ENDDO!DO color
- IF (isweep.EQ.nsweep) THEN
- CALL ppm_map_field_ghost_get(topoid,mg_meshid(mlev),&
- & ghostsize,info)
- CALL ppm_map_field_push(topoid,mg_meshid(mlev),u,vecdim,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,mg_meshid(mlev),u,&
- & vecdim,ghostsize,info)
- ENDIF
- ENDDO
- 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,'ppm_mg_smooth_fine', &
- & 'moldu',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
-#endif
- !---------------------------------------------------------------------
- ! Deallocate local work arrays
- !----------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(a,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'a',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(b,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'b',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(c,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'c',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(d,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'd',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(e,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'e',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(g,ldl1,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_mg_smooth_fine', &
- & 'g',__LINE__,info)
- GOTO 9999
- ENDIF
- !---------------------------------------------------------------------
- ! Return
- !----------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_mg_smooth_fine',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_fine_2D_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_fine_2D_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_fine_3D_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_fine_3D_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_fine_2D_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_fine_2D_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_fine_3D_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_smooth_fine_3D_vec_d
-#endif
-#endif
-#endif
diff --git a/src/mg/ppm_mg_solv.f b/src/mg/ppm_mg_solv.f
deleted file mode 100644
index 7b75f1b0f30924ca3e9e43756e3b26a31a44c37b..0000000000000000000000000000000000000000
--- a/src/mg/ppm_mg_solv.f
+++ /dev/null
@@ -1,1063 +0,0 @@
- !------------------------------------------------------------------------
- ! Subroutine : ppm_mg_solv
- !------------------------------------------------------------------------
- ! Copyright (c) 2011 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_solv_2d_sca_s(topo_id,u,f,&
- & initsweep,finsweep,restrsweep,prolsweep,&
- & Eu,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_solv_2d_sca_d(topo_id,u,f,&
- & initsweep,finsweep,restrsweep,prolsweep,&
- & Eu,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_solv_3d_sca_s(topo_id,u,f,&
- & initsweep,finsweep,restrsweep,prolsweep,&
- & Eu,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_solv_3d_sca_d(topo_id,u,f,&
- & initsweep,finsweep,restrsweep,prolsweep,&
- & Eu,info)
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_solv_2d_vec_s(topo_id,u,f,lda,&
- & initsweep,finsweep,restrsweep,prolsweep,&
- & Eu,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_solv_2d_vec_d(topo_id,u,f,lda,&
- & initsweep,finsweep,restrsweep,prolsweep,&
- & Eu,info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_mg_solv_3d_vec_s(topo_id,u,f,lda,&
- & initsweep,finsweep,restrsweep,prolsweep,&
- & Eu,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_mg_solv_3d_vec_d(topo_id,u,f,lda,&
- & initsweep,finsweep,restrsweep,prolsweep,&
- & Eu,info)
-#endif
-#endif
-#endif
- !!! Solves the given equation using the multigrid method
-
-
-#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_map
- USE ppm_module_mg_core
- USE ppm_module_mg_res
- USE ppm_module_mg_prolong
- USE ppm_module_mg_smooth
- USE ppm_module_write
- IMPLICIT NONE
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !----------------------------------------------------------------------
- ! Arguments (for u and f index: local mesh locations and isub)
- !----------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: u
- !!! the field of the solution (including the ghost layer)
- REAL(MK),DIMENSION(:,:,:),POINTER :: f
- !!! the field of the right hand side (without the ghost layer)
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
- !!! the field of the solution (including the ghost layer)
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
- !!! the field of the right hand side (without the ghost layer)
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: u
- !!! the field of the solution (including the ghost layer)
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: f
- !!! the field of the right hand side (without the ghost layer)
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: u
- !!! the field of the solution (including the ghost layer)
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: f
- !!! the field of the right hand side (without the ghost layer)
-#endif
-#endif
-#if __DIM == __VFIELD
- INTEGER,INTENT(IN) :: lda
- !!! leading dimension
-#endif
- INTEGER, INTENT(IN) :: initsweep
- !!! initial smoothing sweeps in the finest level
- INTEGER, INTENT(IN) :: finsweep
- !!! final smoothing sweeps in the finest level
- INTEGER, INTENT(IN) :: restrsweep
- !!! Number of smoothing sweeps after each restriction step
- !!! IMPORTANT: This parameter is considere important
- INTEGER, INTENT(IN) :: prolsweep
- !!! Number of smoothing sweeps after each prolongation step
- 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 => NULL()
- TYPE(ppm_t_equi_mesh), POINTER :: mesh => NULL()
-#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
-#if __MESH_DIM == __2D
- INTEGER,DIMENSION(3) :: ldl3,ldu3
- INTEGER,DIMENSION(4) :: ldl4,ldu4
-#endif
- INTEGER :: topoid,iopt,idom
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_sca_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_sca_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_sca_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_sca_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_2d_vec_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_2d_vec_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- TYPE(mg_field_3d_vec_s),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#elif __KIND == __DOUBLE_PRECISION
- TYPE(mg_field_3d_vec_d),DIMENSION(:,:),POINTER :: mgfield => NULL()
-#endif
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: uc_dummy => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy => NULL()
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: uc_dummy => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:,:),POINTER :: uc_dummy => NULL()
-#endif
-#endif
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:),POINTER :: tuc => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc => NULL()
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK),DIMENSION(:,:,:),POINTER :: tuc => NULL()
-#elif __MESH_DIM == __3D
- REAL(MK),DIMENSION(:,:,:,:),POINTER :: tuc => NULL()
-#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
- ELSE
- MPI_PREC = MPI_DOUBLE_PRECISION
- ENDIF
-#endif
- topoid=topo_id
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mg_meshid(1))
- !----------------------------------------------------------------------
- ! Check arguments
- !----------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- CALL check()
- ENDIF
- !----------------------------------------------------------------------
- ! Definition of necessary variables and allocation of arrays
- !----------------------------------------------------------------------
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
-#if __DIM == __SFIELD
- mgfield=>mgfield_2d_sca_s
-#elif __DIM == __VFIELD
- mgfield=>mgfield_2d_vec_s
-#endif
- rdx2=rdx2_s
- rdy2=rdy2_s
- dx=dx_s
- dy=dy_s
-#elif __KIND == __DOUBLE_PRECISION
-#if __DIM == __SFIELD
- mgfield=>mgfield_2d_sca_d
-#elif __DIM == __VFIELD
- mgfield=>mgfield_2d_vec_d
-#endif
- rdx2=rdx2_d
- rdy2=rdy2_d
- dx=dx_d
- dy=dy_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
-#if __DIM == __SFIELD
- mgfield=>mgfield_3d_sca_s
-#elif __DIM == __VFIELD
- mgfield=>mgfield_3d_vec_s
-#endif
- rdx2=rdx2_s
- rdy2=rdy2_s
- rdz2=rdz2_s
- dx=dx_s
- dy=dy_s
- dz=dz_s
-#elif __KIND == __DOUBLE_PRECISION
-#if __DIM == __SFIELD
- mgfield=>mgfield_3d_sca_d
-#elif __DIM == __VFIELD
- mgfield=>mgfield_3d_vec_d
-#endif
- rdx2=rdx2_d
- rdy2=rdy2_d
- rdz2=rdz2_d
- dx=dx_d
- dy=dy_d
- dz=dz_d
-#endif
-#endif
- 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
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1
- ldu3(1) = max_node(1,i)+ghostsize(1)
- ldu3(2) = max_node(2,i)+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,'ppm_mg_solv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- uc_dummy(:,:,:)=0.0_MK
-#elif __MESH_DIM ==__3D
- 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,i)+ghostsize(1)
- ldu4(2) = max_node(2,i)+ghostsize(2)
- ldu4(3) = max_node(3,i)+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,'ppm_mg_solv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- uc_dummy(:,:,:,:)=0.0_MK
-#endif
-#if __MESH_DIM == __2D
- iopt = ppm_param_dealloc
- ldl3(1) = 1-ghostsize(1)
- ldl3(2) = 1-ghostsize(2)
- ldl3(3) = 1
- ldu3(1) = max_node(1,i)+ghostsize(1)
- ldu3(2) = max_node(2,i)+ghostsize(2)
- ldu3(3) = 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,'ppm_mg_solv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __MESH_DIM ==__3D
- 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,i)+ghostsize(1)
- ldu4(2) = max_node(2,i)+ghostsize(2)
- ldu4(3) = max_node(3,i)+ghostsize(3)
- ldu4(4) = 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,'ppm_mg_solv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- 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,i)+ghostsize(1)
- ldu4(3) = max_node(2,i)+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,'ppm_mg_solv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- uc_dummy(:,:,:,:)=0.0_MK
-#elif __MESH_DIM ==__3D
- 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,i)+ghostsize(1)
- ldu5(3) = max_node(2,i)+ghostsize(2)
- ldu5(4) = max_node(3,i)+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,'ppm_mg_solv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
- uc_dummy(:,:,:,:,:)=0.0_MK
-#endif
-#if __MESH_DIM == __2D
- iopt = ppm_param_dealloc
- ldl4(1) = 1-ghostsize(1)
- ldl4(1) = 1-ghostsize(2)
- ldl4(1) = 1
- ldu4(1) = max_node(1,i)+ghostsize(1)
- ldu4(2) = max_node(2,i)+ghostsize(2)
- ldu4(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,'ppm_mg_solv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __MESH_DIM ==__3D
- iopt = ppm_param_dealloc
- ldl5(1) = 1-ghostsize(1)
- ldl5(2) = 1-ghostsize(2)
- ldl5(3) = 1-ghostsize(3)
- ldl5(4) = 1
- ldu5(1) = max_node(1,i)+ghostsize(1)
- ldu5(2) = max_node(2,i)+ghostsize(2)
- ldu5(3) = max_node(3,i)+ghostsize(3)
- ldu5(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,'ppm_mg_solv', &
- & 'uc_dummy',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
-#endif
- ENDDO
- ncalls=ncalls+1
- ENDIF
- !----------------------------------------------------------------------
- ! DO initial sweeps in the finest mesh with the smoother 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,initsweep,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
- GOTO 9999
- ENDIF
- IF (ppm_debug.NE.0) THEN
- WRITE(cbuf,*) 'initial sweep Eu:',E
- CALL PPM_Write(ppm_rank,'mg_solv_serial',cbuf,info)
- ENDIF
- !---------------------------------------------------------------------
- !Initiation of the function correction. (We start on purpose with lev=2)
- !----------------------------------------------------------------------
- DO mlev=2,maxlev
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- tuc(i,j)=0.0_MK
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- ! Run Multigrid core routine (execute smoothing, restriction,
- ! prologongation cycles)
- !----------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_core_2d_sca_s(topo_id,2,restrsweep,prolsweep,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_core_2d_sca_d(topo_id,2,restrsweep,prolsweep,info)
-#endif
- !----------------------------------------------------------------------
- !PROLONG the solution to the finest grid
- !----------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_prolong_2d_sca_s(1,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_prolong_2d_sca_d(1,info)
-#endif
- !----------------------------------------------------------------------
- !UPDATE THE FUNCTION
- !----------------------------------------------------------------------
- DO isub=1,nsubs
- !tuc=>mgfield(isub,mlev)%uc
- tuc=>mgfield(isub,1)%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
- !----------------------------------------------------------------------
- ! 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
- GOTO 9999
- ENDIF
- IF (ppm_debug.NE.0) THEN
- WRITE(cbuf,*) 'V cycle Eu:',E
- CALL PPM_Write(ppm_rank,'mg_solv_serial',cbuf,info)
- ENDIF
- !----------------------------------------------------------------------
- !DO the final sweeps
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_sca(topo_id,u,f,finsweep,1,c1,c2,c3,info)
- CALL ppm_mg_res_sca(topo_id,u,f,c1,c2,c3,c4,E,info)
-#ifdef __MPI
- CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
- Eu=gEu
-#else
- Eu=E
-#endif
- IF (info .NE. 0) THEN
- GOTO 9999
- ENDIF
- IF (ppm_debug.NE.0) THEN
- WRITE(cbuf,*) 'final sweeps Eu:',Eu
- CALL PPM_Write(ppm_rank,'mg_solv_serial',cbuf,info)
- 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,initsweep,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 (ppm_debug.NE.0) THEN
- WRITE(cbuf,*) 'Eu:',E
- CALL PPM_WRITE(ppm_rank,'mg_solv',cbuf,info)
- ENDIF
- !---------------------------------------------------------------------
- !Initiation of the function correction. (We start on purpose with lev=2)
- !----------------------------------------------------------------------
- DO mlev=2,maxlev
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=start(3,isub,mlev),istop(3,isub,mlev)
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- tuc(i,j,k)=0.0_MK
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- !CALL THE MULTIGRID TO DO NICE STUFF TO OUR FUNCTION
- !----------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_core_3d_sca_s(topo_id,2,restrsweep,prolsweep,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_core_3d_sca_d(topo_id,2,restrsweep,prolsweep,info)
-#endif
- !----------------------------------------------------------------------
- !PROLONG the solution to the finest grid
- !----------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_prolong_3d_sca_s(1,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_prolong_3d_sca_d(1,info)
-#endif
- !----------------------------------------------------------------------
- !UPDATE THE FUNCTION
- !----------------------------------------------------------------------
- DO isub=1,nsubs
- !tuc=>mgfield(isub,mlev)%uc
- tuc=>mgfield(isub,1)%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
- !----------------------------------------------------------------------
- !DO the final sweeps
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_sca(topo_id,u,f,finsweep,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
-#else
- Eu=E
-#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,initsweep,1,c1,c2,c3,info)
- !----------------------------------------------------------------------
- ! Compute residual
- !----------------------------------------------------------------------
- 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 (ppm_debug.GT.0) THEN
- WRITE(cbuf,*) 'Eu:',E
- CALL PPM_WRITE(ppm_rank,'mg_solv',cbuf,info)
- ENDIF
-
- !---------------------------------------------------------------------
- !Initiation of the function correction. (We start on purpose with lev=2)
- !----------------------------------------------------------------------
- DO mlev=2,maxlev
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
- DO ilda=1,vecdim
- tuc(ilda,i,j)=0.0_MK
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- !CALL THE MULTIGRID TO DO NICE STUFF TO OUR FUNCTION
- !----------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_core_2d_vec_s(topo_id,2,restrsweep,prolsweep,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_core_2d_vec_d(topo_id,2,restrsweep,prolsweep,info)
-#endif
- !----------------------------------------------------------------------
- !PROLONG the solution to the finest grid
- !----------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_prolong_2d_vec_s(1,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_prolong_2d_vec_d(1,info)
-#endif
- !----------------------------------------------------------------------
- !UPDATE THE FUNCTION
- !----------------------------------------------------------------------
- DO isub=1,nsubs
- !tuc=>mgfield(isub,mlev)%uc
- tuc=>mgfield(isub,1)%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)=tuc(ilda,i,j)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- !DO the final sweeps
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_vec(topo_id,u,f,finsweep,1,c1,c2,c3,info)
- CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,E,info)
-
-#ifdef __MPI
- CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
- Eu=gEu
-#else
- Eu=E
-#endif
-#elif __MESH_DIM == __3D
- c1 = 1.0_MK/(2.0_MK*(rdx2+rdy2+rdz2))
- c2 = rdx2
- c3 = rdy2
- c4 = rdz2
- c5 = 2.0_MK*c2+2.0_MK*c3+2.0_MK*c4
- CALL ppm_mg_smooth_vec(topo_id,u,f,initsweep,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 (ppm_debug.GT.0) THEN
- WRITE(cbuf,*) 'Eu:',E
- CALL PPM_WRITE(ppm_rank,'mg_solv',cbuf,info)
- ENDIF
- !---------------------------------------------------------------------
- !Initiation of the function correction. (We start on purpose with lev=2)
- !----------------------------------------------------------------------
- DO mlev=2,maxlev
- DO isub=1,nsubs
- tuc=>mgfield(isub,mlev)%uc
- DO k=start(3,isub,mlev),istop(3,isub,mlev)
- DO j=start(2,isub,mlev),istop(2,isub,mlev)
- DO i=start(1,isub,mlev),istop(1,isub,mlev)
-#ifdef __VECTOR
- tuc(1,i,j,k)=0.0_MK
- tuc(2,i,j,k)=0.0_MK
- tuc(3,i,j,k)=0.0_MK
-#else
- DO ilda=1,vecdim
- tuc(ilda,i,j,k)=0.0_MK
- ENDDO
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- !CALL THE MULTIGRID TO DO NICE STUFF TO OUR FUNCTION
- !----------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_core_3d_vec_s(topo_id,2,restrsweep,prolsweep,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_core_3d_vec_d(topo_id,2,restrsweep,prolsweep,info)
-#endif
- !----------------------------------------------------------------------
- !PROLONG the solution to the finest grid
- !----------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_mg_prolong_3d_vec_s(1,info)
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_mg_prolong_3d_vec_d(1,info)
-#endif
- !----------------------------------------------------------------------
- !UPDATE THE FUNCTION
- !----------------------------------------------------------------------
- DO isub=1,nsubs
- !tuc=>mgfield(isub,mlev)%uc
- tuc=>mgfield(isub,1)%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)=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)=tuc(ilda,i,j,k)
- ENDDO
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- !DO the final sweeps
- !--------------------------------------------------------------------
- CALL ppm_mg_smooth_vec(topo_id,u,f,finsweep,1,c1,c2,c3,c4,info)
- CALL ppm_mg_res_vec(topo_id,u,f,c1,c2,c3,c4,c5,E,info)
-#ifdef __MPI
- CALL MPI_AllReduce(E,gEu,1,MPI_PREC,MPI_MAX,ppm_comm,info)
- Eu=gEu
-#else
- Eu=E
-#endif
-#endif
-#endif
- !----------------------------------------------------------------------
- ! Return
- !----------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_mg_solv',t0,info)
- RETURN
- CONTAINS
-
- SUBROUTINE check
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- IF (SIZE(u,3) .LT. nsubs) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'solution exist on nsubs subdomains',__LINE__,info)
- GOTO 8888
- ENDIF
- DO i=1,nsubs
- idom=topo%isublist(i)
- IF (SIZE(u(:,:,i),1).LT.mesh%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 8888
- ENDIF
- IF (SIZE(u(:,:,i),2).LT.mesh%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 8888
- ENDIF
- ENDDO
- IF (SIZE(f,3) .LT. nsubs) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs exist on nsubs subdomains!',__LINE__,info)
- GOTO 8888
- ENDIF
- DO i=1,nsubs
- idom=topo%isublist(i)
- IF (SIZE(f(:,:,i),1).LT. mesh%nnodes(1,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in x-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- IF (SIZE(f(:,:,i),2).LT. mesh%nnodes(2,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in y-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
-#elif __MESH_DIM == __3D
- IF (SIZE(u,4) .LT. nsubs) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'solution exist on nsubs subdomains!',__LINE__,info)
- GOTO 8888
- ENDIF
- DO i=1,nsubs
- idom=topo%isublist(i)
- IF (SIZE(u(:,:,:,i),1).LT.mesh%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 8888
- ENDIF
- IF (SIZE(u(:,:,:,i),2).LT.mesh%nnodes(2,idom)+ &
- & 2*ghostsize(1)) 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 8888
- ENDIF
- IF (SIZE(u(:,:,:,i),3).LT.mesh%nnodes(3,idom)+ &
- & 2*ghostsize(1)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'solution mess with mesh points in z-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
- IF (SIZE(f,4) .LT. nsubs) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs exist on nsubs subdomains!',__LINE__,info)
- GOTO 8888
- ENDIF
- DO i=1,nsubs
- idom=topo%isublist(i)
- IF (SIZE(f(:,:,:,i),1).LT.mesh%nnodes(1,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in x-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- IF (SIZE(f(:,:,:,i),2).LT.mesh%nnodes(2,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in y-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- IF (SIZE(f(:,:,:,i),3).LT.mesh%nnodes(3,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in z-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
- IF (SIZE(u,4) .LT. nsubs) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'solution exist on nsubs subdomains',__LINE__,info)
- GOTO 8888
- ENDIF
- DO i=1,nsubs
- idom=topo%isublist(i)
- IF (SIZE(u(:,:,:,i),2).LT.mesh%nnodes(1,idom)+2) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'solution mess with mesh points in x-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- IF (SIZE(u(:,:,:,i),3).LT.mesh%nnodes(2,idom)+2) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'solution mess with mesh points in y-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
- IF (SIZE(f,4) .LT. nsubs) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs exist on nsubs subdomains!',__LINE__,info)
- GOTO 8888
- ENDIF
- DO i=1,nsubs
- idom=topo%isublist(i)
- IF (SIZE(f(:,:,:,i),2).LT.mesh%nnodes(1,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in x-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- IF (SIZE(f(:,:,:,i),3).LT.mesh%nnodes(2,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in y-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
-#elif __MESH_DIM == __3D
- IF (SIZE(u,5) .LT. nsubs) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'solution exist on nsubs subdomains!',__LINE__,info)
- GOTO 8888
- ENDIF
- DO i=1,nsubs
- idom=topo%isublist(i)
- IF (SIZE(u(:,:,:,:,i),2).LT.mesh%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 8888
- ENDIF
- IF (SIZE(u(:,:,:,:,i),3).LT.mesh%nnodes(2,idom)+ &
- & 2*ghostsize(1)) 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 8888
- ENDIF
- IF (SIZE(u(:,:,:,:,i),4).LT.mesh%nnodes(3,idom)+ &
- & 2*ghostsize(1)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'solution mess with mesh points in z-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
- IF (SIZE(f,5) .LT. nsubs) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs exist on nsubs subdomains!',__LINE__,info)
- GOTO 8888
- ENDIF
- DO i=1,nsubs
- idom=topo%isublist(i)
- IF (SIZE(f(:,:,:,:,i),2).LT.mesh%nnodes(1,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in x-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- IF (SIZE(f(:,:,:,:,i),3).LT.mesh%nnodes(2,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in y-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- IF (SIZE(f(:,:,:,:,i),4).LT.mesh%nnodes(3,idom)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_mg_solv', &
- & 'rhs mess with mesh points in z-dir!',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
-#endif
-#endif
-
-8888 CONTINUE
- RETURN
-
- END SUBROUTINE check
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_solv_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_solv_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_solv_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_solv_3d_sca_d
-#endif
-#endif
-#elif __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_solv_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_solv_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_mg_solv_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_mg_solv_3d_vec_d
-#endif
-#endif
-#endif
diff --git a/src/ppm_ode_alldone.f b/src/ode/ppm_ode_alldone.f
similarity index 100%
rename from src/ppm_ode_alldone.f
rename to src/ode/ppm_ode_alldone.f
diff --git a/src/ppm_ode_create_ode.f b/src/ode/ppm_ode_create_ode.f
similarity index 100%
rename from src/ppm_ode_create_ode.f
rename to src/ode/ppm_ode_create_ode.f
diff --git a/src/ppm_ode_finalize.f b/src/ode/ppm_ode_finalize.f
similarity index 100%
rename from src/ppm_ode_finalize.f
rename to src/ode/ppm_ode_finalize.f
diff --git a/src/ppm_ode_init.f b/src/ode/ppm_ode_init.f
similarity index 100%
rename from src/ppm_ode_init.f
rename to src/ode/ppm_ode_init.f
diff --git a/src/ppm_ode_map_pop.f b/src/ode/ppm_ode_map_pop.f
similarity index 100%
rename from src/ppm_ode_map_pop.f
rename to src/ode/ppm_ode_map_pop.f
diff --git a/src/ppm_ode_map_push.f b/src/ode/ppm_ode_map_push.f
similarity index 100%
rename from src/ppm_ode_map_push.f
rename to src/ode/ppm_ode_map_push.f
diff --git a/src/ppm_ode_modalloc.h b/src/ode/ppm_ode_modalloc.h
similarity index 100%
rename from src/ppm_ode_modalloc.h
rename to src/ode/ppm_ode_modalloc.h
diff --git a/src/ppm_ode_rhsfunc_macro.h b/src/ode/ppm_ode_rhsfunc_macro.h
similarity index 100%
rename from src/ppm_ode_rhsfunc_macro.h
rename to src/ode/ppm_ode_rhsfunc_macro.h
diff --git a/src/ppm_ode_start.f b/src/ode/ppm_ode_start.f
similarity index 100%
rename from src/ppm_ode_start.f
rename to src/ode/ppm_ode_start.f
diff --git a/src/ppm_ode_step.f b/src/ode/ppm_ode_step.f
similarity index 100%
rename from src/ppm_ode_step.f
rename to src/ode/ppm_ode_step.f
diff --git a/src/poisson/ppm_poisson_extrapolateghost.f b/src/poisson/ppm_poisson_extrapolateghost.f
deleted file mode 100644
index 08fc0972eab6f3a9887fa148bd0909805816fe30..0000000000000000000000000000000000000000
--- a/src/poisson/ppm_poisson_extrapolateghost.f
+++ /dev/null
@@ -1,265 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_poisson_extrapolateghost.f90
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !-------------------------------------------------------------------------
- SUBROUTINE __ROUTINE(topoid,meshid,field,nextra,nbase,gstw,info)
- !!! This routine extrapolates field values of field with topology and mesh
- !!! id topoid,meshid respectively into the ghost layer of width gstw.
- !!! nbase points are used to extrapolate into nextra points.
- !!!
- !!! [NOTE]
- !!! Presently extrapolation can only be done to 1 or two points into the
- !!! ghostlayer always based on 4 points (fourth order spatial convergence)
- !!! A general nbase,nextra extrapolation can be implemented vi solution
- !!! of a small linear system of equations. This has not been done.
- !!! This routine is in need of loop unrollling in particular for
- !!! typical choices of nbase,nextra pairs. Extrapolation is necessary for
- !!! e.g. freespace FD curl of stream function
-
- USE ppm_module_topo_get
-
-
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT(IN) :: topoid
- !!! Topology id of the field
- INTEGER, INTENT(IN) :: meshid
- !!! Mesh id of the field
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: field
- !!! Field to extrapolate ghost layer
- INTEGER, INTENT(IN) :: nextra
- !!! Number of points to extrapolate into the ghostlayer
- INTEGER, INTENT(IN) :: nbase
- !!! Number of points to base the extrapolation on
- INTEGER,DIMENSION(__DIM),INTENT(IN) :: gstw
- !!! Width of the ghotslayer
- INTEGER, INTENT(OUT) :: info
- !!! Return state
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER,PARAMETER :: MK = __PREC
- REAL(__PREC) :: t0
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
- INTEGER :: isub,isubl
- INTEGER :: i,j,k,iextra,ibase
- REAL(__PREC),DIMENSION(:,:),POINTER :: coeff
- REAL(__PREC),DIMENSION(__DIM) :: tmpbuf
-
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_poisson_extrapolateghost',t0,info)
-
-
- !-------------------------------------------------------------------------
- ! Compare the number of points to extrapolate to the ghost layer width
- !-------------------------------------------------------------------------
- IF (nextra .GT. gstw(1) .OR. &
- & nextra .GT. gstw(2) .OR. &
- & nextra .GT. gstw(3)) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_extrapolateghost',&
- & 'The points to extrapolate exceeds the ghost layer.',info)
- info = -1
- GOTO 9999
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Determine weights
- !-------------------------------------------------------------------------
- ALLOCATE(coeff(nbase,nextra))
- IF (nbase .EQ. 4) THEN
- IF (nextra .GE. 1) THEN
- coeff(:,1) = (/4.0_MK,-6.0_MK,4.0_MK,-1.0_MK/)
- ENDIF
- IF (nextra .GE. 2) THEN
- coeff(:,2) = (/10.0_MK,-20.0_MK,15.0_MK,-4.0_MK/)
- ENDIF
- IF (nextra .GE. 3) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_extrapolateghost',&
- & 'Extrapolation to more than two points has not been implemented.',info)
- info = -1
- GOTO 9999
- ENDIF
- ELSE
- CALL ppm_write(ppm_rank,'ppm_poisson_extrapolateghost',&
- & 'Only extrapolation based on 4 points has been implemented.',info)
- info = -1
- GOTO 9999
- ENDIF
-
-
- !-------------------------------------------------------------------------
- ! Get topology
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_extrapolateghost',&
- & 'Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- mesh = topology%mesh(meshid)
-
- !-------------------------------------------------------------------------
- ! Extrapolate field into ghost layer
- ! The indicies of subs_bc represent:
- ! west,east(x),south,north(y),bottom,top(z)
- !@ Some more unrolling here would be nice
- !-------------------------------------------------------------------------
- DO isub=1,topology%nsublist
- isubl=topology%isublist(isub)
- !West (-x)
- IF (topology%subs_bc(1,isubl) .EQ. 1) THEN
- DO k=1-gstw(3),mesh%nnodes(3,isubl)+gstw(3)
- DO j=1-gstw(2),mesh%nnodes(2,isubl)+gstw(2)
- !DO i=1-gstw(1),mesh%nnodes(1,isubl)+gstw(1)
- i = 1
- DO iextra=1,nextra
- tmpbuf = 0.0_MK
- DO ibase=0,nbase-1
- tmpbuf(1) = tmpbuf(1) + &
- & coeff(ibase+1,iextra)*field(1,i+ibase,j,k,isub)
- tmpbuf(2) = tmpbuf(2) + &
- & coeff(ibase+1,iextra)*field(2,i+ibase,j,k,isub)
- tmpbuf(3) = tmpbuf(3) + &
- & coeff(ibase+1,iextra)*field(3,i+ibase,j,k,isub)
- END DO !ibase
- field(1,i-iextra,j,k,isub) = tmpbuf(1)
- field(2,i-iextra,j,k,isub) = tmpbuf(2)
- field(3,i-iextra,j,k,isub) = tmpbuf(3)
- END DO !iextra
- ENDDO !j
- ENDDO !k
- ENDIF
- !East (+x)
- IF (topology%subs_bc(2,isubl) .EQ. 1) THEN
- DO k=1-gstw(3),mesh%nnodes(3,isubl)+gstw(3)
- DO j=1-gstw(2),mesh%nnodes(2,isubl)+gstw(2)
- !DO i=1-gstw(1),mesh%nnodes(1,isubl)+gstw(1)
- i = mesh%nnodes(1,isubl)
- DO iextra=1,nextra
- tmpbuf = 0.0_MK
- DO ibase=0,nbase-1
- tmpbuf(1) = tmpbuf(1) + &
- & coeff(ibase+1,iextra)*field(1,i-ibase,j,k,isub)
- tmpbuf(2) = tmpbuf(2) + &
- & coeff(ibase+1,iextra)*field(2,i-ibase,j,k,isub)
- tmpbuf(3) = tmpbuf(3) + &
- & coeff(ibase+1,iextra)*field(3,i-ibase,j,k,isub)
- END DO !ibase
- field(1,i+iextra,j,k,isub) = tmpbuf(1)
- field(2,i+iextra,j,k,isub) = tmpbuf(2)
- field(3,i+iextra,j,k,isub) = tmpbuf(3)
- END DO !iextra
- ENDDO !j
- ENDDO !k
- ENDIF
- !South (-y)
- IF (topology%subs_bc(3,isubl) .EQ. 1) THEN
- DO k=1-gstw(3),mesh%nnodes(3,isubl)+gstw(3)
- !DO j=1-gstw(2),mesh%nnodes(2,isubl)+gstw(2)
- DO i=1-gstw(1),mesh%nnodes(1,isubl)+gstw(1)
- j = 1
- DO iextra=1,nextra
- tmpbuf = 0.0_MK
- DO ibase=0,nbase-1
- tmpbuf(1) = tmpbuf(1) + &
- & coeff(ibase+1,iextra)*field(1,i,j+ibase,k,isub)
- tmpbuf(2) = tmpbuf(2) + &
- & coeff(ibase+1,iextra)*field(2,i,j+ibase,k,isub)
- tmpbuf(3) = tmpbuf(3) + &
- & coeff(ibase+1,iextra)*field(3,i,j+ibase,k,isub)
- END DO !ibase
- field(1,i,j-iextra,k,isub) = tmpbuf(1)
- field(2,i,j-iextra,k,isub) = tmpbuf(2)
- field(3,i,j-iextra,k,isub) = tmpbuf(3)
- END DO !iextra
- ENDDO !i
- ENDDO !k
- ENDIF
- !North (+y)
- IF (topology%subs_bc(4,isubl) .EQ. 1) THEN
- DO k=1-gstw(3),mesh%nnodes(3,isubl)+gstw(3)
- !DO j=1-gstw(2),mesh%nnodes(2,isubl)+gstw(2)
- DO i=1-gstw(1),mesh%nnodes(1,isubl)+gstw(1)
- j = mesh%nnodes(2,isubl)
- DO iextra=1,nextra
- tmpbuf = 0.0_MK
- DO ibase=0,nbase-1
- tmpbuf(1) = tmpbuf(1) + &
- & coeff(ibase+1,iextra)*field(1,i,j-ibase,k,isub)
- tmpbuf(2) = tmpbuf(2) + &
- & coeff(ibase+1,iextra)*field(2,i,j-ibase,k,isub)
- tmpbuf(3) = tmpbuf(3) + &
- & coeff(ibase+1,iextra)*field(3,i,j-ibase,k,isub)
- END DO !ibase
- field(1,i,j+iextra,k,isub) = tmpbuf(1)
- field(2,i,j+iextra,k,isub) = tmpbuf(2)
- field(3,i,j+iextra,k,isub) = tmpbuf(3)
- END DO !iextra
- ENDDO !i
- ENDDO !k
- ENDIF
- !Bottom (-z)
- IF (topology%subs_bc(5,isubl) .EQ. 1) THEN
- !DO k=1-gstw(3),mesh%nnodes(3,isubl)+gstw(3)
- DO j=1-gstw(2),mesh%nnodes(2,isubl)+gstw(2)
- DO i=1-gstw(1),mesh%nnodes(1,isubl)+gstw(1)
- k = 1
- DO iextra=1,nextra
- tmpbuf = 0.0_MK
- DO ibase=0,nbase-1
- tmpbuf(1) = tmpbuf(1) + &
- & coeff(ibase+1,iextra)*field(1,i,j,k+ibase,isub)
- tmpbuf(2) = tmpbuf(2) + &
- & coeff(ibase+1,iextra)*field(2,i,j,k+ibase,isub)
- tmpbuf(3) = tmpbuf(3) + &
- & coeff(ibase+1,iextra)*field(3,i,j,k+ibase,isub)
- END DO !ibase
- field(1,i,j,k-iextra,isub) = tmpbuf(1)
- field(2,i,j,k-iextra,isub) = tmpbuf(2)
- field(3,i,j,k-iextra,isub) = tmpbuf(3)
- END DO !iextra
- ENDDO !i
- ENDDO !j
- ENDIF
- !Top (+z)
- IF (topology%subs_bc(6,isubl) .EQ. 1) THEN
- !DO k=1-gstw(3),mesh%nnodes(3,isubl)+gstw(3)
- DO j=1-gstw(2),mesh%nnodes(2,isubl)+gstw(2)
- DO i=1-gstw(1),mesh%nnodes(1,isubl)+gstw(1)
- k = mesh%nnodes(3,isubl)
- DO iextra=1,nextra
- tmpbuf = 0.0_MK
- DO ibase=0,nbase-1
- tmpbuf(1) = tmpbuf(1) + &
- & coeff(ibase+1,iextra)*field(1,i,j,k-ibase,isub)
- tmpbuf(2) = tmpbuf(2) + &
- & coeff(ibase+1,iextra)*field(2,i,j,k-ibase,isub)
- tmpbuf(3) = tmpbuf(3) + &
- & coeff(ibase+1,iextra)*field(3,i,j,k-ibase,isub)
- END DO !ibase
- field(1,i,j,k+iextra,isub) = tmpbuf(1)
- field(2,i,j,k+iextra,isub) = tmpbuf(2)
- field(3,i,j,k+iextra,isub) = tmpbuf(3)
- END DO !iextra
- ENDDO !i
- ENDDO !j
- ENDIF
- ENDDO !isub
-
-
- 9999 CONTINUE
- CALL substop('ppm_poisson_extrapolateghost',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-
diff --git a/src/poisson/ppm_poisson_fd.f b/src/poisson/ppm_poisson_fd.f
deleted file mode 100644
index 8928ffaeaeaae342807648b1a5ad8ee5ed958449..0000000000000000000000000000000000000000
--- a/src/poisson/ppm_poisson_fd.f
+++ /dev/null
@@ -1,174 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_poisson_fd.f90
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !-------------------------------------------------------------------------
- SUBROUTINE __ROUTINE(topoid,meshid,fieldin,fieldout,dtype,info)
- !!! This routine computes the finite difference gradients, curl etc of
- !!! fieldin and outputs to fieldout. Both in and out fields are on
- !!! the mesh with meshid belonging to the topology with id topoid.
- !!! The finite difference to be carried out is determined by dtype which
- !!! must be one of the following:
- !!! * ppm_poisson_drv_curl_fd2
- !!! * ppm_poisson_drv_grad_fd2 (not implemented yet)
- !!! * ppm_poisson_drv_lapl_fd2 (not implemented yet)
- !!! * ppm_poisson_drv_div_fd2 (not implemented yet)
- !!! * ppm_poisson_drv_curl_fd4
- !!! * ppm_poisson_drv_grad_fd4 (not implemented yet)
- !!! * ppm_poisson_drv_lapl_fd4 (not implemented yet)
- !!! * ppm_poisson_drv_div_fd4 (not implemented yet)
- !!!
- !!! [NOTE] fieldin and fieldout must NOT be the same array. A check
- !!! should be added.
- !@ TODO: Somewhere check if fieldin is equal to fieldout and give a warning
-
- USE ppm_module_topo_get
-
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT(IN) :: topoid
- !!! ID of the topology
- INTEGER, INTENT(IN) :: meshid
- !!! Mesh ID
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: fieldin
- !!! Input field data
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: fieldout
- !!! Output field data
- INTEGER, INTENT(IN) :: dtype
- !!! Derivation type. Can be one of the types:
- !!! * ppm_poisson_drv_curl_fd2
- !!! * ppm_poisson_drv_grad_fd2 (not implemented yet)
- !!! * ppm_poisson_drv_lapl_fd2 (not implemented yet)
- !!! * ppm_poisson_drv_div_fd2 (not implemented yet)
- !!! * ppm_poisson_drv_curl_fd4
- !!! * ppm_poisson_drv_grad_fd4 (not implemented yet)
- !!! * ppm_poisson_drv_lapl_fd4 (not implemented yet)
- !!! * ppm_poisson_drv_div_fd4 (not implemented yet)
- INTEGER, INTENT(OUT) :: info
- !!! Return status, 0 upon succes
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER,PARAMETER :: MK = __PREC
- REAL(__PREC) :: t0
- TYPE(ppm_t_topo),POINTER :: topology
- TYPE(ppm_t_equi_mesh) :: mesh
- REAL(__PREC) :: dx,dy,dz
- REAL(__PREC) :: facx,facy,facz
- INTEGER :: isub,isubl
- INTEGER :: i,j,k
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_poisson_fd',t0,info)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_init_predef','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- mesh = topology%mesh(meshid)
-
- dx = (topology%max_physd(1)-topology%min_physd(1))/REAL(mesh%nm(1)-1) !vertex
- dy = (topology%max_physd(2)-topology%min_physd(2))/REAL(mesh%nm(2)-1)
- dz = (topology%max_physd(3)-topology%min_physd(3))/REAL(mesh%nm(3)-1)
-
- !-----------------------------------------------------------------------
- ! Do the finite difference calculation
- !-----------------------------------------------------------------------
- !-----------------------------------------------------------------------
- ! Curl, 2nd order FD
- !-----------------------------------------------------------------------
- IF (dtype .EQ. ppm_poisson_drv_curl_fd2) THEN
- facx = 1.0_MK/(2.0_MK*dx)
- facy = 1.0_MK/(2.0_MK*dy)
- facz = 1.0_MK/(2.0_MK*dz)
-
- DO isub=1,topology%nsublist
- isubl=topology%isublist(isub)
- DO k=1,mesh%nnodes(3,isubl)
- DO j=1,mesh%nnodes(2,isubl)
- DO i=1,mesh%nnodes(1,isubl)
- fieldout(1,i,j,k,isub) = &
- & facy*(fieldin(3,i ,j+1,k ,isub)- &
- & fieldin(3,i ,j-1,k ,isub)) &
- & -facz*(fieldin(2,i ,j ,k+1,isub)- &
- & fieldin(2,i ,j ,k-1,isub))
- fieldout(2,i,j,k,isub) = &
- & facz*(fieldin(1,i ,j ,k+1,isub)- &
- & fieldin(1,i ,j ,k-1,isub)) &
- & -facx*(fieldin(3,i+1,j ,k ,isub)- &
- & fieldin(3,i-1,j ,k ,isub))
- fieldout(3,i,j,k,isub) = &
- & facx*(fieldin(2,i+1,j ,k ,isub)- &
- & fieldin(2,i-1,j ,k ,isub)) &
- & -facy*(fieldin(1,i ,j+1,k ,isub)- &
- & fieldin(1,i ,j-1,k ,isub))
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- !-----------------------------------------------------------------------
- ! Curl, 4th order FD
- !-----------------------------------------------------------------------
- ELSE IF (dtype .EQ. ppm_poisson_drv_curl_fd4) THEN
- facx = 1.0_MK/(12.0_MK*dx)
- facy = 1.0_MK/(12.0_MK*dy)
- facz = 1.0_MK/(12.0_MK*dz)
-
- DO isub=1,topology%nsublist
- isubl=topology%isublist(isub)
- DO k=1,mesh%nnodes(3,isubl)
- DO j=1,mesh%nnodes(2,isubl)
- DO i=1,mesh%nnodes(1,isubl)
- fieldout(1,i,j,k,isub) = &
- & facy*( -fieldin(3,i ,j+2,k ,isub) &
- & +8.0_MK*fieldin(3,i ,j+1,k ,isub) &
- & -8.0_MK*fieldin(3,i ,j-1,k ,isub) &
- & +fieldin(3,i ,j-2,k ,isub)) &
- & -facz*( -fieldin(2,i ,j ,k+2,isub) &
- & +8.0_MK*fieldin(2,i ,j ,k+1,isub) &
- & -8.0_MK*fieldin(2,i ,j ,k-1,isub) &
- & +fieldin(2,i ,j ,k-2,isub))
- fieldout(2,i,j,k,isub) = &
- & facz*( -fieldin(1,i ,j ,k+2,isub) &
- & +8.0_MK*fieldin(1,i ,j ,k+1,isub) &
- & -8.0_MK*fieldin(1,i ,j ,k-1,isub) &
- & +fieldin(1,i ,j ,k-2,isub)) &
- & -facx*( -fieldin(3,i+2,j ,k ,isub) &
- & +8.0_MK*fieldin(3,i+1,j ,k ,isub) &
- & -8.0_MK*fieldin(3,i-1,j ,k ,isub) &
- & +fieldin(3,i-2,j ,k ,isub))
- fieldout(3,i,j,k,isub) = &
- & facx*( -fieldin(2,i+2,j ,k ,isub) &
- & +8.0_MK*fieldin(2,i+1,j ,k ,isub) &
- & -8.0_MK*fieldin(2,i-1,j ,k ,isub) &
- & +fieldin(2,i-2,j ,k ,isub)) &
- & -facy*( -fieldin(1,i ,j+2,k ,isub) &
- & +8.0_MK*fieldin(1,i ,j+1,k ,isub) &
- & -8.0_MK*fieldin(1,i ,j-1,k ,isub) &
- & +fieldin(1,i ,j-2,k ,isub))
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_poisson_fd',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-
diff --git a/src/poisson/ppm_poisson_init.f b/src/poisson/ppm_poisson_init.f
deleted file mode 100644
index 9f00c90d38fa856a4ba86f993910bb9a139e8d1c..0000000000000000000000000000000000000000
--- a/src/poisson/ppm_poisson_init.f
+++ /dev/null
@@ -1,733 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_poisson_init.f90
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !-------------------------------------------------------------------------
- SUBROUTINE __ROUTINE(topoid,meshid,ppmpoisson,fieldin,fieldout,green,info&
- &,bc,derive)
- !!! Routine to initialise Greens function solution of the Poisson
- !!! equation. green is the flag defining which Greens function to use:
- !!! * ppm_poisson_grn_pois_per - Poisson equation, periodic boundaries
- !!! * ppm_poisson_grn_pois_fre - Poisson equation, freespace boundaries
- !!! * ppm_poisson_grn_reprojec - Do vorticity reprojection to kill divergence
- !!!
- !!! [NOTE]
- !!! fieldin is not preserved by this routine!
- !!! fieldin and fieldout must NOT be the same fields. In-place FFTs have
- !!! not been implemented.
- !!!
- !!! Eventually the routine should be overloaded to accept custom Greens
- !!! functions such that more general convolutions can be performed.
- !!! green should be expanded to include more buildin Greens functions.
- !!!
- !!! The routine should eventually accept an optional flag to toggle
- !!! deallocation of work arrays between calls to ppm_poisson_solve.
-
-
- USE ppm_module_mktopo
- USE ppm_module_topo_get
- USE ppm_module_mesh_define
- USE ppm_module_map_field
- USE ppm_module_map_field_global
- USE ppm_module_map
-
-
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT(IN) :: topoid
- !!! Topology ID
- INTEGER, INTENT(IN) :: meshid
- !!! Mesh ID
- TYPE(ppm_poisson_plan),INTENT(INOUT) :: ppmpoisson
- !!! The PPM Poisson plan type (inspired by the FFTW plan)
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: fieldin
- !!! Input data field. RHS to the Poisson equation/field to be convolved
- !@ strictly speaking fieldin is not being used in the init routine
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: fieldout
- !!! Output data field
- INTEGER, INTENT(IN) :: green
- !!!flag to select build-in Greens functions:
- !!!ppm_poisson_grn_pois_per - Poisson equation, periodic boundaries
- !!!ppm_poisson_grn_pois_fre - Poisson equation, freespace boundaries
- !!!ppm_poisson_grn_reprojec - Do vorticity reprojection to kill divergence
- !!!
- !!!Eventually this should also accept custom Greens function
- INTEGER, INTENT(OUT) :: info
- INTEGER,INTENT(IN),OPTIONAL :: bc
- !!!boundary condition for the convolution. Can be on of the following:
- !!!ppm_poisson_grn_pois_per, ppm_poisson_grn_pois_fre.
- !!!One could argue that this is redundant in the build-in case
- !@ Isnt this redundant because of green?
- INTEGER,INTENT(IN),OPTIONAL :: derive
- !!!flag to toggle various derivatives of the solution (not to be used with
- !!!green=ppm_poisson_grn_reprojec):
- !!! * ppm_poisson_drv_none
- !!! * ppm_poisson_drv_curl_sp (only for periodic BC)
- !!! * ppm_poisson_drv_grad_sp (not implemented)
- !!! * ppm_poisson_drv_lapl_sp (not implemented)
- !!! * ppm_poisson_drv_div_sp (not implemented)
- !!! * ppm_poisson_drv_curl_fd2
- !!! * ppm_poisson_drv_grad_fd2 (not implemented)
- !!! * ppm_poisson_drv_lapl_fd2 (not implemented)
- !!! * ppm_poisson_drv_div_fd2 (not implemented)
- !!! * ppm_poisson_drv_curl_fd4
- !!! * ppm_poisson_drv_grad_fd4 (not implemented)
- !!! * ppm_poisson_drv_lapl_fd4 (not implemented)
- !!! * ppm_poisson_drv_div_fd4 (not implemented)
- !!!
- !!! curl=curl, grad=gradient,lapl=laplace operator,div=divergence
- !!! sp=spectrally, fd2=2nd order finite differences, fd4=4th order FD
- !!!
- !!!The spectral derivatives can only be computed in this routine. Since
- !!!the flag exists finite difference derivatives have also been included.
-
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(__PREC) :: t0
- REAL(__PREC),DIMENSION(:,:),POINTER :: xp=>NULL() !particle positions
- TYPE(ppm_t_topo),POINTER :: topology=>NULL()
- TYPE(ppm_t_equi_mesh) :: mesh
- INTEGER ,DIMENSION(__DIM) :: indl,indu
- INTEGER,PARAMETER :: MK = __PREC
- REAL(__PREC),PARAMETER :: PI=ACOS(-1.0_MK) !@ use ppm pi
- REAL(__PREC) :: normfac
- !!!factor for the Greens function, including FFT normalization
- INTEGER :: i,j,k
- INTEGER :: kx,ky,kz
- INTEGER :: isubl,isub
- INTEGER,DIMENSION(__DIM*2) :: bcdef
- INTEGER :: assigning
- INTEGER :: decomposition
- INTEGER,SAVE :: ttopoid
- INTEGER :: tmeshid
- REAL(__PREC) :: dx,dy,dz
- REAL(__PREC) :: Lx2,Ly2,Lz2
- REAL(__PREC) :: rad !@
- REAL(__PREC) :: gzero
-
- REAL(__PREC),DIMENSION(__DIM) :: tmpmin,tmpmax
- INTEGER, DIMENSION(__DIM) :: maxndataxy,maxndataz
- INTEGER, DIMENSION(: ), POINTER :: dummynmxy,dummynmz
-
-
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_poisson_init',t0,info)
-
-
- !-------------------------------------------------------------------------
- ! Investigate optional arguments, setup routine accordingly
- ! !@TODO: Also check if the input/output and derivatives match
- !-------------------------------------------------------------------------
- IF (green .EQ. ppm_poisson_grn_pois_per) THEN
- ppmpoisson%case = ppm_poisson_grn_pois_per
- ELSE IF (green .EQ. ppm_poisson_grn_pois_fre) THEN
- ppmpoisson%case = ppm_poisson_grn_pois_fre
- ELSE IF (green .EQ. ppm_poisson_grn_reprojec) THEN
- ppmpoisson%case = ppm_poisson_grn_reprojec
- ENDIF
-
-
- !-------------------------------------------------------------------------
- ! Nullify pointers from the ppmpoisson plans and the fftplans
- !-------------------------------------------------------------------------
- NULLIFY(xp)
- NULLIFY(ppmpoisson%costxy)
- NULLIFY(ppmpoisson%istartxy)
- NULLIFY(ppmpoisson%ndataxy)
- NULLIFY(ppmpoisson%istartxyc)
- NULLIFY(ppmpoisson%ndataxyc)
- NULLIFY(ppmpoisson%costz)
- NULLIFY(ppmpoisson%istartz)
- NULLIFY(ppmpoisson%ndataz)
- NULLIFY(ppmpoisson%planfxy%plan)
- NULLIFY(ppmpoisson%planbxy%plan)
- NULLIFY(ppmpoisson%planfz%plan)
- NULLIFY(ppmpoisson%planbz%plan)
- NULLIFY(dummynmxy)
- NULLIFY(dummynmz)
-
- !-------------------------------------------------------------------------
- ! Get topology and mesh values of input/output
- !-------------------------------------------------------------------------
- CALL ppm_topo_get(topoid,topology,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_init','Failed to get topology.',isub)
- GOTO 9999
- ENDIF
- mesh = topology%mesh(meshid)
-
-
- !-------------------------------------------------------------------------
- ! Setup mesh sizes for intermediate meshes/topologies
- !-------------------------------------------------------------------------
- IF (green .EQ. ppm_poisson_grn_pois_per) THEN
- !size of real slabs
- ppmpoisson%nmxy (1) = mesh%nm(1)
- ppmpoisson%nmxy (2) = mesh%nm(2)
- ppmpoisson%nmxy (3) = mesh%nm(3)
- !size of complex slabs
- ppmpoisson%nmxyc(1) = (mesh%nm(1)-1)/2+1
- !!ppmpoisson%nmxyc(1) = mesh%nm(1)
- ppmpoisson%nmxyc(2) = mesh%nm(2)
- ppmpoisson%nmxyc(3) = mesh%nm(3)
- !size of complex pencils
- ppmpoisson%nmz (1) = (ppmpoisson%nmxyc(1))
- ppmpoisson%nmz (2) = (ppmpoisson%nmxyc(2))
- ppmpoisson%nmz (3) = (ppmpoisson%nmxyc(3))
- !size of the fft
- ppmpoisson%nmfft(1) = mesh%nm(1)-1
- ppmpoisson%nmfft(2) = mesh%nm(2)-1
- ppmpoisson%nmfft(3) = mesh%nm(3)-1
- !Inverse of the size of the domain squared
- Lx2 = 1.0_MK/(topology%max_physd(1)-topology%min_physd(1))**2
- Ly2 = 1.0_MK/(topology%max_physd(2)-topology%min_physd(2))**2
- Lz2 = 1.0_MK/(topology%max_physd(3)-topology%min_physd(3))**2
- ELSE IF (green .EQ. ppm_poisson_grn_pois_fre) THEN !vertex
- !size of real slabs
- ppmpoisson%nmxy (1) = mesh%nm(1)*2
- ppmpoisson%nmxy (2) = mesh%nm(2)*2
- ppmpoisson%nmxy (3) = mesh%nm(3)*2
- !size of complex slabs
- ppmpoisson%nmxyc(1) = (mesh%nm(1)*2)/2+1
- !!ppmpoisson%nmxyc(1) = mesh%nm(1)*2
- ppmpoisson%nmxyc(2) = mesh%nm(2)*2
- ppmpoisson%nmxyc(3) = mesh%nm(3)*2
- !size of complex pencils
- ppmpoisson%nmz (1) = (ppmpoisson%nmxyc(1))
- ppmpoisson%nmz (2) = (ppmpoisson%nmxyc(2))
- ppmpoisson%nmz (3) = (ppmpoisson%nmxyc(3))
- !size of the fft
- ppmpoisson%nmfft(1) = mesh%nm(1)*2
- ppmpoisson%nmfft(2) = mesh%nm(2)*2
- ppmpoisson%nmfft(3) = mesh%nm(3)*2
- !Determine the grid spacing !vertex
- dx = (topology%max_physd(1)-topology%min_physd(1))/(mesh%nm(1)-1)
- dy = (topology%max_physd(2)-topology%min_physd(2))/(mesh%nm(2)-1)
- dz = (topology%max_physd(3)-topology%min_physd(3))/(mesh%nm(3)-1)
- ENDIF
-
-
- !-------------------------------------------------------------------------
- ! Create temporary derivation arrays if necessary
- !-------------------------------------------------------------------------
- !!write(*,*) 'fieldout',ppm_rank, LBOUND(fieldout),UBOUND(fieldout)
- IF (PRESENT(derive)) THEN
- IF (( derive .EQ. ppm_poisson_drv_curl_fd2 &
- & .OR. derive .EQ. ppm_poisson_drv_curl_fd4)) THEN
- ppmpoisson%derivatives = derive
- ALLOCATE(ppmpoisson%drv_vr(LBOUND(fieldout,1):UBOUND(fieldout,1),&
- & LBOUND(fieldout,2):UBOUND(fieldout,2),&
- & LBOUND(fieldout,3):UBOUND(fieldout,3),&
- & LBOUND(fieldout,4):UBOUND(fieldout,4),&
- & LBOUND(fieldout,5):UBOUND(fieldout,5)))
- ELSE IF (derive .EQ. ppm_poisson_drv_curl_sp) THEN
- ppmpoisson%derivatives = ppm_poisson_drv_curl_sp
- !IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_fre) THEN
- !CALL ppm_write(ppm_rank,'ppm_poisson_init', &
- !& 'WARNING: Spectral curl is not fully implemented in Freespace.',isub)
- !ENDIF
- ELSE IF (derive .EQ. ppm_poisson_drv_none) THEN
- ppmpoisson%derivatives = ppm_poisson_drv_none
- ELSE
- CALL ppm_write(ppm_rank,'ppm_poisson_init','Undefined derivation input.',isub)
- GOTO 9999
- ENDIF
- ELSE
- ppmpoisson%derivatives = ppm_poisson_drv_none
- ENDIF
-
-
- !-------------------------------------------------------------------------
- ! Create spectral scaling components always. Just in case some
- ! reprojection comes up
- ! The conditionals need to be for not just the Poisson equation
- !-------------------------------------------------------------------------
- IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_per) THEN
- ppmpoisson%normkx = &
- & 2.0_MK*PI/(topology%max_physd(1)-topology%min_physd(1))
- ppmpoisson%normky = &
- & 2.0_MK*PI/(topology%max_physd(2)-topology%min_physd(2))
- ppmpoisson%normkz = &
- & 2.0_MK*PI/(topology%max_physd(3)-topology%min_physd(3))
- ELSE IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_fre) THEN
- ppmpoisson%normkx = &
- & 2.0_MK*PI/((topology%max_physd(1)-topology%min_physd(1))*2.0_MK)
- ppmpoisson%normky = &
- & 2.0_MK*PI/((topology%max_physd(2)-topology%min_physd(2))*2.0_MK)
- ppmpoisson%normkz = &
- & 2.0_MK*PI/((topology%max_physd(3)-topology%min_physd(3))*2.0_MK)
- ENDIF
-
-
- !-------------------------------------------------------------------------
- ! Create new slab topology
- !-------------------------------------------------------------------------
- ttopoid = 0
- tmeshid = -1
- decomposition = ppm_param_decomp_xy_slab
- assigning = ppm_param_assign_internal
- IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_per) THEN
- bcdef = ppm_param_bcdef_periodic
- ELSE IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_fre) THEN
- bcdef = ppm_param_bcdef_freespace
- ENDIF
- tmpmin = topology%min_physd
- tmpmax = topology%max_physd
-
-
- CALL ppm_mktopo(ttopoid,tmeshid,xp,0,&
- & decomposition,assigning,&
- & tmpmin,tmpmax,bcdef,&
- & __ZEROSI,ppmpoisson%costxy,&
- & ppmpoisson%nmxy,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_init','Failed to create xy-topology.',isub)
- GOTO 9999
- ENDIF
- ppmpoisson%topoidxy = ttopoid
- ppmpoisson%meshidxy = tmeshid
- !-------------------------------------------------------------------------
- ! Get additional xy-mesh information
- !-------------------------------------------------------------------------
- CALL ppm_topo_get_meshinfo(ppmpoisson%topoidxy,ppmpoisson%meshidxy, &
- & dummynmxy,ppmpoisson%istartxy,ppmpoisson%ndataxy,maxndataxy, &
- & ppmpoisson%isublistxy,ppmpoisson%nsublistxy,info)
-
-
- !-------------------------------------------------------------------------
- ! Create complex slab mesh
- !-------------------------------------------------------------------------
- ttopoid = ppmpoisson%topoidxy
- tmeshid = -1
- CALL ppm_mesh_define(ttopoid,tmeshid,&
- & ppmpoisson%nmxyc,ppmpoisson%istartxyc,ppmpoisson%ndataxyc,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_init','Failed to create complex xy mesh definition.',isub)
- GOTO 9999
- ENDIF
- ppmpoisson%meshidxyc = tmeshid
-
-
- !-------------------------------------------------------------------------
- ! Create new pencil topology
- !-------------------------------------------------------------------------
- ttopoid = 0
- tmeshid = -1
- IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_per) THEN
- bcdef = ppm_param_bcdef_periodic
- ELSE IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_fre) THEN
- bcdef = ppm_param_bcdef_freespace
- ENDIF
- assigning = ppm_param_assign_internal
- decomposition = ppm_param_decomp_zpencil
-
- CALL ppm_mktopo(ttopoid,tmeshid,xp,0,&
- & decomposition,assigning,&
- & tmpmin,tmpmax,bcdef,&
- & __ZEROSI,ppmpoisson%costz,&
- & ppmpoisson%nmz,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_init','Failed to create z-topology.',isub)
- GOTO 9999
- ENDIF
- ppmpoisson%topoidz = ttopoid
- ppmpoisson%meshidz = tmeshid
- !-------------------------------------------------------------------------
- ! Get additional z-mesh information
- !-------------------------------------------------------------------------
- CALL ppm_topo_get_meshinfo(ppmpoisson%topoidz,ppmpoisson%meshidz, &
- & dummynmz,ppmpoisson%istartz,ppmpoisson%ndataz,maxndataz, &
- & ppmpoisson%isublistz,ppmpoisson%nsublistz,info)
-
-
- !-------------------------------------------------------------------------
- ! Set and get minimum and maximum indicies
- !-------------------------------------------------------------------------
- indl(1) = 1
- indl(2) = 1
- indl(3) = 1
-
- !-------------------------------------------------------------------------
- ! Allocate real xy slabs
- !-------------------------------------------------------------------------
- ALLOCATE(ppmpoisson%fldxyr(__DIM,&
- & indl(1):maxndataxy(1),indl(2):maxndataxy(2),indl(3):maxndataxy(3),&
- & 1:ppmpoisson%nsublistxy),stat=info)
-
-
- !-------------------------------------------------------------------------
- ! Set and get minimum and maximum indicies of COMPLEX xy slabs
- !-------------------------------------------------------------------------
- indl(1) = 1
- indl(2) = 1
- indl(3) = 1
- indu(1) = 0
- indu(2) = 0
- indu(3) = 0
- DO isub=1,ppmpoisson%nsublistxy
- isubl = ppmpoisson%isublistxy(isub)
- indu(1) = MAX(indu(1),ppmpoisson%ndataxyc(1,isubl))
- indu(2) = MAX(indu(2),ppmpoisson%ndataxyc(2,isubl))
- indu(3) = MAX(indu(3),ppmpoisson%ndataxyc(3,isubl))
- ENDDO
-
-
- !-------------------------------------------------------------------------
- ! Allocate complex xy slabs
- !-------------------------------------------------------------------------
- ALLOCATE(ppmpoisson%fldxyc(__DIM,&
- & indl(1):indu(1),indl(2):indu(2),indl(3):indu(3),&
- & 1:ppmpoisson%nsublistxy),stat=info)
-
-
- !-------------------------------------------------------------------------
- ! Allocate two complex z pencils + Greens fcn array !@check return vars.
- !-------------------------------------------------------------------------
- ALLOCATE(ppmpoisson%fldzc1(__DIM,&
- & indl(1):maxndataz(1),indl(2):maxndataz(2),indl(3):maxndataz(3),&
- & 1:ppmpoisson%nsublistz),stat=info)
-
- ALLOCATE(ppmpoisson%fldzc2(__DIM,&
- & indl(1):maxndataz(1),indl(2):maxndataz(2),indl(3):maxndataz(3),&
- & 1:ppmpoisson%nsublistz),stat=info)
-
-
- !-------------------------------------------------------------------------
- ! The complex Greens function is always kept on the z-pencil topology
- !-------------------------------------------------------------------------
- IF (green .EQ. ppm_poisson_grn_pois_per) THEN
- !!ALLOCATE(ppmpoisson%fldgrnr(&
- !!& indl(1):indu(1),indl(2):indu(2),indl(3):indu(3),&
- !!& 1:ppmpoisson%nsublistz),stat=info)
- ALLOCATE(ppmpoisson%fldgrnr(&
- & indl(1):maxndataz(1),indl(2):maxndataz(2),indl(3):maxndataz(3),&
- & 1:ppmpoisson%nsublistz),stat=info)
- ELSE IF (green .EQ. ppm_poisson_grn_pois_fre) THEN
- !!ALLOCATE(ppmpoisson%fldgrnc(&
- !!& indl(1):indu(1),indl(2):indu(2),indl(3):indu(3),&
- !!& 1:ppmpoisson%nsublistz),stat=info)
- ALLOCATE(ppmpoisson%fldgrnc(&
- & indl(1):maxndataz(1),indl(2):maxndataz(2),indl(3):maxndataz(3),&
- & 1:ppmpoisson%nsublistz),stat=info)
- ENDIF
-
-
- !-------------------------------------------------------------------------
- ! Set up xy FFT plans
- ! The inverse plan takes the returning topology since it has the full size
- !-------------------------------------------------------------------------
- CALL ppm_fft_forward_2d(ppmpoisson%topoidxy,ppmpoisson%meshidxy,&
- & ppmpoisson%planfxy,ppmpoisson%fldxyr,&
- & ppmpoisson%fldxyc,info)
-
- CALL ppm_fft_backward_2d(ppmpoisson%topoidxy,ppmpoisson%meshidxy,&
- & ppmpoisson%planbxy,ppmpoisson%fldxyc,&
- & ppmpoisson%fldxyr,info)
-
-
- !-------------------------------------------------------------------------
- ! Set up z FFT plans
- !-------------------------------------------------------------------------
- CALL ppm_fft_forward_1d(ppmpoisson%topoidz,ppmpoisson%meshidz,&
- & ppmpoisson%planfz,ppmpoisson%fldzc1,&
- & ppmpoisson%fldzc2,info)
-
- CALL ppm_fft_backward_1d(ppmpoisson%topoidz,ppmpoisson%meshidz,&
- & ppmpoisson%planbz,ppmpoisson%fldzc2,&
- & ppmpoisson%fldzc1,info)
-
-
- !-------------------------------------------------------------------------
- ! Compute Greens function. Analytic, periodic
- !
- ! (d2_/dx2 + d2_/dy2 + d2_/dz2)psi = -omega =>
- ! -4*pi2(kx2 + ky2 + kz2)PSI = -OMEGA =>
- ! PSI = 1/(4*pi2)*1/(kx2 + ky2 + kz2)OMEGA
- !-------------------------------------------------------------------------
- IF (green .EQ. ppm_poisson_grn_pois_per) THEN
- ! Scaling the spectral coefficients...
- ! one minus due to (i*k)^2 and another due to the Poisson equation
- normfac = 1.0_MK/(4.0_MK*PI*PI * &
- !and normalisation of FFTs (full domain) !vertex
- & REAL((ppmpoisson%nmfft(1))* &
- & (ppmpoisson%nmfft(2))* &
- & (ppmpoisson%nmfft(3)),MK))
- DO isub=1,ppmpoisson%nsublistz
- isubl=ppmpoisson%isublistz(isub)
- DO k=1,ppmpoisson%ndataz(3,isubl)
- DO j=1,ppmpoisson%ndataz(2,isubl)
- DO i=1,ppmpoisson%ndataz(1,isubl)
- kx = i-1 + (ppmpoisson%istartz(1,isubl)-1)
- ky = j-1 + (ppmpoisson%istartz(2,isubl)-1)
- kz = k-1 + (ppmpoisson%istartz(3,isubl)-1)
- !This is a nasty way to do this but it is only done once so...:
- IF (kx .GT. (ppmpoisson%nmfft(1)/2)) kx = kx-(ppmpoisson%nmfft(1))
- IF (ky .GT. (ppmpoisson%nmfft(2)/2)) ky = ky-(ppmpoisson%nmfft(2))
- IF (kz .GT. (ppmpoisson%nmfft(3)/2)) kz = kz-(ppmpoisson%nmfft(3))
- ppmpoisson%fldgrnr(i,j,k,isub) = &
- & normfac/(REAL(kx*kx,__PREC)*Lx2 &
- & + REAL(ky*ky,__PREC)*Ly2 &
- & + REAL(kz*kz,__PREC)*Lz2)
- !Take care of singularity
- !This is nasty as well
- IF ((kx*kx+ky*ky+kz*kz) .EQ. 0) THEN
- ppmpoisson%fldgrnr(i,j,k,isub) = 0.0_MK
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-
-
- !-------------------------------------------------------------------------
- ! Compute real free space Greens function. Analytic
- ! The Greens function is initialised temporarily in the real xy slabs,
- ! then FFTed in those directions, mapped to z-pencils, FFTed in z and
- ! finally copied to ppmpoisson%fldgrnc. The real xy slabs have already
- ! been setup for FFTs etc so they offer a convenient container for the
- ! FFTing the Greens function instead of setting up the whole apparatus
- ! for this one-time affair.
- ! These loops must run over the padded(extended) domain thus %ndataxy
- ! \nabla \Psi = -\omega
- ! The Greens function is 1/4piR (R is distance to origo) and includes the
- ! minus of the RHS
- !-------------------------------------------------------------------------
- ELSE IF (green .EQ. ppm_poisson_grn_pois_fre) THEN
-#define __GFREESPACE
-!#define __GBLOB4
-
-!#define __GSPEC
- !-----------------------------------------------------------------------
- ! First initialise the real Greens function
- !@alternatively this could come from as input
- !-----------------------------------------------------------------------
- !there should NOT be a minus here since THIS Greens function takes
- !the minus of the Poisson equation into account
- normfac = 1.0_MK/(4.0_MK*PI* &
- !remembering FFT normalization of ALL points: !vertex
- & REAL((ppmpoisson%nmfft(1))* &
- & (ppmpoisson%nmfft(2))* &
- & (ppmpoisson%nmfft(3)),MK))*dx*dy*dz
- DO isub=1,ppmpoisson%nsublistxy
- isubl=ppmpoisson%isublistxy(isub)
- DO k=1,ppmpoisson%ndataxy(3,isubl)
- DO j=1,ppmpoisson%ndataxy(2,isubl)
- DO i=1,ppmpoisson%ndataxy(1,isubl)
- !kx,ky,kz implies that they are spectral coordinates. they are not
- kx = i-1 + (ppmpoisson%istartxy(1,isubl)-1)
- ky = j-1 + (ppmpoisson%istartxy(2,isubl)-1)
- kz = k-1 + (ppmpoisson%istartxy(3,isubl)-1)
- !This is a nasty way to do this but it is only done once so...:
- IF (kx .GT. (ppmpoisson%nmfft(1))/2) kx = kx-(ppmpoisson%nmfft(1))
- IF (ky .GT. (ppmpoisson%nmfft(2))/2) ky = ky-(ppmpoisson%nmfft(2))
- IF (kz .GT. (ppmpoisson%nmfft(3))/2) kz = kz-(ppmpoisson%nmfft(3))
- rad = SQRT( REAL(kx*kx,__PREC)*dx*dx+ &
- & REAL(ky*ky,__PREC)*dy*dy+ &
- & REAL(kz*kz,__PREC)*dz*dz)
- !----FREESPACE GREENS FUNCTION----
-#ifdef __GFREESPACE
- ppmpoisson%fldxyr(1,i,j,k,isub) = &
- & normfac/(SQRT( REAL(kx*kx,__PREC)*dx*dx+ &
- & REAL(ky*ky,__PREC)*dy*dy+ &
- & REAL(kz*kz,__PREC)*dz*dz))
-#endif
- !----BLOB----2nd ORDER---:
-#ifdef __GBLOB2
- ppmpoisson%fldxyr(1,i,j,k,isub) = &
- & normfac/(rad)*ERF(rad/(SQRT(2.0E0_MK)*dx))
- !& normfac/(rad)*ERF(rad/(1.0_MK*dx))
- !& normfac/(rad)*ERF(rad/1.0E-2_MK)
-#endif
- !----BLOB----4th ORDER---cell-normalised:
-#ifdef __GBLOB4
- ppmpoisson%fldxyr(1,i,j,k,isub) = &
- & normfac/(rad)* &
- & (ERF(rad/(dx*1.0_MK*SQRT(2.0_MK)))+ &
- & 1.0_MK/SQRT(PI)*rad/(dx*1.0_MK*SQRT(2.0_MK))* &
- & EXP(-rad**2/(dx*1.0_MK*SQRT(2.0_MK))**2))
-
- !---4th ORDER---unnormalised:
- !& (ERF(rad/SQRT(2.0_MK))+1.0_MK/SQRT(2.0_MK*PI)*rad* &
- !& EXP(-rad**2/2))
-#endif
- ppmpoisson%fldxyr(2,i,j,k,isub) = 0.0_MK
- ppmpoisson%fldxyr(3,i,j,k,isub) = 0.0_MK
- !Take care of singularity (This is nasty as well)
- !Simply zero
- !gzero = 0.0_MK
- !Simply one (H&E style)
- !gzero = 1.0_MK*normfac
- !Equal to the neighbour point (first order)
- !gzero = normfac/(dx)
- !Linear extrapolation into zero (2nd order)
- !gzero = 2.0_MK*normfac/( dx) &
- !& - 1.0_MK*normfac/(2.0_MK*dx)
- !extrapolation 3rd order
- !gzero = 3.0_MK*normfac/( dx) &
- !& - 3.0_MK*normfac/(2.0_MK*dx) &
- !& + 1.0_MK*normfac/(3.0_MK*dx)
- !extrapolation 4th order
- !gzero = 4.0_MK*normfac/( dx) &
- !& - 6.0_MK*normfac/(2.0_MK*dx) &
- !& + 4.0_MK*normfac/(3.0_MK*dx) &
- !& - 1.0_MK*normfac/(4.0_MK*dx)
- !extrapolation 6th order
- !gzero = 6.0_MK*normfac/( dx) &
- !& -15.0_MK*normfac/(2.0_MK*dx) &
- !& +20.0_MK*normfac/(3.0_MK*dx) &
- !& -15.0_MK*normfac/(4.0_MK*dx) &
- !& + 6.0_MK*normfac/(5.0_MK*dx) &
- !& - 1.0_MK*normfac/(6.0_MK*dx)
- !Finite difference fit 4th order (minimum max error adj. points)
- gzero = normfac*77.0_MK/(36.0_MK*dx) !4*pi is included in normfac
- !one thousand!!!
- !gzero = normfac*1000.0_MK
- !Chatelain:2010
- !gzero = &
- !& 0.5_MK*( 3.0_MK*dx*dy*dz/(4.0_MK*PI) ) ** (2.0_MK/3.0_MK) * &
- !& normfac *4.0_MK*PI
- !bi-section galore!!!!
- !gzero = normfac * &
- !Chatelain for dx=2/64:
- !& 0.00236131633889131295_MK
- !& 0.001_MK
- !& 0.01_MK
- !& 0.1_MK
- !& 1.0_MK
- !& 10.0_MK
- !& 100.0_MK
- !& 1.0E-4_MK
- !& 1.0E-5_MK
- !& 0.0_MK
- !& -0.001_MK
- !& -0.1_MK
- !& -10.0_MK
- !& -1000.0_MK
- !& -100.0_MK
- !& -20.0_MK
- !& -30.0_MK
- !Matching the blob (both 2nd and 4th order)
-#if defined __GBLOB2 || defined __GBLOB4
- gzero = 4.0_MK*PI*normfac/ &
- & (2.0_MK*PI**(3.0_MK/2.0_MK)* &
- !& SQRT(2.0_MK))
- & 1.0_MK*SQRT(2.0_MK)*dx)
- !& 0.01_MK)
- !!write(*,*) ERF(1.0_MK)
-#endif
- IF ((kx*kx+ky*ky+kz*kz) .EQ. 0) THEN
- !Professor Nutbutter is out.
- ppmpoisson%fldxyr(1,i,j,k,isub) = gzero
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! FOURIER TRANSFORM AND MAP GALORE
- ! This part should be used both for freespace and a custom Greens function
- !-------------------------------------------------------------------------
- !-----------------------------------------------------------------------
- ! Do slab FFT (XY)
- !-----------------------------------------------------------------------
- CALL ppm_fft_execute_2d(ppmpoisson%topoidxy,&
- & ppmpoisson%meshidxy, ppmpoisson%planfxy, &
- & ppmpoisson%fldxyr, ppmpoisson%fldxyc, &
- & info)
- !-----------------------------------------------------------------------
- ! Map to the pencils (Z)
- !-----------------------------------------------------------------------
- !Initialise
- CALL ppm_map_field_global(&
- & ppmpoisson%topoidxy, &
- & ppmpoisson%topoidz, &
- & ppmpoisson%meshidxyc, &
- & ppmpoisson%meshidz,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to initialise field mapping.',isub)
- GOTO 9999
- ENDIF
-
- !Push the data
- CALL ppm_map_field_push(&
- & ppmpoisson%topoidxy, &
- & ppmpoisson%meshidxyc,ppmpoisson%fldxyc,__NCOM,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to push vector field.',isub)
- GOTO 9999
- ENDIF
-
- !Send
- CALL ppm_map_field_send(info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to send field.',isub)
- GOTO 9999
- ENDIF
-
- !Retrieve
- CALL ppm_map_field_pop(&
- & ppmpoisson%topoidz, &
- & ppmpoisson%meshidz,ppmpoisson%fldzc1, &
- & __NCOM,__ZEROSI,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to pop vector field.',isub)
- GOTO 9999
- ENDIF
-
-
- !-----------------------------------------------------------------------
- ! Do pencil FFT (Z)
- !-----------------------------------------------------------------------
- CALL ppm_fft_execute_1d(ppmpoisson%topoidz,&
- & ppmpoisson%meshidz, ppmpoisson%planfz, &
- & ppmpoisson%fldzc1, ppmpoisson%fldzc2, &
- & info)
-
-
- !-----------------------------------------------------------------------
- ! Copy first component of the Fourier transformed vector to fldgrnc
- !-----------------------------------------------------------------------
- DO isub=1,ppmpoisson%nsublistz
- isubl=ppmpoisson%isublistz(isub)
- DO k=1,ppmpoisson%ndataz(3,isubl)
- DO j=1,ppmpoisson%ndataz(2,isubl)
- DO i=1,ppmpoisson%ndataz(1,isubl)
-#ifdef __GSPEC
- ppmpoisson%fldgrnc(i,j,k,isub) = ppmpoisson%fldzc2(1,i,j,k,isub) &
- & + (1.0_MK * normfac*4.0_MK*PI - gzero) !dirac minus actual value
-#else
- ppmpoisson%fldgrnc(i,j,k,isub) = ppmpoisson%fldzc2(1,i,j,k,isub)
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- END IF
- !-------------------------------------------------------------------------
- ! Or alternatively FFT real Green from input
- !-------------------------------------------------------------------------
-
-
- !-------------------------------------------------------------------------
- ! Deallocate fields? !@
- !-------------------------------------------------------------------------
-
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_poisson_init',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-
diff --git a/src/poisson/ppm_poisson_solve.f b/src/poisson/ppm_poisson_solve.f
deleted file mode 100644
index 2f9c0e8910a7f9e574bd4e82bf56b7fc24f08345..0000000000000000000000000000000000000000
--- a/src/poisson/ppm_poisson_solve.f
+++ /dev/null
@@ -1,537 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_poisson_solve.f90
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !-------------------------------------------------------------------------
- SUBROUTINE __ROUTINE(topoid,meshid,ppmpoisson,fieldin,fieldout,gstw,info,&
- & tmpcase)
- !!! Routine to perform the Greens function solution of the Poisson
- !!! equation. All settings are defined in ppm_poisson_initdef and stored
- !!! in the ppmpoisson plan.
- !!!
- !!! The tmpcase argument allows the use of a
- !!! different Greens function or operation than initialised. This is
- !!! particularly useful for Helmholtz reprojection
- !!! (ppm_poisson_grn_reprojec).
- !!!
- !!! [NOTE]
- !!! fieldin and fieldout must NOT be the same fields. In-place FFTs have
- !!! not been implemented.
-
- USE ppm_module_map_field
- USE ppm_module_map_field_global
- USE ppm_module_map
-
- IMPLICIT NONE
- include 'mpif.h'
-
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT(IN) :: topoid
- !!! Topology ID
- INTEGER, INTENT(IN) :: meshid
- !!! Mesh ID
- TYPE(ppm_poisson_plan),INTENT(INOUT) :: ppmpoisson
- !!! The PPM Poisson plan
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: fieldin
- !!! Input data field
- REAL(__PREC),DIMENSION(:,:,:,:,:),POINTER :: fieldout
- !!! Output data field
- INTEGER,DIMENSION(__DIM),INTENT(IN) :: gstw
- !!! Ghost layer width
- INTEGER, INTENT(OUT) :: info
- !!! Return status, 0 upon succes
- INTEGER,OPTIONAL,INTENT(IN) :: tmpcase
- !!! Temporary operation (useful for ppm_poisson_grn_reprojec)
-
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER,PARAMETER :: MK = __PREC
- REAL(__PREC) :: t0
- INTEGER :: isub,isubl
- INTEGER :: i,j,k
- INTEGER :: info2
- INTEGER :: presentcase
- COMPLEX(__PREC) :: divomega
- INTEGER :: gi,gj,gk
- COMPLEX(__PREC) :: kx,ky,kz
- COMPLEX(__PREC) :: phix,phiy,phiz
- REAL(__PREC) :: normfac
-
- !-------------------------------------------------------------------------
- ! Initialise routine
- !-------------------------------------------------------------------------
- CALL substart('ppm_poisson_solve',t0,info)
-
- !-------------------------------------------------------------------------
- ! Check if we run a different/temporary case
- !-------------------------------------------------------------------------
- IF (PRESENT(tmpcase)) THEN
- presentcase = tmpcase
- ELSE
- presentcase = ppmpoisson%case
- ENDIF
-
- !-------------------------------------------------------------------------
- !@ Perhaps check if ghostlayer suffices for a given fd stencil
- !-------------------------------------------------------------------------
-
-
- !-------------------------------------------------------------------------
- ! Perhaps allocate (and deallocate) arrays
- !-------------------------------------------------------------------------
-
-
- !-----------------------------------------------------------------------
- ! Set the real xy slabs 0 (part of the 0 padding) for free-space
- !@ free-space calculations and reprojection may cause problems !why?
- !-----------------------------------------------------------------------
- IF (presentcase .EQ. ppm_poisson_grn_pois_fre) THEN
- ppmpoisson%fldxyr = 0.0_MK
- ENDIF
-
- !-----------------------------------------------------------------------
- ! Map data globally to the slabs (XY)
- ! This is where the vorticity is extended and padded with 0 for free-space
- !-----------------------------------------------------------------------
- !Initialise
- CALL ppm_map_field_global(&
- & topoid, &
- & ppmpoisson%topoidxy, &
- & meshid, &
- & ppmpoisson%meshidxy,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_poisson_solve','Failed to initialise field mapping.',info2)
- GOTO 9999
- ENDIF
-
- !Push the data
- CALL ppm_map_field_push(&
- & topoid, &
- & meshid,fieldin,__NCOM,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to push vector field.',info2)
- GOTO 9999
- ENDIF
-
- !Send
- CALL ppm_map_field_send(info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to send field.',info2)
- GOTO 9999
- ENDIF
-
- !Retrieve
- CALL ppm_map_field_pop(&
- & ppmpoisson%topoidxy, &
- & ppmpoisson%meshidxy,ppmpoisson%fldxyr, &
- & __NCOM,__ZEROSI,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to pop vector field.',info2)
- GOTO 9999
- ENDIF
-
- !-----------------------------------------------------------------------
- ! Do slab FFT (XY) - use the xy topology as its extent has not been halved
- !-----------------------------------------------------------------------
- CALL ppm_fft_execute_2d(ppmpoisson%topoidxy,&
- & ppmpoisson%meshidxy, ppmpoisson%planfxy, &
- & ppmpoisson%fldxyr, ppmpoisson%fldxyc, &
- & info)
-
-
- !-----------------------------------------------------------------------
- ! Map to the pencils (Z)
- !-----------------------------------------------------------------------
- !Initialise
- CALL ppm_map_field_global(&
- & ppmpoisson%topoidxy, &
- & ppmpoisson%topoidz, &
- & ppmpoisson%meshidxyc, &
- & ppmpoisson%meshidz,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to initialise field mapping.',info2)
- GOTO 9999
- ENDIF
-
- !Push the data
- CALL ppm_map_field_push(&
- & ppmpoisson%topoidxy, &
- & ppmpoisson%meshidxyc,ppmpoisson%fldxyc,__NCOM,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to push vector field.',info2)
- GOTO 9999
- ENDIF
-
- !Send
- CALL ppm_map_field_send(info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to send field.',info2)
- GOTO 9999
- ENDIF
-
- !Retrieve
- CALL ppm_map_field_pop(&
- & ppmpoisson%topoidz, &
- & ppmpoisson%meshidz,ppmpoisson%fldzc1, &
- & __NCOM,__ZEROSI,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to pop vector field.',info2)
- GOTO 9999
- ENDIF
-
-
- !-----------------------------------------------------------------------
- ! Do pencil FFT (Z)
- !-----------------------------------------------------------------------
- CALL ppm_fft_execute_1d(ppmpoisson%topoidz,&
- & ppmpoisson%meshidz, ppmpoisson%planfz, &
- & ppmpoisson%fldzc1, ppmpoisson%fldzc2, &
- & info)
-
-
- !-----------------------------------------------------------------------
- ! Apply the periodic Greens function
- !-----------------------------------------------------------------------
- IF (presentcase .EQ. ppm_poisson_grn_pois_per) THEN
- DO isub=1,ppmpoisson%nsublistz
- isubl=ppmpoisson%isublistz(isub)
- DO k=1,ppmpoisson%ndataz(3,isubl)
- DO j=1,ppmpoisson%ndataz(2,isubl)
- DO i=1,ppmpoisson%ndataz(1,isubl)
- ppmpoisson%fldzc2(1,i,j,k,isub) = ppmpoisson%fldgrnr( i,j,k,isub)*&
- & ppmpoisson%fldzc2(1,i,j,k,isub)
- ppmpoisson%fldzc2(2,i,j,k,isub) = ppmpoisson%fldgrnr( i,j,k,isub)*&
- & ppmpoisson%fldzc2(2,i,j,k,isub)
- ppmpoisson%fldzc2(3,i,j,k,isub) = ppmpoisson%fldgrnr( i,j,k,isub)*&
- & ppmpoisson%fldzc2(3,i,j,k,isub)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-
-
- !-----------------------------------------------------------------------
- ! Apply the free-space Greens function
- !-----------------------------------------------------------------------
- ELSE IF (presentcase .EQ. ppm_poisson_grn_pois_fre) THEN
- DO isub=1,ppmpoisson%nsublistz
- isubl=ppmpoisson%isublistz(isub)
- DO k=1,ppmpoisson%ndataz(3,isubl)
- DO j=1,ppmpoisson%ndataz(2,isubl)
- DO i=1,ppmpoisson%ndataz(1,isubl)
- ppmpoisson%fldzc2(1,i,j,k,isub) = ppmpoisson%fldgrnc( i,j,k,isub)*&
- & ppmpoisson%fldzc2(1,i,j,k,isub)
- ppmpoisson%fldzc2(2,i,j,k,isub) = ppmpoisson%fldgrnc( i,j,k,isub)*&
- & ppmpoisson%fldzc2(2,i,j,k,isub)
- ppmpoisson%fldzc2(3,i,j,k,isub) = ppmpoisson%fldgrnc( i,j,k,isub)*&
- & ppmpoisson%fldzc2(3,i,j,k,isub)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-
- !-----------------------------------------------------------------------
- ! Vorticity re-projection
- !-----------------------------------------------------------------------
- ELSE IF (presentcase .EQ. ppm_poisson_grn_reprojec) THEN
- !remembering to normalize the FFT:
- !!IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_fre) THEN
- !!normfac = 1.0_MK/ REAL((ppmpoisson%nmfft(1))* & !vertex
- !!& (ppmpoisson%nmfft(2))* &
- !!& (ppmpoisson%nmfft(3)),MK)
- !!ELSE IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_per) THEN
- normfac = 1.0_MK/ REAL((ppmpoisson%nmfft(1))* & !vertex
- & (ppmpoisson%nmfft(2))* &
- & (ppmpoisson%nmfft(3)),MK)
- !!ENDIF
-
- DO isub=1,ppmpoisson%nsublistz
- isubl=ppmpoisson%isublistz(isub)
- DO k=1,ppmpoisson%ndataz(3,isubl)
- gk = k - 1 + (ppmpoisson%istartz(3,isubl)-1)
- IF (gk .GT. (ppmpoisson%nmfft(3))/2) gk = gk-(ppmpoisson%nmfft(3))
- kz = CMPLX(0.0_MK,REAL(gk,MK),MK)*ppmpoisson%normkz
- DO j=1,ppmpoisson%ndataz(2,isubl)
- gj = j - 1 + (ppmpoisson%istartz(2,isubl)-1)
- IF (gj .GT. (ppmpoisson%nmfft(2))/2) gj = gj-(ppmpoisson%nmfft(2))
- ky = CMPLX(0.0_MK,REAL(gj,MK),MK)*ppmpoisson%normky
- DO i=1,ppmpoisson%ndataz(1,isubl)
- gi = i - 1 + (ppmpoisson%istartz(1,isubl)-1)
- IF (gi .GT. (ppmpoisson%nmfft(1))/2) gi = gi-(ppmpoisson%nmfft(1))
- kx = CMPLX(0.0_MK,REAL(gi,MK),MK)*ppmpoisson%normkx
-
-
- !compute spectral divergence....
- IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_fre) THEN
- divomega = (ppmpoisson%fldzc2(1,i,j,k,isub) * kx + &
- & ppmpoisson%fldzc2(2,i,j,k,isub) * ky + &
- & ppmpoisson%fldzc2(3,i,j,k,isub) * kz) * &
- & ppmpoisson%fldgrnc( i,j,k,isub)
- ELSE IF (ppmpoisson%case .EQ. ppm_poisson_grn_pois_per) THEN
- !compute spectral divergence....
- divomega = (ppmpoisson%fldzc2(1,i,j,k,isub) * kx + &
- & ppmpoisson%fldzc2(2,i,j,k,isub) * ky + &
- & ppmpoisson%fldzc2(3,i,j,k,isub) * kz) * &
- & ppmpoisson%fldgrnr( i,j,k,isub)
- ENDIF
- !...and subtract its gradient
- ppmpoisson%fldzc2(1,i,j,k,isub) = &
- & (ppmpoisson%fldzc2(1,i,j,k,isub)*normfac + divomega *kx)
- ppmpoisson%fldzc2(2,i,j,k,isub) = &
- & (ppmpoisson%fldzc2(2,i,j,k,isub)*normfac + divomega *ky)
- ppmpoisson%fldzc2(3,i,j,k,isub) = &
- & (ppmpoisson%fldzc2(3,i,j,k,isub)*normfac + divomega *kz)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
-
- !-----------------------------------------------------------------------
- ! Spectral derivatives
- ! normkx, etc contains 2pi/Lx
- !-----------------------------------------------------------------------
- IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_sp) THEN
- normfac = 1.0_MK/ REAL((ppmpoisson%nmfft(1))* & !vertex
- & (ppmpoisson%nmfft(2))* &
- & (ppmpoisson%nmfft(3)),MK)
- IF (presentcase .EQ. ppm_poisson_grn_pois_per .OR. &
- & presentcase .EQ. ppm_poisson_grn_pois_fre) THEN
- DO isub=1,ppmpoisson%nsublistz
- isubl=ppmpoisson%isublistz(isub)
- DO k=1,ppmpoisson%ndataz(3,isubl)
- gk = k - 1 + (ppmpoisson%istartz(3,isubl)-1)
- IF (gk .GT. (ppmpoisson%nmfft(3)/2)) gk = gk-(ppmpoisson%nmfft(3))
- kz = CMPLX(0.0_MK,REAL(gk,MK),MK)*ppmpoisson%normkz
- DO j=1,ppmpoisson%ndataz(2,isubl)
- gj = j - 1 + (ppmpoisson%istartz(2,isubl)-1)
- IF (gj .GT. (ppmpoisson%nmfft(2)/2)) gj = gj-(ppmpoisson%nmfft(2))
- ky = CMPLX(0.0_MK,REAL(gj,MK),MK)*ppmpoisson%normky
- DO i=1,ppmpoisson%ndataz(1,isubl)
- gi = i - 1 + (ppmpoisson%istartz(1,isubl)-1)
- IF (gi .GT. (ppmpoisson%nmfft(1)/2)) gi = gi-(ppmpoisson%nmfft(1))
- kx = CMPLX(0.0_MK,REAL(gi,MK),MK)*ppmpoisson%normkx
-
- phix = ppmpoisson%fldzc2(1,i,j,k,isub)
- phiy = ppmpoisson%fldzc2(2,i,j,k,isub)
- phiz = ppmpoisson%fldzc2(3,i,j,k,isub)
-
- ppmpoisson%fldzc2(1,i,j,k,isub) = (ky*phiz-kz*phiy)
- ppmpoisson%fldzc2(2,i,j,k,isub) = (kz*phix-kx*phiz)
- ppmpoisson%fldzc2(3,i,j,k,isub) = (kx*phiy-ky*phix)
- !ppmpoisson%fldzc2(1,i,j,k,isub) = normfac*kx*phix !@
- !ppmpoisson%fldzc2(2,i,j,k,isub) = normfac*ky*phiy !@
- !ppmpoisson%fldzc2(3,i,j,k,isub) = normfac*kz*phiz !@
- !ppmpoisson%fldzc2(1,i,j,k,isub) = normfac*phix !@
- !ppmpoisson%fldzc2(2,i,j,k,isub) = normfac*phiy !@
- !ppmpoisson%fldzc2(3,i,j,k,isub) = normfac*phiz !@
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-
-
- !-----------------------------------------------------------------------
- ! IFFT pencil (Z)
- !-----------------------------------------------------------------------
- CALL ppm_fft_execute_1d(ppmpoisson%topoidz,&
- & ppmpoisson%meshidz, ppmpoisson%planbz, &
- & ppmpoisson%fldzc2, ppmpoisson%fldzc1, &
- & info)
-
-
- !-----------------------------------------------------------------------
- ! Map back to slabs (XY)
- !-----------------------------------------------------------------------
- !Initialise
- CALL ppm_map_field_global(&
- & ppmpoisson%topoidz, &
- & ppmpoisson%topoidxy, &
- & ppmpoisson%meshidz, &
- & ppmpoisson%meshidxyc,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to initialise field mapping.',info2)
- GOTO 9999
- ENDIF
-
- !Push the data
- CALL ppm_map_field_push(&
- & ppmpoisson%topoidz, &
- & ppmpoisson%meshidz,ppmpoisson%fldzc1,__NCOM,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to push vector field.',info2)
- GOTO 9999
- ENDIF
-
- !Send
- CALL ppm_map_field_send(info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to send field.',info2)
- GOTO 9999
- ENDIF
-
- !Retrieve
- CALL ppm_map_field_pop(&
- & ppmpoisson%topoidxy, &
- & ppmpoisson%meshidxyc,ppmpoisson%fldxyc, &
- & __NCOM,__ZEROSI,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to pop vector field.',info2)
- GOTO 9999
- ENDIF
-
-
- !-----------------------------------------------------------------------
- ! IFFT (XY) use the non-reduced topology
- !-----------------------------------------------------------------------
- CALL ppm_fft_execute_2d(ppmpoisson%topoidxy,&
- & ppmpoisson%meshidxy, ppmpoisson%planbxy, &
- & ppmpoisson%fldxyc, ppmpoisson%fldxyr, &
- & info)
-
-
- !-----------------------------------------------------------------------
- ! Map back to standard topology (XYZ)
- !-----------------------------------------------------------------------
- !Initialise
- CALL ppm_map_field_global(&
- & ppmpoisson%topoidxy, &
- & topoid, &
- & ppmpoisson%meshidxy, &
- & meshid,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to initialise field mapping.',info2)
- GOTO 9999
- ENDIF
-
- !Push the data
- CALL ppm_map_field_push(&
- & ppmpoisson%topoidxy, &
- & ppmpoisson%meshidxy,ppmpoisson%fldxyr,__NCOM,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to push vector field.',info2)
- GOTO 9999
- ENDIF
-
- !Send
- CALL ppm_map_field_send(info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to send field.',info2)
- GOTO 9999
- ENDIF
-
- !-------------------------------------------------------------------------
- ! FINAL RETRIEVE - Here we do different things depending on the task
- ! i.e. the receiver varies
- !-------------------------------------------------------------------------
- IF ((ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd2 .OR. &
- & ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd4) .AND. &
- & (presentcase .EQ. ppm_poisson_grn_pois_per .OR. &
- & presentcase .EQ. ppm_poisson_grn_pois_fre )) THEN
- CALL ppm_map_field_pop(&
- & topoid, &
- & meshid,ppmpoisson%drv_vr, &
- & __NCOM,gstw,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to pop vector field.',info2)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Ghost the temporary array for derivatives (drv_vr)
- !-------------------------------------------------------------------------
- CALL ppm_map_field_ghost_get(topoid,meshid,gstw,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to initialise ghosts.',info2)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_push(topoid,meshid,ppmpoisson%drv_vr,__NCOM,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to push ghosts.',info2)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to send ghosts.',info2)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(topoid,meshid,ppmpoisson%drv_vr,__NCOM,gstw,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to pop ghosts.',info2)
- GOTO 9999
- ENDIF
-
- ELSE
- CALL ppm_map_field_pop(&
- & topoid, &
- & meshid,fieldout, &
- & __NCOM,gstw,info)
- ENDIF
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank, 'ppm_poisson_solve','Failed to pop vector field.',info2)
- GOTO 9999
- ENDIF
-
-
- !-------------------------------------------------------------------------
- ! Treat ghost layer to make FD stencils work
- !-------------------------------------------------------------------------
- IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd2 .AND.&
- & (presentcase .EQ. ppm_poisson_grn_pois_fre)) THEN
- CALL ppm_poisson_extrapolateghost(topoid,meshid,ppmpoisson%drv_vr,&
- & 2,4,gstw,info)
- ENDIF
- IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd4 .AND.&
- & (presentcase .EQ. ppm_poisson_grn_pois_fre)) THEN
- CALL ppm_poisson_extrapolateghost(topoid,meshid,ppmpoisson%drv_vr,&
- & 2,4,gstw,info)
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Optionally do derivatives
- ! Perhaps make ppm_poisson_fd take _none as argument. Then maybe no
- ! if-statement is required
- !-------------------------------------------------------------------------
- IF (presentcase .NE. ppm_poisson_grn_reprojec) THEN
- IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd2) THEN
- CALL ppm_poisson_fd(topoid,meshid,ppmpoisson%drv_vr,fieldout,&
- & ppm_poisson_drv_curl_fd2,info)
- ENDIF
- IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd4) THEN
- CALL ppm_poisson_fd(topoid,meshid,ppmpoisson%drv_vr,fieldout,&
- & ppm_poisson_drv_curl_fd4,info)
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Finally ghost the velocity/stream function field before returning it
- ! Also extrapolate if freespace
- !-------------------------------------------------------------------------
- CALL ppm_map_field_ghost_get(topoid,meshid,gstw,info)
- CALL ppm_map_field_push(topoid,meshid,fieldout,__NCOM,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topoid,meshid,fieldout,__NCOM,gstw,info)
- IF (presentcase .EQ. ppm_poisson_grn_pois_fre) THEN
- CALL ppm_poisson_extrapolateghost(topoid,meshid,fieldout,&
- & 2,4,gstw,info)
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Perhaps allocate (and deallocate) arrays !@
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_poisson_solve',t0,info)
- RETURN
-
- END SUBROUTINE __ROUTINE
-
diff --git a/src/ppm_bem_basis.f b/src/ppm_bem_basis.f
deleted file mode 100644
index dbc662d9a22c4e53a5c90bdce5b5e7414455a91f..0000000000000000000000000000000000000000
--- a/src/ppm_bem_basis.f
+++ /dev/null
@@ -1,204 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_bem_basis
- !-------------------------------------------------------------------------
- !
- ! Purpose : Returns the coefficients of the basis functions for
- ! a given (s,t) pair in the triangle
- !
- ! Input : qp (F) : coordinates where the basis functions
- ! has to be evaluated
- ! basis (I) : set of basis functions. One of the
- ! following values:
- ! ppm_bem_basis_const :
- ! constant interpolation, 1 coefficient
- ! ppm_bem_basis_linear :
- ! linear interpolation, 3 coefficients
- ! ppm_bem_basis_quad :
- ! quadratic interpolation, 6 coefficients
- !
- ! Input/output : lb (F) : coefficients of the basis functions
- !
- ! Output : info (I) : return status. 0 on success.
- !
- ! Remarks : lb has to be big enough to hold the coefficients
- ! for a given set of basis functions.
- !
- ! t
- ! 3 (0,1)
- ! |\
- ! | \
- ! 4 5
- ! | \
- ! | \
- ! 1--6--2 (1,0) s
- ! (0,0)
- !
- ! The order of the coefficients in the lb array is
- ! mentioned in the figure above. E.g. for the linear
- ! case, lb(1) contains the coefficient of the value
- ! at 1, lb(2) contains the coefficient of the value
- ! at 2, lb(3) contains the coefficient of the value
- ! at 3.
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_bem_basis.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.6 2006/09/04 18:34:40 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.5 2004/10/01 16:08:55 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.4 2004/07/27 07:06:48 ivos
- ! Renamed parameters after moving their definition to ppm_param.h.
- !
- ! Revision 1.3 2004/07/26 11:46:52 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.2 2004/07/26 07:46:35 ivos
- ! Changed to use single-interface modules. Updated all USE statements.
- !
- ! Revision 1.1 2004/07/16 08:32:46 oingo
- ! Initial release. Not tested
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_bem_basis_s(qp,lb,basis,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_bem_basis_d(qp,lb,basis,info)
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_numerics_data
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Type kind
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK), DIMENSION(:), INTENT(IN ) :: qp
- REAL(MK), DIMENSION(:), POINTER :: lb
- INTEGER , INTENT(IN ) :: basis
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(MK) :: u
- REAL(MK) :: t0
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_bem_basis',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF ((basis .LT. 1) .OR. (basis .GT. 3)) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_argument,'ppm_bem_basis', &
- & 'Invalid value for BASIS',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((SIZE(lb,1) .LT. 1) .AND. (basis .EQ. &
- & ppm_param_bem_basis_const)) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_argument,'ppm_bem_basis', &
- & 'LB must have a size of at least 1',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((SIZE(lb,1) .LT. 3) .AND. (basis .EQ. &
- & ppm_param_bem_basis_linear)) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_argument,'ppm_bem_basis', &
- & 'LB must have a size of at least 3',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((SIZE(lb,1) .LT. 6) .AND. (basis .EQ. &
- & ppm_param_bem_basis_quad)) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_argument,'ppm_bem_basis', &
- & 'LB must have a size of at least 6',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Calculate the coefficients
- !-------------------------------------------------------------------------
- IF (basis .EQ. ppm_param_bem_basis_const) THEN
- lb(1) = 1.0
- ELSEIF (basis .EQ. ppm_param_bem_basis_linear) THEN
- lb(1) = 1.0 - qp(1) - qp(2)
- lb(2) = qp(1)
- lb(3) = qp(2)
- ELSE
- u = 1.0 - qp(1) - qp(2)
- lb(1) = u * (2.0*u - 1.0)
- lb(2) = qp(1) * (2.0*qp(1) - 1.0)
- lb(3) = qp(2) * (2.0*qp(2) - 1.0)
- lb(4) = 4.0 * qp(2) * u
- lb(5) = 4.0 * qp(1) * qp(2)
- lb(6) = 4.0 * qp(1) * u
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_bem_basis',t0,info)
- RETURN
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_bem_basis_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_bem_basis_d
-#endif
diff --git a/src/ppm_bem_quadrule.f b/src/ppm_bem_quadrule.f
deleted file mode 100644
index 3e3cf817a0e39ae190ea0aacc32d2885e35cda10..0000000000000000000000000000000000000000
--- a/src/ppm_bem_quadrule.f
+++ /dev/null
@@ -1,257 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_bem_quadrule
- !-------------------------------------------------------------------------
- !
- ! Purpose : Sets up various rules for the quadrature (cubature)
- ! over a unit triangle
- !
- ! Input : rule (I) : the rule to be returned
- !
- ! Input/output :
- !
- ! Output : qp (F) : quadrature points
- ! qw (F) : quadrature weights
- ! info (I) : return status. 0 on success.
- !
- ! Remarks : qp is a 2-dimensional array containing the (s,t)-
- ! coordinates of quadrature points in the unit triangle
- !
- ! * (0,1)
- ! |\
- ! | \
- ! t \
- ! | \
- ! | \
- ! *--s--* (1,0)
- ! (0,0)
- !
- ! e.g. qp(1,1) contains the s-coordinate of the first
- ! quadrature points and qp(2,1) the t-coordinate. The
- ! array qp and qw must be big enough to hold the
- ! quadrature points indicated by the rule.
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_bem_quadrule.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.8 2006/09/04 18:34:40 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.7 2006/05/11 10:44:07 pchatela
- ! Added Hammer rules
- ! Switch loop rather than if then else
- !
- ! Revision 1.6 2004/10/01 16:08:56 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.5 2004/07/27 07:56:01 ivos
- ! Corrected typo in CALL statement.
- !
- ! Revision 1.4 2004/07/27 07:06:48 ivos
- ! Renamed parameters after moving their definition to ppm_param.h.
- !
- ! Revision 1.3 2004/07/26 11:46:53 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.2 2004/07/26 07:46:35 ivos
- ! Changed to use single-interface modules. Updated all USE statements.
- !
- ! Revision 1.1 2004/07/16 08:33:11 oingo
- ! Initial release. Not tested
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_bem_quadrule_s(qp,qw,rule,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_bem_quadrule_d(qp,qw,rule,info)
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_bem_quadrule_npoints
- USE ppm_module_numerics_data
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Type kind
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK), DIMENSION(:,:), POINTER :: qp
- REAL(MK), DIMENSION(:) , POINTER :: qw
- INTEGER , INTENT(IN ) :: rule
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(MK) :: temp
- REAL(MK) :: a1, a2, b1, b2, c1, c2, c3, w1, w2, w3
- INTEGER :: nqp
- REAL(MK) :: t0
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_bem_quadrule',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_bem_quadrule_npoints(rule,nqp,info)
- IF (nqp .EQ. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_bem_quadrule', &
- & 'Unknown quadrature rule',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (SIZE(qp,2) .LT. nqp) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_argument,'ppm_bem_quadrule', &
- & 'QP array not big enough',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (SIZE(qw,1) .LT. nqp) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_argument,'ppm_bem_quadrule', &
- & 'QW array not big enough',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Fill in the quadrature points according to the rule
- !-------------------------------------------------------------------------
- SELECT CASE (rule)
- CASE (ppm_param_bem_quadrule_center)
- qp(1:2,1) = (/ 1.0/3.0, 1.0/3.0 /)
- qw(1) = 1.0
- CASE (ppm_param_bem_quadrule_nodes)
- qp(1:2,1) = (/ 0.0, 0.0 /)
- qp(1:2,2) = (/ 1.0, 0.0 /)
- qp(1:2,3) = (/ 0.0, 1.0 /)
- qw(:) = 1.0 / 3.0
- CASE (ppm_param_bem_quadrule_edges)
- qp(1:2,1) = (/ 0.0, 0.5 /)
- qp(1:2,2) = (/ 0.5, 0.5 /)
- qp(1:2,3) = (/ 0.5, 0.0 /)
- qw(:) = 1.0 / 3.0
- CASE (ppm_param_bem_quadrule_cne)
- qp(1:2,1) = (/ 0.0, 0.0 /)
- qp(1:2,2) = (/ 1.0, 0.0 /)
- qp(1:2,3) = (/ 0.0, 1.0 /)
- qp(1:2,4) = (/ 0.0, 0.5 /)
- qp(1:2,5) = (/ 0.5, 0.5 /)
- qp(1:2,6) = (/ 0.5, 0.0 /)
- qp(1:2,7) = (/ 1.0/3.0, 1.0/3.0 /)
- qw(1:3) = 1.0 / 20.0
- qw(4:6) = 2.0 / 15.0
- qw(7) = 27.0 / 60.0
- CASE (ppm_param_bem_quadrule_stroud,ppm_param_bem_quadrule_hammer7)
- ! Stroud T2:5-1
- temp = SQRT(15.0_MK)
- qp(1:2,1) = (/ 1.0/3.0, 1.0/3.0 /)
- qp(1:2,2) = (/ (9.0 + 2.0*temp) / 21.0, (6.0 - temp) / 21.0 /)
- qp(1:2,3) = (/ (6.0 - temp) / 21.0, (9.0 + 2.0*temp) / 21.0 /)
- qp(1:2,4) = (/ (6.0 - temp) / 21.0, (6.0 - temp) / 21.0 /)
- qp(1:2,5) = (/ (9.0 - 2.0*temp) / 21.0, (6.0 + temp) / 21.0 /)
- qp(1:2,6) = (/ (6.0 + temp) / 21.0, (9.0 - 2.0*temp) / 21.0 /)
- qp(1:2,7) = (/ (6.0 + temp) / 21.0, (6.0 + temp) / 21.0 /)
- qw(1) = 9.0 / 40.0
- qw(2:4) = (155.0 - temp) / 1200.0
- qw(5:7) = (155.0 + temp) / 1200.0
- CASE (ppm_param_bem_quadrule_hammer3)
- qp(1:2,1) = (/ 2.0/3.0, 1.0/6.0 /)
- qp(1:2,2) = (/ 1.0/6.0, 1.0/6.0 /)
- qp(1:2,3) = (/ 1.0/6.0, 2.0/3.0 /)
- qw(:) = 1.0 / 3.0
- CASE (ppm_param_bem_quadrule_hammer4)
- qp(1:2,1) = (/ 1.0/3.0, 1.0/3.0 /)
- qp(1:2,2) = (/ 0.2, 0.2 /)
- qp(1:2,3) = (/ 0.6, 0.2 /)
- qp(1:2,4) = (/ 0.2, 0.6 /)
- qw(1) = -27.0/48.0
- qw(2:4) = 25.0/48.0
- CASE (ppm_param_bem_quadrule_hammer12)
- a1=0.873821971016996_MK; a2=0.063089014491502_MK
- b1=0.501426509658179_MK; b2=0.249286745170910_MK
- c1=0.636502499121399_MK; c2=0.310352451033785_MK; c3=0.053145049844816_MK
- w1=0.050844906370207_MK; w2=0.116786275726379_MK; w3=0.082851075618374_MK
- qp(1:2,1) = (/ a1, a2 /)
- qp(1:2,2) = (/ a2, a1 /)
- qp(1:2,3) = (/ a2, a2 /)
- qp(1:2,4) = (/ b1, b2 /)
- qp(1:2,5) = (/ b2, b1 /)
- qp(1:2,6) = (/ b2, b2 /)
- qp(1:2,7) = (/ c1, c2 /)
- qp(1:2,8) = (/ c1, c3 /)
- qp(1:2,9) = (/ c2, c1 /)
- qp(1:2,10)= (/ c2, c3 /)
- qp(1:2,11)= (/ c3, c1 /)
- qp(1:2,12)= (/ c3, c2 /)
- qw(1:3) = w1
- qw(3:6) = w2
- qw(7:12) = w3
- CASE DEFAULT
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_bem_quadrule', &
- & 'Unknown quadrature rule',__LINE__,info)
- GOTO 9999
- END SELECT
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_bem_quadrule',t0,info)
- RETURN
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_bem_quadrule_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_bem_quadrule_d
-#endif
diff --git a/src/ppm_bem_quadrule_npoints.f b/src/ppm_bem_quadrule_npoints.f
deleted file mode 100644
index 61d78867b13120b46e2b7f8e06c89b9a43a86188..0000000000000000000000000000000000000000
--- a/src/ppm_bem_quadrule_npoints.f
+++ /dev/null
@@ -1,147 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_bem_quadrule_npoints
- !-------------------------------------------------------------------------
- !
- ! Purpose : Returns the number of quadrature points for the
- ! given rule
- !
- ! Input : rule (I) : the quadrature rule
- !
- ! Input/output :
- !
- ! Output : nqp (I) : number of quadrature points
- ! info (I) : return status. 0 on success.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_bem_quadrule_npoints.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.8 2006/09/04 18:34:41 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.7 2006/05/11 10:44:07 pchatela
- ! Added Hammer rules
- ! Switch loop rather than if then else
- !
- ! Revision 1.6 2004/10/01 16:33:31 ivos
- ! cosmetics.
- !
- ! Revision 1.5 2004/10/01 16:08:56 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.4 2004/07/27 07:06:48 ivos
- ! Renamed parameters after moving their definition to ppm_param.h.
- !
- ! Revision 1.3 2004/07/26 11:46:53 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.2 2004/07/26 07:46:36 ivos
- ! Changed to use single-interface modules. Updated all USE statements.
- !
- ! Revision 1.1 2004/07/16 08:33:39 oingo
- ! Initial release. Not tested
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
- SUBROUTINE ppm_bem_quadrule_npoints(rule,nqp,info)
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_numerics_data
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT(IN ) :: rule
- INTEGER, INTENT( OUT) :: nqp
- INTEGER, INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(ppm_kind_double) :: t0
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_bem_quadrule_npoints',t0,info)
- !-------------------------------------------------------------------------
- ! Check for the rule and set the number of points accordingly
- !-------------------------------------------------------------------------
- SELECT CASE (rule)
- CASE(ppm_param_bem_quadrule_center)
- nqp = 1
- CASE(ppm_param_bem_quadrule_nodes)
- nqp = 3
- CASE(ppm_param_bem_quadrule_edges)
- nqp = 3
- CASE(ppm_param_bem_quadrule_cne)
- nqp = 7
- CASE(ppm_param_bem_quadrule_stroud,ppm_param_bem_quadrule_hammer7)
- nqp = 7
- CASE(ppm_param_bem_quadrule_hammer3)
- nqp = 3
- CASE(ppm_param_bem_quadrule_hammer4)
- nqp = 4
- CASE(ppm_param_bem_quadrule_hammer12)
- nqp = 12
- CASE DEFAULT
- nqp = 0
- END SELECT
-
- IF (nqp .EQ. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_bem_quadrule_npoints', &
- & 'Unknown quadrature rule',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_bem_quadrule_npoints',t0,info)
- RETURN
-
- END SUBROUTINE ppm_bem_quadrule_npoints
diff --git a/src/ppm_comp_pp_cell.f b/src/ppm_comp_pp_cell.f
deleted file mode 100644
index d968cace6b26d31e1315313cc83ee616860811b2..0000000000000000000000000000000000000000
--- a/src/ppm_comp_pp_cell.f
+++ /dev/null
@@ -1,823 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_comp_pp_cell
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_cell_si(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & clist,cutoff2,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_cell_di(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & clist,cutoff2,dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_cell_sci(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar,&
- & clist,cutoff2,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_cell_dci(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar,&
- & clist,cutoff2,dpd,info)
-#endif
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_cell_su(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & clist,cutoff2,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_cell_du(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & clist,cutoff2,dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_cell_scu(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar,&
- & clist,cutoff2,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_cell_dcu(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar,&
- & clist,cutoff2,dpd,info)
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_cell_st(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & clist,cutoff2,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_cell_dt(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & clist,cutoff2,dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_cell_sct(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar,&
- & clist,cutoff2,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_cell_dct(topoid,xp,Np,pdata,lda,lsymm,kernel,kpar,&
- & clist,cutoff2,dpd,info)
-#endif
-#endif
- !!! This routine computes kernel interactions by direct
- !!! particle-particle interactions using cell lists.
- !!!
- !!! [NOTE]
- !!! Loops over lda have been explicitly unrolled for the cases of
- !!! `lda.EQ.1` and `lda.EQ.2` to allow vectorization in these cases.
- !!!
- !!! [WARNING]
- !!! clist has to be created by the user program before
- !!! calling this routine. ppm_neighlist_clist should be
- !!! used for this. The reason is that this allows the
- !!! user to have multiple cell lists and call this
- !!! routine for the appropriate one. Do not forget to
- !!! call ppm_neighlist_clist_destroy.
- !!!
- !!! [NOTE]
- !!! dpd needs to be allocated to proper size before
- !!! calling this routine. Also, this routine is not
- !!! resetting dpd to zero before doing the PP
- !!! interactions. This allows contributions from
- !!! different kernels to be accumulated. If needed,
- !!! set it to zero before calling this routine the
- !!! first time.
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_typedef
- USE ppm_module_check_id
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_neighlist
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER :: topoid
- !!! The ID of the topology currently mapped to (needed to get number
- !!! of subdomains on local processor)
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: xp
- !!! particle co-ordinates
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: pdata
- !!! particle strengths used for interaction.
- !!! Overloaded type: single,double
- REAL(MK) , DIMENSION(:,:), INTENT( OUT) :: dpd
- !!! Change of particle data (pdata) due to interaction.
- !!! This is not initialized by this routine!
- !!! Overloaded types: single,double.
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:), INTENT(IN ) :: pdata
- !!! particle strengths used for interaction.
- !!! Overloaded types: single complex, double complex.
- COMPLEX(MK), DIMENSION(:,:), INTENT( OUT) :: dpd
- !!! Change of particle data (pdata) due to interaction.
- !!! This is not initialized by this routine!
- !!! Overloaded types: single complex, double complex.
-#endif
- INTEGER , INTENT(IN ) :: Np
- !!! number of particles on this proc.
- INTEGER , INTENT(IN ) :: lda
- !!! lading dimension of pdata.
-#if __KERNEL == __INTERNAL
- INTEGER , INTENT(IN ) :: kernel
- !!! kernel to be used for PP interactions. To use ppm-internal
- !!! kernels, specify one of:
- !!!
- !!! ---------------------------------------
- !!! ppm_param_kerel_laplace2d_2p
- !!! (2nd order Laplacian, polynomial in 2D)
- !!! ppm_param_kerel_laplace3d_2p
- !!! (2nd order Laplacian, polynomial in 3D)
- !!! ---------------------------------------
- !!!
- !!! To use your own kernel function, pass the function pointer here.
- !!! Your function should take one argument and return one value.
- !!! The third possibility is to pass a lookup table with tabulated
- !!! kernel values. Such a table can be created using
- !!! ppm_comp_pp_mk_table.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc
- !!! for description. Type can be single, double
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc
- !!! for description. Type can be single complex or double complex.
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
- REAL(MK) , INTENT(IN ) :: kpar
- !!! Kernel parameters. Lookup table version.
- !!! Pass dxtableinv (the inverse of the table spacing) as a scalar here.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(: ), INTENT(IN ) :: kernel
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(: ), INTENT(IN ) :: kernel
-#endif
- !!! lookup table with tabulated kernel values. Such a table can
- !!! be created using <<ppm_comp_pp_mk_table>>.
-#endif
- LOGICAL , INTENT(IN ) :: lsymm
- !!! Do symmetric PP interactions?
- TYPE(ppm_t_clist), DIMENSION(:), INTENT(IN) :: clist
- !!! Cell list as a list of ptr_to_clist.
- !!!
- !!! particle index list of isub: `clist(isub)%lpdx(:)` +
- !!! pointer to first particle in ibox of isub: ` clist(isub)%lhbx(ibox)`
- REAL(MK) , INTENT(IN ) :: cutoff2
- !!! Squared PP interaction cutoff. Should be .LE. cell size.
- INTEGER , INTENT( OUT) :: info
- !!! Returns status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: nsublist
- ! number of subdomains on the local processor
-
- ! counters
- INTEGER :: i,idom,ibox,jbox,idx
- INTEGER :: ipart,jpart,ip,jp
- INTEGER :: cbox,iinter,j,k,ispec
- ! coordinate differences
- REAL(MK) :: dx,dy,dz
- REAL(MK) :: factor,factor2
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) :: summ,summ2
- REAL(MK) :: eta,dm
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK) :: summ,summ2
- COMPLEX(MK) :: eta,dm
-#endif
- ! square of inter particle distance
- REAL(MK) :: dij,dij2,dij4,dij5
- ! start and end particle in a box
- INTEGER :: istart,iend,jstart,jend
- ! cell neighbor lists
- INTEGER, DIMENSION(:,:), POINTER :: inp,jnp
- ! number of interactions for each cell
- INTEGER, SAVE :: nnp
- ! cell offsets for box index
- INTEGER :: n1,n2,nz
- LOGICAL :: valid
- REAL(MK) :: t0
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-#if __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- REAL(MK), DIMENSION(:), INTENT(IN) :: kpar
- REAL(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- COMPLEX(MK), DIMENSION(:), INTENT(IN) :: kpar
- COMPLEX(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#endif
-#endif
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_comp_pp_cell',t0,info)
-
- !-------------------------------------------------------------------------
- ! Check arguments.
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_comp_pp_cell', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (Np .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_cell', &
- & 'Np must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda .LT. 1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_cell', &
- & 'lda must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_check_topoid(topoid,valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_cell', &
- & 'Topology ID not valid',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (cutoff2 .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_cell', &
- & 'cutoff2 must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __KERNEL == __LOOKUP_TABLE
- IF (kpar .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_cell', &
- & 'kpar (dxtableinv) must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF
-
- nsublist = ppm_topo(topoid)%t%nsublist
-
- !-------------------------------------------------------------------------
- ! Build interaction index lists
- !-------------------------------------------------------------------------
- CALL ppm_neighlist_MkNeighIdx(lsymm,inp,jnp,nnp,info)
-
- !-------------------------------------------------------------------------
- ! PARTICLE-PARTICLE INTERACTIONS using symmetry
- !-------------------------------------------------------------------------
- IF (lsymm) THEN
- DO idom=1,nsublist
- n1 = clist(idom)%Nm(1)
- n2 = clist(idom)%Nm(1)*clist(idom)%Nm(2)
- nz = clist(idom)%Nm(3)
- IF (ppm_dim .EQ. 2) THEN
- n2 = 0
- nz = 2
- ENDIF
- ! loop over all REAL cells (the -2 in the end does this)
- DO k=0,nz-2
- DO j=0,clist(idom)%Nm(2)-2
- DO i=0,clist(idom)%Nm(1)-2
- ! index of the center box
- cbox = i + 1 + n1*j + n2*k
- ! loop over all box-box interactions
- DO iinter=1,nnp
- ! determine box indices for this interaction
- ibox = cbox+(inp(1,iinter)+n1*inp(2,iinter)+ &
- & n2*inp(3,iinter))
- jbox = cbox+(jnp(1,iinter)+n1*jnp(2,iinter)+ &
- & n2*jnp(3,iinter))
- !-------------------------------------------------
- ! Read indices and check if box is empty
- !-------------------------------------------------
- istart = clist(idom)%lhbx(ibox)
- iend = clist(idom)%lhbx(ibox+1)-1
- IF (iend .LT. istart) CYCLE
- !-------------------------------------------------
- ! Within the box itself use symmetry and avoid
- ! adding the particle itself to its own list
- !-------------------------------------------------
- IF (ibox .EQ. jbox) THEN
- DO ipart=istart,iend
- ip = clist(idom)%lpdx(ipart)
- IF (lda .EQ. 1) THEN
- summ = 0.0_MK
-#ifdef __SXF90
-!CDIR NODEP
-#endif
- DO jpart=(ipart+1),iend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp here... and
- ! vice versa to use symmetry.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - &
- & pdata(1,ip))
- summ = summ + dm
- dpd(1,jp) = dpd(1,jp) - dm
- ENDDO
- dpd(1,ip) = dpd(1,ip) + summ
- ELSEIF (lda .EQ. 2) THEN
- summ = 0.0_MK
- summ2 = 0.0_MK
-#ifdef __SXF90
-!CDIR NODEP
-#endif
- DO jpart=(ipart+1),iend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp here... and
- ! vice versa to use symmetry.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - &
- & pdata(1,ip))
- summ = summ + dm
- dpd(1,jp) = dpd(1,jp) - dm
- dm = eta*(pdata(2,jp) - &
- & pdata(2,ip))
- summ2 = summ2 + dm
- dpd(2,jp) = dpd(2,jp) - dm
- ENDDO
- dpd(1,ip) = dpd(1,ip) + summ
- dpd(2,ip) = dpd(2,ip) + summ2
- ELSE
- DO jpart=(ipart+1),iend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp here... and
- ! vice versa to use symmetry.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata(ispec,jp)- &
- & pdata(ispec,ip))
- dpd(ispec,ip)=dpd(ispec,ip)+dm
- dpd(ispec,jp)=dpd(ispec,jp)-dm
- ENDDO
- ENDDO
- ENDIF
- ENDDO
- !-------------------------------------------------
- ! For the other boxes check all particles
- !-------------------------------------------------
- ELSE
- ! get pointers to first and last particle
- jstart = clist(idom)%lhbx(jbox)
- jend = clist(idom)%lhbx(jbox+1)-1
- ! skip this iinter if other box is empty
- IF (jend .LT. jstart) CYCLE
- ! loop over all particles inside this cell
- DO ipart=istart,iend
- ip = clist(idom)%lpdx(ipart)
- IF (lda .EQ. 1) THEN
- summ = 0.0_MK
- ! check against all particles
- ! in the other cell
-#ifdef __SXF90
-!CDIR NODEP
-#endif
- DO jpart=jstart,jend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp here... and
- ! vice versa to use symmetry.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - &
- & pdata(1,ip))
- summ = summ +dm
- dpd(1,jp) = dpd(1,jp) - dm
- ENDDO
- dpd(1,ip) = dpd(1,ip) + summ
- ELSEIF (lda .EQ. 2) THEN
- summ = 0.0_MK
- summ2 = 0.0_MK
- ! check against all particles
- ! in the other cell
-#ifdef __SXF90
-!CDIR NODEP
-#endif
- DO jpart=jstart,jend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp here... and
- ! vice versa to use symmetry.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - &
- & pdata(1,ip))
- summ = summ + dm
- dpd(1,jp) = dpd(1,jp) - dm
- dm = eta*(pdata(2,jp) - &
- & pdata(2,ip))
- summ2 = summ2 + dm
- dpd(2,jp) = dpd(2,jp) - dm
- ENDDO
- dpd(1,ip) = dpd(1,ip) + summ
- dpd(2,ip) = dpd(2,ip) + summ2
- ELSE
- ! check against all particles
- ! in the other cell
- DO jpart=jstart,jend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp here... and
- ! vice versa to use symmetry.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata(ispec,jp)- &
- & pdata(ispec,ip))
- dpd(ispec,ip)=dpd(ispec,ip)+dm
- dpd(ispec,jp)=dpd(ispec,jp)-dm
- ENDDO
- ENDDO
- ENDIF
- ENDDO
- ENDIF ! ibox .EQ. jbox
- ENDDO ! iinter
- ENDDO ! i
- ENDDO ! j
- ENDDO ! k
- ENDDO ! idom
-
- !-------------------------------------------------------------------------
- ! PARTICLE-PARTICLE INTERACTIONS not using symmetry
- !-------------------------------------------------------------------------
- ELSE
- DO idom=1,nsublist
- n1 = clist(idom)%Nm(1)
- n2 = clist(idom)%Nm(1)*clist(idom)%Nm(2)
- nz = clist(idom)%Nm(3)
- IF (ppm_dim .EQ. 2) THEN
- n2 = 0
- nz = 2
- ENDIF
- ! loop over all REAL cells (the -2 in the end does this)
- DO k=1,nz-2
- DO j=1,clist(idom)%Nm(2)-2
- DO i=1,clist(idom)%Nm(1)-2
- ! index of the center box
- cbox = i + 1 + n1*j + n2*k
- ! loop over all box-box interactions
- DO iinter=1,nnp
- ! determine box indices for this interaction
- ibox = cbox+(inp(1,iinter)+n1*inp(2,iinter)+ &
- & n2*inp(3,iinter))
- jbox = cbox+(jnp(1,iinter)+n1*jnp(2,iinter)+ &
- & n2*jnp(3,iinter))
- !-------------------------------------------------
- ! Read indices and check if box is empty
- !-------------------------------------------------
- istart = clist(idom)%lhbx(ibox)
- iend = clist(idom)%lhbx(ibox+1)-1
- IF (iend .LT. istart) CYCLE
- !-------------------------------------------------
- ! Do all interactions within the box itself
- !-------------------------------------------------
- IF (ibox .EQ. jbox) THEN
- DO ipart=istart,iend
- ip = clist(idom)%lpdx(ipart)
- IF (lda .EQ. 1) THEN
- DO jpart=istart,iend
- jp = clist(idom)%lpdx(jpart)
- ! No particle interacts with
- ! itself
- IF (ip .EQ. jp) CYCLE
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - &
- & pdata(1,ip))
- dpd(1,ip) = dpd(1,ip) + dm
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- DO jpart=istart,iend
- jp = clist(idom)%lpdx(jpart)
- ! No particle interacts with
- ! itself
- IF (ip .EQ. jp) CYCLE
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - &
- & pdata(1,ip))
- dpd(1,ip) = dpd(1,ip) + dm
- dm = eta*(pdata(2,jp) - &
- & pdata(2,ip))
- dpd(2,ip) = dpd(2,ip) + dm
- ENDDO
- ELSE
- DO jpart=istart,iend
- jp = clist(idom)%lpdx(jpart)
- ! No particle interacts with
- ! itself
- IF (ip .EQ. jp) CYCLE
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata(ispec,jp)- &
- & pdata(ispec,ip))
- dpd(ispec,ip)=dpd(ispec,ip)+dm
- ENDDO
- ENDDO
- ENDIF
- ENDDO
- !-------------------------------------------------
- ! Do interactions with all neighboring boxes
- !-------------------------------------------------
- ELSE
- ! get pointers to first and last particle
- jstart = clist(idom)%lhbx(jbox)
- jend = clist(idom)%lhbx(jbox+1)-1
- ! skip if empty
- IF (jend .LT. jstart) CYCLE
- ! loop over all particles inside this cell
- DO ipart=istart,iend
- ip = clist(idom)%lpdx(ipart)
- IF (lda .EQ. 1) THEN
- ! check against all particles
- ! in the other cell
- DO jpart=jstart,jend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - &
- & pdata(1,ip))
- dpd(1,ip) = dpd(1,ip) + dm
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- ! check against all particles
- ! in the other cell
- DO jpart=jstart,jend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - &
- & pdata(1,ip))
- dpd(1,ip) = dpd(1,ip) + dm
- dm = eta*(pdata(2,jp) - &
- & pdata(2,ip))
- dpd(2,ip) = dpd(2,ip) + dm
- ENDDO
- ELSE
- ! check against all particles
- ! in the other cell
- DO jpart=jstart,jend
- jp = clist(idom)%lpdx(jpart)
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx)+(dy*dy)+(dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx)+(dy*dy)
- ENDIF
- IF (dij .GT. cutoff2) CYCLE
- !---------------------------------
- ! Particle ip interacts with
- ! particle jp.
- !---------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata(ispec,jp)- &
- & pdata(ispec,ip))
- dpd(ispec,ip)=dpd(ispec,ip)+dm
- ENDDO
- ENDDO
- ENDIF
- ENDDO
- ENDIF ! ibox .EQ. jbox
- ENDDO ! iinter
- ENDDO ! i
- ENDDO ! j
- ENDDO ! k
- ENDDO ! idom
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_comp_pp_cell',t0,info)
- RETURN
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_cell_si
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_cell_di
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_cell_sci
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_cell_dci
-#endif
-
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_cell_su
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_cell_du
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_cell_scu
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_cell_dcu
-#endif
-
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_cell_st
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_cell_dt
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_cell_sct
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_cell_dct
-#endif
-#endif
diff --git a/src/ppm_comp_pp_correct.f b/src/ppm_comp_pp_correct.f
deleted file mode 100644
index 4a296579c4f2c9aa7b5b486085518090c605f1f3..0000000000000000000000000000000000000000
--- a/src/ppm_comp_pp_correct.f
+++ /dev/null
@@ -1,364 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_comp_pp_correct
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_correct_si(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_correct_di(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_correct_sci(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_correct_dci(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#endif
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_correct_su(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_correct_du(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_correct_scu(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_correct_dcu(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_correct_st(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_correct_dt(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_correct_sct(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_correct_dct(dh,cutoff,kernel,eps,kpar,targt, &
- & kappa,info)
-#endif
-#endif
- !!! Computes the discretisation correction factor
- !!! needed to ensure that the discrete second-order
- !!! moment of the kernel function is equal to some
- !!! value. The kernel is evaluated on a regular mesh
- !!! here, so this factor can only be used if the
- !!! particles are on a regular grid (e.g. after
- !!! remeshing).
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_write
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK), DIMENSION(:), INTENT(IN ) :: dh
- !!! grid spacings in all directions 1..ppm_dim
- REAL(MK) , INTENT(IN ) :: cutoff
- !!! PP interaction cutoff used. If no cutoff is used, pass a negative
- !!! value here.
- REAL(MK) , INTENT(IN ) :: eps
- !!! Kernel size (width)
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , INTENT(IN ) :: targt
- !!! target value for the second order kernel moment. Overloaded types:
- !!! single,double
- REAL(MK) , INTENT( OUT) :: kappa
- !!! computed discretisation correction factor. Every kernel evaluation has
- !!! to be multiplied with this in order to correct for discretisation
- !!! effects. Overloaded types: single,double
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK) , INTENT(IN ) :: targt
- !!! target value for the second order kernel moment. Overloaded types:
- !!! single complex, double complex
- COMPLEX(MK) , INTENT( OUT) :: kappa
- !!! computed discretisation correction factor. Every kernel evaluation has
- !!! to be multiplied with this in order to correct for discretisation
- !!! effects. Overloaded types: single complex, double complex
-#endif
-#if __KERNEL == __INTERNAL
- INTEGER , INTENT(IN ) :: kernel
- !!! kernel for which to compute the correction. To use ppm-internal
- !!! kernels, specify one of:
- !!!
- !!! ---------------------------------------
- !!! ppm_param_kerel_laplace2d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 2D)
- !!! ppm_param_kerel_laplace3d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 3D)
- !!! ---------------------------------------
- !!!
- !!! To use your own kernel function, pass the function pointer here. Your
- !!! function should take one argument and return one value.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:), INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single or complex.
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:), INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single complex or double complex.
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
- REAL(MK) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Pass dxtableinv (the inverse of the table spacing) as
- !!! a scalar here.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(: ), INTENT(IN ) :: kernel
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(: ), INTENT(IN ) :: kernel
-#endif
- !!! Lookup table with tabulated kernel values.
- !!! Such a table can be created using <<ppm_comp_pp_mk_table>>.
-#endif
- INTEGER , INTENT( OUT) :: info
- !!! Returns 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- REAL(MK) :: t0,dij2,dij4,dij5
- REAL(MK) :: hi,dx,dy,dz,dij,factor,factor2
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) :: eta,summ
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK) :: eta,summ
-#endif
- INTEGER :: lhx,lhy,lhz,i,j,k,idx
- CHARACTER(LEN=ppm_char) :: cbuf
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-#if __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:), INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- REAL(MK), DIMENSION(:), INTENT(IN) :: kpar
- REAL(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:), INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- COMPLEX(MK), DIMENSION(:), INTENT(IN) :: kpar
- COMPLEX(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#endif
-#endif
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_comp_pp_correct',t0,info)
- kappa = 1.0_MK
-
- !-------------------------------------------------------------------------
- ! Check arguments.
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_comp_pp_correct', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (eps .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_correct', &
- & 'eps must be > 0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (SIZE(dh,1) .LT. ppm_dim) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_correct', &
- & 'dh must be at least of length ppm_dim',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i=1,ppm_dim
- IF (dh(i) .LE. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_correct', &
- & 'dh must be >0 in all directions',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDDO
-#if __KERNEL == __LOOKUP_TABLE
- IF (kpar .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_correct', &
- & 'kpar (dxtableinv) must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Integration bounds
- !-------------------------------------------------------------------------
- IF (cutoff .GE. 0.0_MK) THEN
- hi = cutoff
- ELSE
- hi = 50.0_MK
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Summation bounds
- !-------------------------------------------------------------------------
- lhx = INT(hi/dh(1))
- lhy = INT(hi/dh(2))
- IF (ppm_dim .GT. 2) lhz = INT(hi/dh(3))
-
- !-------------------------------------------------------------------------
- ! Discrete sum
- !-------------------------------------------------------------------------
- summ = 0.0_MK
- IF (ppm_dim .GT. 2) THEN
- DO i=-lhx,lhx
- dx = REAL(i,MK)*dh(1)
- DO j=-lhy,lhy
- dy = REAL(j,MK)*dh(2)
- DO k=-lhz,lhz
- dz = REAL(k,MK)*dh(3)
- dij = dx*dx + dy*dy + dz*dz
-#include "ppm_comp_pp_kernels.inc"
- ! second order moment
- eta = dij*eta
- summ = summ + eta
- ENDDO
- ENDDO
- ENDDO
- summ = summ*dh(1)*dh(2)*dh(3)
- ELSE
- DO i=-lhx,lhx
- dx = REAL(i,MK)*dh(1)
- DO j=-lhy,lhy
- dy = REAL(j,MK)*dh(2)
- dij = dx*dx + dy*dy
-#include "ppm_comp_pp_kernels.inc"
- ! second order moment
- eta = dij*eta
- summ = summ + eta
- ENDDO
- ENDDO
- summ = summ*dh(1)*dh(2)
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Correction factor
- !-------------------------------------------------------------------------
-#if __KERNEL != __LOOKUP_TABLE
- kappa = (REAL(ppm_dim,MK)*targt*eps)/summ
-#endif
-
- !-------------------------------------------------------------------------
- ! Debug output
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 1) THEN
- WRITE(cbuf,'(A,F16.10)') 'Discretization correction factor: ',kappa
- CALL ppm_write(ppm_rank,'ppm_comp_pp_correct',cbuf,info)
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_comp_pp_correct',t0,info)
- RETURN
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_correct_si
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_correct_di
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_correct_sci
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_correct_dci
-#endif
-
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_correct_su
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_correct_du
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_correct_scu
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_correct_dcu
-#endif
-
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_correct_st
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_correct_dt
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_correct_sct
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_correct_dct
-#endif
-#endif
diff --git a/src/ppm_comp_pp_doring.f b/src/ppm_comp_pp_doring.f
deleted file mode 100644
index 2ac37d0a3a27064bffe71764ae21985639fae636..0000000000000000000000000000000000000000
--- a/src/ppm_comp_pp_doring.f
+++ /dev/null
@@ -1,632 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_comp_pp_doring
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_doring_si(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_doring_di(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_doring_sci(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_doring_dci(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#endif
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_doring_su(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_doring_du(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_doring_scu(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_doring_dcu(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_doring_st(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_doring_dt(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_doring_sct(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_doring_dct(xp,pdata,dpd,Mpart,xp2,pdata2,dpd2, &
- & Lpart,lda,lsymm,kernel,kpar,mode,info)
-#endif
-#endif
- !!! Computes direct particle-particle interactions using the
- !!! ring topology (N**2). This is called by ppm_comp_pp_ring and
- !!! not by the user directly.
- !!!
- !!! [NOTE]
- !!! The loops over lda are explicitly unrolled for the cases
- !!! lda.EQ.1 and lda.EQ.2 in order to allow vectorization in these cases.
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: xp
- !!! particle co-ordinates [Group 1]
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: xp2
- !!! particle co-ordinates [Group 2]
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: pdata
- !!! particle data used for interaction (e.g. vorticity, strength,...)
- !!! [Group 1]. Overloaded types: single,double
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: pdata2
- !!! particle data used for interaction (e.g. vorticity, strength,...)
- !!! [Group 2]. Overloaded types: single,double
- REAL(MK) , DIMENSION(:,:), INTENT(INOUT) :: dpd
- !!! Change of particle data due to interaction [Group 1]
- !!! Overloaded types: single,double
- REAL(MK) , DIMENSION(:,:), INTENT(INOUT) :: dpd2
- !!! Change of particle data due to interaction [Group 2]
- !!! Overloaded types: single,double
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:), INTENT(IN ) :: pdata
- !!! particle data used for interaction (e.g. vorticity, strength,...)
- !!! [Group 1]. Overloaded types: single complex, double complex.
- COMPLEX(MK), DIMENSION(:,:), INTENT(IN ) :: pdata2
- !!! particle data used for interaction (e.g. vorticity, strength,...)
- !!! [Group 2]. Overloaded types: single complex, double complex.
- COMPLEX(MK), DIMENSION(:,:), INTENT(INOUT) :: dpd
- !!! Change of particle data due to interaction [Group 1]
- !!! Overloaded types: single complex,double complex.
- COMPLEX(MK), DIMENSION(:,:), INTENT(INOUT) :: dpd2
- !!! Change of particle data due to interaction [Group 2]
- !!! Overloaded types: single complex,double complex.
-#endif
- INTEGER , INTENT(IN ) :: Mpart
- !!! number of particles [Group 1]
- INTEGER , INTENT(IN ) :: Lpart
- !!! number of particles [Group 2]
- INTEGER , INTENT(IN ) :: mode
- !!! Whether the two groups are the same or not:
- !!!
- !!! * 0 not the same group
- !!! * 1 the same group
- INTEGER , INTENT(IN ) :: lda
- !!! leading dimension of pdata,pdata2.
-#if __KERNEL == __INTERNAL
- INTEGER , INTENT(IN ) :: kernel
- !!! kernel for which to compute the correction. To use ppm-internal
- !!! kernels, specify one of:
- !!!
- !!! ---------------------------------------
- !!! ppm_param_kerel_laplace2d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 2D)
- !!! ppm_param_kerel_laplace3d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 3D)
- !!! ---------------------------------------
- !!!
- !!! To use your own kernel function, pass the function pointer here. Your
- !!! function should take one argument and return one value.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single or complex.
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single complex or double complex.
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
- REAL(MK) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Pass dxtableinv (the inverse of the table spacing) as
- !!! a scalar here.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(: ), INTENT(IN ) :: kernel
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(: ), INTENT(IN ) :: kernel
-#endif
- !!! Lookup table with tabulated kernel values.
- !!! Such a table can be created using <<ppm_comp_pp_mk_table>>.
-#endif
- LOGICAL , INTENT(IN ) :: lsymm
- !!! Whether to use symmetry or not
- INTEGER , INTENT( OUT) :: info
- !!! Returns status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! counters
- INTEGER :: i,j,ispec,idx
- ! coordinate differences
- REAL(MK) :: dx,dy,dz
- REAL(MK) :: factor,factor2
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) :: summ,summ2
- REAL(MK) :: eta,dm
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK) :: summ,summ2
- COMPLEX(MK) :: eta,dm
-#endif
- ! square of inter particle distance
- REAL(MK) :: dij,dij2,dij4,dij5
- REAL(MK) :: t0
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-#if __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- REAL(MK), DIMENSION(:), INTENT(IN) :: kpar
- REAL(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- COMPLEX(MK), DIMENSION(:), INTENT(IN) :: kpar
- COMPLEX(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#endif
-#endif
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_comp_pp_doring',t0,info)
-
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (Mpart .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_doring', &
- & 'Np must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (Lpart .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_doring', &
- & 'Np must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda .LT. 1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_doring', &
- & 'lda must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((mode .NE. 0) .AND. (mode .NE. 1)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_doring', &
- & 'mode must be either 0 or 1',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __KERNEL == __LOOKUP_TABLE
- IF (kpar .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_doring', &
- & 'kpar (dxtableinv) must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Check if we are computing the selfinteraction (i.e. Group1 .EQ. Group2)
- !-------------------------------------------------------------------------
- IF (mode .EQ. 1) THEN
- IF (lsymm) THEN
- !-----------------------------------------------------------------
- ! SYMMETRY
- !-----------------------------------------------------------------
- IF (lda .EQ. 1) THEN
- DO i = 1,Mpart
- summ = 0.0_MK
- DO j = i+1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j and vice versa
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata2(1,j) - pdata(1,i))
- summ = summ + dm
- dpd2(1,j) = dpd2(1,j) - dm
- ENDDO
- dpd(1,i) = dpd(1,i) + summ
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- DO i = 1,Mpart
- summ = 0.0_MK
- summ2 = 0.0_MK
- DO j = i+1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j and vice versa
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata2(1,j) - pdata(1,i))
- summ = summ + dm
- dpd2(1,j) = dpd2(1,j) - dm
- dm = eta*(pdata2(2,j) - pdata(2,i))
- summ2 = summ2 + dm
- dpd2(2,j) = dpd2(2,j) - dm
- ENDDO
- dpd(1,i) = dpd(1,i) + summ
- dpd(2,i) = dpd(2,i) + summ2
- ENDDO
- ELSE
- DO i = 1,Mpart
- DO j = i+1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j and vice versa
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata2(ispec,j) - pdata(ispec,i))
- dpd(ispec,i) = dpd(ispec,i) + dm
- dpd2(ispec,j) = dpd2(ispec,j) - dm
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ELSE
- !-----------------------------------------------------------------
- ! NO SYMMETRY
- !-----------------------------------------------------------------
- IF (lda .EQ. 1) THEN
- DO i = 1,Mpart
- DO j = 1,Lpart
- IF (i .EQ. j) CYCLE
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata2(1,j) - pdata(1,i))
- dpd(1,i) = dpd(1,i) + dm
- ENDDO
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- DO i = 1,Mpart
- DO j = 1,Lpart
- IF (i .EQ. j) CYCLE
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata2(1,j) - pdata(1,i))
- dpd(1,i) = dpd(1,i) + dm
- dm = eta*(pdata2(2,j) - pdata(2,i))
- dpd(2,i) = dpd(2,i) + dm
- ENDDO
- ENDDO
- ELSE
- DO i = 1,Mpart
- DO j = 1,Lpart
- IF (i .EQ. j) CYCLE
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata2(ispec,j) - pdata(ispec,i))
- dpd(ispec,i) = dpd(ispec,i) + dm
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! non-self interaction (i.e. Group1 .NE. Group2)
- !-------------------------------------------------------------------------
- ELSE
- IF (lsymm) THEN
- !-----------------------------------------------------------------
- ! SYMMETRY
- !-----------------------------------------------------------------
- IF (lda .EQ. 1) THEN
- DO i = 1,Mpart
- summ = 0.0_MK
- DO j = 1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j and vice versa
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata2(1,j) - pdata(1,i))
- summ = summ + dm
- dpd2(1,j) = dpd2(1,j) - dm
- ENDDO
- dpd(1,i) = dpd(1,i) + summ
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- DO i = 1,Mpart
- summ = 0.0_MK
- summ2 = 0.0_MK
- DO j = 1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j and vice versa
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata2(1,j) - pdata(1,i))
- summ = summ + dm
- dpd2(1,j) = dpd2(1,j) - dm
- dm = eta*(pdata2(2,j) - pdata(2,i))
- summ2 = summ2 + dm
- dpd2(2,j) = dpd2(2,j) - dm
- ENDDO
- dpd(1,i) = dpd(1,i) + summ
- dpd(2,i) = dpd(2,i) + summ2
- ENDDO
- ELSE
- DO i = 1,Mpart
- DO j = 1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j and vice versa
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata2(ispec,j) - pdata(ispec,i))
- dpd(ispec,i) = dpd(ispec,i) + dm
- dpd2(ispec,j) = dpd2(ispec,j) - dm
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ELSE
- !-----------------------------------------------------------------
- ! NO SYMMETRY
- !-----------------------------------------------------------------
- IF (lda .EQ. 1) THEN
- DO i = 1,Mpart
- DO j = 1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata2(1,j) - pdata(1,i))
- dpd(1,i) = dpd(1,i) + dm
- ENDDO
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- DO i = 1,Mpart
- DO j = 1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata2(1,j) - pdata(1,i))
- dpd(1,i) = dpd(1,i) + dm
- dm = eta*(pdata2(2,j) - pdata(2,i))
- dpd(2,i) = dpd(2,i) + dm
- ENDDO
- ENDDO
- ELSE
- DO i = 1,Mpart
- DO j = 1,Lpart
- dx = xp(1,i) - xp2(1,j)
- dy = xp(2,i) - xp2(2,j)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,i) - xp2(3,j)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !--------------------------------------------------------
- ! Particle i interacts with j
- !--------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata2(ispec,j) - pdata(ispec,i))
- dpd(ispec,i) = dpd(ispec,i) + dm
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_comp_pp_doring',t0,info)
- RETURN
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_doring_si
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_doring_di
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_doring_sci
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_doring_dci
-#endif
-
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_doring_su
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_doring_du
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_doring_scu
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_doring_dcu
-#endif
-
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_doring_st
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_doring_dt
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_doring_sct
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_doring_dct
-#endif
-#endif
diff --git a/src/ppm_comp_pp_kernels.inc b/src/ppm_comp_pp_kernels.inc
deleted file mode 100644
index 554f5ae5ffd3a6ceedbcc1a4d2dcebe656a8344d..0000000000000000000000000000000000000000
--- a/src/ppm_comp_pp_kernels.inc
+++ /dev/null
@@ -1,188 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for different PP kernels. This is included in all
- ! the pse_comp_pp* routines wherever kernel evaluations are needed.
- ! Only change this file to add/edit kernel functions.
- !
- ! INPUT: dij is the squared distance between particles i and j
- ! All kernel parameters need to be passed in kpar(:).
- ! dx, dy and dz are the components of the inter particle vector.
- ! OUTPUT: eta is the kernel value for the given distance
- !
- ! Remark: Should SXF90 stop to unfold the loops (swap IF and DO)
- ! because the number of kernels grows too big, we will simply make
- ! several such .inc files and make several versions of the comp_pp
- ! routines with cpp if to choose the proper include file.
- !-------------------------------------------------------------------------
- ! $Log: ppm_comp_pp_kernels.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.4 2004/11/11 15:27:09 ivos
- ! Optimized PSE kernels for speed.
- !
- ! Revision 1.3 2004/10/13 16:42:11 davidch
- ! added support for 3d sph kernels
- !
- ! Revision 1.2 2004/07/29 15:56:48 hiebers
- ! added kernel_sph2d_p2 and kernel_dx_sph2d_p2
- !
- ! Revision 1.1 2004/07/23 12:57:31 ivos
- ! Initial implementation. Not tested.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __KERNEL == __INTERNAL
- IF (kernel .EQ. ppm_param_kernel_fast3d) THEN
- !---------------------------------------------------------------------
- ! 2nd order sph kernel 3d
- ! kpar(1) cutoff^2
- ! kpar(2) 1/cutoff^9
- ! eta(delta^2) = 315/64/Pi/cutoff^9*(cutoff^2-r^2)^3
- !---------------------------------------------------------------------
- factor = kpar(1) - dij
- eta = 1.5666814710608_MK * kpar(2)
- eta = eta * factor * factor * factor
- ELSEIF (kernel .EQ. ppm_param_kernel_fast3d_dx) THEN
- !---------------------------------------------------------------------
- ! 2nd order sph kernel 3d, dx
- ! kpar(1) cutoff^2
- ! kpar(2) 1/cutoff^9
- ! eta(delta^2) = -945/32/Pi/cutoff^9*(cutoff^2-r^2)^2*x
- !---------------------------------------------------------------------
- factor = kpar(1) - dij
- eta = -9.400088826365_MK * kpar(2) * dx
- eta = eta * factor * factor
- ELSEIF (kernel .EQ. ppm_param_kernel_fast3d_dy) THEN
- !---------------------------------------------------------------------
- ! 2nd order sph kernel 3d, dy
- ! kpar(1) cutoff^2
- ! kpar(2) 1/cutoff^9
- ! eta(delta^2) = -945/32/Pi/cutoff^9*(cutoff^2-r^2)^2*y
- !---------------------------------------------------------------------
- factor = kpar(1) - dij
- eta = -9.400088826365_MK * kpar(2) * dy
- eta = eta * factor * factor
- ELSEIF (kernel .EQ. ppm_param_kernel_fast3d_dz) THEN
- !---------------------------------------------------------------------
- ! 2nd order sph kernel 3d, dz
- ! kpar(1) cutoff^2
- ! kpar(2) 1/cutoff^9
- ! eta(delta^2) = -945/32/Pi/cutoff^9*(cutoff^2-r^2)^2*z
- !---------------------------------------------------------------------
- factor = kpar(1) - dij
- eta = -9.400088826365_MK * kpar(2) * dz
- eta = eta * factor * factor
- ELSEIF (kernel .EQ. ppm_param_kernel_fast3d_lap) THEN
- !---------------------------------------------------------------------
- ! 2nd order sph kernel 3d, laplacian
- ! kpar(1) cutoff^2
- ! kpar(2) 1/cutoff^9
- ! eta(delta^2) = -945/32/Pi/cutoff^9*(cutoff^2-r^2)(3*cutoff^2-7*r^2)
- !---------------------------------------------------------------------
- factor = kpar(1) - dij
- factor2 = 3.0_MK * kpar(1) - 7.0_MK * dij
- eta = -9.400088826365_MK * kpar(2)
- eta = eta * factor * factor2
- ELSEIF (kernel .EQ. ppm_param_kernel_laplace2d_p2) THEN
- !---------------------------------------------------------------------
- ! 2nd order polynomial kernel 2D.
- ! kpar(1) eps2inv (1/eps**2)
- ! kpar(2) correction*15.0*dh^2*eps^(-4)/pi^2
- !---------------------------------------------------------------------
- dij = dij*kpar(1)
- dij2 = dij*dij
- dij4 = dij2*dij2
- dij5 = dij4*dij
- eta = dij5 + 1.0_MK
- eta = kpar(2)/eta
- ELSEIF (kernel .EQ. ppm_param_kernel_laplace3d_p2) THEN
- !---------------------------------------------------------------------
- ! 2nd order polynomial kernel 3D.
- ! kpar(1) eps2inv (1/eps**2)
- ! kpar(2) correction*15.0*dh^3*eps^(-5)/pi^2
- !---------------------------------------------------------------------
- dij = dij*kpar(1)
- dij2 = dij*dij
- dij4 = dij2*dij2
- dij5 = dij4*dij
- eta = dij5 + 1.0_MK
- eta = kpar(2)/eta
- ELSEIF (kernel .EQ. ppm_param_kernel_sph2d_p2 ) THEN
- !---------------------------------------------------------------------
- ! 2nd order quartic spline kernel M5 2D.
- ! kpar(1) eps (kernel width)
- ! kpar(2) eps2 (eps**2)
- ! kpar(3) eps2inv (1/eps**2)
- ! kpar(4) eps5inv (1/eps**4)
- ! kpar(5) dh3 (particle volume)
- ! kpar(6) piinv (1/PI, the math constant)
- ! kpar(7) kappa (discretisation correction factor)
- !---------------------------------------------------------------------
- factor = kpar(3)*kpar(6)
- dij2 = dij*kpar(3)
- dij = sqrt( dij2 )
-
- IF (dij.LT.2.5_MK) THEN
- IF (dij.LT.1.5_MK) THEN
- IF (dij.LT.0.5_MK) THEN
- eta = 0.3_MK*dij2*dij2 - 0.75_MK*dij2 + 0.71875_MK
- ELSE
- eta = -0.2_MK*dij2*dij2 + dij2*dij - 1.5_MK*dij2 &
- & + 0.25_MK*dij+0.6875_MK
- ENDIF
- ELSE
- dij4 = 2.5_MK - dij
- eta = 0.05_MK*dij4*dij4*dij4*dij4
- ENDIF
- ELSE
- eta = 0.0_MK
- ENDIF
- eta = eta*factor*kpar(7)
- ELSEIF (kernel .EQ. ppm_param_kernel_dx_sph2d_p2 ) THEN
- !---------------------------------------------------------------------
- ! 2nd order quartic spline kernel M5 2D for first Derivative d/dx.
- ! kpar(1) eps (kernel width)
- ! kpar(2) epsinv (1/eps)
- ! kpar(3) eps2inv (1/eps**2)
- ! kpar(4) eps5inv (1/eps**4)
- ! kpar(5) dh3 (particle volume)
- ! kpar(6) piinv (1/PI, the math constant)
- ! kpar(7) kappa (discretisation correction factor)
- !---------------------------------------------------------------------
- factor = kpar(3)*kpar(6)
- dij2 = dij*kpar(3)
- dij = sqrt( dij2 )
-
- IF ( dij.LT.2.5_MK .AND. dij>0.0_MK ) THEN
- IF (dij.LT.1.5_MK) THEN
- IF (dij.LT.0.5_MK) THEN
- eta = 1.2_MK*dij2*dij - 1.5_MK*dij
- ELSE
- eta = -0.8_MK*dij2*dij + 3_MK*dij2 - 3_MK*dij + 0.25_MK
- ENDIF
- ELSE
- dij4 = 2.5_MK - dij
- eta = -0.2_MK*dij4*dij4*dij4
- ENDIF
- ELSE
- eta = 0.0_MK
- ENDIF
- eta = eta*factor*kpar(7)*kpar(2)/dij*dx
-! eta = eta*factor*kpar(7)*kpar(2)/dij
- ELSE
- !---------------------------------------------------------------------
- ! This ELSE is needed to avoid funny action when an invalid
- ! kernel is specified (and to make SXF90 unfold the loops).
- !---------------------------------------------------------------------
- eta = 0.0_MK
- ENDIF
-#elif __KERNEL == __USER_FUNCTION
- eta = kernel(dij,kpar)
-#elif __KERNEL == __LOOKUP_TABLE
- idx = INT(dij*kpar)
- eta = kernel(idx)
-#endif
diff --git a/src/ppm_comp_pp_mk_table.f b/src/ppm_comp_pp_mk_table.f
deleted file mode 100644
index 9b9e665f79b59a72949dbefab84f3fc552a0a8eb..0000000000000000000000000000000000000000
--- a/src/ppm_comp_pp_mk_table.f
+++ /dev/null
@@ -1,268 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_comp_pp_mk_table
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_mk_table_si(kernel,kpar,ntable,cutoff2, &
- & ktab,dxtableinv,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_mk_table_di(kernel,kpar,ntable,cutoff2, &
- & ktab,dxtableinv,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_mk_table_sci(kernel,kpar,ntable,cutoff2, &
- & ktab,dxtableinv,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_mk_table_dci(kernel,kpar,ntable,cutoff2, &
- & ktab,dxtableinv,info)
-#endif
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_mk_table_su(kernel,kpar,ntable,cutoff2, &
- & ktab,dxtableinv,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_mk_table_du(kernel,kpar,ntable,cutoff2, &
- & ktab,dxtableinv,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_mk_table_scu(kernel,kpar,ntable,cutoff2, &
- & ktab,dxtableinv,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_mk_table_dcu(kernel,kpar,ntable,cutoff2, &
- & ktab,dxtableinv,info)
-#endif
-#endif
- !!! Creates a lookup table for a PP interaction kernel.
- !!! The result is returned in the variables ktab with
- !!! indices running from 0 to ntable-1. The table
- !!! contains kernel values eta as a function of the
- !!! _squared_ distance x**2.
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER , INTENT(IN ) :: ntable
- !!! Number of table entries to be created.
- REAL(MK) , INTENT(IN ) :: cutoff2
- !!! Square of the cutoff used for PP interactions. The kernel will be
- !!! tabulated up to this value.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:), POINTER :: ktab
- !!! Tabulated kernel values 0...ntable-1.
- !!! Overloaded types: single,double.
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK) , DIMENSION(:), POINTER :: ktab
- !!! Tabulated kernel values 0...ntable-1.
- !!! Overloaded types: single complex,double complex.
-#endif
-#if __KERNEL == __INTERNAL
- INTEGER , INTENT(IN ) :: kernel
- !!! kernel for which to compute the correction. To use ppm-internal
- !!! kernels, specify one of:
- !!!
- !!! ---------------------------------------
- !!! ppm_param_kerel_laplace2d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 2D)
- !!! ppm_param_kerel_laplace3d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 3D)
- !!! ---------------------------------------
- !!!
- !!! To use your own kernel function, pass the function pointer here. Your
- !!! function should take one argument and return one value.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
-#endif
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single, double, single complex or double
- !!! complex. Omit this argument when using a lookup table.
-#endif
- REAL(MK) , INTENT( OUT) :: dxtableinv
- !!! inverse of the dx (kernel evaluation locations) used to create
- !!! the table. To use the table, look up the value
- !!! `ktab(INT(dxtableinv*x))`.
- INTEGER , INTENT( OUT) :: info
- !!! Returns status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,atable,iopt,idx
- INTEGER, DIMENSION(1) :: ldl,ldu
- REAL(MK), PARAMETER :: Rmin = 0.0_MK
- REAL(MK) :: dxtable,Rmax,factor,factor2
- REAL(MK) :: t0,dij,dij2,dij4,dij5,dx,dy,dz
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) :: eta
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK) :: eta
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-#if __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- REAL(MK), DIMENSION(:), INTENT(IN) :: kpar
- REAL(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- COMPLEX(MK), DIMENSION(:), INTENT(IN) :: kpar
- COMPLEX(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#endif
-#endif
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_comp_pp_mk_table',t0,info)
-
- !-------------------------------------------------------------------------
- ! Check arguments.
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (ntable .LT. 1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_mk_table', &
- & 'ntable must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (cutoff2 .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_mk_table', &
- & 'cutoff2 must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Compute Rmax
- !-------------------------------------------------------------------------
- Rmax = cutoff2
-
- !-------------------------------------------------------------------------
- ! Allocate memory for table lookup
- !-------------------------------------------------------------------------
- atable = ntable-1
-
- iopt = ppm_param_alloc_fit
- ldl(1) = 0
- ldu(1) = atable
- CALL ppm_alloc(ktab,ldl,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_comp_pp_mk_table', &
- & 'kernel lookup table KTAB',__LINE__,info)
- GOTO 9999
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Compute values
- !-------------------------------------------------------------------------
- dxtable = (Rmax - Rmin)/REAL(atable,MK)
- dxtableinv = 1.0_MK/dxtable
-
- ! This hack is needed since some kernels use dx,dy,dz explicitly. DO
- ! NOT MAKE TABLES FOR THOSE KERNELS!
- dx = 0.0_MK
- dy = 0.0_MK
- dz = 0.0_MK
- DO i=0,atable
- dij = Rmin + REAL(i,MK)*dxtable
-#include "ppm_comp_pp_kernels.inc"
- ktab(i) = eta
- ENDDO
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_comp_pp_mk_table',t0,info)
- RETURN
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_mk_table_si
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_mk_table_di
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_mk_table_sci
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_mk_table_dci
-#endif
-
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_mk_table_su
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_mk_table_du
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_mk_table_scu
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_mk_table_dcu
-#endif
-#endif
diff --git a/src/ppm_comp_pp_ring.f b/src/ppm_comp_pp_ring.f
deleted file mode 100644
index d77e927e680798a177c12e5635c34d9409bec1ba..0000000000000000000000000000000000000000
--- a/src/ppm_comp_pp_ring.f
+++ /dev/null
@@ -1,512 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_comp_pp_ring
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_ring_si(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_ring_di(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_ring_sci(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_ring_dci(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#endif
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_ring_su(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_ring_du(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_ring_scu(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_ring_dcu(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_ring_st(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_ring_dt(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_ring_sct(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_ring_dct(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & dpd,info)
-#endif
-#endif
- !!! Subroutine which computes kernel interactions by
- !!! direct global (N**2) particle-particle
- !!! interactions using the ring topology.
- !!!
- !!! [NOTE]
- !!! dpd needs to be allocated to proper size before
- !!! calling this routine. Also, this routine is not
- !!! resetting dpd to zero before doing the PP interactions.
- !!! This allows contributions from different kernels to be
- !!! accumulated. If needed, set it to zero before calling this
- !!! routine the first time.
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_map
- USE ppm_module_comp_pp_doring
- USE ppm_module_map_part
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: xp
- !!! particle positions
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: pdata
- !!! particle data (e.g. strengths).
- !!! Overloaded types: single,double
- REAL(MK) , DIMENSION(:,:), INTENT( OUT) :: dpd
- !!! Change of particle data (pdata) due to interaction.
- !!! Overloaded types: single,double.
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:), INTENT(IN ) :: pdata
- !!! particle data (e.g. strengths).
- !!! Overloaded types: single complex,double complex.
- COMPLEX(MK), DIMENSION(:,:), INTENT( OUT) :: dpd
- !!! Change of particle data (pdata) due to interaction.
- !!! Overloaded types: single complex,double complex.
-#endif
- LOGICAL , INTENT(IN ) :: lsymm
- !!! Whether to use symmetry or not:
- !!!
- !!! * `.FALSE.` PP interaction w/o symmetry
- !!! * `.TRUE.` PP interaction w/ symmetry
- INTEGER , INTENT(IN ) :: Np
- !!! number of particles on local proc.
- INTEGER , INTENT(IN ) :: lda
- !!! leading dimension of pdata.
-#if __KERNEL == __INTERNAL
- INTEGER , INTENT(IN ) :: kernel
- !!! kernel for which to compute the correction. To use ppm-internal
- !!! kernels, specify one of:
- !!!
- !!! ---------------------------------------
- !!! ppm_param_kerel_laplace2d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 2D)
- !!! ppm_param_kerel_laplace3d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 3D)
- !!! ---------------------------------------
- !!!
- !!! To use your own kernel function, pass the function pointer here. Your
- !!! function should take one argument and return one value.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single or complex.
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single complex or double complex.
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
- REAL(MK) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Pass dxtableinv (the inverse of the table spacing) as
- !!! a scalar here.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(: ), INTENT(IN ) :: kernel
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(: ), INTENT(IN ) :: kernel
-#endif
- !!! Lookup table with tabulated kernel values.
- !!! Such a table can be created using <<ppm_comp_pp_mk_table>>.
-#endif
- INTEGER , INTENT( OUT) :: info
- !!! Returns status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,j
- INTEGER :: hops,isource,itarget
- INTEGER :: ll,lu,rl,ru
- INTEGER :: Lpart,iopt
- INTEGER , DIMENSION(2) :: ldu
- REAL(MK) , DIMENSION(:,:), POINTER :: xp2
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:,:), POINTER :: pdata2,dpd2
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:), POINTER :: pdata2,dpd2
-#endif
- REAL(MK) :: t0
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-#if __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- REAL(MK), DIMENSION(:), INTENT(IN) :: kpar
- REAL(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- COMPLEX(MK), DIMENSION(:), INTENT(IN) :: kpar
- COMPLEX(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#endif
-#endif
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_comp_pp_ring',t0,info)
-
- !-------------------------------------------------------------------------
- ! Check arguments.
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_comp_pp_ring', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (Np .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_ring', &
- & 'Np must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda .LT. 1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_ring', &
- & 'lda must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __KERNEL == __LOOKUP_TABLE
- IF (kpar .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_ring', &
- & 'kpar (dxtableinv) must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Allocate memory for the copy of the local particles
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu(1) = ppm_dim
- ldu(2) = Np
- CALL ppm_alloc(xp2,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_comp_pp_ring', &
- & 'local copy of xp XP2',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu(1) = lda
- ldu(2) = Np
- CALL ppm_alloc(pdata2,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_comp_pp_ring', &
- & 'local copy of pdata PDATA2',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(dpd2,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_comp_pp_ring', &
- & 'local copy of dpd DPD2',__LINE__,info)
- GOTO 9999
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Make a copy of all local particles including all additional info
- ! that they carry
- !-------------------------------------------------------------------------
- Lpart = Np
- xp2(1:ppm_dim,1:Np) = xp(1:ppm_dim,1:Np)
- pdata2(1:lda,1:Np) = pdata(1:lda,1:Np)
- dpd2(1:lda,1:Np) = dpd(1:lda,1:Np)
-
- !-------------------------------------------------------------------------
- ! Calculate the interactions of the local particles with themselves.
- !-------------------------------------------------------------------------
- CALL ppm_comp_pp_doring(xp,pdata,dpd,Np,xp2,pdata2,dpd2,Lpart,lda, &
- & lsymm,kernel,kpar,1,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_comp_pp_ring', &
- & 'Interaction calculation failed.',__LINE__,info)
- GOTO 9999
- ENDIF
-
-#ifdef __MPI
- !-------------------------------------------------------------------------
- ! Compute whom to send the copy and who to receive the copy from
- !-------------------------------------------------------------------------
- itarget = MOD(ppm_nproc+ppm_rank-1,ppm_nproc)
- isource = MOD(ppm_rank+1,ppm_nproc)
-
- !-------------------------------------------------------------------------
- ! Compute how often we have to shift a copy of the particles to the
- ! neighbour processor
- !-------------------------------------------------------------------------
- IF (lsymm) THEN
- IF (MOD(ppm_nproc,2) .EQ. 0) THEN
- hops = (ppm_nproc/2)-1
- ELSE
- hops = ((ppm_nproc+1)/2)-1
- ENDIF
- ELSE
- hops = ppm_nproc-1
- ENDIF
-
- DO i = 1,hops
- !TODO: check the argument quantity accuracy
- CALL ppm_map_part_ring_shift(xp2,ppm_dim,Lpart,itarget,isource,info)
- CALL ppm_map_part_push(pdata2,lda,Lpart,info)
- CALL ppm_map_part_push(dpd2,lda,Lpart,info)
-
- CALL ppm_map_part_send(Lpart,Lpart,info)
-
- CALL ppm_map_part_pop(dpd2,lda,Lpart,Lpart,info)
- CALL ppm_map_part_pop(pdata2,lda,Lpart,Lpart,info)
- CALL ppm_map_part_pop(xp2,ppm_dim,Lpart,Lpart,info)
-
- CALL ppm_comp_pp_doring(xp,pdata,dpd,Np,xp2,pdata2,dpd2,Lpart, &
- & lda,lsymm,kernel,kpar,0,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_comp_pp_ring', &
- & 'Interaction calculation failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDDO
-
- !-------------------------------------------------------------------------
- ! If we have symmetry we only have send the particles half the round,
- ! so we have to check the case of an even number of processors
- !-------------------------------------------------------------------------
- IF (lsymm .AND. (MOD(ppm_nproc,2) .EQ. 0)) THEN
- !TODO: check the argument quantity accuracy
- CALL ppm_map_part_ring_shift(xp2,ppm_dim,Lpart,itarget,isource,info)
- CALL ppm_map_part_push(pdata2,lda,Lpart,info)
- CALL ppm_map_part_push(dpd2,lda,Lpart,info)
-
- CALL ppm_map_part_send(Lpart,Lpart,info)
-
- CALL ppm_map_part_pop(dpd2,lda,Lpart,Lpart,info)
- CALL ppm_map_part_pop(pdata2,lda,Lpart,Lpart,info)
- CALL ppm_map_part_pop(xp2,ppm_dim,Lpart,Lpart,info)
-
- !---------------------------------------------------------------------
- ! The processor with the higher ppm_rank computes the upper half of
- ! the particles and the opposite processor the lower half
- !---------------------------------------------------------------------
- IF (ppm_rank .GT. hops) THEN
- ll = (Np / 2) + 1
- lu = Np
- rl = 1
- ru = Lpart
- ELSE
- ll = 1
- lu = Np
- rl = 1
- ru = Lpart / 2
- ENDIF
-
- CALL ppm_comp_pp_doring(xp(:,ll:lu),pdata(:,ll:lu),dpd(:,ll:lu),&
- & lu-ll+1,xp2(:,rl:ru),pdata2(:,rl:ru), &
- & dpd2(:,rl:ru),ru-rl+1,lda,lsymm,kernel,kpar, &
- & 0,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_comp_pp_ring', &
- & 'Interaction calculation failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Send the particles where they belong to
- !-------------------------------------------------------------------------
- IF (lsymm) THEN
- itarget = MOD(ppm_rank+(ppm_nproc/2),ppm_nproc)
- isource = MOD(ppm_nproc+ppm_rank-(ppm_nproc/2),ppm_nproc)
- ENDIF
-
- IF (itarget .NE. ppm_rank) THEN
- !TODO: check the argument quantity accuracy
- CALL ppm_map_part_ring_shift(xp2,ppm_dim,Lpart,itarget,isource,info)
- CALL ppm_map_part_push(pdata2,lda,Lpart,info)
- CALL ppm_map_part_push(dpd2,lda,Lpart,info)
-
- CALL ppm_map_part_send(Lpart,Lpart,info)
-
- CALL ppm_map_part_pop(dpd2,lda,Lpart,Lpart,info)
- CALL ppm_map_part_pop(pdata2,lda,Lpart,Lpart,info)
- CALL ppm_map_part_pop(xp2,ppm_dim,Lpart,Lpart,info)
-
- IF (Lpart .NE. Np) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_part_lost,'ppm_comp_pp_ring', &
- & 'Not all particles came back!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
-#endif
-
- !-------------------------------------------------------------------------
- ! Add the particle changes of the local and the long traveled copy
- !-------------------------------------------------------------------------
- IF (lda .EQ. 1) THEN
- DO i = 1,Np
- dpd(1,i) = dpd(1,i) + dpd2(1,i)
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- DO i = 1,Np
- dpd(1,i) = dpd(1,i) + dpd2(1,i)
- dpd(2,i) = dpd(2,i) + dpd2(2,i)
- ENDDO
- ELSE
- DO i = 1,Np
- DO j = 1,lda
- dpd(j,i) = dpd(j,i) + dpd2(j,i)
- ENDDO
- ENDDO
- ENDIF
-
- 9999 CONTINUE
-
- !-------------------------------------------------------------------------
- ! Deallocate memory of copies
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(dpd2,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_comp_pp_ring', &
- & 'local copy of dpd DPD2',__LINE__,info)
- ENDIF
- CALL ppm_alloc(pdata2,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_comp_pp_ring', &
- & 'local copy of pdata PDATA2',__LINE__,info)
- ENDIF
- CALL ppm_alloc(xp2,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_comp_pp_ring', &
- & 'local copy of xp XP2',__LINE__,info)
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- CALL substop('ppm_comp_pp_ring',t0,info)
- RETURN
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_ring_si
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_ring_di
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_ring_sci
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_ring_dci
-#endif
-
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_ring_su
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_ring_du
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_ring_scu
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_ring_dcu
-#endif
-
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_ring_st
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_ring_dt
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_ring_sct
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_ring_dct
-#endif
-#endif
diff --git a/src/ppm_comp_pp_verlet.f b/src/ppm_comp_pp_verlet.f
deleted file mode 100644
index 0b0949fa6462fd4126866b7cc955adcf9de6ca37..0000000000000000000000000000000000000000
--- a/src/ppm_comp_pp_verlet.f
+++ /dev/null
@@ -1,514 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_comp_pp_verlet
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_verlet_si(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_verlet_di(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_verlet_sci(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_verlet_dci(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#endif
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_verlet_su(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_verlet_du(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_verlet_scu(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_verlet_dcu(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_comp_pp_verlet_st(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_comp_pp_verlet_dt(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_verlet_sct(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_comp_pp_verlet_dct(xp,Np,pdata,lda,lsymm,kernel,kpar, &
- & nvlist,vlist,dpd,info)
-#endif
-#endif
- !!! Subroutine which computes kernel interactions by direct
- !!! particle-particle interactions using Verlet lists.
- !!!
- !!! [NOTE]
- !!! ======================================================================
- !!! The loops for lda.EQ.1 and lda.EQ.2 are explicitly
- !!! unfolded to allow vectorization in those cases. For
- !!! lda.GT.2 this routine will not vectorize.
- !!!
- !!! Both nvlist and vlist can be created using
- !!! ppm_neighlist_vlist. This should be done by the
- !!! user program since there could be several sets of
- !!! Verlet lists. This routine can then be called with
- !!! the appropriate one. Do not forget to DEALLOCATE
- !!! nvlist and vlist when they are not needed any more.
- !!!
- !!! dpd needs to be allocated to proper size before
- !!! calling this routine. Also, this routine is not
- !!! resetting dpd to zero before doing the PP
- !!! interactions. This allows contributions from
- !!! different kernels to be accumulated. If needed,
- !!! set it to zero before calling this routine the
- !!! first time.
- !!! ======================================================================
- !!!
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: xp
- !!! particle coordinates
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:,:), INTENT(IN ) :: pdata
- !!! particle data (strengths).
- !!! Overloaded types: single,double
- REAL(MK) , DIMENSION(:,:), INTENT( OUT) :: dpd
- !!! Change of particle data (strengths).
- !!! Overloaded types: single,double
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:), INTENT(IN ) :: pdata
- !!! particle data (strengths).
- !!! Overloaded types: single complex,double complex
- COMPLEX(MK), DIMENSION(:,:), INTENT( OUT) :: dpd
- !!! Change of particle data (strengths).
- !!! Overloaded types: single complex,double complex.
-#endif
- LOGICAL , INTENT(IN ) :: lsymm
- !!! using symmetry or not?
- INTEGER , INTENT(IN ) :: Np
- !!! number of particles on local proc.
- INTEGER , INTENT(IN ) :: lda
- !!! leading dimension of pdata.
-#if __KERNEL == __INTERNAL
- INTEGER , INTENT(IN ) :: kernel
- !!! kernel for which to compute the correction. To use ppm-internal
- !!! kernels, specify one of:
- !!!
- !!! ---------------------------------------
- !!! ppm_param_kerel_laplace2d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 2D)
- !!! ppm_param_kerel_laplace3d_2p
- !!! (2nd order Laplacian,
- !!! polynomial in 3D)
- !!! ---------------------------------------
- !!!
- !!! To use your own kernel function, pass the function pointer here. Your
- !!! function should take one argument and return one value.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single or complex.
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Type can be single complex or double complex.
-#endif
-#elif __KERNEL == __LOOKUP_TABLE
- REAL(MK) , INTENT(IN ) :: kpar
- !!! Kernel parameters. See documentation or ppm_comp_pp_kernels.inc for
- !!! description. Pass dxtableinv (the inverse of the table spacing) as
- !!! a scalar here.
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(: ), INTENT(IN ) :: kernel
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(: ), INTENT(IN ) :: kernel
-#endif
- !!! Lookup table with tabulated kernel values.
- !!! Such a table can be created using <<ppm_comp_pp_mk_table>>.
-#endif
- INTEGER , DIMENSION(:,:), INTENT(IN ) :: vlist
- !!! Verlet lists of all particles. 1st index: particles to interact with
- !!! (1..nvlist), 2nd: particle (1..Np).
- INTEGER , DIMENSION( :), INTENT(IN ) :: nvlist
- !!! length of the Verlet lists of all particles
- INTEGER , INTENT( OUT) :: info
- !!! Returns status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: jpart,ip,jp,ispec,idx
- REAL(MK) :: dx,dy,dz
- REAL(MK) :: factor,factor2
- REAL(MK) :: dij,dij2,dij4,dij5
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) :: summ,summ2
- REAL(MK) :: eta,dm
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK) :: summ,summ2
- COMPLEX(MK) :: eta,dm
-#endif
- ! timer
- REAL(MK) :: t0
- CHARACTER(LEN=ppm_char) :: mesg
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-#if __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK) , DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- REAL(MK), DIMENSION(:), INTENT(IN) :: kpar
- REAL(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:) , INTENT(IN ) :: kpar
- INTERFACE
- FUNCTION kernel(x,kpar)
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0E0)
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = KIND(1.0D0)
-#endif
- REAL(MK), INTENT(IN) :: x
- COMPLEX(MK), DIMENSION(:), INTENT(IN) :: kpar
- COMPLEX(MK) :: kernel
- END FUNCTION kernel
- END INTERFACE
-#endif
-#endif
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_comp_pp_verlet',t0,info)
-
- !-------------------------------------------------------------------------
- ! Check arguments.
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_comp_pp_verlet', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (Np .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_verlet', &
- & 'Np must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda .LT. 1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_verlet', &
- & 'lda must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __KERNEL == __LOOKUP_TABLE
- IF (kpar .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_comp_pp_verlet', &
- & 'kpar (dxtableinv) must be >=0',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF
-
- !-------------------------------------------------------------------------
- ! PARTICLE-PARTICLE INTERACTIONS using symmetry
- !-------------------------------------------------------------------------
- IF (lsymm) THEN
- IF (lda .EQ. 1) THEN
- DO ip=1,Np
- summ = 0.0_MK
-#ifdef __SXF90
-!CDIR NODEP
-#endif
- DO jpart=1,nvlist(ip)
- jp = vlist(jpart,ip)
- !---------------------------------------------------------
- ! Calculate the square of the distance between the two
- ! particles. It will always be .LE. (cutoff+skin)**2 by
- ! construction of the Verlet list.
- !---------------------------------------------------------
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !---------------------------------------------------------
- ! Particle ip interacts with jp and vice versa
- !---------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - pdata(1,ip))
- summ = summ + dm
- dpd(1,jp) = dpd(1,jp) - dm
- ENDDO
- dpd(1,ip) = dpd(1,ip) + summ
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- DO ip=1,Np
- summ = 0.0_MK
- summ2 = 0.0_MK
-#ifdef __SXF90
-!CDIR NODEP
-#endif
- DO jpart=1,nvlist(ip)
- jp = vlist(jpart,ip)
- !---------------------------------------------------------
- ! Calculate the square of the distance between the two
- ! particles. It will always be .LE. (cutoff+skin)**2 by
- ! construction of the Verlet list.
- !---------------------------------------------------------
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !---------------------------------------------------------
- ! Particle ip interacts with jp and vice versa
- !---------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - pdata(1,ip))
- summ = summ + dm
- dpd(1,jp) = dpd(1,jp) - dm
- dm = eta*(pdata(2,jp) - pdata(2,ip))
- summ2 = summ2 + dm
- dpd(2,jp) = dpd(2,jp) - dm
- ENDDO
- dpd(1,ip) = dpd(1,ip) + summ
- dpd(2,ip) = dpd(2,ip) + summ2
- ENDDO
- ELSE
- DO ip=1,Np
- DO jpart=1,nvlist(ip)
- jp = vlist(jpart,ip)
- !---------------------------------------------------------
- ! Calculate the square of the distance between the two
- ! particles. It will always be .LE. (cutoff+skin)**2 by
- ! construction of the Verlet list.
- !---------------------------------------------------------
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !---------------------------------------------------------
- ! Particle ip interacts with jp and vice versa
- !---------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata(ispec,jp) - pdata(ispec,ip))
- dpd(ispec,ip) = dpd(ispec,ip) + dm
- dpd(ispec,jp) = dpd(ispec,jp) - dm
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- !-------------------------------------------------------------------------
- ! PARTICLE-PARTICLE INTERACTIONS not using symmetry
- !-------------------------------------------------------------------------
- ELSE
- IF (lda .EQ. 1) THEN
- DO ip=1,Np
-#ifdef __SXF90
-!CDIR NODEP
-#endif
- DO jpart=1,nvlist(ip)
- jp = vlist(jpart,ip)
- !---------------------------------------------------------
- ! Calculate the square of the distance between the two
- ! particles. It will always be .LE. (cutoff+skin)**2 by
- ! construction of the Verlet list.
- !---------------------------------------------------------
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !---------------------------------------------------------
- ! Particle ip interacts with jp
- !---------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - pdata(1,ip))
- dpd(1,ip) = dpd(1,ip) + dm
- ENDDO
- ENDDO
- ELSEIF (lda .EQ. 2) THEN
- DO ip=1,Np
-#ifdef __SXF90
-!CDIR NODEP
-#endif
- DO jpart=1,nvlist(ip)
- jp = vlist(jpart,ip)
- !---------------------------------------------------------
- ! Calculate the square of the distance between the two
- ! particles. It will always be .LE. (cutoff+skin)**2 by
- ! construction of the Verlet list.
- !---------------------------------------------------------
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !---------------------------------------------------------
- ! Particle ip interacts with jp
- !---------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- dm = eta*(pdata(1,jp) - pdata(1,ip))
- dpd(1,ip) = dpd(1,ip) + dm
- dm = eta*(pdata(2,jp) - pdata(2,ip))
- dpd(2,ip) = dpd(2,ip) + dm
- ENDDO
- ENDDO
- ELSE
- DO ip=1,Np
- DO jpart=1,nvlist(ip)
- jp = vlist(jpart,ip)
- !---------------------------------------------------------
- ! Calculate the square of the distance between the two
- ! particles. It will always be .LE. (cutoff+skin)**2 by
- ! construction of the Verlet list.
- !---------------------------------------------------------
- dx = xp(1,ip) - xp(1,jp)
- dy = xp(2,ip) - xp(2,jp)
- IF (ppm_dim .GT. 2) THEN
- dz = xp(3,ip) - xp(3,jp)
- dij = (dx*dx) + (dy*dy) + (dz*dz)
- ELSE
- dz = 0.0_MK
- dij = (dx*dx) + (dy*dy)
- ENDIF
- !---------------------------------------------------------
- ! Particle ip interacts with jp
- !---------------------------------------------------------
-#include "ppm_comp_pp_kernels.inc"
- DO ispec=1,lda
- dm = eta*(pdata(ispec,jp) - pdata(ispec,ip))
- dpd(ispec,ip) = dpd(ispec,ip) + dm
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_comp_pp_verlet',t0,info)
- RETURN
-#if __KERNEL == __INTERNAL
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_verlet_si
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_verlet_di
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_verlet_sci
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_verlet_dci
-#endif
-
-#elif __KERNEL == __USER_FUNCTION
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_verlet_su
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_verlet_du
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_verlet_scu
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_verlet_dcu
-#endif
-
-#elif __KERNEL == __LOOKUP_TABLE
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_comp_pp_verlet_st
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_comp_pp_verlet_dt
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_verlet_sct
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_comp_pp_verlet_dct
-#endif
-#endif
diff --git a/src/ppm_fdsolver_fft_bd_2d.f b/src/ppm_fdsolver_fft_bd_2d.f
deleted file mode 100644
index 0ed4b168e005a99300cff376e7323366c38ca131..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_fft_bd_2d.f
+++ /dev/null
@@ -1,301 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_fft_bd_2d
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine performs Fast Fourier Transform backward
- ! using the precomputed plans in ppm_fdsolver_init
- !
- ! Input : data_in(:,:) (F) 2d data array to be transformed
- !
- ! Input/output : lda(:) (I) size of data array
- !
- ! Output : data_out(:,:) (F) transformed data
- ! info (I) return status. =0 if no error.
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_fft_bd_2d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.4 2006/09/04 18:34:42 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.3 2005/02/18 08:01:28 hiebers
- ! minor changes in error messages
- !
- ! Revision 1.2 2005/02/16 22:22:58 ivos
- ! Bugfix: replaced non-existing ppm_module_data_fdsolver with
- ! ppm_module_data_fieldsolver.
- !
- ! Revision 1.1 2005/02/16 11:54:02 hiebers
- ! initial implementation
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_bd_2ds(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_bd_2dd(data_in,lda,data_out,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_fdsolver_fft_bd_2dc(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_fdsolver_fft_bd_2dcc(data_in,lda,data_out,info)
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fieldsolver
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND ==__SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND ==__DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! FFTW include
- !-------------------------------------------------------------------------
-#ifdef __FFTW
- INCLUDE "fftw3.f"
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! input data
- COMPLEX(MK), DIMENSION(:,:) , INTENT(IN ) :: data_in
- ! size of array
- INTEGER, DIMENSION(:) , INTENT(INOUT) :: lda
- ! output data, inverse fast fourier transformed
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK), DIMENSION(:,:) , POINTER :: data_out
-#elif __KIND == __SINGLE_PRECISION_COMPLEX| __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:) , POINTER :: data_out
-#endif
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! counters
- INTEGER :: i,j,iopt
- ! size of the data_in
- INTEGER :: Nx_in, Ny_in
- ! size of the data_out
- INTEGER :: Nx_out, Ny_out
-#ifdef __FFTW
- ! FFTW Plan
- INTEGER*8 :: Plan
-#endif
-#ifdef __MATHKEISAN
- ! MATHKEISAN variables for MathKeisan FFTs
- INTEGER :: isign_fft,isys
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
-
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- ! parameters for cfft (default=1)
- INTEGER :: incx, incy
-#endif
- ! scale_fft of the transformation
- REAL(MK) :: scale_fft
- ! working storage
- REAL(MK), DIMENSION(:),POINTER :: table, work
- ! the size of the working storage
- INTEGER, DIMENSION(1) :: lda_table, lda_work
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_fft_bd_2d',t0,info)
-#if !(defined(__FFTW) | defined(__MATHKEISAN))
- !-------------------------------------------------------------------------
- ! Error if library support is not available
- !-------------------------------------------------------------------------
- info = ppm_error_error
-#ifndef __FFTW
- CALL ppm_error(ppm_err_nofftw,'ppm_fdsolver_fft_bd_2d', &
- & 'PPM was compiled without fftw support',__LINE__,info)
-#endif
-
-#ifndef __MATHKEISAN
- CALL ppm_error(ppm_err_noMathKeisan,'ppm_fdsolver_fft_bd_2d', &
- & 'PPM was compiled without MATHKEISAN support',__LINE__,info)
-#endif
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (SIZE(lda,1) .LT. 2) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_bd_2d', &
- & 'lda must be at least of size 2',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(1) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_bd_2d', &
- & 'mesh size: lda(1) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(2) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_bd_2d', &
- & 'mesh size: lda(2) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- Nx_in=lda(1)
- Ny_in=lda(2)
- !-------------------------------------------------------------------------
- ! Allocate result array
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- Nx_out = (Nx_in-1)*2
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- Nx_out = Nx_in -1
-#endif
- Ny_out=Ny_in
- lda(1)=Nx_out+1
- lda(2)=Ny_out
- CALL ppm_alloc(data_out,lda,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_bd_2d', &
- & 'fft result DATA_OUT',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! FFT - Transform in x-direction
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! NEC version - Use MathKeisan Library 1.5
- !-------------------------------------------------------------------------
-#ifdef __MATHKEISAN
- !-------------------------------------------------------------------------
- ! Allocate working storage
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- lda_work(1) = 4*Nx_out
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND== __DOUBLE_PRECISION_COMPLEX
- lda_work(1) = 6*Nx_out
-#endif
- CALL ppm_alloc(work,lda_work,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_bd_2d', &
- & 'work not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Forward FFT
- !-------------------------------------------------------------------------
- scale_fft = 1
- isign_fft = 1
- DO j=1,Ny_in
-#if __KIND == __SINGLE_PRECISION
- CALL csfft(isign_fft, Nx_out, scale_fft, data_in(1,j), &
- & data_out(1,j), table_bd_s, work, isys)
-#elif __KIND == __DOUBLE_PRECISION
- CALL zdfft(isign_fft, Nx_out, scale_fft, data_in(1,j), &
- & data_out(1,j), table_bd_d, work, isys)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- CALL cfft(isign_fft, Nx_out, scale_fft, data_in(1,j), incx, &
- & data_out(1,j), incy, table_fd_c_y, lda_table_y, work, &
- & lda_work(1), isys)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- CALL zfft(isign_fft, Nx_out, scale_fft, data_in(1,j), incx, &
- & data_out(1,j), incy, table_fd_c_y, lda_table_y, work, &
- & lda_work(1), isys)
-#endif
- ENDDO
- !-------------------------------------------------------------------------
- ! Deallocate Memory
- !-------------------------------------------------------------------------
- CALL ppm_alloc(work,lda_work,ppm_param_dealloc,info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_bd_2d',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#else
- !-------------------------------------------------------------------------
- ! FFTW version for LINUX,...
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_execute_dft_c2r(Plan_bd_s, data_in(1,1), data_out(1,1) )
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_execute_dft_c2r(Plan_bd_d, data_in(1,1), data_out(1,1) )
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- CALL sfftw_execute_dft(Plan_bd_c_y, data_in(1,1), data_out(1,1) )
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- CALL dfftw_execute_dft(Plan_bd_cc_y, data_in(1,1), data_out(1,1) )
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Copy margin to conform with PPM convention
- !-------------------------------------------------------------------------
- DO j=1,Ny_out
- data_out(lda(1),j) = data_out(1,j)
- ENDDO
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_fft_bd_2d',t0,info)
- RETURN
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_bd_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_bd_2dd
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_fdsolver_fft_bd_2dc
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_fdsolver_fft_bd_2dcc
-#endif
diff --git a/src/ppm_fdsolver_fft_bd_3d.f b/src/ppm_fdsolver_fft_bd_3d.f
deleted file mode 100644
index 7c6c6b73b2ba96007b8e51d4641734697da60965..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_fft_bd_3d.f
+++ /dev/null
@@ -1,391 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_fft_bd_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine performs Fast Fourier Transform backward
- ! using the precomputed plans in ppm_fdsolver_init
- !
- ! Input : data_in(:,:,:) (F) 3d data array to be transformed
- !
- ! Input/output : lda(:) (I) size of data
- !
- !
- ! Output : data_out(:,:,:) (F) transformed data
- ! info (I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_fft_bd_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.4 2006/09/04 18:34:42 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.3 2005/02/18 08:01:29 hiebers
- ! minor changes in error messages
- !
- ! Revision 1.2 2005/02/16 22:22:58 ivos
- ! Bugfix: replaced non-existing ppm_module_data_fdsolver with
- ! ppm_module_data_fieldsolver.
- !
- ! Revision 1.1 2005/02/16 11:54:02 hiebers
- ! initial implementation
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __CASE == __SLAB
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_bd_slab_3ds(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_bd_slab_3dd(data_in,lda,data_out,info)
-#endif
-#else
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_bd_3ds(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_bd_3dd(data_in,lda,data_out,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_fdsolver_fft_bd_3dc(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_fdsolver_fft_bd_3dcc(data_in,lda,data_out,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z
- SUBROUTINE ppm_fdsolver_fft_bd_z_3dc(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- SUBROUTINE ppm_fdsolver_fft_bd_z_3dcc(data_in,lda,data_out,info)
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fieldsolver
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND ==__SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND ==__SINGLE_PRECISION_COMPLEX_Z
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND ==__DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#elif __KIND ==__DOUBLE_PRECISION_COMPLEX_Z
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! FFTW include
- !-------------------------------------------------------------------------
-#ifdef __FFTW
- INCLUDE "fftw3.f"
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! input data
- COMPLEX(MK), DIMENSION(:,:,:) , INTENT(IN ) :: data_in
- ! size of data
- INTEGER, DIMENSION(:) , INTENT(INOUT) :: lda
- ! output data, inverse fast fourier transformed
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK), DIMENSION(:,:,:) , POINTER :: data_out
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:,:) , POINTER :: data_out
-#elif __KIND==__SINGLE_PRECISION_COMPLEX_Z|__KIND ==__DOUBLE_PRECISION_COMPLEX_Z
- COMPLEX(MK), DIMENSION(:,:,:) , POINTER :: data_out
-#endif
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! counters
- INTEGER :: i,j,k,iopt
- ! size of the data_in
- INTEGER :: Nx_in, Ny_in, Nz_in
- ! size of the data_out
- INTEGER :: Nx_out, Ny_out, Nz_out
-#ifdef __FFTW
- ! FFTW Plan
- INTEGER*8 :: Plan
- INTEGER :: mbistride, mbrank, mbidist, mbiembed
- INTEGER :: mboembed, mbhowmany, mbodist
-#endif
-#ifdef __MATHKEISAN
- ! MATHKEISAN variables for MathKeisan FFTs
- INTEGER :: isign_fft,isys
-#if __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER :: incx, incy
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z | __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- INTEGER :: incx, incy
-#endif
- ! scale of the transformation
- REAL(MK) :: scale_fft
- ! working storage
- REAL(MK), DIMENSION(:),POINTER :: table, work
- ! the size of the working storage
- INTEGER, DIMENSION(1) :: lda_table,lda_work
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_fft_bd_3d',t0,info)
-#if !(defined(__FFTW) | defined(__MATHKEISAN))
- !-------------------------------------------------------------------------
- ! Error if FFTW library or NEC is not available
- !-------------------------------------------------------------------------
- info = ppm_error_error
-#ifndef __FFTW
- CALL ppm_error(ppm_err_nofftw,'ppm_fdsolver_fft_bd_3d', &
- & 'PPM was compiled without fftw support',__LINE__,info)
-#endif
-#ifndef __MATHKEISAN
- CALL ppm_error(ppm_err_noMathKeisan,'ppm_fdsolver_fft_bd_3d', &
- & 'PPM was compiled without MATHKEISAN support',__LINE__,info)
-#endif
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (SIZE(lda,1) .LT. 3) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_bd_3d', &
- & 'lda must be at least of size 3',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(1) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_bd_3d', &
- & 'mesh size: lda(1) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(2) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_bd_3d', &
- & 'mesh size: lda(2) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(3) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_bd_3d', &
- & 'mesh size: lda(3) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
-
- Nx_in = lda(1)
- Ny_in = lda(2)
- Nz_in = lda(3)
-
- !-------------------------------------------------------------------------
- ! Allocate result array
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- Nx_out = (Nx_in-1)*2
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- Nx_out = Nx_in-1
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z | __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- Nx_out = Nx_in-1
-#endif
- Ny_out=Ny_in
- Nz_out=Nz_in
- lda(1)=Nx_out +1 ! to fit ppm-convention
- lda(2)=Ny_out
- lda(3)=Nz_out
- CALL ppm_alloc(data_out,lda,ppm_param_alloc_fit,info )
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_bd_3d', &
- & 'fft result DATA_OUT',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! FFT - Transform in x-direction
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! NEC version - Use MathKeisan Library
- !-------------------------------------------------------------------------
-#ifdef __MATHKEISAN
-#if __CASE == __SLAB
- !-------------------------------------------------------------------------
- ! not implemented yet
- !-------------------------------------------------------------------------
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_fd_2d', &
- & 'version not implemented',__LINE__,info)
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Allocate working storage
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- lda_work = 4*Nx_out
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND== __DOUBLE_PRECISION_COMPLEX
- lda_work(1) = 6*Nx_out
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z | __KIND== __DOUBLE_PRECISION_COMPLEX_Z
- lda_work(1) = 6*Nx_out
-#endif
- CALL ppm_alloc(work,lda_work,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_util_fft_forward_2d', &
- & 'work not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Forward FFT
- !-------------------------------------------------------------------------
- scale_fft = 1
- isign_fft = 1
-
- DO k=1,Nz_in
- DO j=1,Ny_in
-#if __KIND == __SINGLE_PRECISION
- CALL csfft(isign_fft, Nx_out, scale_fft, data_in(1,j,k), &
- & data_out(1,j,k), table_bd_s, work, isys)
-#elif __KIND == __DOUBLE_PRECISION
- CALL zdfft(isign_fft, Nx_out, scale_fft, data_in(1,j,k), &
- & data_out(1,j,k), table_bd_d, work, isys)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- CALL cfft(isign_fft, Nx_out, scale_fft, data_in(1,j,k), incx, &
- & data_out(1,j,k), incy, table_fd_c_y, lda_table_y, &
- & work, lda_work(1),isys)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- CALL zfft(isign_fft, Nx_out, scale_fft, data_in(1,j,k), incx, &
- & data_out(1,j,k), incy, table_fd_cc_y, lda_table_y, &
- & work, lda_work(1),isys)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z
- CALL cfft(isign_fft, Nx_out, scale_fft, data_in(1,j,k), incx, &
- & data_out(1,j,k), incy, table_fd_c_z, lda_table_z, &
- & work, lda_work(1),isys)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- CALL zfft(isign_fft, Nx_out, scale_fft, data_in(1,j,k), incx, &
- & data_out(1,j,k), incy, table_fd_cc_z, lda_table_z, &
- & work, lda_work(1),isys)
-#endif
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Deallocate Memory
- !-------------------------------------------------------------------------
- CALL ppm_alloc(work,lda_work,ppm_param_dealloc,info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_fft_bd_3d',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#endif
-#else
- !-------------------------------------------------------------------------
- ! FFTW version for LINUX,...
- !-------------------------------------------------------------------------
-#if __CASE == __SLAB
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_execute_dft_c2r(Plan_slab_bd_s,data_in(1,1,1),data_out(1,1,1) )
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_execute_dft_c2r(Plan_slab_bd_d,data_in(1,1,1),data_out(1,1,1) )
-#endif
-#else
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_execute_dft_c2r(Plan_bd_s, data_in(1,1,1), data_out(1,1,1) )
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_execute_dft_c2r(Plan_bd_d, data_in(1,1,1), data_out(1,1,1) )
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- CALL sfftw_execute_dft(Plan_bd_c_y, data_in(1,1,1), data_out(1,1,1) )
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- CALL dfftw_execute_dft(Plan_bd_cc_y, data_in(1,1,1), data_out(1,1,1) )
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z
- CALL sfftw_execute_dft(Plan_bd_c_z, data_in(1,1,1), data_out(1,1,1) )
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- CALL dfftw_execute_dft(Plan_bd_cc_z, data_in(1,1,1), data_out(1,1,1) )
-#endif
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Copy margin to conform with PPM convention
- !-------------------------------------------------------------------------
- DO j=1,Ny_out
- DO k=1,Nz_out
- data_out(lda(1),j,k) = data_out(1,j,k)
- ENDDO
- ENDDO
-#if __CASE == __SLAB
- DO i=1,lda(1)
- DO k=1,lda(3)
- data_out(i,lda(2),k) = data_out(i,1,k)
- ENDDO
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_fft_bd_3d',t0,info)
- RETURN
-
-#if __CASE == __SLAB
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_bd_slab_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_bd_slab_3dd
-#endif
-#else
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_bd_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_bd_3dd
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_fdsolver_fft_bd_3dc
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_fdsolver_fft_bd_3dcc
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z
- END SUBROUTINE ppm_fdsolver_fft_bd_z_3dc
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- END SUBROUTINE ppm_fdsolver_fft_bd_z_3dcc
-#endif
-#endif
diff --git a/src/ppm_fdsolver_fft_fd_2d.f b/src/ppm_fdsolver_fft_fd_2d.f
deleted file mode 100644
index 5632e29dc4458db035c397b1ba24df4e6918580c..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_fft_fd_2d.f
+++ /dev/null
@@ -1,309 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_fft_fd_2d
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine performs Fast Fourier Transform forth
- ! using the precomputed plans in ppm_fdsolver_init
- !
- ! Input : data_in(:,:) (F) 2d data array to be transformed
- !
- ! Input/output : lda(:) (I) size of data
- !
- !
- ! Output : data_out(:,:) (F) transformed data
- ! info (I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_fft_fd_2d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2006/09/04 18:34:43 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.2 2005/02/16 22:22:59 ivos
- ! Bugfix: replaced non-existing ppm_module_data_fdsolver with
- ! ppm_module_data_fieldsolver.
- !
- ! Revision 1.1 2005/02/16 11:52:46 hiebers
- ! initial implementation
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_fd_2ds(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_fd_2dd(data_in,lda,data_out,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_fdsolver_fft_fd_2dc(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_fdsolver_fft_fd_2dcc(data_in,lda,data_out,info)
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fieldsolver
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND ==__SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND ==__DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! FFTW include
- !-------------------------------------------------------------------------
-#ifdef __FFTW
- INCLUDE "fftw3.f"
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! input data
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK), DIMENSION(:,:) , INTENT(IN ) :: data_in
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:) , INTENT(IN ) :: data_in
-#endif
- ! size of the array
- INTEGER, DIMENSION(:) , INTENT(INOUT) :: lda
- ! output data, fast fourier transformed
- COMPLEX(MK), DIMENSION(:,:) , POINTER :: data_out
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! counters
- INTEGER :: i,j,iopt
- ! size of the data_in
- INTEGER :: Nx_in, Ny_in
- ! size of the data_out
- INTEGER :: Nx_out, Ny_out
-#ifdef __FFTW
- ! FFTW Plan
- INTEGER*8 :: Plan
-#endif
-#ifdef __MATHKEISAN
- ! MATHKEISAN variables for MathKeisan FFTs
- INTEGER :: isign_fft, isys
-#if __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER :: incx, incy
-#endif
- ! scale of the transformation
- REAL(MK) :: scale_fft
- ! working storage
- REAL(MK), DIMENSION(:),POINTER :: table, work
- ! the size of the working storage
- INTEGER, DIMENSION(1) :: lda_table, lda_work
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_fft_fd_2d',t0,info)
-#if !(defined(__FFTW) | defined(__MATHKEISAN))
- !-------------------------------------------------------------------------
- ! Error if FFTW library or NEC is not available
- !-------------------------------------------------------------------------
- info = ppm_error_error
-#ifndef __FFTW
- CALL ppm_error(ppm_err_nofftw,'ppm_fdsolver_fft_fd_2d', &
- & 'PPM was compiled without fftw support',__LINE__,info)
-#endif
-#ifndef __MATHKEISAN
- CALL ppm_error(ppm_err_noMathKeisan,'ppm_fdsolver_fft_fd_2d', &
- & 'PPM was compiled without MATHKEISAN support',__LINE__,info)
-#endif
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (SIZE(lda,1) .LT. 2) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_fd_2d', &
- & 'lda must be at least of size 2',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(1) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_fd_2d', &
- & 'mesh size: lda(1) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(2) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_fd_2d', &
- & 'mesh size: lda(2) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !Nx_in = lda(1)
- !subtract 1 to fit ppm-convention
- Nx_in=lda(1)-1
- Ny_in = lda(2)
- !-------------------------------------------------------------------------
- ! Allocate result array
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- Nx_out = Nx_in/2 + 1
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- Nx_out = Nx_in
-#endif
- Ny_out=Ny_in
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- lda(1) = Nx_out
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- lda(1) = Nx_out+1 ! to fit ppm-convention
-#endif
- lda(2)=Ny_out
- CALL ppm_alloc(data_out,lda,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_fd_2d', &
- & 'fft result DATA_OUT',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! FFT - Transform in x-direction
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! NEC version - Use MathKeisan Library
- !-------------------------------------------------------------------------
-#ifdef __MATHKEISAN
- !-------------------------------------------------------------------------
- !NOTE: This fft routines does not currently work for arbitrary n.
- ! Number of data points, of the form n = 2**p * 3**q *
- ! 5**r, with p, q, r >= 0
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! Allocate working storage
- !-------------------------------------------------------------------------
- lda_work(1) = 4*Nx_in
- CALL ppm_alloc(work,lda_work,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_fd_2d', &
- & 'work not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Forward FFT
- !-------------------------------------------------------------------------
- scale_fft = 1
- isign_fft = 0
- isign_fft = -1
-
- DO j=1,Ny_in
-#if __KIND == __SINGLE_PRECISION
- CALL scfft(isign_fft, Nx_in, scale_fft, data_in(1,j), &
- & data_out(1,j), table_fd_s, work, isys)
-#elif __KIND == __DOUBLE_PRECISION
- CALL dzfft(isign_fft, Nx_in, scale_fft, data_in(1,j), &
- & data_out(1,j), table_fd_d, work, isys)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- CALL cfft(isign_fft, Nx_in, scale_fft, data_in(1,j), incx, &
- & data_out(1,j), incy, table_fd_c_y, lda_table_y, work, &
- & lda_work(1), isys)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- CALL zfft(isign_fft, Nx_in, scale_fft, data_in(1,j), incx, &
- & data_out(1,j), incy, table_fd_cc_y, lda_table_y, work, &
- & lda_work(1), isys)
-#endif
- ENDDO
- !-------------------------------------------------------------------------
- ! Deallocate working storage
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(work,lda,iopt,info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not dealloc memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_fft_2d',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#else
- !-------------------------------------------------------------------------
- ! FFTW version for LINUX,...
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_execute_dft_r2c(Plan_fd_s,data_in(1,1),data_out(1,1) )
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_execute_dft_r2c(Plan_fd_d,data_in(1,1),data_out(1,1) )
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- CALL sfftw_execute_dft(Plan_fd_c_y,data_in(1,1),data_out(1,1) )
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- CALL dfftw_execute_dft(Plan_fd_cc_y,data_in(1,1),data_out(1,1) )
-#endif
-#endif
-#endif
-#if __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- !-------------------------------------------------------------------------
- ! Copy margin to conform with PPM convention
- !-------------------------------------------------------------------------
- DO j=1,Ny_out
- data_out(lda(1),j) = data_out(1,j)
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_fft_fd_2d',t0,info)
- RETURN
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_fd_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_fd_2dd
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_fdsolver_fft_fd_2dc
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_fdsolver_fft_fd_2dcc
-#endif
diff --git a/src/ppm_fdsolver_fft_fd_3d.f b/src/ppm_fdsolver_fft_fd_3d.f
deleted file mode 100644
index 2cbd4926c0a2a9afbaaf784ad527b9598d726cf2..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_fft_fd_3d.f
+++ /dev/null
@@ -1,410 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_fft_fd_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine performs Fast Fourier Transform forth
- ! using the precomputed plans in ppm_fdsolver_init
- !
- ! Input : data_in(:,:,:) (F) 3d data array to be transformed
- !
- ! Input/output : lda(:) (I) size of data
- !
- ! Output : data_out(:,:,:) (F) transformed data
- ! info (I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_fft_fd_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.5 2006/09/04 18:34:43 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.4 2005/02/17 17:50:26 hiebers
- ! removed typo in ppm_module_data_fieldsolver
- !
- ! Revision 1.3 2005/02/16 22:22:59 ivos
- ! Bugfix: replaced non-existing ppm_module_data_fdsolver with
- ! ppm_module_data_fieldsolver.
- !
- ! Revision 1.2 2005/02/16 12:41:44 hiebers
- ! removed print statements
- !
- ! Revision 1.1 2005/02/16 11:53:24 hiebers
- ! initial implementation
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __CASE == __SLAB
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_fd_slab_3ds(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_fd_slab_3dd(data_in,lda,data_out,info)
-#endif
-#else
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_fd_3ds(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_fft_fd_3dd(data_in,lda,data_out,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- SUBROUTINE ppm_fdsolver_fft_fd_3dc(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- SUBROUTINE ppm_fdsolver_fft_fd_3dcc(data_in,lda,data_out,info)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z
- SUBROUTINE ppm_fdsolver_fft_fd_z_3dc(data_in,lda,data_out,info)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- SUBROUTINE ppm_fdsolver_fft_fd_z_3dcc(data_in,lda,data_out,info)
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fieldsolver
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND ==__SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND ==__SINGLE_PRECISION_COMPLEX_Z
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND ==__DOUBLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#elif __KIND ==__DOUBLE_PRECISION_COMPLEX_Z
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! FFTW include
- !-------------------------------------------------------------------------
-#ifdef __FFTW
- INCLUDE "fftw3.f"
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! input data
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK), DIMENSION(:,:,:) , INTENT(IN ) :: data_in
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- COMPLEX(MK), DIMENSION(:,:,:) , INTENT(IN ) :: data_in
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z|__KIND == __DOUBLE_PRECISION_COMPLEX_Z
- COMPLEX(MK), DIMENSION(:,:,:) , INTENT(IN ) :: data_in
-#endif
- ! size of array
- INTEGER, DIMENSION(3) , INTENT(INOUT) :: lda
- ! output data, fast fourier transformed
- COMPLEX(MK), DIMENSION(:,:,:) , POINTER :: data_out
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! counters
- INTEGER :: i,j,k,iopt
- ! size of the data_in
- INTEGER :: Nx_in, Ny_in, Nz_in
- ! size of the data_out
- INTEGER :: Nx_out, Ny_out, Nz_out
-#ifdef __FFTW
- ! FFTW Plan
- INTEGER*8 :: Plan
- INTEGER :: mbistride, mbrank, mbidist, mbiembed
- INTEGER :: mboembed, mbhowmany, mbodist
-#endif
-#ifdef __MATHKEISAN
- ! MATHKEISAN variables for MathKeisan FFTs
- INTEGER :: isign_fft,isys
-#if __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- INTEGER :: incx, incy
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z | __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- INTEGER :: incx, incy
-#endif
- !scale of the transformation
- REAL(MK) :: scale_fft
- ! working storage
- REAL(MK), DIMENSION(:),POINTER :: table, work
- ! the size of the working storage
- INTEGER, DIMENSION(1) :: lda_table, lda_work
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_fft_fd_3d',t0,info)
-#if !(defined(__FFTW) | defined(__MATHKEISAN))
- !-------------------------------------------------------------------------
- ! Error if FFT library support is not available
- !-------------------------------------------------------------------------
- info = ppm_error_error
-#ifndef __FFTW
- CALL ppm_error(ppm_err_nofftw,'ppm_fdsolver_fft_fd_3d', &
- & 'PPM was compiled without fftw support',__LINE__,info)
-#endif
-#ifndef __MATHKEISAN
- CALL ppm_error(ppm_err_noMathKeisan,'ppm_fdsolver_fft_fd_3d', &
- & 'PPM was compiled without MATHKEISAN support',__LINE__,info)
-#endif
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (SIZE(lda,1) .LT. 3) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_fd_3d', &
- & 'lda must be at least of size 3',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(1) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_fd_3d', &
- & 'mesh size: lda(1) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(2) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_fd_3d', &
- & 'mesh size: lda(2) must be >0',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(3) .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_fft_fd_3d', &
- & 'mesh size: lda(3) must be >0' ,__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
-
- ! Nx_in=lda(1)
- ! subtract 1 to fit ppm-convention
- Nx_in=lda(1)-1
- Ny_in=lda(2)
- Nz_in=lda(3)
- !-------------------------------------------------------------------------
- ! Allocate result array
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- Nx_out = Nx_in/2 + 1
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- Nx_out = Nx_in
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z | __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- Nx_out = Nx_in
-#endif
- Ny_out = Ny_in
- Nz_out = Nz_in
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- lda(1) = Nx_out
-#elif __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- lda(1) = Nx_out+1 ! to fit ppm-convention
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z| __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- lda(1) = Nx_out+1 ! to fit ppm-convention
-#endif
- lda(2) = Ny_out
- lda(3) = Nz_out
- CALL ppm_alloc(data_out,lda,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_fd_3d', &
- & 'fft result DATA_OUT',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! FFT - Transform in x-direction
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! NEC version - Use MathKeisan Library
- !-------------------------------------------------------------------------
-#ifdef __MATHKEISAN
-#if __CASE == __SLAB
- !-------------------------------------------------------------------------
- ! not implemented yet
- !-------------------------------------------------------------------------
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_fd_2d', &
- & 'version not implemented',__LINE__,info)
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Allocate working storage
- !-------------------------------------------------------------------------
- lda_work = 4*Nx_in
- CALL ppm_alloc(work,lda_work,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_fft_fd_2d', &
- & 'work not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Forward FFT
- !-------------------------------------------------------------------------
- scale_fft = 1
- isign_fft = -1
-
- DO k=1,Nz_in
- DO j=1,Ny_in
-#if __KIND == __SINGLE_PRECISION
- CALL scfft(isign_fft, Nx_in, scale_fft, data_in(1,j,k), &
- & data_out(1,j,k), table_fd_s, work, isys)
-#elif __KIND == __DOUBLE_PRECISION
- CALL dzfft(isign_fft, Nx_in, scale_fft, data_in(1,j,k), &
- & data_out(1,j,k), table_fd_d, work, isys)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- CALL cfft(isign_fft, Nx_in, scale_fft, data_in(1,j,k), incx, &
- & data_out(1,j,k), incy, table_fd_c_y, lda_table_y, &
- & work, lda_work(1),isys)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- CALL zfft(isign_fft, Nx_in, scale_fft, data_in(1,j,k), incx, &
- & data_out(1,j,k), incy, table_fd_cc_y, lda_table_y, &
- & work, lda_work(1),isys)
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z
- CALL cfft(isign_fft, Nx_in, scale_fft, data_in(1,j,k), incx, &
- & data_out(1,j,k), incy, table_fd_c_z, lda_table_z, &
- & work, lda_work(1),isys)
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- CALL zfft(isign_fft, Nx_in, scale_fft, data_in(1,j,k), incx, &
- & data_out(1,j,k), incy, table_fd_cc_z, lda_table_z, &
- & work, lda_work(1),isys)
-#endif
-
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Deallocate Memory
- !-------------------------------------------------------------------------
- CALL ppm_alloc(work,lda_work,ppm_param_dealloc,info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_fft_fd_3d',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#endif
-
-#else
- !-------------------------------------------------------------------------
- ! FFTW version for LINUX,...
- !-------------------------------------------------------------------------
-#if __CASE == __SLAB
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_execute_dft_r2c(Plan_slab_fd_s,data_in(1,1,1),data_out(1,1,1) )
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_execute_dft_r2c(Plan_slab_fd_d,data_in(1,1,1),data_out(1,1,1) )
-#endif
-#else
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_execute_dft_r2c(Plan_fd_s,data_in(1,1,1),data_out(1,1,1) )
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_execute_dft_r2c(Plan_fd_d,data_in(1,1,1),data_out(1,1,1) )
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- CALL sfftw_execute_dft(Plan_fd_c_y,data_in(1,1,1),data_out(1,1,1) )
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- CALL dfftw_execute_dft(Plan_fd_cc_y,data_in(1,1,1),data_out(1,1,1) )
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z
- CALL sfftw_execute_dft(Plan_fd_c_z,data_in(1,1,1),data_out(1,1,1) )
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- CALL dfftw_execute_dft(Plan_fd_cc_z,data_in(1,1,1),data_out(1,1,1) )
-#endif
-#endif
-#endif
-#endif
-#if __KIND == __SINGLE_PRECISION_COMPLEX | __KIND == __DOUBLE_PRECISION_COMPLEX
- !-------------------------------------------------------------------------
- ! Copy margin to conform with PPM convention
- !-------------------------------------------------------------------------
- DO j=1,Ny_out
- DO k=1,Nz_out
- data_out(lda(1),j,k) = data_out(1,j,k)
- ENDDO
- ENDDO
-#endif
-
-#if __KIND == __SINGLE_PRECISION_COMPLEX_Z | __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- !-------------------------------------------------------------------------
- ! Copy margin to conform with PPM convention
- !-------------------------------------------------------------------------
- DO j=1,Ny_out
- DO k=1,Nz_out
- data_out(lda(1),j,k) = data_out(1,j,k)
- ENDDO
- ENDDO
-#endif
-#if __CASE == __SLAB
- DO i=1,Nx_out
- DO k=1,Nz_out
- data_out(i,lda(2),k) = data_out(i,1,k)
- ENDDO
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_fft_fd_3d',t0,info)
- RETURN
-
-#if __CASE == __SLAB
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_fd_slab_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_fd_slab_3dd
-#endif
-#else
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_fd_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_fft_fd_3dd
-#elif __KIND == __SINGLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_fdsolver_fft_fd_3dc
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX
- END SUBROUTINE ppm_fdsolver_fft_fd_3dcc
-#elif __KIND == __SINGLE_PRECISION_COMPLEX_Z
- END SUBROUTINE ppm_fdsolver_fft_fd_z_3dc
-#elif __KIND == __DOUBLE_PRECISION_COMPLEX_Z
- END SUBROUTINE ppm_fdsolver_fft_fd_z_3dcc
-#endif
-#endif
diff --git a/src/ppm_fdsolver_finalize.f b/src/ppm_fdsolver_finalize.f
deleted file mode 100644
index cbcbfbbd83bc0a383297cc63d88693647f051b91..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_finalize.f
+++ /dev/null
@@ -1,158 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_finalize
- !-------------------------------------------------------------------------
- !
- ! Purpose :
- ! finalizes fieldsolver by destroying all FFT-plans
- !
- ! Input :
- !
- ! Input/output :
- ! info (I) 0 on success
- !
- !
- ! Output :
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_finalize.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.5 2006/09/04 18:34:43 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.4 2005/08/15 08:31:59 hiebers
- ! Exchanged declaration REAL(8):: t0 by REAL(ppm_kind_double)
- !
- ! Revision 1.3 2005/02/18 08:02:12 hiebers
- ! minor changes in error messages
- !
- ! Revision 1.2 2005/02/16 22:22:59 ivos
- ! Bugfix: replaced non-existing ppm_module_data_fdsolver with
- ! ppm_module_data_fieldsolver.
- !
- ! Revision 1.1 2005/02/16 10:23:10 hiebers
- ! initial implementation
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
- SUBROUTINE ppm_fdsolver_finalize(info)
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
-
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_write
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_data_fieldsolver
-
-
-
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! FFTW include
- !-------------------------------------------------------------------------
-#ifdef __FFTW
- INCLUDE "fftw3.f"
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local Variables
- !-------------------------------------------------------------------------
- REAL(ppm_kind_double) :: t0
- INTEGER, DIMENSION(3) :: lda
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_finalize',t0,info)
- !-------------------------------------------------------------------------
- ! Deallocate Memory
- !-------------------------------------------------------------------------
-#ifdef __FFTW
- CALL sfftw_destroy_plan(Plan_fd_s)
- CALL sfftw_destroy_plan(Plan_fd_c_y)
- CALL sfftw_destroy_plan(Plan_fd_c_z)
- CALL sfftw_destroy_plan(Plan_bd_s)
- CALL sfftw_destroy_plan(Plan_bd_c_y)
- CALL sfftw_destroy_plan(Plan_bd_c_z)
- CALL sfftw_destroy_plan(Plan_slab_fd_s)
- CALL sfftw_destroy_plan(Plan_slab_bd_s)
- CALL dfftw_destroy_plan(Plan_fd_d)
- CALL dfftw_destroy_plan(Plan_fd_cc_y)
- CALL dfftw_destroy_plan(Plan_fd_cc_z)
- CALL dfftw_destroy_plan(Plan_bd_d)
- CALL dfftw_destroy_plan(Plan_bd_cc_y)
- CALL dfftw_destroy_plan(Plan_bd_cc_z)
- CALL dfftw_destroy_plan(Plan_slab_fd_d)
- CALL dfftw_destroy_plan(Plan_slab_bd_d)
-#endif
-
-#ifdef __MATHKEISAN
- iopt = ppm_param_dealloc
-
- CALL ppm_alloc(table_fd_s,lda,iopt,info)
- CALL ppm_alloc(table_fd_d,lda,iopt,info)
- CALL ppm_alloc(table_fd_c_y,lda,iopt,info)
- CALL ppm_alloc(table_fd_cc_y,lda,iopt,info)
- CALL ppm_alloc(table_fd_c_z,lda,iopt,info)
- CALL ppm_alloc(table_fd_cc_z,lda,iopt,info)
- CALL ppm_alloc(table_bd_s,lda,iopt,info)
- CALL ppm_alloc(table_bd_d,lda,iopt,info)
- CALL ppm_alloc(table_bd_c_y,lda,iopt,info)
- CALL ppm_alloc(table_bd_cc_y,lda,iopt,info)
- CALL ppm_alloc(table_bd_c_z,lda,iopt,info)
- CALL ppm_alloc(table_bd_cc_z,lda,iopt,info)
-
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_finalize',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#endif
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_finalize',t0,info)
- RETURN
-
- END SUBROUTINE ppm_fdsolver_finalize
diff --git a/src/ppm_fdsolver_init.f b/src/ppm_fdsolver_init.f
deleted file mode 100644
index 9f574cf59c4ecfbd39eeb8c6b3fbacf825ae47e2..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_init.f
+++ /dev/null
@@ -1,1052 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_init
- !-------------------------------------------------------------------------
- !
- ! Purpose :
- ! initializes fieldsolver by creating all FFT-plans apriori
- !
- ! Input :
- ! DATA_fv(:,:,:,:) (F) field data
- ! lda_fv (I) size of leading dimension in vector
- ! case
- ! mesh_id_data(I) mesh ID of the current data field mesh
- ! topo_ids(2) (I) topology IDs on which the FFTs are
- ! performed
- ! topo_ids(1) initial topology(xpencils)
- ! topo_ids(2) second topology(ypencils)
- ! topo_ids(3) third topology(zpencils)
- ! (3D only!!)
- !
- ! mesh_ids(3) (I) mesh IDs where the FFTs are performed
- ! mesh_ids(1) first mesh
- ! (xpencils,real
- ! mesh_ids(2) second mesh
- ! (xpencils,complex)
- ! mesh_ids(3) third mesh
- ! (ypencils,complex)
- ! mesh_ids(4) forth mesh
- ! (zpencils,complex) (3D only!!)
- ! ghostsize(3) (I)ghostsize
- !
- ! Input/output :
- !
- !
- !
- ! Output :
- ! info (I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_init.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.13 2006/09/04 18:34:43 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.11 2006/04/10 08:54:29 pchatela
- ! Made xp a REAL, DIMENSION(:,:), POINTER to get rid of warnings
- !
- ! Revision 1.10 2006/04/07 17:41:04 hiebers
- ! Changed type of variable xp to POINTER
- !
- ! Revision 1.9 2005/11/29 10:56:58 hiebers
- ! Changed arguments for fftwRoutines from INTEGER to INTEGER,DIMENSION(1)
- ! for NAG compiler
- !
- ! Revision 1.8 2005/06/04 00:40:23 michaebe
- ! Cosmetics of cosmetics?
- !
- ! Revision 1.7 2005/06/04 00:37:49 michaebe
- ! cosmetics
- !
- ! Revision 1.6 2005/06/04 00:36:12 michaebe
- ! __ppm_module_fdsolver_init.f, line 491.25: 1516-023 (E) Subscript is
- ! out of bounds.
- ! This compiler warning eventually kinda got on my nerves so I acted.
- !
- ! Revision 1.5 2005/02/19 07:32:31 ivos
- ! Resolved CVS conflicts.
- !
- ! Revision 1.4 2005/02/18 08:01:55 hiebers
- ! minor changes in error messages
- !
- ! Revision 1.3 2005/02/16 22:22:59 ivos
- ! Bugfix: replaced non-existing ppm_module_data_fdsolver with
- ! ppm_module_data_fieldsolver.
- !
- ! Revision 1.2 2005/02/16 12:41:13 hiebers
- ! exchange FFTW_ESTIMATE by FFTW_MEASURE
- !
- ! Revision 1.1 2005/02/16 10:22:34 hiebers
- ! initial implementation
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_init_2d_sca_s(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_init_2d_sca_d(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize, info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_init_3d_sca_s(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_init_3d_sca_d(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize, info)
-#endif
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_init_2d_vec_s(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids, mesh_ids,ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_init_2d_vec_d(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids, mesh_ids,ghostsize, info)
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_init_3d_vec_s(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids, mesh_ids,ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_init_3d_vec_d(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids, mesh_ids,ghostsize, info)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
-
- USE ppm_module_mktopo
- USE ppm_module_topo_get
- USE ppm_module_typedef
- USE ppm_module_data_fieldsolver
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_substop
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! FFTW include
- !-------------------------------------------------------------------------
-#ifdef __FFTW
- INCLUDE "fftw3.f"
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! POINTER to data
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
- REAL(MK), DIMENSION(:,:,:), POINTER :: data_fv
-#elif __MESH_DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: data_fv
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __MESH_DIM == __2D
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: data_fv
- INTEGER, INTENT(IN):: lda_fv
-#elif __MESH_DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: data_fv
- INTEGER, INTENT(IN):: lda_fv
-#endif
-#endif
- ! mesh ID of the data
- INTEGER , INTENT(IN) :: mesh_id_data
- ! topo ID of the field
- INTEGER , INTENT(IN ) :: field_topoid
- ! topo / mesh ID for the mapping
-#if __MESH_DIM == __2D
- INTEGER, DIMENSION(2) , INTENT(IN ) :: topo_ids
- INTEGER, DIMENSION(3) , INTENT(IN ) :: mesh_ids
- INTEGER, DIMENSION(2) , INTENT(IN ) :: ghostsize
-#elif __MESH_DIM == __3D
- INTEGER, DIMENSION(3) , INTENT(IN ) :: topo_ids
- INTEGER, DIMENSION(4) , INTENT(IN ) :: mesh_ids
- INTEGER, DIMENSION(3) , INTENT(IN ) :: ghostsize
-#endif
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(ppm_kind_double) :: t0
- ! counters
- INTEGER :: k, i, j
- CHARACTER(LEN=ppm_char) :: mesg
-#if __MESH_DIM == __2D
- REAL(MK), DIMENSION(:,:), POINTER :: data_real
- COMPLEX(MK), DIMENSION(:,:), POINTER :: data_comp, data_compl
- INTEGER, DIMENSION(2) :: lda
-#elif __MESH_DIM == __3D
- REAL(MK), DIMENSION(:,:,:), POINTER :: data_real
- COMPLEX(MK), DIMENSION(:,:,:),POINTER :: data_comp, data_compl
- INTEGER, DIMENSION(3) :: lda
-#endif
- ! size of the data_in
- INTEGER,DIMENSION(1) :: MB_in
- INTEGER :: Nx_in, Ny_in, Nz_in
- ! size of the data_out
- INTEGER :: Nx_out, Ny_out, Nz_out
-#ifdef __FFTW
- INTEGER :: MBistride, MBrank, MBidist
- INTEGER, DIMENSION(1) :: MBiembed, MBoembed
- INTEGER :: MBhowmany, MBodist
- INTEGER, DIMENSION(2) :: iembed_slab, oembed_slab
-#endif
-#ifdef __MATHKEISAN
- ! MATHKEISAN variables for MathKeisan FFTs
- INTEGER :: isign_fft, scale_fft
- INTEGER :: incx, incy
- ! unused variables for initialization
- INTEGER :: isys
- REAL(MK), DIMENSION(:),POINTER :: work
-#endif
- ! variables
- REAL(MK), DIMENSION(:,:),POINTER :: xp
- INTEGER :: Npart
- INTEGER :: decomp, assign
- REAL(MK), DIMENSION(3 ) :: min_phys, max_phys
- REAL(MK), DIMENSION(3 ) :: length
- REAL(MK), DIMENSION(3 ) :: length_phys
- INTEGER , DIMENSION(6 ) :: bcdef
- INTEGER :: nsubs,topo_id, mesh_id
- INTEGER :: yhmax, zhmax
- INTEGER :: mesh_id_xpen, mesh_id_ypen
- INTEGER :: mesh_id_xpen_complex
- INTEGER :: mesh_id_zpen
- INTEGER :: mesh_id_slab
- INTEGER :: mesh_id_slab_complex
- REAL(MK), DIMENSION(: ), POINTER :: cost
- INTEGER , DIMENSION(:,:), POINTER :: istart, istart_xpen_complex
- INTEGER , DIMENSION(:,:), POINTER :: istart_ypen, istart_trans
- INTEGER , DIMENSION(:,:), POINTER :: istart_zpen
- INTEGER , DIMENSION(:,:), POINTER :: ndata, ndata_xpen_complex
- INTEGER , DIMENSION(:,:), POINTER :: ndata_ypen, ndata_trans
- INTEGER , DIMENSION(:,:), POINTER :: ndata_zpen, ndata_slab
- INTEGER , DIMENSION(ppm_dim) :: maxndata_slab
- INTEGER , DIMENSION(ppm_dim) :: maxndata
- INTEGER , DIMENSION(ppm_dim) :: maxndata_ypen
- INTEGER , DIMENSION(ppm_dim) :: maxndata_zpen
- INTEGER , DIMENSION(: ), POINTER :: isublist => NULL()
- INTEGER :: nsublist
- INTEGER :: dim, n,idom
- INTEGER :: iopt
- INTEGER :: topo_id_xpen, topo_id_ypen
- INTEGER :: topo_id_zpen
- INTEGER :: topo_id_slab
- INTEGER, DIMENSION(3) :: Nm, Nm_com, Nm_poisson
- INTEGER, DIMENSION(2) :: Nm_slab
- LOGICAL :: Its_xpencil_topo
- LOGICAL :: Its_xyslab_topo
- TYPE(ppm_t_topo) , POINTER :: f_topo
- TYPE(ppm_t_equi_mesh) , POINTER :: f_mesh
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_init',t0,info)
- f_topo => ppm_topo(field_topoid)%t
- f_mesh => f_topo%mesh(mesh_id_data)
-
-#if !(defined(__FFTW) | defined(__MATHKEISAN))
- !-------------------------------------------------------------------------
- ! Error if FFTW library or NEC is not available
- !-------------------------------------------------------------------------
- info = ppm_error_error
-#ifndef __FFTW
- CALL ppm_error(ppm_err_nofftw,'ppm_fdsolver_init', &
- & 'PPM was compiled without fftw support',__LINE__,info)
-#endif
-#ifndef __MATHKEISAN
- CALL ppm_error(ppm_err_noMathKeisan,'ppm_fdsolver_init', &
- & 'PPM was compiled without MATHKEISAN support',__LINE__,info)
-#endif
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_fdsolver_init', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (field_topoid .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_init', &
- & 'No field topology has been defined so far',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !----------------------------------------------------------------------
- ! Allocate ndata & ndata_slab
- !----------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- lda(1) = ppm_dim
- lda(2) = f_topo%nsubs
- CALL ppm_alloc(ndata,lda,iopt,info)
- CALL ppm_alloc(ndata_slab,lda,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- WRITE (mesg,'(A,I10,A)') 'allocating ', &
- & f_topo%nsublist ,' ndata failed'
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_init', &
- & mesg,__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Initialize variables
- !-------------------------------------------------------------------------
- assign = ppm_param_assign_internal
- Nm(1) = f_mesh%Nm(1)
- Nm(2) = f_mesh%Nm(2)
- Nm(3) = f_mesh%Nm(3)
- Nm_com(1) = Nm(1)/2+1
- Nm_com(2) = Nm(2)
- Nm_com(3) = Nm(3)
- ndata = f_mesh%nnodes
- bcdef(1:6) = ppm_param_bcdef_periodic
- Npart = 0
- ! size of dummy arrays
- lda = 1
-#ifdef __MATHKEISAN
- CALL ppm_alloc(work,1,ppm_param_alloc_fit,info)
-#endif
- CALL ppm_alloc(data_real,lda,ppm_param_alloc_fit,info)
- CALL ppm_alloc(data_comp,lda,ppm_param_alloc_fit,info)
- CALL ppm_alloc(data_compl,lda,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_init', &
- & 'allocation failed for data_real, data_comp',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __KIND == __SINGLE_PRECISION
- min_phys(1) = f_topo%min_physs(1)
- min_phys(2) = f_topo%min_physs(2)
- min_phys(3) = f_topo%min_physs(3)
- max_phys(1) = f_topo%max_physs(1)
- max_phys(2) = f_topo%max_physs(2)
- max_phys(3) = f_topo%max_physs(3)
-#elif __KIND == __DOUBLE_PRECISION
- min_phys(1) = f_topo%min_physd(1)
- min_phys(2) = f_topo%min_physd(2)
- min_phys(3) = f_topo%min_physd(3)
- max_phys(1) = f_topo%max_physd(1)
- max_phys(2) = f_topo%max_physd(2)
- max_phys(3) = f_topo%max_physd(3)
-#endif
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A,3F15.3)' ) 'minimal extent', min_phys(1), min_phys(2), &
- & min_phys(3)
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- WRITE(mesg,'(A,3F15.3)' ) 'maximal extent', max_phys(1), max_phys(2), &
- & max_phys(3)
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- ENDIF
- length_phys(1) = max_phys(1) - min_phys(1)
- length_phys(2) = max_phys(2) - min_phys(2)
- length_phys(3) = max_phys(3) - min_phys(3)
- !-------------------------------------------------------------------------
- ! Check if x_pencil topology
- !-------------------------------------------------------------------------
- Its_xpencil_topo = .TRUE.
- Its_xyslab_topo = .TRUE.
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
-#if __KIND == __SINGLE_PRECISION
- length(1) = f_topo%max_subs(1,idom) - f_topo%min_subs(1,idom)
- length(2) = f_topo%max_subs(2,idom) - f_topo%min_subs(2,idom)
- IF( abs(length(1) - length_phys(1)).GT.(ppm_myepss) ) THEN
- Its_xpencil_topo=.FALSE.
- Its_xyslab_topo =.FALSE.
- ENDIF
- IF( abs(length(2) - length_phys(2)).GT.(ppm_myepss) ) THEN
- Its_xyslab_topo =.FALSE.
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- length(1) = f_topo%max_subd(1,idom) - f_topo%min_subd(1,idom)
- length(2) = f_topo%max_subd(2,idom) - f_topo%min_subd(2,idom)
- IF( abs(length(1) - length_phys(1)).GT.(ppm_myepsd) ) THEN
- Its_xpencil_topo=.FALSE.
- Its_xyslab_topo =.FALSE.
- ENDIF
- IF( abs(length(2) - length_phys(2)).GT.(ppm_myepsd) ) THEN
- Its_xyslab_topo =.FALSE.
- ENDIF
-#endif
- ENDDO
- IF (ppm_debug .GT. 0) THEN
- IF(Its_xpencil_topo) THEN
- WRITE(mesg,'(A)' ) 'X pencil topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- ELSE
- WRITE(mesg,'(A)' ) 'Not X pencil topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- ENDIF
- IF(Its_xyslab_topo) THEN
- WRITE(mesg,'(A)' ) 'XY slab topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- ELSE
- WRITE(mesg,'(A)' ) 'Not XY slab topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Setting of x-pencil topology
- !-------------------------------------------------------------------------
- IF(Its_xpencil_topo) THEN
- topo_id_xpen = field_topoid
- mesh_id_xpen = mesh_id_data
-! topo_ids(1) = topo_id_xpen
- topo_id_ypen = topo_ids(2)
-#if __MESH_DIM == __3D
- topo_id_zpen = topo_ids(3)
-#endif
- mesh_id_xpen_complex = mesh_ids(2)
- mesh_id_ypen = mesh_ids(3)
-#if __MESH_DIM == __3D
- mesh_id_zpen = mesh_ids(4)
-#endif
- ELSE
- topo_id_xpen = topo_ids(1)
- topo_id_ypen = topo_ids(2)
-#if __MESH_DIM == __3D
- topo_id_zpen = topo_ids(3)
-#endif
- mesh_id_xpen = mesh_ids(1)
- mesh_id_xpen_complex = mesh_ids(2)
- mesh_id_ypen = mesh_ids(3)
-#if __MESH_DIM == __3D
- mesh_id_zpen = mesh_ids(4)
-#endif
- ENDIF
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A)' ) ' ID topo mesh'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- WRITE(mesg,'(A)' ) '-----------------------------------'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Original ',field_topoid, mesh_id_data
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'X Pencil ', topo_id_xpen, mesh_id_xpen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'X Pencil Complex', topo_id_xpen, &
- & mesh_id_xpen_complex
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Y Pencil Complex', topo_id_ypen, mesh_id_ypen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Z Pencil Complex', topo_id_zpen, mesh_id_zpen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_init',mesg,j)
- ENDIF
- !-------------------------------------------------------------------------
- ! Decompose domain in xy Slabs
- !-------------------------------------------------------------------------
- IF(.NOT.Its_xyslab_topo) THEN
- assign = ppm_param_assign_internal
- decomp = ppm_param_decomp_xy_slab
- CALL ppm_mktopo(topo_id_xpen,mesh_id_xpen,xp,Npart,decomp,assign,&
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm, &
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_xpen,mesh_id_xpen,Nm,istart,ndata_slab,&
- & maxndata_slab,isublist,nsublist,info)
- ELSE
- ndata_slab = ndata
- ENDIF
- !-------------------------------------------------------------------------
- ! Create Plan/ Table for xy slab topology
- !-------------------------------------------------------------------------
- idom = f_topo%isublist(f_topo%nsublist)
- ! substract 1 to fit ppm-convention
- Nx_in=ndata_slab(1,idom)-1
- Ny_in=ndata_slab(2,idom)-1
-#if __MESH_DIM == __3D
- Nz_in=ndata_slab(3,idom)
-#endif
- Nx_out = Nx_in/2 + 1
- Ny_out = Ny_in
- Nz_out = Nz_in
- !-------------------------------------------------------------------------
- ! FFTW version xy slab
- !-------------------------------------------------------------------------
-#ifdef __FFTW
-#if __MESH_DIM == __3D
- MBRank = 2
- MBIstride = 1
- MBHowmany = Nz_in
- lda(1) = Nx_in+1
- lda(2) = Ny_in+1
- lda(3) = Nz_in
-
- iopt = ppm_param_alloc_fit
-
- CALL ppm_alloc(data_real,lda,iopt,info)
- data_real = 1.0_MK
- lda(1) = Nx_out
- lda(2) = Ny_out + 1
- lda(3) = Nz_out
- CALL ppm_alloc(data_comp,lda,iopt,info)
- data_comp = 1.0_MK
-
- Nm_slab(1) = Nx_in
- Nm_slab(2) = Ny_in
-
- iEmbed_slab(1) = Nx_in+1
- iEmbed_slab(2) = Ny_in+1
- oEmbed_slab(1) = Nx_out
- oEmbed_slab(2) = Ny_out + 1
- MBiDist = (Nx_in+1) * (Ny_in+1)
- MBoDist = Nx_out * (Ny_out+1)
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_plan_many_dft_r2c(Plan_slab_fd_s, MBRank,Nm_slab(1), MBHowmany, &
- & data_real(1,1,1), iEmbed_slab(1),MBIstride,MBiDist, &
- & data_comp(1,1,1),oEmbed_slab(1),MBIstride,MBoDist,FFTW_MEASURE)
- CALL sfftw_execute(Plan_slab_fd_s)
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_plan_many_dft_r2c(Plan_slab_fd_d, MBRank,Nm_slab, MBHowmany, &
- & data_real(1,1,1), iEmbed_slab,MBIstride,MBiDist, &
- & data_comp(1,1,1), oEmbed_slab,MBIstride,MBoDist,FFTW_MEASURE)
-#endif
- oEmbed_slab(1) = Nx_in+1
- oEmbed_slab(2) = Ny_in+1
- iEmbed_slab(1) = Nx_out
- iEmbed_slab(2) = Ny_out + 1
- MBoDist = (Nx_in+1) * (Ny_in+1)
- MBiDist = Nx_out * (Ny_out+1)
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_plan_many_dft_c2r(Plan_slab_bd_s, MBRank,Nm_slab, MBHowmany, &
- & data_comp(1,1,1),iEmbed_slab,MBIstride,MBiDist, &
- & data_real(1,1,1),oEmbed_slab,MBIstride,MBoDist,FFTW_MEASURE)
- CALL sfftw_execute(Plan_slab_bd_s)
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_plan_many_dft_c2r(Plan_slab_bd_d, MBRank,Nm_slab, MBHowmany, &
- & data_comp(1,1,1), iEmbed_slab,MBIstride,MBiDist, &
- & data_real(1,1,1), oEmbed_slab,MBIstride,MBoDist,FFTW_MEASURE)
-#endif
- CALL ppm_alloc(data_real,lda,ppm_param_dealloc,info)
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Decompose domain in xpencils
- !-------------------------------------------------------------------------
- IF(.NOT.Its_xpencil_topo) THEN
- assign = ppm_param_assign_internal
- ! xpencils decomposition
- decomp = ppm_param_decomp_xpencil
- CALL ppm_mktopo(topo_id_xpen,mesh_id_xpen,xp,Npart,decomp,assign,&
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm, &
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_xpen,mesh_id_xpen,Nm,istart,ndata,&
- & maxndata,isublist,nsublist,info)
-
- ENDIF
- !-------------------------------------------------------------------------
- ! Create Plan/ Table for xpencil topology
- !-------------------------------------------------------------------------
- idom = f_topo%isublist(f_topo%nsublist)
- ! substract 1 to fit ppm-convention
- Nx_in=ndata(1,idom)-1
- Ny_in=ndata(2,idom)
-#if __MESH_DIM == __3D
- Nz_in=ndata(3,idom)
-#endif
- Nx_out = Nx_in/2 + 1
- Ny_out = Ny_in
- Nz_out = Nz_in
- !-------------------------------------------------------------------------
- ! FFTW version xpencil
- !-------------------------------------------------------------------------
-#ifdef __FFTW
-#if __MESH_DIM == __2D
- MBRank = 1
- MBiEmbed(1) = -1
- MBoEmbed(1) = -1
- MBIstride = 1
- MBHowmany = Ny_in
-
- iopt = ppm_param_alloc_fit
- lda(1) = Nx_in+1
- lda(2) = Ny_in
- CALL ppm_alloc(data_real,lda,iopt,info)
- lda(1) = Nx_out
- lda(2) = Ny_out
- CALL ppm_alloc(data_comp,lda,iopt,info)
-#if __KIND == __SINGLE_PRECISION
- MBiDist = Nx_in+1
- MBoDist = Nx_out
- MB_in (1) = Nx_in
- CALL sfftw_plan_many_dft_r2c(Plan_fd_s, MBRank,MB_in, MBHowmany, &
- & data_real(1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_comp(1,1),MBoEmbed(1),MBIstride,MBoDist,FFTW_MEASURE)
- MBiDist = Nx_out
- MBoDist = Nx_in+1
- CALL sfftw_plan_many_dft_c2r(Plan_bd_s, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_real(1,1),MBoEmbed(1),MBIstride,MBoDist,FFTW_MEASURE)
-#elif __KIND == __DOUBLE_PRECISION
- MBiDist = Nx_in+1
- MBoDist = Nx_out
- MB_in (1) = Nx_in
- CALL dfftw_plan_many_dft_r2c(Plan_fd_d, MBRank,MB_in, MBHowmany, &
- & data_real(1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_comp(1,1),MBoEmbed(1),MBIstride,MBoDist,FFTW_MEASURE)
- MBiDist = Nx_out
- MBoDist = Nx_in+1
- CALL dfftw_plan_many_dft_c2r(Plan_bd_d, MBRank,MB_in, MBHowmany, &
- & data_real(1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_comp(1,1),MBoEmbed(1),MBIstride,MBoDist,FFTW_MEASURE)
-#endif
-#endif
-#if __MESH_DIM == __3D
- MBRank = 1
- MBiEmbed(1) = -1
- MBoEmbed(1) = -1
- MBIstride = 1
- MBHowmany = Ny_in*Nz_in
-
- iopt = ppm_param_alloc_fit
- lda(1) = Nx_in+1
- lda(2) = Ny_in
- lda(3) = Nz_in
- CALL ppm_alloc(data_real,lda,iopt,info)
-
- lda(1) = Nx_out
- lda(2) = Ny_out
- lda(3) = Nz_out
- CALL ppm_alloc(data_comp,lda,iopt,info)
-#if __KIND == __SINGLE_PRECISION
- MBiDist = Nx_in+1
- MBoDist = Nx_out
- MB_in (1) = Nx_in
- CALL sfftw_plan_many_dft_r2c(Plan_fd_s, MBRank,MB_in, MBHowmany, &
- & data_real(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_comp(1,1,1),MBoEmbed(1),MBIstride,MBoDist,FFTW_MEASURE)
- MBiDist = Nx_out
- MBoDist = Nx_in+1
-
- CALL sfftw_plan_many_dft_c2r(Plan_bd_s, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_real(1,1,1),MBoEmbed(1),MBIstride,MBoDist,FFTW_MEASURE)
-#elif __KIND == __DOUBLE_PRECISION
- MBiDist = Nx_in+1
- MBoDist = Nx_out
- MB_in (1) = Nx_in
- CALL dfftw_plan_many_dft_r2c(Plan_fd_d, MBRank,MB_in, MBHowmany, &
- & data_real(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_comp(1,1,1),MBoEmbed(1),MBIstride,MBoDist,FFTW_MEASURE)
- MBiDist = Nx_out
- MBoDist = Nx_in+1
- CALL dfftw_plan_many_dft_c2r(Plan_bd_d, MBRank,MB_in, MBHowmany, &
- & data_real(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_comp(1,1,1),MBoEmbed(1),MBIstride,MBoDist,FFTW_MEASURE)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! MATHKEISAN version xpencil
- !-------------------------------------------------------------------------
-#ifdef __MATHKEISAN
- lda_table = 2*Nx_in + 64
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_alloc(table_fd_s,lda_table,ppm_param_alloc_fit,info)
- CALL ppm_alloc(table_bd_s,lda_table,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_init', &
- & 'table_fd_s not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_alloc(table_fd_d,lda_table,ppm_param_alloc_fit,info)
- CALL ppm_alloc(table_bd_d,lda_table,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_init', &
- & 'table_fd_d not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- scale_fft = 1
- isign_fft = 0
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- CALL scfft(isign_fft, Nx_in, scale_fft, data_real(1,1), &
- & data_comp(1,1), table_fd_s, work, isys)
- CALL csfft(isign_fft, Nx_in, scale_fft, data_comp(1,1), &
- & data_real(1,1), table_bd_s, work, isys)
-#elif __KIND == __DOUBLE_PRECISION
- CALL dzfft(isign_fft, Nx_in, scale_fft, data_real(1,1), &
- & data_comp(1,1), table_fd_d, work, isys)
- CALL zdfft(isign_fft, Nx_in, scale_fft, data_comp(1,1), &
- & data_real(1,1), table_bd_d, work, isys)
-#endif
-#endif
-#if __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- CALL scfft(isign_fft, Nx_in, scale_fft, data_real(1,1,1), &
- & data_comp(1,1,1), table_fd_s, work, isys)
- CALL csfft(isign_fft, Nx_in, scale_fft, data_comp(1,1,1), &
- & data_real(1,1,1), table_bd_s, work, isys)
-
-#elif __KIND == __DOUBLE_PRECISION
- CALL dzfft(isign_fft, Nx_in, scale_fft, data_real(1,1,1), &
- & data_comp(1,1,1), table_fd_d, work, isys)
- CALL zdfft(isign_fft, Nx_in, scale_fft, data_comp(1,1,1), &
- & data_real(1,1,1), table_bd_d, work, isys)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Decompose domain in ypencils
- !-------------------------------------------------------------------------
- decomp = ppm_param_decomp_ypencil
- CALL ppm_mktopo(topo_id_ypen,mesh_id_ypen,xp,Npart,decomp,assign, &
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm,&
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_ypen,mesh_id_ypen,Nm,istart_ypen,ndata_ypen,&
- & maxndata_ypen,isublist,nsublist,info)
-
- !-------------------------------------------------------------------------
- ! Create Plan/ Table for ypencil topology
- !-------------------------------------------------------------------------
- idom = f_topo%isublist(f_topo%nsublist)
- ! substract 1 to fit ppm-convention
- Nx_in=ndata_ypen(2,idom)-1
- Ny_in=ndata_ypen(1,idom)
-#if __MESH_DIM == __3D
- Nz_in=ndata_ypen(3,idom)
-#endif
- Nx_out = Nx_in
- Ny_out = Ny_in
- Nz_out = Nz_in
- !-------------------------------------------------------------------------
- ! FFTW version ypencil
- !-------------------------------------------------------------------------
-#ifdef __FFTW
-#if __MESH_DIM == __2D
- MBRank = 1
- MBiEmbed(1) = -1
- MBoEmbed(1) = -1
- MBIstride = 1
- MBiDist = Nx_in+1
- MBoDist = Nx_out+1
- MB_in(1) = Nx_in
- MBHowmany = Ny_in
- lda(1) = Nx_in+1
- lda(2) = Ny_in
- CALL ppm_alloc(data_comp,lda,iopt,info)
- CALL ppm_alloc(data_compl,lda,iopt,info)
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_plan_many_dft(Plan_fd_c_y, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_FORWARD, FFTW_MEASURE)
- CALL sfftw_plan_many_dft(Plan_bd_c_y, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_BACKWARD, FFTW_MEASURE)
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_plan_many_dft(Plan_fd_cc_y, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_FORWARD, FFTW_MEASURE)
- CALL dfftw_plan_many_dft(Plan_bd_cc_y, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_BACKWARD, FFTW_MEASURE)
-#endif
-#endif
-#if __MESH_DIM == __3D
- MBRank = 1
- MBiEmbed(1) = -1
- MBoEmbed(1) = -1
- MBIstride = 1
- MBiDist = Nx_in+1
- MBoDist = Nx_out+1
- MB_in(1) = Nx_in
- MBHowmany = Ny_in*Nz_in
- lda(1) = Nx_in+1
- lda(2) = Ny_in
- lda(3) = Nz_in
- CALL ppm_alloc(data_comp,lda,iopt,info)
- CALL ppm_alloc(data_compl,lda,iopt,info)
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_plan_many_dft(Plan_fd_c_y, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_FORWARD, FFTW_MEASURE)
- CALL sfftw_plan_many_dft(Plan_bd_c_y, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_BACKWARD, FFTW_MEASURE)
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_plan_many_dft(Plan_fd_cc_y, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_FORWARD, FFTW_MEASURE)
- CALL dfftw_plan_many_dft(Plan_bd_cc_y, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_BACKWARD, FFTW_MEASURE)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! MATHKEISAN version ypencil
- !-------------------------------------------------------------------------
-#ifdef __MATHKEISAN
- lda_table_y = 2*Nx_in + 64
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_alloc(table_fd_c_y,lda_table_y,ppm_param_alloc_fit,info)
- CALL ppm_alloc(table_bd_c_y,lda_table_y,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_init', &
- & 'table_fd_s not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_alloc(table_fd_cc_y,lda_table_y,ppm_param_alloc_fit,info)
- CALL ppm_alloc(table_bd_cc_y,lda_table_y,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_init', &
- & 'table_fd_d not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- scale_fft = 1
- isign_fft = 0
- incx = 1
- incy = 1
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- CALL cfft(isign_fft, Nx_in, scale_fft, data_comp(1,1), incx, &
- & data_compl(1,1),incy, table_fd_c_y, lda_table_y,work,1,isys)
-#elif __KIND == __DOUBLE_PRECISION
- CALL zfft(isign_fft, Nx_in, scale_fft, data_comp(1,1), incx, &
- & data_compl(1,1),incy, table_fd_cc_y, lda_table_y,work,1,isys)
-#endif
-#endif
-#if __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- CALL cfft(isign_fft, Nx_in, scale_fft, data_comp(1,1,1), incx, &
- & data_compl(1,1,1),incy, table_fd_c_y, lda_table_y,work,1,isys)
-#elif __KIND == __DOUBLE_PRECISION
- CALL zfft(isign_fft, Nx_in, scale_fft, data_comp(1,1,1), incx, &
- & data_compl(1,1,1),incy, table_fd_cc_y, lda_table_y,work,1,isys)
-#endif
-#endif
-#endif
-#if __MESH_DIM == __3D
- !-------------------------------------------------------------------------
- ! Decompose domain in zpencils
- !-------------------------------------------------------------------------
- decomp = ppm_param_decomp_zpencil
- CALL ppm_mktopo(topo_id_zpen,mesh_id_zpen,xp,Npart,decomp,assign, &
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm,&
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_zpen,mesh_id_zpen,Nm,istart_zpen,ndata_zpen,&
- & maxndata_zpen,isublist,nsublist,info)
-
- !-------------------------------------------------------------------------
- ! Create Plan/ Table for zpencil topology
- !-------------------------------------------------------------------------
- idom = f_topo%isublist(f_topo%nsublist)
- ! substract 1 to fit ppm-convention
- Nx_in=ndata_zpen(3,idom)-1
- Ny_in=ndata_zpen(2,idom)
- Nz_in=ndata_zpen(1,idom)
- Nx_out = Nx_in
- Ny_out = Ny_in
- Nz_out = Nz_in
- !-------------------------------------------------------------------------
- ! FFTW version zpencil
- !-------------------------------------------------------------------------
-#ifdef __FFTW
- MBRank = 1
- MBiEmbed(1) = -1
- MBoEmbed(1) = -1
- MBIstride = 1
- MBiDist = Nx_in+1
- MBoDist = Nx_out+1
- MB_in(1) = Nx_in
- MBHowmany = Ny_in*Nz_in
- lda(1) = Nx_in+1
- lda(2) = Ny_in
- lda(3) = Nz_in
- CALL ppm_alloc(data_comp,lda,iopt,info)
- CALL ppm_alloc(data_compl,lda,iopt,info)
-#if __KIND == __SINGLE_PRECISION
- CALL sfftw_plan_many_dft(Plan_fd_c_z, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_FORWARD, FFTW_MEASURE)
- CALL sfftw_plan_many_dft(Plan_bd_c_z, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_BACKWARD, FFTW_MEASURE)
-#elif __KIND == __DOUBLE_PRECISION
- CALL dfftw_plan_many_dft(Plan_fd_cc_z, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_FORWARD, FFTW_MEASURE)
- CALL dfftw_plan_many_dft(Plan_bd_cc_z, MBRank,MB_in, MBHowmany, &
- & data_comp(1,1,1), MBiEmbed(1),MBIstride,MBiDist, &
- & data_compl(1,1,1),MBoEmbed(1),MBIstride,MBoDist, &
- & FFTW_BACKWARD, FFTW_MEASURE)
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! MATHKEISAN version zpencil
- !-------------------------------------------------------------------------
-#ifdef __MATHKEISAN
- lda_table_z = 2*Nx_in + 64
-#if __KIND == __SINGLE_PRECISION
- CALL ppm_alloc(table_fd_c_z,lda_table_z,ppm_param_alloc_fit,info)
- CALL ppm_alloc(table_bd_c_z,lda_table_z,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_init', &
- & 'table_fd_s not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- CALL ppm_alloc(table_fd_cc_z,lda_table_z,ppm_param_alloc_fit,info)
- CALL ppm_alloc(table_bd_cc_z,lda_table_z,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_init', &
- & 'table_fd_d not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- scale_fft = 1
- isign_fft = 0
- incx = 1
- incy = 1
-#if __KIND == __SINGLE_PRECISION
- CALL cfft(isign_fft, Nx_in, scale_fft, data_comp(1,1,1), incx, &
- & data_compl(1,1,1),incy, table_fd_c_z, lda_table_z,work,1,isys)
-#elif __KIND == __DOUBLE_PRECISION
- CALL zfft(isign_fft, Nx_in, scale_fft, data_comp(1,1), incx, &
- & data_compl(1,1,1),incy, table_fd_cc_z, lda_table_z,work,1,isys)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Deallocate memory
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(ndata,lda,iopt,info)
-#ifdef __MATHKEISAN
- CALL ppm_alloc(work,1,iopt,info)
-#endif
- CALL ppm_alloc(cost,lda,iopt,info)
- CALL ppm_alloc(istart,lda,iopt,info)
- CALL ppm_alloc(istart_ypen,lda,iopt,info)
- CALL ppm_alloc(istart_zpen,lda,iopt,info)
- CALL ppm_alloc(ndata,lda,iopt,info)
- CALL ppm_alloc(ndata_ypen,lda,iopt,info)
- CALL ppm_alloc(ndata_zpen,lda,iopt,info)
- CALL ppm_alloc(ndata_slab,lda,iopt,info)
- CALL ppm_alloc(data_real,lda,iopt,info)
- CALL ppm_alloc(data_comp,lda,iopt,info)
- CALL ppm_alloc(data_compl,lda,iopt,info)
-#endif
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_init',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_init',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_init_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_init_2d_sca_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_init_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_init_3d_sca_d
-#endif
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __MESH_DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_init_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_init_2d_vec_d
-#endif
-#elif __MESH_DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_init_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_init_3d_vec_d
-#endif
-#endif
-#endif
diff --git a/src/ppm_fdsolver_map_2d.f b/src/ppm_fdsolver_map_2d.f
deleted file mode 100644
index a0e37df8901fe07a3421aede420ba8aee02a09d0..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_map_2d.f
+++ /dev/null
@@ -1,270 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_map_2d
- !-------------------------------------------------------------------------
- !
- ! Purpose : maps the data from topology topo_ids(1)) / mesh
- ! (mesh_ids(1)) to topology (topo_ids(2))/mesh (mesh_ids(2))
- !
- !
- ! Input :
- ! topo_ids(2) (I)
- ! first: current topology
- ! second: destination topology
- ! mesh_ids(2) (I)
- ! first: current mesh of the data
- ! second: destination mesh
- !
- !
- ! Input/output : data_fv(:,:,:,:) (F) data to be mapped
- !
- !
- !
- ! Output :
- ! info (I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_map_2d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.9 2006/09/04 18:34:43 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.8 2005/05/03 13:33:41 hiebers
- ! Bugfix: call ppm_check_meshid with internal topo ID
- !
- ! Revision 1.7 2004/10/01 16:08:57 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.6 2004/08/31 15:14:03 hiebers
- ! added argument check for topo and mesh ids
- !
- ! Revision 1.5 2004/08/19 13:14:54 hiebers
- ! debugged scalar/vector version
- !
- ! Revision 1.3 2004/07/26 13:49:16 ivos
- ! Removed Routines sections from the header comment.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_map_2d_sca_s(data_fv, topo_ids, mesh_ids, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_map_2d_sca_d(data_fv, topo_ids, mesh_ids, info)
-#elif __KIND == __COMPLEX
- SUBROUTINE ppm_fdsolver_map_2d_sca_c(data_fv, topo_ids, mesh_ids, info)
-#elif __KIND == __DOUBLE_COMPLEX
- SUBROUTINE ppm_fdsolver_map_2d_sca_cc(data_fv, topo_ids, mesh_ids,info)
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_map_2d_vec_s(data_fv,lda,topo_ids, mesh_ids, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_map_2d_vec_d(data_fv,lda,topo_ids, mesh_ids, info)
-#elif __KIND == __COMPLEX
- SUBROUTINE ppm_fdsolver_map_2d_vec_c(data_fv,lda,topo_ids, mesh_ids, info)
-#elif __KIND == __DOUBLE_COMPLEX
- SUBROUTINE ppm_fdsolver_map_2d_vec_cc(data_fv,lda,topo_ids, mesh_ids,info)
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_map
- USE ppm_module_check_id
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_map_field
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! POINTER to data
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK), DIMENSION(:,:,:), POINTER :: data_fv
-#elif __KIND == __COMPLEX | __KIND == __DOUBLE_COMPLEX
- COMPLEX(MK), DIMENSION(:,:,:), POINTER :: data_fv
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: data_fv
-#elif __KIND == __COMPLEX | __KIND == __DOUBLE_COMPLEX
- COMPLEX(MK), DIMENSION(:,:,:,:), POINTER :: data_fv
-#endif
-#endif
-#if __DIM == __VFIELD
- INTEGER, INTENT(IN) :: lda
-#endif
-
- INTEGER, DIMENSION(2), INTENT(IN) :: topo_ids
- INTEGER, DIMENSION(2), INTENT(IN) :: mesh_ids
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! counters
- INTEGER :: k, i, j
- !Size of the data_in
- INTEGER :: from_topo, to_topo
- INTEGER :: from_mesh, to_mesh
- LOGICAL :: valid
-#if __DIM == __SFIELD
- INTEGER, PARAMETER :: lda = 1
-#endif
- INTEGER , DIMENSION(2 ) :: ghostsize
- INTEGER :: maptype
- CHARACTER(LEN=ppm_char) :: mesg
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_map_2d',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (topo_ids(1).GE.0) THEN
- CALL ppm_check_topoid(topo_ids(1),valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_map_2d', &
- & 'Topology ID (from_topo) is invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (topo_ids(2).GE.0) THEN
- CALL ppm_check_topoid(topo_ids(2),valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_map_2d', &
- & 'Topology ID (to_topo) is invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (mesh_ids(1) .GT. 0) THEN
- CALL ppm_check_meshid(topo_ids(1),mesh_ids(1),valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_map_2d', &
- & 'Mesh ID (from_mesh) invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (mesh_ids(2) .GT. 0) THEN
- CALL ppm_check_meshid(topo_ids(2),mesh_ids(2),valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_map_2d', &
- & 'Mesh ID (to_mesh) invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Define source and destination
- !-------------------------------------------------------------------------
- from_topo = topo_ids(1)
- to_topo = topo_ids(2)
- from_mesh = mesh_ids(1)
- to_mesh = mesh_ids(2)
- ghostsize(1) = 0
- ghostsize(2) = 0
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A,I5,A,I5)' )'Mapping from topo ',from_topo, &
- & ', mesh ',from_mesh
- CALL ppm_write(ppm_rank,'ppm_fdsolver_map',mesg,j)
- WRITE(mesg,'(A,I5,A,I5)' )' to topo ',to_topo, &
- & ', mesh ',to_mesh
- CALL ppm_write(ppm_rank,'ppm_fdsolver_map',mesg,j)
- ENDIF
- !-------------------------------------------------------------------------
- ! Map fields
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
- CALL ppm_map_field_global(from_topo,to_topo,from_mesh,to_mesh,info)
- CALL ppm_map_field_push(from_topo,from_mesh,DATA_fv,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(to_topo,to_mesh,DATA_fv,ghostsize,info)
-#elif __DIM == __VFIELD
- CALL ppm_map_field_global(from_topo,to_topo,from_mesh,to_mesh,info)
- CALL ppm_map_field_push(from_topo,from_mesh,DATA_fv,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(to_topo,to_mesh,DATA_fv,ghostsize,info)
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_map_2d',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_map_2d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_map_2d_sca_d
-#elif __KIND == __COMPLEX
- END SUBROUTINE ppm_fdsolver_map_2d_sca_c
-#elif __KIND == __DOUBLE_COMPLEX
- END SUBROUTINE ppm_fdsolver_map_2d_sca_cc
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_map_2d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_map_2d_vec_d
-#elif __KIND == __COMPLEX
- END SUBROUTINE ppm_fdsolver_map_2d_vec_c
-#elif __KIND == __DOUBLE_COMPLEX
- END SUBROUTINE ppm_fdsolver_map_2d_vec_cc
-#endif
-#endif
diff --git a/src/ppm_fdsolver_map_3d.f b/src/ppm_fdsolver_map_3d.f
deleted file mode 100644
index c4b6014bd18238b4ff07d3d74cdca4ddb00e7666..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_map_3d.f
+++ /dev/null
@@ -1,275 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_map_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : maps the data from topology topo_ids(1)) / mesh
- ! (mesh_ids(1)) to topology (topo_ids(2))/mesh (mesh_ids(2))
- !
- !
- ! Input :
- ! topo_ids(2) (I)
- ! first: current topology
- ! second: destination topology
- ! mesh_ids(2) (I)
- ! first: current mesh of the data
- ! second: destination mesh
- !
- !
- ! Input/output : data_f(:,:,:,:,:) (F) data to be mapped
- !
- !
- !
- ! Output :
- ! info (I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_map_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.11 2006/09/04 18:34:44 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.10 2005/05/03 13:33:10 hiebers
- ! Bugfix: call ppm_check_meshid with internal topo ID
- !
- ! Revision 1.9 2004/10/01 16:08:58 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.8 2004/08/31 15:14:26 hiebers
- ! added argument checks for topo and mesh ids
- !
- ! Revision 1.7 2004/08/27 09:45:47 hiebers
- ! added ghostsize as an argument
- !
- ! Revision 1.4 2004/08/18 16:34:07 hiebers
- ! added scalar vector version
- !
- ! Revision 1.3 2004/07/26 13:49:17 ivos
- ! Removed Routines sections from the header comment.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_map_3d_sca_s(data_fv, topo_ids, mesh_ids,&
- & ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_map_3d_sca_d(data_fv, topo_ids, mesh_ids,&
- & ghostsize, info)
-#elif __KIND == __COMPLEX
- SUBROUTINE ppm_fdsolver_map_3d_sca_c(data_fv, topo_ids, mesh_ids,&
- & ghostsize, info)
-#elif __KIND == __DOUBLE_COMPLEX
- SUBROUTINE ppm_fdsolver_map_3d_sca_cc(data_fv, topo_ids, mesh_ids,&
- & ghostsize, info)
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_map_3d_vec_s(data_fv, lda, topo_ids, mesh_ids, &
- & ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_map_3d_vec_d(data_fv, lda, topo_ids, mesh_ids, &
- & ghostsize, info)
-#elif __KIND == __COMPLEX
- SUBROUTINE ppm_fdsolver_map_3d_vec_c(data_fv, lda, topo_ids, mesh_ids, &
- & ghostsize, info)
-#elif __KIND == __DOUBLE_COMPLEX
- SUBROUTINE ppm_fdsolver_map_3d_vec_cc(data_fv, lda, topo_ids, mesh_ids, &
- & ghostsize, info)
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_map
- USE ppm_module_check_id
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_map_field
-
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION | __KIND == __DOUBLE_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! POINTER to data
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: data_fv
-#elif __KIND == __COMPLEX | __KIND == __DOUBLE_COMPLEX
- COMPLEX(MK), DIMENSION(:,:,:,:), POINTER :: data_fv
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION | __KIND == __DOUBLE_PRECISION
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: data_fv
-#elif __KIND == __COMPLEX | __KIND == __DOUBLE_COMPLEX
- COMPLEX(MK), DIMENSION(:,:,:,:,:), POINTER :: data_fv
-#endif
- INTEGER, INTENT(IN) :: lda
-#endif
- INTEGER, DIMENSION(2), INTENT(IN) :: topo_ids
- INTEGER, DIMENSION(2), INTENT(IN) :: mesh_ids
- INTEGER, DIMENSION(3), INTENT(IN) :: ghostsize
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! counters
- INTEGER :: k, i, j
- !Size of the data_in
- INTEGER :: from_topo, to_topo
- INTEGER :: from_mesh, to_mesh
-#if __DIM == __SFIELD
- INTEGER, PARAMETER :: lda = 1
-#endif
- INTEGER :: maptype
- LOGICAL :: valid
- CHARACTER(LEN=ppm_char) :: mesg
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_map_3d',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (topo_ids(1).GE.0) THEN
- CALL ppm_check_topoid(topo_ids(1),valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_map_2d', &
- & 'Topology ID (from_topo) is invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (topo_ids(2).GE.0) THEN
- CALL ppm_check_topoid(topo_ids(2),valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_map_2d', &
- & 'Topology ID (to_topo) is invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (mesh_ids(1) .GT. 0) THEN
- CALL ppm_check_meshid(topo_ids(1),mesh_ids(1),valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_map_2d', &
- & 'Mesh ID (from_mesh) invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (mesh_ids(2) .GT. 0) THEN
- CALL ppm_check_meshid(topo_ids(2),mesh_ids(2),valid,info)
- IF (.NOT. valid) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_map_2d', &
- & 'Mesh ID (to_mesh) invalid!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Define source and destination
- !-------------------------------------------------------------------------
- from_topo = topo_ids(1)
- to_topo = topo_ids(2)
- from_mesh = mesh_ids(1)
- to_mesh = mesh_ids(2)
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A,I5,A,I5)' )'Mapping from topo ',from_topo,', mesh ',from_mesh
- CALL ppm_write(ppm_rank,'ppm_fdsolver_map',mesg,j)
- WRITE(mesg,'(A,I5,A,I5)' )' to topo ',to_topo,', mesh ',to_mesh
- CALL ppm_write(ppm_rank,'ppm_fdsolver_map',mesg,j)
- ENDIF
- !-------------------------------------------------------------------------
- ! Map field
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
- CALL ppm_map_field_global(from_topo,to_topo,from_mesh,to_mesh,info)
- CALL ppm_map_field_push(from_topo,from_mesh,DATA_fv,lda,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(to_topo,to_mesh,DATA_fv,lda,ghostsize,info)
-#elif __DIM == __VFIELD
- CALL ppm_map_field_global(from_topo,to_topo,from_mesh,to_mesh,info)
- CALL ppm_map_field_push(from_topo,from_mesh,DATA_fv,lda,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(to_topo,to_mesh,DATA_fv,lda,ghostsize,info)
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_map_3d',t0,info)
- RETURN
-
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_map_3d_sca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_map_3d_sca_d
-#elif __KIND == __COMPLEX
- END SUBROUTINE ppm_fdsolver_map_3d_sca_c
-#elif __KIND == __DOUBLE_COMPLEX
- END SUBROUTINE ppm_fdsolver_map_3d_sca_cc
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_map_3d_vec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_map_3d_vec_d
-#elif __KIND == __COMPLEX
- END SUBROUTINE ppm_fdsolver_map_3d_vec_c
-#elif __KIND == __DOUBLE_COMPLEX
- END SUBROUTINE ppm_fdsolver_map_3d_vec_cc
-#endif
-#endif
diff --git a/src/ppm_fdsolver_poisson_2d.f b/src/ppm_fdsolver_poisson_2d.f
deleted file mode 100644
index 104aa527badbaac7d9a78eceedbd05a4fe1c5e48..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_poisson_2d.f
+++ /dev/null
@@ -1,195 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_poisson_2d.f
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine solves the poisson equation with the data
- ! as right hand side in fourier space
- ! - Laplacian of Phi = omega
- !
- !
- ! Input :
- ! lda(2) (I) size of local data field
- ! istart(2) (I) starting index of local field
- ! Nm(2) (I) size of global data
- ! length(2) (I) length of the domain
- !
- !
- ! Input/output :
- ! fdat(:,:) (F) data in fourier space:
- ! right hand side of poisson
- ! equation
- !
- !
- ! Output :
- ! info ( I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_poisson_2d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.7 2006/09/04 18:34:44 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.6 2005/02/16 12:02:50 hiebers
- ! simplified loop
- !
- ! Revision 1.5 2004/10/01 16:08:58 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.4 2004/07/26 15:38:46 ivos
- ! Inserted missing USE statements to resolve undefined references
- ! at link stage.
- !
- ! Revision 1.3 2004/07/26 13:49:17 ivos
- ! Removed Routines sections from the header comment.
- !
- ! Revision 1.2 2004/07/26 11:59:38 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.1 2004/07/26 08:52:27 hiebers
- ! Recommited, formerly ppm_module_fieldsolver
- !
- ! Revision 1.1 2004/05/19 15:35:25 hiebers
- ! implementation from scratch
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __KIND == __COMPLEX
- SUBROUTINE ppm_fdsolver_poisson_2dc(fdat,lda,istart,length,Nm,info)
-#elif __KIND == __DOUBLE_COMPLEX
- SUBROUTINE ppm_fdsolver_poisson_2dcc(fdat,lda,istart,length,Nm,info)
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
-
- IMPLICIT NONE
-#if __KIND == __COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! POINTER to data
- COMPLEX(MK), DIMENSION(:,:), INTENT(INOUT) :: fdat
- INTEGER, DIMENSION(2), INTENT(IN) :: lda,istart,Nm
- REAL(MK), DIMENSION(2), INTENT(IN) :: length
- INTEGER, INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! counters
- INTEGER :: i,j
- INTEGER :: i_global,j_global
- !Size of the data
- INTEGER :: lda_end
- ! wave number
- REAL(MK) :: kx, ky
- REAL(MK) :: pi2_Lx, pi2_Ly
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_poisson_2d',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (lda(1).LE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_poisson_2d', &
- & ' mesh size: Nx must be >0 ' ,__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(2).LE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_poisson_2d', &
- & ' mesh size: Ny must be >0 ' ,__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Solve Poisson Equation
- !-------------------------------------------------------------------------
-#if __KIND == __COMPLEX
- pi2_Lx = 2.0_MK*ppm_pi_s/length(1)
- pi2_Ly = 2.0_MK*ppm_pi_s/length(2)
-#elif __KIND == __DOUBLE_COMPLEX
- pi2_Lx = 2.0_MK*ppm_pi_d/length(1)
- pi2_Ly = 2.0_MK*ppm_pi_d/length(2)
-#endif
- lda_end=Nm(1)/2 +1
- DO j=1,lda(2)
- DO i=1,lda(1)
- ! decremented global index
- i_global = istart(1)+i-2
- j_global = istart(2)+j-2
- IF((i_global.EQ.0) .AND. (j_global.EQ.0) ) THEN
- fdat(i,j)= 0.0_MK
- ELSE
- ! consider complex conjugate elements (i> N/2+1)
- IF( i_global.GE.lda_end) THEN
- i_global = Nm(1)-i_global
- ENDIF
- kx=pi2_Lx*real(i_global,MK)
- ky=pi2_Ly*real(j_global,MK)
- !print*, i_global, j_global, lda_end, Nm
- fdat(i,j)=-1.0_MK/(kx*kx + ky*ky)*fdat(i,j)
- ENDIF
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_poisson_2d',t0,info)
- RETURN
-
-#if __KIND == __COMPLEX
- END SUBROUTINE ppm_fdsolver_poisson_2dc
-#elif __KIND == __DOUBLE_COMPLEX
- END SUBROUTINE ppm_fdsolver_poisson_2dcc
-#endif
diff --git a/src/ppm_fdsolver_poisson_3d.f b/src/ppm_fdsolver_poisson_3d.f
deleted file mode 100644
index cf9b9390d5985fb4ba8689c64584d4c3bcb29d53..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_poisson_3d.f
+++ /dev/null
@@ -1,212 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_poisson_3d.f
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine solves the poisson equation with the data
- ! as right hand side in fourier space
- ! - Laplacian of Phi = omega
- !
- !
- ! Input :
- ! lda(3) (I) size of local data field
- ! istart(3) (I) starting index of local field
- ! Nm(3) (I) size of global data
- ! length(3) (I) length of the domain
- !
- !
- ! Input/output :
- ! fdata(:,:) (F) data in fourier space
- ! right hand side of poisson
- ! equation
- !
- !
- ! Output :
- ! info ( I) return status. =0 if no error.
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_poisson_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.6 2006/09/04 18:34:44 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.5 2004/10/01 16:08:58 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.4 2004/09/24 11:32:20 hiebers
- ! added MK to float numbers, exchanged data by fdata
- !
- ! Revision 1.3 2004/07/26 13:49:17 ivos
- ! Removed Routines sections from the header comment.
- !
- ! Revision 1.2 2004/07/26 11:59:38 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.1 2004/07/26 08:52:28 hiebers
- ! Recommited, formerly ppm_module_fieldsolver
- !
- ! Revision 1.1 2004/05/19 15:36:00 hiebers
- ! implementation from scratch
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __KIND == __COMPLEX
- SUBROUTINE ppm_fdsolver_poisson_3dc(fdata,lda,istart,length,Nm,info)
-#elif __KIND == __DOUBLE_COMPLEX
- SUBROUTINE ppm_fdsolver_poisson_3dcc(fdata,lda,istart,length,Nm,info)
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
-
- IMPLICIT NONE
-#if __KIND == __COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! POINTER to data
- COMPLEX(MK), DIMENSION(:,:,:), POINTER :: fdata
- INTEGER, DIMENSION(3), INTENT(IN) :: lda,istart,Nm
- REAL(MK), DIMENSION(3), INTENT(IN) :: length
- INTEGER, INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! counters
- INTEGER :: i,j,k
- INTEGER :: i_global,j_global,k_global
- !Size of the data
- INTEGER, DIMENSION(2) :: lda_end
- INTEGER :: lda_end2
- ! wave number
- REAL(MK) :: kx,ky,kz
- REAL(MK) :: pi2_Lx,pi2_Ly,pi2_Lz
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_poisson_3d',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (lda(1).LE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_poisson_3d', &
- & ' mesh size: Nx must be >0 ' ,__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(2).LE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_poisson_3d', &
- & ' mesh size: Ny must be >0 ' ,__LINE__,info)
- GOTO 9999
- ENDIF
- IF (lda(3).LE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_poisson_3d', &
- & ' mesh size: Ny must be >0 ' ,__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Solve Poisson Equation
- !-------------------------------------------------------------------------
-#if __KIND == __COMPLEX
- pi2_Lx = 2.0_MK*ppm_pi_s/length(1)
- pi2_Ly = 2.0_MK*ppm_pi_s/length(2)
- pi2_Lz = 2.0_MK*ppm_pi_s/length(3)
-#elif __KIND == __DOUBLE_COMPLEX
- pi2_Lx = 2.0_MK*ppm_pi_d/length(1)
- pi2_Ly = 2.0_MK*ppm_pi_d/length(2)
- pi2_Lz = 2.0_MK*ppm_pi_d/length(3)
-#endif
- lda_end(1)=Nm(1)/2 +1
- lda_end(2)=Nm(2)/2 +1
- !-------------------------------------------------------------------------
- ! loop over all elements in fourier space and multiply 1/(kx^2+ky^2+kz^2)
- !-------------------------------------------------------------------------
- DO k=1,lda(3)
- DO j=1,lda(2)
- DO i=1,lda(1)
- ! decremented global index
- i_global = istart(1)+i-2
- j_global = istart(2)+j-2
- k_global = istart(3)+k-2
- IF((i_global.EQ.0) .AND. (j_global.EQ.0).AND. (k_global.EQ.0) ) THEN
- fdata(i,j,k)= 0.0_MK
- ELSE
- ! consider complex conjugate elements (i> N/2+1)
- IF( i_global.GE.lda_end(1)) THEN
- i_global = Nm(1)-i_global
- ENDIF
- ! consider complex conjugate elements (j> N/2+1)
- IF( j_global.GE.lda_end(2)) THEN
- j_global = Nm(2)-j_global
- ENDIF
- kx=pi2_Lx*real(i_global,MK)
- ky=pi2_Ly*real(j_global,MK)
- kz=pi2_Lz*real(k_global,MK)
- fdata(i,j,k)=-1.0_MK /(kx*kx + ky*ky + kz*kz)*fdata(i,j,k)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_poisson_3d',t0,info)
-
- RETURN
-#if __KIND == __COMPLEX
- END SUBROUTINE ppm_fdsolver_poisson_3dc
-#elif __KIND == __DOUBLE_COMPLEX
- END SUBROUTINE ppm_fdsolver_poisson_3dcc
-#endif
diff --git a/src/ppm_fdsolver_solve_2d.f b/src/ppm_fdsolver_solve_2d.f
deleted file mode 100644
index 6c14a8a6bf4c54a2559eb63bca1dc9693322c01c..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_solve_2d.f
+++ /dev/null
@@ -1,776 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_solve_2d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Poisson solver using FFTW
- ! Solves the negative poisson equation in a 2-dimensional
- ! periodic domain
- ! - Laplacian of Phi = omega
- ! It takes the field quantity omega in DATA_fv which is
- ! assumed to be periodic outside the domain. The most
- ! efficient initial topology for the fieldsolver is
- ! a x-pencil topology. After performing a FFT on the
- ! x-pencils the data is mapped onto y-pencils where
- ! again a FFT is performed.
- ! The version solve_init is based on recomputed FFT-plans
- ! created in ppm_fdsolver_init and destroyed in
- ! ppm_fdsolver_finalize.
- ! The poisson equation is solved in the Fourier space
- ! and the result transformed backward.
- ! The solution Phi is finally returned in DATA_fv.
- ! Note: field quantity must live on current topology
- !
- ! Usage:
- !
- ! ppm_fdsolver_init(arguments)
- !
- ! ppm_fdsolver_solve_init(arguments)
- !
- ! ppm_fdsolver_finalize(info)
- !
- !
- ! Standalone Usage:
- !
- ! ppm_fdsolver_solve(arguments)
- !
- ! Input :
- ! lda_fv (F) leading dimension (vector case only)
- ! mesh_id_data(I) mesh ID of the current data field mesh
- ! topo_ids(2) (I) topology IDs on which the FFTs are
- ! performed
- ! topo_ids(1) initial topology
- ! solve: xpencils
- ! solve_init: xpencils
- ! topo_ids(2) second topology
- ! solve: ypencils
- ! solve_init: ypencils
- !
- ! mesh_ids(3) (I) mesh IDs where the FFTs are performed
- ! mesh_ids(1) first mesh
- ! solve: xpencils,real
- ! solve_init: xpencils,real
- ! mesh_ids(2) second mesh
- ! solve: xpencils,complex
- ! solve_init: xpencils,complex
- ! mesh_ids(3) third mesh
- ! solve: ypencils,complex
- ! solve_init: ypencils,complex
- ! ghostsize(3) (I)ghostsize
- !
- !
- ! Input/output :
- ! DATA_fv(:,:,:,:) (F) field data
- !
- !
- !
- ! Output : info (I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_solve_2d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.15 2006/09/04 18:34:44 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.13 2006/04/10 08:54:29 pchatela
- ! Made xp a REAL, DIMENSION(:,:), POINTER to get rid of warnings
- !
- ! Revision 1.12 2006/04/07 17:41:53 hiebers
- ! Changed type of variable xp to POINTER
- !
- ! Revision 1.11 2005/08/03 14:35:12 ivos
- ! Shortened the subrountine names to meet the F90 31-character limit
- ! standard. pgf90 on gonzales had problems...
- !
- ! Revision 1.10 2005/03/21 15:41:21 hiebers
- ! fixed bug in assigning lda_DATA_fv_com
- !
- ! Revision 1.9 2005/02/16 11:58:43 hiebers
- ! Major addition: finalized scalar and vector version
- ! implemented version <solve_init> that used FFT plans created
- ! in ppm_fdsolver_init and destroyed in ppm_fdsolver_finalize
- ! whereas the version <solve> remains a standalone solver
- !
- ! Revision 1.8 2004/11/03 11:14:16 hiebers
- ! Exchanged __SXF90 by __MATHKEISAN
- !
- ! Revision 1.7 2004/10/01 16:08:58 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.6 2004/08/19 13:14:09 hiebers
- ! debugged scalar/vector version
- !
- ! Revision 1.5 2004/08/17 12:12:17 hiebers
- ! added scalar/vector versions
- !
- ! Revision 1.4 2004/07/28 14:18:47 hiebers
- ! fixed bug in routine call of ppm_fdsolver_poisson
- !
- ! Revision 1.3 2004/07/26 15:38:47 ivos
- ! Inserted missing USE statements to resolve undefined references
- ! at link stage.
- !
- ! Revision 1.2 2004/07/26 11:59:38 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.1 2004/07/26 08:52:28 hiebers
- ! Recommited, formerly ppm_module_fieldsolver
- !
- ! Revision 1.2 2004/07/26 07:28:00 hiebers
- ! optimized loops
- !
- ! Revision 1.1 2004/05/19 15:32:20 hiebers
- ! implementation from scratch
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __CASE == __INIT
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_init_2d_ss(DATA_fv, mesh_id_data,&
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_init_2d_sd(DATA_fv, mesh_id_data,&
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_init_2d_vs(DATA_fv, lda_fv, mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_init_2d_vd(DATA_fv, lda_fv, mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#endif
-#endif
-#else
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_2d_ss(DATA_fv, mesh_id_data,&
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_2d_sd(DATA_fv, mesh_id_data,&
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_2d_vs(DATA_fv, lda_fv, mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_2d_vd(DATA_fv, lda_fv, mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
-
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_write
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_mktopo
- USE ppm_module_topo_get
- USE ppm_module_mesh_define
- USE ppm_module_fdsolver_map
- USE ppm_module_util_fft_forward
- USE ppm_module_util_fft_backward
- USE ppm_module_fdsolver_fft_fd
- USE ppm_module_fdsolver_fft_bd
- USE ppm_module_fdsolver_poisson
- USE ppm_module_error
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! mesh ID of the data
- ! Note F.Perignon: I remove the INTENT(IN) for mesh_id_data to make the lib work, but I guess its
- ! not a proper solution ...
- INTEGER :: mesh_id_data
- ! topo ID of the field
- INTEGER , INTENT(IN) :: field_topoid
-#if __DIM == __SFIELD
- ! data
- REAL(MK), DIMENSION(:,:,:), POINTER :: DATA_fv
-#elif __DIM == __VFIELD
- ! data
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: DATA_fv
- INTEGER , INTENT(IN) :: lda_fv
-#endif
- ! topo / mesh ID for the mapping
- INTEGER, DIMENSION(2) , INTENT(IN ) :: topo_ids
- INTEGER, DIMENSION(3) , INTENT(IN ) :: mesh_ids
- INTEGER, DIMENSION(2) , INTENT(IN ) :: ghostsize
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! parameter for alloc
- INTEGER, DIMENSION(2) :: lda
- ! counters
- INTEGER :: k,i,j,n
- ! 1/ number of gridpoints
- REAL(MK) :: rN
- ! result array
-#if __DIM == __SFIELD
- INTEGER, PARAMETER :: lda_fv = 1
-#endif
-#if __DIM == __SFIELD
- COMPLEX(MK), DIMENSION(:,:,:), POINTER :: DATA_fv_com
- INTEGER , DIMENSION(3 ) :: lda_DATA_fv_com
-#elif __DIM == __VFIELD
- COMPLEX(MK), DIMENSION(:,:,:,:), POINTER :: DATA_fv_com
- INTEGER , DIMENSION(4 ) :: lda_DATA_fv_com
-#endif
- REAL(MK), DIMENSION(:,:), POINTER :: data_in
- COMPLEX(MK), DIMENSION(:,:), POINTER :: data_com
- COMPLEX(MK), DIMENSION(:,:), POINTER :: FFT_x, FFT_xy
- REAL(MK), DIMENSION(:,:), POINTER :: Result
- ! variables
- REAL(MK), DIMENSION(:,:),POINTER :: xp
- INTEGER :: Npart
- INTEGER :: decomp, assign
- REAL(MK), DIMENSION(2 ) :: min_phys, max_phys
- REAL(MK), DIMENSION(2 ) :: length
- REAL(MK), DIMENSION(2 ) :: length_phys
- INTEGER , DIMENSION(4 ) :: bcdef
- INTEGER :: nsubs,topo_id,mesh_id
- INTEGER :: mesh_id_xpen,mesh_id_ypen
- INTEGER :: mesh_id_xpen_complex
- REAL(MK), DIMENSION(: ), POINTER :: cost
- INTEGER , DIMENSION(:,:), POINTER :: istart, istart_xpen_complex
- INTEGER , DIMENSION(:,:), POINTER :: istart_ypen,istart_trans
- INTEGER , DIMENSION(:,:), POINTER :: ndata,ndata_xpen_complex
- INTEGER , DIMENSION(:,:), POINTER :: ndata_ypen,ndata_trans
- INTEGER , DIMENSION(ppm_dim) :: maxndata
- INTEGER , DIMENSION(ppm_dim) :: maxndata_ypen
- INTEGER , DIMENSION(ppm_dim) :: maxndata_zpen
- INTEGER , DIMENSION(: ), POINTER :: isublist => NULL()
- INTEGER :: nsublist
- INTEGER :: dim, yhmax,iopt,idom
- INTEGER :: topo_id_xpen,topo_id_ypen
- INTEGER, DIMENSION(2) :: topo_ids_tmp
- INTEGER, DIMENSION(3) :: mesh_ids_tmp
- INTEGER, DIMENSION(2) :: Nm,Nm_com,Nm_poisson
- LOGICAL :: Its_xpencil_topo
- CHARACTER(LEN=ppm_char) :: mesg
- TYPE(ppm_t_topo) , POINTER :: f_topo
- TYPE(ppm_t_equi_mesh) , POINTER :: f_mesh
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_solve_2d',t0,info)
-
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_fdsolver_solve_2d', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (field_topoid .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_solve_2d', &
- & 'No field topology has been defined so far',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
-
- f_topo => ppm_topo(field_topoid)%t
- f_mesh => f_topo%mesh(mesh_id_data)
- !-------------------------------------------------------------------------
- ! Check if FFTW-Library is available of if NEC Library
- !-------------------------------------------------------------------------
-#if !(defined(__FFTW) | defined(__MATHKEISAN))
- info = ppm_error_error
-#ifndef __FFTW
- CALL ppm_error(ppm_err_nofftw,'ppm_fdsolver_solve_2d', &
- & 'fdsolver needs FFTW Library ' ,__LINE__,info)
-#endif
-#ifndef __MATHKEISAN
- CALL ppm_error(ppm_err_noMathKeisan,'ppm_fdsolver_solve_2d', &
- & 'PPM was compiled without MATHKEISAN support',__LINE__,info)
-#endif
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Initialize variables
- !-------------------------------------------------------------------------
- dim = 1
- bcdef(1:4) = ppm_param_bcdef_freespace
- assign = ppm_param_assign_internal
- topo_ids_tmp = topo_ids
- mesh_ids_tmp = mesh_ids
- Nm(1) = f_mesh%Nm(1)
- Nm(2) = f_mesh%Nm(2)
- Nm_com(1) = Nm(1)/2+1
- Nm_com(2) = Nm(2)
- Npart = 0
-#if __KIND == __SINGLE_PRECISION
- min_phys(1) = f_topo%min_physs(1)
- min_phys(2) = f_topo%min_physs(2)
- max_phys(1) = f_topo%max_physs(1)
- max_phys(2) = f_topo%max_physs(2)
-#elif __KIND == __DOUBLE_PRECISION
- min_phys(1) = f_topo%min_physd(1)
- min_phys(2) = f_topo%min_physd(2)
- max_phys(1) = f_topo%max_physd(1)
- max_phys(2) = f_topo%max_physd(2)
-#endif
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A,2F15.3)' ) 'minimal extent', min_phys(1), min_phys(2)
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- WRITE(mesg,'(A,2F15.3)' ) 'maximal extent', max_phys(1), max_phys(2)
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- ENDIF
- length_phys(1) = max_phys(1) - min_phys(1)
- length_phys(2) = max_phys(2) - min_phys(2)
- !-------------------------------------------------------------------------
- ! Check if x_pencil topology
- !-------------------------------------------------------------------------
- Its_xpencil_topo = .TRUE.
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
-#if __KIND == __SINGLE_PRECISION
- length(1) = f_topo%max_subs(1,idom) - f_topo%min_subs(1,idom)
- IF( abs(length(1) - length_phys(1)).GT.(ppm_myepss) ) THEN
- Its_xpencil_topo=.FALSE.
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- length(1) = f_topo%max_subd(1,idom) - f_topo%min_subd(1,idom)
- IF( abs(length(1) - length_phys(1)).GT.(ppm_myepsd) ) THEN
- Its_xpencil_topo=.FALSE.
- ENDIF
-#endif
- ENDDO
- IF (ppm_debug .GT. 0) THEN
- IF(Its_xpencil_topo) THEN
- WRITE(mesg,'(A)' ) 'X pencil topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- ELSE
- WRITE(mesg,'(A)' ) 'Not X pencil topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Setting of x-pencil topology
- !-------------------------------------------------------------------------
- IF(Its_xpencil_topo) THEN
- topo_id_xpen = field_topoid
- mesh_id_xpen = mesh_id_data
- topo_ids_tmp(1) = topo_id_xpen
- topo_id_ypen = topo_ids_tmp(2)
- mesh_id_xpen_complex = mesh_ids_tmp(2)
- mesh_id_ypen = mesh_ids_tmp(1)
- ELSE
- topo_id_xpen = topo_ids_tmp(1)
- topo_id_ypen = topo_ids_tmp(2)
- mesh_id_xpen = mesh_ids_tmp(1)
- mesh_id_xpen_complex = mesh_ids_tmp(2)
- mesh_id_ypen = mesh_ids_tmp(3)
- ENDIF
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A)' ) ' ID topo mesh'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- WRITE(mesg,'(A)' ) '-----------------------------------'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Original ',field_topoid, mesh_id_data
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'X Pencil ', topo_id_xpen, mesh_id_xpen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'X Pencil Complex', topo_id_xpen, &
- & mesh_id_xpen_complex
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Y Pencil Complex', topo_id_ypen, mesh_id_ypen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve_2d',mesg,j)
- ENDIF
- !-------------------------------------------------------------------------
- ! Decompose domain in xpencils
- !-------------------------------------------------------------------------
- IF(.NOT.Its_xpencil_topo) THEN
- assign = ppm_param_assign_internal
- ! xpencils decomposition
- decomp = ppm_param_decomp_xpencil
- CALL ppm_mktopo(topo_id_xpen,mesh_id_xpen,xp,Npart,decomp,assign,&
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm, &
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_xpen,mesh_id_xpen,Nm,istart,ndata,&
- & maxndata,isublist,nsublist,info)
-
- topo_ids_tmp(1) = field_topoid
- topo_ids_tmp(2) = topo_id_xpen
- mesh_ids_tmp(1) = mesh_id_data
- mesh_ids_tmp(2) = mesh_id_xpen
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv, topo_ids_tmp, mesh_ids_tmp, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv,lda_fv, topo_ids_tmp, mesh_ids_tmp,info)
-#endif
- topo_ids_tmp(1) = topo_id_xpen
- topo_ids_tmp(2) = topo_id_ypen
- mesh_id_data = f_mesh%ID
- ENDIF
- !-------------------------------------------------------------------------
- ! Allocate complex array
- !-------------------------------------------------------------------------
- yhmax = 0
- DO i=1,f_topo%nsublist
- idom = f_topo%isublist(i)
- IF (f_mesh%nnodes(2,idom) .GT. yhmax) THEN
- yhmax = f_mesh%nnodes(2,idom)
- ENDIF
- ENDDO
-#if __DIM == __SFIELD
- lda_DATA_fv_com(1)= Nm_com(1)
- lda_DATA_fv_com(2)= yhmax
- lda_DATA_fv_com(3)= f_topo%nsublist
-#elif __DIM == __VFIELD
- lda_DATA_fv_com(1)= lda_fv
- lda_DATA_fv_com(2)= Nm_com(1)
- lda_DATA_fv_com(3)= yhmax
- lda_DATA_fv_com(4)= f_topo%nsublist
-#endif
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(DATA_fv_com, lda_DATA_fv_com, iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_2d', &
- & 'data array',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! FFT - Transformation in x-direction
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- lda(1)=2
- lda(2)=f_topo%nsubs
- CALL ppm_alloc(ndata,lda,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_2d', &
- & 'ndata array',__LINE__,info)
- GOTO 9999
- ENDIF
- ndata = f_mesh%nnodes
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
- CALL ppm_alloc(data_in, ndata(:,idom), ppm_param_alloc_fit, info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_2d', &
- & 'data_in array',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __VFIELD
- DO n=1,lda_fv
-#endif
- DO i=1, ndata(1,idom)
- DO j=1, ndata(2,idom)
-#if __DIM == __SFIELD
- data_in(i,j) = DATA_fv(i,j,k)
-#elif __DIM == __VFIELD
- data_in(i,j) = DATA_fv(n,i,j,k)
-#endif
- ENDDO
- ENDDO
-#if __CASE == __INIT
- CALL ppm_fdsolver_fft_fd( data_in, ndata(:,idom), FFT_x, info)
-#else
- CALL ppm_util_fft_forward( data_in, ndata(:,idom), FFT_x, info)
-#endif
- iopt = ppm_param_dealloc
- CALL ppm_alloc(data_in, ndata(:,idom), iopt, info)
- DO i=1, ndata(1,idom)
- DO j=1, ndata(2,idom)
-#if __DIM == __SFIELD
- DATA_fv_com(i,j,k) = FFT_x(i,j)
-#elif __DIM == __VFIELD
- DATA_fv_com(n,i,j,k) = FFT_x(i,j)
-#endif
- ENDDO
- ENDDO
- ENDDO
-#if __DIM == __VFIELD
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Decompose complex domain in xpencils
- !-------------------------------------------------------------------------
- CALL ppm_mesh_define(topo_id_xpen,mesh_id_xpen_complex,Nm_com, &
- & istart_xpen_complex,ndata_xpen_complex,info)
- !-------------------------------------------------------------------------
- ! Decompose domain in ypencils
- !-------------------------------------------------------------------------
- decomp = ppm_param_decomp_ypencil
- CALL ppm_mktopo(topo_id_ypen,mesh_id_ypen,xp,Npart,decomp,assign, &
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm,&
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_ypen,mesh_id_ypen,Nm,istart_ypen,ndata,&
- & maxndata,isublist,nsublist,info)
-
-
- !-------------------------------------------------------------------------
- ! Transpose x-direction and y-direction
- !-------------------------------------------------------------------------
- mesh_ids_tmp(1) = mesh_id_xpen_complex
- mesh_ids_tmp(2) = mesh_id_ypen
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,topo_ids_tmp, mesh_ids_tmp, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,lda_fv, topo_ids_tmp, mesh_ids_tmp, info)
-#endif
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
- lda(1)=2
- lda(2)=idom
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(ndata_trans,lda,iopt, info)
- ndata_trans(1,idom)=ndata(2,idom)
- ndata_trans(2,idom)=ndata(1,idom)
- CALL ppm_alloc(data_com,ndata_trans(:,idom),iopt, info)
-#if __DIM == __VFIELD
- DO n=1,lda_fv
-#endif
- DO i=1, ndata(1,idom)
- DO j=1, ndata(2,idom)
-#if __DIM == __SFIELD
- data_com(j,i)= DATA_fv_com(i,j,k)
-#elif __DIM == __VFIELD
- data_com(j,i)= DATA_fv_com(n,i,j,k)
-#endif
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! FFT - Transformation in y-direction
- !-------------------------------------------------------------------------
-#if __CASE == __INIT
- CALL ppm_fdsolver_fft_fd(data_com,ndata_trans(:,idom),FFT_xy,info)
-#else
- CALL ppm_util_fft_forward(data_com,ndata_trans(:,idom),FFT_xy,info)
-#endif
- iopt = ppm_param_dealloc
- CALL ppm_alloc(data_com,ndata_trans(:,idom),iopt, info)
- !-------------------------------------------------------------------------
- ! Solve Poisson Equation
- !-------------------------------------------------------------------------
- ! transpose istart and physical length
- lda(1)=2
- lda(2)=idom
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(istart,lda,iopt,info)
- istart(1,idom)=istart_ypen(2,idom)
- istart(2,idom)=istart_ypen(1,idom)
- length(1) = length_phys(2)
- length(2) = length_phys(1)
- Nm_poisson(1) = Nm_com(2)-1 ! corrected by -1 for ppm convention
- Nm_poisson(2) = Nm_com(1)
- CALL ppm_fdsolver_poisson(FFT_xy, ndata_trans(1:2,idom), &
- & istart(1:2,idom),length,Nm_poisson, info)
- iopt = ppm_param_dealloc
- CALL ppm_alloc(istart,lda,iopt,info)
- !-------------------------------------------------------------------------
- ! FFT - Backward Transformation in y-direction
- !-------------------------------------------------------------------------
-#if __CASE == __INIT
- CALL ppm_fdsolver_fft_bd(FFT_xy, ndata_trans(:,idom), data_com,info)
-#else
- CALL ppm_util_fft_backward(FFT_xy, ndata_trans(:,idom), data_com,info)
-#endif
- !-------------------------------------------------------------------------
- ! Transpose y-direction and x-direction
- !-------------------------------------------------------------------------
- DO i=1, ndata(1,idom)
- DO j=1, ndata(2,idom)
-#if __DIM == __SFIELD
- DATA_fv_com(i,j,k) = data_com(j,i)
-#elif __DIM == __VFIELD
- DATA_fv_com(n,i,j,k) = data_com(j,i)
-#endif
- ENDDO
- ENDDO
-#if __DIM == __VFIELD
- ENDDO
-#endif
- iopt = ppm_param_dealloc
- CALL ppm_alloc(data_com, lda, iopt,info)
- ENDDO ! end of do loop over k=1,f_topo%nsublist
- topo_id = topo_ids_tmp(1)
- topo_ids_tmp(1)= topo_ids_tmp(2)
- topo_ids_tmp(2)= topo_id
- mesh_id = mesh_ids_tmp(1)
- mesh_ids_tmp(1)= mesh_ids_tmp(2)
- mesh_ids_tmp(2)= mesh_id
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,topo_ids_tmp, mesh_ids_tmp, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,lda_fv,topo_ids_tmp, mesh_ids_tmp, info)
-#endif
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
-#if __DIM == __VFIELD
- DO n=1, lda_fv
-#endif
- DO i=1, ndata_xpen_complex(1,idom)
- DO j=1, ndata_xpen_complex(2,idom)
-#if __DIM == __SFIELD
- FFT_x(i,j)= DATA_fv_com(i,j,k)
-#elif __DIM == __VFIELD
- FFT_x(i,j)= DATA_fv_com(n,i,j,k)
-#endif
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! FFT - Backward Transformation in y-direction
- !-------------------------------------------------------------------------
-#if __CASE == __INIT
- CALL ppm_fdsolver_fft_bd(FFT_x,ndata_xpen_complex(:,idom),Result,info)
-#else
- CALL ppm_util_fft_backward(FFT_x,ndata_xpen_complex(:,idom),Result,info)
-#endif
- !-------------------------------------------------------------------------
- ! Correct Inverse by problem size factor 1/(Nx*Ny)
- ! Subtract 1 to fit ppm convention
- !-------------------------------------------------------------------------
- rN = 1/dble((Nm(1)-1)*(Nm(2)-1))
- DO i=1,ndata_xpen_complex(1,idom)
- DO j=1,ndata_xpen_complex(2,idom)
-#if __DIM == __SFIELD
- DATA_fv(i,j,k)= Result(i,j)*rN
-#elif __DIM == __VFIELD
- DATA_fv(n,i,j,k)= Result(i,j)*rN
-#endif
- ENDDO
- ENDDO
-#if __DIM == __VFIELD
- ENDDO
-#endif
- ENDDO ! end of do loop k=1,f_topo%nsublist
- !-------------------------------------------------------------------------
- ! Map to original topology if not x-pencil topology
- !-------------------------------------------------------------------------
- IF(.NOT.Its_xpencil_topo) THEN
- topo_ids_tmp(1) = topo_ids_tmp(2)
- topo_ids_tmp(2) = field_topoid
- mesh_ids_tmp(1) = mesh_id_xpen
- mesh_ids_tmp(2) = mesh_id_data
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv, topo_ids_tmp, mesh_ids_tmp, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv, lda_fv, topo_ids_tmp, mesh_ids_tmp, info)
-#endif
- ENDIF
- !-------------------------------------------------------------------------
- ! Deallocate memory
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(DATA_fv_com, lda_DATA_fv_com, iopt,info)
- CALL ppm_alloc(ndata,lda,iopt,info)
- CALL ppm_alloc(ndata_trans,lda,iopt, info)
- CALL ppm_alloc(data_in,lda,iopt, info)
- CALL ppm_alloc(FFT_x,lda,iopt, info)
- CALL ppm_alloc(FFT_xy,lda,iopt, info)
- CALL ppm_alloc(cost,lda,iopt, info)
- CALL ppm_alloc(istart,lda,iopt, info)
- CALL ppm_alloc(istart_xpen_complex,lda,iopt, info)
- CALL ppm_alloc(istart_ypen,lda,iopt, info)
- CALL ppm_alloc(istart_trans,lda,iopt, info)
- CALL ppm_alloc(ndata,lda,iopt, info)
- CALL ppm_alloc(ndata_xpen_complex,lda,iopt, info)
- CALL ppm_alloc(ndata_ypen,lda,iopt, info)
- CALL ppm_alloc(ndata_trans,lda,iopt, info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_solve_2d',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_solve_2d',t0,info)
- RETURN
-
-#if __CASE == __INIT
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_init_2d_ss
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_init_2d_sd
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_init_2d_vs
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_init_2d_vd
-#endif
-#endif
-#else
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_2d_ss
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_2d_sd
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_2d_vs
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_2d_vd
-#endif
-#endif
-#endif
diff --git a/src/ppm_fdsolver_solve_3d.f b/src/ppm_fdsolver_solve_3d.f
deleted file mode 100644
index bbc11b64668f1d749b1e50d862fbcd6fedc1427b..0000000000000000000000000000000000000000
--- a/src/ppm_fdsolver_solve_3d.f
+++ /dev/null
@@ -1,1242 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fdsolver_solve_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Poisson solver using FFTW
- ! Solves the negative poisson equation in a 3-dimensional
- ! periodic domain:
- ! - Laplacian of Phi = omega
- ! It takes the field quantity omega in DATA_fv which is
- ! assumed to be periodic outside the domain. The most
- ! efficient initial topology for the fieldsolver is
- ! a x-pencil topology. After performing a FFT on the
- ! x-pencils the data is mapped onto y-pencils and
- ! later onto z-pencils.
- ! The version solve_init is based on recomputed FFT-plans
- ! created in ppm_fdsolver_init and destroyed in
- ! ppm_fdsolver_finalize.
- ! In the slab version (solve_slab) the FFTs are performed
- ! on xy slabs and on z-penzils to save field mappings.
- ! This version requires the call of ppm_fdsolver_init and
- ! ppm_fdsolver_finalize.
- ! The poisson equation is solved in the Fourier space
- ! and the result transformed backward.
- ! The solution Phi is finally returned in DATA_fv.
- ! Note: field quantity must live on current topology
- !
- ! Usage:
- !
- ! ppm_fdsolver_init(arguments)
- !
- ! ppm_fdsolver_solve_init(arguments)
- ! or ppm_fdsolver_solve_slab(arguments)
- !
- ! ppm_fdsolver_finalize(info)
- !
- !
- ! Standalone Usage:
- !
- ! ppm_fdsolver_solve(arguments)
- !
- ! Input :
- ! lda_fv (I) size of leading dimension in VectorCase
- ! mesh_id_data(I) mesh ID of the current data field mesh
- ! topo_ids(2) (I) topology IDs on which the FFTs are
- ! performed
- ! topo_ids(1) first topology in
- ! solve: xpencils
- ! solve_init: xpencils
- ! solve_slab: xy slab
- ! topo_ids(2) second topology in
- ! solve: ypencils
- ! solve_init: ypencils
- ! solve_slab: zpencils
- ! topo_ids(3) third topology in
- ! solve: zpencils
- ! solve_init: xpencils
- ! solve_slab: not used
- !
- ! mesh_ids(3) (I) mesh IDs where the FFTs are performed
- ! mesh_ids(1) first mesh
- ! solve: xpencils,real
- ! solve_init: xpencils,real
- ! solve_slab: xy slab ,real
- ! mesh_ids(2) second mesh
- ! solve: xpencils,complex
- ! solve_init: xpencils,complex
- ! solve_slab: xy slab ,complex
- ! mesh_ids(3) third mesh
- ! solve: ypencils,complex
- ! solve_init: ypencils,complex
- ! solve_slab: zpencils,complex
- ! mesh_ids(4) forth mesh
- ! solve: zpencils,complex
- ! solve_init: zpencils,complex
- ! solve_slab: not used
- ! ghostsize(3) (I)ghostsize
- !
- !
- ! Input/output :
- ! DATA_fv(:,:,:,:) (F) field data
- !
- ! Output : info (I) return status. =0 if no error.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fdsolver_solve_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.28 2006/09/04 18:34:45 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.26 2006/04/10 08:54:30 pchatela
- ! Made xp a REAL, DIMENSION(:,:), POINTER to get rid of warnings
- !
- ! Revision 1.25 2006/04/07 17:41:29 hiebers
- ! Changed type of variable xp to POINTER
- !
- ! Revision 1.24 2005/08/23 15:23:12 hiebers
- ! Bugfix in scalar version by adjusting an argument in the call
- ! of the FFT routines
- !
- ! Revision 1.23 2005/08/03 14:35:12 ivos
- ! Shortened the subrountine names to meet the F90 31-character limit
- ! standard. pgf90 on gonzales had problems...
- !
- ! Revision 1.22 2005/02/16 12:38:20 hiebers
- ! bugfix in preprocessor if statement
- !
- ! Revision 1.21 2005/02/16 12:01:07 hiebers
- ! Major addition: finalized scalar and vector version,
- ! implemented version <solve_init> that uses FFT plans created
- ! in ppm_fdsolver_init and destroyed in ppm_fdsolver_finalize
- ! whereas the version <solve> remains a standalone solver,
- ! implemented version <solve_slab> that uses xy-slab topology
- ! and z-pencil topology (needs ppm_fdsolver_init and finalize)
- !
- ! Revision 1.20 2005/02/01 16:38:56 hiebers
- ! reduced size of DATA_fv_com
- !
- ! Revision 1.19 2004/11/03 11:14:55 hiebers
- ! Exchanged __SXF90 by __MATHKEISAN
- !
- ! Revision 1.18 2004/10/01 16:08:59 ivos
- ! Replaced REAL(ppm_kind_double) :: t0 with REAL(MK) t0.
- !
- ! Revision 1.17 2004/08/27 09:45:15 hiebers
- ! added ghostsize as an argument
- !
- ! Revision 1.16 2004/08/26 10:45:52 hiebers
- ! eliminated correction of the field margin. correction is now done in
- ! the fft routines.
- !
- ! Revision 1.9 2004/08/19 13:14:28 hiebers
- ! debugged scalar/vector version
- !
- ! Revision 1.8 2004/08/18 16:32:43 hiebers
- ! intermediate status of debugging vector version
- !
- ! Revision 1.7 2004/08/18 13:35:33 hiebers
- ! bug fix for non xpencil-topology version
- !
- ! Revision 1.3 2004/07/26 15:38:47 ivos
- ! Inserted missing USE statements to resolve undefined references
- ! at link stage.
- !
- ! Revision 1.2 2004/07/26 11:59:38 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.1 2004/07/26 08:52:29 hiebers
- ! Recommited, formerly ppm_module_fieldsolver
- !
- ! Revision 1.1 2004/05/19 15:32:46 hiebers
- ! implementation from scratch
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __CASE == __SLAB
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_slab_3d_ss(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_slab_3d_sd(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize,info)
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_slab_3d_vs(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_slab_3d_vd(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#endif
-#endif
-#elif __CASE == __INIT
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_init_3d_ss(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_init_3d_sd(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize,info)
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_init_3d_vs(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_init_3d_vd(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#endif
-#endif
-#else
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_3d_ss(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_3d_sd(DATA_fv,mesh_id_data,topo_ids, &
- & field_topoid,mesh_ids,ghostsize,info)
-#endif
-#endif
-
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_3d_vs(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fdsolver_solve_3d_vd(DATA_fv,lda_fv,mesh_id_data, &
- & field_topoid,topo_ids,mesh_ids,ghostsize,info)
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
-
- USE ppm_module_mktopo
- USE ppm_module_mesh_define
- USE ppm_module_fdsolver_map
- USE ppm_module_util_fft_forward
- USE ppm_module_util_fft_backward
- USE ppm_module_fdsolver_poisson
- USE ppm_module_fdsolver_fft_fd
- USE ppm_module_fdsolver_fft_bd
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_substop
-
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- ! data
-#if __DIM == __SFIELD
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: DATA_fv
-#elif __DIM == __VFIELD
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: DATA_fv
-#endif
- ! mesh ID of the data
- ! Note F.Perignon: I remove the INTENT(IN) for mesh_id_data to make the lib work, but I guess its
- ! not a proper solution ...
- INTEGER :: mesh_id_data
- ! topo ID of the field
- INTEGER , INTENT(IN) :: field_topoid
-
-#if __DIM == __VFIELD
- INTEGER , INTENT(IN) :: lda_fv
-#endif
- ! topo / mesh ID for the mapping
- INTEGER, DIMENSION(3) , INTENT(IN ) :: topo_ids
- INTEGER, DIMENSION(4) , INTENT(IN ) :: mesh_ids
- INTEGER, DIMENSION(3) , INTENT(IN ) :: ghostsize
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! timer
- REAL(MK) :: t0
- ! parameter for alloc
- INTEGER, DIMENSION(3) :: lda
- ! counters
- INTEGER :: i,j,k,l,m
- INTEGER :: ires, jres, lres
- ! 1/number of gridpoints
- REAL(MK) :: rN
- ! result
-#if __DIM == __SFIELD
- INTEGER, PARAMETER :: lda_fv = 1
-#endif
-#if __DIM == __SFIELD
- INTEGER , DIMENSION(4 ) :: lda_DATA_fv
- COMPLEX(MK), DIMENSION(:,:,:,:), POINTER :: DATA_fv_com
- INTEGER , DIMENSION(4 ) :: lda_DATA_fv_com
-#elif __DIM == __VFIELD
- INTEGER , DIMENSION(5 ) :: lda_DATA_fv
- COMPLEX(MK), DIMENSION(:,:,:,:,:), POINTER :: DATA_fv_com
- INTEGER , DIMENSION(5 ) :: lda_DATA_fv_com
-#endif
- INTEGER, DIMENSION(2) :: topo_ids_tmp
- INTEGER, DIMENSION(2) :: mesh_ids_tmp
- REAL(MK), DIMENSION(:,:,:), POINTER :: data_in
- COMPLEX(MK), DIMENSION(:,:,:), POINTER :: data_com
- COMPLEX(MK), DIMENSION(:,:,:), POINTER :: FFT_x, FFT_xy, FFT_xyz
- REAL(MK), DIMENSION(:,:,:), POINTER :: Result
- ! variables
- REAL(MK), DIMENSION(:,:),POINTER :: xp
- INTEGER :: Npart
- INTEGER :: decomp, assign
- REAL(MK), DIMENSION(3 ) :: min_phys, max_phys
- REAL(MK), DIMENSION(3 ) :: length
- REAL(MK), DIMENSION(3 ) :: length_phys
- INTEGER , DIMENSION(6 ) :: bcdef
- INTEGER :: nsubs,topo_id, mesh_id
- INTEGER :: yhmax, zhmax
- INTEGER :: mesh_id_xpen, mesh_id_ypen
- INTEGER :: mesh_id_xpen_complex
- INTEGER :: mesh_id_zpen
- REAL(MK), DIMENSION(: ), POINTER :: cost
- INTEGER , DIMENSION(:,:), POINTER :: istart, istart_xpen_complex
- INTEGER , DIMENSION(:,:), POINTER :: istart_ypen, istart_trans
- INTEGER , DIMENSION(:,:), POINTER :: istart_zpen
- INTEGER , DIMENSION(:,:), POINTER :: ndata, ndata_xpen_complex
- INTEGER , DIMENSION(:,:), POINTER :: ndata_ypen, ndata_trans
- INTEGER , DIMENSION(:,:), POINTER :: ndata_zpen
- INTEGER , DIMENSION(ppm_dim) :: maxndata
- INTEGER , DIMENSION(ppm_dim) :: maxndata_ypen
- INTEGER , DIMENSION(ppm_dim) :: maxndata_zpen
- INTEGER , DIMENSION(: ), POINTER :: isublist => NULL()
- INTEGER :: nsublist
- INTEGER :: dim,n,idom
- INTEGER :: iopt
- INTEGER :: topo_id_xpen, topo_id_ypen
- INTEGER :: topo_id_zpen
- INTEGER, DIMENSION(3) :: Nm, Nm_com, Nm_poisson
- LOGICAL :: Its_xpencil_topo
- LOGICAL :: Its_xyslab_topo
- CHARACTER(LEN=ppm_char) :: mesg
- TYPE(ppm_t_topo) , POINTER :: f_topo
- TYPE(ppm_t_equi_mesh) , POINTER :: f_mesh
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fdsolver_solve_3d',t0,info)
- f_topo => ppm_topo(field_topoid)%t
- f_mesh => f_topo%mesh(mesh_id_data)
-
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_fdsolver_solve_3d', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (field_topoid .LE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fdsolver_solve_3d', &
- & 'No field topology has been defined so far',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
-#if !(defined(__FFTW) | defined(__MATHKEISAN))
-
- !-------------------------------------------------------------------------
- ! Error if FFTW library or NEC is not available
- !-------------------------------------------------------------------------
- info = ppm_error_error
-#ifndef __FFTW
- CALL ppm_error(ppm_err_nofftw,'ppm_fdsolver_solve_3d', &
- & 'PPM was compiled without fftw support',__LINE__,info)
-#endif
-
-#ifndef __MATHKEISAN
- CALL ppm_error(ppm_err_noMathKeisan,'ppm_fdsolver_solve_3d', &
- & 'PPM was compiled without MATHKEISAN support',__LINE__,info)
-#endif
-
- GOTO 9999
-#else
- !-------------------------------------------------------------------------
- ! Initialize variables
- !-------------------------------------------------------------------------
- bcdef(1:6) = ppm_param_bcdef_periodic
- assign = ppm_param_assign_internal
- Nm(1) = f_mesh%Nm(1)
- Nm(2) = f_mesh%Nm(2)
- Nm(3) = f_mesh%Nm(3)
- Nm_com(1) = Nm(1)/2+1
- Nm_com(2) = Nm(2)
- Nm_com(3) = Nm(3)
- Npart = 0
-#if __KIND == __SINGLE_PRECISION
- min_phys(1) = f_topo%min_physs(1)
- min_phys(2) = f_topo%min_physs(2)
- min_phys(3) = f_topo%min_physs(3)
- max_phys(1) = f_topo%max_physs(1)
- max_phys(2) = f_topo%max_physs(2)
- max_phys(3) = f_topo%max_physs(3)
-#elif __KIND == __DOUBLE_PRECISION
- min_phys(1) = f_topo%min_physd(1)
- min_phys(2) = f_topo%min_physd(2)
- min_phys(3) = f_topo%min_physd(3)
- max_phys(1) = f_topo%max_physd(1)
- max_phys(2) = f_topo%max_physd(2)
- max_phys(3) = f_topo%max_physd(3)
-#endif
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A,3F15.3)' ) 'minimal extent', min_phys(1), min_phys(2), &
- & min_phys(3)
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,3F15.3)' ) 'maximal extent', max_phys(1), max_phys(2), &
- & max_phys(3)
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- ENDIF
- length_phys(1) = max_phys(1) - min_phys(1)
- length_phys(2) = max_phys(2) - min_phys(2)
- length_phys(3) = max_phys(3) - min_phys(3)
- !-------------------------------------------------------------------------
- ! Check if x_pencil topology
- !-------------------------------------------------------------------------
- Its_xpencil_topo = .TRUE.
- Its_xyslab_topo = .TRUE.
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
-#if __KIND == __SINGLE_PRECISION
- length(1) = f_topo%max_subs(1,idom) - f_topo%min_subs(1,idom)
- length(2) = f_topo%max_subs(2,idom) - f_topo%min_subs(2,idom)
- IF( abs(length(1) - length_phys(1)).GT.(ppm_myepss) ) THEN
- Its_xpencil_topo=.FALSE.
- Its_xyslab_topo =.FALSE.
- ENDIF
- IF( abs(length(2) - length_phys(2)).GT.(ppm_myepss) ) THEN
- Its_xyslab_topo =.FALSE.
- ENDIF
-#elif __KIND == __DOUBLE_PRECISION
- length(1) = f_topo%max_subd(1,idom) - f_topo%min_subd(1,idom)
- length(2) = f_topo%max_subd(2,idom) - f_topo%min_subd(2,idom)
- IF( abs(length(1) - length_phys(1)).GT.(ppm_myepsd) ) THEN
- Its_xpencil_topo=.FALSE.
- Its_xyslab_topo =.FALSE.
- ENDIF
- IF( abs(length(2) - length_phys(2)).GT.(ppm_myepsd) ) THEN
- Its_xyslab_topo =.FALSE.
- ENDIF
-#endif
- ENDDO
- IF (ppm_debug .GT. 0) THEN
- IF(Its_xyslab_topo) THEN
- WRITE(mesg,'(A)' ) 'XY slab topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- ELSE
- WRITE(mesg,'(A)' ) 'Not XY slab topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- ENDIF
- IF(Its_xpencil_topo) THEN
- WRITE(mesg,'(A)' ) 'X pencil topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- ELSE
- WRITE(mesg,'(A)' ) 'Not X pencil topology'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- ENDIF
- ENDIF
-#if __CASE == __SLAB
- !-------------------------------------------------------------------------
- ! Setting of xy slab topology
- !-------------------------------------------------------------------------
- IF(Its_xyslab_topo) THEN
- topo_id_xpen = field_topoid
- mesh_id_xpen = mesh_id_data
- topo_id_zpen = topo_ids(2)
- mesh_id_xpen_complex = mesh_ids(2)
- mesh_id_zpen = mesh_ids(3)
- ELSE
- topo_id_xpen = topo_ids(1)
- topo_id_zpen = topo_ids(2)
- mesh_id_xpen = mesh_ids(1)
- mesh_id_xpen_complex = mesh_ids(2)
- mesh_id_zpen = mesh_ids(3)
- ENDIF
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A)' ) ' ID topo mesh'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A)' ) '-----------------------------------'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Original ',field_topoid, mesh_id_data
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'XZ Slab ', topo_id_xpen, mesh_id_xpen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'XZ Slab Complex', topo_id_xpen, &
- & mesh_id_xpen_complex
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Z Pencil Complex', topo_id_zpen, mesh_id_zpen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- ENDIF
- !-------------------------------------------------------------------------
- ! Decompose domain in xy slabs
- !-------------------------------------------------------------------------
- IF(.NOT.Its_xyslab_topo) THEN
- assign = ppm_param_assign_internal
- decomp = ppm_param_decomp_xy_slab
- CALL ppm_mktopo(topo_id_xpen,mesh_id_xpen,xp,Npart,decomp,assign,&
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm, &
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_xpen,mesh_id_xpen,Nm,istart,ndata,&
- & maxndata,isublist,nsublist,info)
- topo_ids_tmp(1) = field_topoid
- topo_ids_tmp(2) = topo_id_xpen
- mesh_ids_tmp(1) = mesh_id_data
- mesh_ids_tmp(2) = mesh_id_xpen
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv,lda_fv, topo_ids_tmp, mesh_ids_tmp,&
- & ghostsize, info)
-#endif
- topo_ids_tmp(1) = topo_id_xpen
- topo_ids_tmp(2) = topo_id_zpen
- mesh_id_data = f_mesh%ID
- ENDIF
-#else
- !-------------------------------------------------------------------------
- ! Setting of x-pencil topology
- !-------------------------------------------------------------------------
- IF(Its_xpencil_topo) THEN
- topo_id_xpen = field_topoid
- mesh_id_xpen = mesh_id_data
- topo_id_ypen = topo_ids(2)
- topo_id_zpen = topo_ids(3)
- mesh_id_xpen_complex = mesh_ids(2)
- mesh_id_ypen = mesh_ids(3)
- mesh_id_zpen = mesh_ids(4)
- ELSE
- topo_id_xpen = topo_ids(1)
- topo_id_ypen = topo_ids(2)
- topo_id_zpen = topo_ids(3)
- mesh_id_xpen = mesh_ids(1)
- mesh_id_xpen_complex = mesh_ids(2)
- mesh_id_ypen = mesh_ids(3)
- mesh_id_zpen = mesh_ids(4)
- ENDIF
- IF (ppm_debug .GT. 0) THEN
- WRITE(mesg,'(A)' ) ' ID topo mesh'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A)' ) '-----------------------------------'
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Original ',field_topoid, mesh_id_data
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'X Pencil ', topo_id_xpen, mesh_id_xpen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'X Pencil Complex', topo_id_xpen, &
- & mesh_id_xpen_complex
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Y Pencil Complex', topo_id_ypen, mesh_id_ypen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- WRITE(mesg,'(A,2I4)' ) 'Z Pencil Complex', topo_id_zpen, mesh_id_zpen
- CALL ppm_write(ppm_rank,'ppm_fdsolver_solve',mesg,j)
- ENDIF
- !-------------------------------------------------------------------------
- ! Decompose domain in xpencils
- !-------------------------------------------------------------------------
- IF(.NOT.Its_xpencil_topo) THEN
- assign = ppm_param_assign_internal
- decomp = ppm_param_decomp_xpencil
- CALL ppm_mktopo(topo_id_xpen,mesh_id_xpen,xp,Npart,decomp,assign,&
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm, &
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_xpen,mesh_id_xpen,Nm,istart,ndata,&
- & maxndata,isublist,nsublist,info)
- topo_ids_tmp(1) = field_topoid
- topo_ids_tmp(2) = topo_id_xpen
- mesh_ids_tmp(1) = mesh_id_data
- mesh_ids_tmp(2) = mesh_id_xpen
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv,lda_fv, topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#endif
- topo_ids_tmp(1) = topo_id_xpen
- topo_ids_tmp(2) = topo_id_ypen
- mesh_id_data = f_topo%mesh(mesh_id_xpen)%ID
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Allocate complex array
- !-------------------------------------------------------------------------
- yhmax = 0
- zhmax = 0
- DO i=1,f_topo%nsublist
- idom = f_topo%isublist(i)
- IF (f_mesh%nnodes(2,idom) .GT. yhmax) THEN
- yhmax = f_mesh%nnodes(2,idom)
- ENDIF
- IF (f_mesh%nnodes(3,idom) .GT. zhmax) THEN
- zhmax = f_mesh%nnodes(3,idom)
- ENDIF
- ENDDO
-#if __DIM == __SFIELD
- lda_DATA_fv_com(1)= Nm_com(1)
- lda_DATA_fv_com(2)= yhmax
- lda_DATA_fv_com(3)= zhmax
- lda_DATA_fv_com(4)= f_topo%nsublist
-#elif __DIM == __VFIELD
- lda_DATA_fv_com(1)= lda_fv
- lda_DATA_fv_com(2)= Nm_com(1)
- lda_DATA_fv_com(3)= yhmax
- lda_DATA_fv_com(4)= zhmax
- lda_DATA_fv_com(5)= f_topo%nsublist
-#endif
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(DATA_fv_com, lda_DATA_fv_com, iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_3d', &
- & 'data array',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! FFT - Transformation in x-direction
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- lda(1)=3
- lda(2)=f_topo%nsubs
- CALL ppm_alloc(ndata,lda,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_3d', &
- & 'ndata array',__LINE__,info)
- GOTO 9999
- ENDIF
- ndata = f_mesh%nnodes
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
- CALL ppm_alloc(data_in, ndata(:,idom), iopt, info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_3d', &
- & 'data_in array',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __SFIELD
- DO l=1, ndata(3,idom)
- DO j=1, ndata(2,idom)
- DO i=1, ndata(1,idom)
- data_in(i,j,l) = DATA_fv(i,j,l,k)
- ENDDO
- ENDDO
- ENDDO
- lda = ndata(:,idom)
-#if __CASE == __SLAB
- CALL ppm_fdsolver_fft_fd_slab(data_in, lda,FFT_x,info)
-#elif __CASE == __INIT
- CALL ppm_fdsolver_fft_fd(data_in, lda,FFT_x,info)
-#else
- CALL ppm_util_fft_forward(data_in, lda,FFT_x,info)
-#endif
- DO l=1, lda(3)
- DO j=1, lda(2)
- DO i=1, lda(1)
- DATA_fv_com(i,j,l,k) = FFT_x(i,j,l)
- ENDDO
- ENDDO
- ENDDO
- iopt = ppm_param_dealloc
- CALL ppm_alloc(FFT_x, ndata(:,idom), iopt, info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_solve',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#elif __DIM == __VFIELD
- DO n=1,lda_fv
- DO l=1, ndata(3,idom)
- DO j=1, ndata(2,idom)
- DO i=1, ndata(1,idom)
- data_in(i,j,l) = DATA_fv(n,i,j,l,k)
- ENDDO
- ENDDO
- ENDDO
- lda = ndata(:,idom)
-#if __CASE == __SLAB
- CALL ppm_fdsolver_fft_fd_slab(data_in, lda,FFT_x,info)
-#elif __CASE == __INIT
- CALL ppm_fdsolver_fft_fd(data_in, lda,FFT_x,info)
-#else
- CALL ppm_util_fft_forward(data_in, lda,FFT_x,info)
-#endif
- DO l=1, lda(3)
- DO j=1, lda(2)
- DO i=1, lda(1)
- DATA_fv_com(n,i,j,l,k) = FFT_x(i,j,l)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- iopt = ppm_param_dealloc
- CALL ppm_alloc(data_in, ndata(:,idom), iopt, info)
- CALL ppm_alloc(FFT_x, ndata(:,idom), iopt, info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_solve_3d',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#endif
- ENDDO
- !-------------------------------------------------------------------------
- ! Decompose complex domain in xpencils
- !-------------------------------------------------------------------------
- CALL ppm_mesh_define(topo_id_xpen,mesh_id_xpen_complex,Nm_com, &
- & istart_xpen_complex, ndata_xpen_complex, info)
- !-------------------------------------------------------------------------
- ! Decompose domain in ypencils
- !-------------------------------------------------------------------------
- decomp = ppm_param_decomp_ypencil
- CALL ppm_mktopo(topo_id_ypen,mesh_id_ypen,xp,Npart,decomp,assign, &
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm,&
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_ypen,mesh_id_ypen,Nm,istart_ypen,ndata_ypen,&
- & maxndata_ypen,isublist,nsublist,info)
- idom = f_topo%isublist(1)
- !-------------------------------------------------------------------------
- ! Decompose domain in zpencils
- !-------------------------------------------------------------------------
- decomp = ppm_param_decomp_zpencil
- CALL ppm_mktopo(topo_id_zpen,mesh_id_zpen,xp,Npart,decomp,assign, &
- & min_phys,max_phys,bcdef,ghostsize,cost,Nm,&
- & info,nsubs)
- CALL ppm_meshinfo(topo_id_zpen,mesh_id_zpen,Nm,istart_zpen,ndata_zpen,&
- & maxndata_zpen,isublist,nsublist,info)
- idom = f_topo%isublist(1)
-#if __CASE == __SLAB
- GOTO 1000
-#endif
- !-------------------------------------------------------------------------
- ! Transpose x-direction and y-direction
- !-------------------------------------------------------------------------
- topo_ids_tmp(1) = topo_id_xpen
- topo_ids_tmp(2) = topo_id_ypen
- mesh_ids_tmp(1) = mesh_id_xpen_complex
- mesh_ids_tmp(2) = mesh_id_ypen
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,lda_fv,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#endif
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
- lda(1)=3
- lda(2)=idom
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(ndata_trans,lda,iopt, info)
- ndata_trans(1,idom)=ndata_ypen(2,idom)
- ndata_trans(2,idom)=ndata_ypen(1,idom)
- ndata_trans(3,idom)=ndata_ypen(3,idom)
-#if __DIM == __VFIELD
- DO n=1,lda_fv
-#endif
- CALL ppm_alloc(data_com,ndata_trans(:,idom),iopt, info)
- DO l=1, ndata_ypen(3,idom)
- DO j=1, ndata_ypen(2,idom)
- DO i=1, ndata_ypen(1,idom)
-#if __DIM == __SFIELD
- data_com(j,i,l)= DATA_fv_com(i,j,l,k)
-#elif __DIM == __VFIELD
- data_com(j,i,l)= DATA_fv_com(n,i,j,l,k)
-#endif
- ENDDO
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! FFT - Transformation in y-direction
- !-------------------------------------------------------------------------
-#if __CASE == __INIT
- CALL ppm_fdsolver_fft_fd(data_com,ndata_trans(:,idom),FFT_xy,info)
-#else
- CALL ppm_util_fft_forward(data_com,ndata_trans(:,idom),FFT_xy,info)
-#endif
- !-------------------------------------------------------------------------
- ! Transpose back x-direction and y-direction
- !-------------------------------------------------------------------------
- DO l=1, ndata_ypen(3,idom)
- DO i=1, ndata_ypen(1,idom)
- DO j=1, ndata_ypen(2,idom)
-#if __DIM == __SFIELD
- DATA_fv_com(i,j,l,k) = FFT_xy(j,i,l)
-#elif __DIM == __VFIELD
- DATA_fv_com(n,i,j,l,k) = FFT_xy(j,i,l)
-#endif
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- iopt = ppm_param_dealloc
- CALL ppm_alloc(data_com,ndata_trans(:,idom),iopt, info)
- CALL ppm_alloc(FFT_xy, ndata_trans(:,idom),iopt, info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_solve_3d',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#if __DIM == __VFIELD
- ENDDO
-#endif
- 1000 CONTINUE! CASE SLAB continues
- !-------------------------------------------------------------------------
- ! Transpose x-direction and z-direction
- !-------------------------------------------------------------------------
- topo_ids_tmp(1) = topo_id_ypen
- topo_ids_tmp(2) = topo_id_zpen
- mesh_ids_tmp(1) = mesh_id_ypen
- mesh_ids_tmp(2) = mesh_id_zpen
-#if __CASE == __SLAB
- topo_ids_tmp(1) = topo_id_xpen
- mesh_ids_tmp(1) = mesh_id_xpen_complex
-#endif
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,lda_fv,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#endif
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
- lda(1)=3
- lda(2)=idom
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(ndata_trans,lda,iopt, info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_3d', &
- & 'ndata not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
- ndata_trans(1,idom)=ndata_zpen(3,idom)
- ndata_trans(2,idom)=ndata_zpen(2,idom)
- ndata_trans(3,idom)=ndata_zpen(1,idom)
- CALL ppm_alloc(data_com,ndata_trans(:,idom),iopt, info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_3d', &
- & 'data_com not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __VFIELD
- DO n=1,lda_fv
-#endif
- DO l=1, ndata_zpen(3,idom)
- DO j=1, ndata_zpen(2,idom)
- DO i=1, ndata_zpen(1,idom)
-#if __DIM == __SFIELD
- data_com(l,j,i)= DATA_fv_com(i,j,l,k)
-#elif __DIM == __VFIELD
- data_com(l,j,i)= DATA_fv_com(n,i,j,l,k)
-#endif
- ENDDO
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! FFT - Transformation in z-direction
- !-------------------------------------------------------------------------
-#if __CASE == __SLAB
- CALL ppm_fdsolver_fft_fd_z(data_com,ndata_trans(:,idom),FFT_xyz,info)
-#elif __CASE == __INIT
- CALL ppm_fdsolver_fft_fd_z(data_com,ndata_trans(:,idom),FFT_xyz,info)
-#else
- CALL ppm_util_fft_forward(data_com,ndata_trans(:,idom),FFT_xyz,info)
-#endif
- !-------------------------------------------------------------------------
- ! Solve Poisson Equation
- !-------------------------------------------------------------------------
- lda(1)=3
- lda(2)=idom
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(istart,lda,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_3d', &
- & 'istart not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
- ! transpose x-z of istart
- istart(1,idom)= istart_zpen(3,idom)
- istart(2,idom)= istart_zpen(2,idom)
- istart(3,idom)= istart_zpen(1,idom)
- length(1) = length_phys(3)
- length(2) = length_phys(2)
- length(3) = length_phys(1)
- Nm_poisson(1) = Nm_com(3)-1 ! corrected by -1 for ppm convention
- Nm_poisson(2) = Nm_com(2)-1 ! corrected by -1 for ppm convention
- Nm_poisson(3) = Nm_com(1)
- CALL ppm_fdsolver_poisson(FFT_xyz, ndata_trans(1:3,idom), &
- & istart(1:3,idom),length, Nm_poisson, info)
- iopt = ppm_param_dealloc
- CALL ppm_alloc(istart,lda,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve_3d', &
- & 'istart not allocated',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! FFT - Backward Transformation in z-direction
- !-------------------------------------------------------------------------
-#if __CASE == __SLAB
- CALL ppm_fdsolver_fft_bd_z(FFT_xyz,ndata_trans(:,idom),data_com,info)
-#elif __CASE == __INIT
- CALL ppm_fdsolver_fft_bd_z(FFT_xyz,ndata_trans(:,idom),data_com,info)
-#else
- CALL ppm_util_fft_backward(FFT_xyz,ndata_trans(:,idom),data_com,info)
-#endif
- iopt = ppm_param_dealloc
- CALL ppm_alloc(FFT_xyz,lda,iopt,info)
- !-------------------------------------------------------------------------
- ! Transpose back z-direction and x-direction
- !-------------------------------------------------------------------------
- DO i=1, ndata_zpen(1,idom)
- DO j=1, ndata_zpen(2,idom)
- DO l=1, ndata_zpen(3,idom)
-
-#if __DIM == __SFIELD
- DATA_fv_com(i,j,l,k) = data_com(l,j,i)
-#elif __DIM == __VFIELD
- DATA_fv_com(n,i,j,l,k) = data_com(l,j,i)
-#endif
- ENDDO
- ENDDO
- ENDDO
-#if __DIM == __VFIELD
- ENDDO
-#endif
- iopt = ppm_param_dealloc
- CALL ppm_alloc(data_com, lda, iopt,info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_solve',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
- ENDDO ! end of do-loop over k=1,f_topo%nsublist
-#if __CASE == __SLAB
- GOTO 2000
-#endif
- topo_ids_tmp(1) = topo_id_zpen
- topo_ids_tmp(2) = topo_id_ypen
- mesh_ids_tmp(1) = mesh_id_zpen
- mesh_ids_tmp(2) = mesh_id_ypen
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv_com, topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,lda_fv,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#endif
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
- iopt = ppm_param_alloc_fit
- ndata_trans(1,idom) = ndata_ypen(2,idom)
- ndata_trans(2,idom) = ndata_ypen(1,idom)
- ndata_trans(3,idom) = ndata_ypen(3,idom)
- CALL ppm_alloc(FFT_xy, ndata_trans(:,idom), iopt, info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve', &
- & 'FFT_xy array',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __VFIELD
- DO n=1,lda_fv
-#endif
- DO l=1, ndata_ypen(3,idom)
- DO j=1, ndata_ypen(2,idom)
- DO i=1, ndata_ypen(1,idom)
-#if __DIM == __SFIELD
- FFT_xy(j,i,l)= DATA_fv_com(i,j,l,k)
-#elif __DIM == __VFIELD
- FFT_xy(j,i,l)= DATA_fv_com(n,i,j,l,k)
-#endif
- ENDDO
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! FFT - Backward Transformation in y-direction
- !-------------------------------------------------------------------------
-#if __CASE == __INIT
- CALL ppm_fdsolver_fft_bd(FFT_xy, ndata_trans(:,idom),data_com,info)
-#else
- CALL ppm_util_fft_backward(FFT_xy,ndata_trans(:,idom),data_com,info)
-#endif
- !-------------------------------------------------------------------------
- ! Transpose y-direction and x-direction
- !-------------------------------------------------------------------------
- DO l=1, ndata_ypen(3,idom)
- DO i=1, ndata_ypen(1,idom)
- DO j=1, ndata_ypen(2,idom)
-#if __DIM == __SFIELD
- DATA_fv_com(i,j,l,k) = data_com(j,i,l)
-#elif __DIM == __VFIELD
- DATA_fv_com(n,i,j,l,k) = data_com(j,i,l)
-#endif
- ENDDO
- ENDDO
- ENDDO
-#if __DIM == __VFIELD
- ENDDO
-#endif
- iopt = ppm_param_dealloc
- CALL ppm_alloc(data_com, lda, iopt,info)
- CALL ppm_alloc(FFT_xy, lda, iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fdsolver_solve', &
- & 'FFT_x array',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDDO ! end of do-loop k=1,f_topo%nsublist
- 2000 CONTINUE ! CASE SLAB continues
- topo_ids_tmp(1) = topo_id_ypen
- topo_ids_tmp(2) = topo_id_xpen
- mesh_ids_tmp(1) = mesh_id_ypen
- mesh_ids_tmp(2) = mesh_id_xpen_complex
-#if __CASE == __SLAB
- topo_ids_tmp(1) = topo_id_zpen
- mesh_ids_tmp(1) = mesh_id_zpen
-#endif
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv_com,lda_fv,topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#endif
- DO k=1,f_topo%nsublist
- idom = f_topo%isublist(k)
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(FFT_x,ndata_xpen_complex(:,idom), iopt, info)
-#if __DIM == __VFIELD
- DO n=1,lda_fv
-#endif
- lda = ndata_xpen_complex(:,idom)
- DO l=1, ndata_xpen_complex(3,idom)
- DO j=1, ndata_xpen_complex(2,idom)
- DO i=1, ndata_xpen_complex(1,idom)
-#if __DIM == __SFIELD
- FFT_x(i,j,l) = DATA_fv_com(i,j,l,k)
-#elif __DIM == __VFIELD
- FFT_x(i,j,l) = DATA_fv_com(n,i,j,l,k)
-#endif
- ENDDO
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! FFT - Backward Transformation in x-direction
- !-------------------------------------------------------------------------
-#if __CASE == __SLAB
- CALL ppm_fdsolver_fft_bd_slab(FFT_x, lda ,Result,info)
-#elif __CASE == __INIT
- CALL ppm_fdsolver_fft_bd(FFT_x, lda ,Result,info)
-#else
- CALL ppm_util_fft_backward(FFT_x, lda ,Result,info)
-#endif
- !-------------------------------------------------------------------------
- ! Correct Inverse by problem size factor 1/(Nx*Ny*Nz)
- ! Subtract 1 to fit ppm convention
- !-------------------------------------------------------------------------
- rN = 1.0_MK/real(((Nm(1)-1)*(Nm(2)-1)*(Nm(3)-1)), MK)
- DO l=1, lda(3)
- DO j=1, lda(2)
- DO i=1, lda(1)
-#if __DIM == __SFIELD
- DATA_fv(i,j,l,k) = Result(i,j,l)*rN
-#elif __DIM == __VFIELD
- DATA_fv(n,i,j,l,k) = Result(i,j,l)*rN
-#endif
- ENDDO
- ENDDO
- ENDDO
-#if __DIM == __VFIELD
- ENDDO
-#endif
- ENDDO ! end of do-loop k=1,f_topo%nsublist
- iopt = ppm_param_dealloc
- CALL ppm_alloc(FFT_x,lda,iopt, info)
-#if __CASE == __SLAB
- !-------------------------------------------------------------------------
- ! Map to original topology if not xy-slab topology
- !-------------------------------------------------------------------------
- IF(.NOT.Its_xyslab_topo) THEN
- topo_ids_tmp(1) = topo_id_xpen
- topo_ids_tmp(2) = field_topoid
- mesh_ids_tmp(1) = mesh_id_xpen
- mesh_ids_tmp(2) = mesh_id_data
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv, topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv,lda_fv, topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#endif
- ENDIF
-#else
- !-------------------------------------------------------------------------
- ! Map to original topology if not x-pencil topology
- !-------------------------------------------------------------------------
- IF(.NOT.Its_xpencil_topo) THEN
- topo_ids_tmp(1) = topo_id_xpen
- topo_ids_tmp(2) = field_topoid
- mesh_ids_tmp(1) = mesh_id_xpen
- mesh_ids_tmp(2) = mesh_id_data
-#if __DIM == __SFIELD
- CALL ppm_fdsolver_map(DATA_fv, topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#elif __DIM == __VFIELD
- CALL ppm_fdsolver_map(DATA_fv,lda_fv, topo_ids_tmp, mesh_ids_tmp, &
- & ghostsize, info)
-#endif
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Deallocate memory
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(Result, lda, iopt,info)
- CALL ppm_alloc(data_in, lda, iopt,info)
- CALL ppm_alloc(data_com, lda, iopt,info)
- CALL ppm_alloc(FFT_x, lda, iopt,info)
- CALL ppm_alloc(FFT_xy, lda, iopt,info)
- CALL ppm_alloc(FFT_xyz, lda, iopt,info)
- CALL ppm_alloc(DATA_fv_com, lda_DATA_fv_com, iopt,info)
- CALL ppm_alloc(ndata,lda,iopt,info)
- CALL ppm_alloc(ndata_trans,lda,iopt, info)
- CALL ppm_alloc(cost,lda,iopt, info)
- CALL ppm_alloc(istart,lda,iopt, info)
- CALL ppm_alloc(istart_xpen_complex,lda,iopt, info)
- CALL ppm_alloc(istart_ypen,lda,iopt, info)
- CALL ppm_alloc(istart_zpen,lda,iopt, info)
- CALL ppm_alloc(istart_trans,lda,iopt, info)
- CALL ppm_alloc(ndata,lda,iopt, info)
- CALL ppm_alloc(ndata_xpen_complex,lda,iopt, info)
- CALL ppm_alloc(ndata_ypen,lda,iopt, info)
- CALL ppm_alloc(ndata_zpen,lda,iopt, info)
- CALL ppm_alloc(ndata_trans,lda,iopt, info)
- IF (info .NE. 0) THEN
- WRITE(mesg,'(A)') 'could not deallocate memory'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fdsolver_solve',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fdsolver_solve_3d',t0,info)
- RETURN
-
-#if __CASE == __SLAB
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_slab_3d_ss
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_slab_3d_sd
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_slab_3d_vs
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_slab_3d_vd
-#endif
-#endif
-#elif __CASE == __INIT
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_init_3d_ss
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_init_3d_sd
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_init_3d_vs
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_init_3d_vd
-#endif
-#endif
-#else
-#if __DIM == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_3d_ss
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_3d_sd
-#endif
-#endif
-#if __DIM == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_3d_vs
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fdsolver_solve_3d_vd
-#endif
-#endif
-#endif
diff --git a/src/ppm_fmm_expansion.f b/src/ppm_fmm_expansion.f
deleted file mode 100644
index c57b91db78d67e37d16c3f10a740671cebf2c4f0..0000000000000000000000000000000000000000
--- a/src/ppm_fmm_expansion.f
+++ /dev/null
@@ -1,529 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fmm_expansion
- !-------------------------------------------------------------------------
- !
- ! Purpose : Compute the expansions of the leaf boxes of the created
- ! tree structure.
- ! Calls ppm_fmm_traverse, which traverses the tree and
- ! shifts the expansions up the tree.
- !
- !
- ! Input : xpunord(:,:) (F) particle positions
- ! wpunord(:,:) (F) particle strengths
- ! Np (I) number of particles.
- ! lda (I) leading dimension of vector case
- !
- ! Input/output :
- !
- ! Output :
- ! info (I) return status. 0 upon success.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fmm_expansion.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.20 2006/09/04 18:34:45 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.19 2006/06/29 10:28:34 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.18 2006/06/20 15:17:05 hiebers
- ! BUGFIX: adjusted indices of ppm_boxid and ppm_subid
- !
- ! Revision 1.17 2006/06/16 07:52:20 hiebers
- ! Added a new list of topo IDs (topoidlist) to prevent
- ! overwriting user defined topologies
- !
- ! Revision 1.16 2006/02/03 09:39:12 ivos
- ! Changed the expansion loop to allow vectorization.
- !
- ! Revision 1.15 2005/09/19 13:03:27 polasekb
- ! code cosmetics
- !
- ! Revision 1.14 2005/09/11 11:43:59 polasekb
- ! moved mapping and second tree call to init
- !
- ! Revision 1.13 2005/08/25 13:52:28 polasekb
- ! mapping of boxpart added
- !
- ! Revision 1.12 2005/08/23 14:22:43 polasekb
- ! corrected to xpunord and wpunord
- !
- ! Revision 1.11 2005/08/23 14:11:38 polasekb
- ! fixed the formula for the Cnm
- !
- ! Revision 1.10 2005/08/11 15:13:15 polasekb
- ! now using maxboxcost from the data file
- !
- ! Revision 1.9 2005/08/08 13:33:41 polasekb
- ! init some more variables
- !
- ! Revision 1.8 2005/08/04 16:01:01 polasekb
- ! moved some data allocation to init
- !
- ! Revision 1.7 2005/07/29 12:35:27 polasekb
- ! changed diagonal to radius
- !
- ! Revision 1.6 2005/07/27 15:01:27 polasekb
- ! changed tree variables
- !
- ! Revision 1.5 2005/07/25 14:39:54 polasekb
- ! adapted to new constants saved in the
- ! ppm_module_data_fmm file
- ! adapted function call to ppm_fmm_traverse
- !
- ! Revision 1.4 2005/07/21 13:20:25 polasekb
- ! nullify lpdx, lhbx pointers
- !
- ! Revision 1.3 2005/06/02 14:18:39 polasekb
- ! removed variable totalmass
- ! changed some comments
- !
- ! Revision 1.2 2005/05/27 12:45:29 polasekb
- ! removed debug output
- !
- ! Revision 1.1 2005/05/27 07:56:40 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/16 15:59:14 polasekb
- ! start
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- SUBROUTINE ppm_fmm_expansion_s_sf(xpunord,wpunord,Np,info)
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- SUBROUTINE ppm_fmm_expansion_d_sf(xpunord,wpunord,Np,info)
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- SUBROUTINE ppm_fmm_expansion_s_vf(xpunord,wpunord,lda,Np,info)
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- SUBROUTINE ppm_fmm_expansion_d_vf(xpunord,wpunord,lda,Np,info)
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fmm
- USE ppm_module_fmm_traverse
- USE ppm_module_typedef
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_util_cart2sph
- USE ppm_module_write
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Precision
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK),DIMENSION(:,:),POINTER :: xpunord
- INTEGER ,INTENT(INOUT) :: Np
- INTEGER ,INTENT( OUT) :: info
-#if __DIM == __SFIELD
- REAL(MK),DIMENSION(:) ,POINTER :: wpunord
-#else
- REAL(MK),DIMENSION(:,:),POINTER :: wpunord
- INTEGER :: lda
-#endif
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! auxiliary variables
- LOGICAL ,DIMENSION(3) :: fixed
- INTEGER :: iopt,i,j,k,m,n,l
- INTEGER :: first,last,box,nrpart
- INTEGER ,DIMENSION(2) :: ldu2
- REAL(MK) :: sine,cosine,val,prod
- REAL(MK) :: angle,reci
- REAL(MK) :: t0,x0,y0,z0
- REAL(MK) :: dx,dy,dz,dist
- REAL(MK),DIMENSION(:,:), POINTER :: min_box,max_box
- REAL(MK),DIMENSION(:,:), POINTER :: min_sub,max_sub
- COMPLEX(MK),PARAMETER :: CI=(0.0_MK,1.0_MK)
- COMPLEX(MK) :: temp
- CHARACTER(LEN=ppm_char) :: cbuf
- ! parallelisation
- INTEGER :: isub,topoid
- INTEGER :: nsublist
- REAL(MK),DIMENSION(:) , POINTER :: boxcost
- ! traversing
- INTEGER :: root
- ! fmm
- REAL(MK),DIMENSION(:) , POINTER :: rho,theta,phi,radius
- REAL(MK),DIMENSION(:) , POINTER :: fac,fracfac
- REAL(MK),DIMENSION(:,:), POINTER :: Anm,Pnm,sqrtfac,xp
- REAL(MK),DIMENSION(:,:), POINTER :: centerofbox
- COMPLEX(MK),DIMENSION(:,:) ,POINTER :: Ynm
- TYPE(ppm_t_topo) , POINTER :: topo
-#if __DIM == __SFIELD
- COMPLEX(MK),DIMENSION(:,:) ,POINTER :: Cnm
- COMPLEX(MK),DIMENSION(:,:,:),POINTER :: expansion
-#else
- COMPLEX(MK),DIMENSION(:,:,:) ,POINTER:: Cnm
- COMPLEX(MK),DIMENSION(:,:,:,:),POINTER:: expansion
-#endif
- !-------------------------------------------------------------------------
- ! Initialize
- !-------------------------------------------------------------------------
- CALL substart('ppm_fmm_expansion',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
- IF (Np.LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fmm_expansion', &
- & 'number of particles must be >= 0 !',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (.NOT. ppm_fmm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fmm_expansion', &
- & 'Please call ppm_fmm_init first',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Checking precision and pointing tree data to correct variables
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- min_box => min_box_s
- max_box => max_box_s
- boxcost => boxcost_s
- centerofbox => centerofbox_s
- radius => radius_s
-#if __DIM == __SFIELD
- expansion => expansion_s_sf
- Cnm => Cnm_s_sf
-#else
- expansion => expansion_s_vf
- Cnm => Cnm_s_vf
-#endif
- Anm => Anm_s
- sqrtfac => sqrtfac_s
- fracfac => fracfac_s
- fac => fac_s
- Ynm => Ynm_s
- Pnm => Pnm_s
- rho => rho_s
- theta => theta_s
- phi => phi_s
-#else
- min_box => min_box_d
- max_box => max_box_d
- boxcost => boxcost_d
- centerofbox => centerofbox_d
- radius => radius_d
-#if __DIM == __SFIELD
- expansion => expansion_d_sf
- Cnm => Cnm_d_sf
-#else
- expansion => expansion_d_vf
- Cnm => Cnm_d_vf
-#endif
- Anm => Anm_d
- sqrtfac => sqrtfac_d
- fracfac => fracfac_d
- fac => fac_d
- Ynm => Ynm_d
- Pnm => Pnm_d
- rho => rho_d
- theta => theta_d
- phi => phi_d
-#endif
- !-------------------------------------------------------------------------
- ! Allocating temporary array for sorted particle positions
- ! according to tree
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu2(1) = ppm_dim
- ldu2(2) = Np
- CALL ppm_alloc(xp,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expansion', &
- & 'error allocating xp',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Computing the expansions of the leafs
- !-------------------------------------------------------------------------
- topoid = topoidlist(nlevel)
- topo => ppm_topo(topoid)%t
- DO i=1,topo%nsublist
- !----------------------------------------------------------------------
- ! initialize arrays
- !----------------------------------------------------------------------
- DO j=0,order
- DO k= -order,order
-#if __DIM == __SFIELD
- Cnm(j,k) = 0.0_MK
-#else
- DO l=1,lda
- Cnm(l,j,k) = 0.0_MK
- ENDDO
-#endif
- Ynm(j,k) = 0.0_MK
- Pnm(j,k) = 0.0_MK
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- ! Store the subid and boxid and the indices of the first and the last
- ! particle in the box
- !----------------------------------------------------------------------
- isub = topo%isublist(i)
- box = ppm_boxid(isub,nlevel)
- first = lhbx(1,box)
- last = lhbx(2,box)
- !----------------------------------------------------------------------
- ! Sort xp (particle order from tree)
- !----------------------------------------------------------------------
- IF(ppm_dim.EQ.2)THEN
- DO j=first,last
- xp(1,j) = xpunord(1,lpdx(j))
- xp(2,j) = xpunord(2,lpdx(j))
- ENDDO
- ENDIF
- IF(ppm_dim.EQ.3)THEN
- DO j=first,last
- xp(1,j) = xpunord(1,lpdx(j))
- xp(2,j) = xpunord(2,lpdx(j))
- xp(3,j) = xpunord(3,lpdx(j))
- ENDDO
- ENDIF
- nrpart = last-first + 1
- !----------------------------------------------------------------------
- ! Compute the spherical coord. of the particles
- !----------------------------------------------------------------------
- IF(nrpart.GT.0)THEN
- CALL ppm_util_cart2sph(xp(1,first:last), &
- & xp(2,first:last),xp(3,first:last),nrpart, &
- & centerofbox(1,box),centerofbox(2,box),centerofbox(3,box), &
- & rho(first:last),theta(first:last),phi(first:last),info)
- IF (info .NE. 0) THEN
- CALL ppm_error(ppm_err_sub_failed,'ppm_fmm_expansion', &
- & 'Failed calling util_cart2sph',__LINE__,info)
- ENDIF
- ENDIF
- !----------------------------------------------------------------------
- ! Loop over the particles in the leaves
- !----------------------------------------------------------------------
- DO j=first,last
- cosine = COS(theta(j))
- sine = SIN(theta(j))
- !-------------------------------------------------------------------
- ! Recurrence for Pnm
- !-------------------------------------------------------------------
- val = -sine
- prod = 1.0_MK
- DO m=0,order
- Pnm(m,m) = fracfac(m)*prod
- prod = prod * val
- ENDDO
- DO m=0,order-1
- Pnm(m+1,m) = cosine*REAL(2*m + 1,MK)*Pnm(m,m)
- ENDDO
- DO n=2,order
- val = cosine*REAL(2*n-1,MK)
- DO m=0,n-2
- Pnm(n,m)=(val*Pnm(n-1,m) - &
- & DBLE(n+m-1)*Pnm(n-2,m))/REAL(n-m,MK)
- ENDDO
- ENDDO
- !-------------------------------------------------------------------
- ! Compute Ynm(n,m) and Ynm(n,-m)
- !-------------------------------------------------------------------
- DO n=0,order
- m = 0
- angle = REAL(m,MK)*phi(j)
- Ynm(n,m) = sqrtfac(n,m)*Pnm(n,m)* &
- & CMPLX(COS(angle),SIN(angle))
- DO m=1,n
- angle = REAL(m,MK)*phi(j)
- Ynm(n,m) = sqrtfac(n,m)* &
- & Pnm(n,m)*CMPLX(COS(angle),SIN(angle))
- Ynm(n,-m) = CONJG(Ynm(n,m))
- ENDDO
- ENDDO
- !-------------------------------------------------------------------
- ! Computing Cnm(n,m) - the expansion coefficients
- !-------------------------------------------------------------------
- prod = 1.0_MK
- val = rho(j)
- DO n=0,order
- DO m=0,n
-#if __DIM == __SFIELD
- Cnm(n,m) = Cnm(n,m) + (wpunord(lpdx(j))*prod*Ynm(n,m)* &
- & Anm(n,m))/((-1)**n)
-#else
- DO l =1,lda
- Cnm(l,n,m) = Cnm(l,n,m) + (wpunord(l,lpdx(j))*prod*Ynm(n,m)* &
- & Anm(n,m))/((-1)**n)
- ENDDO
-#endif
- ENDDO
- prod = prod * val
- ENDDO
- ENDDO !particles in one sub
- !----------------------------------------------------------------------
- ! Computing Cnm(n,-m)
- !----------------------------------------------------------------------
- DO n=0,order
- DO m=1,n
-#if __DIM == __SFIELD
- Cnm(n,-m) = CONJG(Cnm(n,m))
-#else
- DO l =1,lda
- Cnm(l,n,-m) = CONJG(Cnm(l,n,m))
- ENDDO
-#endif
- ENDDO
- ENDDO
- DO m=1,order
- temp = CI**(-m)
- DO n=m,order
-#if __DIM == __SFIELD
- Cnm(n,m) = Cnm(n,m)*temp
- Cnm(n,-m)= Cnm(n,-m)*temp
-#else
- DO l=1,lda
- Cnm(l,n,m) = Cnm(l,n,m)*temp
- Cnm(l,n,-m)= Cnm(l,n,-m)*temp
- ENDDO
-#endif
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- ! Save expansion in fmm_module_data file
- !----------------------------------------------------------------------
-#if __DIM == __SFIELD
- DO n=0,order
- DO m=-order,order
- expansion(box,n,m) = Cnm(n,m)
- ENDDO
- ENDDO
-#else
- DO n=0,order
- DO m=-order,order
- DO l=1,lda
- expansion(l,box,n,m) = Cnm(l,n,m)
- ENDDO
- ENDDO
- ENDDO
-#endif
- ENDDO !loop over all subs
- !-------------------------------------------------------------------------
- ! Nullify data pointers
- !-------------------------------------------------------------------------
- NULLIFY(min_box)
- NULLIFY(max_box)
- NULLIFY(boxcost)
- NULLIFY(centerofbox)
- NULLIFY(radius)
- NULLIFY(expansion)
- NULLIFY(Anm)
- NULLIFY(sqrtfac)
- NULLIFY(fracfac)
- NULLIFY(Ynm)
- NULLIFY(Pnm)
- NULLIFY(Cnm)
- !-------------------------------------------------------------------------
- ! Traverse the tree and shift the expansions upwards
- !-------------------------------------------------------------------------
- IF (parent(1) .EQ. ppm_param_undefined) THEN
- root = 1
- ELSE
- DO i=2,nbox
- IF (parent(i) .EQ. ppm_param_undefined) THEN
- root = i
- EXIT
- ENDIF
- ENDDO
- ENDIF
-#if __DIM == __SFIELD
- CALL ppm_fmm_traverse(root,t0,info)
-#else
- CALL ppm_fmm_traverse(root,lda,t0,info)
-#endif
- IF (info.NE.0) THEN
- CALL ppm_error(ppm_err_sub_failed,'ppm_fmm_expansion', &
- & 'traversing tree failed',__LINE__,info)
- ENDIF
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_expansion','traversed tree',info)
- ENDIF
- !-------------------------------------------------------------------------
- ! deallocate local data
- !-------------------------------------------------------------------------
- CALL ppm_alloc(xp,ldu2,ppm_param_dealloc,info)
- IF (info .NE. 0) THEN
- WRITE(cbuf,'(A,I3,A)') 'for ',info,'error while dealloc'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fmm_expansion',cbuf,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_fmm_expansion',t0,info)
- RETURN
-
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_expansion_s_sf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_expansion_d_sf
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_expansion_s_vf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_expansion_d_vf
-#endif
diff --git a/src/ppm_fmm_expchange.f b/src/ppm_fmm_expchange.f
deleted file mode 100644
index 3847f61ec85840b21e2579b375c3914c921da3a0..0000000000000000000000000000000000000000
--- a/src/ppm_fmm_expchange.f
+++ /dev/null
@@ -1,563 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fmm_expchange
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine exchanges the expansion coefficents,
- ! the radius and the centerofboxes between all processores
- ! by all to all communication
- !
- !
- ! Input :
- ! prec (F) : dummy to determine precision
- ! lda (I) leading dimension of vector case
- !
- ! Output : info (I) : return status, 0 on success
- !
- ! Remarks : This routine has 3 separate sendrecv, ie. the data is
- ! not packed before sending
- ! (no pack data -send - unpack data )
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fmm_expchange.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.15 2007/01/23 09:45:24 hiebers
- ! Bugfix:Corrected indices of the array expansion(1:l,0:order,-order:order)
- !
- ! Revision 1.14 2006/09/04 18:34:46 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.12 2006/06/29 10:28:35 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.11 2006/06/16 07:52:21 hiebers
- ! Added a new list of topo IDs (topoidlist) to prevent overwriting user defined
- ! topologies
- !
- ! Revision 1.10 2005/09/19 13:03:28 polasekb
- ! code cosmetics
- !
- ! Revision 1.9 2005/09/11 18:05:30 polasekb
- ! (final?) corrected version
- ! (also works parallel :-)
- !
- ! Revision 1.8 2005/09/11 11:44:20 polasekb
- ! also communicating radius and centerofbox
- !
- ! Revision 1.7 2005/08/30 08:48:16 polasekb
- ! removed debug output
- !
- ! Revision 1.6 2005/08/25 14:16:02 polasekb
- ! corrected size of send/recv buffers
- ! exchanged sendrank/recvrank
- !
- ! Revision 1.4 2005/08/23 14:30:28 polasekb
- ! now making difference between single/double precision
- !
- ! Revision 1.3 2005/08/23 07:56:24 polasekb
- ! added #ifdef __MPI where needed
- !
- ! Revision 1.2 2005/08/23 07:49:26 polasekb
- ! corrected error output
- !
- ! Revision 1.1 2005/05/27 07:57:54 polasekb
- ! initial implementation
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- SUBROUTINE ppm_fmm_expchange_s_sf(prec,info)
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- SUBROUTINE ppm_fmm_expchange_d_sf(prec,info)
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- SUBROUTINE ppm_fmm_expchange_s_vf(lda,prec,info)
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- SUBROUTINE ppm_fmm_expchange_d_vf(lda,prec,info)
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fmm
- USE ppm_module_typedef
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Precision
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __VFIELD
- INTEGER , INTENT(IN ) :: lda
-#endif
- REAL(MK) , INTENT(IN ) :: prec
- INTEGER , INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! auxiliary variables
- INTEGER :: i,j,k,isub,m,n,l
- INTEGER :: nsend,nrecv,box
- INTEGER :: sendrank,recvrank
- INTEGER :: nsendexp,nrecvexp
- INTEGER :: nsendrad,nrecvrad
- INTEGER :: nsendcen,nrecvcen
- INTEGER :: iopt,level,cnt, topoid
- INTEGER :: tag2,istat
- INTEGER, DIMENSION(1) :: ldu1
- INTEGER, DIMENSION(2) :: ldu2
- INTEGER, DIMENSION(3) :: ldu3
- INTEGER, DIMENSION(4) :: ldu4
- REAL(MK) :: t0
- TYPE(ppm_t_topo), POINTER :: topo
- ! parallelisation
-#ifdef __MPI
- INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
-#endif
- ! fmm
- REAL(MK),DIMENSION(: ), POINTER :: radius,recvrad,sendrad
- REAL(MK),DIMENSION(:,:), POINTER :: recvcen,sendcen,centerofbox
-#if __DIM == __SFIELD
- COMPLEX(MK),DIMENSION(:,:,:),POINTER :: expansion,recvexp,sendexp
-#else
- COMPLEX(MK),DIMENSION(:,:,:,:),POINTER :: expansion,recvexp,sendexp
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fmm_expchange',t0,info)
- !-------------------------------------------------------------------------
- ! pointing to correct variables (single/double)
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
-#if __DIM == __SFIELD
- expansion => expansion_s_sf
-#else
- expansion => expansion_s_vf
-#endif
- centerofbox => centerofbox_s
- radius => radius_s
-#else
-#if __DIM == __SFIELD
- expansion => expansion_d_sf
-#else
- expansion => expansion_d_vf
-#endif
- centerofbox => centerofbox_d
- radius => radius_d
-#endif
- !-------------------------------------------------------------------------
- ! Allocate memory for the sendlist
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ppm_nsendlist = ppm_nproc
- ppm_nrecvlist = ppm_nproc
- ldu1(1) = ppm_nsendlist
- CALL ppm_alloc(ppm_isendlist,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expchange', &
- & 'send list PPM_ISENDLIST',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(ppm_irecvlist,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expchange', &
- & 'receive list PPM_IRECVLIST',__LINE__,info)
- GOTO 9999
- ENDIF
- tag2 = 200
- !-------------------------------------------------------------------------
- ! compute top level topology
- !-------------------------------------------------------------------------
-#ifdef __VECTOR
- DO i=1,nlevel
- IF (nbpl(i) .GE. ppm_nproc) THEN
- level = i
- ENDIF
- ENDDO
-#else
- DO i=1,nlevel
- IF (nbpl(i) .GE. ppm_nproc) THEN
- level = i
- EXIT
- ENDIF
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Compute nsendexp,nsendcen,nsendrad (nr of exp.,cen.,rad. to be sent)
- !-------------------------------------------------------------------------
- nsendexp = 0
- DO i=level,nlevel
- topoid = topoidlist(i)
- topo = ppm_topo(topoid)%t
-
- nsendexp = nsendexp + topo%nsublist
- nsendcen = nsendexp
- nsendrad = nsendexp
- ENDDO
- !-------------------------------------------------------------------------
- ! Set up own lists for sending to other processors
- !-------------------------------------------------------------------------
- ! expansion
-#if __DIM == __SFIELD
- ldu3(1) = nsendexp
- ldu3(2) = order+1
- ldu3(3) = 2*order+1
- CALL ppm_alloc(sendexp,ldu3,iopt,info)
-#else
- ldu4(1) = lda
- ldu4(2) = nsendexp
- ldu4(3) = order+1
- ldu4(4) = 2*order+1
- CALL ppm_alloc(sendexp,ldu4,iopt,info)
-#endif
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expchange', &
- & 'error allocating sendexp',__LINE__,info)
- GOTO 9999
- ENDIF
- ! centerofbox
- ldu2(1) = 3
- ldu2(2) = nsendcen
- CALL ppm_alloc(sendcen,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expchange', &
- & 'error allocating sendcen',__LINE__,info)
- GOTO 9999
- ENDIF
- ! radius
- ldu1(1) = nsendrad
- CALL ppm_alloc(sendrad,ldu1,iopt,info)
-
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expchange', &
- & 'error allocating sendrad',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! loop over levels of tree
- !-------------------------------------------------------------------------
- cnt = 0
- DO i=level,nlevel
- topoid = topoidlist(i)
- topo = ppm_topo(topoid)%t
-
- !----------------------------------------------------------------------
- ! loop over local subs and store in sendexp,sendcen,sendrad
- !----------------------------------------------------------------------
- DO j=1,topo%nsublist
- box = ppm_boxid(topo%isublist(j),i)
- cnt = cnt + 1
-#if __DIM == __SFIELD
- DO n=1,ldu3(2)
- DO m=1,ldu3(3)
- sendexp(cnt,n,m) = expansion(box,n-1,m-order-1)
- ENDDO
- ENDDO
-#else
- DO n=1,ldu4(2)
- DO m=1,ldu4(3)
- DO l=1,ldu4(1)
- sendexp(l,cnt,n,m) = expansion(l,box,n-1,m-order-1)
- ENDDO
- ENDDO
- ENDDO
-#endif
- DO n=1,3
- sendcen(n,cnt) = centerofbox(n,box)
- ENDDO
- sendrad(cnt) = radius(box)
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Initialize sendrank, recvrank, ppm_nsendlist, ppm_nrecvlist
- !-------------------------------------------------------------------------
- sendrank = ppm_rank - 1
- recvrank = ppm_rank + 1
- ppm_nsendlist = 0
- ppm_nrecvlist = 0
- !-------------------------------------------------------------------------
- ! Since we skip the local processor entirely, increment the pointers once
- !-------------------------------------------------------------------------
- sendrank = sendrank + 1
- recvrank = recvrank - 1
- ppm_nsendlist = ppm_nsendlist + 1
- ppm_isendlist(ppm_nsendlist) = sendrank
- ppm_nrecvlist = ppm_nrecvlist + 1
- ppm_irecvlist(ppm_nrecvlist) = recvrank
- !-------------------------------------------------------------------------
- ! Loop over all processors but skip the processor itself
- !-------------------------------------------------------------------------
- DO i=2,ppm_nproc
- !----------------------------------------------------------------------
- ! compute the next processor
- !----------------------------------------------------------------------
- sendrank = sendrank + 1
- IF (sendrank.GT.ppm_nproc-1) sendrank = sendrank - ppm_nproc
- recvrank = recvrank - 1
- IF (recvrank.LT. 0) recvrank = recvrank + ppm_nproc
- !----------------------------------------------------------------------
- ! Store the processor to which we will send to
- !----------------------------------------------------------------------
- ppm_nsendlist = ppm_nsendlist + 1
- ppm_isendlist(ppm_nsendlist) = sendrank
- !----------------------------------------------------------------------
- ! Store the processor to which we will recv from
- !----------------------------------------------------------------------
- ppm_nrecvlist = ppm_nrecvlist + 1
- ppm_irecvlist(ppm_nrecvlist) = recvrank
- !----------------------------------------------------------------------
- ! reset counter for nr of exp.coeff.,rad,centers to be received
- !----------------------------------------------------------------------
- nrecvexp = 0
- nrecvcen = 0
- nrecvrad = 0
- !----------------------------------------------------------------------
- ! loop over all topologies and check all subs
- !----------------------------------------------------------------------
- DO j=level,nlevel
- topoid = topoidlist(j)
- topo = ppm_topo(topoid)%t
-
- DO isub=1,topo%nsubs
- !-----------------------------------------------------------------
- ! Check if they belong to the processor from where we will
- ! receive data
- !-----------------------------------------------------------------
- IF (topo%sub2proc(isub) .EQ. recvrank) THEN
- !--------------------------------------------------------------
- ! If yes, increase counter for correct allocation
- !--------------------------------------------------------------
- nrecvexp = nrecvexp + 1
- nrecvcen = nrecvcen + 1
- nrecvrad = nrecvrad + 1
- ELSE
- !--------------------------------------------------------------
- ! will be exchanged in another round
- !--------------------------------------------------------------
- ENDIF
- ENDDO
- ENDDO
- !----------------------------------------------------------------------
- ! Allocate our recv-arrays, exp.,rad., centers to be received
- !----------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ! expansion
-#if __DIM == __SFIELD
- ldu3(1) = nrecvexp
- ldu3(2) = order+1
- ldu3(3) = 2*order+1
- CALL ppm_alloc(recvexp,ldu3,iopt,info)
-#else
- ldu4(1) = lda
- ldu4(2) = nrecvexp
- ldu4(3) = order+1
- ldu4(4) = 2*order+1
- CALL ppm_alloc(recvexp,ldu4,iopt,info)
-#endif
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expchange', &
- & 'error allocating recvexp',__LINE__,info)
- GOTO 9999
- ENDIF
- ! centerofbox
- ldu2(1) = 3
- ldu2(2) = nrecvcen
- CALL ppm_alloc(recvcen,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expchange', &
- & 'error allocating recvcen',__LINE__,info)
- GOTO 9999
- ENDIF
- ! radius
- ldu1(1) = nrecvrad
- CALL ppm_alloc(recvrad,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_expchange', &
- & 'error allocating recvrad',__LINE__,info)
- GOTO 9999
- ENDIF
- !----------------------------------------------------------------------
- ! receive the expansions
- !----------------------------------------------------------------------
- nsend = nsendexp*(order+1)*(2*order+1)
- nrecv = nrecvexp*(order+1)*(2*order+1)
-#ifdef __MPI
-#if __KIND == __SINGLE_PRECISION
- CALL MPI_SendRecv(sendexp,nsend,MPI_COMPLEX,sendrank,tag2, &
- & recvexp,nrecv,MPI_COMPLEX,recvrank,tag2, &
- & ppm_comm,status,info)
-#else
- CALL MPI_SendRecv(sendexp,nsend,MPI_DOUBLE_COMPLEX,sendrank,tag2,&
- & recvexp,nrecv,MPI_DOUBLE_COMPLEX,recvrank,tag2,&
- & ppm_comm,status,info)
-#endif
-#endif
- !----------------------------------------------------------------------
- ! receive the centers
- !----------------------------------------------------------------------
- nsend = nsendcen*3
- nrecv = nrecvcen*3
-#ifdef __MPI
- CALL MPI_SendRecv(sendcen,nsend,ppm_mpi_kind,sendrank,tag2, &
- & recvcen,nrecv,ppm_mpi_kind,recvrank,tag2, &
- & ppm_comm,status,info)
-#endif
- !----------------------------------------------------------------------
- ! receive the radius
- !----------------------------------------------------------------------
- nsend = nsendrad
- nrecv = nrecvrad
-#ifdef __MPI
- CALL MPI_SendRecv(sendrad,nsend,ppm_mpi_kind,sendrank,tag2,&
- & recvrad,nrecv,ppm_mpi_kind,recvrank,tag2,&
- & ppm_comm,status,info)
-#endif
- !----------------------------------------------------------------------
- ! store the received data
- ! loop over all topologies and check all subs
- !----------------------------------------------------------------------
- cnt = 0
- DO j=level,nlevel
- topoid = topoidlist(j)
- topo = ppm_topo(topoid)%t
- DO isub=1,topo%nsubs
- !-----------------------------------------------------------------
- ! Check if the sub belongs to the processor from where we
- ! received data
- !-----------------------------------------------------------------
- IF (topo%sub2proc(isub) .EQ. recvrank) THEN
- box = ppm_boxid(isub,j)
- !--------------------------------------------------------------
- ! If yes, store
- !--------------------------------------------------------------
- cnt = cnt + 1
-#if __DIM == __SFIELD
- DO n=1,ldu3(2)
- DO m=1,ldu3(3)
- expansion(box,n-1,m-order-1) = recvexp(cnt,n,m)
- ENDDO
- ENDDO
-#else
- DO n=1,ldu4(2)
- DO m=1,ldu4(3)
- DO l=1,ldu4(1)
- expansion(l,box,n-1,m-order-1) = recvexp(l,cnt,n,m)
- ENDDO
- ENDDO
- ENDDO
-#endif
- DO n=1,3
- centerofbox(n,box) = recvcen(n,cnt)
- ENDDO
- radius(box) = recvrad(cnt)
- ENDIF
- ENDDO
- ENDDO
- ENDDO ! end loop over nproc
- !-------------------------------------------------------------------------
- ! Deallocate the memory for the lists
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- ldu3(1) = 0
- ldu3(2) = 0
- ldu3(3) = 0
- istat = 0
- CALL ppm_alloc(recvexp,ldu3,iopt,info)
- istat = istat + info
- CALL ppm_alloc(recvcen,ldu3,iopt,info)
- istat = istat + info
- CALL ppm_alloc(recvrad,ldu3,iopt,info)
- istat = istat + info
- IF (istat.NE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fmm_expchange', &
- & 'recvexp',__LINE__,info)
- ENDIF
- istat = 0
- CALL ppm_alloc(sendexp,ldu3,iopt,info)
- istat = istat + info
- CALL ppm_alloc(sendcen,ldu3,iopt,info)
- istat = istat + info
- CALL ppm_alloc(sendrad,ldu3,iopt,info)
- istat = istat + info
- IF (istat.NE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fmm_expchange', &
- & 'sendexp',__LINE__,info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fmm_expchange',t0,info)
- RETURN
-
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_expchange_s_sf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_expchange_d_sf
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_expchange_s_vf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_expchange_d_vf
-#endif
diff --git a/src/ppm_fmm_finalize.f b/src/ppm_fmm_finalize.f
deleted file mode 100644
index fb5c35fdbcefc07d873a06351cbfd27284ba20f5..0000000000000000000000000000000000000000
--- a/src/ppm_fmm_finalize.f
+++ /dev/null
@@ -1,271 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fmm_finalize
- !-------------------------------------------------------------------------
- !
- ! Purpose : This routine deallocates all the arrays
- ! from the ppm_module_data_fmm module
- !
- !
- ! Input :
- !
- ! Input/output :
- !
- ! Output : info (I) 0 on success.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fmm_finalize.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.12 2006/09/04 18:34:46 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.11 2006/06/29 10:28:35 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.10 2006/06/16 07:52:21 hiebers
- ! Added a new list of topo IDs (topoidlist) to prevent overwriting user defined
- ! topologies
- !
- ! Revision 1.9 2005/09/19 13:03:28 polasekb
- ! code cosmetics
- !
- ! Revision 1.8 2005/09/12 13:31:16 polasekb
- ! added ppm_subid
- !
- ! Revision 1.7 2005/08/04 16:03:58 polasekb
- ! some new to deallocate
- !
- ! Revision 1.6 2005/07/29 12:36:28 polasekb
- ! changed diagonal to radius
- !
- ! Revision 1.5 2005/07/25 14:43:01 polasekb
- ! typo
- !
- ! Revision 1.4 2005/07/25 14:42:24 polasekb
- ! added new variables for dealloc
- !
- ! Revision 1.3 2005/06/02 14:46:39 polasekb
- ! removed variable totalmass
- !
- ! Revision 1.2 2005/05/27 08:42:01 polasekb
- ! removed dummy argument
- !
- ! Revision 1.1 2005/05/27 08:02:42 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/16 14:36:49 polasekb
- ! start
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
- SUBROUTINE ppm_fmm_finalize(info)
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fmm
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER, DIMENSION(1) :: lda1
- INTEGER, DIMENSION(2) :: lda2
- INTEGER, DIMENSION(3) :: lda3
- INTEGER, DIMENSION(4) :: lda4
- INTEGER :: iopt,istat
- INTEGER :: i,j
- REAL(8) :: t0
- CHARACTER(LEN=ppm_char) :: mesg
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_fmm_finalize',t0,info)
- !-------------------------------------------------------------------------
- ! Unset init variables
- !-------------------------------------------------------------------------
- ppm_fmm_initialized = .TRUE.
- lda1(1) = 0
- lda2(1:2) = 0
- lda3(1:3) = 0
- lda4(1:4) = 0
- !-------------------------------------------------------------------------
- ! Deallocate global arrays (from the ppm_module_data_fmm module)
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! Deallocate single/double variables
- !-------------------------------------------------------------------------
- istat = 0
- iopt = ppm_param_dealloc
- CALL ppm_alloc(radius_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(radius_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(expansion_s_sf,lda3,iopt,info)
- istat=istat+info
- CALL ppm_alloc(expansion_d_sf,lda3,iopt,info)
- istat=istat+info
- CALL ppm_alloc(expansion_s_vf,lda4,iopt,info)
- istat=istat+info
- CALL ppm_alloc(expansion_d_vf,lda4,iopt,info)
- istat=istat+info
- CALL ppm_alloc(centerofbox_s,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(centerofbox_d,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(totalmass_s,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(totalmass_d,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(min_box_s,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(min_box_d,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(max_box_s,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(max_box_d,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(boxcost_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(boxcost_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Anm_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Anm_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(sqrtfac_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(sqrtfac_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(fracfac_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(fracfac_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(fac_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(fac_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(rho_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(rho_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(theta_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(theta_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(phi_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(phi_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Cnm_s_sf,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Cnm_d_sf,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Cnm_s_vf,lda3,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Cnm_d_vf,lda3,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Pnm_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Pnm_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Ynm_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Ynm_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Inner_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Inner_d,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Outer_s,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(Outer_d,lda1,iopt,info)
- istat=istat+info
- !-------------------------------------------------------------------------
- ! Deallocate integer variables
- !-------------------------------------------------------------------------
- CALL ppm_alloc(lhbx,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(lpdx,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(nchld,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(parent,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(child,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(blevel,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(nbpl,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(topoidlist,lda1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(ppm_boxid,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(ppm_subid,lda2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(boxpart,lda1,iopt,info)
- istat=istat+info
- !-------------------------------------------------------------------------
- ! Check error status
- !-------------------------------------------------------------------------
- IF (istat .NE. 0) THEN
- WRITE(mesg,'(A,I3,A)') 'for ',istat,'error while deallc'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fmm_finalize',mesg,__LINE__,&
- & info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_fmm_finalize',t0,info)
- RETURN
- END SUBROUTINE ppm_fmm_finalize
diff --git a/src/ppm_fmm_init.f b/src/ppm_fmm_init.f
deleted file mode 100644
index ef2f557fae79b598d2e2e42581a75d13cfc9eeed..0000000000000000000000000000000000000000
--- a/src/ppm_fmm_init.f
+++ /dev/null
@@ -1,1324 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fmm_init
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- SUBROUTINE ppm_fmm_init_s_sf(xp,wp,Np,Nm,ord,min_dom,max_dom,maxboxcost, &
- & nrofbox,info)
-#elif ( __KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- SUBROUTINE ppm_fmm_init_d_sf(xp,wp,Np,Nm,ord,min_dom,max_dom,maxboxcost, &
- & nrofbox,info)
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- SUBROUTINE ppm_fmm_init_s_vf(xp,wp,lda,Np,Nm,ord,min_dom,max_dom, &
- & maxboxcost,nrofbox,info)
-#elif ( __KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- SUBROUTINE ppm_fmm_init_d_vf(xp,wp,lda,Np,Nm,ord,min_dom,max_dom, &
- & maxboxcost,nrofbox,info)
-#endif
- !!! Initialisation of FMM. This routine calls the ppm_tree-routine to
- !!! get the tree information and stores it. Maps the particles to
- !!! the leafs of the tree. It computes the center of the boxes and
- !!! the radius of the leaf boxes and stores it.
- !!!
- !!! [TIP]
- !!! only useful for freespace boundary conditions
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_tree
- USE ppm_module_data
- USE ppm_module_data_fmm
- USE ppm_module_typedef
- USE ppm_module_alloc
- USE ppm_module_error
- USE ppm_module_map
- USE ppm_module_topo_box2subs
- USE ppm_module_topo
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_write
- USE ppm_module_topo_check
- USE ppm_module_map_part
- USE ppm_module_map_part_global
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Precision
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
- REAL(MK), DIMENSION(: ), POINTER :: wp
- !!! field particle strenghts
-#elif __DIM == __VFIELD
- REAL(MK), DIMENSION(:,:), POINTER :: wp
- !!! field particle strenghts
- INTEGER , INTENT(IN ) :: lda
- !!! number of source dimensions
-#endif
- REAL(MK), DIMENSION(:,:), POINTER :: xp
- !!! the field points
- INTEGER , INTENT(INOUT) :: Np
- !!! the number of field points
- INTEGER , DIMENSION(: ), INTENT(IN ) :: Nm
- !!! number of grid points in the global mesh. (0,0,0) if there is
- !!! no mesh. If a mesh is present, the box boundaries will be aligned
- !!! with mesh planes.
- INTEGER , INTENT(IN ) :: ord
- !!! expansion order
- REAL(MK) , INTENT(IN ) :: maxboxcost
- !!! the maximum number of particles allowed in a box
- REAL(MK), DIMENSION(: ), INTENT(IN ) :: min_dom
- !!! the minimum coordinate of the domain
- REAL(MK), DIMENSION(: ), INTENT(IN ) :: max_dom
- !!! the maximum coordinate of the domain
- INTEGER , INTENT( OUT) :: nrofbox
- !!! the total number of all boxes
- INTEGER , INTENT( OUT) :: info
- !!! return status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- LOGICAL :: pruneboxes,OK
- LOGICAL :: TopoExists
- LOGICAL,DIMENSION(3) :: fixed
- INTEGER,DIMENSION(1) :: ldu1
- INTEGER,DIMENSION(2) :: ldu2
- INTEGER,DIMENSION(3) :: ldu3
- INTEGER :: iopt,i,j,k,l
- CHARACTER(LEN=ppm_char) :: cbuf
- INTEGER :: box,first,last,nrpbox
- REAL(MK) :: t0
- REAL(MK) :: tmp
- REAL(MK),DIMENSION(3) :: diagvec
-#if __DIM == __SFIELD
- INTEGER,DIMENSION(3) :: ldu,ldl
-#else
- INTEGER,DIMENSION(4) :: ldu,ldl
-#endif
- INTEGER :: treetype,minboxes
- REAL(MK) :: maxvariance
- INTEGER :: maxlevels
- REAL(MK),DIMENSION(3,2) :: weights
- REAL(MK),DIMENSION(3 ) :: minboxsize
- REAL(MK),DIMENSION(:,:), POINTER :: min_box,max_box
- REAL(MK),DIMENSION(:), POINTER :: boxcost
- REAL(MK),DIMENSION(:) , POINTER :: fac,fracfac
- REAL(MK),DIMENSION(:,:), POINTER :: Anm,sqrtfac
- INTEGER :: n,m,level
- INTEGER,DIMENSION(:), POINTER :: box2proc,boxid
- REAL(MK),DIMENSION(:), POINTER :: cost
- REAL(MK) :: ghostsize
- INTEGER :: decomp,assig
- INTEGER,DIMENSION(6) :: bcdef
- REAL(MK),DIMENSION(:,:), POINTER :: min_sub,max_sub
- INTEGER :: nsubs,topoid
- INTEGER,DIMENSION(:), POINTER :: new_subs2proc,subs2proc
- INTEGER :: Mpart
- INTEGER :: istat
- REAL(MK),DIMENSION(: ), POINTER :: radius,totalmass
- REAL(MK),DIMENSION(:,:), POINTER :: centerofbox
- REAL(MK),DIMENSION(:,:), POINTER :: treepart
-#if __DIM == __SFIELD
- REAL(MK),DIMENSION(: ), POINTER :: treewp
-#elif __DIM == __VFIELD
- REAL(MK),DIMENSION(:,:), POINTER :: treewp
-#endif
- !-------------------------------------------------------------------------
- ! Initialize
- !-------------------------------------------------------------------------
- CALL substart('ppm_fmm_init',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
- DO i=1,ppm_dim
- IF (min_dom(i) .GT. max_dom(i)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fmm_init', &
- & 'min_dom must be <= max_dom !',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDDO
- ENDIF
- !-------------------------------------------------------------------------
- ! Set init variables
- !-------------------------------------------------------------------------
- ppm_fmm_initialized = .TRUE.
- !-------------------------------------------------------------------------
- ! Define global variables
- !-------------------------------------------------------------------------
- order = ord
- !-------------------------------------------------------------------------
- ! Set tree input variables
- !-------------------------------------------------------------------------
- treetype = ppm_param_tree_oct
- minboxes = ppm_nproc
- pruneboxes = .FALSE.
- minboxsize = (/0.001_MK,0.001_MK,0.001_MK/)
- maxvariance = -1.0_MK
- fixed = (/.FALSE.,.FALSE.,.FALSE./)
- weights(:,1) = (/1.0_MK,0.0_MK,0.0_MK/)
- weights(:,2) = (/0.0_MK,0.0_MK,1.0_MK/)
- maxlevels = 20
-#if __KIND == __SINGLE_PRECISION
- !-------------------------------------------------------------------------
- ! Build the tree - single precision
- !-------------------------------------------------------------------------
- CALL ppm_tree(xp,Np,Nm,min_dom,max_dom,treetype,minboxes, &
- & pruneboxes,minboxsize,maxvariance,maxboxcost,maxlevels,fixed,&
- & weights,min_box_s,max_box_s,lhbx,lpdx,boxcost_s,parent,nchld,&
- & child,blevel,nbox,nbpl,nlevel,info)
- min_box => min_box_s
- max_box => max_box_s
- boxcost => boxcost_s
-#else
- !-------------------------------------------------------------------------
- ! Build the tree - double precision
- !-------------------------------------------------------------------------
- CALL ppm_tree(xp,Np,Nm,min_dom,max_dom,treetype,minboxes, &
- & pruneboxes,minboxsize,maxvariance,maxboxcost,maxlevels,fixed,&
- & weights,min_box_d,max_box_d,lhbx,lpdx,boxcost_d,parent,nchld,&
- & child,blevel,nbox,nbpl,nlevel,info)
- min_box => min_box_d
- max_box => max_box_d
- boxcost => boxcost_d
-#endif
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_fmm_init', &
- & 'Calling tree failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- nrofbox = nbox
- IF (ppm_debug.GT.0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'calling tree successful',info)
- WRITE (cbuf,'(A,I6)') 'nbox = ',nbox
- CALL ppm_write(ppm_rank,'ppm_fmm_init',cbuf,info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Allocate topoidlist
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu1(1) = nlevel
- CALL ppm_alloc(topoidlist,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating topoidlist',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Allocate boxpart
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu1(1) = Np
- CALL ppm_alloc(boxpart,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating boxpart',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i=1,Np
- boxpart(i) = 0.0_MK
- ENDDO
- !-------------------------------------------------------------------------
- ! Store which particle is in which leaf box
- !-------------------------------------------------------------------------
- IF (Np .GT. 0) THEN
- DO i=1,nbox
- IF (nchld(i) .EQ. 0) THEN
- DO j=lhbx(1,i),lhbx(2,i)
- boxpart(lpdx(j)) = i
- ENDDO
- ENDIF
- ENDDO
- ENDIF
- !-------------------------------------------------------------------------
- ! make top level topology seperate
- !-------------------------------------------------------------------------
-#ifdef __VECTOR
- DO i=1,nlevel
- IF (nbpl(i) .GE. ppm_nproc) THEN
- level = i
- ENDIF
- ENDDO
-#else
- DO i=1,nlevel
- IF (nbpl(i) .GE. ppm_nproc) THEN
- level = i
- EXIT
- ENDIF
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Allocate ppm_boxid, ppm_subid, box2proc and cost
- !-------------------------------------------------------------------------
- ldu2(1) = nbox
- ldu2(2) = nlevel
- CALL ppm_alloc(ppm_boxid,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating ppm_boxid',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(ppm_subid,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating ppm_boxid',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu1(1) = nbox
- CALL ppm_alloc(box2proc,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating box2proc',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu1(1) = MAXVAL(nbpl(:))
- CALL ppm_alloc(cost,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating box2proc',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Set parallelisation input variables
- !-------------------------------------------------------------------------
- DO i=1,nbox
- box2proc(i) = 0.0_MK
- DO j=1,nlevel
- ppm_boxid(i,j) = 0.0_MK
- ppm_subid(i,j) = 0.0_MK
- ENDDO
- ENDDO
- DO i=1,size(cost,1)
- cost(i) = 1.0_MK
- ENDDO
- decomp = ppm_param_decomp_user_defined
- assig = ppm_param_assign_internal
- ghostsize = 0.0_MK
- bcdef(1:6) = ppm_param_bcdef_freespace
- !-------------------------------------------------------------------------
- ! Transforming leaf boxes into subdomains and create the topologies
- !-------------------------------------------------------------------------
- CALL ppm_topo_box2subs(min_box,max_box,nchld,nbox,min_sub,max_sub, &
- & nsubs,info,boxid,-level,blevel,child)
- IF (info.NE.0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'topo_box2subs failed',info)
- ENDIF
-
-
- !-------------------------------------------------------------------------
- ! Create first topology based on leaf boxes
- ! (this uses the topo_mkgeom implementation of ppm_mktopo
- !-------------------------------------------------------------------------
- CALL ppm_mktopo(topoid,decomp,assig,min_dom,max_dom,bcdef,ghostsize, &
- & cost,info,min_sub,max_sub,nsubs,subs2proc)
- IF (info.NE.0) THEN
- CALL ppm_error(ppm_err_sub_failed,'ppm_fmm_init', &
- & 'mktopo failed',__LINE__,info)
- ENDIF
- topoidlist(level) = topoid
-
- DO i = 1,nsubs
- ppm_boxid(i,level) = boxid(i)
- ENDDO
- DO j=1,SIZE(boxid)
- ppm_subid(boxid(j),level) = j
- ENDDO
- DO i=1,nsubs
- box2proc(boxid(i)) = subs2proc(i)
- ENDDO
- !-------------------------------------------------------------------------
- ! Loop over the levels of the tree and register each level as topology
- !-------------------------------------------------------------------------
- assig = ppm_param_assign_user_defined
-
- DO i=level+1,nlevel
-
- !-----------------------------------------------------------------------
- ! Call subroutine to get subs
- ! changed the level argument from -topoid to -i
- !-----------------------------------------------------------------------
- CALL ppm_topo_box2subs(min_box,max_box,nchld,nbox,min_sub,max_sub, &
- & nsubs,info,boxid,-i,blevel,child)
- IF (info.NE.0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'topo_box2subs failed',info)
- ENDIF
-
- !-----------------------------------------------------------------------
- ! Allocate new subs2proc
- !-----------------------------------------------------------------------
- iopt = ppm_param_alloc_grow
- ldu1(1) = nsubs
- CALL ppm_alloc(new_subs2proc,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating new_subs2proc',__LINE__,info)
- GOTO 9999
- ENDIF
- DO j=1,nsubs
- new_subs2proc(j) = box2proc(parent(boxid(j)))
- box2proc(boxid(j)) = new_subs2proc(j)
- ENDDO
- !-----------------------------------------------------------------------
- ! Call ppm_mktopo to get topology
- !-----------------------------------------------------------------------
- CALL ppm_mktopo(topoid,decomp,assig,min_dom,max_dom,bcdef,ghostsize,&
- & cost,info,min_sub,max_sub,nsubs,new_subs2proc)
- IF (info.NE.0) THEN
- CALL ppm_error(ppm_err_sub_failed,'ppm_fmm_init', &
- & 'mktopo failed',__LINE__,info)
- ENDIF
- ppm_boxid(1:nsubs,i) = boxid(1:nsubs)
- DO j=1,SIZE(boxid)
- ppm_subid(boxid(j),i) = j
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Map for the lowest level (leafs of tree)
- !-------------------------------------------------------------------------
- topoid = topoidlist(nlevel)
- IF (ppm_nproc .GT. 1) THEN
- !-------------------------------------------------------------------------
- ! Map the particles onto the finest tree topology = topoid=nlevel
- !-------------------------------------------------------------------------
-
- CALL ppm_map_part_global(topoid,xp,Np,info) ! positions
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Failed to start global mapping.',info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Push along the strength of the particles and the boxpart
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
- CALL ppm_map_part_push(wp,Np,info) ! strengths
-#else
- CALL ppm_map_part_push(wp,lda,Np,info) ! strengths
-#endif
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Failed to push strengths.',info)
- GOTO 9999
- ENDIF
- CALL ppm_map_part_push(boxpart,Np,info) ! boxpart
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Failed to push strengths.',info)
- GOTO 9999
- ENDIF
-
- CALL ppm_map_part_send(Np,Mpart,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Failed to send particles.',info)
- GOTO 9999
- ENDIF
-
- CALL ppm_map_part_pop(boxpart,Np,Mpart,info) ! boxpart
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Failed to push strengths.',info)
- GOTO 9999
- ENDIF
-#if __DIM == __SFIELD
- CALL ppm_map_part_pop(wp,Np,Mpart,info) ! strengths
-#else
- CALL ppm_map_part_pop(wp,lda,Np,Mpart,info) ! strengths
-#endif
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Failed to pop strengths.',info)
- GOTO 9999
- ENDIF
-
- CALL ppm_map_part_pop(xp,ppm_dim,Np,Mpart,info) ! positions
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Failed to pop positions.',info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Update and store and new number of particles
- !-------------------------------------------------------------------------
- Np = Mpart
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Done mapping particles.',info)
- WRITE(cbuf,'(A,I6)') 'Local number of particles is now: ',Np
- CALL ppm_write(ppm_rank,'ppm_fmm_init',cbuf,info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Check that particles have been mapped correctly
- !-------------------------------------------------------------------------
- CALL ppm_topo_check(topoid,xp,Np,OK,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Failed to check topology.',info)
- ENDIF
-
- IF (.NOT.OK) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'Particles not mapped correctly!',info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Rebuild the tree to get the correct lpdx and lhbx arrays
- ! (after mapping particles changed)
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- !-------------------------------------------------------------------------
- ! Build the tree - single precision
- !-------------------------------------------------------------------------
- CALL ppm_tree(xp,Np,Nm,min_dom,max_dom,treetype,minboxes, &
- & pruneboxes,minboxsize,maxvariance,maxboxcost,maxlevels,fixed,&
- & weights,min_box_s,max_box_s,lhbx,lpdx,boxcost_s,parent,nchld,&
- & child,blevel,nbox,nbpl,nlevel,info)
- min_box => min_box_s
- max_box => max_box_s
- boxcost => boxcost_s
-#else
- !-------------------------------------------------------------------------
- ! Build the tree - double precision
- !-------------------------------------------------------------------------
- CALL ppm_tree(xp,Np,Nm,min_dom,max_dom,treetype,minboxes, &
- & pruneboxes,minboxsize,maxvariance,maxboxcost,maxlevels,fixed,&
- & weights,min_box_d,max_box_d,lhbx,lpdx,boxcost_d,parent,nchld,&
- & child,blevel,nbox,nbpl,nlevel,info)
- min_box => min_box_d
- max_box => max_box_d
- boxcost => boxcost_d
-#endif
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_fmm_init', &
- & 'Calling tree (2) failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Store number of boxes in nrofbox
- !-------------------------------------------------------------------------
- nrofbox = nbox
- IF (ppm_debug.GT.0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init', &
- & 'calling tree (2) successful',info)
- WRITE (cbuf,'(A,I6)') 'nbox = ',nbox
- CALL ppm_write(ppm_rank,'ppm_fmm_init',cbuf,info)
- ENDIF
- ENDIF ! ppm_nrpco .GT. 1
- !-------------------------------------------------------------------------
- ! Allocate all data (single/double)
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! Allocate and initialise sqrtfac,Anm, Outer, fracfac (single/double)
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
-#if __KIND == __SINGLE_PRECISION
- ldl(1) = 0
- ldl(2) = -order
- ldu(1) = order
- ldu(2) = order
- CALL ppm_alloc(sqrtfac_s,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating sqrtfac',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(Anm_s,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Anm',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(Outer_s,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Outer',__LINE__,info)
- GOTO 9999
- ENDIF
- ldl(1) = 0
- ldu(1) = order
- CALL ppm_alloc(fracfac_s,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating frac_fac',__LINE__,info)
- GOTO 9999
- ENDIF
- ! Initiatise variables
- Anm => Anm_s
- sqrtfac => sqrtfac_s
- fracfac => fracfac_s
-#else
- ldl(1) = 0
- ldl(2) = -order
- ldu(1) = order
- ldu(2) = order
- CALL ppm_alloc(sqrtfac_d,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating sqrtfac',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(Anm_d,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Anm',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(Outer_d,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Outer',__LINE__,info)
- GOTO 9999
- ENDIF
- ldl(1) = 0
- ldu(1) = order
- CALL ppm_alloc(fracfac_d,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating fracfac',__LINE__,info)
- GOTO 9999
- ENDIF
- ! Initiatise variables
- Anm => Anm_d
- sqrtfac => sqrtfac_d
- fracfac => fracfac_d
-#endif
- !-------------------------------------------------------------------------
- ! Allocate and initialise expansions
- !-------------------------------------------------------------------------
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- ldl(1) = 1
- ldl(2) = 0
- ldl(3) = -order
- ldu(1) = nbox
- ldu(2) = order
- ldu(3) = order
- CALL ppm_alloc(expansion_s_sf,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating expansion',__LINE__,info)
- GOTO 9999
- ENDIF
- DO j=0,order
- DO k=-order,order
- DO i=1,nbox
- expansion_s_sf(i,j,k) = 0.0_MK
- ENDDO
- ENDDO
- ENDDO
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- ldl(1) = 1
- ldl(2) = 0
- ldl(3) = -order
- ldu(1) = nbox
- ldu(2) = order
- ldu(3) = order
- CALL ppm_alloc(expansion_d_sf,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating expansion',__LINE__,info)
- GOTO 9999
- ENDIF
- DO j=0,order
- DO k=-order,order
- DO i=1,nbox
- expansion_d_sf(i,j,k) = 0.0_MK
- ENDDO
- ENDDO
- ENDDO
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- ldl(1) = 1
- ldl(2) = 1
- ldl(3) = 0
- ldl(4) = -order
- ldu(1) = lda
- ldu(2) = nbox
- ldu(3) = order
- ldu(4) = order
- CALL ppm_alloc(expansion_s_vf,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating expansion',__LINE__,info)
- GOTO 9999
- ENDIF
- DO j=0,order
- DO k=-order,order
- DO i=1,nbox
- DO l=1,lda
- expansion_s_vf(l,i,j,k) = 0.0_MK
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- ldl(1) = 1
- ldl(2) = 1
- ldl(3) = 0
- ldl(4) = -order
- ldu(1) = lda
- ldu(2) = nbox
- ldu(3) = order
- ldu(4) = order
- CALL ppm_alloc(expansion_d_vf,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating expansion',__LINE__,info)
- GOTO 9999
- ENDIF
- DO j=0,order
- DO k=-order,order
- DO i=1,nbox
- DO l=1,lda
- expansion_d_vf(l,i,j,k) = 0.0_MK
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Allocate multipole coefficient variables
- ! Pnm, Ynm, fac, rho, theta, phi
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- ldl(1) = 0
- ldu(1) = 2*order
- CALL ppm_alloc(fac_s,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating fac',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu1(1) = ppm_nproc*Np
- CALL ppm_alloc(rho_s,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating rho',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(theta_s,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating theta',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(phi_s,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating phi',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i = 1,ldu1(1)
- rho_s(i) = 0.0_MK
- theta_s(i) = 0.0_MK
- phi_s(i) = 0.0_MK
- ENDDO
- ldl(1) = 0
- ldl(2) = -order
- ldu(1) = order
- ldu(2) = order
- CALL ppm_alloc(Ynm_s,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Ynm',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(Pnm_s,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Pnm',__LINE__,info)
- GOTO 9999
- ENDIF
- ldl(1) = 0
- ldl(2) = -2*order
- ldu(1) = 2*order
- ldu(2) = 2*order
- CALL ppm_alloc(Inner_s,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Inner',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i=ldl(1),ldu(1)
- DO j=ldl(2),ldu(2)
- Inner_s(i,j) = 0.0_MK
- ENDDO
- ENDDO
- ! Initiatise variables
- fac => fac_s
-#else
- ldl(1) = 0
- ldu(1) = 2*order
- CALL ppm_alloc(fac_d,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating fac',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu1(1) = ppm_nproc*Np
- CALL ppm_alloc(rho_d,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating rho',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(theta_d,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating theta',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(phi_d,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating phi',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i = 1,ldu1(1)
- rho_d(i) = 0.0_MK
- theta_d(i) = 0.0_MK
- phi_d(i) = 0.0_MK
- ENDDO
- ldl(1) = 0
- ldl(2) = -order
- ldu(1) = order
- ldu(2) = order
- CALL ppm_alloc(Ynm_d,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Ynm',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_alloc(Pnm_d,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Pnm',__LINE__,info)
- GOTO 9999
- ENDIF
- ldl(1) = 0
- ldl(2) = -2*order
- ldu(1) = 2*order
- ldu(2) = 2*order
- CALL ppm_alloc(Inner_d,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Inner',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i=ldl(1),ldu(1)
- DO j=ldl(2),ldu(2)
- Inner_d(i,j) = 0.0_MK
- ENDDO
- ENDDO
- ! Initiatise variables
- fac => fac_d
-#endif
- !-------------------------------------------------------------------------
- ! Initialise fac with zero
- !-------------------------------------------------------------------------
- DO i = 0,2*order
- fac(i) = 0.0_MK
- ENDDO
- !-------------------------------------------------------------------------
- ! Compute fac, rho, phi, theta and topoid
- !-------------------------------------------------------------------------
- fac(0) = 1
- DO i=1,order*2
- fac(i) = fac(i-1)*REAL(i,MK)
- ENDDO
- DO n=0,order
- DO m=-n,n
- sqrtfac(n,m) = SQRT(fac(n-ABS(m))/fac(n+ABS(m)))
- Anm(n,m) = (-1)**n/SQRT(fac(n-m)*fac(n+m))
- ENDDO
- ENDDO
- DO m=0,order
- fracfac(m) = fac(2*m)/(2.**m*fac(m))
- ENDDO
- !-------------------------------------------------------------------------
- ! Allocate Cnm
- !-------------------------------------------------------------------------
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- ldl(1) = 0
- ldl(2) = -order
- ldu(1) = order
- ldu(2) = order
- CALL ppm_alloc(Cnm_s_sf,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Cnm',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- ldl(1) = 0
- ldl(2) = -order
- ldu(1) = order
- ldu(2) = order
- CALL ppm_alloc(Cnm_d_sf,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Cnm',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif (__KIND == SINGLE_PRECISION && __DIM == __VFIELD)
- ldl(1) = 1
- ldl(2) = 0
- ldl(3) = -order
- ldu(1) = lda
- ldu(2) = order
- ldu(3) = order
- CALL ppm_alloc(Cnm_s_vf,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Cnm',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- ldl(1) = 1
- ldl(2) = 0
- ldl(3) = -order
- ldu(1) = lda
- ldu(2) = order
- ldu(3) = order
- CALL ppm_alloc(Cnm_d_vf,ldl,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating Cnm',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Allocate radius (single/double)
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
-#if __KIND == __SINGLE_PRECISION
- ldu1 = nbox
- CALL ppm_alloc(radius_s,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating radius',__LINE__,info)
- GOTO 9999
- ENDIF
-#else
- ldu1 = nbox
- CALL ppm_alloc(radius_d,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating radius',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Allocate centerofbox (single/double)
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- ldu2(1) = ppm_dim
- ldu2(2) = nbox
- CALL ppm_alloc(centerofbox_s,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating centerofbox',__LINE__,info)
- GOTO 9999
- ENDIF
-#else
- ldu2(1) = ppm_dim
- ldu2(2) = nbox
- CALL ppm_alloc(centerofbox_d,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating centerofbox',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Allocate totalmass (single/double)
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- ldu1 = nbox
- CALL ppm_alloc(totalmass_s,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating totalmass',__LINE__,info)
- GOTO 9999
- ENDIF
-#else
- ldu1 = nbox
- CALL ppm_alloc(totalmass_d,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating totalmass',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- IF (ppm_debug.GT.0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init','alloc data successful' &
- & ,info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Check precision and pointing to the correct variables
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- centerofbox => centerofbox_s
- totalmass => totalmass_s
- radius => radius_s
- maxboxcost_s = maxboxcost
-#else
- centerofbox => centerofbox_d
- totalmass => totalmass_d
- radius => radius_d
- maxboxcost_d = maxboxcost
-#endif
- ! initialise centerofbox with zero
- DO j=1,nbox
- DO i=1,ppm_dim
- centerofbox(i,j) = 0.0_MK
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Allocate treepart and treewp
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu2(1) = ppm_dim
- ldu2(2) = Np
- CALL ppm_alloc(treepart,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating treepart',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __SFIELD
- ldu1 = Np
- CALL ppm_alloc(treewp,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating treewp',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __DIM == __VFIELD
- ldu2(1) = lda
- ldu2(2) = Np
- CALL ppm_alloc(treewp,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_init', &
- & 'error allocating treewp',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Loop over the boxes to compute the centerofbox of each
- !-------------------------------------------------------------------------
- DO box=1,nbox
- IF (nchld(box) .NE. 0) CYCLE
- first = lhbx(1,box)
- last = lhbx(2,box)
- !----------------------------------------------------------------------
- ! Compute new array with particle order from tree
- ! and necessary information (nr. of part. in box)
- !----------------------------------------------------------------------
- nrpbox = last-first+1
- DO j=first,last
- treepart(1,j) = xp(1,lpdx(j))
- treepart(2,j) = xp(2,lpdx(j))
- IF(ppm_dim.EQ.3)THEN
- treepart(3,j) = xp(3,lpdx(j))
- ENDIF
-#if __DIM == __SFIELD
- treewp(j) = wp(lpdx(j))
-#else
- DO i=1,lda
- treewp(i,j) = wp(i,lpdx(j))
- ENDDO
-#endif
- ENDDO
- !----------------------------------------------------------------------
- ! Computing the total mass
- !----------------------------------------------------------------------
-#if __DIM == __SFIELD
- totalmass(box) = 0.0_MK
- DO i=first,last
- totalmass(box) = totalmass(box) + ABS(treewp(i))
- ENDDO
-#else
- totalmass(box) = 0.0_MK
- DO i=first,last
- DO j=1,lda
- totalmass(box) = totalmass(box) + treewp(j,i)*treewp(j,i)
- ENDDO
- ENDDO
- totalmass(box) = SQRT(totalmass(box))
-#endif
- !----------------------------------------------------------------------
- ! Compute the centers of the leaf boxes
- !----------------------------------------------------------------------
- IF (nrpbox .GT. 0) THEN
-#if __DIM == __SFIELD
- IF(ppm_dim.EQ.2)THEN
- centerofbox(1,box) = 0.0_MK
- centerofbox(2,box) = 0.0_MK
- DO j=first,last
- centerofbox(1,box) = centerofbox(1,box) + treepart(1,j)* &
- & ABS(treewp(j))
- centerofbox(2,box) = centerofbox(2,box) + treepart(2,j)* &
- & ABS(treewp(j))
- ENDDO
- tmp = 1.0_MK/totalmass(box)
- centerofbox(1,box) = centerofbox(1,box) * tmp
- centerofbox(2,box) = centerofbox(2,box) * tmp
- ENDIF
- IF(ppm_dim.EQ.3)THEN
- centerofbox(1,box) = 0.0_MK
- centerofbox(2,box) = 0.0_MK
- centerofbox(3,box) = 0.0_MK
- DO j=first,last
- centerofbox(1,box) = centerofbox(1,box) + treepart(1,j)* &
- & ABS(treewp(j))
- centerofbox(2,box) = centerofbox(2,box) + treepart(2,j)* &
- & ABS(treewp(j))
- centerofbox(3,box) = centerofbox(3,box) + treepart(3,j)* &
- & ABS(treewp(j))
- ENDDO
- tmp = 1.0_MK/totalmass(box)
- centerofbox(1,box) = centerofbox(1,box) *tmp
- centerofbox(2,box) = centerofbox(2,box) *tmp
- centerofbox(3,box) = centerofbox(3,box) *tmp
- ENDIF
-#else
- IF(ppm_dim.EQ.2)THEN
- centerofbox(1,box) = 0.0_MK
- centerofbox(2,box) = 0.0_MK
- DO j=first,last
- tmp = 0.0_MK
- DO l = 1,lda
- tmp = tmp + treewp(l,j)*treewp(l,j)
- ENDDO
- centerofbox(1,box) = centerofbox(1,box)+ &
- & SQRT(tmp)*treepart(1,j)
- centerofbox(2,box) = centerofbox(2,box)+ &
- & SQRT(tmp)*treepart(2,j)
- ENDDO
- tmp = 1.0_MK/totalmass(box)
- centerofbox(1,box) = centerofbox(1,box) * tmp
- centerofbox(2,box) = centerofbox(2,box) * tmp
- ENDIF
- IF(ppm_dim.EQ.3)THEN
- centerofbox(1,box) = 0.0_MK
- centerofbox(2,box) = 0.0_MK
- centerofbox(3,box) = 0.0_MK
- DO j=first,last
- tmp = 0.0_MK
- DO l = 1,lda
- tmp = tmp + treewp(l,j)*treewp(l,j)
- ENDDO
- centerofbox(1,box) = centerofbox(1,box)+ &
- & SQRT(tmp)*treepart(1,j)
- centerofbox(2,box) = centerofbox(2,box)+ &
- & SQRT(tmp)*treepart(2,j)
- centerofbox(3,box) = centerofbox(3,box)+ &
- & SQRT(tmp)*treepart(3,j)
- ENDDO
- tmp = 1.0_MK/totalmass(box)
- centerofbox(1,box) = centerofbox(1,box) * tmp
- centerofbox(2,box) = centerofbox(2,box) * tmp
- centerofbox(3,box) = centerofbox(3,box) * tmp
- ENDIF
-#endif
- ELSE
- IF(ppm_dim.EQ.2)THEN
- centerofbox(1,box) = 0.5_MK*(max_box(1,box) + min_box(1,box))
- centerofbox(2,box) = 0.5_MK*(max_box(2,box) + min_box(2,box))
- ENDIF
- IF(ppm_dim.EQ.3)THEN
- centerofbox(1,box) = 0.5_MK*(max_box(1,box) + min_box(1,box))
- centerofbox(2,box) = 0.5_MK*(max_box(2,box) + min_box(2,box))
- centerofbox(3,box) = 0.5_MK*(max_box(3,box) + min_box(3,box))
- ENDIF
- ENDIF
- ENDDO
- IF (ppm_debug.GT.0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init','computed centers',info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Compute the radius of the leaf boxes
- !-------------------------------------------------------------------------
- DO box=1,nbox
- radius(box) = -1.0_MK
- ENDDO
- IF(ppm_dim.EQ.2)THEN
- DO box=1,nbox
- IF (nchld(box) .NE. 0) CYCLE
- first = lhbx(1,box)
- last = lhbx(2,box)
- DO j=first,last
- diagvec(1) = treepart(1,j) - centerofbox(1,box)
- diagvec(2) = treepart(2,j) - centerofbox(2,box)
- tmp = diagvec(1)*diagvec(1) + diagvec(2)*diagvec(2)
- tmp = SQRT(tmp)
- IF (tmp .GT. radius(box)) THEN
- radius(box) = tmp
- ENDIF
- ENDDO
- ENDDO
- ENDIF
- IF(ppm_dim.EQ.3)THEN
- DO box=1,nbox
- IF (nchld(box) .NE. 0) CYCLE
- first = lhbx(1,box)
- last = lhbx(2,box)
- DO j=first,last
- diagvec(1) = treepart(1,j) - centerofbox(1,box)
- diagvec(2) = treepart(2,j) - centerofbox(2,box)
- diagvec(3) = treepart(3,j) - centerofbox(3,box)
- tmp = diagvec(1)*diagvec(1) + diagvec(2)*diagvec(2)
- tmp = tmp + diagvec(3)*diagvec(3)
- tmp = SQRT(tmp)
- IF (tmp .GT. radius(box)) THEN
- radius(box) = tmp
- ENDIF
- ENDDO
- ENDDO
- ENDIF
- IF (ppm_debug.GT.0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_init','computed radius',info)
- ENDIF
- !-------------------------------------------------------------------------
- ! deallocate local variables
- !-------------------------------------------------------------------------
- ldu1 = 0
- ldu2(1) = 0
- ldu2(2) = 0
- istat = 0
- iopt = ppm_param_dealloc
- CALL ppm_alloc(treepart,ldu2,iopt,info)
- istat=istat+info
- CALL ppm_alloc(treewp,ldu1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(box2proc,ldu1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(boxid,ldu1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(cost,ldu1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(subs2proc,ldu1,iopt,info)
- istat=istat+info
- CALL ppm_alloc(new_subs2proc,ldu1,iopt,info)
- istat=istat+info
-
- IF (istat .NE. 0) THEN
- WRITE(cbuf,'(A,I3,A)') 'for ',istat,'error while dealloc'
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fmm_init',cbuf,__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Nullify data pointers
- !-------------------------------------------------------------------------
- NULLIFY(min_box)
- NULLIFY(max_box)
- NULLIFY(boxcost)
- NULLIFY(centerofbox)
- NULLIFY(totalmass)
- NULLIFY(radius)
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_fmm_init',t0,info)
- RETURN
-
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_init_s_sf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_init_d_sf
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_init_s_vf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_init_d_vf
-#endif
-
diff --git a/src/ppm_fmm_potential.f b/src/ppm_fmm_potential.f
deleted file mode 100644
index 4659bce763da2b5bf033b7243fc5be492f502b57..0000000000000000000000000000000000000000
--- a/src/ppm_fmm_potential.f
+++ /dev/null
@@ -1,976 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fmm_potential
- !-------------------------------------------------------------------------
- !
- ! Purpose : Compute the potential at the target points using
- ! the expansion coefficients
- ! In the parallel case:
- ! Calls ppm_fmm_pretraverse and ppm_fmm_expchange
- ! Maps the target points onto the leaf topolgy
- !
- ! Input : xpunord(:,:) (F) the position of the field points
- ! wpunord(:) (F) the strength of the field points
- ! tp(:,:) (F) the target points
- ! theta (F) acceptance factor
- !
- ! Input/output :
- ! Np (I) the number of field points.
- ! Ntp (I) the number of target points
- !
- ! Output : potential(:) (F) the multipole expansion potential
- ! for each point
- ! size 1:Np
- ! info (I) return status. 0 upon success.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fmm_potential.f,v $
- ! Revision 1.30 2006/09/04 18:34:46 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.29 2006/06/29 10:28:35 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.28 2006/06/20 15:15:51 hiebers
- ! adjusted arguments in call of ppm_fmm_pretraverse
- !
- ! Revision 1.27 2006/06/16 07:52:21 hiebers
- ! Added a new list of topo IDs (topoidlist) to prevent overwriting user defined
- ! topologies
- !
- ! Revision 1.26 2006/06/09 07:56:46 pchatela
- ! Bugfix: weights wp were integers!
- !
- ! Revision 1.25 2005/09/19 13:03:29 polasekb
- ! code cosmetics
- !
- ! Revision 1.24 2005/09/12 09:14:10 hiebers
- ! added mapping of target points
- !
- ! Revision 1.23 2005/09/11 18:05:31 polasekb
- ! (final?) corrected version
- ! (also works parallel :-)
- !
- ! Revision 1.22 2005/09/10 07:50:04 polasekb
- ! changed init of stack for parallel version
- !
- ! Revision 1.21 2005/09/05 06:23:57 polasekb
- ! corrected variable initialisation
- !
- ! Revision 1.20 2005/08/29 15:18:00 polasekb
- ! bugfix when computing direct way
- !
- ! Revision 1.19 2005/08/25 13:52:10 polasekb
- ! mapping corrected from wp to wpunord
- !
- ! Revision 1.18 2005/08/23 14:35:20 polasekb
- ! changed call to ppm_fmm_pretraverse
- !
- ! Revision 1.17 2005/08/23 14:30:05 polasekb
- ! changed call to ppm_fmm_expchange
- !
- ! Revision 1.16 2005/08/23 14:16:50 polasekb
- ! corrected wpunord and wp
- !
- ! Revision 1.15 2005/08/11 15:12:04 polasekb
- ! fixed indices of Outer
- !
- ! Revision 1.14 2005/08/11 13:32:34 polasekb
- ! added variable theta
- !
- ! Revision 1.13 2005/08/08 13:35:52 polasekb
- ! deallocate some local variables
- !
- ! Revision 1.12 2005/08/04 16:04:51 polasekb
- ! removed some data allocation
- !
- ! Revision 1.11 2005/07/29 14:06:52 polasekb
- ! changed check of eqalness to ppm_myeps
- !
- ! Revision 1.10 2005/07/29 12:36:13 polasekb
- ! changed diagonal to radius
- !
- ! Revision 1.9 2005/07/27 14:59:24 polasekb
- ! now using constants from data file
- !
- ! Revision 1.8 2005/07/25 15:01:20 polasekb
- ! bugfix with indices
- !
- ! Revision 1.7 2005/07/25 14:40:31 polasekb
- ! adapted computation of the potential
- !
- ! Revision 1.6 2005/07/21 12:42:07 polasekb
- ! bugfix in allocating an array
- !
- ! Revision 1.5 2005/07/21 08:26:09 polasekb
- ! changed function call, now different target
- ! points and field points can be
- ! specified by the user
- !
- ! Revision 1.4 2005/06/02 19:18:51 polasekb
- ! corrected syntax error
- !
- ! Revision 1.3 2005/05/30 09:37:01 polasekb
- ! bugfix: corrected call to ppm_util_cart2sph
- !
- ! Revision 1.2 2005/05/27 12:42:48 polasekb
- ! initialized further arrays
- !
- ! Revision 1.1 2005/05/27 08:01:23 polasekb
- ! initial implementation
- ! TODO: remove debug output
- !
- ! Revision 0 2005/01/16 15:59:14 polasekb
- ! start
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- SUBROUTINE ppm_fmm_potential_s_sf(xpunord,wpunord,Np,tp,Ntp,theta, &
- & potential,target_topoid,info)
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- SUBROUTINE ppm_fmm_potential_d_sf(xpunord,wpunord,Np,tp,Ntp,theta, &
- & potential,target_topoid,info)
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- SUBROUTINE ppm_fmm_potential_s_vf(xpunord,wpunord,lda,Np,tp,Ntp,theta,&
- & potential,target_topoid,info)
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- SUBROUTINE ppm_fmm_potential_d_vf(xpunord,wpunord,lda,Np,tp,Ntp,theta,&
- & potential,target_topoid,info)
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fmm
- USE ppm_module_fmm_expchange
- USE ppm_module_fmm_pretraverse
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_map_part_util
- USE ppm_module_util_cart2sph
- USE ppm_module_write
- USE ppm_module_topo_check
- USE ppm_module_map_part_ghost
- USE ppm_module_map_part
- USE ppm_module_map_part_global
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Precision
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK), DIMENSION(:,:), POINTER :: xpunord
- INTEGER , INTENT(INOUT) :: Np
- REAL(MK), DIMENSION(:,:), POINTER :: tp
- INTEGER , INTENT(INOUT) :: Ntp
- REAL(MK) , INTENT(IN ) :: theta
- INTEGER , INTENT(IN ) :: target_topoid
- INTEGER , INTENT( OUT) :: info
-#if __DIM == __SFIELD
- REAL(MK), DIMENSION(:), POINTER :: wpunord
- REAL(MK), DIMENSION(:), POINTER :: potential
-#else
- REAL(MK), DIMENSION(:,:), POINTER :: wpunord
- INTEGER :: lda
- REAL(MK), DIMENSION(:,:), POINTER :: potential
-#endif
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- LOGICAL :: check,drct,OK
- INTEGER :: i,j,k,l,cnt,iopt,m,n
- INTEGER :: pcount,ccount
- INTEGER :: Mpart,root,istat
- INTEGER :: first,last,level
- INTEGER :: stackpointer,curbox
- INTEGER :: pexp,isymm
- INTEGER ,DIMENSION(1) :: ldu1
- INTEGER ,DIMENSION(2) :: ldu2
- INTEGER ,DIMENSION(: ), POINTER :: newlpdx,stack
- REAL(MK) :: thetap,eps,angle,reci
- REAL(MK) :: sine,cosine,val,prod
- REAL(MK),DIMENSION(1) :: curboxrho,curboxphi,curboxtheta
- REAL(MK),DIMENSION(:,:), POINTER :: min_box,max_box
- REAL(MK),DIMENSION(:,:), POINTER :: min_sub,max_sub
- COMPLEX(MK),PARAMETER :: CI=(0.0_MK,1.0_MK)
- CHARACTER(LEN=ppm_char) :: cbuf
- REAL(MK) :: dx,dy,dz,dist,rad
- ! parallelisation
- REAL(MK) :: t0,ghostsize,cutoff
- INTEGER :: topoid
- INTEGER ,DIMENSION(: ), POINTER :: part_subtop
- ! fmm
- REAL(MK),DIMENSION(: ), POINTER :: fracfac,boxcost
- REAL(MK),DIMENSION(:,:), POINTER :: sqrtfac,xp,Anm
- REAL(MK),DIMENSION(: ), POINTER :: radius
- REAL(MK),DIMENSION(:,:), POINTER :: Pnm,centerofbox
- COMPLEX(MK),DIMENSION(:,:), POINTER :: Ynm
- COMPLEX(MK),DIMENSION(:,:), POINTER :: Outer
-#if __DIM == __SFIELD
- REAL ,DIMENSION(: ), POINTER :: wp
- COMPLEX(MK),DIMENSION(:,:,:),POINTER :: expansion
-#else
- REAL ,DIMENSION(:,:), POINTER :: wp
- COMPLEX(MK),DIMENSION(:,:,:,:),POINTER :: expansion
-#endif
- !-------------------------------------------------------------------------
- ! Initialize
- !-------------------------------------------------------------------------
- CALL substart('ppm_fmm_potential',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug.GT.0) THEN
- IF (Np .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fmm_potential', &
- & 'number of particles must be > 0 !',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (.NOT. ppm_fmm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_fmm_potential', &
- & 'Please call ppm_fmm_init first',__LINE__,info)
- GOTO 9999
- ENDIF
-
- ENDIF
- !-------------------------------------------------------------------------
- ! Check precision and pointing tree data to correct variables
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- min_box => min_box_s
- max_box => max_box_s
- boxcost => boxcost_s
- centerofbox => centerofbox_s
- radius => radius_s
-#if __DIM == __SFIELD
- expansion => expansion_s_sf
-#else
- expansion => expansion_s_vf
-#endif
- sqrtfac => sqrtfac_s
- fracfac => fracfac_s
- Anm => Anm_s
- eps = ppm_myepss
- Ynm => Ynm_s
- Pnm => Pnm_s
- Outer => Outer_s
-#else
- min_box => min_box_d
- max_box => max_box_d
- boxcost => boxcost_d
- centerofbox => centerofbox_d
- radius => radius_d
-#if __DIM == __SFIELD
- expansion => expansion_d_sf
-#else
- expansion => expansion_d_vf
-#endif
- sqrtfac => sqrtfac_d
- fracfac => fracfac_d
- Anm => Anm_d
- eps = ppm_myepsd
- Ynm => Ynm_d
- Pnm => Pnm_d
- Outer => Outer_d
-#endif
- IF (ppm_nproc .GT. 1) THEN
- !choose lowest level of the tree as topology
- topoid = topoidlist(nlevel)
- !-------------------------------------------------------------------------
- ! Call fmm_expchange to communicate all expansions
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
- CALL ppm_fmm_expchange(t0,info)
-#else
- CALL ppm_fmm_expchange(lda,t0,info)
-#endif
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to call expchange.',info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Map target points
- !-------------------------------------------------------------------------
- CALL ppm_map_part_global(target_topoid,tp,Ntp,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to start global mapping.',info)
- GOTO 9999
- ENDIF
- CALL ppm_map_part_send(Ntp,Mpart,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to start global mapping.',info)
- GOTO 9999
- ENDIF
- CALL ppm_map_part_pop(tp,ppm_dim,Ntp,Mpart,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to start global mapping.',info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Store new number of particles
- !-------------------------------------------------------------------------
- Ntp = Mpart
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Done mapping target points.',info)
- WRITE(cbuf,'(A,I6)') 'Local number of target points now:',Ntp
- CALL ppm_write(ppm_rank,'ppm_fmm_potential',cbuf,info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Check that particles have been mapped correctly
- !-------------------------------------------------------------------------
- IF(ppm_debug.GT.0)THEN
- CALL ppm_topo_check(topoid,tp,Ntp,OK,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to check topology.',info)
- ENDIF
- IF (.NOT.OK) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'target points not mapped correctly!',info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Call pretraversal routine to build communication lists
- !-------------------------------------------------------------------------
- CALL ppm_fmm_pretraverse(tp,Ntp,nlevel,theta,ccount,&
- & part_subtop,pcount,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to call pretraverse.',info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Get particles on local processor stored in part_subtop
- !-------------------------------------------------------------------------
- CALL ppm_map_part_get_sub(topoid,part_subtop,pcount,xpunord,Np,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to call map_part_get_sub.',info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Push the weights and boxpart
- !-------------------------------------------------------------------------
- isymm = 0
- cutoff = 1.0_MK ! can be any number > 0
- ! OA: Is this correct???
- CALL ppm_map_part_ghost_get(topoid,xpunord,ppm_dim,Np,isymm,cutoff,info)
-#if __DIM == __SFIELD
- CALL ppm_map_part_push(wpunord,Np,info) !strengths
-#else
- CALL ppm_map_part_push(wpunord,lda,Np,info) !strengths
-#endif
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to push strengths.',info)
- GOTO 9999
- ENDIF
- CALL ppm_map_part_push(boxpart,Np,info) !boxpart
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to push strengths.',info)
- GOTO 9999
- ENDIF
- CALL ppm_map_part_send(Np,Mpart,info) ! send
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to send particles.',info)
- GOTO 9999
- ENDIF
- CALL ppm_map_part_pop(boxpart,Np,Mpart,info) !boxpart
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to push strengths.',info)
- GOTO 9999
- ENDIF
-#if __DIM == __SFIELD
- CALL ppm_map_part_pop(wpunord,Np,Mpart,info) !strengths
-#else
- CALL ppm_map_part_pop(wpunord,lda,Np,Mpart,info) !strengths
-#endif
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to pop strengths.',info)
- GOTO 9999
- ENDIF !positions
- CALL ppm_map_part_pop(xpunord,ppm_dim,Np,Mpart,info)
- IF (info .NE. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Failed to pop positions.',info)
- GOTO 9999
- ENDIF
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'Done mapping ghost particles.',info)
- WRITE(cbuf,'(A,I6)') 'Received ghost particles:',Mpart-Np
- CALL ppm_write(ppm_rank,'ppm_fmm_potential',cbuf,info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Sort new (ghost) particles
- !-------------------------------------------------------------------------
- ldu1(1) = Mpart
- CALL ppm_alloc(newlpdx,ldu1,ppm_param_alloc_fit,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_potential', &
- & 'error allocating newlpdx',__LINE__,info)
- GOTO 9999
- ENDIF
- newlpdx(1:Np) = lpdx(1:Np)
- cnt = Np
- DO i=1,nbox
- check = .TRUE.
- DO j=Np+1,Mpart
- IF (boxpart(j) .EQ. i) THEN
- cnt = cnt + 1
- IF (((lhbx(1,i) .EQ. 1) .OR. (lhbx(1,i) .EQ. Np+1)) .AND. &
- (check)) THEN
- check = .FALSE.
- lhbx(1,i) = cnt
- lhbx(2,i) = cnt
- newlpdx(cnt) = j
- ELSE
- lhbx(2,i) = lhbx(2,i) + 1
- newlpdx(cnt) = j
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! ATTENTION: now tree lists lhbx and lpdx are not valid anymore
- !-------------------------------------------------------------------------
- ENDIF !ppm_nproc .GT. 1
- !-------------------------------------------------------------------------
- ! Allocate array for potentials of target points
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
-#if __DIM == __SFIELD
- ldu1(1) = Ntp
- CALL ppm_alloc(potential,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_potential', &
- & 'error allocating potential',__LINE__,info)
- GOTO 9999
- ENDIF
-#else
- ldu2(1) = lda
- ldu2(2) = Ntp
- CALL ppm_alloc(potential,ldu2,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_potential', &
- & 'error allocating potential',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Initialize arrays
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
- DO i=1,Ntp
- potential(i) = 0.0_MK
- ENDDO
-#else
- DO i=1,Ntp
- DO j=1,lda
- potential(j,i) = 0.0_MK
- ENDDO
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! allocate and initialize further arrays
- !-------------------------------------------------------------------------
- istat = 0
- ldu1(1) = nbox
- CALL ppm_alloc(stack,ldu1,iopt,info)
- istat = istat + info
- ldu2(1) = 3
- IF (ppm_nproc .GT. 1) THEN
- ldu2(2) = Mpart
- ELSE
- ldu2(2) = Np
- ENDIF
- CALL ppm_alloc(xp,ldu2,iopt,info)
- istat = istat + info
-#if __DIM == __SFIELD
- IF (ppm_nproc .GT. 1) THEN
- ldu1(1) = Mpart
- ELSE
- ldu1(1) = Np
- ENDIF
- CALL ppm_alloc(wp,ldu1,iopt,info)
-#else
- ldu2(1) = lda
- IF (ppm_nproc .GT. 1) THEN
- ldu2(2) = Mpart
- ELSE
- ldu2(2) = Np
- ENDIF
- CALL ppm_alloc(wp,ldu2,iopt,info)
-#endif
- istat = istat + info
- IF (istat .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_potential', &
- & 'error allocating variables',__LINE__,info)
- GOTO 9999
- ENDIF
- stack = (0)
- xp = (0.0_MK,0.0_MK)
-#if __DIM == __SFIELD
- DO i =1,size(wp,1)
- wp(i) = 0.0_MK
- ENDDO
-#else
- DO i =1,size(wp,2)
- DO j =1,lda
- wp(i,j) = 0.0_MK
- ENDDO
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Find the root of the tree (serial) and find the
- ! top level of tree (parallel)
- !-------------------------------------------------------------------------
-#ifdef __VECTOR
- IF (ppm_nproc .GT. 1) THEN
- ! finding top level
- DO i=1,nlevel
- IF (nbpl(i) .GE. ppm_nproc) THEN
- level = i
- ENDIF
- ENDDO
- ELSE
- IF (parent(1) .EQ. ppm_param_undefined) THEN
- root = 1
- ELSE
- DO i=1,nbox
- IF (parent(i) .EQ. ppm_param_undefined) THEN
- root = i
- ENDIF
- ENDDO
- ENDIF
- ENDIF
-#else
- IF (ppm_nproc .GT. 1) THEN
- ! finding top level
- DO i=1,nlevel
- IF (nbpl(i) .GE. ppm_nproc) THEN
- level = i
- EXIT
- ENDIF
- ENDDO
- ELSE
- IF (parent(1) .EQ. ppm_param_undefined) THEN
- root = 1
- ELSE
- DO i=1,nbox
- IF (parent(i) .EQ. ppm_param_undefined) THEN
- root = i
- EXIT
- ENDIF
- ENDDO
- ENDIF
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! order the particles according to the tree
- !-------------------------------------------------------------------------
-#if __DIM == __SFIELD
- IF(ppm_dim.EQ.2)THEN
- IF (ppm_nproc .GT. 1) THEN
- DO i=1,nbox
- first = lhbx(1,i)
- last = lhbx(2,i)
- DO j=first,last
- xp(1,j) = xpunord(1,newlpdx(j))
- xp(2,j) = xpunord(2,newlpdx(j))
- wp(j) = wpunord(newlpdx(j))
- ENDDO
- ENDDO
- ELSE
- DO i=1,nbox
- first = lhbx(1,i)
- last = lhbx(2,i)
- DO j=first,last
- xp(1,j) = xpunord(1,lpdx(j))
- xp(2,j) = xpunord(2,lpdx(j))
- wp(j) = wpunord(lpdx(j))
- ENDDO
- ENDDO
- ENDIF
- ENDIF
- IF(ppm_dim.EQ.3)THEN
- IF (ppm_nproc .GT. 1) THEN
- DO i=1,nbox
- first = lhbx(1,i)
- last = lhbx(2,i)
- DO j=first,last
- xp(1,j) = xpunord(1,newlpdx(j))
- xp(2,j) = xpunord(2,newlpdx(j))
- xp(3,j) = xpunord(3,newlpdx(j))
- wp(j) = wpunord(newlpdx(j))
- ENDDO
- ENDDO
- ELSE
- DO i=1,nbox
- first = lhbx(1,i)
- last = lhbx(2,i)
- DO j=first,last
- xp(1,j) = xpunord(1,lpdx(j))
- xp(2,j) = xpunord(2,lpdx(j))
- xp(3,j) = xpunord(3,lpdx(j))
- wp(j) = wpunord(lpdx(j))
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-#else
- IF(ppm_dim.EQ.2)THEN
- IF (ppm_nproc .GT. 1) THEN
- DO i=1,nbox
- first = lhbx(1,i)
- last = lhbx(2,i)
- DO j=first,last
- xp(1,j) = xpunord(1,newlpdx(j))
- xp(2,j) = xpunord(2,newlpdx(j))
- DO l=1,lda
- wp(l,j) = wpunord(l,newlpdx(j))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i=1,nbox
- first = lhbx(1,i)
- last = lhbx(2,i)
- DO j=first,last
- xp(1,j) = xpunord(1,lpdx(j))
- xp(2,j) = xpunord(2,lpdx(j))
- DO l=1,lda
- wp(l,j) = wpunord(l,lpdx(j))
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
- IF(ppm_dim.EQ.3)THEN
- IF (ppm_nproc .GT. 1) THEN
- DO i=1,nbox
- first = lhbx(1,i)
- last = lhbx(2,i)
- DO j=first,last
- xp(1,j) = xpunord(1,newlpdx(j))
- xp(2,j) = xpunord(2,newlpdx(j))
- xp(3,j) = xpunord(3,newlpdx(j))
- DO l=1,lda
- wp(l,j) = wpunord(l,newlpdx(j))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i=1,nbox
- first = lhbx(1,i)
- last = lhbx(2,i)
- DO j=first,last
- xp(1,j) = xpunord(1,lpdx(j))
- xp(2,j) = xpunord(2,lpdx(j))
- xp(3,j) = xpunord(3,lpdx(j))
- DO l=1,lda
- wp(l,j) = wpunord(l,lpdx(j))
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Compute the potential for the target points
- ! Ntp: number of target points
- !-------------------------------------------------------------------------
- DO i=1,Ntp
- IF (ppm_nproc .GT. 1) THEN
- ! init stack parallel
- stackpointer = 1
- cnt = 0
- !--------------------------------------------------------------------
- ! Collect all boxes at the highest level (doesnt vectorize)
- !--------------------------------------------------------------------
- DO j=1,nbox
- IF (blevel(j) .EQ. level) THEN
- stack(stackpointer) = j
- stackpointer = stackpointer + 1
- cnt = cnt +1
- IF (cnt .EQ. nbpl(level)) THEN
- EXIT
- ENDIF
- ENDIF
- ENDDO
- ELSE
- ! init stack serial
- stackpointer = 1
- stack(stackpointer) = root
- stackpointer = stackpointer + 1
- ENDIF
- DO WHILE (stackpointer .GT. 1)
- !pop top box
- stackpointer = stackpointer - 1
- curbox = stack(stackpointer)
- dx = tp(1,i) - centerofbox(1,curbox)
- dy = tp(2,i) - centerofbox(2,curbox)
- dz = tp(3,i) - centerofbox(3,curbox)
- dist = SQRT(dx*dx + dy*dy + dz*dz)
- !--------------------------------------------------------------------
- ! Checking Barnes-Hut Criterium
- !--------------------------------------------------------------------
- drct = .FALSE.
- IF (radius(curbox) .LE. 0.0_MK) THEN
- !only one particle in box, do direct computation
- drct = .TRUE.
- ENDIF
- IF ((dist/(2*radius(curbox)) .GT. theta) .AND. (.NOT. drct)) THEN
- !-----------------------------------------------------------------
- ! far enough, compute part-box interaction
- !-----------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'far enough',info)
- ENDIF
- !------------------------------------------------------------------
- ! TODO:
- ! Computing the expansion order pexp according to Wang
- !------------------------------------------------------------------
- !thetap = 0.75_MK+0.2_MK*(order-pexp)+0.05_MK*(order-pexp)**2
- pexp = order
- !DO WHILE((thetap .LE. dist/radius(curbox)).AND.(pexp .GT. 3))
- ! pexp = pexp - 1
- ! thetap = 0.75_MK+0.2_MK*(order-pexp)+0.05_MK*(order-pexp)**2
- !ENDDO
- CALL ppm_util_cart2sph(tp(1,i:i),tp(2,i:i),tp(3,i:i),1, &
- & centerofbox(1,curbox),centerofbox(2,curbox), &
- & centerofbox(3,curbox), &
- & curboxrho,curboxtheta,curboxphi,info)
- IF (info .NE. 0) THEN
- CALL ppm_error(ppm_err_sub_failed,'ppm_fmm_potential', &
- & 'Failed calling util_cart2sph',__LINE__,info)
- ENDIF
- !------------------------------------------------------------------
- ! compute expansion
- !------------------------------------------------------------------
- !------------------------------------------------------------------
- ! Compute Legendre polynomial box-particle interaction
- !------------------------------------------------------------------
- reci = 1.0_MK/curboxrho(1)
- sine = SIN(curboxtheta(1))
- cosine = COS(curboxtheta(1))
- val = -sine
- prod = 1.0_MK
- DO m=0,pexp
- Pnm(m,m) = fracfac(m)*prod
- prod = prod * val
- ENDDO
- DO m=0,pexp-1
- Pnm(m+1,m) = cosine*REAL(2*m + 1,MK)*Pnm(m,m)
- ENDDO
- DO n=2,pexp
- val = cosine*REAL(2*n-1,MK)
- DO m=0,n-1
- Pnm(n,m)=(val*Pnm(n-1,m)-REAL(n+m-1,MK)* &
- Pnm(n-2,m))/REAL(n-m,MK)
- ENDDO
- ENDDO
- !------------------------------------------------------------------
- ! Compute Ynm(n,m) and Ynm(n,-m)
- !------------------------------------------------------------------
- DO n=0,pexp
- m = 0
- angle = REAL(m,MK)*curboxphi(1)
- Ynm(n,m) = sqrtfac(n,m)*Pnm(n,m)*CMPLX(COS(angle),SIN(angle))
- DO m=1,n
- angle = REAL(m,MK)*curboxphi(1)
- Ynm(n,m) = sqrtfac(n,m)*Pnm(n,m)* &
- CMPLX(COS(angle),SIN(angle))
- Ynm(n,-m) = CONJG(Ynm(n,m))
- ENDDO
- ENDDO
- !------------------------------------------------------------------
- ! Compute the Outer expansion
- !------------------------------------------------------------------
- prod = 1.0_MK
- DO n=0,pexp
- prod = prod * curboxrho(1)
- DO m=-n,n
- Outer(n,m) = (-1)**n*CI**ABS(m)*Ynm(n,m)/(Anm(n,m)*prod)
- ENDDO
- ENDDO
- !------------------------------------------------------------------
- ! Evaluate potential, using multipole expansion coefficients
- !------------------------------------------------------------------
- DO n=0,pexp
- DO m=-n,n
-#if __DIM == __SFIELD
- potential(i)=potential(i) + expansion(curbox,n,m) &
- & *Outer(n,-m)
-#else
- DO j=1,lda
- potential(j,i)=potential(j,i) + expansion(j,curbox,n,m) &
- & *Outer(n,-m)
- ENDDO
-#endif
- ENDDO
- ENDDO
- ELSE
- !-----------------------------------------------------------------
- ! not far enough, push children if present
- !-----------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'not far enough',info)
- ENDIF
- IF (nchld(curbox) .GT. 0) THEN
- !---------------------------------------------------------------
- ! not far enough, push children if present
- !---------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'push children',info)
- ENDIF
- DO j=1,nchld(curbox)
- stack(stackpointer) = child(j,curbox)
- stackpointer = stackpointer + 1
- ENDDO
-
- ELSE
- !------------------------------------------------------------------
- ! no children, direct computation
- !------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_potential', &
- & 'no children',info)
- ENDIF
- first = lhbx(1,curbox)
- last = lhbx(2,curbox)
- DO j=first,last !loop over particles in leaf
- !-------------------------------------------------------------
- ! Evaluate potential, direct method
- !-------------------------------------------------------------
- dx = xp(1,j) - tp(1,i)
- dy = xp(2,j) - tp(2,i)
- dz = xp(3,j) - tp(3,i)
- rad = dx*dx + dy*dy + dz*dz
- IF(rad.GT.eps)THEN
- rad = 1.0_MK/SQRT(rad)
-#if __DIM == __SFIELD
- potential(i) = potential(i) + wp(j)*rad
-#else
- DO l=1,lda
- potential(l,i) = potential(l,i) + wp(l,j)*rad
- ENDDO
-#endif
- ENDIF
- ENDDO
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Nullify data pointers
- !-------------------------------------------------------------------------
- NULLIFY(min_box)
- NULLIFY(max_box)
- NULLIFY(boxcost)
- NULLIFY(centerofbox)
- NULLIFY(radius)
- !-------------------------------------------------------------------------
- ! Deallocate local data
- !-------------------------------------------------------------------------
- istat = 0
- ldu1(1) = 0
- ldu2(1:2) = 0
- CALL ppm_alloc(newlpdx,ldu1,ppm_param_dealloc,info)
- istat = istat + info
- CALL ppm_alloc(stack,ldu1,ppm_param_dealloc,info)
- istat = istat + info
- CALL ppm_alloc(xp,ldu2,ppm_param_dealloc,info)
- istat = istat + info
- CALL ppm_alloc(wp,ldu2,ppm_param_dealloc,info)
- istat = istat + info
- CALL ppm_alloc(part_subtop,ldu2,ppm_param_dealloc,info)
- istat = istat + info
- IF (istat .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fmm_expansion', &
- & 'error deallocating newlpdx',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_fmm_potential',t0,info)
- RETURN
-
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_potential_s_sf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_potential_d_sf
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_potential_s_vf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_potential_d_vf
-#endif
diff --git a/src/ppm_fmm_pretraverse.f b/src/ppm_fmm_pretraverse.f
deleted file mode 100644
index 22aeae99d3762993d2753698e26ca354b145b318..0000000000000000000000000000000000000000
--- a/src/ppm_fmm_pretraverse.f
+++ /dev/null
@@ -1,420 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fmm_pretraverse
- !-------------------------------------------------------------------------
- !
- ! Purpose : Do a pretraversal for the target points, to determine
- ! which particles are needed for the computation.
- !
- ! Input : tp(:,:) (F) : position of target points
- ! Ntp (I) : number of target points
- ! tolevel (I) : level onto which particles
- ! are mapped to
- !
- !
- ! Input/Output :
- !
- ! Output :
- ! ccount (I) : length of coeff_subtop
- ! part_subtop(:) (I) : array containing needed
- ! particles from other procs
- ! 1st index: subid
- ! pcount (I) : length of part_subtop
- ! info (I) : return status
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fmm_pretraverse.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.18 2007/01/23 09:35:17 hiebers
- ! Bugfix: ppm_internal_topoid needs an topoid (= topoidlist(blevel(curbox)))
- ! as input
- !
- ! Revision 1.17 2006/09/04 18:34:47 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.16 2006/06/29 10:28:36 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.15 2006/06/20 15:14:42 hiebers
- ! change input argument from topoid to the number of the level (tolevel)
- !
- ! Revision 1.14 2005/09/19 13:03:29 polasekb
- ! code cosmetics
- !
- ! Revision 1.13 2005/09/12 13:30:54 polasekb
- ! added ppm_subid
- !
- ! Revision 1.12 2005/09/12 11:38:03 polasekb
- ! changed duplex check to flag-arrays
- !
- ! Revision 1.11 2005/09/11 18:05:31 polasekb
- ! (final?) corrected version
- ! (also works parallel :-)
- !
- ! Revision 1.10 2005/09/11 11:44:46 polasekb
- ! now using correct topoid for leaf boxes
- !
- ! Revision 1.9 2005/09/10 07:50:22 polasekb
- ! changed init of stack for parallel version
- !
- ! Revision 1.8 2005/09/05 06:24:42 polasekb
- ! deallocation of local variables
- ! checking topology
- !
- ! Revision 1.7 2005/08/23 14:35:04 polasekb
- ! added parameter theta (as in potential)
- !
- ! Revision 1.6 2005/08/23 14:32:14 polasekb
- ! corrected acceptance criterion
- !
- ! Revision 1.5 2005/07/29 12:37:32 polasekb
- ! changed diagonal to radius
- !
- ! Revision 1.4 2005/07/21 12:42:28 polasekb
- ! adapted to target points
- !
- ! Revision 1.3 2005/06/04 00:28:29 ivos
- ! Fixed syntax error (XLF) in logical comparisons.
- !
- ! Revision 1.2 2005/06/02 14:35:01 polasekb
- ! changed allocation of variables
- !
- ! Revision 1.1 2005/05/27 08:02:14 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/17 16:02:03 polasekb
- ! start.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_fmm_pretraverse_s(tp,Ntp,tolevel,theta, &
- & ccount,part_subtop,pcount,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_fmm_pretraverse_d(tp,Ntp,tolevel,theta, &
- & ccount,part_subtop,pcount,info)
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fmm
- USE ppm_module_error
- USE ppm_module_typedef
- USE ppm_module_alloc
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_substop
-
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Precision
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- REAL(MK), DIMENSION(:,:), POINTER :: tp
- INTEGER, INTENT(IN ) :: Ntp
- INTEGER, INTENT(IN ) :: tolevel
- REAL(MK), INTENT(IN ) :: theta
- INTEGER, INTENT( OUT) :: ccount
- INTEGER, DIMENSION(: ), POINTER :: part_subtop
- INTEGER, INTENT( OUT) :: pcount
- INTEGER, INTENT( OUT) :: info
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! auxiliary variables
- LOGICAL :: drct
- LOGICAL,DIMENSION(:), POINTER :: flagcoeff,flagpart
- INTEGER :: i,j,cnt,level
- INTEGER :: root,iopt,istat
- REAL(MK) :: dx,dy,dz,dist,rad,t0
- INTEGER :: stackpointer,curbox,cursub
- INTEGER,DIMENSION(:), POINTER :: stack
- INTEGER,DIMENSION(1) :: ldu1
- INTEGER,DIMENSION(2) :: ldu2
- CHARACTER(LEN=256) :: cbuf
- TYPE(ppm_t_topo), POINTER :: topo
- ! parallelisation
- INTEGER :: curtopoid
- INTEGER :: topoid
- INTEGER,DIMENSION(:), POINTER :: lpart_subtop
- INTEGER,DIMENSION(:,:), POINTER :: lcoeff_subtop
- ! fmm
- REAL(MK),DIMENSION(:), POINTER :: radius
- REAL(MK),DIMENSION(:,:),POINTER :: centerofbox
- !-------------------------------------------------------------------------
- ! Initialize
- !-------------------------------------------------------------------------
- CALL substart('ppm_fmm_pretraverse',t0,info)
- !-------------------------------------------------------------------------
- ! Check precision and pointing to the correct variables
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- centerofbox => centerofbox_s
- radius => radius_s
-#else
- centerofbox => centerofbox_d
- radius => radius_d
-#endif
- !-------------------------------------------------------------------------
- ! Find the root of the tree (serial) and
- ! find top level of tree (parallel)
- !-------------------------------------------------------------------------
- topoid = topoidlist(tolevel)
-#ifdef __VECTOR
- IF (ppm_nproc .GT. 1) THEN
- ! finding top level
- DO i=1,nlevel
- IF (nbpl(i) .GE. ppm_nproc) THEN
- level = i
- ENDIF
- ENDDO
- ELSE
- IF (parent(1) .EQ. ppm_param_undefined) THEN
- root = 1
- ELSE
- DO i=1,nbox
- IF (parent(i) .EQ. ppm_param_undefined) THEN
- root = i
- ENDIF
- ENDDO
- ENDIF
- ENDIF
-#else
- IF (ppm_nproc .GT. 1) THEN
- ! finding top level
- DO i=1,nlevel
- IF (nbpl(i) .GE. ppm_nproc) THEN
- level = i
- EXIT
- ENDIF
- ENDDO
- ELSE
- IF (parent(1) .EQ. ppm_param_undefined) THEN
- root = 1
- ELSE
- DO i=1,nbox
- IF (parent(i) .EQ. ppm_param_undefined) THEN
- root = i
- EXIT
- ENDIF
- ENDDO
- ENDIF
- ENDIF
-#endif
- ccount = 0
- pcount = 0
- !-------------------------------------------------------------------------
- ! Allocate and initialize local variables
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- istat = 0
- ldu1(1) = nbox
- CALL ppm_alloc(stack,ldu1,iopt,info)
- istat = istat + info
- CALL ppm_alloc(lpart_subtop,ldu1,iopt,info)
- istat = istat + info
- CALL ppm_alloc(flagcoeff,ldu1,iopt,info)
- istat = istat + info
- CALL ppm_alloc(flagpart,ldu1,iopt,info)
- istat = istat + info
- ldu2(1) = 2
- ldu2(2) = nbox
- CALL ppm_alloc(lcoeff_subtop,ldu2,iopt,info)
- istat = istat + info
- IF (istat .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_pretraverse', &
- & 'error allocating variables',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i=1,nbox
- stack(i) = 0
- lpart_subtop(i) = 0
- lcoeff_subtop(1,i) = 0
- lcoeff_subtop(2,i) = 0
- flagcoeff(i) = .FALSE.
- flagpart(i) = .FALSE.
- ENDDO
- !-------------------------------------------------------------------------
- ! Traverse tree and build list part_subtop and coeff_subtop
- !-------------------------------------------------------------------------
- DO i=1,Ntp
- IF (ppm_nproc .GT. 1) THEN
- ! initialise stack parallel
- stackpointer = 1
- cnt = 0
- !--------------------------------------------------------------------
- ! Collect all boxes at the highest level (doesnt vectorize)
- !--------------------------------------------------------------------
- DO j=1,nbox
- IF (blevel(j) .EQ. level) THEN
- stack(stackpointer) = j
- stackpointer = stackpointer + 1
- cnt = cnt +1
- IF (cnt .EQ. nbpl(level)) THEN
- EXIT
- ENDIF
-
- ENDIF
- ENDDO
- ELSE
- ! initialise stack serial
- stackpointer = 1
- stack(stackpointer) = root
- stackpointer = stackpointer + 1
- ENDIF
- DO WHILE (stackpointer .GT. 1)
- curbox = stack(stackpointer-1)
- dx = tp(1,i) - centerofbox(1,curbox)
- dy = tp(2,i) - centerofbox(2,curbox)
- dz = tp(3,i) - centerofbox(3,curbox)
- dist = SQRT(dx*dx + dy*dy + dz*dz)
- !pop top box
- stackpointer = stackpointer -1
- !--------------------------------------------------------------------
- ! Checking Barnes-Hut Criterium
- !--------------------------------------------------------------------
- IF (radius(curbox) .LE. 0.0_MK) THEN
- !only one particle in box, do direct computation
- drct = .TRUE.
- ENDIF
- IF ((dist/(2*radius(curbox)) .GT. theta) .AND. (.NOT. drct)) THEN
- curtopoid = topoidlist(blevel(curbox))
- cursub = ppm_subid(curbox,blevel(curbox))
- !far enough, compute part-box interaction
- topo => ppm_topo(curtopoid)%t
- IF (ppm_rank .NE. topo%sub2proc(cursub)) THEN
- ! check if its a duplicate
- IF (.NOT. flagcoeff(curbox)) THEN
- ccount = ccount+1
- lcoeff_subtop(1,ccount) = cursub
- lcoeff_subtop(2,ccount) = blevel(curbox)
- flagcoeff(curbox) = .TRUE.
- ENDIF
- ENDIF
- !ELSE : ok, on same processor
- ELSE
- !not far enough, push childern
- IF (nchld(curbox) .GT. 0) THEN
- DO j=1,nchld(curbox)
- IF (stackpointer .LE. nbox) THEN
- stack(stackpointer) = child(j,curbox)
- stackpointer = stackpointer + 1
- ENDIF
- ENDDO
- IF (stackpointer .GT. nbox+1) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_pretraverse', &
- & 'stack overflow',info)
- ENDIF
- ELSE
- cursub = ppm_subid(curbox,tolevel)
- !no children, direct computation
- !particles only needed on the finest topology
- topo => ppm_topo(topoid)%t
- IF (ppm_rank .NE. topo%sub2proc(cursub)) THEN
- IF (.NOT. flagpart(curbox)) THEN
- pcount = pcount +1
- lpart_subtop(pcount) = cursub
- flagpart(curbox) = .TRUE.
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- !-------------------------------------------------------------------------
- ! Allocate the correct size of return variables
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu1(1) = pcount
- CALL ppm_alloc(part_subtop,ldu1,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_fmm_pretraverse', &
- & 'error allocating part_subtop',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i=1,pcount
- part_subtop(i) = lpart_subtop(i)
- ENDDO
- !-------------------------------------------------------------------------
- ! Deallocating local variables
- !-------------------------------------------------------------------------
- istat = 0
- ldu1(1) = 0
- ldu2(1:2) = 0
- CALL ppm_alloc(stack,ldu1,ppm_param_dealloc,info)
- istat = istat + info
- CALL ppm_alloc(lpart_subtop,ldu1,ppm_param_dealloc,info)
- istat = istat + info
- CALL ppm_alloc(lcoeff_subtop,ldu2,ppm_param_dealloc,info)
- istat = istat + info
- CALL ppm_alloc(flagcoeff,ldu2,ppm_param_dealloc,info)
- istat = istat + info
- CALL ppm_alloc(flagpart,ldu2,ppm_param_dealloc,info)
- istat = istat + info
- IF (istat .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_fmm_expansion', &
- & 'error deallocating newlpdx',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_fmm_pretraverse',t0,info)
- RETURN
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_fmm_pretraverse_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_fmm_pretraverse_d
-#endif
diff --git a/src/ppm_fmm_traverse.f b/src/ppm_fmm_traverse.f
deleted file mode 100644
index d919e748d2e32a604b867ff2479b5d003d0e9330..0000000000000000000000000000000000000000
--- a/src/ppm_fmm_traverse.f
+++ /dev/null
@@ -1,463 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_fmm_traverse
- !-------------------------------------------------------------------------
- !
- ! Purpose : Recursive routine to traverse the tree.
- ! Called by the ppm_fmm_expansion subroutine.
- !
- ! Input : root (I) index of the root box.
- ! prec (I) not used dummy argument
- ! to determine precision
- !
- ! Input/output :
- !
- ! Output :
- ! info (I) return status. 0 upon success
- !
- ! Remarks : The recurrences will not vectorize
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_fmm_traverse.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:54 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.15 2006/09/04 18:34:47 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.14 2006/06/29 10:28:36 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.13 2006/06/16 07:52:22 hiebers
- ! Added a new list of topo IDs (topoidlist) to prevent overwriting user defined
- ! topologies
- !
- ! Revision 1.12 2005/09/19 13:03:30 polasekb
- ! code cosmetics
- !
- ! Revision 1.11 2005/09/05 06:27:59 polasekb
- ! checking if box is on proc
- !
- ! Revision 1.10 2005/08/23 14:11:55 polasekb
- ! fixed the sign for the Dnm
- !
- ! Revision 1.9 2005/08/08 13:37:08 polasekb
- ! nullify some data pointers
- !
- ! Revision 1.8 2005/08/04 16:03:17 polasekb
- ! moved data allocation to init
- !
- ! Revision 1.7 2005/07/29 12:35:54 polasekb
- ! changed diagonal to radius
- !
- ! Revision 1.6 2005/07/27 14:59:57 polasekb
- ! now computing centerofbox from children
- !
- ! Revision 1.5 2005/07/25 14:38:19 polasekb
- ! changed call to subroutine,
- ! now saving constants in module_data_fmm file
- !
- ! Revision 1.4 2005/07/21 13:17:03 polasekb
- ! bugfix in do-loop
- !
- ! Revision 1.3 2005/06/02 14:24:01 polasekb
- ! removed variable totalmass
- ! bugfix calling cart2sph
- !
- ! Revision 1.2 2005/05/27 12:44:28 polasekb
- ! removed some debug output
- !
- ! Revision 1.1 2005/05/27 07:59:30 polasekb
- ! initial implementation
- ! TODO: remove debug outputs
- !
- ! Revision 0 2004/12/02 15:59:14 polasekb
- ! start
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- RECURSIVE SUBROUTINE ppm_fmm_traverse_s_sf(root,prec,info)
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- RECURSIVE SUBROUTINE ppm_fmm_traverse_d_sf(root,prec,info)
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- RECURSIVE SUBROUTINE ppm_fmm_traverse_s_vf(root,lda,prec,info)
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- RECURSIVE SUBROUTINE ppm_fmm_traverse_d_vf(root,lda,prec,info)
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_fmm
- USE ppm_module_error
- USE ppm_module_typedef
- USE ppm_module_util_cart2sph
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_substop
-
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Precision
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER , INTENT(IN ) :: root
- REAL(MK) , INTENT(IN ) :: prec !dummy arg for prec.
- INTEGER , INTENT( OUT) :: info
-#if __DIM == __VFIELD
- INTEGER , INTENT(IN ) :: lda
-#endif
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- ! auxiliary variables
- LOGICAL :: onlocalproc
- INTEGER :: m,n,l,j,i,p,iopt
- INTEGER :: fir,las,box,istat,topoid
- INTEGER :: first,last
- REAL(MK) :: sine,cosine,val,prod
- REAL(MK) :: angle,reci,t0
- REAL(MK) :: dx,dy,dz,tmp
- REAL(MK),DIMENSION(: ),POINTER :: box_rho,box_theta,box_phi
- COMPLEX(MK) :: csum
- COMPLEX(MK),PARAMETER :: CI=(0.0_MK,1.0_MK)
- CHARACTER(LEN=ppm_char) :: cbuf
- TYPE(ppm_t_topo), POINTER :: topo
- ! fmm
- REAL(MK),DIMENSION(: ),POINTER :: fracfac,totalmass,radius
- REAL(MK),DIMENSION(:,:),POINTER :: Pnm,Anm,sqrtfac,centerofbox
- COMPLEX(MK),DIMENSION(:,:),POINTER :: Inner,Ynm
-#if __DIM == __SFIELD
- COMPLEX(MK),DIMENSION(:,:,:) ,POINTER :: expansion
-#else
- COMPLEX(MK),DIMENSION(:,:,:,:),POINTER :: expansion
-#endif
- !-------------------------------------------------------------------------
- ! Initialize
- !-------------------------------------------------------------------------
- CALL substart('ppm_fmm_traverse',t0,info)
- !-------------------------------------------------------------------------
- ! Check precision and pointing tree data to correct variables
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- centerofbox => centerofbox_s
- totalmass => totalmass_s
-#if __DIM == __SFIELD
- expansion => expansion_s_sf
-#else
- expansion => expansion_s_vf
-#endif
- radius => radius_s
- Anm => Anm_s
- sqrtfac => sqrtfac_s
- fracfac => fracfac_s
- Ynm => Ynm_s
- Pnm => Pnm_s
- box_rho => rho_s
- box_theta => theta_s
- box_phi => phi_s
- Inner => Inner_s
-#else
- centerofbox => centerofbox_d
- totalmass => totalmass_d
-#if __DIM == __SFIELD
- expansion => expansion_d_sf
-#else
- expansion => expansion_d_vf
-#endif
- radius => radius_d
- Anm => Anm_d
- sqrtfac => sqrtfac_d
- fracfac => fracfac_d
- Ynm => Ynm_d
- Pnm => Pnm_d
- box_rho => rho_d
- box_theta => theta_d
- box_phi => phi_d
- Inner => Inner_d
-#endif
- !-------------------------------------------------------------------------
- ! Check if current root is a leaf,
- ! if yes, no shifting has to be done
- !-------------------------------------------------------------------------
- IF (nchld(root) .EQ. 0) THEN
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_traverse','leaf box',info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Current root has more children, call routine recursively
- !-------------------------------------------------------------------------
- ELSE
- !----------------------------------------------------------------------
- ! Check if box on local proc., if not, no computation for this box
- ! loop doesnt vectorize
- !----------------------------------------------------------------------
- onlocalproc = .FALSE.
- IF (nbpl(blevel(root)) .LT. ppm_nproc) THEN
- !level topology not defined
- onlocalproc = .TRUE.
- ELSE
- topoid = topoidlist(blevel(root))
- topo => ppm_topo(topoid)%t
- DO i=1,topo%nsublist
- IF(ppm_boxid(topo%isublist(i),blevel(root)) .EQ. root)THEN
- onlocalproc = .TRUE.
- EXIT
- ENDIF
- ENDDO
- ENDIF
- IF (onlocalproc) THEN
- DO i=1,nchld(root)
-#if __DIM == __SFIELD
- CALL ppm_fmm_traverse(child(i,root),prec,info)
-#else
- CALL ppm_fmm_traverse(child(i,root),lda,prec,info)
-#endif
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_traverse', &
- & 'Called traverse',info)
- ENDIF
- ENDDO
- !-----------------------------------------------------------------------
- ! Now all children have been called recursively, computation can start
- !-----------------------------------------------------------------------
- !-----------------------------------------------------------------------
- ! Compute centerofbox and totalmass
- !-----------------------------------------------------------------------
- fir = child(1,root)
- las = child((nchld(root)),root)
- totalmass(root) = 0.0_MK
- DO i=fir,las
- totalmass(root) = totalmass(root) + totalmass(i)
- ENDDO
- IF(ppm_dim.EQ.2)THEN
- centerofbox(1,root) = 0.0_MK
- centerofbox(2,root) = 0.0_MK
- DO i= fir,las
- centerofbox(1,root) = centerofbox(1,root) + &
- & centerofbox(1,i)*totalmass(i)
- centerofbox(2,root) = centerofbox(2,root) + &
- & centerofbox(2,i)*totalmass(i)
- ENDDO
- tmp = 1.0_MK/totalmass(root)
- centerofbox(1,root) = centerofbox(1,root)*tmp
- centerofbox(2,root) = centerofbox(2,root)*tmp
- ENDIF
- IF(ppm_dim.EQ.3)THEN
- centerofbox(1,root) = 0.0_MK
- centerofbox(2,root) = 0.0_MK
- centerofbox(3,root) = 0.0_MK
- DO i= fir,las
- centerofbox(1,root) = centerofbox(1,root) + &
- & centerofbox(1,i)*totalmass(i)
- centerofbox(2,root) = centerofbox(2,root) + &
- & centerofbox(2,i)*totalmass(i)
- centerofbox(3,root) = centerofbox(3,root) + &
- & centerofbox(3,i)*totalmass(i)
- ENDDO
- tmp = 1.0_MK/totalmass(root)
- centerofbox(1,root) = centerofbox(1,root)*tmp
- centerofbox(2,root) = centerofbox(2,root)*tmp
- centerofbox(3,root) = centerofbox(3,root)*tmp
- ENDIF
- !-----------------------------------------------------------------------
- ! Initiation of spherical coordinates to zero
- !-----------------------------------------------------------------------
- DO i=1,nchld(root)
- box_rho(i) = 0.0_MK
- box_phi(i) = 0.0_MK
- box_theta(i) = 0.0_MK
- ENDDO
- !-----------------------------------------------------------------------
- ! Compute spherical coordinates of child boxes
- !-----------------------------------------------------------------------
- CALL ppm_util_cart2sph(centerofbox(1,fir:las),centerofbox(2,fir:las), &
- & centerofbox(3,fir:las),nchld(root), &
- & centerofbox(1,root),centerofbox(2,root),centerofbox(3,root), &
- & box_rho(1:nchld(root)),box_theta(1:nchld(root)), &
- & box_phi(1:nchld(root)),info)
- IF (info .NE. 0) THEN
- CALL ppm_error(ppm_err_sub_failed,'ppm_fmm_traverse', &
- & 'Failed calling util_cart2sph',__LINE__,info)
- ENDIF
- DO i=1,nchld(root)
- first = lhbx(1,child(i,root))
- last = lhbx(2,child(i,root))
- IF (last-first+1 .EQ. 0) CYCLE
- !--------------------------------------------------------------------
- ! Compute radius
- !--------------------------------------------------------------------
- box = child(i,root)
- dx = centerofbox(1,box) - centerofbox(1,root)
- dy = centerofbox(2,box) - centerofbox(2,root)
- dz = centerofbox(3,box) - centerofbox(3,root)
- tmp = SQRT(dx**2 + dy**2 + dz**2) + radius(box)
- IF (tmp .GT. radius(root)) THEN
- radius(root) = tmp
- ENDIF
- !--------------------------------------------------------------------
- ! Compute Legendre polynomial
- !--------------------------------------------------------------------
- reci = 1.0_MK/box_rho(i)
- sine = SIN(box_theta(i))
- cosine = COS(box_theta(i))
- val = -sine
- prod = 1.0_MK
- DO m=0,order
- Pnm(m,m) = fracfac(m)*prod
- prod = prod * val
- ENDDO
- DO m=0,order-1
- Pnm(m+1,m) = cosine*REAL(2*m + 1,MK)*Pnm(m,m)
- ENDDO
- DO n=2,order
- val = cosine*REAL(2*n-1,MK)
- DO m=0,n-1
- Pnm(n,m)=(val*Pnm(n-1,m)-REAL(n+m-1,MK)* &
- Pnm(n-2,m))/REAL(n-m,MK)
- ENDDO
- ENDDO
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_traverse','Computed Pnm',info)
- ENDIF
- !--------------------------------------------------------------------
- ! Compute Ynm(n,m) and Ynm(n,-m)
- !--------------------------------------------------------------------
- DO n=0,order
- m = 0
- angle = REAL(m,MK)*box_phi(i)
- Ynm(n,m) = sqrtfac(n,m)*Pnm(n,m)* &
- & CMPLX(COS(angle),SIN(angle))
- DO m=1,n
- angle = REAL(m,MK)*box_phi(i)
- Ynm(n,m) = sqrtfac(n,m)*Pnm(n,m)* &
- & CMPLX(COS(angle),SIN(angle))
- Ynm(n,-m) = CONJG(Ynm(n,m))
- ENDDO
- ENDDO
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_traverse','Computed Ynm',info)
- ENDIF
- !--------------------------------------------------------------------
- ! Compute Inner expansion
- !--------------------------------------------------------------------
- DO n=0,order
- DO m=-n,n
- Inner(n,m)=CI**(-ABS(m))*Anm(n,m)*box_rho(i)**n*Ynm(n,m)
- ENDDO
- ENDDO
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_traverse','Computed Inner',info)
- ENDIF
- !--------------------------------------------------------------------
- ! Compute Dnm(n,m) = expansion coefficient
- !--------------------------------------------------------------------
-#if __DIM == __SFIELD
- DO l=0,order
- DO j=-l,l
- csum = (0.0_MK,0.0_MK)
- DO n=0,l !order
- DO m=MAX(j+n-l,-n),MIN(j+l-n,n) !-n,n
- csum = csum + (-1)**(l-n)*Inner((l-n),(j-m)) &
- & *expansion(child(i,root),n,m)
- ENDDO
- ENDDO
- ! add to expansion in fmm_module_data file
- expansion(root,l,j) = expansion(root,l,j) + csum
- ENDDO
- ENDDO
-#else
- DO l=0,order
- DO j=-l,l
- DO p=1,lda
- csum = (0.0_MK,0.0_MK)
- DO n=0,l !order
- DO m=MAX(j+n-l,-n),MIN(j+l-n,n) !-n,n
- csum = csum + (-1)**(l-n)*Inner((l-n),(j-m)) &
- & *expansion(p,child(i,root),n,m)
- ENDDO
- ENDDO
- ! add to expansion in fmm_module_data file
- expansion(p,root,l,j) = expansion(p,root,l,j) + csum
- ENDDO
- ENDDO
- ENDDO
-#endif
- IF (ppm_debug .GT. 0) THEN
- CALL ppm_write(ppm_rank,'ppm_fmm_traverse','Computed Dnm',info)
- ENDIF
- ENDDO
- ENDIF !on local proc
- ENDIF
- !-------------------------------------------------------------------------
- ! Nullify data pointers
- !-------------------------------------------------------------------------
- NULLIFY(centerofbox)
- NULLIFY(radius)
- NULLIFY(expansion)
- NULLIFY(Anm)
- NULLIFY(sqrtfac)
- NULLIFY(fracfac)
- NULLIFY(Ynm)
- NULLIFY(Pnm)
- NULLIFY(Inner)
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
-9999 CONTINUE
- CALL substop('ppm_fmm_traverse',t0,info)
- RETURN
-
-#if (__KIND == __SINGLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_traverse_s_sf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __SFIELD)
- END SUBROUTINE ppm_fmm_traverse_d_sf
-#elif (__KIND == __SINGLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_traverse_s_vf
-#elif (__KIND == __DOUBLE_PRECISION && __DIM == __VFIELD)
- END SUBROUTINE ppm_fmm_traverse_d_vf
-#endif
diff --git a/src/ppm_gmm_2dmatrix_data.inc b/src/ppm_gmm_2dmatrix_data.inc
deleted file mode 100644
index 320cd7e112702cd31c30899b4b94e220c3978319..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_2dmatrix_data.inc
+++ /dev/null
@@ -1,29 +0,0 @@
- DATA A /1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- &1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- &-1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- &0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- &1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- &-1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, -1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -1.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- &-1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- &-1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- &1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- &1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, &
- &1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, &
- &0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, &
- &0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, &
- &-1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK/
diff --git a/src/ppm_gmm_2dpermut_data.inc b/src/ppm_gmm_2dpermut_data.inc
deleted file mode 100644
index c6ec0aea321679cfac9b6452d00b4739f87143ab..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_2dpermut_data.inc
+++ /dev/null
@@ -1 +0,0 @@
- DATA Aind/1, 2, 5, 6, 3, 4, 7, 8, 9, 10, 13, 14, 11, 12, 15, 16/
diff --git a/src/ppm_gmm_3dmatrix_data.inc b/src/ppm_gmm_3dmatrix_data.inc
deleted file mode 100644
index 1c19cdbcd2af1a193245454b177c90dc7ed60fef..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_3dmatrix_data.inc
+++ /dev/null
@@ -1,600 +0,0 @@
- DATA A(:,1:8) / 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, &
- & 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK /
-
- DATA A(:,9:16) / 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 1.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK /
-
- DATA A(:,17:24) / 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, &
- & -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, &
- & -1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, &
- & 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, &
- & 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK /
-
- DATA A(:,25:32) / 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, -0.5_MK, 0.0_MK, 0.0_MK, -0.5_MK, -0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -0.5_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, -0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, -0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & 2.0_MK, -0.5_MK, -0.5_MK, 0.0_MK, 0.5_MK, 0.5_MK, -0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -0.5_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -0.5_MK, -0.5_MK, 0.0_MK, 1.0_MK, &
- & 0.5_MK, 0.5_MK, -0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -0.5_MK, -0.5_MK, &
- & 0.0_MK, 0.5_MK, 0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, &
- & -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, &
- & 0.0_MK, 2.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 3.0_MK, 0.0_MK, 2.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 3.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.5_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, &
- & 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, 3.0_MK, 0.5_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, 3.0_MK, 1.5_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.25_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.25_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.25_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, &
- & 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 3.0_MK, 0.0_MK, 3.0_MK, &
- & 1.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 3.0_MK, -0.25_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK /
-
- DATA A(:,33:40) / 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -2.0_MK, &
- & -0.5_MK, 0.0_MK, 0.0_MK, 0.5_MK, -0.5_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.5_MK, 0.0_MK, 0.0_MK, -0.5_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, &
- & -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 2.0_MK, &
- & -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, &
- & 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 1.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -1.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, &
- & 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK /
-
- DATA A(:,41:48) / 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 1.0_MK, 2.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & 2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, -1.0_MK, &
- & -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -1.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, &
- & -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, &
- & 0.0_MK, 2.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 3.0_MK, 0.0_MK, 2.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 3.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 2.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, &
- & 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, 3.0_MK, 0.5_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, 3.0_MK, 1.5_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, &
- & 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 3.0_MK, 0.0_MK, 3.0_MK, &
- & 1.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 3.0_MK, -0.25_MK, 0.0_MK, &
- & 1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, -1.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK /
-
- DATA A(:,49:56) / 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, 0.0_MK, -2.0_MK, -3.0_MK, &
- & 0.5_MK, 0.5_MK, 1.0_MK, 0.5_MK, -0.5_MK, 0.5_MK, 1.0_MK, &
- & -0.5_MK, 0.5_MK, -0.5_MK, -1.0_MK, -1.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, -0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 2.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, &
- & -1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 2.0_MK, 2.0_MK, 2.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 2.0_MK, -0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.25_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 2.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 3.0_MK, &
- & 0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -0.5_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 2.0_MK, 4.0_MK, &
- & -1.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, 2.0_MK, -2.0_MK, -4.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, &
- & 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 2.0_MK, &
- & 4.0_MK, 0.0_MK, -2.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, 2.0_MK, -2.0_MK, -4.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, &
- & 2.0_MK, 4.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 2.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 2.0_MK, -2.0_MK, -4.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, &
- & 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 2.0_MK, -2.0_MK, &
- & -4.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK /
-
- DATA A(:,57:64) /0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 2.0_MK, 2.0_MK, 4.0_MK, -1.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, &
- & 1.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 2.0_MK, -2.0_MK, &
- & -4.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 2.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.25_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & 2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -2.0_MK, 1.0_MK, &
- & 2.0_MK, 0.0_MK, 2.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 2.0_MK, &
- & -2.0_MK, -4.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, 2.0_MK, -0.5_MK, -0.5_MK, &
- & 0.5_MK, 0.5_MK, 0.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, &
- & 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, &
- & -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, &
- & 0.0_MK, 2.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -2.0_MK, &
- & 2.0_MK, 2.0_MK, 0.0_MK, 2.0_MK, -2.0_MK, -2.0_MK, 0.0_MK, &
- & 2.0_MK, -2.0_MK, -4.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, 2.0_MK, 1.0_MK, &
- & -1.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, &
- & 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 3.0_MK, 0.0_MK, 2.0_MK, 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, &
- & -2.0_MK, 2.0_MK, 1.0_MK, 0.0_MK, 2.0_MK, -2.0_MK, -1.0_MK, &
- & 0.0_MK, 2.0_MK, -2.0_MK, -4.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 3.0_MK, 0.0_MK, 2.0_MK, &
- & 1.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, -2.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, -1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 3.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 2.0_MK, 4.0_MK, &
- & -1.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 1.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, -1.0_MK, 2.0_MK, -2.0_MK, -4.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 3.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, -0.5_MK, 0.0_MK, 0.0_MK, 0.5_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, -2.0_MK, &
- & 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, &
- & 0.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, 3.0_MK, 0.5_MK, 1.0_MK, &
- & 0.0_MK, 1.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 2.0_MK, &
- & 4.0_MK, 0.0_MK, -2.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, 2.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, 1.0_MK, -2.0_MK, -4.0_MK, 0.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, 2.0_MK, &
- & 0.0_MK, 3.0_MK, 0.5_MK, 1.0_MK, -0.5_MK, 1.0_MK, 1.0_MK, &
- & 0.25_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 1.0_MK, &
- & -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, 0.0_MK, &
- & -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, -2.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, 3.0_MK, 1.5_MK, &
- & 1.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, 0.0_MK, 0.0_MK, 2.0_MK, &
- & 2.0_MK, 4.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 2.0_MK, 0.0_MK, &
- & 2.0_MK, -2.0_MK, -2.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, -4.0_MK, &
- & 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 2.0_MK, 0.0_MK, 3.0_MK, 1.5_MK, 1.0_MK, -0.5_MK, 0.0_MK, &
- & 2.0_MK, 0.125_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 1.0_MK, -1.0_MK, -2.0_MK, 0.0_MK, -1.0_MK, 1.0_MK, 2.0_MK, &
- & 0.0_MK, -2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -1.0_MK, -1.0_MK, &
- & -2.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 3.0_MK, 0.0_MK, 3.0_MK, &
- & 1.5_MK, 0.0_MK, 0.0_MK, 0.0_MK, 3.0_MK, -0.25_MK, 0.0_MK, &
- & 2.0_MK, 2.0_MK, 4.0_MK, 0.0_MK, -2.0_MK, 2.0_MK, 1.0_MK, &
- & 0.0_MK, 2.0_MK, -2.0_MK, -1.0_MK, 0.0_MK, 1.0_MK, -1.0_MK, &
- & -5.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, 0.0_MK, &
- & 0.0_MK, 3.0_MK, 0.0_MK, 3.0_MK, 1.5_MK, 0.0_MK, -0.5_MK, &
- & 0.0_MK, 3.0_MK, -0.125_MK /
-
diff --git a/src/ppm_gmm_3dpermut_data.inc b/src/ppm_gmm_3dpermut_data.inc
deleted file mode 100644
index 8021f694e3203b5b91b07d44494611671a009616..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_3dpermut_data.inc
+++ /dev/null
@@ -1,6 +0,0 @@
- DATA Aind /1, 2, 9, 10, 7, 8, 11, 12, 17, 18, 33, 34, 19, 20, 35, &
- & 36, 3, 4, 13, 14, 21, 22, 15, 16, 23, 24, 37, 38, 29, 39, &
- & 40, 6, 25, 32, 41, 42, 27, 30, 43, 44, 49, 50, 57, 58, 51, &
- & 52, 59, 60, 26, 45, 46, 31, 53, 54, 47, 48, 55, 56, 61, 62,&
- & 28, 63, 64, 5/
-
diff --git a/src/ppm_gmm_add_to_list.inc b/src/ppm_gmm_add_to_list.inc
deleted file mode 100644
index c2ff9f6da342b942dd484540d62074afb6a15149..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_add_to_list.inc
+++ /dev/null
@@ -1,73 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for adding a point to the list gmm_ipos and
- ! growing the list if needed.
- !
- ! INPUT: INTEGER :: i,j,(k) -- point to add
- ! INTEGER :: jsub -- local sub index of point to add
- ! OUTPUT:
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_add_to_list.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2005/05/10 04:48:44 ivos
- ! Split marching and extension routines for faster compilation,
- ! Sharked extension routines, moved all initialization to gmm_init, and
- ! code cosmetics.
- !
- ! Revision 1.2 2005/04/27 01:06:09 ivos
- ! Convergence tests completed, cleaned up code, optmized code (Shark),
- ! and changed structure to allow faster compilation.
- !
- ! Revision 1.1 2005/03/10 01:38:42 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __3D
- npos0 = npos0 + 1
- IF (gmm_lsiz .LT. npos0) THEN
- gmm_lsiz = gmm_lsiz + incr
- iopt = ppm_param_alloc_grow_preserve
- ldu(1) = 4
- ldu(2) = gmm_lsiz
- CALL ppm_alloc(gmm_ipos,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc, &
- & 'ppm_gmm_march','sparse positions GMM_IPOS', &
- & __LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- ! append to gmm_ipos
- gmm_ipos(1,npos0) = i
- gmm_ipos(2,npos0) = j
- gmm_ipos(3,npos0) = k
- gmm_ipos(4,npos0) = jsub
-#elif __DIM == __2D
- npos0 = npos0 + 1
- IF (gmm_lsiz .LT. npos0) THEN
- gmm_lsiz = gmm_lsiz + incr
- iopt = ppm_param_alloc_grow_preserve
- ldu(1) = 3
- ldu(2) = gmm_lsiz
- CALL ppm_alloc(gmm_ipos,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc, &
- & 'ppm_gmm_march','sparse positions GMM_IPOS', &
- & __LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- ! append to gmm_ipos
- gmm_ipos(1,npos0) = i
- gmm_ipos(2,npos0) = j
- gmm_ipos(3,npos0) = jsub
-#endif
diff --git a/src/ppm_gmm_cpt.f b/src/ppm_gmm_cpt.f
deleted file mode 100644
index 0df23119bbf5e025f505ef828dc330c95a2894e7..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_cpt.f
+++ /dev/null
@@ -1,432 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_cpt
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_cpt_2ds(fdata,tol,npts,ipts,closest, &
- & info,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_cpt_2dd(fdata,tol,npts,ipts,closest, &
- & info,chi)
-#endif
-
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_cpt_3ds(fdata,tol,npts,ipts,closest, &
- & info,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_cpt_3dd(fdata,tol,npts,ipts,closest, &
- & info,chi)
-#endif
-#endif
- !!! This routine performs a closest point transform. For each grid point
- !!! adjacent to the interface, the closest point ON the interface is
- !!! returned. ppm_gmm_init must be called BEFORE this routine is invoked.
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
-
- USE ppm_module_data_gmm
- USE ppm_module_gmm_kickoff
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- USE ppm_module_util_qsort
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER :: fdata
- !!! Level data. Rank 3 (for 2D scalar fields),
- !!! Indices: (i,j,[k],isub). Every zero-crossing is interpreted as an
- !!! interface. A ghostsize of 1 is needed on all sides which must be
- !!! filled with the old level function value on input!! Only scalar fdata
- !!! supported.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL:: chi
- !!! Rank 4 (2d) field specifying the positions of the grid nodes.
- !!! 1st index: 1..ppm_dim, then i,j,[k],isub. OPTIONAL. Uniform grid is
- !!! assumed if absent. Ghostlayers of size >=1 must be pre-filled.
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdata
- !!! Level data. Rank 4 (for 3D scalar fields).
- !!! Indices: (i,j,[k],isub). Every zero-crossing is interpreted as an
- !!! interface. A ghostsize of 1 is needed on all sides which must be
- !!! filled with the old level function value on input!! Only scalar fdata
- !!! supported.
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN), OPTIONAL:: chi
- !!! Rank 5 (3d) field specifying the positions of the grid nodes.
- !!! 1st index: 1..ppm_dim, then i,j,[k],isub. OPTIONAL. Uniform grid is
- !!! assumed if absent. Ghostlayers of size >=1 must be pre-filled.
-#endif
- INTEGER , DIMENSION(:,:) , POINTER :: ipts
- !!! Mesh indices of these points. 1st index: i,j,(k),isub (local sub ID);
- !!! 2nd: 1...npts. Will be allocated by this routine.
- REAL(MK), DIMENSION(:,:) , POINTER :: closest
- !!! Locations of the closest points ON the interface. 1st index: x,y,(z),
- !!! 2nd: 1...npts. Will be allocated by this routine.
- REAL(MK) , INTENT(IN ) :: tol
- !!! Relative tolerance for the determined distance to the interface.
- !!! 1E-3 is a good choice. The tolerance is in multiples of grid spacings.
- INTEGER , INTENT( OUT) :: info
- !!! Return status. 0 upon success
- INTEGER , INTENT( OUT) :: npts
- !!! Number of unique grid points adjacent to the interface.
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,iopt,Nt,isub
- INTEGER :: n1,n2,n3,jsub,prev
- INTEGER, DIMENSION(2) :: ldu
- REAL(MK),DIMENSION(:,:), POINTER :: clotmp
- REAL(MK) :: t0,x,y,z,xx,yy,zz,dx,dy,dz
- REAL(MK) :: s,sprev,thresh
- LOGICAL :: lok
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_cpt',t0,info)
- topo => ppm_topo(gmm_topoid)%t
- mesh => topo%mesh(gmm_meshid)
-#if __KIND == __SINGLE_PRECISION
- clotmp => gmm_clos
-#elif __KIND == __DOUBLE_PRECISION
- clotmp => gmm_clod
-#endif
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_cpt', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (tol .LE. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_cpt', &
- & 'tolerance must be >0!',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __3D
- IF (SIZE(fdata,4) .LT. topo%nsublist) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_cpt', &
- & 'field data for some subs is missing',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,1) .LT. maxxhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_cpt', &
- & 'x dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,2) .LT. maxyhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_cpt', &
- & 'y dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,3) .LT. maxzhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_cpt', &
- & 'z dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __DIM == __2D
- IF (SIZE(fdata,3) .LT. topo%nsublist) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_cpt', &
- & 'field data for some subs is missing',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,1) .LT. maxxhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_cpt', &
- & 'x dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,2) .LT. maxyhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_cpt', &
- & 'y dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF ! ppm_debug for argument check
- !-------------------------------------------------------------------------
- ! Find mesh spacing
- !-------------------------------------------------------------------------
- IF (ppm_kind .EQ. ppm_kind_single) THEN
- dx = (topo%max_physs(1)-topo%min_physs(1))/ &
- & REAL(mesh%Nm(1)-1,ppm_kind_single)
- dy = (topo%max_physs(2)-topo%min_physs(2))/ &
- & REAL(mesh%Nm(2)-1,ppm_kind_single)
- IF (ppm_dim .GT. 2) THEN
- dz = (topo%max_physs(3)-topo%min_physs(3))/ &
- & REAL(mesh%Nm(3)-1, &
- & ppm_kind_single)
- ENDIF
- ELSE
- dx = (topo%max_physs(1)-topo%min_physs(1))/ &
- & REAL(mesh%Nm(1)-1,ppm_kind_double)
- dy = (topo%max_physs(2)-topo%min_physs(2))/ &
- & REAL(mesh%Nm(2)-1,ppm_kind_double)
- IF (ppm_dim .GT. 2) THEN
- dz = (topo%max_physs(3)-topo%min_physs(3))/ &
- & REAL(mesh%Nm(3)-1, &
- & ppm_kind_double)
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Get non-unique closest points. We assume that the largest occuring
- ! values in fdata are outside of the narrow band.
- !-------------------------------------------------------------------------
- Nt = -1 ! leave fdata untouched !
- thresh = 0.99_MK*MAXVAL(ABS(fdata))
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_kickoff(fdata,tol,thresh,info,Nt,iptstmp,clotmp,chi=chi)
- ELSE
- CALL ppm_gmm_kickoff(fdata,tol,thresh,info,Nt,iptstmp,clotmp)
- ENDIF
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_cpt', &
- & 'Starting GMM failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Hash mesh coordinates to key
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu(1) = Nt
- CALL ppm_alloc(key,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_cpt', &
- & 'sort key KEY',__LINE__,info)
- GOTO 9999
- ENDIF
- n1 = maxxhi
- n2 = maxxhi*maxyhi
- n3 = n2*maxzhi
- DO i=1,Nt
- key(i) = iptstmp(1,i) + (iptstmp(2,i)-1)*n1 + (iptstmp(3,i)-1)*n2
-#if __DIM == __3D
- key(i) = key(i) + (iptstmp(4,i)-1)*n3
-#endif
- ENDDO
- !-------------------------------------------------------------------------
- ! Sort
- !-------------------------------------------------------------------------
- CALL ppm_util_qsort(key,idx,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_cpt', &
- & 'Sorting failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Find the number of unique points
- !-------------------------------------------------------------------------
- npts = 0
- prev = -1
- DO i=1,Nt
- IF (key(idx(i)) .NE. prev) THEN
- npts = npts + 1
- prev = key(idx(i))
- ENDIF
- ENDDO
- !-------------------------------------------------------------------------
- ! Allocate memory for unique CPT
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldu(1) = ppm_dim
- ldu(2) = npts
- CALL ppm_alloc(closest,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_cpt', &
- & 'closest point transform CLOSEST',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu(1) = ppm_dim+1
- ldu(2) = npts
- CALL ppm_alloc(ipts,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_cpt', &
- & 'closest point transform CLOSEST',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Store unique CPT
- !-------------------------------------------------------------------------
- npts = 0
- prev = -1
-#if __DIM == __3D
- DO i=1,Nt
- IF (key(idx(i)) .NE. prev) THEN
- npts = npts + 1
- ipts(1,npts) = iptstmp(1,idx(i))
- ipts(2,npts) = iptstmp(2,idx(i))
- ipts(3,npts) = iptstmp(3,idx(i))
- ipts(4,npts) = iptstmp(4,idx(i))
- prev = key(idx(i))
- sprev = HUGE(sprev)
- ENDIF
- isub = ipts(4,npts)
- jsub = topo%isublist(isub)
- IF (PRESENT(chi)) THEN
- x = chi(1,ipts(1,npts),ipts(2,npts),ipts(3,npts),isub)
- y = chi(2,ipts(1,npts),ipts(2,npts),ipts(3,npts),isub)
- z = chi(3,ipts(1,npts),ipts(2,npts),ipts(3,npts),isub)
- ELSE
- IF (ppm_kind .EQ. ppm_kind_single) THEN
- x = topo%min_subs(1,jsub) + (ipts(1,npts)-1)*dx
- y = topo%min_subs(2,jsub)+ (ipts(2,npts)-1)*dy
- z = topo%min_subs(3,jsub)+ (ipts(3,npts)-1)*dz
- ELSE
- x = topo%min_subd(1,jsub) + (ipts(1,npts)-1)*dx
- y = topo%min_subd(2,jsub) + (ipts(2,npts)-1)*dy
- z = topo%min_subd(3,jsub) + (ipts(3,npts)-1)*dz
- ENDIF
- ENDIF
- xx = clotmp(1,idx(i))
- yy = clotmp(2,idx(i))
- zz = clotmp(3,idx(i))
- s = (xx-x)*(xx-x) + (yy-y)*(yy-y) + (zz-z)*(zz-z)
- IF (s .LT. sprev) THEN
- closest(1,npts) = xx
- closest(2,npts) = yy
- closest(3,npts) = zz
- sprev = s
- ENDIF
- ENDDO
-#elif __DIM == __2D
- DO i=1,Nt
- IF (key(idx(i)) .NE. prev) THEN
- npts = npts + 1
- ipts(1,npts) = iptstmp(1,idx(i))
- ipts(2,npts) = iptstmp(2,idx(i))
- ipts(3,npts) = iptstmp(3,idx(i))
- prev = key(idx(i))
- sprev = HUGE(sprev)
- ENDIF
- isub = ipts(3,npts)
- jsub = topo%isublist(isub)
- IF (PRESENT(chi)) THEN
- x = chi(1,ipts(1,npts),ipts(2,npts),isub)
- y = chi(2,ipts(1,npts),ipts(2,npts),isub)
- ELSE
- IF (ppm_kind .EQ. ppm_kind_single) THEN
- x = topo%min_subs(1,jsub) + (ipts(1,npts)-1)*dx
- y = topo%min_subs(2,jsub)+ (ipts(2,npts)-1)*dy
- ELSE
- x = topo%min_subd(1,jsub) + (ipts(1,npts)-1)*dx
- y = topo%min_subd(2,jsub) + (ipts(2,npts)-1)*dy
- ENDIF
- ENDIF
- xx = clotmp(1,idx(i))
- yy = clotmp(2,idx(i))
- s = (xx-x)*(xx-x) + (yy-y)*(yy-y)
- IF (s .LT. sprev) THEN
- closest(1,npts) = xx
- closest(2,npts) = yy
- sprev = s
- ENDIF
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Free temp memory
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(iptstmp,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_cpt', &
- & 'temporary point list IPTSTMP',__LINE__,info)
- ENDIF
- CALL ppm_alloc(clotmp,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_cpt', &
- & 'temporary closest points CLOTMP',__LINE__,info)
- ENDIF
-#if __KIND == __SINGLE_PRECISION
- NULLIFY(gmm_clos)
-#elif __KIND == __DOUBLE_PRECISION
- NULLIFY(gmm_clod)
-#endif
- CALL ppm_alloc(idx,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_cpt', &
- & 'Permutation index IDX',__LINE__,info)
- ENDIF
- CALL ppm_alloc(key,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_cpt', &
- & 'sort key KEY',__LINE__,info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_cpt',t0,info)
- RETURN
-
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_cpt_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_cpt_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_cpt_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_cpt_3dd
-#endif
-#endif
diff --git a/src/ppm_gmm_create_2dmatrix.m b/src/ppm_gmm_create_2dmatrix.m
deleted file mode 100644
index 6fe24db75ad777e7f908ddc6b574bd6b2cbbd0f7..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_create_2dmatrix.m
+++ /dev/null
@@ -1,74 +0,0 @@
-% compute and factorize the matrix for the bi-cubic interpolation in 2D
-% in ppm_gmm_kickoff.
-%
-% $Log: ppm_gmm_create_2dmatrix.m,v $
-% Revision 1.1.1.1 2007/07/13 10:18:55 ivos
-% CBL version of the PPM library
-%
-% Revision 1.2 2005/03/10 01:54:49 ivos
-% Removed debug output.
-%
-% Revision 1.1 2005/03/10 01:53:00 ivos
-% Initial check-in.
-%
-%-------------------------------------------------------------------------------
- A = zeros(16,16);
- for n=0:3,
- nm1 = n-1;
- % 0.0**n
- ohn = 0.0;
- if (n==0), ohn = 1.0; end;
- % 0.0**(n-1)
- ohnm1 = 0.0;
- if (n==1), ohnm1 = 1.0; end;
- for m=0:3,
- mm1 = m-1;
- % 0.0**m
- ohm = 0.0;
- if (m==0), ohm = 1.0; end;
- % 0.0**(m-1)
- ohmm1 = 0.0;
- if (m==1), ohmm1 = 1.0; end;
- % coefficient index
- ind = 4*n+m+1;
- % m --> x
- % n --> y
- %-------------------------------------------------------------
- % VALUES
- %-------------------------------------------------------------
- A(1,ind) = ohm*ohn;
- A(2,ind) = ohn;
- A(3,ind) = ohm;
- A(4,ind) = 1.0;
- %-------------------------------------------------------------
- % Dx
- %-------------------------------------------------------------
- A(5,ind) = m*ohmm1*ohn;
- A(6,ind) = m*ohn;
- A(7,ind) = m*ohmm1;
- A(8,ind) = m;
- %-------------------------------------------------------------
- % Dy
- %-------------------------------------------------------------
- A(9,ind) = n*ohm*ohnm1;
- A(10,ind) = n*ohnm1;
- A(11,ind) = n*ohm;
- A(12,ind) = n;
- %-------------------------------------------------------------
- % DxDy
- %-------------------------------------------------------------
- f = m*n;
- A(13,ind) = f*ohmm1*ohnm1;
- A(14,ind) = f*ohnm1;
- A(15,ind) = f*ohmm1;
- A(16,ind) = f;
- end;
- end;
-
- [L,U,P] = lu(A);
- ALU = (L-eye(16))+U;
- ind = P*[1:1:16]';
- save 'gaga_ind.dat' ind -ASCII;
- ALUT = ALU'; % FORTRAN HAS COLUMN MAJOR
- save 'gaga_a.dat' ALUT -ASCII;
-
diff --git a/src/ppm_gmm_create_3dmatrix.m b/src/ppm_gmm_create_3dmatrix.m
deleted file mode 100644
index 7ddf36416d30d89df1fee241abdf8dd3d4776196..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_create_3dmatrix.m
+++ /dev/null
@@ -1,144 +0,0 @@
-% compute and factorize the matrix for the tri-cubic interpolation in 3D
-% in ppm_gmm_kickoff.
-%
-% $Log: ppm_gmm_create_3dmatrix.m,v $
-% Revision 1.1.1.1 2007/07/13 10:18:55 ivos
-% CBL version of the PPM library
-%
-% Revision 1.1 2005/03/10 01:53:00 ivos
-% Initial check-in.
-%
-%-------------------------------------------------------------------------------
- A = zeros(64,64);
- for p=0:3,
- pm1 = p-1;
- % 0.0**p
- ohp = 0.0;
- if (p==0), ohp = 1.0; end;
- % 0.0**(p-1)
- ohpm1 = 0.0;
- if (p==1), ohpm1 = 1.0; end;
- for n=0:3,
- nm1 = n-1;
- % 0.0**n
- ohn = 0.0;
- if (n==0), ohn = 1.0; end;
- % 0.0**(n-1)
- ohnm1 = 0.0,
- if (n==1), ohnm1 = 1.0; end;
- for m=0:3,
- mm1 = m-1;
- % 0.0**m
- ohm = 0.0;
- if (m==0), ohm = 1.0; end;
- % 0.0**(m-1)
- ohmm1 = 0.0;
- if (m==1), ohmm1 = 1.0; end;
- % coefficient index
- ind = 16*p+4*n+m+1;
- % m --> x
- % n --> y
- % p --> z
- %-------------------------------------------------------------
- % VALUES
- %-------------------------------------------------------------
- A(1,ind) = ohm*ohn*ohp;
- A(2,ind) = ohn*ohp;
- A(3,ind) = ohm*ohp;
- A(4,ind) = ohp;
- A(5,ind) = ohm*ohn;
- A(6,ind) = ohn;
- A(7,ind) = ohm;
- A(8,ind) = 1.0;
- %-------------------------------------------------------------
- % Dx
- %-------------------------------------------------------------
- A(9,ind) = m*ohmm1*ohn*ohp;
- A(10,ind) = m*ohn*ohp;
- A(11,ind) = m*ohmm1*ohp;
- A(12,ind) = m*ohp;
- A(13,ind) = m*ohmm1*ohn;
- A(14,ind) = m*ohn;
- A(15,ind) = m*ohmm1;
- A(16,ind) = m;
- %-------------------------------------------------------------
- % Dy
- %-------------------------------------------------------------
- A(17,ind) = n*ohm*ohnm1*ohp;
- A(18,ind) = n*ohnm1*ohp;
- A(19,ind) = n*ohm*ohp;
- A(20,ind) = n*ohp;
- A(21,ind) = n*ohm*ohnm1;
- A(22,ind) = n*ohnm1;
- A(23,ind) = n*ohm;
- A(24,ind) = n;
- %-------------------------------------------------------------
- % Dz
- %-------------------------------------------------------------
- A(25,ind) = p*ohm*ohn*ohpm1;
- A(26,ind) = p*ohn*ohpm1;
- A(27,ind) = p*ohm*ohpm1;
- A(28,ind) = p*ohpm1;
- A(29,ind) = p*ohm*ohn;
- A(30,ind) = p*ohn;
- A(31,ind) = p*ohm;
- A(32,ind) = p;
- %-------------------------------------------------------------
- % DxDy
- %-------------------------------------------------------------
- f = m*n;
- A(33,ind) = f*ohmm1*ohnm1*ohp;
- A(34,ind) = f*ohnm1*ohp;
- A(35,ind) = f*ohmm1*ohp;
- A(36,ind) = f*ohp;
- A(37,ind) = f*ohmm1*ohnm1;
- A(38,ind) = f*ohnm1;
- A(39,ind) = f*ohmm1;
- A(40,ind) = f;
- %-------------------------------------------------------------
- % DxDz
- %-------------------------------------------------------------
- f = m*p;
- A(41,ind) = f*ohmm1*ohn*ohpm1;
- A(42,ind) = f*ohn*ohpm1;
- A(43,ind) = f*ohmm1*ohpm1;
- A(44,ind) = f*ohpm1;
- A(45,ind) = f*ohmm1*ohn;
- A(46,ind) = f*ohn;
- A(47,ind) = f*ohmm1;
- A(48,ind) = f;
- %-------------------------------------------------------------
- % DyDz
- %-------------------------------------------------------------
- f = n*p;
- A(49,ind) = f*ohm*ohnm1*ohpm1;
- A(50,ind) = f*ohnm1*ohpm1;
- A(51,ind) = f*ohm*ohpm1;
- A(52,ind) = f*ohpm1;
- A(53,ind) = f*ohm*ohnm1;
- A(54,ind) = f*ohnm1;
- A(55,ind) = f*ohm;
- A(56,ind) = f;
- %-------------------------------------------------------------
- % DxDyDz
- %-------------------------------------------------------------
- f = m*n*p;
- A(57,ind) = f*ohmm1*ohnm1*ohpm1;
- A(58,ind) = f*ohnm1*ohpm1;
- A(59,ind) = f*ohmm1*ohpm1;
- A(60,ind) = f*ohpm1;
- A(61,ind) = f*ohmm1*ohnm1;
- A(62,ind) = f*ohnm1;
- A(63,ind) = f*ohmm1;
- A(64,ind) = f;
- end;
- end;
- end;
-
- [L,U,P] = lu(A);
- ALU = (L-eye(64))+U;
- ind = P*[1:1:64]';
- save 'gaga_ind.dat' ind -ASCII;
- ALUT = ALU'; % FORTRAN HAS COLUMN MAJOR
- save 'gaga_a.dat' ALUT -ASCII;
-
diff --git a/src/ppm_gmm_extend.f b/src/ppm_gmm_extend.f
deleted file mode 100644
index aa52ff3d534ba9fb537965cb9812bfe4e0a90387..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_extend.f
+++ /dev/null
@@ -1,718 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_extend
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __KICKOFF == __YES
-#if __DIM == __2D
-#if __TYPE == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_2d_ksca_s(ivalue,fdata,udata,tol, &
- & width,order,info,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_2d_ksca_d(ivalue,fdata,udata,tol, &
- & width,order,info,chi,MaxIter)
-#endif
-#elif __TYPE == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_2d_kvec_s(ivalue,fdata,udata,lda,tol, &
- & width,order,info,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_2d_kvec_d(ivalue,fdata,udata,lda,tol, &
- & width,order,info,chi,MaxIter)
-#endif
-#endif
-#elif __DIM == __3D
-#if __TYPE == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_3d_ksca_s(ivalue,fdata,udata,tol, &
- & width,order,info,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_3d_ksca_d(ivalue,fdata,udata,tol, &
- & width,order,info,chi,MaxIter)
-#endif
-#elif __TYPE == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_3d_kvec_s(ivalue,fdata,udata,lda, &
- & tol,width,order,info,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_3d_kvec_d(ivalue,fdata,udata,lda, &
- & tol,width,order,info,chi,MaxIter)
-#endif
-#endif
-#endif
-#elif __KICKOFF == __NO
-#if __DIM == __2D
-#if __TYPE == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_2d_tsca_s(ivalue,fdata,udata,tol, &
- & width,order,info,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_2d_tsca_d(ivalue,fdata,udata,tol, &
- & width,order,info,chi,MaxIter)
-#endif
-#elif __TYPE == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_2d_tvec_s(ivalue,fdata,udata,lda,tol, &
- & width,order,info,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_2d_tvec_d(ivalue,fdata,udata,lda,tol, &
- & width,order,info,chi,MaxIter)
-#endif
-#endif
-#elif __DIM == __3D
-#if __TYPE == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_3d_tsca_s(ivalue,fdata,udata,tol, &
- & width,order,info,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_3d_tsca_d(ivalue,fdata,udata,tol, &
- & width,order,info,chi,MaxIter)
-#endif
-#elif __TYPE == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_3d_tvec_s(ivalue,fdata,udata,lda, &
- & tol,width,order,info,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_3d_tvec_d(ivalue,fdata,udata,lda, &
- & tol,width,order,info,chi,MaxIter)
-#endif
-#endif
-#endif
-#endif
- !!! This routine extends a function defined on the interface to the whole
- !!! band on which the level function is defined. The extension is done
- !!! such that the gradient of the function is perpendicular to the
- !!! gradient of the level function. ppm_gmm_init must be called BEFORE
- !!! this routine is invoked.
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_numerics_data
- USE ppm_module_data_gmm
- USE ppm_module_gmm_init
- USE ppm_module_gmm_cpt
- USE ppm_module_gmm_march
- USE ppm_module_gmm_finalize
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KICKOFF == __YES
-#if __KIND == __SINGLE_PRECISION
- INTERFACE
- FUNCTION ivalue(x,y,info)
- REAL(KIND(1.0E0)), INTENT(IN) :: x,y
- REAL(KIND(1.0E0)) :: ivalue
- INTEGER, INTENT(OUT) :: info
- END FUNCTION ivalue
- END INTERFACE
-#elif __KIND == __DOUBLE_PRECISION
- INTERFACE
- FUNCTION ivalue(x,y,info)
- REAL(KIND(1.0D0)), INTENT(IN) :: x,y
- REAL(KIND(1.0D0)) :: ivalue
- INTEGER, INTENT(OUT) :: info
- END FUNCTION ivalue
- END INTERFACE
-#endif
-#else
- REAL(MK) , INTENT(IN ) :: ivalue
- !!! A (F) scalar value defining a cutoff. Points closer to the interface
- !!! than this cutoff will be kept to initialize the marching. The cpt is
- !!! skipped in this case.
-#endif
-#if __TYPE == __SFIELD
- REAL(MK), DIMENSION(:,:,:) , POINTER :: udata
-#elif __TYPE == __VFIELD
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: udata
- INTEGER , INTENT(IN ) :: lda
- !!! Only present for vector udata. Gives the length of the leading
- !!! dimension of udata. All elements will be equally extended.
-#endif
- REAL(MK), DIMENSION(:,:,:) , POINTER :: fdata
- !!! Level function data. Needs to be defined in a narrow band of
- !!! specific width around the interface. The zero level is interpreted
- !!! to be the interface. Always a scalar field. THIS NEEDS TO BE
- !!! PROPERLY ALLOCATED ON INPUT, INCLUDING GHOST LAYERS OF SIZE order.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN),OPTIONAL:: chi
- !!! rank 4 (2d) field specifying the positions of the
- !!! grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub. OPTIONAL.
- !!! Uniform grid is assumed if absent. Ghostlayers of size >=1 must
- !!! be pre-filled.
-#elif __DIM == __3D
-#if __KICKOFF == __YES
-#if __KIND == __SINGLE_PRECISION
- INTERFACE
- FUNCTION ivalue(x,y,z,info)
- REAL(KIND(1.0E0)), INTENT(IN) :: x,y,z
- REAL(KIND(1.0E0)) :: ivalue
- INTEGER, INTENT(OUT) :: info
- END FUNCTION ivalue
- END INTERFACE
-#elif __KIND == __DOUBLE_PRECISION
- INTERFACE
- FUNCTION ivalue(x,y,z,info)
- REAL(KIND(1.0D0)), INTENT(IN) :: x,y,z
- REAL(KIND(1.0D0)) :: ivalue
- INTEGER, INTENT(OUT) :: info
- END FUNCTION ivalue
- END INTERFACE
-#endif
- !!! Function pointer to the function computing the value of the function
- !!! on the interface: (F) ivalue(x,y[,z]) The function may assume that
- !!! the point (x,y[,z]) is on the interface.
-#else
- REAL(MK) , INTENT(IN ) :: ivalue
- !!! A (F) scalar value defining a cutoff. Points closer to the interface
- !!! than this cutoff will be kept to initialize the marching. The cpt is
- !!! skipped in this case.
-#endif
-#if __TYPE == __SFIELD
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: udata
- !!! Field of the function to be extended, defined in the same narrow
- !!! band as the level function. Values outside this band are set to
- !!! HUGE. This has to be allocated to proper size incl. ghost layers
- !!! of size order! If ivalue is a function pointer, udata will be
- !!! completely replaced. If ivalue is a scalar, the points closer to
- !!! the interface than this scalar are kept unchanged. Can be a vector
- !!! or a scalar field. If vector, lda must be given.
-#elif __TYPE == __VFIELD
- REAL(MK), DIMENSION(:,:,:,:,:) , POINTER :: udata
- !!! Field of the function to be extended, defined in the same narrow
- !!! band as the level function. Values outside this band are set to
- !!! HUGE. This has to be allocated to proper size incl. ghost layers
- !!! of size order! If ivalue is a function pointer, udata will be
- !!! completely replaced. If ivalue is a scalar, the points closer to
- !!! the interface than this scalar are kept unchanged. Can be a vector
- !!! or a scalar field. If vector, lda must be given.
- INTEGER , INTENT(IN ) :: lda
- !!! Only present for vector udata. Gives the length of the leading
- !!! dimension of udata. All elements will be equally extended.
-#endif
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdata
- !!! Level function data. Needs to be defined in a narrow band of
- !!! specific width around the interface. The zero level is interpreted
- !!! to be the interface. Always a scalar field. THIS NEEDS TO BE
- !!! PROPERLY ALLOCATED ON INPUT, INCLUDING GHOST LAYERS OF SIZE order.
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN),OPTIONAL:: chi
- !!! rank 5 (3d) field specifying the positions of the
- !!! grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub. OPTIONAL.
- !!! Uniform grid is assumed if absent. Ghostlayers of size >=1 must
- !!! be pre-filled.
-#endif
- INTEGER , INTENT(IN ) :: order
- !!! Desired order of the method. One of:
- !!!
- !!! *ppm_param_order_1
- !!! *ppm_param_order_2
- !!! *ppm_param_order_3
- REAL(MK) , INTENT(IN ) :: tol
- !!! Relative tolerance for the determined distance to the interface.
- !!! 1E-3 is a good choice. The tolerance is in multiples of grid spacings
- REAL(MK) , INTENT(IN ) :: width
- !!! Width of the narrow band to be produced on each side of the interface.
- INTEGER , INTENT( OUT) :: info
- !!! Return status. 0 upon success
- INTEGER , OPTIONAL , INTENT(IN ) :: MaxIter
- !!! OPTIONAL argument specifying the maximum number of allowed
- !!! iterations. This can be useful since a cyclic dependency in the
- !!! GMM algorithms could cause infinite loops. In each iteration at least
- !!! one point is computed.
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: isub,npts,MaxIt
- INTEGER :: i,j,k,p
- INTEGER :: iopt,jsub,ida
- INTEGER , DIMENSION(4) :: ldl,ldu
- REAL(MK) :: t0,x,y,z,big
- LOGICAL :: lok
- REAL(MK), DIMENSION(:,:), POINTER :: closest
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-#if __TYPE == __VFIELD
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,: ), POINTER :: ext_wrk
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: ext_wrk
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_extend',t0,info)
- big = HUGE(big)
- topo => ppm_topo(gmm_topoid)%t
- mesh => topo%mesh(gmm_meshid)
- !-------------------------------------------------------------------------
- ! Set pointers
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- closest => gmm_clos2
-#elif __KIND == __DOUBLE_PRECISION
- closest => gmm_clod2
-#endif
-#if __TYPE == __VFIELD
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- ext_wrk => ext_wrk_2ds
-#elif __KIND == __DOUBLE_PRECISION
- ext_wrk => ext_wrk_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- ext_wrk => ext_wrk_3ds
-#elif __KIND == __DOUBLE_PRECISION
- ext_wrk => ext_wrk_3dd
-#endif
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_extend', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (tol .LE. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_extend', &
- & 'tolerance must be >0!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (width .LE. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_extend', &
- & 'width must be >0!',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __TYPE == __VFIELD
- IF (lda .LT. 1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_extend', &
- & 'lda must be >=1 for vector data',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF ! ppm_debug for argument check
-
-#if __KICKOFF == __YES
- !-------------------------------------------------------------------------
- ! Closest point transform on fdata
- !-------------------------------------------------------------------------
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_cpt(fdata,tol,npts,iptstmp2,closest,info,chi)
- ELSE
- CALL ppm_gmm_cpt(fdata,tol,npts,iptstmp2,closest,info)
- ENDIF
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'Closest point transform failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Allocate udata
- !-------------------------------------------------------------------------
-! iopt = ppm_param_alloc_fit
-! ldl(1) = 1 - ghostsize(1)
-! ldl(2) = 1 - ghostsize(2)
-! ldl(3) = 1 - ghostsize(3)
-! ldl(4) = 1
-! ldu(1) = maxxhi + ghostsize(1)
-! ldu(2) = maxyhi + ghostsize(2)
-! ldu(3) = maxzhi + ghostsize(3)
-! ldu(4) = topo%nsublist
-! CALL ppm_alloc(udata,ldl,ldu,iopt,info)
-! IF (info .NE. ppm_param_success) THEN
-! info = ppm_error_fatal
-! CALL ppm_error(ppm_err_alloc,'ppm_gmm_extend', &
-! & 'function data UDATA',__LINE__,info)
-! GOTO 9999
-! ENDIF
- udata = HUGE(x)
- !-------------------------------------------------------------------------
- ! Assign each point the value of its closest point on the
- ! interface.
- !-------------------------------------------------------------------------
-#if __DIM == __3D
- DO p=1,npts
- i = iptstmp2(1,p)
- j = iptstmp2(2,p)
- k = iptstmp2(3,p)
- isub = iptstmp2(4,p)
- x = closest(1,p)
- y = closest(2,p)
- z = closest(3,p)
-#if __TYPE == __SFIELD
- udata(i,j,k,isub) = ivalue(x,y,z,info)
-#elif __TYPE == __VFIELD
- udata(1,i,j,k,isub) = ivalue(x,y,z,info)
- DO ida=2,lda
- udata(ida,i,j,k,isub) = udata(1,i,j,k,isub)
- ENDDO
-#endif
- ENDDO
-#elif __DIM == __2D
- DO p=1,npts
- i = iptstmp2(1,p)
- j = iptstmp2(2,p)
- isub = iptstmp2(3,p)
- x = closest(1,p)
- y = closest(2,p)
-#if __TYPE == __SFIELD
- udata(i,j,isub) = ivalue(x,y,info)
-#elif __TYPE == __VFIELD
- udata(1,i,j,isub) = ivalue(x,y,info)
- DO ida=2,lda
- udata(ida,i,j,isub) = udata(1,i,j,isub)
- ENDDO
-#endif
- ENDDO
-#endif
- !-------------------------------------------------------------------------
- ! Deallocate
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(closest,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_extend', &
- & 'closest points locations CLOSEST',__LINE__,info)
- ENDIF
-#if __KIND == __SINGLE_PRECISION
- NULLIFY(gmm_clos2)
-#elif __KIND == __DOUBLE_PRECISION
- NULLIFY(gmm_clod2)
-#endif
- CALL ppm_alloc(iptstmp2,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_extend', &
- & 'close mesh points IPTS',__LINE__,info)
- ENDIF
-#elif __KICKOFF == __NO
- !-------------------------------------------------------------------------
- ! Add ghost layers to field if needed
- !-------------------------------------------------------------------------
-! iopt = ppm_param_alloc_grow_preserve
-! ldl(1) = 1 - ghostsize(1)
-! ldl(2) = 1 - ghostsize(2)
-! ldl(3) = 1 - ghostsize(3)
-! ldl(4) = 1
-! ldu(1) = maxxhi + ghostsize(1)
-! ldu(2) = maxyhi + ghostsize(2)
-! ldu(3) = maxzhi + ghostsize(3)
-! ldu(4) = topo%nsublist
-! CALL ppm_alloc(udata,ldu,iopt,info)
-! IF (info .NE. ppm_param_success) THEN
-! info = ppm_error_fatal
-! CALL ppm_error(ppm_err_alloc,'ppm_gmm_extend', &
-! & 'function data UDATA',__LINE__,info)
-! GOTO 9999
-! ENDIF
- !-------------------------------------------------------------------------
- ! Nuke points farther from the interface than ivalue
- !-------------------------------------------------------------------------
-#if __DIM == __3D
- DO isub=1,topo%nsublist
- jsub = topo%isublist(isub)
- DO k=1,mesh%nnodes(3,jsub)
- DO j=1,mesh%nnodes(2,jsub)
- DO i=1,mesh%nnodes(1,jsub)
- IF (ABS(fdata(i,j,k,isub)) .GT. ivalue) THEN
-#if __TYPE == __VFIELD
- DO ida=1,lda
- udata(ida,i,j,k,isub) = big
- ENDDO
-#elif __TYPE == __SFIELD
- udata(i,j,k,isub) = big
-#endif
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#elif __DIM == __2D
- DO isub=1,topo%nsublist
- jsub = topo%isublist(isub)
- DO j=1,mesh%nnodes(2,jsub)
- DO i=1,mesh%nnodes(1,jsub)
- IF (ABS(fdata(i,j,isub)) .GT. ivalue) THEN
-#if __TYPE == __VFIELD
- DO ida=1,lda
- udata(ida,i,j,isub) = big
- ENDDO
-#elif __TYPE == __SFIELD
- udata(i,j,isub) = big
-#endif
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Check the maximum number of allowed iterations
- !-------------------------------------------------------------------------
- IF (PRESENT(MaxIter)) THEN
- MaxIt = MaxIter
- ELSE
- MaxIt = HUGE(MaxIt)
- ENDIF
- !-------------------------------------------------------------------------
- ! Marching udata
- !-------------------------------------------------------------------------
-#if __TYPE == __VFIELD
- !-------------------------------------------------------------------------
- ! Allocate work array
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_fit
- ldl(1) = LBOUND(udata,2)
- ldl(2) = LBOUND(udata,3)
-#if __DIM == __3D
- ldl(3) = LBOUND(udata,4)
-#endif
- ldl(4) = 1
- ldu(1) = UBOUND(udata,2)
- ldu(2) = UBOUND(udata,3)
-#if __DIM == __3D
- ldu(3) = UBOUND(udata,4)
-#endif
- ldu(4) = topo%nsublist
- CALL ppm_alloc(ext_wrk,ldl,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_extend', &
- & 'work memory EXT_WRK',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Do each vector dimension separately using the work memory
- !-------------------------------------------------------------------------
- DO ida=1,lda
-#if __DIM == __3D
- DO isub=1,ldu(4)
- DO k=ldl(3),ldu(3)
- DO j=ldl(2),ldu(2)
- DO i=ldl(1),ldu(1)
- ext_wrk(i,j,k,isub) = udata(ida,i,j,k,isub)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#elif __DIM == __2D
- DO isub=1,ldu(4)
- DO j=ldl(2),ldu(2)
- DO i=ldl(1),ldu(1)
- ext_wrk(i,j,isub) = udata(ida,i,j,isub)
- ENDDO
- ENDDO
- ENDDO
-#endif
- !---------------------------------------------------------------------
- ! March
- !---------------------------------------------------------------------
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_march(width,order,fdata,0.0_MK,MaxIt,info, &
- & udata=ext_wrk,chi=chi)
- ELSE
- CALL ppm_gmm_march(width,order,fdata,0.0_MK,MaxIt,info, &
- & udata=ext_wrk)
- ENDIF
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'Marching GMM failed.',__LINE__,info)
- GOTO 9999
- ENDIF
-
- !---------------------------------------------------------------------
- ! The ghostsize might have changed in the marching, depending on
- ! the order of the marching algorithm.
- !---------------------------------------------------------------------
- ldl(1) = MAX(ldl(1),LBOUND(ext_wrk,1))
- ldl(2) = MAX(ldl(2),LBOUND(ext_wrk,2))
-#if __DIM == __3D
- ldl(3) = MAX(ldl(3),LBOUND(ext_wrk,3))
-#endif
- ldu(1) = MIN(ldu(1),UBOUND(ext_wrk,1))
- ldu(2) = MIN(ldu(2),UBOUND(ext_wrk,2))
-#if __DIM == __3D
- ldu(3) = MIN(ldu(3),UBOUND(ext_wrk,3))
-#endif
- !---------------------------------------------------------------------
- ! Copy results back
- !---------------------------------------------------------------------
-#if __DIM == __3D
- DO isub=1,ldu(4)
- DO k=ldl(3),ldu(3)
- DO j=ldl(2),ldu(2)
- DO i=ldl(1),ldu(1)
- udata(ida,i,j,k,isub) = ext_wrk(i,j,k,isub)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-#elif __DIM == __2D
- DO isub=1,ldu(4)
- DO j=ldl(2),ldu(2)
- DO i=ldl(1),ldu(1)
- udata(ida,i,j,isub) = ext_wrk(i,j,isub)
- ENDDO
- ENDDO
- ENDDO
-#endif
- ENDDO ! ida
- !-------------------------------------------------------------------------
- ! Free work memory
- !-------------------------------------------------------------------------
- iopt = ppm_param_dealloc
- CALL ppm_alloc(ext_wrk,ldl,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_extend', &
- & 'work memory EXT_WRK',__LINE__,info)
- ENDIF
-#if __TYPE == __VFIELD
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- NULLIFY(ext_wrk_2ds)
-#elif __KIND == __DOUBLE_PRECISION
- NULLIFY(ext_wrk_2dd)
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- NULLIFY(ext_wrk_3ds)
-#elif __KIND == __DOUBLE_PRECISION
- NULLIFY(ext_wrk_3dd)
-#endif
-#endif
-#endif
-#elif __TYPE == __SFIELD
- !-------------------------------------------------------------------------
- ! Do scalar marching directly
- !-------------------------------------------------------------------------
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_march(width,order,fdata,0.0_MK,MaxIt,info, &
- & udata=udata,chi=chi)
- ELSE
- CALL ppm_gmm_march(width,order,fdata,0.0_MK,MaxIt,info,udata=udata)
- ENDIF
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'Marching GMM failed.',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_extend',t0,info)
- RETURN
-#if __KICKOFF == __YES
-#if __DIM == __2D
-#if __TYPE == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_2d_ksca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_2d_ksca_d
-#endif
-#elif __TYPE == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_2d_kvec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_2d_kvec_d
-#endif
-#endif
-#elif __DIM == __3D
-#if __TYPE == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_3d_ksca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_3d_ksca_d
-#endif
-#elif __TYPE == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_3d_kvec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_3d_kvec_d
-#endif
-#endif
-#endif
-#elif __KICKOFF == __NO
-#if __DIM == __2D
-#if __TYPE == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_2d_tsca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_2d_tsca_d
-#endif
-#elif __TYPE == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_2d_tvec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_2d_tvec_d
-#endif
-#endif
-#elif __DIM == __3D
-#if __TYPE == __SFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_3d_tsca_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_3d_tsca_d
-#endif
-#elif __TYPE == __VFIELD
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_3d_tvec_s
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_3d_tvec_d
-#endif
-#endif
-#endif
-#endif
diff --git a/src/ppm_gmm_extend_bkwd.f b/src/ppm_gmm_extend_bkwd.f
deleted file mode 100644
index 585c166e5ca97fa0565d8b9d1a1f0d5411ae1de2..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_extend_bkwd.f
+++ /dev/null
@@ -1,452 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_extend_bkwd
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_bkwd_2ds(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_bkwd_2dd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_bkwd_3ds(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_bkwd_3dd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#endif
-#endif
- !!! This routine performs the backward marching step of the GMM. See
- !!! ppm_gmm_march for details.
- !!!
- !!! === References ===
- !!!
- !!! Chopp:2001, Kim:2001b
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_numerics_data
- USE ppm_module_data_gmm
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- USE ppm_module_map_field
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER :: fdta
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdta
-#endif
- !!! pointer to level function. Needs to be defined in a band
- !!! (width+order*dx).
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER :: dta
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: dta
-#endif
- !!! pointer to value function.
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , INTENT(IN), OPTIONAL :: speed
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: speed
-#endif
- !!! rank 4 (3d) or rank 3 (2d) field of front speeds.
- !!! OPTIONAL to override rhscst.
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: chi
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN), OPTIONAL :: chi
-#endif
- !!! rank 5 (3d) or rank 4 (2d) field specifying the positions
- !!! of the grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub.
- !!! OPTIONAL. Uniform grid is assumed if absent.
- REAL(MK) , INTENT(IN ) :: width
- !!! Width of the narrow band to be produced on each side of
- !!! the interface.
- REAL(MK) , INTENT(IN ) :: rhscst
- !!! constant value for the right hand side of grad u * grad f = c.
- !!! If speed is present, this argument will be ignored.
- REAL(MK) , INTENT(IN ) :: TM
- !!! Current threshold for wave front location.
- REAL(MK) , INTENT(IN ) :: dxinv
- !!! inverse of the x grid spacing.
- REAL(MK) , INTENT(IN ) :: dyinv
- !!! inverse of the y grid spacing.
- REAL(MK) , INTENT(IN ) :: dzinv
- !!! inverse of the z grid spacing. (Not used in 2D version).
- INTEGER , INTENT(IN ) :: order
- !!! Order of the method to be used. One of
- !!!
- !!! *ppm_param_order_1
- !!! *ppm_param_order_2
- !!! *ppm_param_order_3
- INTEGER, DIMENSION(3) , INTENT(IN ) :: ghostsize
- !!! Size of the ghostlayer on all sides.
- INTEGER , INTENT(INOUT) :: npos
- !!! Current number of points in the close set.
- INTEGER , INTENT( OUT) :: info
- !!! Return status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,j,k,p,xhi,yhi,zhi,ii,jj,kk
- INTEGER :: jsub,isub
- INTEGER :: i1,i2,i3
- INTEGER, DIMENSION(-3:3) :: sx,sy,sz
- REAL(MK) :: t0,onethird,onetwelfth
- REAL(MK) :: valijk,det,hsave,fdta0
- REAL(MK) :: lmyeps,ainv,big,absfdta0
- REAL(MK) :: dxihalf,dxitwelve,agag
- REAL(MK) :: dyihalf,dyitwelve
- REAL(MK) :: dzihalf,dzitwelve
- REAL(MK), DIMENSION(3) :: coefs,gphi,gpp
- REAL(MK), DIMENSION(3,3) :: jac,ji
- REAL(MK), DIMENSION(-3:3,ppm_dim):: phi,psi
- REAL(MK), DIMENSION(ppm_dim) :: alpha,beta
- REAL(MK), DIMENSION(2) :: roots
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_extend_bkwd',t0,info)
- topo => ppm_topo(gmm_topoid)%t
- mesh => topo%mesh(gmm_meshid)
- phi = 0.0_MK
- psi = 0.0_MK
- big = HUGE(big)
- hsave = 0.9_MK*big
- onethird = 1.0_MK/3.0_MK
- onetwelfth = 1.0_MK/12.0_MK
-#if __KIND == __SINGLE_PRECISION
- lmyeps = ppm_myepss
-#else
- lmyeps = ppm_myepsd
-#endif
- dxihalf = 0.5_MK*dxinv
- dyihalf = 0.5_MK*dyinv
- dxitwelve = onetwelfth*dxinv
- dyitwelve = onetwelfth*dyinv
-#if __DIM == __3D
- dzihalf = 0.5_MK*dzinv
- dzitwelve = onetwelfth*dzinv
-#endif
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (width .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_extend_bkwd', &
- & 'width must be positive!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((order.NE.ppm_param_order_1).AND.(order.NE.ppm_param_order_2) &
- & .AND.(order.NE.ppm_param_order_3)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_extend_bkwd', &
- & 'order must be 1, 2, or 3!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF ! ppm_debug for argument check
-#if __DIM == __3D
- !-------------------------------------------------------------------------
- ! Reverse order: recompute neighbors of points in ggm_ipos
- !-------------------------------------------------------------------------
- DO p=npos,1,-1
- ii = gmm_ipos(1,p)
- jj = gmm_ipos(2,p)
- kk = gmm_ipos(3,p)
- jsub = gmm_ipos(4,p)
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- zhi = mesh%nnodes(3,isub)
- fdta0= fdta(ii,jj,kk,jsub)
- absfdta0 = fdta0
- IF (absfdta0 .LT. 0.0_MK) absfdta0 = -absfdta0
- !---------------------------------------------------------------------
- ! GMM update condition (see Kim:2001a)
- !---------------------------------------------------------------------
- IF (.NOT.(absfdta0.GT.TM)) THEN
- !-----------------------------------------------------------------
- ! Recompute non-accepted close neighbors
- !-----------------------------------------------------------------
- i = ii - 1
- j = jj
- k = kk
- IF (i.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (ABS(valijk) .LT. hsave) dta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- i = ii + 1
- j = jj
- k = kk
- IF (i.LE.xhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (ABS(valijk) .LT. hsave) dta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- i = ii
- j = jj - 1
- k = kk
- IF (j.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (ABS(valijk) .LT. hsave) dta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- i = ii
- j = jj + 1
- k = kk
- IF (j.LE.yhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (ABS(valijk) .LT. hsave) dta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- i = ii
- j = jj
- k = kk - 1
- IF (k.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (ABS(valijk) .LT. hsave) dta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- i = ii
- j = jj
- k = kk + 1
- IF (k.LE.zhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (ABS(valijk) .LT. hsave) dta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF ! TT .LE. TM
- ENDDO ! p=npos,1,-1
- !-------------------------------------------------------------------------
- ! Update ghost layers for dta
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,dta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,dta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-
-#elif __DIM == __2D
- !-------------------------------------------------------------------------
- ! Reverse order: recompute neighbors of points in ggm_ipos
- !-------------------------------------------------------------------------
- DO p=npos,1,-1
- ii = gmm_ipos(1,p)
- jj = gmm_ipos(2,p)
- jsub = gmm_ipos(3,p)
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- fdta0= fdta(ii,jj,jsub)
- !---------------------------------------------------------------------
- ! GMM update condition (see Kim:2001a)
- !---------------------------------------------------------------------
- IF (.NOT.(ABS(fdta0).GT.TM)) THEN
- !-----------------------------------------------------------------
- ! Recompute non-accepted close neighbors
- !-----------------------------------------------------------------
- i = ii - 1
- j = jj
- IF (i.GT.0) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.ABS(fdta0))) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) dta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- i = ii + 1
- j = jj
- IF (i.LE.xhi) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.ABS(fdta0))) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) dta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- i = ii
- j = jj - 1
- IF (j.GT.0) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.ABS(fdta0))) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) dta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- i = ii
- j = jj + 1
- IF (j.LE.yhi) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.ABS(fdta0))) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) dta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF ! TT .LE. TM
- ENDDO ! p=npos,1,-1
- !-------------------------------------------------------------------------
- ! Update ghost layers for dta
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,dta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,dta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_extend_bkwd',t0,info)
- RETURN
-
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_bkwd_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_bkwd_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_bkwd_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_bkwd_3dd
-#endif
-#endif
diff --git a/src/ppm_gmm_extend_fwd.f b/src/ppm_gmm_extend_fwd.f
deleted file mode 100644
index 692e65c07d38f224606e401c082cd46d29576d02..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_extend_fwd.f
+++ /dev/null
@@ -1,638 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_extend_fwd
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_fwd_2ds(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_fwd_2dd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_extend_fwd_3ds(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_extend_fwd_3dd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#endif
-#endif
- !!! This routine performs the forward marching step of the GMM. See
- !!! ppm_gmm_march for details.
- !!!
- !!! === References ===
- !!!
- !!! Chopp:2001, Kim:2001b
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_numerics_data
- USE ppm_module_data_gmm
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- USE ppm_module_map_field
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER :: fdta
- !!! pointer to level function. Needs to be defined in a band
- !!! (width+order*dx)
- REAL(MK), DIMENSION(:,:,:) , POINTER :: dta
- !!! pointer to value function.
- REAL(MK), DIMENSION(:,:,:) , INTENT(IN), OPTIONAL :: speed
- !!! rank 3 (2d) field of front speeds. OPTIONAL to override rhscst.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: chi
- !!! rank 4 (2d) field specifying the positions of the grid nodes.
- !!! 1st index: 1..ppm_dim, then i,j,[k],isub. OPTIONAL. Uniform grid is
- !!! assumed if absent.
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdta
- !!! pointer to level function. Needs to be defined in a band
- !!! (width+order*dx)
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: dta
- !!! pointer to value function.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: speed
- !!! rank 4 (3d) field of front speeds. OPTIONAL to override rhscst.
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN), OPTIONAL :: chi
- !!! rank 5 (3d) field specifying the positions of the grid nodes.
- !!! 1st index: 1..ppm_dim, then i,j,[k],isub. OPTIONAL. Uniform grid is
- !!! assumed if absent.
-#endif
- REAL(MK) , INTENT(IN ) :: width
- !!! Width of the narrow band to be produced on each side of the interface
- REAL(MK) , INTENT(IN ) :: rhscst
- !!! constant value for the right hand side of grad u * grad f = c.
- !!! If speed is present, this argument will be ignored.
- REAL(MK) , INTENT(IN ) :: TM
- !!! Current threshold for wave front location.
- REAL(MK) , INTENT(IN ) :: dxinv
- !!! inverse of the x grid spacing.
- REAL(MK) , INTENT(IN ) :: dyinv
- !!! inverse of the y grid spacing.
- REAL(MK) , INTENT(IN ) :: dzinv
- !!! inverse of the z grid spacing. (Not used in 2D version).
- INTEGER, DIMENSION(3) , INTENT(IN ) :: ghostsize
- !!! Size of the ghostlayer on all sides.
- INTEGER , INTENT(IN ) :: order
- !!! Order of the method to be used. One of
- !!!
- !!! *ppm_param_order_1
- !!! *ppm_param_order_2
- !!! *ppm_param_order_3
- INTEGER , INTENT(INOUT) :: npos
- !!! Current number of points in the close set.
- INTEGER , INTENT( OUT) :: info
- !!! Return status. 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,j,k,p,xhi,yhi,zhi,ii,jj,kk
- INTEGER :: npos0,jsub,isub,iopt
- INTEGER :: i1,i2,i3
- INTEGER, DIMENSION(-3:3) :: sx,sy,sz
- INTEGER, DIMENSION(4) :: ldu
- REAL(MK) :: t0,onethird,onetwelfth
- REAL(MK) :: valijk,det,hsave,fdta0
- REAL(MK) :: lmyeps,ainv,big,absfdta0
- REAL(MK) :: dxihalf,dxitwelve,agag
- REAL(MK) :: dyihalf,dyitwelve
- REAL(MK) :: dzihalf,dzitwelve
- REAL(MK), DIMENSION(3) :: coefs,gphi,gpp
- REAL(MK), DIMENSION(3,3) :: jac,ji
- REAL(MK), DIMENSION(-3:3,ppm_dim):: phi,psi
- REAL(MK), DIMENSION(ppm_dim) :: alpha,beta
- REAL(MK), DIMENSION(2) :: roots
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_extend_fwd',t0,info)
- topo => ppm_topo(gmm_topoid)%t
- mesh => topo%mesh(gmm_meshid)
- phi = 0.0_MK
- psi = 0.0_MK
- big = HUGE(big)
- hsave = 0.9_MK*big
- onethird = 1.0_MK/3.0_MK
- onetwelfth = 1.0_MK/12.0_MK
-#if __KIND == __SINGLE_PRECISION
- lmyeps = ppm_myepss
-#else
- lmyeps = ppm_myepsd
-#endif
- dxihalf = 0.5_MK*dxinv
- dyihalf = 0.5_MK*dyinv
- dxitwelve = onetwelfth*dxinv
- dyitwelve = onetwelfth*dyinv
-#if __DIM == __3D
- dzihalf = 0.5_MK*dzinv
- dzitwelve = onetwelfth*dzinv
-#endif
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (width .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_extend_fwd', &
- & 'width must be positive!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((order.NE.ppm_param_order_1).AND.(order.NE.ppm_param_order_2) &
- & .AND.(order.NE.ppm_param_order_3)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_extend_fwd', &
- & 'order must be 1, 2, or 3!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF ! ppm_debug for argument check
-
-#if __DIM == __3D
- npos0 = npos
- !-------------------------------------------------------------------------
- ! Forward order: update neighbors of points in ggm_ipos
- !-------------------------------------------------------------------------
- DO p=1,npos
- IF (p .GT. npos0) EXIT
- ii = gmm_ipos(1,p)
- jj = gmm_ipos(2,p)
- kk = gmm_ipos(3,p)
- jsub = gmm_ipos(4,p)
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- zhi = mesh%nnodes(3,isub)
- fdta0= fdta(ii,jj,kk,jsub)
- absfdta0 = fdta0
- IF (absfdta0 .LT. 0.0_MK) absfdta0 = -absfdta0
- !---------------------------------------------------------------------
- ! GMM update condition (see Kim:2001a)
- !---------------------------------------------------------------------
- IF (.NOT.(absfdta0.GT.TM)) THEN
- !-----------------------------------------------------------------
- ! Compute non-accepted neighbors
- !-----------------------------------------------------------------
- i = ii - 1
- j = jj
- k = kk
- IF (i.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,k,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii + 1
- j = jj
- k = kk
- IF (i.LE.xhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,k,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj - 1
- k = kk
- IF (j.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,k,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj + 1
- k = kk
- IF (j.LE.yhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,k,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj
- k = kk - 1
- IF (k.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,k,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj
- k = kk + 1
- IF (k.LE.zhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,k,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- !-----------------------------------------------------------------
- ! Accept this point and remove it from the list
- !-----------------------------------------------------------------
- gmm_state3d(ii,jj,kk,jsub) = ppm_gmm_param_accepted
- gmm_ipos(1,p) = gmm_ipos(1,npos0)
- gmm_ipos(2,p) = gmm_ipos(2,npos0)
- gmm_ipos(3,p) = gmm_ipos(3,npos0)
- gmm_ipos(4,p) = gmm_ipos(4,npos0)
- npos0 = npos0 - 1
- ENDIF ! TT .LE. TM
- ENDDO ! p=1,npos
- npos = npos0
- ! WRITE(cbuf,'(A,I2.2,A)') 'state_',Marchit,'.out'
- ! OPEN(40,FILE=cbuf,STATUS='REPLACE',ACTION='WRITE')
- ! WRITE(cbuf,'(A,I2.2,A)') 'value_',Marchit,'.out'
- ! OPEN(30,FILE=cbuf,STATUS='REPLACE',ACTION='WRITE')
- ! DO kk=1,zhi
- ! DO jj=1,yhi
- ! DO ii=1,xhi
- ! WRITE(40,'(I3)') gmm_state3d(ii,jj,kk,jsub)
- ! IF (dta(ii,jj,kk,jsub) .GT. hsave) THEN
- ! WRITE(30,'(E20.8)') 0.0_MK
- ! ELSE
- ! WRITE(30,'(E20.8)') dta(ii,jj,kk,jsub)
- ! ENDIF
- ! ENDDO
- ! ENDDO
- ! ENDDO
- ! CLOSE(30)
- ! CLOSE(40)
- !-------------------------------------------------------------------------
- ! Update ghost layers for both dta AND gmm_state3d
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,dta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,gmm_state3d,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'pushing status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,gmm_state3d,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'popping status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,dta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __DIM == __2D
- npos0 = npos
- !-------------------------------------------------------------------------
- ! Forward order: update neighbors of points in ggm_ipos
- !-------------------------------------------------------------------------
- DO p=1,npos
- IF (p .GT. npos0) EXIT
- ii = gmm_ipos(1,p)
- jj = gmm_ipos(2,p)
- jsub = gmm_ipos(3,p)
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- fdta0= fdta(ii,jj,jsub)
- !---------------------------------------------------------------------
- ! GMM update condition (see Kim:2001a)
- !---------------------------------------------------------------------
- IF (.NOT.(ABS(fdta0).GT.TM)) THEN
- !-----------------------------------------------------------------
- ! Compute non-accepted neighbors
- !-----------------------------------------------------------------
- i = ii - 1
- j = jj
- IF (i.GT.0) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.ABS(fdta0))) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state2d(i,j,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,jsub)) .LT. width)) THEN
- gmm_state2d(i,j,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii + 1
- j = jj
- IF (i.LE.xhi) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.ABS(fdta0))) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state2d(i,j,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,jsub)) .LT. width)) THEN
- gmm_state2d(i,j,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj - 1
- IF (j.GT.0) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.ABS(fdta0))) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state2d(i,j,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,jsub)) .LT. width)) THEN
- gmm_state2d(i,j,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj + 1
- IF (j.LE.yhi) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.ABS(fdta0))) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvextn.inc"
- IF (valijk .LT. hsave) THEN
- dta(i,j,jsub) = valijk
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state2d(i,j,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,jsub)) .LT. width)) THEN
- gmm_state2d(i,j,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- !-----------------------------------------------------------------
- ! Accept this point and remove it from the list
- !-----------------------------------------------------------------
- gmm_state2d(ii,jj,jsub) = ppm_gmm_param_accepted
- gmm_ipos(1,p) = gmm_ipos(1,npos0)
- gmm_ipos(2,p) = gmm_ipos(2,npos0)
- gmm_ipos(3,p) = gmm_ipos(3,npos0)
- npos0 = npos0 - 1
- ENDIF ! TT .LE. TM
- ENDDO ! p=1,npos
- npos = npos0
- !-------------------------------------------------------------------------
- ! Update ghost layers for both dta AND gmm_state2d
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,dta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,gmm_state2d,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'pushing status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,gmm_state2d,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'popping status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,dta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_extend_fwd', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_extend_fwd',t0,info)
- RETURN
-
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_fwd_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_fwd_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_fwd_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_extend_fwd_3dd
-#endif
-#endif
diff --git a/src/ppm_gmm_finalize.f b/src/ppm_gmm_finalize.f
deleted file mode 100644
index 26568d1c9cc8e485d6d81db64bf40179716458e7..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_finalize.f
+++ /dev/null
@@ -1,131 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_finalize
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- SUBROUTINE ppm_gmm_finalize(info)
- !!! This routine finalizes the ppm_gmm module and deallocates all
- !!! data structures.
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_gmm
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT( OUT) :: info
- !!! Return status. 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER, DIMENSION(3) :: ldu
- INTEGER :: iopt
- REAL(ppm_kind_double) :: t0
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_finalize',t0,info)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_finalize', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Deallocate work space structures
- !-------------------------------------------------------------------------
- gmm_lsiz = -1
- iopt = ppm_param_dealloc
- CALL ppm_alloc(gmm_phis,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_finalize', &
- & 'sparse data values GMM_PHIS',__LINE__,info)
- ENDIF
- CALL ppm_alloc(gmm_phid,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_finalize', &
- & 'sparse data values GMM_PHID',__LINE__,info)
- ENDIF
- CALL ppm_alloc(gmm_ipos,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_finalize', &
- & 'sparse data locations GMM_IPOS',__LINE__,info)
- ENDIF
- CALL ppm_alloc(gmm_clod,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_finalize', &
- & 'close point locations GMM_CLOD',__LINE__,info)
- ENDIF
- CALL ppm_alloc(gmm_clos,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_finalize', &
- & 'close point locations GMM_CLOS',__LINE__,info)
- ENDIF
- CALL ppm_alloc(gmm_clod2,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_finalize', &
- & 'close point locations GMM_CLOD2',__LINE__,info)
- ENDIF
- CALL ppm_alloc(gmm_clos2,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_finalize', &
- & 'close point locations GMM_CLOS2',__LINE__,info)
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_finalize',t0,info)
- RETURN
-
- END SUBROUTINE ppm_gmm_finalize
diff --git a/src/ppm_gmm_getdta.inc b/src/ppm_gmm_getdta.inc
deleted file mode 100644
index 475f5e53860cde16a0af7099aa6f7021c7aceee9..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_getdta.inc
+++ /dev/null
@@ -1,121 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for reading the function values from dta.
- !
- ! INPUT: INTEGER :: i,j,k -- Point to solve for
- ! INTEGER :: order -- Desired order of FD scheme
- ! OUTPUT: REAL(MK)(-order:order,1:ppm_dim) :: psi -- function
- ! values at shifted locations in all directions.
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_getdta.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/05/10 04:41:14 ivos
- ! Newly created during modularization of ppm_gmm_march. Marching
- ! and orthogonal extendion are now in separate routines for faster
- ! compilation.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- psi = 0.0_MK
-#if __DIM == __3D
- IF (order .EQ. ppm_param_order_3) THEN
- psi(-3,1) = dta(i-3,j,k,jsub)
- psi(-2,1) = dta(i-2,j,k,jsub)
- psi(-1,1) = dta(i-1,j,k,jsub)
- psi( 0,1) = dta(i ,j,k,jsub)
- psi( 1,1) = dta(i+1,j,k,jsub)
- psi( 2,1) = dta(i+2,j,k,jsub)
- psi( 3,1) = dta(i+3,j,k,jsub)
-
- psi(-3,2) = dta(i,j-3,k,jsub)
- psi(-2,2) = dta(i,j-2,k,jsub)
- psi(-1,2) = dta(i,j-1,k,jsub)
- psi( 0,2) = dta(i,j ,k,jsub)
- psi( 1,2) = dta(i,j+1,k,jsub)
- psi( 2,2) = dta(i,j+2,k,jsub)
- psi( 3,2) = dta(i,j+3,k,jsub)
-
- psi(-3,3) = dta(i,j,k-3,jsub)
- psi(-2,3) = dta(i,j,k-2,jsub)
- psi(-1,3) = dta(i,j,k-1,jsub)
- psi( 0,3) = dta(i,j,k ,jsub)
- psi( 1,3) = dta(i,j,k+1,jsub)
- psi( 2,3) = dta(i,j,k+2,jsub)
- psi( 3,3) = dta(i,j,k+3,jsub)
- ELSEIF (order .EQ. ppm_param_order_2) THEN
- psi(-2,1) = dta(i-2,j,k,jsub)
- psi(-1,1) = dta(i-1,j,k,jsub)
- psi( 0,1) = dta(i ,j,k,jsub)
- psi( 1,1) = dta(i+1,j,k,jsub)
- psi( 2,1) = dta(i+2,j,k,jsub)
-
- psi(-2,2) = dta(i,j-2,k,jsub)
- psi(-1,2) = dta(i,j-1,k,jsub)
- psi( 0,2) = dta(i,j ,k,jsub)
- psi( 1,2) = dta(i,j+1,k,jsub)
- psi( 2,2) = dta(i,j+2,k,jsub)
-
- psi(-2,3) = dta(i,j,k-2,jsub)
- psi(-1,3) = dta(i,j,k-1,jsub)
- psi( 0,3) = dta(i,j,k ,jsub)
- psi( 1,3) = dta(i,j,k+1,jsub)
- psi( 2,3) = dta(i,j,k+2,jsub)
- ELSE
- psi(-1,1) = dta(i-1,j,k,jsub)
- psi( 0,1) = dta(i ,j,k,jsub)
- psi( 1,1) = dta(i+1,j,k,jsub)
-
- psi(-1,2) = dta(i,j-1,k,jsub)
- psi( 0,2) = dta(i,j ,k,jsub)
- psi( 1,2) = dta(i,j+1,k,jsub)
-
- psi(-1,3) = dta(i,j,k-1,jsub)
- psi( 0,3) = dta(i,j,k ,jsub)
- psi( 1,3) = dta(i,j,k+1,jsub)
- ENDIF
-#elif __DIM == __2D
- IF (order .EQ. ppm_param_order_3) THEN
- psi(-3,1) = dta(i-3,j,jsub)
- psi(-2,1) = dta(i-2,j,jsub)
- psi(-1,1) = dta(i-1,j,jsub)
- psi( 0,1) = dta(i ,j,jsub)
- psi( 1,1) = dta(i+1,j,jsub)
- psi( 2,1) = dta(i+2,j,jsub)
- psi( 3,1) = dta(i+3,j,jsub)
-
- psi(-3,2) = dta(i,j-3,jsub)
- psi(-2,2) = dta(i,j-2,jsub)
- psi(-1,2) = dta(i,j-1,jsub)
- psi( 0,2) = dta(i,j ,jsub)
- psi( 1,2) = dta(i,j+1,jsub)
- psi( 2,2) = dta(i,j+2,jsub)
- psi( 3,2) = dta(i,j+3,jsub)
- ELSEIF (order .EQ. ppm_param_order_2) THEN
- psi(-2,1) = dta(i-2,j,jsub)
- psi(-1,1) = dta(i-1,j,jsub)
- psi( 0,1) = dta(i ,j,jsub)
- psi( 1,1) = dta(i+1,j,jsub)
- psi( 2,1) = dta(i+2,j,jsub)
-
- psi(-2,2) = dta(i,j-2,jsub)
- psi(-1,2) = dta(i,j-1,jsub)
- psi( 0,2) = dta(i,j ,jsub)
- psi( 1,2) = dta(i,j+1,jsub)
- psi( 2,2) = dta(i,j+2,jsub)
- ELSE
- psi(-1,1) = dta(i-1,j,jsub)
- psi( 0,1) = dta(i ,j,jsub)
- psi( 1,1) = dta(i+1,j,jsub)
-
- psi(-1,2) = dta(i,j-1,jsub)
- psi( 0,2) = dta(i,j ,jsub)
- psi( 1,2) = dta(i,j+1,jsub)
- ENDIF
-#endif
diff --git a/src/ppm_gmm_getfdta.inc b/src/ppm_gmm_getfdta.inc
deleted file mode 100644
index 74e403aec3af53bc0f89f7d69ff8e9a5d8127378..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_getfdta.inc
+++ /dev/null
@@ -1,121 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for reading the data from fdta (level function).
- !
- ! INPUT: INTEGER :: i,j,k -- Point to solve for
- ! INTEGER :: order -- Desired order of FD scheme
- ! OUTPUT: REAL(MK)(-order:order,1:ppm_dim) :: phi -- level
- ! function at shifted locations in each dir.
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_getfdta.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/05/10 04:41:15 ivos
- ! Newly created during modularization of ppm_gmm_march. Marching
- ! and orthogonal extendion are now in separate routines for faster
- ! compilation.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- phi = 0.0_MK
-#if __DIM == __3D
- IF (order .EQ. ppm_param_order_3) THEN
- phi(-3,1) = fdta(i-3,j,k,jsub)
- phi(-2,1) = fdta(i-2,j,k,jsub)
- phi(-1,1) = fdta(i-1,j,k,jsub)
- phi( 0,1) = fdta(i ,j,k,jsub)
- phi( 1,1) = fdta(i+1,j,k,jsub)
- phi( 2,1) = fdta(i+2,j,k,jsub)
- phi( 3,1) = fdta(i+3,j,k,jsub)
-
- phi(-3,2) = fdta(i,j-3,k,jsub)
- phi(-2,2) = fdta(i,j-2,k,jsub)
- phi(-1,2) = fdta(i,j-1,k,jsub)
- phi( 0,2) = fdta(i,j ,k,jsub)
- phi( 1,2) = fdta(i,j+1,k,jsub)
- phi( 2,2) = fdta(i,j+2,k,jsub)
- phi( 3,2) = fdta(i,j+3,k,jsub)
-
- phi(-3,3) = fdta(i,j,k-3,jsub)
- phi(-2,3) = fdta(i,j,k-2,jsub)
- phi(-1,3) = fdta(i,j,k-1,jsub)
- phi( 0,3) = fdta(i,j,k ,jsub)
- phi( 1,3) = fdta(i,j,k+1,jsub)
- phi( 2,3) = fdta(i,j,k+2,jsub)
- phi( 3,3) = fdta(i,j,k+3,jsub)
- ELSEIF (order .EQ. ppm_param_order_2) THEN
- phi(-2,1) = fdta(i-2,j,k,jsub)
- phi(-1,1) = fdta(i-1,j,k,jsub)
- phi( 0,1) = fdta(i ,j,k,jsub)
- phi( 1,1) = fdta(i+1,j,k,jsub)
- phi( 2,1) = fdta(i+2,j,k,jsub)
-
- phi(-2,2) = fdta(i,j-2,k,jsub)
- phi(-1,2) = fdta(i,j-1,k,jsub)
- phi( 0,2) = fdta(i,j ,k,jsub)
- phi( 1,2) = fdta(i,j+1,k,jsub)
- phi( 2,2) = fdta(i,j+2,k,jsub)
-
- phi(-2,3) = fdta(i,j,k-2,jsub)
- phi(-1,3) = fdta(i,j,k-1,jsub)
- phi( 0,3) = fdta(i,j,k ,jsub)
- phi( 1,3) = fdta(i,j,k+1,jsub)
- phi( 2,3) = fdta(i,j,k+2,jsub)
- ELSE
- phi(-1,1) = fdta(i-1,j,k,jsub)
- phi( 0,1) = fdta(i ,j,k,jsub)
- phi( 1,1) = fdta(i+1,j,k,jsub)
-
- phi(-1,2) = fdta(i,j-1,k,jsub)
- phi( 0,2) = fdta(i,j ,k,jsub)
- phi( 1,2) = fdta(i,j+1,k,jsub)
-
- phi(-1,3) = fdta(i,j,k-1,jsub)
- phi( 0,3) = fdta(i,j,k ,jsub)
- phi( 1,3) = fdta(i,j,k+1,jsub)
- ENDIF
-#elif __DIM == __2D
- IF (order .EQ. ppm_param_order_3) THEN
- phi(-3,1) = fdta(i-3,j,jsub)
- phi(-2,1) = fdta(i-2,j,jsub)
- phi(-1,1) = fdta(i-1,j,jsub)
- phi( 0,1) = fdta(i ,j,jsub)
- phi( 1,1) = fdta(i+1,j,jsub)
- phi( 2,1) = fdta(i+2,j,jsub)
- phi( 3,1) = fdta(i+3,j,jsub)
-
- phi(-3,2) = fdta(i,j-3,jsub)
- phi(-2,2) = fdta(i,j-2,jsub)
- phi(-1,2) = fdta(i,j-1,jsub)
- phi( 0,2) = fdta(i,j ,jsub)
- phi( 1,2) = fdta(i,j+1,jsub)
- phi( 2,2) = fdta(i,j+2,jsub)
- phi( 3,2) = fdta(i,j+3,jsub)
- ELSEIF (order .EQ. ppm_param_order_2) THEN
- phi(-2,1) = fdta(i-2,j,jsub)
- phi(-1,1) = fdta(i-1,j,jsub)
- phi( 0,1) = fdta(i ,j,jsub)
- phi( 1,1) = fdta(i+1,j,jsub)
- phi( 2,1) = fdta(i+2,j,jsub)
-
- phi(-2,2) = fdta(i,j-2,jsub)
- phi(-1,2) = fdta(i,j-1,jsub)
- phi( 0,2) = fdta(i,j ,jsub)
- phi( 1,2) = fdta(i,j+1,jsub)
- phi( 2,2) = fdta(i,j+2,jsub)
- ELSE
- phi(-1,1) = fdta(i-1,j,jsub)
- phi( 0,1) = fdta(i ,j,jsub)
- phi( 1,1) = fdta(i+1,j,jsub)
-
- phi(-1,2) = fdta(i,j-1,jsub)
- phi( 0,2) = fdta(i,j ,jsub)
- phi( 1,2) = fdta(i,j+1,jsub)
- ENDIF
-#endif
diff --git a/src/ppm_gmm_init.f b/src/ppm_gmm_init.f
deleted file mode 100644
index 00f189624412016cf09c93360f7ea45fc01a8006..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_init.f
+++ /dev/null
@@ -1,185 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_init
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
- SUBROUTINE ppm_gmm_init(field_topoid,meshid,Nest,prec,info)
- !!! This routine initializes the ppm_gmm module and allocates all data
- !!! structures.
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_data_gmm
-
- USE ppm_module_error
- USE ppm_module_typedef
- USE ppm_module_check_id
- USE ppm_module_alloc
- USE ppm_module_substart
- USE ppm_module_substop
-
- IMPLICIT NONE
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
- INTEGER, INTENT(IN ) :: Nest
- !!! Estimated number of grid points adjacent to the zero level. This is
- !!! only used to estimate the size of the memory needed and will be grown
- !!! automatically if too small.
- INTEGER, INTENT(IN ) :: prec
- !!! Precision of the field data to be reinitialized. One of:
- !!!
- !!! *ppm_kind_single
- !!! *ppm_kind_double
- INTEGER, INTENT(IN ) :: meshid
- !!! Mesh ID (user numbering) for which a GMM should be initialized.
- INTEGER, INTENT(IN ) :: field_topoid
- !!! Topo ID of the field
- INTEGER, INTENT( OUT) :: info
- !!! Return status. 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER, DIMENSION(3) :: ldu
- INTEGER :: iopt,i,isub
- LOGICAL :: lok
- REAL(ppm_kind_double) :: t0
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_init',t0,info)
- topo => ppm_topo(field_topoid)%t
- mesh => topo%mesh(gmm_meshid)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_init', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_check_meshid(field_topoid,meshid,lok,info)
- IF (.NOT. lok) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_init', &
- & 'meshid out of range',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (Nest .LT. 1) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_init', &
- & 'Nest must be >0!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((prec.NE.ppm_kind_single).AND.(prec.NE.ppm_kind_double)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_init', &
- & 'Illegal precision specifiec!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Nullify the pointers to allow proper inquiry of ASSOCIATED status.
- !-------------------------------------------------------------------------
- NULLIFY(gmm_ipos)
- NULLIFY(gmm_phis)
- NULLIFY(gmm_phid)
- NULLIFY(gmm_state2d)
- NULLIFY(gmm_state3d)
- !-------------------------------------------------------------------------
- ! Allocate sparse work space structure
- !-------------------------------------------------------------------------
- gmm_lsiz = Nest
- iopt = ppm_param_alloc_fit
- ldu(1) = gmm_lsiz
- IF (prec .EQ. ppm_kind_double) THEN
- CALL ppm_alloc(gmm_phid,ldu,iopt,info)
- ELSE
- CALL ppm_alloc(gmm_phis,ldu,iopt,info)
- ENDIF
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_init', &
- & 'sparse data values GMM_PHI',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu(1) = ppm_dim + 1
- ldu(2) = gmm_lsiz
- CALL ppm_alloc(gmm_ipos,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_init', &
- & 'sparse data locations GMM_IPOS',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Translate meshid to internal numbering and store it
- !-------------------------------------------------------------------------
-
- gmm_meshid = mesh%ID
- !-------------------------------------------------------------------------
- ! Determine max extent of mesh in any sub
- !-------------------------------------------------------------------------
- maxxhi = 0
- maxyhi = 0
- maxzhi = 0
- DO i=1,topo%nsublist
- isub = topo%isublist(i)
- IF (mesh%nnodes(1,isub).GT.maxxhi) &
- & maxxhi = mesh%nnodes(1,isub)
- IF (mesh%nnodes(2,isub).GT.maxyhi) &
- & maxyhi = mesh%nnodes(2,isub)
- IF (ppm_dim .GT. 2) THEN
- IF (mesh%nnodes(3,isub).GT.maxzhi)&
- & maxzhi = mesh%nnodes(3,isub)
- ENDIF
- ENDDO
- !-------------------------------------------------------------------------
- ! Memory increment step size
- !-------------------------------------------------------------------------
- incr = MAX(maxxhi,maxyhi,maxzhi)
- incr = 10*incr*incr
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_init',t0,info)
- RETURN
-
- END SUBROUTINE ppm_gmm_init
diff --git a/src/ppm_gmm_jacobian.inc b/src/ppm_gmm_jacobian.inc
deleted file mode 100644
index 0c3e6f3ecc8097d78ab2b8525addc0b360142eee..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_jacobian.inc
+++ /dev/null
@@ -1,127 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for computing the jacobian of a mesh map
- ! The indexing is in mathematical ordering with the first index
- ! the row number and the second one the column number. This way
- ! multiplication with the transpose of the
- ! Jacobian will be stride-1 in memory.
- !
- ! INPUT: INTEGER :: i,j,k,jsub -- Point to compute at
- ! INTEGER :: order -- Desired order of FD scheme
- ! REAL(MK)(field) :: chi -- mesh node positions
- ! OUTPUT: REAL(MK)(3,3) :: jac -- The Jacobian
- ! [grad = transp(jac)*gref]
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_jacobian.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2005/09/06 14:32:07 ivos
- ! Now returns the Jacobian and NOT its transpose. Ordering is (a)ij=a(i,j).
- !
- ! Revision 1.2 2005/07/25 00:31:09 ivos
- ! bugfix: index errors in jacobian fixed.
- !
- ! Revision 1.1 2005/07/14 19:59:59 ivos
- ! Initial implementation.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __DIM == __3D
- !-------------------------------------------------------------------------
- ! Compute the inverse Jacobian using centered FD of order 2 or 4
- !-------------------------------------------------------------------------
- IF (order .NE. ppm_param_order_3) THEN
- ji(1,1) = dxihalf*(chi(1,i+1,j,k,jsub)-chi(1,i-1,j,k,jsub))
- ji(1,2) = dyihalf*(chi(1,i,j+1,k,jsub)-chi(1,i,j-1,k,jsub))
- ji(1,3) = dzihalf*(chi(1,i,j,k+1,jsub)-chi(1,i,j,k-1,jsub))
- ji(2,1) = dxihalf*(chi(2,i+1,j,k,jsub)-chi(2,i-1,j,k,jsub))
- ji(2,2) = dyihalf*(chi(2,i,j+1,k,jsub)-chi(2,i,j-1,k,jsub))
- ji(2,3) = dzihalf*(chi(2,i,j,k+1,jsub)-chi(2,i,j,k-1,jsub))
- ji(3,1) = dxihalf*(chi(3,i+1,j,k,jsub)-chi(3,i-1,j,k,jsub))
- ji(3,2) = dyihalf*(chi(3,i,j+1,k,jsub)-chi(3,i,j-1,k,jsub))
- ji(3,3) = dzihalf*(chi(3,i,j,k+1,jsub)-chi(3,i,j,k-1,jsub))
- ELSE
- ji(1,1) = &
- & dxitwelve*(chi(1,i-2,j,k,jsub)-8.0_MK*chi(1,i-1,j,k,jsub) &
- & +8.0_MK*chi(1,i+1,j,k,jsub)- chi(1,i+2,j,k,jsub))
- ji(1,2) = &
- & dyitwelve*(chi(1,i,j-2,k,jsub)-8.0_MK*chi(1,i,j-1,k,jsub) &
- & +8.0_MK*chi(1,i,j+1,k,jsub)- chi(1,i,j+2,k,jsub))
- ji(1,3) = &
- & dzitwelve*(chi(1,i,j,k-2,jsub)-8.0_MK*chi(1,i,j,k-1,jsub) &
- & +8.0_MK*chi(1,i,j,k+1,jsub)- chi(1,i,j,k+2,jsub))
- ji(2,1) = &
- & dxitwelve*(chi(2,i-2,j,k,jsub)-8.0_MK*chi(2,i-1,j,k,jsub) &
- & +8.0_MK*chi(2,i+1,j,k,jsub)- chi(2,i+2,j,k,jsub))
- ji(2,2) = &
- & dyitwelve*(chi(2,i,j-2,k,jsub)-8.0_MK*chi(2,i,j-1,k,jsub) &
- & +8.0_MK*chi(2,i,j+1,k,jsub)- chi(2,i,j+2,k,jsub))
- ji(2,3) = &
- & dzitwelve*(chi(2,i,j,k-2,jsub)-8.0_MK*chi(2,i,j,k-1,jsub) &
- & +8.0_MK*chi(2,i,j,k+1,jsub)- chi(2,i,j,k+2,jsub))
- ji(3,1) = &
- & dxitwelve*(chi(3,i-2,j,k,jsub)-8.0_MK*chi(3,i-1,j,k,jsub) &
- & +8.0_MK*chi(3,i+1,j,k,jsub)- chi(3,i+2,j,k,jsub))
- ji(3,2) = &
- & dyitwelve*(chi(3,i,j-2,k,jsub)-8.0_MK*chi(3,i,j-1,k,jsub) &
- & +8.0_MK*chi(3,i,j+1,k,jsub)- chi(3,i,j+2,k,jsub))
- ji(3,3) = &
- & dzitwelve*(chi(3,i,j,k-2,jsub)-8.0_MK*chi(3,i,j,k-1,jsub) &
- & +8.0_MK*chi(3,i,j,k+1,jsub)- chi(3,i,j,k+2,jsub))
- ENDIF
- !-------------------------------------------------------------------------
- ! Invert (grad = Transp(jac)*gref)
- !-------------------------------------------------------------------------
- det = ji(3,1)*ji(1,2)*ji(2,3) - ji(3,1)*ji(1,3)*ji(2,2) - &
- & ji(2,1)*ji(1,2)*ji(3,3) + ji(2,1)*ji(1,3)*ji(3,2) + &
- & ji(1,1)*ji(2,2)*ji(3,3) - ji(1,1)*ji(2,3)*ji(3,2)
- det = 1.0_MK/det
- jac(1,1) = ( ji(2,2)*ji(3,3) - ji(2,3)*ji(3,2))*det
- jac(2,1) = ( ji(3,1)*ji(2,3) - ji(2,1)*ji(3,3))*det
- jac(3,1) = (-ji(3,1)*ji(2,2) + ji(2,1)*ji(3,2))*det
- jac(1,2) = (-ji(1,2)*ji(3,3) + ji(1,3)*ji(3,2))*det
- jac(2,2) = (-ji(3,1)*ji(1,3) + ji(1,1)*ji(3,3))*det
- jac(3,2) = ( ji(3,1)*ji(1,2) - ji(1,1)*ji(3,2))*det
- jac(1,3) = ( ji(1,2)*ji(2,3) - ji(1,3)*ji(2,2))*det
- jac(2,3) = ( ji(2,1)*ji(1,3) - ji(1,1)*ji(2,3))*det
- jac(3,3) = (-ji(2,1)*ji(1,2) + ji(1,1)*ji(2,2))*det
-#elif __DIM == __2D
- !-------------------------------------------------------------------------
- ! Compute the inverse Jacobian using centered FD of order 2 or 4
- !-------------------------------------------------------------------------
- IF (order .NE. ppm_param_order_3) THEN
- ji(1,1) = dxihalf*(chi(1,i+1,j,jsub)-chi(1,i-1,j,jsub))
- ji(1,2) = dyihalf*(chi(1,i,j+1,jsub)-chi(1,i,j-1,jsub))
- ji(2,1) = dxihalf*(chi(2,i+1,j,jsub)-chi(2,i-1,j,jsub))
- ji(2,2) = dyihalf*(chi(2,i,j+1,jsub)-chi(2,i,j-1,jsub))
- ELSE
- ji(1,1) = &
- & dxitwelve*(chi(1,i-2,j,jsub)-8.0_MK*chi(1,i-1,j,jsub) &
- & +8.0_MK*chi(1,i+1,j,jsub)- chi(1,i+2,j,jsub))
- ji(1,2) = &
- & dyitwelve*(chi(1,i,j-2,jsub)-8.0_MK*chi(1,i,j-1,jsub) &
- & +8.0_MK*chi(1,i,j+1,jsub)- chi(1,i,j+2,jsub))
- ji(2,1) = &
- & dxitwelve*(chi(2,i-2,j,jsub)-8.0_MK*chi(2,i-1,j,jsub) &
- & +8.0_MK*chi(2,i+1,j,jsub)- chi(2,i+2,j,jsub))
- ji(2,2) = &
- & dyitwelve*(chi(2,i,j-2,jsub)-8.0_MK*chi(2,i,j-1,jsub) &
- & +8.0_MK*chi(2,i,j+1,jsub)- chi(2,i,j+2,jsub))
- ENDIF
- !-------------------------------------------------------------------------
- ! Invert
- !-------------------------------------------------------------------------
- det = ji(1,1)*ji(2,2) - ji(1,2)*ji(2,1)
- det = 1.0_MK/det
- jac(1,1) = ji(2,2)*det
- jac(2,1) = -ji(2,1)*det
- jac(1,2) = -ji(1,2)*det
- jac(2,2) = ji(1,1)*det
-#endif
-
diff --git a/src/ppm_gmm_kickoff.f b/src/ppm_gmm_kickoff.f
deleted file mode 100644
index bc1a90675504e462430c93139cc5ac5a1705dbda..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_kickoff.f
+++ /dev/null
@@ -1,1440 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_kickoff
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_kickoff_2ds(fdata,tol,thresh,info, &
- & npts,ipts,closest,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_kickoff_2dd(fdata,tol,thresh,info, &
- & npts,ipts,closest,chi)
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_kickoff_3ds(fdata,tol,thresh,info, &
- & npts,ipts,closest,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_kickoff_3dd(fdata,tol,thresh,info, &
- & npts,ipts,closest,chi)
-#endif
-#endif
- !!! This routine starts the gmm by computing second order accurate
- !!! approximations of the distance to the interface near it, i.e. on
- !!! neighboring grid points. Every sign reversal is interpreted as the
- !!! location of an interface! To use interfaces represented by a non-zero
- !!! level set, apply shifting as pre-processing.
- !!!
- !!! [NOTE]
- !!! ======================================================================
- !!! This routine creates second-order accurate data near the interface
- !!! and is needed to kick off a reinitialize a level set or extend a
- !!! function to a narrow band.
- !!!
- !!! The order of the method is limited by the order of the finite
- !!! differences used in computing the rhs of the interpolation system.
- !!! Use higher order FD to get higher order initialization.
- !!!
- !!! Tests have shown that storing shifted indices (i.e. ip1 = i+1) is
- !!! faster than using i+1 in the array index directly. We thus use
- !!! this technique here.
- !!!
- !!! Maybe we shoud actually allocate ipos and copy the stuff so it will
- !!! survive ppm_gmm_finalize?? This will be easy: just change the pointer
- !!! assignment at the end of the routine to a physical copy operation.
- !!! ======================================================================
- !!!
- !!! === References ====
- !!!
- !!! D.L. Chopp. Some improvements on the fast marching method. SIAM J.
- !!! Sci. Comput. 23(1):230-244, 2001.
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
-
- USE ppm_module_data_gmm
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- USE ppm_module_write
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER :: fdata
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdata
-#endif
- !!! Level set data. Either rank 3 (for 2D scalar fields), or rank
- !!! 4 (for 3D scalar fields). Indices: (i,j,[k],isub). On input: old
- !!! level function values. The interface is at level zero.
- !!! A ghostsize of 1 is needed on all sides which must be filled with the
- !!! old level function value on input!! On output: 2nd order approximation
- !!! of the signed distance function using the interpolation method of
- !!! Chopp Points far from the interface will have the value HUGE.
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: chi
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN), OPTIONAL :: chi
-#endif
- !!! rank 5 (3d) or rank 4 (2d) field specifying the positions of the grid
- !!! nodes. 1st index: 1..ppm_dim, then i,j,[k],isub. OPTIONAL. Uniform
- !!! grid is assumed if absent. Ghostlayers of size >=1 must be pre-filled.
-
- REAL(MK) , INTENT(IN ) :: tol
- !!! Relative tolerance for the determined distance to the interface.
- !!! 1E-3 is a good choice. The tolerance is in multiples of grid spacings.
- REAL(MK) , INTENT(IN ) :: thresh
- !!! Threshold for values in narrow band on input. Any zero-crossing from
- !!! a value larger than this will not be considered as interface. Set
- !!! this to the absolute value of whatever the field outside the band is
- !!! initialized to.
- REAL(MK), DIMENSION(:,:) , POINTER, OPTIONAL :: closest
- !!! coordinates of the closest points on the interface from the mesh
- !!! points in ipts. Not unique! OPTIONAL. Only computed and returned if
- !!! present.
- INTEGER , DIMENSION(:,:) , POINTER, OPTIONAL :: ipts
- !!! indices of mesh points adjacent to the interface. 1st index:
- !!! i,j,(k),jsub (local sub ID); 2nd: 1..npts. OPTIONAL has to be
- !!! present if closest is present! Not unique. The same point will occur
- !!! multiple times.
- INTEGER , INTENT(INOUT), OPTIONAL :: npts
- !!! ON input: if .LT. 0 the level is not recomputed and remains untouched.
- !!! Only the closest points are returned. On out: total number of points
- !!! adjacent to the interface. OPTIONAL. Has to be present if closest or
- !!! ipts are present!
- INTEGER , INTENT( OUT) :: info
- !!! Return status, 0 upon success.
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,j,k,xhi,yhi,zhi,ip1,jp1,kp1,npos
- INTEGER :: isub,jsub,sneg,nit,ind,f,iopt,ii
- INTEGER :: m,n,p,kpp,jpn,pp2,np2,ll,ntotal,ltotal
- INTEGER ,DIMENSION(2) :: ldu
- REAL(MK) :: t0,dx,dy,dz,nrm2,big,hsave
- REAL(MK) :: facx,facy,facz,facxy,facxz,facyz,facxyz
- REAL(MK) :: err,tol2,pxk,sprod,x,y,z
- REAL(MK),DIMENSION(ppm_dim) :: xk,x0,gradpxk,delta1,delta2,x0mxk,xkhalf
- REAL(MK),DIMENSION(:),POINTER :: phi
- LOGICAL :: lok
- INTEGER , DIMENSION(8) :: neg
- REAL(MK), DIMENSION(0:3) :: xv,yv,gxv,gyv
- CHARACTER(LEN=ppm_char) :: mesg,cbuf
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-#if __DIM == __2D
- REAL(MK), DIMENSION(16,16) :: A
- INTEGER , DIMENSION(16) :: Aind
- REAL(MK), DIMENSION(16) :: rhs,coef
- REAL(MK), DIMENSION(4,4) :: psi
- REAL(MK), DIMENSION(4) :: ch
- REAL(MK), DIMENSION(2) :: xr,xi
- INTEGER , PARAMETER :: Nel = 16
-#elif __DIM == __3D
- REAL(MK), DIMENSION(64,64) :: A
- INTEGER , DIMENSION(64) :: Aind
- REAL(MK), DIMENSION(64) :: rhs,coef
- REAL(MK), DIMENSION(4,4,4) :: psi
- REAL(MK), DIMENSION(0:3) :: zv,gzv
- REAL(MK), DIMENSION(8) :: ch
- REAL(MK), DIMENSION(3) :: xr,xi
- INTEGER , PARAMETER :: Nel = 64
-#endif
- !-------------------------------------------------------------------------
- ! DATA
- !-------------------------------------------------------------------------
-#if __DIM == __3D
- !-------------------------------------------------------------------------
- ! LU factorization of the system matrix for the 3D tri-cubic
- ! interpolation polynomial. Created using ppm_gmm_create_3dmatrix.m.
- !-------------------------------------------------------------------------
-#include "ppm_gmm_3dmatrix_data.inc"
- !-------------------------------------------------------------------------
- ! Permutation index vector of the LU factorization of the matrix.
- ! Created using ppm_gmm_create_3dmatrix.m.
- !-------------------------------------------------------------------------
-#include "ppm_gmm_3dpermut_data.inc"
-#elif __DIM == __2D
- !-------------------------------------------------------------------------
- ! LU factorization of the system matrix for the 2D bi-cubic
- ! interpolation polynomial. Created using ppm_gmm_create_2dmatrix.m.
- !-------------------------------------------------------------------------
-#include "ppm_gmm_2dmatrix_data.inc"
- !-------------------------------------------------------------------------
- ! Permutation index vector of the LU factorization of the matrix.
- ! Created using ppm_gmm_create_2dmatrix.m.
- !-------------------------------------------------------------------------
-#include "ppm_gmm_2dpermut_data.inc"
-#endif
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_kickoff',t0,info)
- ntotal = 0
- big = HUGE(big)
- hsave = 0.9_MK*big
- topo => ppm_topo(gmm_topoid)%t
- mesh => topo%mesh(gmm_meshid)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_kickoff', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (gmm_lsiz .LT. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_kickoff', &
- & 'Please call gmm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (tol .LE. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'tolerance must be >0!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (PRESENT(closest)) THEN
- IF (.NOT.PRESENT(ipts)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'ipts must be present if closest is',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (.NOT.PRESENT(npts)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'npts must be present if closest is',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (PRESENT(ipts)) THEN
- IF (.NOT.PRESENT(npts)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'npts must be present if ipts is',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (.NOT.ASSOCIATED(fdata)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'field data is not allocated!',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __3D
- IF (SIZE(fdata,4) .LT. topo%nsublist) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'field data for some subs is missing',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,1) .LT. maxxhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'x dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,2) .LT. maxyhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'y dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,3) .LT. maxzhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'z dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __DIM == __2D
- IF (SIZE(fdata,3) .LT. topo%nsublist) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'field data for some subs is missing',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,1) .LT. maxxhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'x dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,2) .LT. maxyhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_kickoff', &
- & 'y dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF ! ppm_debug for argument check
- !-------------------------------------------------------------------------
- ! Set the pointers to work memory (in module data_gmm)
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- phi => gmm_phis
-#elif __KIND == __DOUBLE_PRECISION
- phi => gmm_phid
-#endif
- !-------------------------------------------------------------------------
- ! Set constants
- !-------------------------------------------------------------------------
- xv(0) = 1.0_MK
- yv(0) = 1.0_MK
- gxv(0) = 0.0_MK
- gxv(1) = 1.0_MK
- gyv(0) = 0.0_MK
- gyv(1) = 1.0_MK
-#if __DIM == __3D
- zv(0) = 1.0_MK
- gzv(0) = 0.0_MK
- gzv(1) = 1.0_MK
-#endif
- !-------------------------------------------------------------------------
- ! Nuke OPTIONAL arrays
- !-------------------------------------------------------------------------
- IF (PRESENT(closest)) THEN
- iopt = ppm_param_dealloc
- CALL ppm_alloc(closest,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_kickoff', &
- & 'closest points CLOSEST',__LINE__,info)
- ENDIF
- ENDIF
- IF (PRESENT(ipts)) THEN
- iopt = ppm_param_dealloc
- CALL ppm_alloc(ipts,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_kickoff', &
- & 'point locations IPTS',__LINE__,info)
- ENDIF
- ENDIF
- ltotal = 0
- !-------------------------------------------------------------------------
- ! Find mesh spacing
- !-------------------------------------------------------------------------
- IF (ppm_kind .EQ. ppm_kind_single) THEN
- dx = (topo%max_physs(1)-topo%min_physs(1))/ &
- & REAL(mesh%Nm(1)-1,ppm_kind_single)
- dy = (topo%max_physs(2)-topo%min_physs(2))/ &
- & REAL(mesh%Nm(2)-1,ppm_kind_single)
- IF (ppm_dim .GT. 2) THEN
- dz = (topo%max_physs(3)-topo%min_physs(3))/ &
- & REAL(mesh%Nm(3)-1, &
- & ppm_kind_single)
- ENDIF
- ELSE
- dx = (topo%max_physs(1)-topo%min_physs(1))/ &
- & REAL(mesh%Nm(1)-1,ppm_kind_double)
- dy = (topo%max_physs(2)-topo%min_physs(2))/ &
- & REAL(mesh%Nm(2)-1,ppm_kind_double)
- IF (ppm_dim .GT. 2) THEN
- dz = (topo%max_physs(3)-topo%min_physs(3))/ &
- & REAL(mesh%Nm(3)-1, &
- & ppm_kind_double)
- ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Loop over all mesh blocks
- !-------------------------------------------------------------------------
- DO jsub=1,topo%nsublist
- npos= 0
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)-1
- yhi = mesh%nnodes(2,isub)-1
- facx= 0.5_MK
- facy= 0.5_MK
- facxy= 0.25_MK
-#if __DIM == __3D
- zhi = mesh%nnodes(3,isub)-1
- facz= 0.5_MK
- facxz= 0.25_MK
- facyz= 0.25_MK
- facxyz= 0.125_MK
- !---------------------------------------------------------------------
- ! Find mesh cells through which the zero level passes and
- ! that are close to the interface (to exclude the boundaries
- ! of the narrow band)
- !---------------------------------------------------------------------
- DO k=1,zhi
- kp1 = k+1
- DO j=1,yhi
- jp1 = j+1
- DO i=1,xhi
- ! storing the shifted index is 50% faster then
- ! doing the additions. According to test program.
- ip1 = i+1
- neg(1:8) = 0
- lok = .TRUE.
- IF (fdata(i ,j ,k ,jsub) .LT. 0.0_MK) neg(1) = 1
- IF (ABS(fdata(i,j,k,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(ip1,j ,k ,jsub) .LT. 0.0_MK) neg(2) = 1
- IF (ABS(fdata(ip1,j,k,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(i ,jp1,k ,jsub) .LT. 0.0_MK) neg(3) = 1
- IF (ABS(fdata(i,jp1,k,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(ip1,jp1,k ,jsub) .LT. 0.0_MK) neg(4) = 1
- IF (ABS(fdata(ip1,jp1,k,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(i ,j ,kp1,jsub) .LT. 0.0_MK) neg(5) = 1
- IF (ABS(fdata(i,j,kp1,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(ip1,j ,kp1,jsub) .LT. 0.0_MK) neg(6) = 1
- IF (ABS(fdata(ip1,j,kp1,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(i ,jp1,kp1,jsub) .LT. 0.0_MK) neg(7) = 1
- IF (ABS(fdata(i,jp1,kp1,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(ip1,jp1,kp1,jsub) .LT. 0.0_MK) neg(8) = 1
- IF (ABS(fdata(ip1,jp1,kp1,jsub)).GT.thresh) lok = .FALSE.
- sneg = neg(1)+neg(2)+neg(3)+neg(4)+neg(5)+neg(6)+ &
- & neg(7)+neg(8)
- IF ((sneg.GT.0).AND.(sneg.LT.8).AND.(lok)) THEN
- !-----------------------------------------------------
- ! Old value of the level function
- !-----------------------------------------------------
- DO p=-1,2
- pp2 = p+2
- kpp = k+p
- DO n=-1,2
- np2 = n+2
- jpn = j+n
- DO m=-1,2
- psi(m+2,np2,pp2) = fdata(i+m,jpn,kpp,jsub)
- ENDDO
- ENDDO
- ENDDO
- !-----------------------------------------------------
- ! Right-hand-side for tri-cubic interpolation
- ! polynomial. The order of the method is
- ! limited by the order of the finite
- ! differences used here.
- !-----------------------------------------------------
- ! value at (i,j,k)
- rhs(1) = psi(2,2,2)
- ! value at (i+1,j,k)
- rhs(2) = psi(3,2,2)
- ! value at (i,j+1,k)
- rhs(3) = psi(2,3,2)
- ! value at (i+1,j+1,k)
- rhs(4) = psi(3,3,2)
- ! value at (i,j,k+1)
- rhs(5) = psi(2,2,3)
- ! value at (i+1,j,k+1)
- rhs(6) = psi(3,2,3)
- ! value at (i,j+1,k+1)
- rhs(7) = psi(2,3,3)
- ! value at (i+1,j+1,k+1)
- rhs(8) = psi(3,3,3)
- !-----------------------------------------------------
- ! Dx at (i,j,k)
- rhs(9) = facx*(psi(3,2,2)-psi(1,2,2))
- ! Dx at (i+1,j,k)
- rhs(10) = facx*(psi(4,2,2)-psi(2,2,2))
- ! Dx at (i,j+1,k)
- rhs(11) = facx*(psi(3,3,2)-psi(1,3,2))
- ! Dx at (i+1,j+1,k)
- rhs(12) = facx*(psi(4,3,2)-psi(2,3,2))
- ! Dx at (i,j,k+1)
- rhs(13) = facx*(psi(3,2,3)-psi(1,2,3))
- ! Dx at (i+1,j,k+1)
- rhs(14) = facx*(psi(4,2,3)-psi(2,2,3))
- ! Dx at (i,j+1,k+1)
- rhs(15) = facx*(psi(3,3,3)-psi(1,3,3))
- ! Dx at (i+1,j+1,k+1)
- rhs(16) = facx*(psi(4,3,3)-psi(2,3,3))
- !-----------------------------------------------------
- ! Dy at (i,j,k)
- rhs(17) = facy*(psi(2,3,2)-psi(2,1,2))
- ! Dy at (i+1,j,k)
- rhs(18) = facy*(psi(3,3,2)-psi(3,1,2))
- ! Dy at (i,j+1,k)
- rhs(19) = facy*(psi(2,4,2)-psi(2,2,2))
- ! Dy at (i+1,j+1,k)
- rhs(20) = facy*(psi(3,4,2)-psi(3,2,2))
- ! Dy at (i,j,k+1)
- rhs(21) = facy*(psi(2,3,3)-psi(2,1,3))
- ! Dy at (i+1,j,k+1)
- rhs(22) = facy*(psi(3,3,3)-psi(3,1,3))
- ! Dy at (i,j+1,k+1)
- rhs(23) = facy*(psi(2,4,3)-psi(2,2,3))
- ! Dy at (i+1,j+1,k+1)
- rhs(24) = facy*(psi(3,4,3)-psi(3,2,3))
- !-----------------------------------------------------
- ! Dz at (i,j,k)
- rhs(25) = facz*(psi(2,2,3)-psi(2,2,1))
- ! Dz at (i+1,j,k)
- rhs(26) = facz*(psi(3,2,3)-psi(3,2,1))
- ! Dz at (i,j+1,k)
- rhs(27) = facz*(psi(2,3,3)-psi(2,3,1))
- ! Dz at (i+1,j+1,k)
- rhs(28) = facz*(psi(3,3,3)-psi(3,3,1))
- ! Dz at (i,j,k+1)
- rhs(29) = facz*(psi(2,2,4)-psi(2,2,2))
- ! Dz at (i+1,j,k+1)
- rhs(30) = facz*(psi(3,2,4)-psi(3,2,2))
- ! Dz at (i,j+1,k+1)
- rhs(31) = facz*(psi(2,3,4)-psi(2,3,2))
- ! Dz at (i+1,j+1,k+1)
- rhs(32) = facz*(psi(3,3,4)-psi(3,3,2))
- !-----------------------------------------------------
- ! DxDy at (i,j,k)
- rhs(33) = facxy*(psi(3,3,2)-psi(1,3,2)- &
- & psi(3,1,2)+psi(1,1,2))
- ! DxDy at (i+1,j,k)
- rhs(34) = facxy*(psi(4,3,2)-psi(2,3,2)- &
- & psi(4,1,2)+psi(2,1,2))
- ! DxDy at (i,j+1,k)
- rhs(35) = facxy*(psi(3,4,2)-psi(1,4,2)- &
- & psi(3,2,2)+psi(1,2,2))
- ! DxDy at (i+1,j+1,k)
- rhs(36) = facxy*(psi(4,4,2)-psi(2,4,2)- &
- & psi(4,2,2)+psi(2,2,2))
- ! DxDy at (i,j,k+1)
- rhs(37) = facxy*(psi(3,3,3)-psi(1,3,3)- &
- & psi(3,1,3)+psi(1,1,3))
- ! DxDy at (i+1,j,k+1)
- rhs(38) = facxy*(psi(4,3,3)-psi(2,3,3)- &
- & psi(4,1,3)+psi(2,1,3))
- ! DxDy at (i,j+1,k+1)
- rhs(39) = facxy*(psi(3,4,3)-psi(1,4,3)- &
- & psi(3,2,3)+psi(1,2,3))
- ! DxDy at (i+1,j+1,k+1)
- rhs(40) = facxy*(psi(4,4,3)-psi(2,4,3)- &
- & psi(4,2,3)+psi(2,2,3))
- !-----------------------------------------------------
- ! DxDz at (i,j,k)
- rhs(41) = facxz*(psi(3,2,3)-psi(1,2,3)- &
- & psi(3,2,1)+psi(1,2,1))
- ! DxDz at (i+1,j,k)
- rhs(42) = facxz*(psi(4,2,3)-psi(2,2,3)- &
- & psi(4,2,1)+psi(2,2,1))
- ! DxDz at (i,j+1,k)
- rhs(43) = facxz*(psi(3,3,3)-psi(1,3,3)- &
- & psi(3,3,1)+psi(1,3,1))
- ! DxDz at (i+1,j+1,k)
- rhs(44) = facxz*(psi(4,3,3)-psi(2,3,3)- &
- & psi(4,3,1)+psi(2,3,1))
- ! DxDz at (i,j,k+1)
- rhs(45) = facxz*(psi(3,2,4)-psi(1,2,4)- &
- & psi(3,2,2)+psi(1,2,2))
- ! DxDz at (i+1,j,k+1)
- rhs(46) = facxz*(psi(4,2,4)-psi(2,2,4)- &
- & psi(4,2,2)+psi(2,2,2))
- ! DxDz at (i,j+1,k+1)
- rhs(47) = facxz*(psi(3,3,4)-psi(1,3,4)- &
- & psi(3,3,2)+psi(1,3,2))
- ! DxDz at (i+1,j+1,k+1)
- rhs(48) = facxz*(psi(4,3,4)-psi(2,3,4)- &
- & psi(4,3,2)+psi(2,3,2))
- !-----------------------------------------------------
- ! DyDz at (i,j,k)
- rhs(49) = facyz*(psi(2,3,3)-psi(2,1,3)- &
- & psi(2,3,1)+psi(2,1,1))
- ! DyDz at (i+1,j,k)
- rhs(50) = facyz*(psi(3,3,3)-psi(3,1,3)- &
- & psi(3,3,1)+psi(3,1,1))
- ! DyDz at (i,j+1,k)
- rhs(51) = facyz*(psi(2,4,3)-psi(2,2,3)- &
- & psi(2,4,1)+psi(2,2,1))
- ! DyDz at (i+1,j+1,k)
- rhs(52) = facyz*(psi(3,4,3)-psi(3,2,3)- &
- & psi(3,4,1)+psi(3,2,1))
- ! DyDz at (i,j,k+1)
- rhs(53) = facyz*(psi(2,3,4)-psi(2,1,4)- &
- & psi(2,3,2)+psi(2,1,2))
- ! DyDz at (i+1,j,k+1)
- rhs(54) = facyz*(psi(3,3,4)-psi(3,1,4)- &
- & psi(3,3,2)+psi(3,1,2))
- ! DyDz at (i,j+1,k+1)
- rhs(55) = facyz*(psi(2,4,4)-psi(2,2,4)- &
- & psi(2,4,2)+psi(2,2,2))
- ! DyDz at (i+1,j+1,k+1)
- rhs(56) = facyz*(psi(3,4,4)-psi(3,2,4)- &
- & psi(3,4,2)+psi(3,2,2))
- !-----------------------------------------------------
- ! DxDyDz at (i,j,k)
- rhs(57) = facxyz*(psi(3,3,3)-psi(3,3,1)- &
- & psi(3,1,3)+psi(3,1,1)-psi(1,3,3)+ &
- & psi(1,3,1)+psi(1,1,3)-psi(1,1,1))
- ! DxDyDz at (i+1,j,k)
- rhs(58) = facxyz*(psi(4,3,3)-psi(4,3,1)- &
- & psi(4,1,3)+psi(4,1,1)-psi(2,3,3)+ &
- & psi(2,3,1)+psi(2,1,3)-psi(2,1,1))
- ! DxDyDz at (i,j+1,k)
- rhs(59) = facxyz*(psi(3,4,3)-psi(3,4,1)- &
- & psi(3,2,3)+psi(3,2,1)-psi(1,4,3)+ &
- & psi(1,4,1)+psi(1,2,3)-psi(1,2,1))
- ! DxDyDz at (i+1,j+1,k)
- rhs(60) = facxyz*(psi(4,4,3)-psi(4,4,1)- &
- & psi(4,2,3)+psi(4,2,1)-psi(2,4,3)+ &
- & psi(2,4,1)+psi(2,2,3)-psi(2,2,1))
- ! DxDyDz at (i,j,k+1)
- rhs(61) = facxyz*(psi(3,3,4)-psi(3,3,2)- &
- & psi(3,1,4)+psi(3,1,2)-psi(1,3,4)+ &
- & psi(1,3,2)+psi(1,1,4)-psi(1,1,2))
- ! DxDyDz at (i+1,j,k+1)
- rhs(62) = facxyz*(psi(4,3,4)-psi(4,3,2)- &
- & psi(4,1,4)+psi(4,1,2)-psi(2,3,4)+ &
- & psi(2,3,2)+psi(2,1,4)-psi(2,1,2))
- ! DxDyDz at (i,j+1,k+1)
- rhs(63) = facxyz*(psi(3,4,4)-psi(3,4,2)- &
- & psi(3,2,4)+psi(3,2,2)-psi(1,4,4)+ &
- & psi(1,4,2)+psi(1,2,4)-psi(1,2,2))
- ! DxDyDz at (i+1,j+1,k+1)
- rhs(64) = facxyz*(psi(4,4,4)-psi(4,4,2)- &
- & psi(4,2,4)+psi(4,2,2)-psi(2,4,4)+ &
- & psi(2,4,2)+psi(2,2,4)-psi(2,2,2))
- !-----------------------------------------------------
- ! Check if needed
- !-----------------------------------------------------
- IF (ppm_debug .GT. 1) THEN
- DO m=1,64
- IF ((rhs(m) .NE. rhs(m)) .OR. &
- & (ABS(rhs(m)) .GT. hsave)) THEN
- !-----------------------------------------
- ! rhs(m) is Inf or NaN
- !-----------------------------------------
- CALL ppm_write(ppm_rank, &
- & 'ppm_gmm_kickoff', &
- & 'WARNING: RHS not defined! Check support of input field!',info)
- ENDIF
- ENDDO
- ENDIF
- !-----------------------------------------------------
- ! Solve for polynomial coefficients. coef will
- ! contain the result.
- !-----------------------------------------------------
-#include "ppm_gmm_lubksb.inc"
-! CHECK SOLUTION
-! U = 0.0_MK
-! L = 0.0_MK
-! LU = 0.0_MK
-! DO ii=1,64
-! DO jj=ii,64
-! U(ii,jj) = A(ii,jj)
-! ENDDO
-! ENDDO
-! DO ii=1,64
-! DO jj=1,(ii-1)
-! L(ii,jj) = A(ii,jj)
-! ENDDO
-! ENDDO
-! DO ii=1,64
-! L(ii,ii) = L(ii,ii) + 1.0_MK
-! ENDDO
-! LU = MATMUL(L,U)
-! gaga = MATMUL(LU,coef)
-! nrm2 = 0.0_MK
-! DO ii=1,64
-! ll = Aind(ii)
-! nrm2 = nrm2 + (gaga(ii)-rhs(ll))**2
-! ENDDO
-! ! IF (nrm2 .NE. nrm2) THEN
-! PRINT*,'ERROR: ',nrm2
-! ! PRINT*,'rhs: ',rhs
-! ! PRINT*,'coefs: ',coef
-! ! ENDIF
-! Wanna see them interpolants in MATLAB??? Uncomment this!
-! WRITE(cbuf,'(A,I3.3,A)') 'interp_',npos/8,'.out'
-! OPEN(30,FILE=cbuf,STATUS='REPLACE',ACTION='WRITE')
-! WRITE(30,'(3E20.8)') topo%min_subs(1,isub,gmm_topoid)+(i-1)*dx, &
-! & topo%min_subs(2,isub,gmm_topoid)+(j-1)*dy, &
-! & topo%min_subs(3,isub,gmm_topoid)+(k-1)*dz
-! WRITE(30,'(3E20.8)') topo%min_subs(1,isub,gmm_topoid)+(i)*dx, &
-! & topo%min_subs(2,isub,gmm_topoid)+(j-1)*dy, &
-! & topo%min_subs(3,isub,gmm_topoid)+(k-1)*dz
-! WRITE(30,'(3E20.8)') topo%min_subs(1,isub,gmm_topoid)+(i-1)*dx, &
-! & topo%min_subs(2,isub,gmm_topoid)+(j)*dy, &
-! & topo%min_subs(3,isub,gmm_topoid)+(k-1)*dz
-! WRITE(30,'(3E20.8)') topo%min_subs(1,isub,gmm_topoid)+(i)*dx, &
-! & topo%min_subs(2,isub,gmm_topoid)+(j)*dy, &
-! & topo%min_subs(3,isub,gmm_topoid)+(k-1)*dz
-! WRITE(30,'(3E20.8)') topo%min_subs(1,isub,gmm_topoid)+(i-1)*dx, &
-! & topo%min_subs(2,isub,gmm_topoid)+(j-1)*dy, &
-! & topo%min_subs(3,isub,gmm_topoid)+(k)*dz
-! WRITE(30,'(3E20.8)') topo%min_subs(1,isub,gmm_topoid)+(i)*dx, &
-! & topo%min_subs(2,isub,gmm_topoid)+(j-1)*dy, &
-! & topo%min_subs(3,isub,gmm_topoid)+(k)*dz
-! WRITE(30,'(3E20.8)') topo%min_subs(1,isub,gmm_topoid)+(i-1)*dx, &
-! & topo%min_subs(2,isub,gmm_topoid)+(j)*dy, &
-! & topo%min_subs(3,isub,gmm_topoid)+(k)*dz
-! WRITE(30,'(3E20.8)') topo%min_subs(1,isub,gmm_topoid)+(i)*dx, &
-! & topo%min_subs(2,isub,gmm_topoid)+(j)*dy, &
-! & (3,isub,gmm_topoid)+(k)*dz
-! WRITE(30,'(2E20.8)') rhs(1),rhs(2)
-! WRITE(30,'(2E20.8)') rhs(3),rhs(4)
-! WRITE(30,'(2E20.8)') rhs(5),rhs(6)
-! WRITE(30,'(2E20.8)') rhs(7),rhs(8)
-! DO ii=1,64
-! WRITE(30,'(E20.8)') coef(ii)
-! ENDDO
-! CLOSE(30)
- !-----------------------------------------------------
- ! Check that sparse structure has at least 8
- ! spaces to hold the new data
- !-----------------------------------------------------
- IF (gmm_lsiz .LT. npos+8) THEN
- gmm_lsiz = gmm_lsiz + incr
- iopt = ppm_param_alloc_grow_preserve
- ldu(1) = gmm_lsiz
- CALL ppm_alloc(phi,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc, &
- & 'ppm_gmm_kickoff', &
- & 'sparse values GMM_PHI',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu(1) = 4
- ldu(2) = gmm_lsiz
- CALL ppm_alloc(gmm_ipos,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc, &
- & 'ppm_gmm_kickoff', &
- & 'sparse positions GMM_IPOS',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (PRESENT(closest)) THEN
- IF (ltotal .LT. ntotal+8) THEN
- ltotal = ntotal + incr
- iopt = ppm_param_alloc_grow_preserve
- ldu(1) = 3
- ldu(2) = ltotal
- CALL ppm_alloc(closest,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc, &
- & 'ppm_gmm_kickoff', &
- & 'closest points CLOSEST', &
- & __LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Newton iteration for each point bounding
- ! the mesh cell to find the new level
- ! function value and the closest point on the
- ! interface.
- !-----------------------------------------------------
- IF (PRESENT(closest).AND..NOT.PRESENT(chi)) THEN
-#if __KIND == __SINGLE_PRECISION
- x = topo%min_subs(1,isub)+(i-1)*dx
- y = topo%min_subs(2,isub)+(j-1)*dy
- z = topo%min_subs(3,isub)+(k-1)*dz
-#elif __KIND == __DOUBLE_PRECISION
- x = topo%min_subd(1,isub)+(i-1)*dx
- y = topo%min_subd(2,isub)+(j-1)*dy
- z = topo%min_subd(3,isub)+(k-1)*dz
-#endif
- ENDIF
- x0 = 0.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,i,j,k,jsub)
- y = chi(2,i,j,k,jsub)
- z = chi(3,i,j,k,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(1).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = i
- gmm_ipos(2,npos) = j
- gmm_ipos(3,npos) = k
- gmm_ipos(4,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- closest(3,ntotal) = xr(3)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- closest(3,ntotal) = z + dz*xk(3)
- ENDIF
- ENDIF
- !-----------------------------------------------------
- x0(1) = 1.0_MK
- x0(2) = 0.0_MK
- x0(3) = 0.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,ip1,j,k,jsub)
- y = chi(2,ip1,j,k,jsub)
- z = chi(3,ip1,j,k,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(2).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = ip1
- gmm_ipos(2,npos) = j
- gmm_ipos(3,npos) = k
- gmm_ipos(4,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- closest(3,ntotal) = xr(3)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- closest(3,ntotal) = z + dz*xk(3)
- ENDIF
- ENDIF
- !-----------------------------------------------------
- x0(1) = 0.0_MK
- x0(2) = 1.0_MK
- x0(3) = 0.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,i,jp1,k,jsub)
- y = chi(2,i,jp1,k,jsub)
- z = chi(3,i,jp1,k,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(3).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = i
- gmm_ipos(2,npos) = jp1
- gmm_ipos(3,npos) = k
- gmm_ipos(4,npos) = jsub
- phi(npos) = sprod
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- closest(3,ntotal) = xr(3)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- closest(3,ntotal) = z + dz*xk(3)
- ENDIF
- ENDIF
- !-----------------------------------------------------
- x0(1) = 1.0_MK
- x0(2) = 1.0_MK
- x0(3) = 0.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,ip1,jp1,k,jsub)
- y = chi(2,ip1,jp1,k,jsub)
- z = chi(3,ip1,jp1,k,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(4).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = ip1
- gmm_ipos(2,npos) = jp1
- gmm_ipos(3,npos) = k
- gmm_ipos(4,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- closest(3,ntotal) = xr(3)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- closest(3,ntotal) = z + dz*xk(3)
- ENDIF
- ENDIF
- !-----------------------------------------------------
- x0(1) = 0.0_MK
- x0(2) = 0.0_MK
- x0(3) = 1.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,i,j,kp1,jsub)
- y = chi(2,i,j,kp1,jsub)
- z = chi(3,i,j,kp1,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(5).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = i
- gmm_ipos(2,npos) = j
- gmm_ipos(3,npos) = kp1
- gmm_ipos(4,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- closest(3,ntotal) = xr(3)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- closest(3,ntotal) = z + dz*xk(3)
- ENDIF
- ENDIF
- !-----------------------------------------------------
- x0(1) = 1.0_MK
- x0(2) = 0.0_MK
- x0(3) = 1.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,ip1,j,kp1,jsub)
- y = chi(2,ip1,j,kp1,jsub)
- z = chi(3,ip1,j,kp1,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(6).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = ip1
- gmm_ipos(2,npos) = j
- gmm_ipos(3,npos) = kp1
- gmm_ipos(4,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- closest(3,ntotal) = xr(3)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- closest(3,ntotal) = z + dz*xk(3)
- ENDIF
- ENDIF
- !-----------------------------------------------------
- x0(1) = 0.0_MK
- x0(2) = 1.0_MK
- x0(3) = 1.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,i,jp1,kp1,jsub)
- y = chi(2,i,jp1,kp1,jsub)
- z = chi(3,i,jp1,kp1,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(7).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = i
- gmm_ipos(2,npos) = jp1
- gmm_ipos(3,npos) = kp1
- gmm_ipos(4,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- closest(3,ntotal) = xr(3)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- closest(3,ntotal) = z + dz*xk(3)
- ENDIF
- ENDIF
- !-----------------------------------------------------
- x0(1) = 1.0_MK
- x0(2) = 1.0_MK
- x0(3) = 1.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,ip1,jp1,kp1,jsub)
- y = chi(2,ip1,jp1,kp1,jsub)
- z = chi(3,ip1,jp1,kp1,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(8).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = ip1
- gmm_ipos(2,npos) = jp1
- gmm_ipos(3,npos) = kp1
- gmm_ipos(4,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- closest(3,ntotal) = xr(3)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- closest(3,ntotal) = z + dz*xk(3)
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ENDIF ! cell near interface
- ENDDO ! mesh cell i
- ENDDO ! mesh cell j
- ENDDO ! mesh cell k
-#elif __DIM == __2D
- !---------------------------------------------------------------------
- ! Find mesh cells through which the zero level passes and
- ! that are close to the interface (to exclude the boundaries
- ! of the narrow band)
- !---------------------------------------------------------------------
- DO j=1,yhi
- jp1 = j+1
- DO i=1,xhi
- ip1 = i+1
- neg(1:8) = 0
- lok = .TRUE.
- IF (fdata(i ,j ,jsub) .LT. 0.0_MK) neg(1) = 1
- IF (ABS(fdata(i ,j ,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(ip1,j ,jsub) .LT. 0.0_MK) neg(2) = 1
- IF (ABS(fdata(ip1,j ,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(i ,jp1,jsub) .LT. 0.0_MK) neg(3) = 1
- IF (ABS(fdata(i ,jp1,jsub)) .GT. thresh) lok = .FALSE.
- IF (fdata(ip1,jp1,jsub) .LT. 0.0_MK) neg(4) = 1
- IF (ABS(fdata(ip1,jp1,jsub)) .GT. thresh) lok = .FALSE.
- sneg = neg(1)+neg(2)+neg(3)+neg(4)
- IF ((sneg.GT.0).AND.(sneg.LT.4).AND.(lok)) THEN
- !---------------------------------------------------------
- ! Old value of the level function
- !---------------------------------------------------------
- DO n=-1,2
- np2 = n+2
- jpn = j+n
- DO m=-1,2
- psi(m+2,np2) = fdata(i+m,jpn,jsub)
- ENDDO
- ENDDO
- !---------------------------------------------------------
- ! Right-hand-side for bi-cubic interpolation
- ! polynomial. The order of the method is
- ! limited by the order of the finite
- ! differences used here.
- !---------------------------------------------------------
- ! value at (i,j)
- rhs(1) = psi(2,2)
- ! value at (i+1,j)
- rhs(2) = psi(3,2)
- ! value at (i,j+1)
- rhs(3) = psi(2,3)
- ! value at (i+1,j+1)
- rhs(4) = psi(3,3)
- !---------------------------------------------------------
- ! Dx at (i,j)
- rhs(5) = facx*(psi(3,2)-psi(1,2))
- ! Dx at (i+1,j)
- rhs(6) = facx*(psi(4,2)-psi(2,2))
- ! Dx at (i,j+1)
- rhs(7) = facx*(psi(3,3)-psi(1,3))
- ! Dx at (i+1,j+1)
- rhs(8) = facx*(psi(4,3)-psi(2,3))
- !---------------------------------------------------------
- ! Dy at (i,j)
- rhs(9) = facy*(psi(2,3)-psi(2,1))
- ! Dy at (i+1,j)
- rhs(10) = facy*(psi(3,3)-psi(3,1))
- ! Dy at (i,j+1)
- rhs(11) = facy*(psi(2,4)-psi(2,2))
- ! Dy at (i+1,j+1)
- rhs(12) = facy*(psi(3,4)-psi(3,2))
- !---------------------------------------------------------
- ! DxDy at (i,j)
- rhs(13) = facxy*(psi(3,3)-psi(1,3)-psi(3,1)+psi(1,1))
- ! DxDy at (i+1,j)
- rhs(14) = facxy*(psi(4,3)-psi(2,3)-psi(4,1)+psi(2,1))
- ! DxDy at (i,j+1)
- rhs(15) = facxy*(psi(3,4)-psi(1,4)-psi(3,2)+psi(1,2))
- ! DxDy at (i+1,j+1)
- rhs(16) = facxy*(psi(4,4)-psi(2,4)-psi(4,2)+psi(2,2))
- !---------------------------------------------------------
- ! Check if needed
- !---------------------------------------------------------
- IF (ppm_debug .GT. 1) THEN
- DO m=1,16
- IF ((rhs(m) .NE. rhs(m)) .OR. &
- & (ABS(rhs(m)) .GT. hsave)) THEN
- !---------------------------------------------
- ! rhs(m) is Inf or NaN or too big
- !---------------------------------------------
- CALL ppm_write(ppm_rank, &
- & 'ppm_gmm_kickoff', &
- & 'WARNING: RHS not defined! Check support of input field!',info)
- ENDIF
- ENDDO
- ENDIF
- !---------------------------------------------------------
- ! Solve for polynomial coefficients. coef will
- ! contain the result.
- !---------------------------------------------------------
-#include "ppm_gmm_lubksb.inc"
-! CHECK SOLUTION
-! U = 0.0_MK
-! L = 0.0_MK
-! LU = 0.0_MK
-! DO ii=1,16
-! DO jj=ii,16
-! U(ii,jj) = A(ii,jj)
-! ENDDO
-! ENDDO
-! DO ii=1,16
-! DO jj=1,(ii-1)
-! L(ii,jj) = A(ii,jj)
-! ENDDO
-! ENDDO
-! DO ii=1,16
-! L(ii,ii) = L(ii,ii) + 1.0_MK
-! ENDDO
-! LU = MATMUL(L,U)
-! gaga = MATMUL(LU,coef)
-! nrm2 = 0.0_MK
-! DO ii=1,16
-! ll = Aind(ii)
-! nrm2 = nrm2 + (gaga(ii)-rhs(ll))**2
-! ENDDO
-! PRINT*,'ERROR: ',nrm2
-! Wanna see them interpolants in MATLAB??? Uncomment this!
-! WRITE(cbuf,'(A,I3.3,A)') 'interp_',npos/4,'.out'
-! OPEN(30,FILE=cbuf,STATUS='REPLACE',ACTION='WRITE')
-! WRITE(30,'(2E20.8)') topo%min_subd(1,isub,gmm_topoid)+(i-1)*dx, &
-! & topo%min_subd(2,isub,gmm_topoid)+(j-1)*dy
-! WRITE(30,'(2E20.8)') topo%min_subd(1,isub,gmm_topoid)+(i)*dx, &
-! & topo%min_subd(2,isub,gmm_topoid)+(j-1)*dy
-! WRITE(30,'(2E20.8)') topo%min_subd(1,isub,gmm_topoid)+(i-1)*dx, &
-! & topo%min_subd(2,isub,gmm_topoid)+(j)*dy
-! WRITE(30,'(2E20.8)') topo%min_subd(1,isub,gmm_topoid)+(i)*dx, &
-! & topo%min_subd(2,isub,gmm_topoid)+(j)*dy
-! WRITE(30,'(2E20.8)') rhs(1),rhs(2)
-! WRITE(30,'(2E20.8)') rhs(3),rhs(4)
-! WRITE(30,'(2E20.8)') coef(1:2)
-! WRITE(30,'(2E20.8)') coef(3:4)
-! WRITE(30,'(2E20.8)') coef(5:6)
-! WRITE(30,'(2E20.8)') coef(7:8)
-! WRITE(30,'(2E20.8)') coef(9:10)
-! WRITE(30,'(2E20.8)') coef(11:12)
-! WRITE(30,'(2E20.8)') coef(13:14)
-! WRITE(30,'(2E20.8)') coef(15:16)
-! CLOSE(30)
- !---------------------------------------------------------
- ! Check that sparse structure has at least 4
- ! spaces to hold the new data
- !---------------------------------------------------------
- IF (gmm_lsiz .LT. npos+4) THEN
- gmm_lsiz = gmm_lsiz + incr
- iopt = ppm_param_alloc_grow_preserve
- ldu(1) = gmm_lsiz
- CALL ppm_alloc(phi,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc, &
- & 'ppm_gmm_kickoff', &
- & 'sparse values GMM_PHI',__LINE__,info)
- GOTO 9999
- ENDIF
- ldu(1) = 3
- ldu(2) = gmm_lsiz
- CALL ppm_alloc(gmm_ipos,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc, &
- & 'ppm_gmm_kickoff', &
- & 'sparse positions GMM_IPOS',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (PRESENT(closest)) THEN
- IF (ltotal .LT. ntotal+4) THEN
- ltotal = ntotal + incr
- iopt = ppm_param_alloc_grow_preserve
- ldu(1) = 2
- ldu(2) = ltotal
- CALL ppm_alloc(closest,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc, &
- & 'ppm_gmm_kickoff', &
- & 'closest points CLOSEST', &
- & __LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- ENDIF
- !---------------------------------------------------------
- ! Newton iteration for each point bounding
- ! the mesh cell to find the new level
- ! function value and the closest point on the
- ! interface.
- !---------------------------------------------------------
- IF (PRESENT(closest).AND..NOT.PRESENT(chi)) THEN
-#if __KIND == __SINGLE_PRECISION
- x = topo%min_subs(1,isub)+(i-1)*dx
- y = topo%min_subs(2,isub)+(j-1)*dy
-#elif __KIND == __DOUBLE_PRECISION
- x = topo%min_subd(1,isub)+(i-1)*dx
- y = topo%min_subd(2,isub)+(j-1)*dy
-#endif
- ENDIF
- x0 = 0.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,i,j,jsub)
- y = chi(2,i,j,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- ! BTW: the closest point on the interface is xk
- IF (neg(1).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = i
- gmm_ipos(2,npos) = j
- gmm_ipos(3,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- ENDIF
- ENDIF
- !---------------------------------------------------------
- x0(1) = 1.0_MK
- x0(2) = 0.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,ip1,j,jsub)
- y = chi(2,ip1,j,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(2).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = ip1
- gmm_ipos(2,npos) = j
- gmm_ipos(3,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- ENDIF
- ENDIF
- !---------------------------------------------------------
- x0(1) = 0.0_MK
- x0(2) = 1.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,i,jp1,jsub)
- y = chi(2,i,jp1,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(3).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = i
- gmm_ipos(2,npos) = jp1
- gmm_ipos(3,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- ENDIF
- ENDIF
- !---------------------------------------------------------
- x0(1) = 1.0_MK
- x0(2) = 1.0_MK
- IF (PRESENT(chi)) THEN
- x = chi(1,ip1,jp1,jsub)
- y = chi(2,ip1,jp1,jsub)
- ENDIF
-#include "ppm_gmm_quasinewton.inc"
- IF (neg(4).EQ.1) sprod = -sprod
- npos = npos + 1
- ntotal = ntotal + 1
- gmm_ipos(1,npos) = ip1
- gmm_ipos(2,npos) = jp1
- gmm_ipos(3,npos) = jsub
- phi(npos) = sprod
- ! the closest point on the interface is xk
- IF (PRESENT(closest)) THEN
- IF (PRESENT(chi)) THEN
- closest(1,ntotal) = xr(1)
- closest(2,ntotal) = xr(2)
- ELSE
- closest(1,ntotal) = x + dx*xk(1)
- closest(2,ntotal) = y + dy*xk(2)
- ENDIF
- ENDIF
- !---------------------------------------------------------
- ENDIF ! mesh cell near interface
- ENDDO ! mesh cell i
- ENDDO ! mesh cell j
-#endif
- !---------------------------------------------------------------------
- ! Check if we need to return the level function or not
- !---------------------------------------------------------------------
- lok = .TRUE.
- IF (PRESENT(npts)) THEN
- IF (npts .LT. 0) lok = .FALSE.
- ENDIF
-
- IF (lok) THEN
-#if __DIM == __3D
- !-----------------------------------------------------------------
- ! Flush field data incl. ghost layer
- !-----------------------------------------------------------------
- DO k=0,zhi+2 ! +2 because zhi=ndata-1 (see above)
- DO j=0,yhi+2
- DO i=0,xhi+2
- fdata(i,j,k,jsub) = big
- ENDDO
- ENDDO
- ENDDO
- !-----------------------------------------------------------------
- ! Copy back from sparse structure
- !-----------------------------------------------------------------
- DO i=1,npos
- m = gmm_ipos(1,i)
- n = gmm_ipos(2,i)
- p = gmm_ipos(3,i)
- IF (ABS(phi(i)).LT.ABS(fdata(m,n,p,jsub))) &
- & fdata(m,n,p,jsub)=phi(i)
- ENDDO
-#elif __DIM == __2D
- !-----------------------------------------------------------------
- ! Flush field data incl. ghost layer
- !-----------------------------------------------------------------
- DO j=0,yhi+2
- DO i=0,xhi+2
- fdata(i,j,jsub) = big
- ENDDO
- ENDDO
- !-----------------------------------------------------------------
- ! Copy back from sparse structure
- !-----------------------------------------------------------------
- DO i=1,npos
- m = gmm_ipos(1,i)
- n = gmm_ipos(2,i)
- IF (ABS(phi(i)).LT.ABS(fdata(m,n,jsub))) &
- & fdata(m,n,jsub)=phi(i)
- ENDDO
-#endif
- ENDIF
- !---------------------------------------------------------------------
- ! Pass stuff back out if requested
- !---------------------------------------------------------------------
- IF (PRESENT(ipts)) THEN
- iopt = ppm_param_alloc_grow_preserve
- ldu(1) = ppm_dim+1
- ldu(2) = ntotal
- CALL ppm_alloc(ipts,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_kickoff', &
- & 'point locations IPTS',__LINE__,info)
- GOTO 9999
- ENDIF
- DO i=1,npos
- j = i+ntotal-npos
-#if __DIM == __3D
- ipts(1,j) = gmm_ipos(1,i)
- ipts(2,j) = gmm_ipos(2,i)
- ipts(3,j) = gmm_ipos(3,i)
- ipts(4,j) = jsub
-#elif __DIM == __2D
- ipts(1,j) = gmm_ipos(1,i)
- ipts(2,j) = gmm_ipos(2,i)
- ipts(3,j) = jsub
-#endif
- ENDDO
- ENDIF
- ENDDO ! jsub
- !-------------------------------------------------------------------------
- ! Shrink to actual size to save memory
- !-------------------------------------------------------------------------
- IF (PRESENT(closest)) THEN
- iopt = ppm_param_alloc_fit_preserve
- ldu(1) = ppm_dim
- ldu(2) = ntotal
- CALL ppm_alloc(closest,ldu,iopt,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_kickoff', &
- & 'closest points CLOSEST',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- IF (PRESENT(npts)) npts = ntotal
- !-------------------------------------------------------------------------
- ! Nullify pointer to work memory and restore module pointers
- !-------------------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- gmm_phis => phi
-#elif __KIND == __DOUBLE_PRECISION
- gmm_phid => phi
-#endif
- NULLIFY(phi)
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_kickoff',t0,info)
- RETURN
-
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_kickoff_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_kickoff_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_kickoff_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_kickoff_3dd
-#endif
-#endif
diff --git a/src/ppm_gmm_lubksb.inc b/src/ppm_gmm_lubksb.inc
deleted file mode 100644
index 627b30b1d60d55aa2ebf23315ef9070f9fd3303b..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_lubksb.inc
+++ /dev/null
@@ -1,46 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for the backsubstitution to solve the linear system
- ! for the interpolation polynomial coefficients based on the LU
- ! factorization of the system matrix.
- !
- ! INPUT: REAL(MK), DIMENSION(:) :: rhs -- right-hand side
- ! REAL(MK), DIMENSION(:,:) :: A -- LU factorization of
- ! system matrix
- ! INTEGER :: Nel -- number of elements in rhs
- ! INTEGER, DIMENSION(:) :: Aind -- permutation index of LU
- ! factorization
- ! OUTPUT: REAL(MK), DIMENSION(:) :: coef -- solution vector
- !
- ! VARIABLES NEEDED: INTEGER :: m,n,ll
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_lubksb.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2005/03/11 04:18:59 ivos
- ! Cosmetics.
- !
- ! Revision 1.1 2005/03/10 01:37:21 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
- DO n=1,Nel
- ll = Aind(n)
- coef(n) = rhs(ll)
- DO m=1,n-1
- coef(n) = coef(n) - A(n,m)*coef(m)
- ENDDO
- ENDDO
- coef(Nel) = coef(Nel)/A(Nel,Nel)
- DO n=Nel-1,1,-1
- DO m=n+1,Nel
- coef(n) = coef(n) - A(n,m)*coef(m)
- ENDDO
- coef(n) = coef(n)/A(n,n)
- ENDDO
diff --git a/src/ppm_gmm_march.f b/src/ppm_gmm_march.f
deleted file mode 100644
index 348fc85c690a9391dbc73ea053e77b827ee00e89..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_march.f
+++ /dev/null
@@ -1,970 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_march
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_march_2ds(width,order,fdata,rhscst,MaxIter,info, &
- & speed,udata,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_march_2dd(width,order,fdata,rhscst,MaxIter,info, &
- & speed,udata,chi)
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_march_3ds(width,order,fdata,rhscst,MaxIter,info, &
- & speed,udata,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_march_3dd(width,order,fdata,rhscst,MaxIter,info, &
- & speed,udata,chi)
-#endif
-#endif
- !!! This routine performs the group marching to
- !!! extend the infprmation from the interface to a
- !!! narrow band. This is used for level set
- !!! reinitialization or function extension. The
- !!! interface is assumed to be at the zero level.
- !!! Use postprocess shifting if this is not the case.
- !!!
- !!! [NOTE]
- !!! This routine uses the o(N) group marching method
- !!! of Kim, rather than o(NlogN) fast marching. If
- !!! combines this with the high order equations by
- !!! Chopp to get 2nd or 3rd order accurate
- !!! extrapolations in linear time.
- !!! speed should maybe be passed as speed**2. This
- !!! would save the multiplication in gmm_slvupwind,
- !!! but would require SQRTs in the initial
- !!! conversion from distance to travel time.
- !!! When recomputing the close neighbors one could
- !!! detect local minima and directly remove (i.e.
- !!! accept) them to avoid unnecessary double
- !!! computations.
- !!! To be more memory efficient, we could maybe
- !!! allocate gmm_state only for the sub we are
- !!! currently working on instead of for the full local
- !!! field. This will however only give cashback if
- !!! there are lots of subs per proc, which is currently
- !!! not the case for mesh topologies.
- !!!
- !!! === References ===
- !!!
- !!! D.L. Chopp. Some improvements on the fast marching method. SIAM J.
- !!! Sci. Comput. 23(1):230-244, 2001.
- !!! S. Kim. An O(N) level set method for Eikonal equations. SIAM J. Sci.
- !!! Comput. 22(6):2178-2193, 2001.
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_numerics_data
- USE ppm_module_data_gmm
- USE ppm_module_gmm_march_fwd
- USE ppm_module_gmm_march_bkwd
- USE ppm_module_gmm_extend_fwd
- USE ppm_module_gmm_extend_bkwd
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_alloc
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , INTENT(IN), OPTIONAL :: speed
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: speed
-#endif
- !!! rank 4 (3d) or rank 3 (2d) field of front speeds.
- !!! OPTIONAL to override rhscst.
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER :: fdata
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdata
-#endif
- !!! Level data. Either rank 3 (for 2D scalar fields), or rank
- !!! 4 (for 3D scalar fields). Indices: (i,k,[k],isub). On input:
- !!! signed distance function after initialization as returned by
- !!! ppm_gmm_kickoff. Uninitialized values must be set to HUGE.
- !!! On output: approximation of the extended signed distance
- !!! function in the whole band. Points far from the interface will have
- !!! the value HUGE.
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER, OPTIONAL :: udata
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER, OPTIONAL :: udata
-#endif
- !!! Function data. OPTIONAL. If present, udata will be extended in the
- !!! whole band such that its gradient is orthogonal to the gradient
- !!! of fdata. fdata in this case is a pure input and needs to be
- !!! available in the whole band. Needs to be a scalar field.
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: chi
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN), OPTIONAL :: chi
-#endif
- !!! rank 5 (3d) or rank 4 (2d) field specifying the positions of the
- !!! grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub.
- !!! OPTIONAL. Uniform grid is assumed if absent. Ghostlayers of size
- !!! >=1 must be pre-filled.
- REAL(MK) , INTENT(IN ) :: width
- !!! Width of the narrow band to be produced on each side of the interface.
- REAL(MK) , INTENT(IN ) :: rhscst
- !!! constant value for the right hand side of grad u * grad f = c. If
- !!! speed is present, this argument will be ignored.
- INTEGER , INTENT(IN ) :: order
- !!! Order of the method to be used. One of
- !!!
- !!! *ppm_param_order_1
- !!! *ppm_param_order_2
- !!! *ppm_param_order_3
- INTEGER , INTENT(IN ) :: MaxIter
- !!! argument specifying the maximum number of allowed iterations.
- !!! This can be useful since a cyclic dependency in the GMM algorithms
- !!! could cause infinite loops.
- INTEGER , INTENT( OUT) :: info
- !!! Return status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,j,k,p,iopt,xhi,yhi,zhi
- INTEGER :: npos,npos0,jsub,isub
- INTEGER :: nposg
- INTEGER :: nord
- INTEGER :: Marchit
- INTEGER, DIMENSION(3) :: ghostsize
- INTEGER, DIMENSION(4) :: ldl,ldu
- REAL(MK),DIMENSION(2) :: coefs
- REAL(MK) :: t0,deltaT,sqrtdiminv,smin
- REAL(MK) :: TM,dx,dy,dz,dxinv,dyinv,dzinv
- REAL(MK) :: hsave,mindx
- REAL(MK) :: ainv,big
- TYPE(ppm_t_topo) , POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-#ifdef __MPI
- REAL(MK) :: allsmin
-#endif
- LOGICAL :: lok
- CHARACTER(LEN=ppm_char) :: cbuf
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,: ), POINTER :: fdta
- REAL(MK), DIMENSION(:,:,: ), POINTER :: dta
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,: ), POINTER :: fdta
- REAL(MK), DIMENSION(:,:,:,: ), POINTER :: dta
-#endif
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_march',t0,info)
- big = HUGE(big)
- hsave = 0.9_MK*big
-#if __DIM == __2D
- sqrtdiminv = 1.0_MK/SQRT(2.0_MK)
-#else
- sqrtdiminv = 1.0_MK/SQRT(3.0_MK)
-#endif
- topo => ppm_topo(gmm_topoid)%t
- mesh => topo%mesh(gmm_meshid)
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_march', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (width .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_march', &
- & 'width must be positive!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((order.NE.ppm_param_order_1).AND.(order.NE.ppm_param_order_2) &
- & .AND.(order.NE.ppm_param_order_3)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_march', &
- & 'order must be 1, 2, or 3!',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __3D
- IF (SIZE(fdata,4) .LT. topo%nsublist) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_march', &
- & 'field data for some subs is missing',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,1) .LT. maxxhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_march', &
- & 'x dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,2) .LT. maxyhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_march', &
- & 'y dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,3) .LT. maxzhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_march', &
- & 'z dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __DIM == __2D
- IF (SIZE(fdata,3) .LT. topo%nsublist) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_march', &
- & 'field data for some subs is missing',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,1) .LT. maxxhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_march', &
- & 'x dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,2) .LT. maxyhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_march', &
- & 'y dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF ! ppm_debug for argument check
- !-------------------------------------------------------------------------
- ! Determine ghostsize needed. Only change if larger than what it
- ! already is. Do not shrink as this would freak out the client...
- !-------------------------------------------------------------------------
-#if __DIM == __3D
- i = MIN(1-LBOUND(fdata,1),1-LBOUND(fdata,2),1-LBOUND(fdata,3))
-#else
- i = MIN(1-LBOUND(fdata,1),1-LBOUND(fdata,2))
-#endif
- IF (order .EQ. ppm_param_order_1) THEN
- ghostsize = MAX(1,i)
- nord = 1
- ! IF (ppm_debug .GT. 0) THEN
- WRITE(cbuf,'(A)') 'Using first order upwinding'
- CALL ppm_write(ppm_rank,'ppm_gmm_march',cbuf,info)
- ! ENDIF
- ELSEIF (order .EQ. ppm_param_order_2) THEN
- ghostsize = MAX(2,i)
- nord = 2
- ! IF (ppm_debug .GT. 0) THEN
- WRITE(cbuf,'(A)') 'Using second order upwinding'
- CALL ppm_write(ppm_rank,'ppm_gmm_march',cbuf,info)
- ! ENDIF
- ELSE
- ghostsize = MAX(3,i)
- nord = 3
- ! IF (ppm_debug .GT. 0) THEN
- WRITE(cbuf,'(A)') 'Using third order upwinding'
- CALL ppm_write(ppm_rank,'ppm_gmm_march',cbuf,info)
- ! ENDIF
- ENDIF
- !-------------------------------------------------------------------------
- ! Set the pointers
- !-------------------------------------------------------------------------
- IF (PRESENT(udata)) THEN
- !---------------------------------------------------------------------
- ! March udata and use fdata as level set
- !---------------------------------------------------------------------
- dta => udata
- fdta => fdata
- ELSE
- !---------------------------------------------------------------------
- ! March the level set itself
- !---------------------------------------------------------------------
- dta => fdata
- fdta => fdata
- ENDIF
- !-------------------------------------------------------------------------
- ! Find mesh spacing
- !-------------------------------------------------------------------------
- IF (ppm_kind .EQ. ppm_kind_single) THEN
- dx = (topo%max_physs(1)-topo%min_physs(1))/ &
- & REAL(mesh%Nm(1)-1,ppm_kind_single)
- dy = (topo%max_physs(2)-topo%min_physs(2))/ &
- & REAL(mesh%Nm(2)-1,ppm_kind_single)
- IF (ppm_dim .GT. 2) THEN
- dz = (topo%max_physs(3)-topo%min_physs(3))/ &
- & REAL(mesh%Nm(3)-1, &
- & ppm_kind_single)
- ENDIF
- ELSE
- dx = (topo%max_physs(1)-topo%min_physs(1))/ &
- & REAL(mesh%Nm(1)-1,ppm_kind_double)
- dy = (topo%max_physs(2)-topo%min_physs(2))/ &
- & REAL(mesh%Nm(2)-1,ppm_kind_double)
- IF (ppm_dim .GT. 2) THEN
- dz = (topo%max_physs(3)-topo%min_physs(3))/ &
- & REAL(mesh%Nm(3)-1, &
- & ppm_kind_double)
- ENDIF
- ENDIF
- dxinv = 1.0_MK/dx
- dyinv = 1.0_MK/dy
-#if __DIM == __3D
- dzinv = 1.0_MK/dz
- mindx = MIN(dx,dy,dz)
-#else
- dzinv = 0.0_MK
- mindx = MIN(dx,dy)
-#endif
- !-------------------------------------------------------------------------
- ! Initialize the ghost layers.
- !-------------------------------------------------------------------------
- CALL ppm_map_field_ghost_get(gmm_topoid,gmm_meshid,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'ghost get mapping failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,fdta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'pushing level data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (PRESENT(udata)) THEN
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,dta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (PRESENT(udata)) THEN
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,dta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,fdta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'popping level data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- ! because it has not been mapped
- IF (.NOT.(PRESENT(udata))) dta => fdta
- !-------------------------------------------------------------------------
- ! Allocate and initialize status array
- !-------------------------------------------------------------------------
- iopt = ppm_param_alloc_grow
-#if __DIM == __3D
- ldl(1) = 1-ghostsize(1)
- ldl(2) = 1-ghostsize(2)
- ldl(3) = 1-ghostsize(3)
- ldl(4) = 1
- ldu(1) = maxxhi+ghostsize(1)
- ldu(2) = maxyhi+ghostsize(2)
- ldu(3) = maxzhi+ghostsize(3)
- ldu(4) = topo%nsublist
- CALL ppm_alloc(gmm_state3d,ldl,ldu,iopt,info)
-#else
- ldl(1) = 1-ghostsize(1)
- ldl(2) = 1-ghostsize(2)
- ldl(3) = 1
- ldu(1) = maxxhi+ghostsize(1)
- ldu(2) = maxyhi+ghostsize(2)
- ldu(3) = topo%nsublist
- CALL ppm_alloc(gmm_state2d,ldl,ldu,iopt,info)
-#endif
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_gmm_march', &
- & 'point status array GMM_STATE',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __3D
- gmm_state3d = ppm_gmm_param_far
- !-------------------------------------------------------------------------
- ! Convert distance to travel time and find minimum slowness (=
- ! max speed)
- !-------------------------------------------------------------------------
- DO jsub=1,topo%nsublist
- IF (PRESENT(speed)) THEN
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- zhi = mesh%nnodes(3,isub)
- smin = -big
- DO k=1,zhi
- DO j=1,yhi
- DO i=1,xhi
- IF (speed(i,j,k,jsub) .GT. smin) &
- & smin = speed(i,j,k,jsub)
- IF (dta(i,j,k,jsub) .LT. hsave) THEN
- dta(i,j,k,jsub)=dta(i,j,k,jsub)/speed(i,j,k,jsub)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- smin = 1.0_MK/smin
-#ifdef __MPI
- !-----------------------------------------------------------------
- ! Ensure consistent computations on all processors
- !-----------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL MPI_Allreduce(smin,allsmin,1,MPI_REAL,MPI_MIN, &
- & ppm_comm,info)
-#else
- CALL MPI_Allreduce(smin,allsmin,1,MPI_DOUBLE_PRECISION,MPI_MIN, &
- & ppm_comm,info)
-#endif
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_mpi_fail,'ppm_gmm_march', &
- & 'MPI_ALLREDUCE of smin',__LINE__,info)
- GOTO 9999
- ENDIF
- smin = allsmin
-#endif
- ELSE
- smin = 1.0_MK
- ENDIF
- ENDDO ! jsub
- !-------------------------------------------------------------------------
- ! Initialize travel limit (see Kim:2001a)
- !-------------------------------------------------------------------------
- deltaT = 0.99_MK*sqrtdiminv*mindx*smin
- !IF (.NOT.PRESENT(udata)) deltaT = (10.0_MK**REAL(-nord+1,MK))*deltaT
- !-------------------------------------------------------------------------
- ! Make a list of all initialized points and find the minimum
- ! travel time on the boundary of the band.
- !-------------------------------------------------------------------------
- npos0 = 0
- DO jsub=1,topo%nsublist
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- zhi = mesh%nnodes(3,isub)
- TM = big
- DO k=1,zhi
- DO j=1,yhi
- DO i=1,xhi
- coefs(1) = dta(i,j,k,jsub)
- coefs(2) = fdta(i,j,k,jsub)
- IF ((coefs(1).LT.hsave).AND.(gmm_state3d(i,j,k,jsub).EQ.&
- & ppm_gmm_param_far)) THEN
- IF ((dta(i-1,j,k,jsub) .GT. hsave) .OR. &
- & (dta(i+1,j,k,jsub) .GT. hsave) .OR. &
- & (dta(i,j-1,k,jsub) .GT. hsave) .OR. &
- & (dta(i,j+1,k,jsub) .GT. hsave) .OR. &
- & (dta(i,j,k-1,jsub) .GT. hsave) .OR. &
- & (dta(i,j,k+1,jsub) .GT. hsave)) THEN
- !-------------------------------------------------
- ! Add points on the surface to close set and
- ! set TM to min distance to interface
- !-------------------------------------------------
- IF (ABS(coefs(2)) .LT. TM) TM = ABS(coefs(2))
- gmm_state3d(i,j,k,jsub) = ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ELSE
- gmm_state3d(i,j,k,jsub) = ppm_gmm_param_accepted
- ENDIF
- ENDIF
- ENDDO ! mesh cell i
- ENDDO ! mesh cell j
- ENDDO ! mesh cell k
- ENDDO ! jsub
- npos = npos0
- !-------------------------------------------------------------------------
- ! Initialize ghost layers for state array
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,gmm_state3d,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'pushing status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'sending status ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,gmm_state3d,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'popping status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Initialize the global gamma size
- !-------------------------------------------------------------------------
-#ifdef __MPI
- CALL MPI_AllReduce(npos,nposg,1,MPI_INTEGER,MPI_SUM,ppm_comm,info)
-#else
- nposg = npos
-#endif
- !-------------------------------------------------------------------------
- ! March
- !-------------------------------------------------------------------------
- Marchit = 0
- DO WHILE ((nposg .GT. 0) .AND. (Marchit .LT. MaxIter))
- Marchit = Marchit + 1
- TM = TM + deltaT
- IF (ppm_debug .GT. 0) THEN
- WRITE(cbuf,'(A,I4,A,I9)') 'Iteration ',Marchit, &
- & ': Number of points in list: ',npos
- CALL ppm_write(ppm_rank,'ppm_gmm_march',cbuf,info)
- IF (npos.LE.5) THEN
- DO i=1,npos
- WRITE(cbuf,'(A,I9,I9,I9)') 'Point ', gmm_ipos(1,i), gmm_ipos(2,i), gmm_ipos(3,i)
- CALL ppm_write(ppm_rank,'ppm_gmm_march',cbuf,info)
- END DO
- END IF
- ENDIF
- !---------------------------------------------------------------------
- ! Hard-core debuging
- !---------------------------------------------------------------------
-! WRITE(cbuf,'(A,I4.4,A)') 'state_',Marchit,'.out'
-! OPEN(50,FILE=cbuf,STATUS='REPLACE',ACTION='WRITE')
-! WRITE(cbuf,'(A,I4.4,A)') 'level_',Marchit,'.out'
-! OPEN(40,FILE=cbuf,STATUS='REPLACE',ACTION='WRITE')
-! DO k=1,zhi
-! DO j=1,yhi
-! DO i=1,xhi
-! IF (ABS(fdta(i,j,k,1)) .LT. hsave) THEN
-! WRITE(40,*) fdta(i,j,k,1)
-! ELSE
-! WRITE(40,*) 0.0_MK
-! ENDIF
-! WRITE(50,*) gmm_state3d(i,j,k,1)
-! ENDDO
-! ENDDO
-! ENDDO
-! CLOSE(40)
-! CLOSE(50)
- !---------------------------------------------------------------------
- ! Reverse order: recompute neighbors of points in ggm_ipos to
- ! fix stability.
- !---------------------------------------------------------------------
- IF (PRESENT(udata)) THEN
- DO i=1,nord
- IF (PRESENT(speed)) THEN
- CALL ppm_gmm_extend_bkwd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed)
- ELSE
- CALL ppm_gmm_extend_bkwd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info)
- ENDIF
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'Backward extension failed.',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
- ELSE
- IF (PRESENT(speed)) THEN
- CALL ppm_gmm_march_bkwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed)
- ELSE
- CALL ppm_gmm_march_bkwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info)
- ENDIF
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'Backward marching failed.',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDIF
- !---------------------------------------------------------------------
- ! Forward order: update neighbors of points in ggm_ipos and
- ! advance front
- !---------------------------------------------------------------------
- IF (PRESENT(udata)) THEN
- IF (PRESENT(speed)) THEN
- CALL ppm_gmm_extend_fwd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed)
- ELSE
- CALL ppm_gmm_extend_fwd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info)
- ENDIF
- ELSE
- IF (PRESENT(speed)) THEN
- CALL ppm_gmm_march_fwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed)
- ELSE
- CALL ppm_gmm_march_fwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info)
- ENDIF
- ENDIF
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'Forward marching failed.',__LINE__,info)
- GOTO 8888
- ENDIF
- !---------------------------------------------------------------------
- ! Update the global gamma size
- !---------------------------------------------------------------------
-#ifdef __MPI
- CALL MPI_AllReduce(npos,nposg,1,MPI_INTEGER,MPI_SUM,ppm_comm,info)
-#else
- nposg = npos
-#endif
- ENDDO ! while nposg.GT.0
-#elif __DIM == __2D
- gmm_state2d = ppm_gmm_param_far
- !-------------------------------------------------------------------------
- ! Convert distance to travel time and find minimum slowness (=
- ! max speed)
- !-------------------------------------------------------------------------
- DO jsub=1,topo%nsublist
- IF (PRESENT(speed)) THEN
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- smin = -big
- DO j=1,yhi
- DO i=1,xhi
- IF (speed(i,j,jsub) .GT. smin) &
- & smin = speed(i,j,jsub)
- IF (dta(i,j,jsub) .LT. hsave) THEN
- dta(i,j,jsub) = &
- & dta(i,j,jsub)/speed(i,j,jsub)
- ENDIF
- ENDDO
- ENDDO
- smin = 1.0_MK/smin
-#ifdef __MPI
- !-----------------------------------------------------------------
- ! Ensure consistent computations on all processors
- !-----------------------------------------------------------------
-#if __KIND == __SINGLE_PRECISION
- CALL MPI_Allreduce(smin,allsmin,1,MPI_REAL,MPI_MIN, &
- & ppm_comm,info)
-#else
- CALL MPI_Allreduce(smin,allsmin,1,MPI_DOUBLE_PRECISION,MPI_MIN, &
- & ppm_comm,info)
-#endif
- IF (info .NE. 0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_mpi_fail,'ppm_gmm_march', &
- & 'MPI_ALLREDUCE of smin',__LINE__,info)
- GOTO 9999
- ENDIF
- smin = allsmin
-#endif
- ELSE
- smin = 1.0_MK
- ENDIF
- ENDDO ! jsub
- !-------------------------------------------------------------------------
- ! Initialize travel limit (see Kim:2001a)
- !-------------------------------------------------------------------------
- deltaT = 0.99_MK*sqrtdiminv*mindx*smin
- !IF (.NOT.PRESENT(udata)) deltaT = (10.0_MK**REAL(-nord+1,MK))*deltaT
- !-------------------------------------------------------------------------
- ! Make a list of all initialized points and find the minimum
- ! travel time on the boundary of the band.
- !-------------------------------------------------------------------------
- npos0 = 0
- DO jsub=1,topo%nsublist
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- TM = big
- DO j=1,yhi
- DO i=1,xhi
- coefs(1) = dta(i,j,jsub)
- coefs(2) = fdta(i,j,jsub)
- IF ((coefs(1).LT.hsave).AND.(gmm_state2d(i,j,jsub).EQ.&
- & ppm_gmm_param_far)) THEN
- IF ((dta(i-1,j,jsub) .GT. hsave) .OR. &
- & (dta(i+1,j,jsub) .GT. hsave) .OR. &
- & (dta(i,j-1,jsub) .GT. hsave) .OR. &
- & (dta(i,j+1,jsub) .GT. hsave)) THEN
- !-----------------------------------------------------
- ! Add points on the surface to close set and
- ! set TM to min distance to interface
- !-----------------------------------------------------
- IF (ABS(coefs(2)) .LT. TM) TM = ABS(coefs(2))
- gmm_state2d(i,j,jsub) = ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ELSE
- gmm_state2d(i,j,jsub) = ppm_gmm_param_accepted
- ENDIF
- ENDIF
- ENDDO ! mesh cell i
- ENDDO ! mesh cell j
- ENDDO ! jsub
- npos = npos0
- !-------------------------------------------------------------------------
- ! Initialize ghost layers for state array
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,gmm_state2d,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'pushing status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'sending status ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,gmm_state2d,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'popping status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Initialize the global gamma size
- !-------------------------------------------------------------------------
-#ifdef __MPI
- CALL MPI_AllReduce(npos,nposg,1,MPI_INTEGER,MPI_SUM,ppm_comm,info)
-#else
- nposg = npos
-#endif
- !-------------------------------------------------------------------------
- ! March
- !-------------------------------------------------------------------------
- Marchit = 0
- DO WHILE ((nposg .GT. 0) .AND. (Marchit .LT. MaxIter))
- Marchit = Marchit + 1
- TM = TM + deltaT
- IF (ppm_debug .GT. 0) THEN
- WRITE(cbuf,'(A,I4,A,I9)') 'Iteration ',Marchit, &
- & ': Number of points in list: ',npos
- CALL ppm_write(ppm_rank,'ppm_gmm_march',cbuf,info)
- ENDIF
- !---------------------------------------------------------------------
- ! Reverse order: recompute neighbors of points in ggm_ipos to
- ! fix stability
- !---------------------------------------------------------------------
- IF (PRESENT(udata)) THEN
- DO i=1,nord
- IF (PRESENT(speed)) THEN
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_extend_bkwd(fdta,dta,width,order,npos,&
- & TM,rhscst,dxinv,dyinv,dzinv,ghostsize,info, &
- & speed,chi)
- ELSE
- CALL ppm_gmm_extend_bkwd(fdta,dta,width,order,npos,&
- & TM,rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed)
- ENDIF
- ELSE
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_extend_bkwd(fdta,dta,width,order,npos, &
- & TM,rhscst,dxinv,dyinv,dzinv,ghostsize,info, &
- & chi=chi)
- ELSE
- CALL ppm_gmm_extend_bkwd(fdta,dta,width,order,npos, &
- & TM,rhscst,dxinv,dyinv,dzinv,ghostsize,info)
- ENDIF
- ENDIF
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'Backward extension failed.',__LINE__,info)
- GOTO 8888
- ENDIF
- ENDDO
- ELSE
- IF (PRESENT(speed)) THEN
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_march_bkwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
- ELSE
- CALL ppm_gmm_march_bkwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed)
- ENDIF
- ELSE
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_march_bkwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,chi=chi)
- ELSE
- CALL ppm_gmm_march_bkwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info)
- ENDIF
- ENDIF
- ENDIF
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'Backward marching failed.',__LINE__,info)
- GOTO 8888
- ENDIF
- !---------------------------------------------------------------------
- ! Forward order: update neighbors of points in ggm_ipos and
- ! advance front
- !---------------------------------------------------------------------
- IF (PRESENT(udata)) THEN
- IF (PRESENT(speed)) THEN
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_extend_fwd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
- ELSE
- CALL ppm_gmm_extend_fwd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed)
- ENDIF
- ELSE
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_extend_fwd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,chi=chi)
- ELSE
- CALL ppm_gmm_extend_fwd(fdta,dta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info)
- ENDIF
- ENDIF
- ELSE
- IF (PRESENT(speed)) THEN
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_march_fwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
- ELSE
- CALL ppm_gmm_march_fwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed)
- ENDIF
- ELSE
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_march_fwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,chi=chi)
- ELSE
- CALL ppm_gmm_march_fwd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info)
- ENDIF
- ENDIF
- ENDIF
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'Forward marching failed.',__LINE__,info)
- GOTO 8888
- ENDIF
- !---------------------------------------------------------------------
- ! Update the global gamma size
- !---------------------------------------------------------------------
-#ifdef __MPI
- CALL MPI_AllReduce(npos,nposg,1,MPI_INTEGER,MPI_SUM,ppm_comm,info)
-#else
- nposg = npos
-#endif
- ENDDO ! while nposg.GT.0
-#endif
- !-------------------------------------------------------------------------
- ! Deallocate status array
- !-------------------------------------------------------------------------
- 8888 iopt = ppm_param_dealloc
-#if __DIM == __3D
- CALL ppm_alloc(gmm_state3d,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_march', &
- & 'point status array GMM_STATE3D',__LINE__,info)
- ENDIF
-#elif __DIM == __2D
- CALL ppm_alloc(gmm_state2d,ldu,iopt,info)
- IF (info .NE. 0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_gmm_march', &
- & 'point status array GMM_STATE2D',__LINE__,info)
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! In case one of the mappings reallocated the data, we might want to
- ! pass back out the new data and save it from destruction upon
- ! subroutine termination.
- !-------------------------------------------------------------------------
- fdata => fdta
- IF (PRESENT(udata)) udata => dta
- NULLIFY(dta)
- NULLIFY(fdta)
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_march',t0,info)
- RETURN
-
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_march_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_march_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_march_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_march_3dd
-#endif
-#endif
diff --git a/src/ppm_gmm_march_bkwd.f b/src/ppm_gmm_march_bkwd.f
deleted file mode 100644
index d743377d3a7032e2d3eb7e510b364638fff26b88..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_march_bkwd.f
+++ /dev/null
@@ -1,494 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_march_bkwd
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_march_bkwd_2ds(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_march_bkwd_2dd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_march_bkwd_3ds(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_march_bkwd_3dd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#endif
-#endif
- !!! This routine performs the backward marching step of the GMM. See
- !!! ppm_gmm_march for details.
- !!!
- !!! === References ===
- !!!
- !!! Chopp:2001, Kim:2001b
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_numerics_data
- USE ppm_module_data_gmm
- USE ppm_module_typedef
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_map_field
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER :: fdta
- !!! pointer to level function.
- REAL(MK), DIMENSION(:,:,:) , INTENT(IN), OPTIONAL :: speed
- !!! rank 4 (3d) or rank 3 (2d) field of front speeds.
- !!! OPTIONAL to override rhscst.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: chi
- !!! rank 5 (3d) or rank 4 (2d) field specifying the positions of the
- !!! grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub.
- !!! OPTIONAL. Uniform grid is assumed if absent.
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdta
- !!! pointer to level function.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: speed
- !!! rank 4 (3d) or rank 3 (2d) field of front speeds.
- !!! OPTIONAL to override rhscst.
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN), OPTIONAL :: chi
- !!! rank 5 (3d) or rank 4 (2d) field specifying the positions of the
- !!! grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub.
- !!! OPTIONAL. Uniform grid is assumed if absent.
-#endif
- REAL(MK) , INTENT(IN ) :: width
- !!! Width of the narrow band to be produced on each side of the interface.
- REAL(MK) , INTENT(IN ) :: rhscst
- !!! constant value for the right hand side of grad u * grad f = c.
- !!! If speed is present, this argument will be ignored.
- REAL(MK) , INTENT(IN ) :: TM
- !!! Current threshold for wave front location.
- REAL(MK) , INTENT(IN ) :: dxinv
- !!! inverse of the x grid spacing.
- REAL(MK) , INTENT(IN ) :: dyinv
- !!! inverse of the y grid spacing.
- REAL(MK) , INTENT(IN ) :: dzinv
- !!! inverse of the z grid spacing. (Not used in 2D version).
- INTEGER, DIMENSION(3) , INTENT(IN ) :: ghostsize
- !!! Size of the ghostlayer on all sides.
- INTEGER , INTENT(IN ) :: order
- !!! Order of the method to be used. One of
- !!!
- !!! *ppm_param_order_1
- !!! *ppm_param_order_2
- !!! *ppm_param_order_3
- INTEGER , INTENT(INOUT) :: npos
- !!! Current number of points in the close set.
- INTEGER , INTENT( OUT) :: info
- !!! Return status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,j,k,p,xhi,yhi,zhi,ii,jj,kk
- INTEGER :: jsub,isub
- INTEGER :: i1,i2,i3
- INTEGER, DIMENSION(-3:3) :: sx,sy,sz
- REAL(MK) :: t0,onethird,onetwelfth
- REAL(MK) :: dxihalf,dyihalf,dzihalf
- REAL(MK) :: dxitwelve,dyitwelve,dzitwelve
- REAL(MK) :: valijk,det,hsave,fdta0
- REAL(MK) :: lmyeps,ainv,big,absfdta0
- REAL(MK), DIMENSION(3) :: coefs,gphi
- REAL(MK), DIMENSION(3,3) :: jac,ji
- REAL(MK), DIMENSION(-3:3,ppm_dim):: phi,psi
- REAL(MK), DIMENSION(ppm_dim) :: alpha,beta
- REAL(MK), DIMENSION(2) :: roots
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_march_bkwd',t0,info)
- phi = 0.0_MK
- psi = 0.0_MK
- big = HUGE(big)
- hsave = 0.9_MK*big
- onethird = 1.0_MK/3.0_MK
- topo => ppm_topo(gmm_topoid)%t
- mesh => topo%mesh(gmm_meshid)
-#if __KIND == __SINGLE_PRECISION
- lmyeps = ppm_myepss
-#else
- lmyeps = ppm_myepsd
-#endif
- dxihalf = 0.5_MK*dxinv
- dyihalf = 0.5_MK*dyinv
- dxitwelve = onetwelfth*dxinv
- dyitwelve = onetwelfth*dyinv
-#if __DIM == __3D
- dzihalf = 0.5_MK*dzinv
- dzitwelve = onetwelfth*dzinv
-#endif
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (width .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_march_bkwd', &
- & 'width must be positive!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((order.NE.ppm_param_order_1).AND.(order.NE.ppm_param_order_2) &
- & .AND.(order.NE.ppm_param_order_3)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_march_bkwd', &
- & 'order must be 1, 2, or 3!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF ! ppm_debug for argument check
-#if __DIM == __3D
- !-------------------------------------------------------------------------
- ! Reverse order: recompute neighbors of points in ggm_ipos
- !-------------------------------------------------------------------------
- DO p=npos,1,-1
- ii = gmm_ipos(1,p)
- jj = gmm_ipos(2,p)
- kk = gmm_ipos(3,p)
- jsub = gmm_ipos(4,p)
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- zhi = mesh%nnodes(3,isub)
- fdta0= fdta(ii,jj,kk,jsub)
- absfdta0 = fdta0
- IF (absfdta0 .LT. 0.0_MK) absfdta0 = -absfdta0
- !---------------------------------------------------------------------
- ! GMM update condition (see Kim:2001a)
- !---------------------------------------------------------------------
- IF (.NOT.(absfdta0.GT.TM)) THEN
- !-----------------------------------------------------------------
- ! Recompute non-accepted close neighbors
- !-----------------------------------------------------------------
- i = ii - 1
- j = jj
- k = kk
- IF (i.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii + 1
- j = jj
- k = kk
- IF (i.LE.xhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj - 1
- k = kk
- IF (j.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj + 1
- k = kk
- IF (j.LE.yhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj
- k = kk - 1
- IF (k.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj
- k = kk + 1
- IF (k.LE.zhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF ! TT .LE. TM
- ENDDO ! p=npos,1,-1
- !-------------------------------------------------------------------------
- ! Update ghost layers for fdta
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,fdta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,fdta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __DIM == __2D
- !-------------------------------------------------------------------------
- ! Reverse order: recompute neighbors of points in ggm_ipos
- !-------------------------------------------------------------------------
- DO p=npos,1,-1
- ii = gmm_ipos(1,p)
- jj = gmm_ipos(2,p)
- jsub = gmm_ipos(3,p)
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- fdta0= fdta(ii,jj,jsub)
- absfdta0 = fdta0
- IF (absfdta0 .LT. 0.0_MK) absfdta0 = -absfdta0
- !---------------------------------------------------------------------
- ! GMM update condition (see Kim:2001a)
- !---------------------------------------------------------------------
- IF (.NOT.(absfdta0.GT.TM)) THEN
- !-----------------------------------------------------------------
- ! Recompute non-accepted close neighbors
- !-----------------------------------------------------------------
- i = ii - 1
- j = jj
- IF (i.GT.0) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,jsub))) THEN
- IF ((valijk*fdta(i,j,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,jsub).GT.hsave)) THEN
- fdta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii + 1
- j = jj
- IF (i.LE.xhi) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,jsub))) THEN
- IF ((valijk*fdta(i,j,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,jsub).GT.hsave)) THEN
- fdta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj - 1
- IF (j.GT.0) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,jsub))) THEN
- IF ((valijk*fdta(i,j,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,jsub).GT.hsave)) THEN
- fdta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj + 1
- IF (j.LE.yhi) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (ABS(valijk).LT.ABS(fdta(i,j,jsub))) THEN
- IF ((valijk*fdta(i,j,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,jsub).GT.hsave)) THEN
- fdta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF ! TT .LE. TM
- ENDDO ! p=npos,1,-1
- !-------------------------------------------------------------------------
- ! Update ghost layers for fdta
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,fdta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,fdta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_march_bkwd',t0,info)
- RETURN
-
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_march_bkwd_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_march_bkwd_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_march_bkwd_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_march_bkwd_3dd
-#endif
-#endif
diff --git a/src/ppm_gmm_march_fwd.f b/src/ppm_gmm_march_fwd.f
deleted file mode 100644
index 8653d8e16843f7896549124725b7b2d45419615e..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_march_fwd.f
+++ /dev/null
@@ -1,685 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_march_fwd
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_march_fwd_2ds(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_march_fwd_2dd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_march_fwd_3ds(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_march_fwd_3dd(fdta,width,order,npos,TM, &
- & rhscst,dxinv,dyinv,dzinv,ghostsize,info,speed,chi)
-#endif
-#endif
- !!! This routine performs the forward marching step of the GMM. See
- !!! ppm_gmm_march for details.
- !!!
- !!! === References ===
- !!!
- !!! Chopp:2001, Kim:2001b
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
- USE ppm_module_numerics_data
- USE ppm_module_data_gmm
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- USE ppm_module_map_field
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,:) , POINTER :: fdta
- !!! pointer to level function.
- REAL(MK), DIMENSION(:,:,:) , INTENT(IN), OPTIONAL :: speed
- !!! rank 4 (3d) or rank 3 (2d) field of front speeds.
- !!! OPTIONAL to override rhscst.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: chi
- !!! rank 5 (3d) or rank 4 (2d) field specifying the positions of the
- !!! grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub.
- !!! OPTIONAL. Uniform grid is assumed if absent.
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdta
- !!! pointer to level function.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL :: speed
- !!! rank 4 (3d) or rank 3 (2d) field of front speeds.
- !!! OPTIONAL to override rhscst.
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN), OPTIONAL :: chi
- !!! rank 5 (3d) or rank 4 (2d) field specifying the positions of the
- !!! grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub.
- !!! OPTIONAL. Uniform grid is assumed if absent.
-#endif
- REAL(MK) , INTENT(IN ) :: width
- !!! Width of the narrow band to be produced on each side of the interface.
- REAL(MK) , INTENT(IN ) :: rhscst
- !!! constant value for the right hand side of grad u * grad f = c.
- !!! If speed is present, this argument will be ignored.
- REAL(MK) , INTENT(IN ) :: TM
- !!! Current threshold for wave front location.
- REAL(MK) , INTENT(IN ) :: dxinv
- !!! inverse of the x grid spacing.
- REAL(MK) , INTENT(IN ) :: dyinv
- !!! inverse of the y grid spacing.
- REAL(MK) , INTENT(IN ) :: dzinv
- !!! inverse of the z grid spacing. (Not used in 2D version).
- INTEGER, DIMENSION(3) , INTENT(IN ) :: ghostsize
- !!! Size of the ghostlayer on all sides.
- INTEGER , INTENT(IN ) :: order
- !!! Order of the method to be used. One of
- !!!
- !!! *ppm_param_order_1
- !!! *ppm_param_order_2
- !!! *ppm_param_order_3
- INTEGER , INTENT(INOUT) :: npos
- !!! Current number of points in the close set.
- INTEGER , INTENT( OUT) :: info
- !!! Return status, 0 upon success
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: i,j,k,p,xhi,yhi,zhi,ii,jj,kk
- INTEGER :: npos0,jsub,isub,iopt
- INTEGER :: i1,i2,i3
- INTEGER, DIMENSION(-3:3) :: sx,sy,sz
- INTEGER, DIMENSION(4) :: ldu
- REAL(MK) :: t0,onethird,onetwelfth
- REAL(MK) :: dxihalf,dyihalf,dzihalf
- REAL(MK) :: dxitwelve,dyitwelve,dzitwelve
- REAL(MK) :: valijk,det,hsave,fdta0
- REAL(MK) :: lmyeps,ainv,big,absfdta0
- REAL(MK), DIMENSION(3) :: coefs
- REAL(MK), DIMENSION(3,3) :: jac,ji
- REAL(MK), DIMENSION(-3:3,ppm_dim):: phi,psi
- REAL(MK), DIMENSION(ppm_dim) :: alpha,beta
- REAL(MK), DIMENSION(2) :: roots
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
- !-------------------------------------------------------------------------
- ! Externals
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_march_fwd',t0,info)
- topo => ppm_topo(gmm_topoid)%t
- mesh => topo%mesh(gmm_meshid)
- phi = 0.0_MK
- psi = 0.0_MK
- big = HUGE(big)
- hsave = 0.9_MK*big
- onethird = 1.0_MK/3.0_MK
- onetwelfth = 1.0_MK/12.0_MK
-#if __KIND == __SINGLE_PRECISION
- lmyeps = ppm_myepss
-#else
- lmyeps = ppm_myepsd
-#endif
- dxihalf = 0.5_MK*dxinv
- dyihalf = 0.5_MK*dyinv
- dxitwelve = onetwelfth*dxinv
- dyitwelve = onetwelfth*dyinv
-#if __DIM == __3D
- dzihalf = 0.5_MK*dzinv
- dzitwelve = onetwelfth*dzinv
-#endif
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (width .LT. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_march_fwd', &
- & 'width must be positive!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF ((order.NE.ppm_param_order_1).AND.(order.NE.ppm_param_order_2) &
- & .AND.(order.NE.ppm_param_order_3)) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_march_fwd', &
- & 'order must be 1, 2, or 3!',__LINE__,info)
- GOTO 9999
- ENDIF
- ENDIF ! ppm_debug for argument check
-
-#if __DIM == __3D
- npos0 = npos
- !-------------------------------------------------------------------------
- ! Forward order: update neighbors of points in ggm_ipos
- !-------------------------------------------------------------------------
- DO p=1,npos
- IF (p .GT. npos0) EXIT
- ii = gmm_ipos(1,p)
- jj = gmm_ipos(2,p)
- kk = gmm_ipos(3,p)
- jsub = gmm_ipos(4,p)
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- zhi = mesh%nnodes(3,isub)
- fdta0= fdta(ii,jj,kk,jsub)
- absfdta0 = fdta0
- IF (absfdta0 .LT. 0.0_MK) absfdta0 = -absfdta0
- !---------------------------------------------------------------------
- ! GMM update condition (see Kim:2001a)
- !---------------------------------------------------------------------
- IF (.NOT.(absfdta0.GT.TM)) THEN
- !-----------------------------------------------------------------
- ! Compute non-accepted neighbors
- !-----------------------------------------------------------------
- i = ii - 1
- j = jj
- k = kk
- IF (i.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii + 1
- j = jj
- k = kk
- IF (i.LE.xhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj - 1
- k = kk
- IF (j.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj + 1
- k = kk
- IF (j.LE.yhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj
- k = kk - 1
- IF (k.GT.0) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj
- k = kk + 1
- IF (k.LE.zhi) THEN
- IF ((gmm_state3d(i,j,k,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,k,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j,k
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,k,jsub))) THEN
- IF ((valijk*fdta(i,j,k,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,k,jsub).GT.hsave)) THEN
- fdta(i,j,k,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state3d(i,j,k,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,k,jsub)) .LT. width)) THEN
- gmm_state3d(i,j,k,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- !-----------------------------------------------------------------
- ! Accept this point and remove it from the list
- !-----------------------------------------------------------------
- gmm_state3d(ii,jj,kk,jsub) = ppm_gmm_param_accepted
- gmm_ipos(1,p) = gmm_ipos(1,npos0)
- gmm_ipos(2,p) = gmm_ipos(2,npos0)
- gmm_ipos(3,p) = gmm_ipos(3,npos0)
- gmm_ipos(4,p) = gmm_ipos(4,npos0)
- npos0 = npos0 - 1
- ENDIF ! TT .LE. TM
- ENDDO ! p=1,npos
- npos = npos0
- ! WRITE(cbuf,'(A,I2.2,A)') 'state_',Marchit,'.out'
- ! OPEN(40,FILE=cbuf,STATUS='REPLACE',ACTION='WRITE')
- ! WRITE(cbuf,'(A,I2.2,A)') 'value_',Marchit,'.out'
- ! OPEN(30,FILE=cbuf,STATUS='REPLACE',ACTION='WRITE')
- ! DO kk=1,zhi
- ! DO jj=1,yhi
- ! DO ii=1,xhi
- ! WRITE(40,'(I3)') gmm_state3d(ii,jj,kk,jsub)
- ! IF (fdta(ii,jj,kk,jsub) .GT. hsave) THEN
- ! WRITE(30,'(E20.8)') 0.0_MK
- ! ELSE
- ! WRITE(30,'(E20.8)') fdta(ii,jj,kk,jsub)
- ! ENDIF
- ! ENDDO
- ! ENDDO
- ! ENDDO
- ! CLOSE(30)
- ! CLOSE(40)
- !-------------------------------------------------------------------------
- ! Update ghost layers for both fdta AND gmm_state3d
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,fdta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,gmm_state3d,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'pushing status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,gmm_state3d,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'popping status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,fdta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __DIM == __2D
- npos0 = npos
- !-------------------------------------------------------------------------
- ! Forward order: update neighbors of points in ggm_ipos
- !-------------------------------------------------------------------------
- DO p=1,npos
- IF (p .GT. npos0) EXIT
- ii = gmm_ipos(1,p)
- jj = gmm_ipos(2,p)
- jsub = gmm_ipos(3,p)
- isub = topo%isublist(jsub)
- xhi = mesh%nnodes(1,isub)
- yhi = mesh%nnodes(2,isub)
- fdta0= fdta(ii,jj,jsub)
- absfdta0 = fdta0
- IF (absfdta0 .LT. 0.0_MK) absfdta0 = -absfdta0
- !---------------------------------------------------------------------
- ! GMM update condition (see Kim:2001a)
- !---------------------------------------------------------------------
- IF (.NOT.(absfdta0.GT.TM)) THEN
- !-----------------------------------------------------------------
- ! Compute non-accepted neighbors
- !-----------------------------------------------------------------
- i = ii - 1
- j = jj
- IF (i.GT.0) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,jsub))) THEN
- IF ((valijk*fdta(i,j,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,jsub).GT.hsave)) THEN
- fdta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state2d(i,j,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,jsub)) .LT. width)) THEN
- gmm_state2d(i,j,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii + 1
- j = jj
- IF (i.LE.xhi) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,jsub))) THEN
- IF ((valijk*fdta(i,j,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,jsub).GT.hsave)) THEN
- fdta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state2d(i,j,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,jsub)) .LT. width)) THEN
- gmm_state2d(i,j,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj - 1
- IF (j.GT.0) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,jsub))) THEN
- IF ((valijk*fdta(i,j,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,jsub).GT.hsave)) THEN
- fdta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state2d(i,j,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,jsub)) .LT. width)) THEN
- gmm_state2d(i,j,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- i = ii
- j = jj + 1
- IF (j.LE.yhi) THEN
- IF ((gmm_state2d(i,j,jsub) .NE. &
- & ppm_gmm_param_accepted) .AND. &
- & (ABS(fdta(i,j,jsub)).GT.absfdta0)) THEN
- !---------------------------------------------------------
- ! Update point i,j
- !---------------------------------------------------------
-#include "ppm_gmm_slvupwnd.inc"
- IF (valijk .LT. hsave) THEN
- IF (ABS(valijk).LT.ABS(fdta(i,j,jsub))) THEN
- IF ((valijk*fdta(i,j,jsub).GE.0.0_MK) .OR. &
- & (fdta(i,j,jsub).GT.hsave)) THEN
- fdta(i,j,jsub) = valijk
- ENDIF
- ENDIF
- !-----------------------------------------------------
- ! Keep in or add to close set
- !-----------------------------------------------------
- IF ((gmm_state2d(i,j,jsub) .EQ. &
- & ppm_gmm_param_far) .AND. &
- & (ABS(fdta(i,j,jsub)) .LT. width)) THEN
- gmm_state2d(i,j,jsub) = &
- & ppm_gmm_param_close
-#include "ppm_gmm_add_to_list.inc"
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- !-----------------------------------------------------------------
- ! Accept this point and remove it from the list
- !-----------------------------------------------------------------
- gmm_state2d(ii,jj,jsub) = ppm_gmm_param_accepted
- gmm_ipos(1,p) = gmm_ipos(1,npos0)
- gmm_ipos(2,p) = gmm_ipos(2,npos0)
- gmm_ipos(3,p) = gmm_ipos(3,npos0)
- npos0 = npos0 - 1
- ENDIF ! TT .LE. TM
- ENDDO ! p=1,npos
- npos = npos0
- !-------------------------------------------------------------------------
- ! Update ghost layers for both fdta AND gmm_state2d
- !-------------------------------------------------------------------------
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,fdta,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'pushing field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_push(gmm_topoid,gmm_meshid,gmm_state2d,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'pushing status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_send(info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'sending ghosts failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,gmm_state2d,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'popping status data failed',__LINE__,info)
- GOTO 9999
- ENDIF
- CALL ppm_map_field_pop(gmm_topoid,gmm_meshid,fdta,ghostsize,info)
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_march_fwd', &
- & 'popping field data failed',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_march_fwd',t0,info)
- RETURN
-
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_march_fwd_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_march_fwd_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_march_fwd_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_march_fwd_3dd
-#endif
-#endif
diff --git a/src/ppm_gmm_quadeq.inc b/src/ppm_gmm_quadeq.inc
deleted file mode 100644
index 0d8c803c5bf4e1c7e35440f5e0dc2ee6a824daf8..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_quadeq.inc
+++ /dev/null
@@ -1,52 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for solving a quadratic equation.
- !
- ! INPUT: REAL(MK), DIMENSION(3) :: coefs -- coefficients:
- ! coefs(3)*x**2 + coefs(2)*x + coefs(1) = 0
- ! OUTPUT: REAL(MK), DIMENSION(2) :: roots -- the two roots.
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_quadeq.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2005/04/27 01:06:12 ivos
- ! Convergence tests completed, cleaned up code, optmized code (Shark),
- ! and changed structure to allow faster compilation.
- !
- ! Revision 1.2 2005/03/10 01:48:27 ivos
- ! Removed debug output.
- !
- ! Revision 1.1 2005/03/10 01:37:20 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
- IF (ABS(coefs(3)) .GT. lmyeps) THEN
- ainv = 1.0_MK/coefs(3)
- det = ainv*ainv
- det = 0.25_MK*coefs(2)*coefs(2)*det
- det = det - coefs(1)*ainv
- IF (det .GT. 0.0_MK) THEN
- det = SQRT(det)
- roots(1) = -0.5_MK*coefs(2)*ainv
- roots(2) = roots(1) + det
- roots(1) = roots(1) - det
- ELSE
- roots(1) = big
- roots(2) = big
- ENDIF
- ELSE
- ! linear equation
- IF (ABS(coefs(2)) .GT. lmyeps) THEN
- roots(1) = 0.0_MK
- roots(2) = -coefs(1)/coefs(2)
- ELSE
- roots(1) = big
- roots(2) = big
- ENDIF
- ENDIF
diff --git a/src/ppm_gmm_quasinewton.inc b/src/ppm_gmm_quasinewton.inc
deleted file mode 100644
index 25d1ad2dd339f273f8692e2e68ac8eee81bd1eb5..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_quasinewton.inc
+++ /dev/null
@@ -1,313 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for the quasi-Newton iteration in the initialization
- ! of the high-order marching method.
- !
- ! INPUT: REAL(MK), DIMENSION(2 or 3) :: x0 -- start value
- ! OUTPUT: REAL(MK) :: sprod -- new distance to interface
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_quasinewton.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.6 2005/07/14 19:58:15 ivos
- ! Added OPTIONAL argument chi for mesh node positions in distorted
- ! (mapped) meshes. For use with AGM for example.
- !
- ! Revision 1.5 2005/05/24 23:21:55 ivos
- ! Commented out the convergence warning as I think this can naturally
- ! occur in under-resolved regions...
- !
- ! Revision 1.4 2005/05/10 04:48:46 ivos
- ! Split marching and extension routines for faster compilation,
- ! Sharked extension routines, moved all initialization to gmm_init, and
- ! code cosmetics.
- !
- ! Revision 1.3 2005/04/21 04:53:27 ivos
- ! If convergence fails, an error message is now produced, rather
- ! than returning HUGE. The latter could go undetected and produce
- ! funny results downstream...
- !
- ! Revision 1.2 2005/03/11 04:20:13 ivos
- ! Removed debug output.
- !
- ! Revision 1.1 2005/03/10 01:37:19 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __3D
- xk = x0
- err = big
- tol2 = tol*tol
- nit = 0
- DO WHILE ((err.GT.tol2).AND.(nit.LT.40))
- ! interpolation polynomial and its gradient at xk
- ! This is a stupid way to evaluate the
- ! polynomial, but I could not find a better
- ! one immediately...
- xv(1) = xk(1)
- xv(2) = xk(1)*xk(1)
- xv(3) = xv(2)*xk(1)
- yv(1) = xk(2)
- yv(2) = xk(2)*xk(2)
- yv(3) = yv(2)*xk(2)
- zv(1) = xk(3)
- zv(2) = xk(3)*xk(3)
- zv(3) = zv(2)*xk(3)
- gxv(2) = 2.0_MK*xk(1)
- gxv(3) = 3.0_MK*xv(2)
- gyv(2) = 2.0_MK*xk(2)
- gyv(3) = 3.0_MK*yv(2)
- gzv(2) = 2.0_MK*xk(3)
- gzv(3) = 3.0_MK*zv(2)
- pxk = 0.0_MK
- gradpxk = 0.0_MK
- DO p=0,3
- DO n=0,3
- DO m=0,3
- ind = 16*p+4*n+m+1
- pxk = pxk+coef(ind)*xv(m)*yv(n)*zv(p)
- gradpxk(1) = gradpxk(1) + &
- & (coef(ind)*gxv(m)*yv(n)*zv(p))
- gradpxk(2) = gradpxk(2) + &
- & (coef(ind)*xv(m)*gyv(n)*zv(p))
- gradpxk(3) = gradpxk(3) + &
- & (coef(ind)*xv(m)*yv(n)*gzv(p))
- ENDDO
- ENDDO
- ENDDO
- ! equation (3.4) in Chopp:2001
- nrm2 = gradpxk(1)*gradpxk(1)
- nrm2 = nrm2 + (gradpxk(2)*gradpxk(2))
- nrm2 = nrm2 + (gradpxk(3)*gradpxk(3))
- nrm2 = 1.0_MK/nrm2
- delta1(1) = -pxk*gradpxk(1)*nrm2
- delta1(2) = -pxk*gradpxk(2)*nrm2
- delta1(3) = -pxk*gradpxk(3)*nrm2
- err = delta1(1)*delta1(1)
- err = err + (delta1(2)*delta1(2))
- err = err + (delta1(3)*delta1(3))
- ! equation (3.5) in Chopp:2001
- xkhalf(1) = xk(1) + delta1(1)
- xkhalf(2) = xk(2) + delta1(2)
- xkhalf(3) = xk(3) + delta1(3)
- ! equation (3.6) in Chopp:2001
- x0mxk(1) = x0(1)-xk(1)
- x0mxk(2) = x0(2)-xk(2)
- x0mxk(3) = x0(3)-xk(3)
- sprod = x0mxk(1)*gradpxk(1)
- sprod = sprod + (x0mxk(2)*gradpxk(2))
- sprod = sprod + (x0mxk(3)*gradpxk(3))
- nrm2 = nrm2*sprod
- delta2(1) = x0mxk(1) - nrm2*gradpxk(1)
- delta2(2) = x0mxk(2) - nrm2*gradpxk(2)
- delta2(3) = x0mxk(3) - nrm2*gradpxk(3)
- err = err + (delta2(1)*delta2(1))
- err = err + (delta2(2)*delta2(2))
- err = err + (delta2(3)*delta2(3))
- ! equation (3.7) in Chopp:2001
- xk(1) = xkhalf(1) + delta2(1)
- xk(2) = xkhalf(2) + delta2(2)
- xk(3) = xkhalf(3) + delta2(3)
- nit = nit + 1
- ENDDO
- IF (nit .GT. 39) THEN
- ! did not converge
- ! info = ppm_error_warning
- ! CALL ppm_error(ppm_err_converge, &
- !& 'ppm_gmm_kickoff', &
- !& 'WARNING: Tolerance not reached!'&
- !& ,__LINE__,info)
- ! info = ppm_param_success
- sprod = big
- ELSE
- ! distance to the interface in real
- ! coordinates
- IF (PRESENT(chi)) THEN
- !-----------------------------------------------------------------
- ! Map the point to physical space using trilinear
- ! interpolation of the map (AGM uses linear basis functions)
- !-----------------------------------------------------------------
- xi(1) = 1.0_MK-xk(1)
- xi(2) = 1.0_MK-xk(2)
- xi(3) = 1.0_MK-xk(3)
- ch(1) = chi(1,i ,j ,k ,jsub)
- ch(2) = chi(1,ip1,j ,k ,jsub)
- ch(3) = chi(1,i ,jp1,k ,jsub)
- ch(4) = chi(1,i ,j ,kp1,jsub)
- ch(5) = chi(1,ip1,j ,kp1,jsub)
- ch(6) = chi(1,i ,jp1,kp1,jsub)
- ch(7) = chi(1,ip1,jp1,k ,jsub)
- ch(8) = chi(1,ip1,jp1,kp1,jsub)
- xr(1) = ch(1)*xi(1)*xi(2)*xi(3)
- xr(1) = xr(1) + ch(2)*xk(1)*xi(2)*xi(3)
- xr(1) = xr(1) + ch(3)*xi(1)*xk(2)*xi(3)
- xr(1) = xr(1) + ch(4)*xi(1)*xi(2)*xk(3)
- xr(1) = xr(1) + ch(5)*xk(1)*xi(2)*xk(3)
- xr(1) = xr(1) + ch(6)*xi(1)*xk(2)*xk(3)
- xr(1) = xr(1) + ch(7)*xk(1)*xk(2)*xi(3)
- xr(1) = xr(1) + ch(8)*xk(1)*xk(2)*xk(3)
- ch(1) = chi(2,i ,j ,k ,jsub)
- ch(2) = chi(2,ip1,j ,k ,jsub)
- ch(3) = chi(2,i ,jp1,k ,jsub)
- ch(4) = chi(2,i ,j ,kp1,jsub)
- ch(5) = chi(2,ip1,j ,kp1,jsub)
- ch(6) = chi(2,i ,jp1,kp1,jsub)
- ch(7) = chi(2,ip1,jp1,k ,jsub)
- ch(8) = chi(2,ip1,jp1,kp1,jsub)
- xr(2) = ch(1)*xi(1)*xi(2)*xi(3)
- xr(2) = xr(2) + ch(2)*xk(1)*xi(2)*xi(3)
- xr(2) = xr(2) + ch(3)*xi(1)*xk(2)*xi(3)
- xr(2) = xr(2) + ch(4)*xi(1)*xi(2)*xk(3)
- xr(2) = xr(2) + ch(5)*xk(1)*xi(2)*xk(3)
- xr(2) = xr(2) + ch(6)*xi(1)*xk(2)*xk(3)
- xr(2) = xr(2) + ch(7)*xk(1)*xk(2)*xi(3)
- xr(2) = xr(2) + ch(8)*xk(1)*xk(2)*xk(3)
- ch(1) = chi(3,i ,j ,k ,jsub)
- ch(2) = chi(3,ip1,j ,k ,jsub)
- ch(3) = chi(3,i ,jp1,k ,jsub)
- ch(4) = chi(3,i ,j ,kp1,jsub)
- ch(5) = chi(3,ip1,j ,kp1,jsub)
- ch(6) = chi(3,i ,jp1,kp1,jsub)
- ch(7) = chi(3,ip1,jp1,k ,jsub)
- ch(8) = chi(3,ip1,jp1,kp1,jsub)
- xr(3) = ch(1)*xi(1)*xi(2)*xi(3)
- xr(3) = xr(3) + ch(2)*xk(1)*xi(2)*xi(3)
- xr(3) = xr(3) + ch(3)*xi(1)*xk(2)*xi(3)
- xr(3) = xr(3) + ch(4)*xi(1)*xi(2)*xk(3)
- xr(3) = xr(3) + ch(5)*xk(1)*xi(2)*xk(3)
- xr(3) = xr(3) + ch(6)*xi(1)*xk(2)*xk(3)
- xr(3) = xr(3) + ch(7)*xk(1)*xk(2)*xi(3)
- xr(3) = xr(3) + ch(8)*xk(1)*xk(2)*xk(3)
- !-----------------------------------------------------------------
- ! Compute the distance vector in physical space
- !-----------------------------------------------------------------
- x0mxk(1) = x-xr(1)
- x0mxk(2) = y-xr(2)
- x0mxk(3) = z-xr(3)
- ELSE
- !-----------------------------------------------------------------
- ! Undo scaling and compute distance vector
- !-----------------------------------------------------------------
- x0mxk(1) = dx*(x0(1)-xk(1))
- x0mxk(2) = dy*(x0(2)-xk(2))
- x0mxk(3) = dz*(x0(3)-xk(3))
- ENDIF
- sprod = x0mxk(1)*x0mxk(1)
- sprod = sprod + (x0mxk(2)*x0mxk(2))
- sprod = sprod + (x0mxk(3)*x0mxk(3))
- sprod = SQRT(sprod)
- ENDIF
-#elif __DIM == __2D
- xk = x0
- err = big
- tol2 = tol*tol
- nit = 0
- DO WHILE ((err.GT.tol2).AND.(nit.LT.40))
- ! interpolation polynomial and its gradient at xk
- ! This is a stupid way to evaluate the
- ! polynomial, but I could not find a better
- ! one immediately...
- xv(1) = xk(1)
- xv(2) = xk(1)*xk(1)
- xv(3) = xv(2)*xk(1)
- yv(1) = xk(2)
- yv(2) = xk(2)*xk(2)
- yv(3) = yv(2)*xk(2)
- gxv(2) = 2.0_MK*xk(1)
- gxv(3) = 3.0_MK*xv(2)
- gyv(2) = 2.0_MK*xk(2)
- gyv(3) = 3.0_MK*yv(2)
- pxk = 0.0_MK
- gradpxk = 0.0_MK
- DO n=0,3
- DO m=0,3
- ind = 4*n+m+1
- pxk = pxk+coef(ind)*xv(m)*yv(n)
- gradpxk(1) = gradpxk(1) + &
- & (coef(ind)*gxv(m)*yv(n))
- gradpxk(2) = gradpxk(2) + &
- & (coef(ind)*xv(m)*gyv(n))
- ENDDO
- ENDDO
- ! equation (3.4) in Chopp:2001
- nrm2 = gradpxk(1)*gradpxk(1)
- nrm2 = nrm2 + (gradpxk(2)*gradpxk(2))
- nrm2 = 1.0_MK/nrm2
- delta1(1) = -pxk*gradpxk(1)*nrm2
- delta1(2) = -pxk*gradpxk(2)*nrm2
- err = delta1(1)*delta1(1)
- err = err + (delta1(2)*delta1(2))
- ! equation (3.5) in Chopp:2001
- xkhalf(1) = xk(1) + delta1(1)
- xkhalf(2) = xk(2) + delta1(2)
- ! equation (3.6) in Chopp:2001
- x0mxk(1) = x0(1)-xk(1)
- x0mxk(2) = x0(2)-xk(2)
- sprod = x0mxk(1)*gradpxk(1)
- sprod = sprod + (x0mxk(2)*gradpxk(2))
- nrm2 = nrm2*sprod
- delta2(1) = x0mxk(1) - nrm2*gradpxk(1)
- delta2(2) = x0mxk(2) - nrm2*gradpxk(2)
- err = err + (delta2(1)*delta2(1))
- err = err + (delta2(2)*delta2(2))
- ! equation (3.7) in Chopp:2001
- xk(1) = xkhalf(1) + delta2(1)
- xk(2) = xkhalf(2) + delta2(2)
- nit = nit + 1
- ENDDO
- IF (nit .GT. 39) THEN
- ! did not converge
- ! info = ppm_error_warning
- ! CALL ppm_error(ppm_err_converge, &
- !& 'ppm_gmm_kickoff', &
- !& 'WARNING: Tolerance not reached!'&
- !& ,__LINE__,info)
- ! info = ppm_param_success
- sprod = big
- ELSE
- IF (PRESENT(chi)) THEN
- !-----------------------------------------------------------------
- ! Map the point to physical space using bilinear
- ! interpolation of the map (AGM uses linear basis functions)
- !-----------------------------------------------------------------
- xi(1) = 1.0_MK-xk(1)
- xi(2) = 1.0_MK-xk(2)
- ch(1) = chi(1,i ,j ,jsub)
- ch(2) = chi(1,ip1,j ,jsub)
- ch(3) = chi(1,i ,jp1,jsub)
- ch(4) = chi(1,ip1,jp1,jsub)
- xr(1) = ch(1)*xi(1)*xi(2)
- xr(1) = xr(1) + ch(2)*xk(1)*xi(2)
- xr(1) = xr(1) + ch(3)*xi(1)*xk(2)
- xr(1) = xr(1) + ch(4)*xk(1)*xk(2)
- ch(1) = chi(2,i ,j ,jsub)
- ch(2) = chi(2,ip1,j ,jsub)
- ch(3) = chi(2,i ,jp1,jsub)
- ch(4) = chi(2,ip1,jp1,jsub)
- xr(2) = ch(1)*xi(1)*xi(2)
- xr(2) = xr(2) + ch(2)*xk(1)*xi(2)
- xr(2) = xr(2) + ch(3)*xi(1)*xk(2)
- xr(2) = xr(2) + ch(4)*xk(1)*xk(2)
- !-----------------------------------------------------------------
- ! Compute the distance vector in physical space
- !-----------------------------------------------------------------
- x0mxk(1) = x-xr(1)
- x0mxk(2) = y-xr(2)
- ELSE
- !-----------------------------------------------------------------
- ! Undo scaling and compute distance vector
- !-----------------------------------------------------------------
- x0mxk(1) = dx*(x0(1)-xk(1))
- x0mxk(2) = dy*(x0(2)-xk(2))
- ENDIF
- sprod = x0mxk(1)*x0mxk(1)
- sprod = sprod + (x0mxk(2)*x0mxk(2))
- sprod = SQRT(sprod)
- ENDIF
-#endif
diff --git a/src/ppm_gmm_reinitialize.f b/src/ppm_gmm_reinitialize.f
deleted file mode 100644
index c0dbca0b2d4c3706e3476fa6695d1d64d25ac529..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_reinitialize.f
+++ /dev/null
@@ -1,269 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_gmm_reinitialize
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_reinitialize_2ds(fdata,tol,width, &
- & order,info,thresh,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_reinitialize_2dd(fdata,tol,width, &
- & order,info,thresh,chi,MaxIter)
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_gmm_reinitialize_3ds(fdata,tol,width, &
- & order,info,thresh,chi,MaxIter)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_gmm_reinitialize_3dd(fdata,tol,width, &
- & order,info,thresh,chi,MaxIter)
-#endif
-#endif
- !!! This routine re-initializes a signed distance level function with the
- !!! zero level representing the interface. Shift accordingly if other
- !!! level is to be used. The group marching method is used.
- !!!
- !!! === References ===
- !!!
- !!! S. Kim. An O(N) level set method for Eikonal equations. SIAM J. Sci.
- !!! Comput. 22(6):2178-2193, 2001.
- !-------------------------------------------------------------------------
- ! Includes
- !-------------------------------------------------------------------------
-#include "ppm_define.h"
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
-
- USE ppm_module_data_gmm
- USE ppm_module_gmm_init
- USE ppm_module_gmm_kickoff
- USE ppm_module_gmm_march
- USE ppm_module_gmm_finalize
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_typedef
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION | __KIND == __SINGLE_PRECISION_COMPLEX
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#else
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-------------------------------------------------------------------------
- ! Arguments
- !-------------------------------------------------------------------------
-#if __DIM == __2D
- REAL(MK), DIMENSION(:,:,: ) , POINTER :: fdata
- !!! Field data. Rank 3 (for 2D scalar fields).
- !!! Indices: (i,j,[k],isub). On input: old level function values. The
- !!! interface is at level zero. A ghostsize of 1 is needed on all sides
- !!! which must be filled with the old level function value on input!!
- !!! On output: reinitialized signed distance function using the
- !!! interpolation method of Chopp. Points far from the interface will have
- !!! the value HUGE.
- REAL(MK), DIMENSION(:,:,:,:) , INTENT(IN), OPTIONAL:: chi
- !!! Rank 4 (2d) field specifying the positions of the grid nodes.
- !!! 1st index: 1..ppm_dim, then i,j,[k],isub. OPTIONAL. Uniform grid is
- !!! assumed if absent. Ghostlayers of size >=1 must be pre-filled.
-#elif __DIM == __3D
- REAL(MK), DIMENSION(:,:,:,:) , POINTER :: fdata
- !!! Field data. Rank 4 (for 3D scalar fields).
- !!! Indices: (i,j,[k],isub). On input: old level function values. The
- !!! interface is at level zero. A ghostsize of 1 is needed on all sides
- !!! which must be filled with the old level function value on input!!
- !!! On output: reinitialized signed distance function using the
- !!! interpolation method of Chopp. Points far from the interface will have
- !!! the value HUGE.
- REAL(MK), DIMENSION(:,:,:,:,:) , INTENT(IN), OPTIONAL:: chi
- !!! Rank 5 (3d) field specifying the positions
- !!! of the grid nodes. 1st index: 1..ppm_dim, then i,j,[k],isub.
- !!! OPTIONAL. Uniform grid is assumed if absent. Ghostlayers of size >=1
- !!! must be pre-filled.
-#endif
- INTEGER , INTENT(IN ) :: order
- !!! Order of the method to be used. One of
- !!!
- !!! *ppm_param_order_1
- !!! *ppm_param_order_2
- !!! *ppm_param_order_3
- REAL(MK) , INTENT(IN ) :: tol
- !!! Relative tolerance for the determined distance to the interface.
- !!! 1E-3 is a good choice. The tolerance is in multiples of grid spacings.
- REAL(MK) , INTENT(IN ) :: width
- !!! Width of the narrow band to be produced on each side of the interface.
- INTEGER , INTENT( OUT) :: info
- REAL(MK) , OPTIONAL , INTENT(IN ) :: thresh
- !!! OPTIONAL. Threshold for interface detection. If this is not specified,
- !!! it is set to MAXVAL(ABS(fdata)).
- INTEGER , OPTIONAL , INTENT(IN ) :: MaxIter
- !!! OPTIONAL argument specifying the maximum number of allowed iterations.
- !!! This can be useful since a cyclic dependency in the GMM algorithms
- !!! could cause infinite loops. In each iteration at least one point is
- !!! computed.
- !-------------------------------------------------------------------------
- ! Local variables
- !-------------------------------------------------------------------------
- INTEGER :: xhi,i,isub,Nminit,MaxIt
- REAL(MK) :: t0,th
- LOGICAL :: lok
- TYPE(ppm_t_topo), POINTER :: topo
- !-------------------------------------------------------------------------
- ! Initialise
- !-------------------------------------------------------------------------
- CALL substart('ppm_gmm_reinitialize',t0,info)
- topo => ppm_topo(gmm_topoid)%t
- !-------------------------------------------------------------------------
- ! Check arguments
- !-------------------------------------------------------------------------
- IF (ppm_debug .GT. 0) THEN
- IF (.NOT. ppm_initialized) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_ppm_noinit,'ppm_gmm_reinitialize', &
- & 'Please call ppm_init first!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (tol .LE. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'tolerance must be >0!',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (width .LE. 0.0_MK) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'width must be >0!',__LINE__,info)
- GOTO 9999
- ENDIF
-#if __DIM == __3D
- IF (SIZE(fdata,4) .LT. topo%nsublist) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'field data for some subs is missing',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,1) .LT. maxxhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'x dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,2) .LT. maxyhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'y dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,3) .LT. maxzhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'z dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
-#elif __DIM == __2D
- IF (SIZE(fdata,3) .LT. topo%nsublist) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'field data for some subs is missing',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,1) .LT. maxxhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'x dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
- IF (UBOUND(fdata,2) .LT. maxyhi) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_argument,'ppm_gmm_reinitialize', &
- & 'y dimension of field data does not match mesh',__LINE__,info)
- GOTO 9999
- ENDIF
-#endif
- ENDIF ! ppm_debug for argument check
- !-------------------------------------------------------------------------
- ! Kickoff GMM. We assume that the largest occuring values are
- ! outside of the band.
- !-------------------------------------------------------------------------
- IF (PRESENT(thresh)) THEN
- th = thresh
- ELSE
- th = 0.99_MK*MAXVAL(ABS(fdata))
- ENDIF
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_kickoff(fdata,tol,th,info,chi=chi)
- ELSE
- CALL ppm_gmm_kickoff(fdata,tol,th,info)
- ENDIF
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_reinitialize', &
- & 'Starting GMM failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Check if the maximum number of iterations was specified
- !-------------------------------------------------------------------------
- IF (PRESENT(MaxIter)) THEN
- MaxIt = MaxIter
- ELSE
- MaxIt = HUGE(MaxIt)
- ENDIF
- !-------------------------------------------------------------------------
- ! Marching GMM
- !-------------------------------------------------------------------------
- IF (PRESENT(chi)) THEN
- CALL ppm_gmm_march(width,order,fdata,1.0_MK,MaxIt,info,chi=chi)
- ELSE
- CALL ppm_gmm_march(width,order,fdata,1.0_MK,MaxIt,info)
- ENDIF
- IF (info .NE. ppm_param_success) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_sub_failed,'ppm_gmm_reinitialize', &
- & 'Marching GMM failed.',__LINE__,info)
- GOTO 9999
- ENDIF
- !-------------------------------------------------------------------------
- ! Return
- !-------------------------------------------------------------------------
- 9999 CONTINUE
- CALL substop('ppm_gmm_reinitialize',t0,info)
- RETURN
-#if __DIM == __2D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_reinitialize_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_reinitialize_2dd
-#endif
-#elif __DIM == __3D
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_gmm_reinitialize_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_gmm_reinitialize_3dd
-#endif
-#endif
diff --git a/src/ppm_gmm_slvextn.inc b/src/ppm_gmm_slvextn.inc
deleted file mode 100644
index 847ee8882eb0427edee1696efd208e2784c11cbb..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_slvextn.inc
+++ /dev/null
@@ -1,358 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for determining and solving the linear equation
- ! for orthogonal extension using upwind differences in the unknown
- ! funciton and centered differences for the level function.
- !
- ! INPUT: INTEGER :: i,j,k -- Point to solve for
- ! INTEGER :: order -- Desired order of FD scheme
- ! REAL(MK), POINTER :: dta -- data
- ! REAL(MK), POINTER :: fdta -- level function
- ! OUTPUT: REAL(MK):: valijk -- Computed value for point i,j,k
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_slvextn.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.4 2005/07/25 00:31:10 ivos
- ! bugfix: index errors in jacobian fixed.
- !
- ! Revision 1.3 2005/07/14 19:58:16 ivos
- ! Added OPTIONAL argument chi for mesh node positions in distorted
- ! (mapped) meshes. For use with AGM for example.
- !
- ! Revision 1.2 2005/05/24 23:24:44 ivos
- ! Added checks for uninitialized values in the centered differences
- ! to avoid float overflows in underresolved regions. This is a
- ! technical fix as the result will still be wrong in such cases...
- !
- ! Revision 1.1 2005/05/10 04:41:16 ivos
- ! Newly created during modularization of ppm_gmm_march. Marching
- ! and orthogonal extendion are now in separate routines for faster
- ! compilation.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Determine switches
- !-------------------------------------------------------------------------
-#include "ppm_gmm_switches.inc"
-
- !-------------------------------------------------------------------------
- ! Read level function
- !-------------------------------------------------------------------------
-#include "ppm_gmm_getfdta.inc"
-
- !-------------------------------------------------------------------------
- ! Read value function
- !-------------------------------------------------------------------------
-#include "ppm_gmm_getdta.inc"
-
- !-------------------------------------------------------------------------
- ! Compute upwind finite differences of appropriate
- ! order.
- ! alpha(1:3) x,y(,z) coefs of the unknown term in dta
- ! beta(1:3) x,y(,z) coefs of the constant term in dta
- ! gphi(1:3) x,y(,z) gradient of the level function
- !-------------------------------------------------------------------------
- alpha = 0.0_MK
- beta = 0.0_MK
- gphi = 0.0_MK
-
- !-------------------------------------------------------------------------
- ! --- X DIRECTION
- !-------------------------------------------------------------------------
- ! Use upwind direction in level function
- IF ((ABS(phi(-1,1)) .LT. ABS(phi(0,1))) .OR. (psi(1,1) .GT. hsave)) THEN
- i1 = -1
- i2 = -2
- i3 = -3
- ELSE
- i1 = 1
- i2 = 2
- i3 = 3
- ENDIF
- IF (sx(i1) .GT. 0) THEN
- !---------------------------------------------------------------------
- ! First order in x direction
- !---------------------------------------------------------------------
- alpha(1) = -1.0_MK
- beta(1) = psi(i1,1)
- IF (sx(i2) .GT. 0) THEN
- !-----------------------------------------------------------------
- ! Second order in x direction
- !-----------------------------------------------------------------
- alpha(1) = alpha(1) - 0.5_MK
- beta(1) = beta(1) + psi(i1,1) - 0.5_MK*psi(i2,1)
- IF (sx(i3) .GT. 0) THEN
- !-------------------------------------------------------------
- ! Third order in negative x direction
- !-------------------------------------------------------------
- alpha(1) = alpha(1) - onethird
- beta(1) = beta(1)+psi(i1,1)-psi(i2,1)+onethird*psi(i3,1)
- ENDIF
- ENDIF
- ENDIF
-
- IF (i1 .LT. 0) THEN
- alpha(1) = -alpha(1)*dxinv
- beta(1) = -beta(1)*dxinv
- ELSE
- alpha(1) = alpha(1)*dxinv
- beta(1) = beta(1)*dxinv
- ENDIF
-
- !-------------------------------------------------------------------------
- ! --- Y DIRECTION
- !-------------------------------------------------------------------------
- ! Use upwind direction
- IF ((ABS(phi(-1,2)) .LT. ABS(phi(0,2))) .OR. (psi(1,2) .GT. hsave)) THEN
- i1 = -1
- i2 = -2
- i3 = -3
- ELSE
- i1 = 1
- i2 = 2
- i3 = 3
- ENDIF
- IF (sy(i1) .GT. 0) THEN
- !---------------------------------------------------------------------
- ! First order in y direction
- !---------------------------------------------------------------------
- alpha(2) = -1.0_MK
- beta(2) = psi(i1,2)
- IF (sy(i2) .GT. 0) THEN
- !-----------------------------------------------------------------
- ! Second order in y direction
- !-----------------------------------------------------------------
- alpha(2) = alpha(2) - 0.5_MK
- beta(2) = beta(2) + psi(i1,2) - 0.5_MK*psi(i2,2)
- IF (sy(i3) .GT. 0) THEN
- !-------------------------------------------------------------
- ! Third order in y direction
- !-------------------------------------------------------------
- alpha(2) = alpha(2) - onethird
- beta(2) = beta(2)+psi(i1,2)-psi(i2,2)+onethird*psi(i3,2)
- ENDIF
- ENDIF
- ENDIF
-
- IF (i1 .LT. 0) THEN
- alpha(2) = -alpha(2)*dyinv
- beta(2) = -beta(2)*dyinv
- ELSE
- alpha(2) = alpha(2)*dyinv
- beta(2) = beta(2)*dyinv
- ENDIF
-
-#if __DIM == __3D
- !-------------------------------------------------------------------------
- ! --- Z DIRECTION
- !-------------------------------------------------------------------------
- ! Use upwind direction
- IF ((ABS(phi(-1,3)) .LT. ABS(phi(0,3))) .OR. (psi(1,3) .GT. hsave)) THEN
- i1 = -1
- i2 = -2
- i3 = -3
- ELSE
- i1 = 1
- i2 = 2
- i3 = 3
- ENDIF
- IF (sz(i1) .GT. 0) THEN
- !---------------------------------------------------------------------
- ! First order in z direction
- !---------------------------------------------------------------------
- alpha(3) = -1.0_MK
- beta(3) = psi(i1,3)
- IF (sz(i2) .GT. 0) THEN
- !-----------------------------------------------------------------
- ! Second order in z direction
- !-----------------------------------------------------------------
- alpha(3) = alpha(3) - 0.5_MK
- beta(3) = beta(3) + psi(i1,3) - 0.5_MK*psi(i2,3)
- IF (sz(i3) .GT. 0) THEN
- !-------------------------------------------------------------
- ! Third order in z direction
- !-------------------------------------------------------------
- alpha(3) = alpha(3) - onethird
- beta(3) = beta(3)+psi(i1,3)-psi(i2,3)+onethird*psi(i3,3)
- ENDIF
- ENDIF
- ENDIF
-
- IF (i1 .LT. 0) THEN
- alpha(3) = -alpha(3)*dzinv
- beta(3) = -beta(3)*dzinv
- ELSE
- alpha(3) = alpha(3)*dzinv
- beta(3) = beta(3)*dzinv
- ENDIF
-#endif
-
- !-------------------------------------------------------------------------
- ! Compute the gradient of the level function using centered
- ! differences.
- !-------------------------------------------------------------------------
- IF (order .EQ. ppm_param_order_1) THEN
- IF (ABS(phi(-1,1)).LT.hsave .AND. ABS(phi(1,1)).LT.hsave) THEN
- gphi(1) = phi(1,1)-phi(-1,1)
- gphi(1) = gphi(1)*dxihalf
- ENDIF
- IF (ABS(phi(-1,2)).LT.hsave .AND. ABS(phi(1,2)).LT.hsave) THEN
- gphi(2) = phi(1,2)-phi(-1,2)
- gphi(2) = gphi(2)*dyihalf
- ENDIF
-#if __DIM == __3D
- IF (ABS(phi(-1,3)).LT.hsave .AND. ABS(phi(1,3)).LT.hsave) THEN
- gphi(3) = phi(1,3)-phi(-1,3)
- gphi(3) = gphi(3)*dzihalf
- ENDIF
-#endif
- ELSEIF (order .EQ. ppm_param_order_2) THEN
- IF (ABS(phi(-1,1)).LT.hsave .AND. ABS(phi(1,1)).LT.hsave) THEN
- gphi(1) = phi(1,1)-phi(-1,1)
- gphi(1) = gphi(1)*dxihalf
- ENDIF
- IF (ABS(phi(-1,2)).LT.hsave .AND. ABS(phi(1,2)).LT.hsave) THEN
- gphi(2) = phi(1,2)-phi(-1,2)
- gphi(2) = gphi(2)*dyihalf
- ENDIF
-#if __DIM == __3D
- IF (ABS(phi(-1,3)).LT.hsave .AND. ABS(phi(1,3)).LT.hsave) THEN
- gphi(3) = phi(1,3)-phi(-1,3)
- gphi(3) = gphi(3)*dzihalf
- ENDIF
-#endif
- ELSE
- IF (ABS(phi(-2,1)).LT.hsave .AND. ABS(phi(-1,1)).LT.hsave .AND. &
- & ABS(phi(1,1)).LT.hsave .AND. ABS(phi(2,1)).LT.hsave) THEN
- gphi(1) = phi(-2,1)-8.0_MK*phi(-1,1)+8.0_MK*phi(1,1)-phi(2,1)
- gphi(1) = gphi(1)*dxitwelve
- ENDIF
- IF (ABS(phi(-2,2)).LT.hsave .AND. ABS(phi(-1,2)).LT.hsave .AND. &
- & ABS(phi(1,2)).LT.hsave .AND. ABS(phi(2,2)).LT.hsave) THEN
- gphi(2) = phi(-2,2)-8.0_MK*phi(-1,2)+8.0_MK*phi(1,2)-phi(2,2)
- gphi(2) = gphi(2)*dyitwelve
- ENDIF
-#if __DIM == __3D
- IF (ABS(phi(-2,3)).LT.hsave .AND. ABS(phi(-1,3)).LT.hsave .AND. &
- & ABS(phi(1,3)).LT.hsave .AND. ABS(phi(2,3)).LT.hsave) THEN
- gphi(3) = phi(-2,3)-8.0_MK*phi(-1,3)+8.0_MK*phi(1,3)-phi(2,3)
- gphi(3) = gphi(3)*dzitwelve
- ENDIF
-#endif
- ENDIF
-
- !-------------------------------------------------------------------------
- ! Compute coefficients for the linear equation for
- ! the value at (i,j,k)
- !-------------------------------------------------------------------------
-#if __DIM == __3D
- IF (PRESENT(chi)) THEN
- !---------------------------------------------------------------------
- ! If we have a non-uniform mesh, compute the Jacobian
- !---------------------------------------------------------------------
-#include "ppm_gmm_jacobian.inc"
- !---------------------------------------------------------------------
- ! Grad phi in physical space
- !---------------------------------------------------------------------
- gpp(1) = jac(1,1)*gphi(1) + jac(2,1)*gphi(2) + jac(3,1)*gphi(3)
- gpp(2) = jac(1,2)*gphi(1) + jac(2,2)*gphi(2) + jac(3,2)*gphi(3)
- gpp(3) = jac(1,3)*gphi(1) + jac(2,3)*gphi(2) + jac(3,3)*gphi(3)
- !---------------------------------------------------------------------
- ! Determine the linear equation for the unknown node
- !---------------------------------------------------------------------
- ! x**0 term
- coefs(1) = &
- & gpp(1)*(jac(1,1)*beta(1)+jac(2,1)*beta(2)+jac(3,1)*beta(3)) + &
- & gpp(2)*(jac(1,2)*beta(1)+jac(2,2)*beta(2)+jac(3,2)*beta(3)) + &
- & gpp(3)*(jac(1,3)*beta(1)+jac(2,3)*beta(2)+jac(3,3)*beta(3))
- IF(PRESENT(speed)) THEN
- coefs(1) = coefs(1) - &
- & 1.0_MK/(speed(i,j,k,jsub)*speed(i,j,k,jsub))
- ELSE
- coefs(1) = coefs(1) - rhscst
- ENDIF
-
- ! x**1 term
- coefs(3) = &
- & gpp(1)*(jac(1,1)*alpha(1)+jac(2,1)*alpha(2)+jac(3,1)*alpha(3))+ &
- & gpp(2)*(jac(1,2)*alpha(1)+jac(2,2)*alpha(2)+jac(3,2)*alpha(3))+ &
- & gpp(3)*(jac(1,3)*alpha(1)+jac(2,3)*alpha(2)+jac(3,3)*alpha(3))
- ELSE
- !---------------------------------------------------------------------
- ! Uniform mesh
- !---------------------------------------------------------------------
- ! x**0 term
- coefs(1) = (beta(1)*gphi(1))+(beta(2)*gphi(2))+(beta(3)*gphi(3))
- IF(PRESENT(speed)) THEN
- coefs(1) = coefs(1) - &
- & 1.0_MK/(speed(i,j,k,jsub)*speed(i,j,k,jsub))
- ELSE
- coefs(1) = coefs(1) - rhscst
- ENDIF
-
- ! x**1 term
- coefs(3) = (alpha(1)*gphi(1))+(alpha(2)*gphi(2))+(alpha(3)*gphi(3))
- ENDIF
-#elif __DIM == __2D
- IF (PRESENT(chi)) THEN
- !---------------------------------------------------------------------
- ! If we have a non-uniform mesh, compute the Jacobian
- !---------------------------------------------------------------------
-#include "ppm_gmm_jacobian.inc"
- !---------------------------------------------------------------------
- ! Grad phi in physical space
- !---------------------------------------------------------------------
- gpp(1) = jac(1,1)*gphi(1) + jac(2,1)*gphi(2)
- gpp(2) = jac(1,2)*gphi(1) + jac(2,2)*gphi(2)
- !---------------------------------------------------------------------
- ! Determine the linear equation for the unknown node
- !---------------------------------------------------------------------
- ! x**0 term
- coefs(1) = &
- & gpp(1)*(jac(1,1)*beta(1)+jac(2,1)*beta(2)) + &
- & gpp(2)*(jac(1,2)*beta(1)+jac(2,2)*beta(2))
- IF(PRESENT(speed)) THEN
- coefs(1) = coefs(1) - &
- & 1.0_MK/(speed(i,j,jsub)*speed(i,j,jsub))
- ELSE
- coefs(1) = coefs(1) - rhscst
- ENDIF
-
- ! x**1 term
- coefs(3) = &
- & gpp(1)*(jac(1,1)*alpha(1)+jac(2,1)*alpha(2))+ &
- & gpp(2)*(jac(1,2)*alpha(1)+jac(2,2)*alpha(2))
- ELSE
- !---------------------------------------------------------------------
- ! Uniform mesh
- !---------------------------------------------------------------------
- ! x**0 term
- coefs(1) = (beta(1)*gphi(1))+(beta(2)*gphi(2))
- IF(PRESENT(speed)) THEN
- coefs(1) = coefs(1) - &
- & 1.0_MK/(speed(i,j,jsub)*speed(i,j,jsub))
- ELSE
- coefs(1) = coefs(1) - rhscst
- ENDIF
-
- ! x**1 term
- coefs(3) = (alpha(1)*gphi(1))+(alpha(2)*gphi(2))
- ENDIF
-#endif
- !-------------------------------------------------------------------------
- ! Solve for the unknown node value
- !-------------------------------------------------------------------------
- IF (ABS(coefs(3)) .GT. lmyeps) THEN
- valijk = -coefs(1)/coefs(3)
- ELSE
- valijk = big
- ENDIF
-
diff --git a/src/ppm_gmm_slvupwnd.inc b/src/ppm_gmm_slvupwnd.inc
deleted file mode 100644
index d8c8e0749f37f3300222d78e4b697b255db118c8..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_slvupwnd.inc
+++ /dev/null
@@ -1,327 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for determining and solving the quadratic equation
- ! using upwind finite differences.
- !
- ! INPUT: INTEGER :: i,j,k -- Point to solve for
- ! INTEGER :: order -- Desired order of FD scheme
- ! REAL(MK), POINTER :: dta -- data
- ! REAL(MK), POINTER :: fdta -- level function
- ! OUTPUT: REAL(MK):: valijk -- Computed value for point i,j,k
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_slvupwnd.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.7 2005/07/25 00:31:09 ivos
- ! bugfix: index errors in jacobian fixed.
- !
- ! Revision 1.6 2005/07/14 19:58:16 ivos
- ! Added OPTIONAL argument chi for mesh node positions in distorted
- ! (mapped) meshes. For use with AGM for example.
- !
- ! Revision 1.5 2005/05/10 04:48:47 ivos
- ! Split marching and extension routines for faster compilation,
- ! Sharked extension routines, moved all initialization to gmm_init, and
- ! code cosmetics.
- !
- ! Revision 1.4 2005/04/27 01:06:13 ivos
- ! Convergence tests completed, cleaned up code, optmized code (Shark),
- ! and changed structure to allow faster compilation.
- !
- ! Revision 1.3 2005/03/16 06:20:09 ivos
- ! Several bugfixes. 1st order version is now tested. Moved all large
- ! data to the module.
- !
- ! Revision 1.2 2005/03/11 04:17:01 ivos
- ! Added possiblity to for velocity extension and to get back
- ! the closest point transform.
- !
- ! Revision 1.1 2005/03/10 01:37:18 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Determine switches
- !-------------------------------------------------------------------------
-#include "ppm_gmm_switches.inc"
-
- !-------------------------------------------------------------------------
- ! Read the level set data
- !-------------------------------------------------------------------------
-#include "ppm_gmm_getfdta.inc"
-
- !-------------------------------------------------------------------------
- ! Compute upwind finite differences of appropriate
- ! order.
- ! alpha(1:3) x,y(,z) coefs of the unknown term in fdta
- ! beta(1:3) x,y(,z) coefs of the constant term in fdta
- !-------------------------------------------------------------------------
- alpha = 0.0_MK
- beta = 0.0_MK
-
- !-------------------------------------------------------------------------
- ! --- X DIRECTION
- !-------------------------------------------------------------------------
- ! Use upwind direction
- IF ((ABS(phi(-1,1)) .LT. ABS(phi(0,1))) .OR. (phi(1,1) .GT. hsave)) THEN
- i1 = -1
- i2 = -2
- i3 = -3
- ELSE
- i1 = 1
- i2 = 2
- i3 = 3
- ENDIF
- IF (sx(i1) .GT. 0) THEN
- !---------------------------------------------------------------------
- ! First order in x direction
- !---------------------------------------------------------------------
- alpha(1) = -1.0_MK
- beta(1) = phi(i1,1)
- IF (sx(i2) .GT. 0) THEN
- !-----------------------------------------------------------------
- ! Second order in x direction
- !-----------------------------------------------------------------
- alpha(1) = alpha(1) - 0.5_MK
- beta(1) = beta(1) + phi(i1,1) - 0.5_MK*phi(i2,1)
- IF (sx(i3) .GT. 0) THEN
- !-------------------------------------------------------------
- ! Third order in negative x direction
- !-------------------------------------------------------------
- alpha(1) = alpha(1) - onethird
- beta(1) = beta(1)+phi(i1,1)-phi(i2,1)+onethird*phi(i3,1)
- ENDIF
- ENDIF
- ENDIF
-
- IF (i1 .LT. 0) THEN
- alpha(1) = -alpha(1)*dxinv
- beta(1) = -beta(1)*dxinv
- ELSE
- alpha(1) = alpha(1)*dxinv
- beta(1) = beta(1)*dxinv
- ENDIF
-
- !-------------------------------------------------------------------------
- ! --- Y DIRECTION
- !-------------------------------------------------------------------------
- ! Use upwind direction
- IF ((ABS(phi(-1,2)) .LT. ABS(phi(0,2))) .OR. (phi(1,2) .GT. hsave)) THEN
- i1 = -1
- i2 = -2
- i3 = -3
- ELSE
- i1 = 1
- i2 = 2
- i3 = 3
- ENDIF
- IF (sy(i1) .GT. 0) THEN
- !---------------------------------------------------------------------
- ! First order in y direction
- !---------------------------------------------------------------------
- alpha(2) = -1.0_MK
- beta(2) = phi(i1,2)
- IF (sy(i2) .GT. 0) THEN
- !-----------------------------------------------------------------
- ! Second order in y direction
- !-----------------------------------------------------------------
- alpha(2) = alpha(2) - 0.5_MK
- beta(2) = beta(2) + phi(i1,2) - 0.5_MK*phi(i2,2)
- IF (sy(i3) .GT. 0) THEN
- !-------------------------------------------------------------
- ! Third order in y direction
- !-------------------------------------------------------------
- alpha(2) = alpha(2) - onethird
- beta(2) = beta(2)+phi(i1,2)-phi(i2,2)+onethird*phi(i3,2)
- ENDIF
- ENDIF
- ENDIF
-
- IF (i1 .LT. 0) THEN
- alpha(2) = -alpha(2)*dyinv
- beta(2) = -beta(2)*dyinv
- ELSE
- alpha(2) = alpha(2)*dyinv
- beta(2) = beta(2)*dyinv
- ENDIF
-
-#if __DIM == __3D
- !-------------------------------------------------------------------------
- ! --- Z DIRECTION
- !-------------------------------------------------------------------------
- ! Use upwind direction
- IF ((ABS(phi(-1,3)) .LT. ABS(phi(0,3))) .OR. (phi(1,3) .GT. hsave)) THEN
- i1 = -1
- i2 = -2
- i3 = -3
- ELSE
- i1 = 1
- i2 = 2
- i3 = 3
- ENDIF
- IF (sz(i1) .GT. 0) THEN
- !---------------------------------------------------------------------
- ! First order in z direction
- !---------------------------------------------------------------------
- alpha(3) = -1.0_MK
- beta(3) = phi(i1,3)
- IF (sz(i2) .GT. 0) THEN
- !-----------------------------------------------------------------
- ! Second order in z direction
- !-----------------------------------------------------------------
- alpha(3) = alpha(3) - 0.5_MK
- beta(3) = beta(3) + phi(i1,3) - 0.5_MK*phi(i2,3)
- IF (sz(i3) .GT. 0) THEN
- !-------------------------------------------------------------
- ! Third order in z direction
- !-------------------------------------------------------------
- alpha(3) = alpha(3) - onethird
- beta(3) = beta(3)+phi(i1,3)-phi(i2,3)+onethird*phi(i3,3)
- ENDIF
- ENDIF
- ENDIF
-
- IF (i1 .LT. 0) THEN
- alpha(3) = -alpha(3)*dzinv
- beta(3) = -beta(3)*dzinv
- ELSE
- alpha(3) = alpha(3)*dzinv
- beta(3) = beta(3)*dzinv
- ENDIF
-#endif
-
- !-------------------------------------------------------------------------
- ! Compute coefficients for the quadratic equation for
- ! the value at (i,j,k)
- !-------------------------------------------------------------------------
-#if __DIM == __3D
- IF (PRESENT(chi)) THEN
- !---------------------------------------------------------------------
- ! If we have a non-uniform mesh, compute the Jacobian
- !---------------------------------------------------------------------
-#include "ppm_gmm_jacobian.inc"
- !---------------------------------------------------------------------
- ! Determine the quadratic equation for the unknown node
- !---------------------------------------------------------------------
- ! x**0 term
- coefs(1) = &
- & (jac(1,1)*beta(1)+jac(2,1)*beta(2)+jac(3,1)*beta(3))**2.0_MK+ &
- & (jac(1,2)*beta(1)+jac(2,2)*beta(2)+jac(3,2)*beta(3))**2.0_MK+ &
- & (jac(1,3)*beta(1)+jac(2,3)*beta(2)+jac(3,3)*beta(3))**2.0_MK
- IF(PRESENT(speed)) THEN
- coefs(1) = coefs(1) - 1.0_MK/(speed(i,j,k,jsub)*speed(i,j,k,jsub))
- ELSE
- coefs(1) = coefs(1) - rhscst
- ENDIF
-
- ! x**2 term
- coefs(3) = &
- & (jac(1,1)*alpha(1)+jac(2,1)*alpha(2)+jac(3,1)*alpha(3))**2.0_MK+ &
- & (jac(1,2)*alpha(1)+jac(2,2)*alpha(2)+jac(3,2)*alpha(3))**2.0_MK+ &
- & (jac(1,3)*alpha(1)+jac(2,3)*alpha(2)+jac(3,3)*alpha(3))**2.0_MK
-
- ! x**1 term
- coefs(2) = &
- (jac(1,1)*beta(1) +jac(2,1)*beta(2) +jac(3,1)*beta(3) ) * &
- & (jac(1,1)*alpha(1)+jac(2,1)*alpha(2)+jac(3,1)*alpha(3))
- coefs(2) = coefs(2) + &
- (jac(1,2)*beta(1) +jac(2,2)*beta(2) +jac(3,2)*beta(3) ) * &
- & (jac(1,2)*alpha(1)+jac(2,2)*alpha(2)+jac(3,2)*alpha(3))
- coefs(2) = coefs(2) + &
- (jac(1,3)*beta(1) +jac(2,3)*beta(2) +jac(3,3)*beta(3) ) * &
- & (jac(1,3)*alpha(1)+jac(2,3)*alpha(2)+jac(3,3)*alpha(3))
- coefs(2) = 2.0_MK*coefs(2)
- ELSE
- !---------------------------------------------------------------------
- ! Uniform mesh
- !---------------------------------------------------------------------
- ! x**0 term
- coefs(1) = (beta(1)*beta(1))+(beta(2)*beta(2))+(beta(3)*beta(3))
- IF(PRESENT(speed)) THEN
- coefs(1) = coefs(1) - 1.0_MK/(speed(i,j,k,jsub)*speed(i,j,k,jsub))
- ELSE
- coefs(1) = coefs(1) - rhscst
- ENDIF
-
- ! x**2 term
- coefs(3) = (alpha(1)*alpha(1))+(alpha(2)*alpha(2))+(alpha(3)*alpha(3))
-
- ! x**1 term
- coefs(2) = (alpha(1)*beta(1))+(alpha(2)*beta(2))+(alpha(3)*beta(3))
- coefs(2) = 2.0_MK*coefs(2)
- ENDIF
-#elif __DIM == __2D
- IF (PRESENT(chi)) THEN
- !---------------------------------------------------------------------
- ! If we have a non-uniform mesh, compute the Jacobian
- !---------------------------------------------------------------------
-#include "ppm_gmm_jacobian.inc"
- !---------------------------------------------------------------------
- ! Determine the quadratic equation for the unknown node
- !---------------------------------------------------------------------
- ! x**0 term
- coefs(1) = &
- & (jac(1,1)*beta(1)+jac(2,1)*beta(2))**2.0_MK+ &
- & (jac(1,2)*beta(1)+jac(2,2)*beta(2))**2.0_MK
- IF(PRESENT(speed)) THEN
- coefs(1) = coefs(1) - 1.0_MK/(speed(i,j,jsub)*speed(i,j,jsub))
- ELSE
- coefs(1) = coefs(1) - rhscst
- ENDIF
-
- ! x**2 term
- coefs(3) = &
- & (jac(1,1)*alpha(1)+jac(2,1)*alpha(2))**2.0_MK+ &
- & (jac(1,2)*alpha(1)+jac(2,2)*alpha(2))**2.0_MK
-
- ! x**1 term
- coefs(2) = &
- (jac(1,1)*beta(1) +jac(2,1)*beta(2) ) * &
- & (jac(1,1)*alpha(1)+jac(2,1)*alpha(2))
- coefs(2) = coefs(2) + &
- (jac(1,2)*beta(1) +jac(2,2)*beta(2) ) * &
- & (jac(1,2)*alpha(1)+jac(2,2)*alpha(2))
- coefs(2) = 2.0_MK*coefs(2)
- ELSE
- !---------------------------------------------------------------------
- ! Uniform mesh
- !---------------------------------------------------------------------
- ! x**0 term
- coefs(1) = (beta(1)*beta(1))+(beta(2)*beta(2))
- IF(PRESENT(speed)) THEN
- coefs(1) = coefs(1) - 1.0_MK/(speed(i,j,jsub)*speed(i,j,jsub))
- ELSE
- coefs(1) = coefs(1) - rhscst
- ENDIF
-
- ! x**2 term
- coefs(3) = (alpha(1)*alpha(1))+(alpha(2)*alpha(2))
-
- ! x**1 term
- coefs(2) = (alpha(1)*beta(1))+(alpha(2)*beta(2))
- coefs(2) = 2.0_MK*coefs(2)
- ENDIF
-#endif
-
- !-------------------------------------------------------------------------
- ! Solve quadratic equation for the unknown node value
- ! Cannot use ppm_util_quadeq_real because this equation can have
- ! complex roots. Result in roots(1:2)
- !-------------------------------------------------------------------------
-#include "ppm_gmm_quadeq.inc"
-
- !-------------------------------------------------------------------------
- ! Update value using the larger of the two roots
- !-------------------------------------------------------------------------
- IF (ABS(roots(1)) .GT. ABS(roots(2))) THEN
- valijk = roots(1)
- ELSE
- valijk = roots(2)
- ENDIF
diff --git a/src/ppm_gmm_switches.inc b/src/ppm_gmm_switches.inc
deleted file mode 100644
index babc1fb0f3d9edab4f0660c55b7460a08403dbcb..0000000000000000000000000000000000000000
--- a/src/ppm_gmm_switches.inc
+++ /dev/null
@@ -1,139 +0,0 @@
- !-------------------------------------------------------------------------
- ! Include file for determining the switches for the higher order
- ! differences.
- !
- ! INPUT: INTEGER :: i,j,k -- Point to solve for
- ! INTEGER :: order -- Desired order of FD scheme
- ! OUTPUT: INTEGER(-order:order) :: sx,sy,sz -- gmm_state of the
- ! neighbors in each direction
- !
- !-------------------------------------------------------------------------
- ! $Log: ppm_gmm_switches.inc,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2005/05/10 04:48:47 ivos
- ! Split marching and extension routines for faster compilation,
- ! Sharked extension routines, moved all initialization to gmm_init, and
- ! code cosmetics.
- !
- ! Revision 1.1 2005/04/27 01:08:39 ivos
- ! Initial commit, but tested.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __DIM == __3D
- IF (order .EQ. ppm_param_order_3) THEN
- sx = 0
- sx(-3) = gmm_state3d(i-3,j,k,jsub)
- sx(-2) = gmm_state3d(i-2,j,k,jsub)
- sx(-1) = gmm_state3d(i-1,j,k,jsub)
- sx( 0) = gmm_state3d(i ,j,k,jsub)
- sx( 1) = gmm_state3d(i+1,j,k,jsub)
- sx( 2) = gmm_state3d(i+2,j,k,jsub)
- sx( 3) = gmm_state3d(i+3,j,k,jsub)
-
- sy = 0
- sy(-3) = gmm_state3d(i,j-3,k,jsub)
- sy(-2) = gmm_state3d(i,j-2,k,jsub)
- sy(-1) = gmm_state3d(i,j-1,k,jsub)
- sy( 0) = gmm_state3d(i,j ,k,jsub)
- sy( 1) = gmm_state3d(i,j+1,k,jsub)
- sy( 2) = gmm_state3d(i,j+2,k,jsub)
- sy( 3) = gmm_state3d(i,j+3,k,jsub)
-
- sz = 0
- sz(-3) = gmm_state3d(i,j,k-3,jsub)
- sz(-2) = gmm_state3d(i,j,k-2,jsub)
- sz(-1) = gmm_state3d(i,j,k-1,jsub)
- sz( 0) = gmm_state3d(i,j,k ,jsub)
- sz( 1) = gmm_state3d(i,j,k+1,jsub)
- sz( 2) = gmm_state3d(i,j,k+2,jsub)
- sz( 3) = gmm_state3d(i,j,k+3,jsub)
- ELSEIF (order .EQ. ppm_param_order_2) THEN
- sx = 0
- sx(-2) = gmm_state3d(i-2,j,k,jsub)
- sx(-1) = gmm_state3d(i-1,j,k,jsub)
- sx( 0) = gmm_state3d(i ,j,k,jsub)
- sx( 1) = gmm_state3d(i+1,j,k,jsub)
- sx( 2) = gmm_state3d(i+2,j,k,jsub)
-
- sy = 0
- sy(-2) = gmm_state3d(i,j-2,k,jsub)
- sy(-1) = gmm_state3d(i,j-1,k,jsub)
- sy( 0) = gmm_state3d(i,j ,k,jsub)
- sy( 1) = gmm_state3d(i,j+1,k,jsub)
- sy( 2) = gmm_state3d(i,j+2,k,jsub)
-
- sz = 0
- sz(-2) = gmm_state3d(i,j,k-2,jsub)
- sz(-1) = gmm_state3d(i,j,k-1,jsub)
- sz( 0) = gmm_state3d(i,j,k ,jsub)
- sz( 1) = gmm_state3d(i,j,k+1,jsub)
- sz( 2) = gmm_state3d(i,j,k+2,jsub)
- ELSE
- sx = 0
- sx(-1) = gmm_state3d(i-1,j,k,jsub)
- sx( 0) = gmm_state3d(i ,j,k,jsub)
- sx( 1) = gmm_state3d(i+1,j,k,jsub)
-
- sy = 0
- sy(-1) = gmm_state3d(i,j-1,k,jsub)
- sy( 0) = gmm_state3d(i,j ,k,jsub)
- sy( 1) = gmm_state3d(i,j+1,k,jsub)
-
- sz = 0
- sz(-1) = gmm_state3d(i,j,k-1,jsub)
- sz( 0) = gmm_state3d(i,j,k ,jsub)
- sz( 1) = gmm_state3d(i,j,k+1,jsub)
- ENDIF
-#elif __DIM == __2D
- IF (order .EQ. ppm_param_order_3) THEN
- sx = 0
- sx(-3) = gmm_state2d(i-3,j,jsub)
- sx(-2) = gmm_state2d(i-2,j,jsub)
- sx(-1) = gmm_state2d(i-1,j,jsub)
- sx( 0) = gmm_state2d(i ,j,jsub)
- sx( 1) = gmm_state2d(i+1,j,jsub)
- sx( 2) = gmm_state2d(i+2,j,jsub)
- sx( 3) = gmm_state2d(i+3,j,jsub)
-
- sy = 0
- sy(-3) = gmm_state2d(i,j-3,jsub)
- sy(-2) = gmm_state2d(i,j-2,jsub)
- sy(-1) = gmm_state2d(i,j-1,jsub)
- sy( 0) = gmm_state2d(i,j ,jsub)
- sy( 1) = gmm_state2d(i,j+1,jsub)
- sy( 2) = gmm_state2d(i,j+2,jsub)
- sy( 3) = gmm_state2d(i,j+3,jsub)
- ELSEIF (order .EQ. ppm_param_order_2) THEN
- sx = 0
- sx(-2) = gmm_state2d(i-2,j,jsub)
- sx(-1) = gmm_state2d(i-1,j,jsub)
- sx( 0) = gmm_state2d(i ,j,jsub)
- sx( 1) = gmm_state2d(i+1,j,jsub)
- sx( 2) = gmm_state2d(i+2,j,jsub)
-
- sy = 0
- sy(-2) = gmm_state2d(i,j-2,jsub)
- sy(-1) = gmm_state2d(i,j-1,jsub)
- sy( 0) = gmm_state2d(i,j ,jsub)
- sy( 1) = gmm_state2d(i,j+1,jsub)
- sy( 2) = gmm_state2d(i,j+2,jsub)
- ELSE
- sx = 0
- sx(-1) = gmm_state2d(i-1,j,jsub)
- sx( 0) = gmm_state2d(i ,j,jsub)
- sx( 1) = gmm_state2d(i+1,j,jsub)
-
- sy = 0
- sy(-1) = gmm_state2d(i,j-1,jsub)
- sy( 0) = gmm_state2d(i,j ,jsub)
- sy( 1) = gmm_state2d(i,j+1,jsub)
- ENDIF
-#endif
diff --git a/src/ppm_hamjac_ext_3d.f b/src/ppm_hamjac_ext_3d.f
deleted file mode 100644
index 5e03a2f74226da7c9109dcd8a836b41def86cd70..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_ext_3d.f
+++ /dev/null
@@ -1,266 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_ext_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas extension
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_ext_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2006/11/24 12:41:13 pchatela
- ! Bugfix: missing collective communication step for global residual
- !
- ! Revision 1.2 2005/08/25 16:48:50 ivos
- ! Fixed format string. pgf90 barked.
- !
- ! Revision 1.1 2005/07/25 00:34:00 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_ext_3ds (phi, psi, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_ext_3dd (phi, psi, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_ext_3dsv (phi, psi, lda, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_ext_3ddv (phi, psi, lda, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#endif
- !-------------------------------------------------------------------------
- ! Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data
-
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- USE ppm_module_write
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#ifdef __MPI
- INTEGER, PARAMETER :: MPTYPE = MPI_REAL
-#endif
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#ifdef __MPI
- INTEGER, PARAMETER :: MPTYPE = MPI_DOUBLE_PRECISION
-#endif
-#endif
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
-#if __MODE == __SCA
- REAL(mk), DIMENSION(:,:,:,:), POINTER :: psi
-#elif __MODE == __VEC
- REAL(mk), DIMENSION(:,:,:,:,:), POINTER :: psi
- INTEGER, INTENT(in) :: lda
-#endif
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(out) :: info
- INTEGER, INTENT(in) :: maxstep
- REAL(mk), INTENT(in) :: tol
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
-#if __MODE == __SCA
- REAL(mk), DIMENSION(:,:,:,:), POINTER :: tpsi
-#elif __MODE == __VEC
- REAL(mk), DIMENSION(:,:,:,:,:), POINTER :: tpsi
-#endif
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
- !-----------------------------------------------------
- ! Local variables
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k
- INTEGER :: istep,iopt
-#if __MODE == __SCA
- INTEGER :: ldl(4), ldu(4)
-#elif __MODE == __VEC
- INTEGER :: ldl(5), ldu(5)
-#endif
- INTEGER :: ndata_max(3)
- REAL(mk) :: t0, lres, gres
- CHARACTER(LEN=ppm_char) :: cbuf
- REAL(mk) :: dx(3), len_phys(3)
- !-----------------------------------------------------
- ! Initialisation
- !-----------------------------------------------------
- CALL substart('ppm_hamjac_ext_3d',t0,info)
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- ! COMMENT Thu May 26 19:39:51 PDT 2005: experimental
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
- !-----------------------------------------------------
- ! allocate temporary storage
- !-----------------------------------------------------
-#if __MODE == __SCA
- ldl(1:3) = 1 - ghostsize(1:3); ldl(4) = 1
-#elif __MODE == __VEC
- ldl(1) = 1
- ldl(2:4) = 1- ghostsize(1:3); ldl(5) = 1
-#endif
- ndata_max(1) = MAXVAL(ndata(1,1:nsublist))
- ndata_max(2) = MAXVAL(ndata(2,1:nsublist))
- ndata_max(3) = MAXVAL(ndata(3,1:nsublist))
-#if __MODE == __SCA
- ldu(1) = ndata_max(1) + ghostsize(1)
- ldu(2) = ndata_max(2) + ghostsize(2)
- ldu(3) = ndata_max(3) + ghostsize(3)
- ldu(4) = nsublist
-#elif __MODE == __VEC
- ldu(1) = lda
- ldu(2) = ndata_max(1) + ghostsize(1)
- ldu(3) = ndata_max(2) + ghostsize(2)
- ldu(4) = ndata_max(3) + ghostsize(3)
- ldu(5) = nsublist
-#endif
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(tpsi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_hamjac_ext_3d', &
- & 'temp storage for donowatocalit',__LINE__,info)
- GOTO 9999
- END IF
- len_phys(1) = max_phys(1) - min_phys(1)
- len_phys(2) = max_phys(2) - min_phys(2)
- len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(mesh%nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%nm(3)-1,mk)
- !--- map the gowas
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
- !--- map the function
- DO istep=1,maxstep
-#if __MODE == __SCA
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,psi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,psi,ghostsize,info)
-
-#elif __MODE == __VEC
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,psi,lda,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id, mesh_id, psi,lda,ghostsize,info)
-#endif
- ! IF (ppm_debug .GT. 0) THEN
- ! ENDIF
-#if __MODE == __SCA
- CALL ppm_hamjac_ext_step (phi,psi,tpsi,lres,topo_id,mesh_id&
- &, ghostsize,info)
-#elif __MODE == __VEC
- CALL ppm_hamjac_ext_step (phi,psi,lda,tpsi,lres,topo_id,mesh_id&
- &, ghostsize,info)
-#endif
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl);DO j=1,ndata(2,isubl);DO i=1,ndata(1,isubl)
- IF(ABS(phi(i,j,k,isub)).GT.6.0_mk*dx(1)) CYCLE
-#if __MODE == __SCA
- psi(i,j,k,isub) = tpsi(i,j,k,isub)
-#elif __MODE == __VEC
- psi(1:lda,i,j,k,isub) = tpsi(1:lda,i,j,k,isub)
-#endif
- END DO; END DO; END DO
- END DO
-#ifdef __MPI
- CALL MPI_Allreduce(lres,gres,1,MPTYPE,MPI_MAX,ppm_comm,info)
-#else
- gres = lres
-#endif
- !-----------------------------------------------------
- ! maybe put a if(debug)then
- !-----------------------------------------------------
- WRITE(cbuf,'(A,I4,A,E12.5)') 'Iteration ',istep,' Residual: ',gres
- IF (ppm_rank.EQ.0) CALL ppm_write(ppm_rank,'ppm_hamjac_ext_3d',cbuf,info)
- IF(gres.LT.tol) GOTO 666
- END DO
- info = ppm_error_warning
- CALL ppm_error(ppm_err_converge,'ppm_hamjac_ext_3d', &
- & 'failed to reach target residual',__LINE__,info)
-666 CONTINUE
- iopt = ppm_param_dealloc
- CALL ppm_alloc(tpsi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_hamjac_ext_3d', &
- & 'temp storage for donowatocalit not freed',__LINE__,info)
- GOTO 9999
- END IF
-9999 CONTINUE
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_ext_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_ext_3dd
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_ext_3dsv
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_ext_3ddv
-#endif
-#endif
diff --git a/src/ppm_hamjac_ext_step_3d.f b/src/ppm_hamjac_ext_step_3d.f
deleted file mode 100644
index 8da44b787a5623a6b83bddfad19f20fa1d9cf7a2..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_ext_step_3d.f
+++ /dev/null
@@ -1,217 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_ext_step_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Extension
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_ext_step_3d.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:55 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2006/03/27 08:17:33 michaebe
- ! bug fix
- !
- ! Revision 1.2 2005/08/12 14:38:00 ivos
- ! bugfix: index bounds in loop corrected.
- !
- ! Revision 1.1 2005/07/25 00:34:01 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_ext_step_3ds (phi, psi, tpsi, res, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_ext_step_3dd (phi, psi, tpsi, res, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_ext_step_3dsv (phi, psi, lda, tpsi, res, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_ext_step_3ddv (phi, psi, lda, tpsi, res, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#endif
- USE ppm_module_data
-
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_error
- USE ppm_module_alloc
- USE ppm_module_typedef
- IMPLICIT NONE
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
-#if __MODE == __SCA
- REAL(mk), DIMENSION(:,:,:,: ), POINTER :: psi, tpsi
-#elif __MODE == __VEC
- REAL(mk), DIMENSION(:,:,:,:,:), POINTER :: psi, tpsi
- INTEGER, INTENT(in) :: lda
-#endif
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- REAL(mk),INTENT(out) :: res
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k
- REAL(mk) :: len_phys(3)
- !-----------------------------------------------------
- ! WENO stuff
- !-----------------------------------------------------
- REAL(mk) :: oneg(3), opos(3), wenoeps, wenotau, pbs, n(3)
- REAL(mk) :: laps(-1:1,3), rpos(3), rneg(3), dx(3), dxi(3)
- REAL(mk) :: phip(3), phin(3), phimid(3), rms, sij
-#if __MODE == __SCA
- REAL(MK) :: dphi_dt
-#elif __MODE == __VEC
- REAL(mk) :: dphi_dt(10)
-#endif
- INTEGER :: ilap
- INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
- & = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
- REAL(mk) :: t0, dxavg
- dphi_dt = 0.0_mk
- CALL substart('ppm_hamjac_ext_step_3d',t0,info)
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
- len_phys(1) = max_phys(1) - min_phys(1)
- len_phys(2) = max_phys(2) - min_phys(2)
- len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(mesh%nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%nm(3)-1,mk)
- dxavg = SUM(dx(1:3))/3.0_mk
- dxi(1) = 1.0_mk/dx(1)
- dxi(2) = 1.0_mk/dx(2)
- dxi(3) = 1.0_mk/dx(3)
- wenoeps = 1.0e-6_mk
- wenotau = 0.5_mk*MINVAL(dx)
- rms = -HUGE(rms)
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl)
- DO j=1,ndata(2,isubl)
- DO i=1,ndata(1,isubl)
- IF(ABS(phi(i,j,k,isub)).GT.7.0_mk*dx(1)) CYCLE
- ! TODO replace the hardcoded 7 by an argument
- IF(ABS(phi(i,j,k,isub)).LT.dx(1)) THEN
-#if __MODE == __SCA
- tpsi(i,j,k,isub) = psi(i,j,k,isub)
-#elif __MODE == __VEC
- tpsi(1:lda,i,j,k,isub) = psi(1:lda,i,j,k,isub)
-#endif
- ELSE
- phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
- phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
- phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
- sij = phi(i,j,k,isub) &
- & /SQRT(phi(i,j,k,isub)**2+dxavg**2)
- n = phimid / SQRT(SUM(phimid**2))
-#if __MODE == __SCA
- dphi_dt = &
- & MAX(n(1)*sij,0.0_mk)*dxi(1)* &
- & (psi(i,j,k,isub)-psi(i-1,j,k,isub)) + &
- & MIN(n(1)*sij,0.0_mk)*dxi(1)* &
- & (psi(i+1,j,k,isub)-psi(i,j,k,isub)) + &
- & MAX(n(2)*sij,0.0_mk)*dxi(2)* &
- & (psi(i,j,k,isub)-psi(i,j-1,k,isub)) + &
- & MIN(n(2)*sij,0.0_mk)*dxi(2)* &
- & (psi(i,j+1,k,isub)-psi(i,j,k,isub)) + &
- & MAX(n(3)*sij,0.0_mk)*dxi(3)* &
- & (psi(i,j,k,isub)-psi(i,j,k-1,isub)) + &
- & MIN(n(3)*sij,0.0_mk)*dxi(3)* &
- & (psi(i,j,k+1,isub)-psi(i,j,k,isub))
- tpsi(i,j,k,isub) = psi(i,j,k,isub) - wenotau * dphi_dt
- rms = MAX(rms,ABS(dphi_dt))
-#elif __MODE == __VEC
- dphi_dt(1:lda) = &
- & MAX(n(1)*sij,0.0_mk)*dxi(1)* &
- & (psi(1:lda,i,j,k,isub)-psi(1:lda,i-1,j,k,isub)) + &
- & MIN(n(1)*sij,0.0_mk)*dxi(1)* &
- & (psi(1:lda,i+1,j,k,isub)-psi(1:lda,i,j,k,isub)) + &
- & MAX(n(2)*sij,0.0_mk)*dxi(2)* &
- & (psi(1:lda,i,j,k,isub)-psi(1:lda,i,j-1,k,isub)) + &
- & MIN(n(2)*sij,0.0_mk)*dxi(2)* &
- & (psi(1:lda,i,j+1,k,isub)-psi(1:lda,i,j,k,isub)) + &
- & MAX(n(3)*sij,0.0_mk)*dxi(3)* &
- & (psi(1:lda,i,j,k,isub)-psi(1:lda,i,j,k-1,isub)) + &
- & MIN(n(3)*sij,0.0_mk)*dxi(3)* &
- & (psi(1:lda,i,j,k+1,isub)-psi(1:lda,i,j,k,isub))
- tpsi(1:lda,i,j,k,isub) = psi(1:lda,i,j,k,isub) &
- & - wenotau * dphi_dt(1:lda)
- rms = MAX(rms,SUM(ABS(dphi_dt)))
-#endif
- ENDIF
- END DO
- END DO
- END DO
- END DO
- res = rms
- CALL substop('ppm_hamjac_ext_step_3d',t0,info)
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_ext_step_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_ext_step_3dd
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_ext_step_3dsv
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_ext_step_3ddv
-#endif
-#endif
diff --git a/src/ppm_hamjac_reinit_2d.f b/src/ppm_hamjac_reinit_2d.f
deleted file mode 100644
index 29ede9cfb9c2e305af23d3630842df3c3992703e..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_2d.f
+++ /dev/null
@@ -1,193 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_2d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_2d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.1 2005/07/25 00:34:02 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_2ds (phi, trgt, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_2dd (phi, trgt, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#error VECTOR NOT IMPLEMENTED
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_alloc
- USE ppm_module_substop
- USE ppm_module_map
- USE ppm_module_map_field_ghost
- USE ppm_module_typedef
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
- REAL(MK), DIMENSION(:,:,: ), POINTER :: phi
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(2), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- INTEGER, INTENT(in) :: maxstep
- REAL(mk), INTENT(in) :: tol, trgt
-
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- REAL(mk), DIMENSION(:,:,: ), POINTER :: tphi
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid,meshid
- REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k,maptype,istep,iopt
- INTEGER :: ldl(3), ldu(3), ndata_max(2)
- REAL(mk) :: len_phys(2)
- REAL(mk) :: t0, res
- CHARACTER(len=256) :: msg
-
- CALL substart('ppm_hamjac_reinit_2d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- !-----------------------------------------------------
- ! RATIONALE Thu May 26 20:51:19 PDT 2005:
- ! loop ghostmap doit. easy.
- !-----------------------------------------------------
-
-
- !-----------------------------------------------------
- ! allocate temporary storage
- !-----------------------------------------------------
- ldl(1:2) = 1 - ghostsize(1:2); ldl(3) = 1
- ndata_max(1) = MAXVAL(ndata(1,1:nsublist))
- ndata_max(2) = MAXVAL(ndata(2,1:nsublist))
- ldu(1) = ndata_max(1) + ghostsize(1)
- ldu(2) = ndata_max(2) + ghostsize(2)
- ldu(3) = nsublist
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_hamjac_reinit_2d', &
- & 'temp storage for hamjac',__LINE__,info)
- GOTO 9999
- END IF
-
-
- !--- COMMENT Thu May 26 21:05:23 PDT 2005: simple euler here, do TVD
- DO istep=1,maxstep
- !--- map the gowas
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
-
- CALL ppm_hamjac_reinit_step(phi,tphi,trgt,res,topo_id,mesh_id&
- &, ghostsize,info)
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO j=1,ndata(2,isubl);DO i=1,ndata(1,isubl)
- phi(i,j,isub) = tphi(i,j,isub)
- END DO; END DO
- END DO
- WRITE(msg,*) 'iteration #',istep,' res=',res
- IF(MOD(istep,10).EQ.0) CALL ppm_write(ppm_Rank,'ppm_hamjac',msg,info)
-
- IF(res.LT.tol) GOTO 666
- END DO
-
- info = ppm_error_warning
- CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_2d', &
- & 'failed to reach target residual',__LINE__,info)
-
-666 CONTINUE
-
- iopt = ppm_param_dealloc
- CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_hamjac_reinit_2d', &
- & 'temp storage for hamjac not freed',__LINE__,info)
- GOTO 9999
- END IF
-
-
-9999 CONTINUE
- CALL substop('ppm_hamjac_reinit_2d',t0,info)
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_2dd
-#endif
-
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_3d.f b/src/ppm_hamjac_reinit_3d.f
deleted file mode 100644
index cc7c3a1317961a975433aee1ef22b499d88d53d8..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_3d.f
+++ /dev/null
@@ -1,238 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_3d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.2 2005/08/25 16:48:50 ivos
- ! Fixed format string. pgf90 barked.
- !
- ! Revision 1.1 2005/07/25 00:34:02 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_3ds (phi, trgt, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_3dd (phi, trgt, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_3dsV (phi, lda, idx, trgt, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_3ddV (phi, lda, idx, trgt, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_alloc
- USE ppm_module_substop
- USE ppm_module_map
- USE ppm_module_typedef
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
-#if __MODE == __SCA
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
-#elif __MODE == __VEC
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: phi
- INTEGER, INTENT(in) :: idx, lda
-#endif
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- INTEGER, INTENT(in) :: maxstep
- REAL(mk), INTENT(in) :: tol, trgt
-
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- REAL(mk), DIMENSION(:,:,:,:), POINTER :: tphi
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid,meshid
- REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k
- INTEGER :: maptype,istep,iopt
- INTEGER :: ldl(4), ldu(4), ndata_max(3)
- REAL(mk) :: len_phys(3)
- REAL(mk) :: t0, res
- CHARACTER(LEN=ppm_char) :: cbuf
-
- CALL substart('ppm_hamjac_reinit_3d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- !-----------------------------------------------------
- ! RATIONALE Thu May 26 20:51:19 PDT 2005:
- ! loop ghostmap doit. easy.
- !-----------------------------------------------------
-
- !-----------------------------------------------------
- ! allocate temporary storage
- !-----------------------------------------------------
- ldl(1:3) = 1 - ghostsize(1:3); ldl(4) = 1
- ndata_max(1) = MAXVAL(ndata(1,1:nsublist))
- ndata_max(2) = MAXVAL(ndata(2,1:nsublist))
- ndata_max(3) = MAXVAL(ndata(3,1:nsublist))
- ldu(1) = ndata_max(1) + ghostsize(1)
- ldu(2) = ndata_max(2) + ghostsize(2)
- ldu(3) = ndata_max(3) + ghostsize(3)
- ldu(4) = nsublist
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_hamjac_reinit_3d', &
- & 'temp storage for hamjac',__LINE__,info)
- GOTO 9999
- END IF
-
-
- !-----------------------------------------------------
- ! COMMENT Thu May 26 21:05:23 PDT 2005: simple euler here, DO TVD
- !-----------------------------------------------------
- DO istep=1,maxstep
- !--- map the gowas
-#if __MODE == __SCA
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
- CALL ppm_hamjac_reinit_step(phi,tphi,trgt,res,topo_id,mesh_id&
- &, ghostsize,info)
-#elif __MODE == __VEC
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,lda,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,lda,ghostsize, info)
- CALL ppm_hamjac_reinit_step(phi,idx,tphi,trgt,res,topo_id,mesh_id,&
- & ghostsize,info)
-#endif
- !-----------------------------------------------------
- ! maybe put a if(debug)then
- !-----------------------------------------------------
- IF(ppm_debug.GT.0) THEN
- WRITE(cbuf,'(A,I4,A,E12.5)') 'Iteration ',istep,' Residual: ',res
- CALL ppm_write(ppm_rank,'ppm_hamjac_reinit_3d',cbuf,info)
- END IF
- !-----------------------------------------------------
- ! copy the data back
- !-----------------------------------------------------
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl);DO j=1,ndata(2,isubl);DO i=1,ndata(1,isubl)
-#if __MODE == __SCA
- phi(i,j,k,isub) = tphi(i,j,k,isub)
-#elif __MODE == __VEC
- phi(idx,i,j,k,isub) = tphi(i,j,k,isub)
-#endif
- END DO; END DO; END DO
- END DO
- IF(res.LT.tol) GOTO 666
- END DO
-
- info = ppm_error_warning
- CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_3d', &
- & 'failed to reach target residual',__LINE__,info)
- info = ppm_param_success
-
-666 CONTINUE
-
- iopt = ppm_param_dealloc
- CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_hamjac_reinit_3d', &
- & 'temp storage for hamjac not freed',__LINE__,info)
- GOTO 9999
- END IF
-
-
-9999 CONTINUE
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_3dd
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_3dsV
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_3ddV
-#endif
-#endif
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_loc_3d.f b/src/ppm_hamjac_reinit_loc_3d.f
deleted file mode 100644
index f7cecd87c4d5511ff808b9a11aa12ae8f212f6b4..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_loc_3d.f
+++ /dev/null
@@ -1,240 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_loc_3d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.2 2005/08/25 16:48:50 ivos
- ! Fixed format string. pgf90 barked.
- !
- ! Revision 1.1 2005/07/25 00:34:02 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_loc_3ds (phi, iloc, np, trgt, tol, maxstep,&
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_loc_3dd (phi, iloc, np, trgt, tol, maxstep,&
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_loc_3dsV(phi, lda, iloc, np, idx, trgt,tol,&
- & maxstep,topo_id, mesh_id, ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_loc_3ddV(phi, lda, iloc, np, idx, trgt,tol,&
- & maxstep,topo_id, mesh_id, ghostsize,info)
-#endif
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_alloc
- USE ppm_module_substop
- USE ppm_module_map
- USE ppm_module_typedef
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
-#if __MODE == __SCA
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
-#elif __MODE == __VEC
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: phi
- INTEGER, INTENT(in) :: idx, lda
-#endif
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- INTEGER, INTENT(in) :: maxstep
- REAL(mk), INTENT(in) :: tol, trgt
-
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- INTEGER, DIMENSION(:,:), INTENT(in) :: iloc
- INTEGER :: np, p
- REAL(mk), DIMENSION(:,:,:,:), POINTER :: tphi
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid,meshid
- REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k
- INTEGER :: maptype,istep,iopt
- INTEGER :: ldl(4),ldu(4),ndata_max(3)
- REAL(mk) :: len_phys(3)
- REAL(mk) :: t0, res
- CHARACTER(LEN=ppm_char) :: cbuf
-
- CALL substart('ppm_hamjac_reinit_loc_3d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- !-----------------------------------------------------
- ! RATIONALE Thu May 26 20:51:19 PDT 2005:
- ! loop ghostmap doit. easy.
- !-----------------------------------------------------
-
- !-----------------------------------------------------
- ! allocate temporary storage
- !-----------------------------------------------------
- ldl(1:3) = 1 - ghostsize(1:3); ldl(4) = 1
- ndata_max(1) = MAXVAL(ndata(1,1:nsublist))
- ndata_max(2) = MAXVAL(ndata(2,1:nsublist))
- ndata_max(3) = MAXVAL(ndata(3,1:nsublist))
- ldu(1) = ndata_max(1) + ghostsize(1)
- ldu(2) = ndata_max(2) + ghostsize(2)
- ldu(3) = ndata_max(3) + ghostsize(3)
- ldu(4) = nsublist
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_hamjac_reinit_loc_3d', &
- & 'temp storage for hamjac',__LINE__,info)
- GOTO 9999
- END IF
-
-
- !-----------------------------------------------------
- ! COMMENT Thu May 26 21:05:23 PDT 2005: simple euler here, DO TVD
- !-----------------------------------------------------
- DO istep=1,maxstep
- !--- map the gowas
-#if __MODE == __SCA
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
- CALL ppm_hamjac_reinit_loc_step(phi,tphi,iloc,np,trgt,res,topo_id,&
- & mesh_id,ghostsize,info)
-#elif __MODE == __VEC
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,lda,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,lda,ghostsize,info)
- CALL ppm_hamjac_reinit_loc_step(phi,idx,tphi,iloc,np,trgt,res,topo_id,&
- & mesh_id,ghostsize,info)
-#endif
- !-----------------------------------------------------
- ! maybe put a if(debug)then
- !-----------------------------------------------------
- WRITE(cbuf,'(A,I4,A,E12.5)') 'Iteration ',istep,' Residual: ',res
- CALL ppm_write(ppm_rank,'ppm_hamjac_reinit_loc_3d',cbuf,info)
-
- !-----------------------------------------------------
- ! copy the data back
- !-----------------------------------------------------
- DO p=1,np
- isub = iloc(4,p)
- i = iloc(1,p)
- j = iloc(2,p)
- k = iloc(3,p)
-#if __MODE == __SCA
- phi(i,j,k,isub) = tphi(i,j,k,isub)
-#elif __MODE == __VEC
- phi(idx,i,j,k,isub) = tphi(i,j,k,isub)
-#endif
- END DO
- IF(res.LT.tol) GOTO 666
- END DO
-
- info = ppm_error_warning
- CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_loc_3d', &
- & 'failed to reach target residual',__LINE__,info)
- info = ppm_param_success
-
-666 CONTINUE
-
- iopt = ppm_param_dealloc
- CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_hamjac_reinit_loc_3d', &
- & 'temp storage for hamjac not freed',__LINE__,info)
- GOTO 9999
- END IF
-
-
-9999 CONTINUE
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_loc_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_loc_3dd
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_loc_3dsV
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_loc_3ddV
-#endif
-#endif
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_loc_step_3d.f b/src/ppm_hamjac_reinit_loc_step_3d.f
deleted file mode 100644
index 9dc4c7ae24807a786296d0d66ee9f1d4ef695b22..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_loc_step_3d.f
+++ /dev/null
@@ -1,371 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_step_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_loc_step_3d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.2 2005/08/12 14:38:01 ivos
- ! bugfix: index bounds in loop corrected.
- !
- ! Revision 1.1 2005/07/25 00:34:05 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_loc_step_3ds(phi,tphi,iloc,np,trgt,res, &
- & topo_id,mesh_id,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_loc_step_3dd(phi,tphi,iloc,np,trgt,res, &
- & topo_id,mesh_id,ghostsize,info)
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_loc_step_3dsV(phi,idx,tphi,iloc,np,trgt,&
- & res,topo_id,mesh_id,ghostsize,info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_loc_step_3ddV(phi,idx,tphi,iloc,np,trgt,&
- & res,topo_id,mesh_id,ghostsize,info)
-#endif
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
-#if __MODE == __SCA
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
-#elif __MODE == __VEC
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: phi
-#endif
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: tphi
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- REAL(mk), INTENT(out) :: res
-#if __MODE == __VEC
- INTEGER, INTENT(in) :: idx
-#endif
- REAL(mk), INTENT(in) :: trgt
- INTEGER, DIMENSION(:,:), INTENT(in) :: iloc
- INTEGER :: np, p
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid, meshid
- REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k
- REAL(MK) :: len_phys(3)
- !-----------------------------------------------------
- ! WENO stuff
- !-----------------------------------------------------
- REAL(mk) :: oneg(3), opos(3), wenoeps, wenotau, pbs
- REAL(mk) :: laps(-1:1,3), rpos(3), rneg(3), dx(3), dxi(3)
- REAL(mk) :: phip(3), phin(3), phimid(3), rms, dphi_dt
- INTEGER :: ilap
- INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
- & = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
- REAL(mk) :: t0
-
-
- CALL substart('ppm_hamjac_reinit_loc_step_3d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- len_phys(1) = max_phys(1) - min_phys(1)
- len_phys(2) = max_phys(2) - min_phys(2)
- len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
- dxi(1) = 1.0_mk/dx(1)
- dxi(2) = 1.0_mk/dx(2)
- dxi(3) = 1.0_mk/dx(3)
- wenoeps = 1.0e-6_mk
- wenotau = 0.25_mk*MINVAL(dx)
-
- rms = -HUGE(rms)
-
- DO p=1,np
- isub = iloc(4,p)
- i = iloc(1,p)
- j = iloc(2,p)
- k = iloc(3,p)
- ! hack
-#if __MODE == __SCA
-! IF(phi(i+1,j,k,isub).EQ.phi(i-1,j,k,isub).AND. &
-! & phi(i,j+1,k,isub).EQ.phi(i,j-1,k,isub).AND. &
-! & phi(i,j,k+1,isub).EQ.phi(i,j,k-1,isub).AND.ABS(phi(i&
-! &,j,k,isub)).LT.14.0_mk*dx(1)) CYCLE
-#endif
-#if __MODE == __SCA
- phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
- phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
- phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
-#else
- phimid(1) = phi(idx,i+1,j,k,isub)-phi(idx,i-1,j,k,isub)
- phimid(2) = phi(idx,i,j+1,k,isub)-phi(idx,i,j-1,k,isub)
- phimid(3) = phi(idx,i,j,k+1,isub)-phi(idx,i,j,k-1,isub)
-#endif
-
-#if __MODE == __SCA
- laps(2-3,1) = phi(i+offs(1,3),j,k,isub) &
- & -2.0_mk * phi(i+offs(2,3),j,k,isub) &
- & + phi(i+offs(3,3),j,k,isub)
- laps(2-3,2) = phi(i,j+offs(1,3),k,isub) &
- & -2.0_mk * phi(i,j+offs(2,3),k,isub) &
- & + phi(i,j+offs(3,3),k,isub)
- laps(2-3,3) = phi(i,j,k+offs(1,3),isub) &
- & -2.0_mk * phi(i,j,k+offs(2,3),isub) &
- & + phi(i,j,k+offs(3,3),isub)
- laps(2-2,1) = phi(i+offs(1,2),j,k,isub) &
- & -2.0_mk * phi(i+offs(2,2),j,k,isub) &
- & + phi(i+offs(3,2),j,k,isub)
- laps(2-2,2) = phi(i,j+offs(1,2),k,isub) &
- & -2.0_mk * phi(i,j+offs(2,2),k,isub) &
- & + phi(i,j+offs(3,2),k,isub)
- laps(2-2,3) = phi(i,j,k+offs(1,2),isub) &
- & -2.0_mk * phi(i,j,k+offs(2,2),isub) &
- & + phi(i,j,k+offs(3,2),isub)
- laps(2-1,1) = phi(i+offs(1,1),j,k,isub) &
- & -2.0_mk * phi(i+offs(2,1),j,k,isub) &
- & + phi(i+offs(3,1),j,k,isub)
- laps(2-1,2) = phi(i,j+offs(1,1),k,isub) &
- & -2.0_mk * phi(i,j+offs(2,1),k,isub) &
- & + phi(i,j+offs(3,1),k,isub)
- laps(2-1,3) = phi(i,j,k+offs(1,1),isub) &
- & -2.0_mk * phi(i,j,k+offs(2,1),isub) &
- & + phi(i,j,k+offs(3,1),isub)
-#elif __MODE == __VEC
- DO ilap=1,3
- laps(2-ilap,1) = phi(idx,i+offs(1,ilap),j,k,isub) &
- & -2.0_mk * phi(idx,i+offs(2,ilap),j,k,isub) &
- & + phi(idx,i+offs(3,ilap),j,k,isub)
- laps(2-ilap,2) = phi(idx,i,j+offs(1,ilap),k,isub) &
- & -2.0_mk * phi(idx,i,j+offs(2,ilap),k,isub) &
- & + phi(idx,i,j+offs(3,ilap),k,isub)
- laps(2-ilap,3) = phi(idx,i,j,k+offs(1,ilap),isub) &
- & -2.0_mk * phi(idx,i,j,k+offs(2,ilap),isub) &
- & + phi(idx,i,j,k+offs(3,ilap),isub)
- END DO
-#endif
-
- rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
- rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
- rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
- rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
- rpos(3) = (wenoeps + laps( 1,3)**2)/(wenoeps + laps(0,3)**2)
- rneg(3) = (wenoeps + laps(-1,3)**2)/(wenoeps + laps(0,3)**2)
-
- opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
- opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
- opos(3) = 1.0_mk/(1.0_mk+2.0_mk*rpos(3)**2)
- oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
- oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
- oneg(3) = 1.0_mk/(1.0_mk+2.0_mk*rneg(3)**2)
-
-#if __MODE == __SCA
- phip(1) = 0.5_mk*(phimid(1) - &
- & opos(1)*( &
- & phi(i+2,j,k,isub) - &
- & 3.0_mk*(phi(i+1,j,k,isub) - phi(i ,j,k,isub)) - &
- & phi(i-1,j,k,isub)))*dxi(1)
- phip(2) = 0.5_mk*(phimid(2) - &
- & opos(2)*( &
- & phi(i,j+2,k,isub) - &
- & 3.0_mk*(phi(i,j+1,k,isub) - phi(i ,j,k,isub)) - &
- & phi(i,j-1,k,isub)))*dxi(2)
- phip(3) = 0.5_mk*(phimid(3) - &
- & opos(3)*( &
- & phi(i,j,k+2,isub) - &
- & 3.0_mk*(phi(i,j,k+1,isub) - phi(i ,j,k,isub)) - &
- & phi(i,j,k-1,isub)))*dxi(3)
- phin(1) = 0.5_mk*(phimid(1) - &
- & oneg(1)*( &
- & phi(i+1,j,k,isub) - &
- & 3.0_mk*(phi(i ,j,k,isub) - phi(i-1,j,k,isub)) - &
- & phi(i-2,j,k,isub)))*dxi(1)
- phin(2) = 0.5_mk*(phimid(2) - &
- & oneg(2)*( &
- & phi(i,j+1,k,isub) - &
- & 3.0_mk*(phi(i,j ,k,isub) - phi(i,j-1,k,isub)) - &
- & phi(i,j-2,k,isub)))*dxi(2)
- phin(3) = 0.5_mk*(phimid(3) - &
- & oneg(3)*( &
- & phi(i,j,k+1,isub) - &
- & 3.0_mk*(phi(i,j,k ,isub) - phi(i,j,k-1,isub)) - &
- & phi(i,j,k-2,isub)))*dxi(3)
-#else
- phip(1) = 0.5_mk*(phimid(1) - &
- & opos(1)*( &
- & phi(idx,i+2,j,k,isub) - &
- & 3.0_mk*(phi(idx,i+1,j,k,isub)-phi(idx,i,j,k,isub))-&
- & phi(idx,i-1,j,k,isub)))*dxi(1)
- phip(2) = 0.5_mk*(phimid(2) - &
- & opos(2)*( &
- & phi(idx,i,j+2,k,isub) - &
- & 3.0_mk*(phi(idx,i,j+1,k,isub)-phi(idx,i,j,k,isub))-&
- & phi(idx,i,j-1,k,isub)))*dxi(2)
- phip(3) = 0.5_mk*(phimid(3) - &
- & opos(3)*( &
- & phi(idx,i,j,k+2,isub) - &
- & 3.0_mk*(phi(idx,i,j,k+1,isub)-phi(idx,i,j,k,isub))-&
- & phi(idx,i,j,k-1,isub)))*dxi(3)
- phin(1) = 0.5_mk*(phimid(1) - &
- & oneg(1)*( &
- & phi(idx,i+1,j,k,isub) - &
- & 3.0_mk*(phi(idx,i ,j,k,isub)-phi(idx,i-1,j,k,isub))-&
- & phi(idx,i-2,j,k,isub)))*dxi(1)
- phin(2) = 0.5_mk*(phimid(2) - &
- & oneg(2)*( &
- & phi(idx,i,j+1,k,isub) - &
- & 3.0_mk*(phi(idx,i,j ,k,isub)-phi(idx,i,j-1,k,isub))-&
- & phi(idx,i,j-2,k,isub)))*dxi(2)
- phin(3) = 0.5_mk*(phimid(3) - &
- & oneg(3)*( &
- & phi(idx,i,j,k+1,isub) - &
- & 3.0_mk*(phi(idx,i,j,k ,isub)-phi(idx,i,j,k-1,isub))-&
- & phi(idx,i,j,k-2,isub)))*dxi(3)
-#endif
-
-#if __MODE == __SCA
- !--- collect
- IF(phi(i,j,k,isub).GT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))**2+&
- & MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))**2+&
- & MAX(-MIN(phip(3),0.0_mk),MAX(phin(3),0.0_mk))**2)&
- & - trgt
- ELSEIF(phi(i,j,k,isub).LT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(MAX(phip(1),0.0_mk),-MIN(phin(1),0.0_mk))**2+&
- & MAX(MAX(phip(2),0.0_mk),-MIN(phin(2),0.0_mk))**2+&
- & MAX(MAX(phip(3),0.0_mk),-MIN(phin(3),0.0_mk))**2)&
- & - trgt
- ELSE
- pbs = 0.0_mk
- END IF
- dphi_dt = pbs * phi(i,j,k,isub) / &
- & SQRT(phi(i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
- tphi(i,j,k,isub) = phi(i,j,k,isub) - wenotau * dphi_dt
-
-#else
- !--- collect
- IF(phi(idx,i,j,k,isub).GT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))**2+&
- & MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))**2+&
- & MAX(-MIN(phip(3),0.0_mk),MAX(phin(3),0.0_mk))**2)&
- & - trgt
- ELSEIF(phi(idx,i,j,k,isub).LT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(MAX(phip(1),0.0_mk),-MIN(phin(1),0.0_mk))**2+&
- & MAX(MAX(phip(2),0.0_mk),-MIN(phin(2),0.0_mk))**2+&
- & MAX(MAX(phip(3),0.0_mk),-MIN(phin(3),0.0_mk))**2)&
- & - trgt
- ELSE
- pbs = 0.0_mk
- END IF
- dphi_dt = pbs * phi(idx,i,j,k,isub) / &
- & SQRT(phi(idx,i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
- tphi(i,j,k,isub) = phi(idx,i,j,k,isub) - wenotau * dphi_dt
-
-#endif
-
- rms = MAX(rms,ABS(dphi_dt))
-
-
-
- END DO
-
- res = rms
-
- CALL substop('ppm_hamjac_reinit_loc_step_3d',t0,info)
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_loc_step_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_loc_step_3dd
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_loc_step_3dsV
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_loc_step_3ddV
-#endif
-#endif
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_ref_3d.f b/src/ppm_hamjac_reinit_ref_3d.f
deleted file mode 100644
index 3df3ba2162853741123135eb618584913cec4547..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_ref_3d.f
+++ /dev/null
@@ -1,208 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_ref_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit in ref spc
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_ref_3d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.1 2005/07/25 00:34:03 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_ref_3ds (phi, chi, trgt, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_ref_3dd (phi, chi, trgt, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#error VECTOR NOT IMPLEMENTED
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_alloc
- USE ppm_module_substop
- USE ppm_module_map
- USE ppm_module_typedef
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
- REAL(mk), DIMENSION(:,:,:,:,:), POINTER :: chi
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- INTEGER, INTENT(in) :: maxstep
- REAL(mk), INTENT(in) :: tol, trgt
-
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- REAL(mk), DIMENSION(:,:,:,:), POINTER :: tphi
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid,meshid
- REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k,maptype,istep,iopt
- INTEGER :: ldl(4), ldu(4), ndata_max(3)
- REAL(mk) :: len_phys(3)
- REAL(mk) :: t0, res
- CHARACTER(LEN=ppm_char) :: cbuf
-
- CALL substart('ppm_hamjac_reinit_ref_3d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
-
- !-----------------------------------------------------
- ! RATIONALE Thu May 26 20:51:19 PDT 2005:
- ! loop ghostmap doit. easy.
- !-----------------------------------------------------
-
-
- !-----------------------------------------------------
- ! allocate temporary storage
- !-----------------------------------------------------
- ldl(1:3) = 1 - ghostsize(1:3); ldl(4) = 1
- ndata_max(1) = MAXVAL(ndata(1,1:nsublist))
- ndata_max(2) = MAXVAL(ndata(2,1:nsublist))
- ndata_max(3) = MAXVAL(ndata(3,1:nsublist))
- ldu(1) = ndata_max(1) + ghostsize(1)
- ldu(2) = ndata_max(2) + ghostsize(2)
- ldu(3) = ndata_max(3) + ghostsize(3)
- ldu(4) = nsublist
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_hamjac_reinit_ref_3d', &
- & 'temp storage for hamjac',__LINE__,info)
- GOTO 9999
- END IF
-
- !--- map the map
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,chi,3,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,chi,3,ghostsize,info)
-
-
- !--- COMMENT Thu May 26 21:05:23 PDT 2005: simple euler here, do TVD
- DO istep=1,maxstep
- !--- map the gowas
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
-
- CALL ppm_hamjac_reinit_step_ref(phi,chi,tphi,trgt,res,topo_id, &
- & mesh_id,ghostsize,info)
-
- ! IF (ppm_debug .GT. 0) THEN
- !TODO Uncomment WRITE statement
- !WRITE(cbuf,'(A,I4,A,ES)') 'Iteration ',istep,' Residual: ', res
- CALL ppm_write(ppm_rank,'ppm_hamjac_reinit_ref_3d',cbuf,info)
- ! ENDIF
-
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl);DO j=1,ndata(2,isubl);DO i=1,ndata(1,isubl)
- phi(i,j,k,isub) = tphi(i,j,k,isub)
- END DO; END DO; END DO
- END DO
- IF(res.LT.tol) GOTO 666
- END DO
-
- info = ppm_error_warning
- CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_ref_3d', &
- & 'failed to reach target residual',__LINE__,info)
- info = ppm_param_success
-
-666 CONTINUE
-
- iopt = ppm_param_dealloc
- CALL ppm_alloc(tphi,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_hamjac_reinit_ref_3d', &
- & 'temp storage for hamjac not freed',__LINE__,info)
- GOTO 9999
- END IF
-
-
-9999 CONTINUE
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_ref_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_ref_3dd
-#endif
-
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_russo_3d.f b/src/ppm_hamjac_reinit_russo_3d.f
deleted file mode 100644
index 9cedc76f2e6f31358d51cfdb2df8f85c6c25a1fe..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_russo_3d.f
+++ /dev/null
@@ -1,306 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_3d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.1 2005/07/25 00:34:02 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_russo_3ds (phi, phigrad, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info, indx)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_russo_3dd (phi, phigrad, tol, maxstep, &
- & topo_id, mesh_id, ghostsize, info, indx)
-#endif
-#elif __MODE == __VEC
-#error VECTOR NOT IMPLEMENTED
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_write
- USE ppm_module_substart
- USE ppm_module_alloc
- USE ppm_module_substop
- USE ppm_module_map
- USE ppm_module_map_field
- USE ppm_module_map_field_ghost
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
-#ifdef __MPI
- INCLUDE 'mpif.h'
-#endif
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
- REAL(MK), DIMENSION(:,:,:,: ), POINTER :: phi
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: phigrad
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- INTEGER, INTENT(in) :: maxstep
- REAL(mk), INTENT(in) :: tol
- INTEGER,INTENT(IN),OPTIONAL :: indx
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- REAL(mk), DIMENSION(:,:,:,: ), POINTER :: phi0,phirhs,phiprev
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid,meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
- INTEGER, DIMENSION(6) :: orgbcdef
- INTEGER :: s2didx, mpi_prec
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k,maptype,istep,iopt
- INTEGER :: ldl(4), ldu(4), ndata_max(3)
- REAL(mk) :: len_phys(3), dx(3)
- REAL(mk) :: t0, res, gres,tau
- CHARACTER(len=256) :: msg
-
- CALL substart('ppm_hamjac_reinit_russo_3d',t0,info)
-
- IF(PRESENT(indx)) THEN
- s2didx=indx
- ELSE
- s2didx= -1
- END IF
-
-#ifdef __MPI
- IF (ppm_kind.EQ.ppm_kind_single) THEN
- MPI_PREC = MPI_REAL
- ELSE
- MPI_PREC = MPI_DOUBLE_PRECISION
- ENDIF
-#endif
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- len_phys(1) = max_phys(1) - min_phys(1)
- len_phys(2) = max_phys(2) - min_phys(2)
- len_phys(3) = max_phys(3) - min_phys(3)
-
- dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
-
- ! timestep
- tau = 0.25_mk*MINVAL(dx)
-
- !-----------------------------------------------------
- ! allocate temporary storage
- !-----------------------------------------------------
- ldl(1:3) = 1 - ghostsize(1:3); ldl(4) = 1
- ndata_max(1) = MAXVAL(ndata(1,1:nsublist))
- ndata_max(2) = MAXVAL(ndata(2,1:nsublist))
- ndata_max(3) = MAXVAL(ndata(3,1:nsublist))
- ldu(1) = ndata_max(1) + ghostsize(1)
- ldu(2) = ndata_max(2) + ghostsize(2)
- ldu(3) = ndata_max(3) + ghostsize(3)
- ldu(4) = nsublist
- iopt = ppm_param_alloc_fit
- CALL ppm_alloc(phi0,ldl,ldu,iopt,info)
- CALL ppm_alloc(phirhs,ldl,ldu,iopt,info)
- CALL ppm_alloc(phiprev,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_fatal
- CALL ppm_error(ppm_err_alloc,'ppm_hamjac_reinit_russo_3d', &
- & 'temp storage for hamjac',__LINE__,info)
- GOTO 9999
- END IF
-
- ! fill phi0 with initial condition
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl)
- DO j=1,ndata(2,isubl)
- DO i=1,ndata(1,isubl)
- phi0(i,j,k,isub) = phi(i,j,k,isub)
- phiprev(i,j,k,isub) = phi(i,j,k,isub)
- phigrad(1:3,i,j,k,isub) = 0.0_mk
- END DO
- END DO
- END DO
- END DO
-
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi0,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi0,ghostsize,info)
-
- !-----------------------------------------------------
- ! start time integration loop: using TVD RK3
- !-----------------------------------------------------
-
- DO istep=1,maxstep
- !--- map the ghosts
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
-
- ! TVDRK3 substep A
-
- CALL ppm_hamjac_reinit_russo_step(phi,phi0,phirhs,phigrad,res,s2didx,topo_id,mesh_id&
- &, ghostsize,info)
-
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl); DO j=1,ndata(2,isubl);DO i=1,ndata(1,isubl)
- phi(i,j,k,isub) = phi(i,j,k,isub) + tau*phirhs(i,j,k,isub)
- END DO; END DO; END DO
- END DO
-
- !--- map the ghosts
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
-
- ! TVDRK3 substep B
-
- CALL ppm_hamjac_reinit_russo_step(phi,phi0,phirhs,phigrad,res,s2didx,topo_id,mesh_id&
- &, ghostsize,info)
-
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl); DO j=1,ndata(2,isubl);DO i=1,ndata(1,isubl)
- phi(i,j,k,isub) = phi(i,j,k,isub) + tau*phirhs(i,j,k,isub)
- phi(i,j,k,isub) = 0.25_mk*phiprev(i,j,k,isub) + 0.75_mk*phi(i,j,k,isub)
- END DO; END DO; END DO
- END DO
-
- !--- map the ghosts
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
-
- ! TVDRK3 substep C
-
- CALL ppm_hamjac_reinit_russo_step(phi,phi0,phirhs,phigrad,res,s2didx,topo_id,mesh_id&
- &, ghostsize,info)
-
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl); DO j=1,ndata(2,isubl);DO i=1,ndata(1,isubl)
- phi(i,j,k,isub) = phi(i,j,k,isub) + tau*phirhs(i,j,k,isub)
- phi(i,j,k,isub) = (2.0_mk*phiprev(i,j,k,isub) + phi(i,j,k,isub))/3.0_mk
- phiprev(i,j,k,isub) = phi(i,j,k,isub)
- END DO; END DO; END DO
- END DO
-#ifdef __MPI
- CALL MPI_AllReduce(res,gres,1,mpi_prec,MPI_MIN,0,ppm_comm,info)
- res = gres
-#endif
- IF(res.LT.tol) GOTO 666
-
- IF(ppm_rank.EQ.0.AND.MOD(istep,5).EQ.0) THEN
- WRITE(msg,*) 'iteration #',istep,' res=',res
- CALL ppm_write(ppm_Rank,'ppm_hamjac',msg,info)
- END IF
-
- !IF(res.LT.tol) GOTO 666 ! does not work in parallel with ghosting, because all
- ! processors need to be in loop for ghosting to work
- END DO
-
- !info = ppm_error_warning
- !CALL ppm_error(ppm_err_converge,'ppm_hamjac_reinit_russo_3d', &
- ! & 'failed to reach target residual',__LINE__,info)
-
-666 CONTINUE
- !--- map the ghosts for last time
- CALL ppm_map_field_ghost_get(topo_id,mesh_id,ghostsize,info)
- CALL ppm_map_field_push(topo_id,mesh_id,phi,info)
- CALL ppm_map_field_send(info)
- CALL ppm_map_field_pop(topo_id,mesh_id,phi,ghostsize,info)
-
- IF(ppm_rank.EQ.0) THEN
- WRITE(msg,*) 'ended after iteration #',istep,' res=',res
- CALL ppm_write(ppm_Rank,'ppm_hamjac',msg,info)
- END IF
-
- iopt = ppm_param_dealloc
- CALL ppm_alloc(phi0,ldl,ldu,iopt,info)
- CALL ppm_alloc(phirhs,ldl,ldu,iopt,info)
- CALL ppm_alloc(phiprev,ldl,ldu,iopt,info)
- IF(info.NE.0) THEN
- info = ppm_error_error
- CALL ppm_error(ppm_err_dealloc,'ppm_hamjac_reinit_russo_3d', &
- & 'temp storage for hamjac not freed',__LINE__,info)
- GOTO 9999
- END IF
-
-
-9999 CONTINUE
-
- CALL substop('ppm_hamjac_reinit_russo_3d',t0,info)
-
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_russo_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_russo_3dd
-#endif
-
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_russo_step_3d.f b/src/ppm_hamjac_reinit_russo_step_3d.f
deleted file mode 100644
index 212cf76221a7c54981cb327877c027169b17dd66..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_russo_step_3d.f
+++ /dev/null
@@ -1,362 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_step_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_step_3d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.1 2005/07/25 00:34:04 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_russo_step_3ds (phi, phi0, phirhs,phigrad,res, s2didx,&
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_russo_step_3dd (phi, phi0, phirhs,phigrad,res, s2didx,&
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#error VECTOR NOT IMPLEMENTED
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
-
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
- REAL(MK), DIMENSION(:,:,:,: ), POINTER :: phi, phi0,phirhs
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: phigrad
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- REAL(mk),INTENT(out) :: res
- INTEGER, INTENT(in) :: s2didx
-
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid, meshid
- REAL(mk), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k,kmin,kmax
- REAL(mk) :: len_phys(3)
- REAL(mk) :: delta_phis(3,3), delta(3), D
- !-----------------------------------------------------
- ! WENO stuff
- !-----------------------------------------------------
- REAL(mk) :: oneg(3), opos(3), closeeps, wenoeps, pbs
- REAL(mk) :: laps(-1:1,3), rpos(3), rneg(3), dx(3), dxi(3)
- REAL(mk) :: phip(3), phin(3), phimid(3), rms, dphi_dt
- INTEGER :: ilap
- INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
- & = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
- REAL(mk) :: t0
-
-
- CALL substart('ppm_hamjac_reinit_russo_step_3d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- len_phys(1) = max_phys(1) - min_phys(1)
- len_phys(2) = max_phys(2) - min_phys(2)
- len_phys(3) = max_phys(3) - min_phys(3)
-
- dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
- dxi(1) = 1.0_mk/dx(1)
- dxi(2) = 1.0_mk/dx(2)
- dxi(3) = 1.0_mk/dx(3)
-
- closeeps = 1.0e-6_mk
- wenoeps = 1.0e-6_mk
-
- rms = -HUGE(rms)
-
- !-----------------------------------------------------
- ! compute right hand side
- !-----------------------------------------------------
-
- DO isub=1,nsublist
- isubl = isublist(isub)
- IF(s2didx.LT.0) THEN
- kmin = 1 + ghostsize(3)
- kmax = ndata(3,isubl) - ghostsize(3)
- ELSE
- kmin = s2didx
- kmax = s2didx
- END IF
- DO k=kmin,kmax
- DO j=1,ndata(2,isubl)
- DO i=1,ndata(1,isubl)
-
- IF( phi0(i,j,k,isub)*phi0(i+1,j,k,isub).LT.0.0_mk.OR.&
- & phi0(i,j,k,isub)*phi0(i-1,j,k,isub).LT.0.0_mk.OR.&
- & phi0(i,j,k,isub)*phi0(i,j+1,k,isub).LT.0.0_mk.OR.&
- & phi0(i,j,k,isub)*phi0(i,j-1,k,isub).LT.0.0_mk.OR.&
- & phi0(i,j,k,isub)*phi0(i,j,k+1,isub).LT.0.0_mk.OR.&
- & phi0(i,j,k,isub)*phi0(i,j,k-1,isub).LT.0.0_mk) THEN
- ! near interface: apply russo smereka (2000) technique to
- ! prevent interface from moving
-
- delta_phis(1,1) = 0.5_mk*(phi0(i+1,j,k,isub)-phi0(i-1,j,k,isub))**2
- delta_phis(1,2) = 0.5_mk*(phi0(i,j+1,k,isub)-phi0(i,j-1,k,isub))**2
- delta_phis(1,3) = 0.5_mk*(phi0(i,j,k+1,isub)-phi0(i,j,k-1,isub))**2
-
- delta_phis(2,1) = (phi0(i+1,j,k,isub)-phi0(i,j,k,isub))**2
- delta_phis(2,2) = (phi0(i,j+1,k,isub)-phi0(i,j,k,isub))**2
- delta_phis(2,3) = (phi0(i,j,k+1,isub)-phi0(i,j,k,isub))**2
-
- delta_phis(3,1) = (phi0(i,j,k,isub)-phi0(i-1,j,k,isub))**2
- delta_phis(3,2) = (phi0(i,j,k,isub)-phi0(i,j-1,k,isub))**2
- delta_phis(3,3) = (phi0(i,j,k,isub)-phi0(i,j,k-1,isub))**2
-
- delta(1) = MAX(MAX(delta_phis(1,1),delta_phis(2,1)), &
- & MAX(delta_phis(3,1),closeeps))
- delta(2) = MAX(MAX(delta_phis(1,2),delta_phis(2,2)), &
- & MAX(delta_phis(3,2),closeeps))
- delta(3) = MAX(MAX(delta_phis(1,3),delta_phis(2,3)), &
- & MAX(delta_phis(3,3),closeeps))
-
- !here assume dx(1)==dx(2) need to do the dx(1)~=dx(2) case
- D = dx(1)*phi0(i,j,k,isub)/(SQRT(delta(1)+delta(2)+delta(3)))
-
- IF(phi0(i,j,k,isub).GT.0.0_mk) THEN
- phirhs(i,j,k,isub) = -dxi(1)*(ABS(phi(i,j,k,isub))-D)
-
- ELSE IF(phi0(i,j,k,isub).LT.0.0_mk) THEN
- phirhs(i,j,k,isub) = -dxi(1)*(-1.0_mk*ABS(phi(i,j,k,isub))-D)
- ELSE
- phirhs(i,j,k,isub) = 0.0_mk
- END IF
- ! gradient not yet correctly implemented
- phigrad(1,i,j,k,isub) = dxi(1)*D
- phigrad(2,i,j,k,isub) = dxi(2)*D
- phigrad(3,i,j,k,isub) = dxi(3)*D
-
- ELSE
- ! away from interface: normal flux calculation
-
- phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
- phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
- phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
-
- laps(-1,1) = phi(i+2,j,k,isub) &
- & -2.0_mk * phi(i+1,j,k,isub) &
- & + phi(i,j,k,isub)
- laps(-1,2) = phi(i,j+2,k,isub) &
- & -2.0_mk * phi(i,j+1,k,isub) &
- & + phi(i,j,k,isub)
- laps(-1,3) = phi(i,j,k+2,isub) &
- & -2.0_mk * phi(i,j,k+1,isub) &
- & + phi(i,j,k,isub)
-
- laps(0,1) = phi(i+1,j,k,isub) &
- & -2.0_mk * phi(i,j,k,isub) &
- & + phi(i-1,j,k,isub)
- laps(0,2) = phi(i,j+1,k,isub) &
- & -2.0_mk * phi(i,j,k,isub) &
- & + phi(i,j-1,k,isub)
- laps(0,3) = phi(i,j,k+1,isub) &
- & -2.0_mk * phi(i,j,k,isub) &
- & + phi(i,j,k-1,isub)
-
- laps(1,1) = phi(i,j,k,isub) &
- & -2.0_mk * phi(i-1,j,k,isub) &
- & + phi(i-2,j,k,isub)
- laps(1,2) = phi(i,j,k,isub) &
- & -2.0_mk * phi(i,j-1,k,isub) &
- & + phi(i,j-2,k,isub)
- laps(1,3) = phi(i,j,k,isub) &
- & -2.0_mk * phi(i,j,k-1,isub) &
- & + phi(i,j,k-2,isub)
-
-
- rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
- rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
- rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
- rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
- rpos(3) = (wenoeps + laps( 1,3)**2)/(wenoeps + laps(0,3)**2)
- rneg(3) = (wenoeps + laps(-1,3)**2)/(wenoeps + laps(0,3)**2)
-
- opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
- opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
- opos(3) = 1.0_mk/(1.0_mk+2.0_mk*rpos(3)**2)
- oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
- oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
- oneg(3) = 1.0_mk/(1.0_mk+2.0_mk*rneg(3)**2)
-
- phip(1) = 0.5_mk*(phimid(1) - &
- & opos(1)*( &
- & phi(i+2,j,k,isub) - &
- & 3.0_mk*(phi(i+1,j,k,isub) - phi(i ,j,k,isub)) - &
- & phi(i-1,j,k,isub)))*dxi(1)
- phip(2) = 0.5_mk*(phimid(2) - &
- & opos(2)*( &
- & phi(i,j+2,k,isub) - &
- & 3.0_mk*(phi(i,j+1,k,isub) - phi(i ,j,k,isub)) - &
- & phi(i,j-1,k,isub)))*dxi(2)
- phip(3) = 0.5_mk*(phimid(3) - &
- & opos(3)*( &
- & phi(i,j,k+2,isub) - &
- & 3.0_mk*(phi(i,j,k+1,isub) - phi(i ,j,k,isub)) - &
- & phi(i,j,k-1,isub)))*dxi(3)
- phin(1) = 0.5_mk*(phimid(1) - &
- & oneg(1)*( &
- & phi(i+1,j,k,isub) - &
- & 3.0_mk*(phi(i ,j,k,isub) - phi(i-1,j,k,isub)) - &
- & phi(i-2,j,k,isub)))*dxi(1)
- phin(2) = 0.5_mk*(phimid(2) - &
- & oneg(2)*( &
- & phi(i,j+1,k,isub) - &
- & 3.0_mk*(phi(i,j ,k,isub) - phi(i,j-1,k,isub)) - &
- & phi(i,j-2,k,isub)))*dxi(2)
- phin(3) = 0.5_mk*(phimid(3) - &
- & oneg(3)*( &
- & phi(i,j,k+1,isub) - &
- & 3.0_mk*(phi(i,j,k ,isub) - phi(i,j,k-1,isub)) - &
- & phi(i,j,k-2,isub)))*dxi(3)
-
- !--- collect
- IF(phi0(i,j,k,isub).GT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))**2+&
- & MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))**2+&
- & MAX(-MIN(phip(3),0.0_mk),MAX(phin(3),0.0_mk))**2)&
- & - 1.0_mk
-
- phirhs(i,j,k,isub) = -1.0_mk*pbs
-
-
- ELSE IF(phi0(i,j,k,isub).LT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(MAX(phip(1),0.0_mk),-MIN(phin(1),0.0_mk))**2+&
- & MAX(MAX(phip(2),0.0_mk),-MIN(phin(2),0.0_mk))**2+&
- & MAX(MAX(phip(3),0.0_mk),-MIN(phin(3),0.0_mk))**2)&
- & - 1.0_mk
-
- phirhs(i,j,k,isub) = +1.0_mk*pbs
-
- ELSE
- pbs = 0.0_mk
- phirhs(i,j,k,isub) = 0.0_mk
- END IF
- ! gradient not yet correctly implemented
- phigrad(1,i,j,k,isub) = MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))
- phigrad(2,i,j,k,isub) = MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))
- phigrad(3,i,j,k,isub) = MAX(-MIN(phip(3),0.0_mk),MAX(phin(3),0.0_mk))
-
-
- END IF
- ! simple euler for now
- !tphi(i,j,k,isub) = phi(i,j,k,isub) + reinit_tau * flux
-
- rms = MAX(rms,ABS(phirhs(i,j,k,isub)))
-
- END DO
-
- END DO
- END DO
-
- END DO
-
-
- IF(s2didx.GT.0) THEN
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl)
- DO j=1,ndata(2,isubl)
- DO i=1,ndata(1,isubl)
- phirhs(i,j,k,isub) = phirhs(i,j,s2didx,isub)
- phigrad(1,i,j,k,isub) = phigrad(1,i,j,s2didx,isub)
- phigrad(2,i,j,k,isub) = phigrad(2,i,j,s2didx,isub)
- phigrad(3,i,j,k,isub) = phigrad(3,i,j,s2didx,isub)
- END DO
- END DO
- END DO
- END DO
- END IF
- res = rms
-
- CALL substop('ppm_hamjac_reinit_russo_step_3d',t0,info)
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_russo_step_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_russo_step_3dd
-#endif
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_step_2d.f b/src/ppm_hamjac_reinit_step_2d.f
deleted file mode 100644
index 3edac699a5d64b88200a8375e790a20235c20931..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_step_2d.f
+++ /dev/null
@@ -1,248 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_step_2d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_step_2d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.1 2005/07/25 00:34:04 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_2ds (phi, tphi, trgt, res, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_2dd (phi, tphi, trgt, res, topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#error VECTOR NOT IMPLEMENTED
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
-
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
- REAL(MK), DIMENSION(:,:,: ), POINTER :: phi, tphi
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(2), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- REAL(mk),INTENT(out) :: res
- REAL(mk), INTENT(in) :: trgt
-
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid, meshid
- REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k
- REAL(MK) :: len_phys(2)
- !-----------------------------------------------------
- ! WENO stuff
- !-----------------------------------------------------
- REAL(mk) :: oneg(2), opos(2), wenoeps, wenotau, pbs
- REAL(mk) :: laps(-1:1,2), rpos(2), rneg(2), dx(2), dxi(2)
- REAL(mk) :: phip(2), phin(2), phimid(2), rms, dphi_dt
- INTEGER :: ilap
- INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
- & = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
- REAL(mk) :: t0
-
-
- CALL substart('ppm_hamjac_reinit_step_2d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- len_phys(1) = max_phys(1) - min_phys(1)
- len_phys(2) = max_phys(2) - min_phys(2)
- dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
- dxi(1) = 1.0_mk/dx(1)
- dxi(2) = 1.0_mk/dx(2)
- wenoeps = 1.0e-6_mk
- wenotau = 0.25_mk*MINVAL(dx)
-
- rms = -HUGE(rms)
-
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO j=1,ndata(2,isubl)
- DO i=1,ndata(1,isubl)
-
- !DO ilap=1,3
- ! laps(2-ilap,1) = phi(i+offs(1,ilap),j,isub) &
- ! & -2.0_mk * phi(i+offs(2,ilap),j,isub) &
- ! & + phi(i+offs(3,ilap),j,isub)
- ! laps(2-ilap,2) = phi(i,j+offs(1,ilap),isub) &
- ! & -2.0_mk * phi(i,j+offs(2,ilap),isub) &
- ! & + phi(i,j+offs(3,ilap),isub)
- !END DO
- laps(1,1) = phi(i+2,j,isub) &
- & -2.0_mk * phi(i+1,j,isub) &
- & + phi(i,j,isub)
- laps(1,2) = phi(i,j+2,isub) &
- & -2.0_mk * phi(i,j+1,isub) &
- & + phi(i,j,isub)
- laps(0,1) = phi(i+1,j,isub) &
- & -2.0_mk * phi(i,j,isub) &
- & + phi(i-1,j,isub)
- laps(0,2) = phi(i,j+1,isub) &
- & -2.0_mk * phi(i,j,isub) &
- & + phi(i,j-1,isub)
- laps(-1,1) = phi(i,j,isub) &
- & -2.0_mk * phi(i-1,j,isub) &
- & + phi(i-2,j,isub)
- laps(-1,2) = phi(i,j,isub) &
- & -2.0_mk * phi(i,j-1,isub) &
- & + phi(i,j-2,isub)
-
-
-
- rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
- rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
- rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
- rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
-
- opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
- opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
- oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
- oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
-
- phimid(1) = phi(i+1,j,isub)-phi(i-1,j,isub)
- phimid(2) = phi(i,j+1,isub)-phi(i,j-1,isub)
-
- phip(1) = 0.5_mk*(phimid(1) - &
- & opos(1)*( &
- & phi(i+2,j,isub) - &
- & 3.0_mk*(phi(i+1,j,isub) - phi(i ,j,isub)) - &
- & phi(i-1,j,isub)))*dxi(1)
- phip(2) = 0.5_mk*(phimid(2) - &
- & opos(2)*( &
- & phi(i,j+2,isub) - &
- & 3.0_mk*(phi(i,j+1,isub) - phi(i ,j,isub)) - &
- & phi(i,j-1,isub)))*dxi(2)
- phin(1) = 0.5_mk*(phimid(1) - &
- & oneg(1)*( &
- & phi(i+1,j,isub) - &
- & 3.0_mk*(phi(i ,j,isub) - phi(i-1,j,isub)) - &
- & phi(i-2,j,isub)))*dxi(1)
- phin(2) = 0.5_mk*(phimid(2) - &
- & oneg(2)*( &
- & phi(i,j+1,isub) - &
- & 3.0_mk*(phi(i,j ,isub) - phi(i,j-1,isub)) - &
- & phi(i,j-2,isub)))*dxi(2)
-
- !--- collect
- IF(phi(i,j,isub).GT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))**2+&
- & MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))**2)&
- & - trgt
- ELSEIF(phi(i,j,isub).LT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(MAX(phip(1),0.0_mk),-MIN(phin(1),0.0_mk))**2+&
- & MAX(MAX(phip(2),0.0_mk),-MIN(phin(2),0.0_mk))**2)&
- & - trgt
- ELSE
- pbs = 0.0_mk
- END IF
- dphi_dt = pbs * phi(i,j,isub) / &
- & SQRT(phi(i,j,isub)**2+0.25_mk*SUM(phimid**2))
- tphi(i,j,isub) = phi(i,j,isub) - wenotau * dphi_dt
-
- rms = MAX(rms,ABS(dphi_dt))
-
- END DO
-
- END DO
-
- END DO
-
-
-
- res = rms
-
- CALL substop('ppm_hamjac_reinit_step_2d',t0,info)
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_step_2ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_step_2dd
-#endif
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_step_3d.f b/src/ppm_hamjac_reinit_step_3d.f
deleted file mode 100644
index e67a95b707cbb1382ad904a9ef16421b9d2dd8a9..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_step_3d.f
+++ /dev/null
@@ -1,375 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_step_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_step_3d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.2 2005/08/12 14:38:01 ivos
- ! bugfix: index bounds in loop corrected.
- !
- ! Revision 1.1 2005/07/25 00:34:05 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_3ds (phi, tphi, trgt, res, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_3dd (phi, tphi, trgt, res, topo_id, &
- & mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_3dsV (phi, idx, tphi, trgt, res, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_3ddV (phi, idx, tphi, trgt, res, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
-
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
-#if __MODE == __SCA
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: phi
-#elif __MODE == __VEC
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: phi
-#endif
- REAL(MK), DIMENSION(:,:,:,:), POINTER :: tphi
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- REAL(mk), INTENT(out) :: res
-#if __MODE == __VEC
- INTEGER, INTENT(in) :: idx
-#endif
- REAL(mk), INTENT(in) :: trgt
-
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid, meshid
- REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k
- REAL(MK) :: len_phys(3)
- !-----------------------------------------------------
- ! WENO stuff
- !-----------------------------------------------------
- REAL(mk) :: oneg(3), opos(3), wenoeps, wenotau, pbs
- REAL(mk) :: laps(-1:1,3), rpos(3), rneg(3), dx(3), dxi(3)
- REAL(mk) :: phip(3), phin(3), phimid(3), rms, dphi_dt
- INTEGER :: ilap
- INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
- & = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
- REAL(mk) :: t0
-
-
- CALL substart('ppm_hamjac_reinit_step_3d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- len_phys(1) = max_phys(1) - min_phys(1)
- len_phys(2) = max_phys(2) - min_phys(2)
- len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
- dxi(1) = 1.0_mk/dx(1)
- dxi(2) = 1.0_mk/dx(2)
- dxi(3) = 1.0_mk/dx(3)
- wenoeps = 1.0e-6_mk
- wenotau = 0.25_mk*MINVAL(dx)
-
- rms = -HUGE(rms)
-
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl)
- DO j=1,ndata(2,isubl)
- DO i=1,ndata(1,isubl)
- ! hack
-#if __MODE == __SCA
-! IF(phi(i+1,j,k,isub).EQ.phi(i-1,j,k,isub).AND. &
-! & phi(i,j+1,k,isub).EQ.phi(i,j-1,k,isub).AND. &
-! & phi(i,j,k+1,isub).EQ.phi(i,j,k-1,isub).AND.ABS(phi(i&
-! &,j,k,isub)).LT.14.0_mk*dx(1)) CYCLE
-#endif
-#if __MODE == __SCA
- phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
- phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
- phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
-#else
- phimid(1) = phi(idx,i+1,j,k,isub)-phi(idx,i-1,j,k,isub)
- phimid(2) = phi(idx,i,j+1,k,isub)-phi(idx,i,j-1,k,isub)
- phimid(3) = phi(idx,i,j,k+1,isub)-phi(idx,i,j,k-1,isub)
-#endif
-
- DO ilap=1,3
-#if __MODE == __SCA
- laps(2-3,1) = phi(i+offs(1,3),j,k,isub) &
- & -2.0_mk * phi(i+offs(2,3),j,k,isub) &
- & + phi(i+offs(3,3),j,k,isub)
- laps(2-3,2) = phi(i,j+offs(1,3),k,isub) &
- & -2.0_mk * phi(i,j+offs(2,3),k,isub) &
- & + phi(i,j+offs(3,3),k,isub)
- laps(2-3,3) = phi(i,j,k+offs(1,3),isub) &
- & -2.0_mk * phi(i,j,k+offs(2,3),isub) &
- & + phi(i,j,k+offs(3,3),isub)
- laps(2-2,1) = phi(i+offs(1,2),j,k,isub) &
- & -2.0_mk * phi(i+offs(2,2),j,k,isub) &
- & + phi(i+offs(3,2),j,k,isub)
- laps(2-2,2) = phi(i,j+offs(1,2),k,isub) &
- & -2.0_mk * phi(i,j+offs(2,2),k,isub) &
- & + phi(i,j+offs(3,2),k,isub)
- laps(2-2,3) = phi(i,j,k+offs(1,2),isub) &
- & -2.0_mk * phi(i,j,k+offs(2,2),isub) &
- & + phi(i,j,k+offs(3,2),isub)
- laps(2-1,1) = phi(i+offs(1,1),j,k,isub) &
- & -2.0_mk * phi(i+offs(2,1),j,k,isub) &
- & + phi(i+offs(3,1),j,k,isub)
- laps(2-1,2) = phi(i,j+offs(1,1),k,isub) &
- & -2.0_mk * phi(i,j+offs(2,1),k,isub) &
- & + phi(i,j+offs(3,1),k,isub)
- laps(2-1,3) = phi(i,j,k+offs(1,1),isub) &
- & -2.0_mk * phi(i,j,k+offs(2,1),isub) &
- & + phi(i,j,k+offs(3,1),isub)
-#elif __MODE == __VEC
- laps(2-ilap,1) = phi(idx,i+offs(1,ilap),j,k,isub) &
- & -2.0_mk * phi(idx,i+offs(2,ilap),j,k,isub) &
- & + phi(idx,i+offs(3,ilap),j,k,isub)
- laps(2-ilap,2) = phi(idx,i,j+offs(1,ilap),k,isub) &
- & -2.0_mk * phi(idx,i,j+offs(2,ilap),k,isub) &
- & + phi(idx,i,j+offs(3,ilap),k,isub)
- laps(2-ilap,3) = phi(idx,i,j,k+offs(1,ilap),isub) &
- & -2.0_mk * phi(idx,i,j,k+offs(2,ilap),isub) &
- & + phi(idx,i,j,k+offs(3,ilap),isub)
-#endif
- END DO
-
- rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
- rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
- rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
- rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
- rpos(3) = (wenoeps + laps( 1,3)**2)/(wenoeps + laps(0,3)**2)
- rneg(3) = (wenoeps + laps(-1,3)**2)/(wenoeps + laps(0,3)**2)
-
- opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
- opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
- opos(3) = 1.0_mk/(1.0_mk+2.0_mk*rpos(3)**2)
- oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
- oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
- oneg(3) = 1.0_mk/(1.0_mk+2.0_mk*rneg(3)**2)
-
-#if __MODE == __SCA
- phip(1) = 0.5_mk*(phimid(1) - &
- & opos(1)*( &
- & phi(i+2,j,k,isub) - &
- & 3.0_mk*(phi(i+1,j,k,isub) - phi(i ,j,k,isub)) - &
- & phi(i-1,j,k,isub)))*dxi(1)
- phip(2) = 0.5_mk*(phimid(2) - &
- & opos(2)*( &
- & phi(i,j+2,k,isub) - &
- & 3.0_mk*(phi(i,j+1,k,isub) - phi(i ,j,k,isub)) - &
- & phi(i,j-1,k,isub)))*dxi(2)
- phip(3) = 0.5_mk*(phimid(3) - &
- & opos(3)*( &
- & phi(i,j,k+2,isub) - &
- & 3.0_mk*(phi(i,j,k+1,isub) - phi(i ,j,k,isub)) - &
- & phi(i,j,k-1,isub)))*dxi(3)
- phin(1) = 0.5_mk*(phimid(1) - &
- & oneg(1)*( &
- & phi(i+1,j,k,isub) - &
- & 3.0_mk*(phi(i ,j,k,isub) - phi(i-1,j,k,isub)) - &
- & phi(i-2,j,k,isub)))*dxi(1)
- phin(2) = 0.5_mk*(phimid(2) - &
- & oneg(2)*( &
- & phi(i,j+1,k,isub) - &
- & 3.0_mk*(phi(i,j ,k,isub) - phi(i,j-1,k,isub)) - &
- & phi(i,j-2,k,isub)))*dxi(2)
- phin(3) = 0.5_mk*(phimid(3) - &
- & oneg(3)*( &
- & phi(i,j,k+1,isub) - &
- & 3.0_mk*(phi(i,j,k ,isub) - phi(i,j,k-1,isub)) - &
- & phi(i,j,k-2,isub)))*dxi(3)
-#else
- phip(1) = 0.5_mk*(phimid(1) - &
- & opos(1)*( &
- & phi(idx,i+2,j,k,isub) - &
- & 3.0_mk*(phi(idx,i+1,j,k,isub) - phi(idx,i ,j,k,isub)) - &
- & phi(idx,i-1,j,k,isub)))*dxi(1)
- phip(2) = 0.5_mk*(phimid(2) - &
- & opos(2)*( &
- & phi(idx,i,j+2,k,isub) - &
- & 3.0_mk*(phi(idx,i,j+1,k,isub) - phi(idx,i ,j,k,isub)) - &
- & phi(idx,i,j-1,k,isub)))*dxi(2)
- phip(3) = 0.5_mk*(phimid(3) - &
- & opos(3)*( &
- & phi(idx,i,j,k+2,isub) - &
- & 3.0_mk*(phi(idx,i,j,k+1,isub) - phi(idx,i ,j,k,isub)) - &
- & phi(idx,i,j,k-1,isub)))*dxi(3)
- phin(1) = 0.5_mk*(phimid(1) - &
- & oneg(1)*( &
- & phi(idx,i+1,j,k,isub) - &
- & 3.0_mk*(phi(idx,i ,j,k,isub) - phi(idx,i-1,j,k,isub)) - &
- & phi(idx,i-2,j,k,isub)))*dxi(1)
- phin(2) = 0.5_mk*(phimid(2) - &
- & oneg(2)*( &
- & phi(idx,i,j+1,k,isub) - &
- & 3.0_mk*(phi(idx,i,j ,k,isub) - phi(idx,i,j-1,k,isub)) - &
- & phi(idx,i,j-2,k,isub)))*dxi(2)
- phin(3) = 0.5_mk*(phimid(3) - &
- & oneg(3)*( &
- & phi(idx,i,j,k+1,isub) - &
- & 3.0_mk*(phi(idx,i,j,k ,isub) - phi(idx,i,j,k-1,isub)) - &
- & phi(idx,i,j,k-2,isub)))*dxi(3)
-#endif
-
-#if __MODE == __SCA
- !--- collect
- IF(phi(i,j,k,isub).GT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))**2+&
- & MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))**2+&
- & MAX(-MIN(phip(3),0.0_mk),MAX(phin(3),0.0_mk))**2)&
- & - trgt
- ELSEIF(phi(i,j,k,isub).LT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(MAX(phip(1),0.0_mk),-MIN(phin(1),0.0_mk))**2+&
- & MAX(MAX(phip(2),0.0_mk),-MIN(phin(2),0.0_mk))**2+&
- & MAX(MAX(phip(3),0.0_mk),-MIN(phin(3),0.0_mk))**2)&
- & - trgt
- ELSE
- pbs = 0.0_mk
- END IF
- dphi_dt = pbs * phi(i,j,k,isub) / &
- & SQRT(phi(i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
- tphi(i,j,k,isub) = phi(i,j,k,isub) - wenotau * dphi_dt
-
-#else
- !--- collect
- IF(phi(idx,i,j,k,isub).GT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(-MIN(phip(1),0.0_mk),MAX(phin(1),0.0_mk))**2+&
- & MAX(-MIN(phip(2),0.0_mk),MAX(phin(2),0.0_mk))**2+&
- & MAX(-MIN(phip(3),0.0_mk),MAX(phin(3),0.0_mk))**2)&
- & - trgt
- ELSEIF(phi(idx,i,j,k,isub).LT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(MAX(phip(1),0.0_mk),-MIN(phin(1),0.0_mk))**2+&
- & MAX(MAX(phip(2),0.0_mk),-MIN(phin(2),0.0_mk))**2+&
- & MAX(MAX(phip(3),0.0_mk),-MIN(phin(3),0.0_mk))**2)&
- & - trgt
- ELSE
- pbs = 0.0_mk
- END IF
- dphi_dt = pbs * phi(idx,i,j,k,isub) / &
- & SQRT(phi(idx,i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
- tphi(i,j,k,isub) = phi(idx,i,j,k,isub) - wenotau * dphi_dt
-
-#endif
-
- rms = MAX(rms,ABS(dphi_dt))
-
- END DO
-
- END DO
-
- END DO
-
- END DO
-
- res = rms
-
- CALL substop('ppm_hamjac_reinit_step_3d',t0,info)
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_step_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_step_3dd
-#endif
-#elif __MODE == __VEC
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_step_3dsV
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_step_3ddV
-#endif
-#endif
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/src/ppm_hamjac_reinit_step_ref_3d.f b/src/ppm_hamjac_reinit_step_ref_3d.f
deleted file mode 100644
index 70168f06fd2c5e7cfbf4fa260d60f3b9b8c61fb8..0000000000000000000000000000000000000000
--- a/src/ppm_hamjac_reinit_step_ref_3d.f
+++ /dev/null
@@ -1,277 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_hamjac_reinit_step_ref_3d
- !-------------------------------------------------------------------------
- !
- ! Purpose : Solve Hamilton-Jacobi for Gowas reinit in ref
- ! spc
- !
- ! Input :
- !
- ! Input/Output :
- !
- ! Output :
- !
- ! Remarks :
- !
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_hamjac_reinit_step_ref_3d.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:19 menahel
- ! initial import
- !
- ! Revision 1.2 2005/08/12 14:38:01 ivos
- ! bugfix: index bounds in loop corrected.
- !
- ! Revision 1.1 2005/07/25 00:34:05 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
-#if __MODE == __SCA
-#if __KIND == __SINGLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_ref_3ds (phi, chi, tphi, trgt, res, &
- & topo_id, mesh_id, ghostsize, info)
-#elif __KIND == __DOUBLE_PRECISION
- SUBROUTINE ppm_hamjac_reinit_step_ref_3dd (phi, chi, tphi, trgt, res, &
- & topo_id, mesh_id, ghostsize, info)
-#endif
-#elif __MODE == __VEC
-#error VECTOR NOT IMPLEMENTED
-#endif
-
- USE ppm_module_data
-
- USE ppm_module_error
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_typedef
- IMPLICIT NONE
-
-#if __KIND == __SINGLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_single
-#elif __KIND == __DOUBLE_PRECISION
- INTEGER, PARAMETER :: MK = ppm_kind_double
-#endif
-
- !-----------------------------------------------------
- ! Arguments
- !-----------------------------------------------------
- REAL(MK), DIMENSION(:,:,:,: ), POINTER :: phi, tphi
- REAL(MK), DIMENSION(:,:,:,:,:), POINTER :: chi
- INTEGER, INTENT(in) :: topo_id, mesh_id
- INTEGER, DIMENSION(3), INTENT(in) :: ghostsize
- INTEGER, INTENT(inout) :: info
- real(mk),INTENT(out) :: res
- REAL(mk), INTENT(in) :: trgt
-
- !-----------------------------------------------------
- ! Aliases
- !-----------------------------------------------------
- INTEGER, DIMENSION(:), POINTER :: isublist
- INTEGER :: nsublist
- INTEGER, DIMENSION(:,:), POINTER :: ndata
- INTEGER :: topoid, meshid
- REAL(MK), DIMENSION(:), POINTER :: min_phys, max_phys
- TYPE(ppm_t_topo), POINTER :: topo
- TYPE(ppm_t_equi_mesh), POINTER :: mesh
-
- !-----------------------------------------------------
- ! standard stuff
- !-----------------------------------------------------
- INTEGER :: isub,isubl,i,j,k
- REAL(MK) :: len_phys(3)
- !-----------------------------------------------------
- ! WENO stuff
- !-----------------------------------------------------
- REAL(mk) :: oneg(3), opos(3), wenoeps, wenotau, pbs
- REAL(mk) :: laps(-1:1,3), rpos(3), rneg(3), dx(3), dxi(3)
- REAL(mk) :: phip(3), phin(3), phimid(3), rms, dphi_dt
- REAL(mk) :: dxihalf, dyihalf, dzihalf, phinx(3), phipx(3)
- REAL(mk) :: dxitwelve, dyitwelve, dzitwelve
- INTEGER :: ilap, order, jsub
- REAL(mk) :: ji(3,3), jac(3,3)
- INTEGER, PARAMETER, DIMENSION(3,3) :: offs &
- & = RESHAPE((/2,1,0,1,0,-1,0,-1,-2/),(/3,3/))
- REAL(mk) :: t0
-
-
- CALL substart('ppm_hamjac_step_3d',t0,info)
-
- !-----------------------------------------------------
- ! Get the mesh data
- !-----------------------------------------------------
- topo => ppm_topo(topo_id)%t
- mesh => topo%mesh(mesh_id)
- meshid = mesh%ID
- nsublist = topo%nsublist
- ndata => mesh%nnodes
- isublist => topo%isublist
-#if __KIND == __SINGLE_PRECISION
- min_phys => topo%min_physs
- max_phys => topo%max_physs
-#elif __KIND == __DOUBLE_PRECISION
- min_phys => topo%min_physd
- max_phys => topo%max_physd
-#endif
-
- len_phys(1) = max_phys(1) - min_phys(1)
- len_phys(2) = max_phys(2) - min_phys(2)
- len_phys(3) = max_phys(3) - min_phys(3)
- dx(1) = len_phys(1)/REAL(mesh%Nm(1)-1,mk)
- dx(2) = len_phys(2)/REAL(mesh%Nm(2)-1,mk)
- dx(3) = len_phys(3)/REAL(mesh%Nm(3)-1,mk)
- dxi(1) = 1.0_mk/dx(1)
- dxi(2) = 1.0_mk/dx(2)
- dxi(3) = 1.0_mk/dx(3)
- dxihalf = 0.5_mk*dxi(1)
- dyihalf = 0.5_mk*dxi(2)
- dzihalf = 0.5_mk*dxi(3)
- dxitwelve = dxi(1)/12.0_mk
- dyitwelve = dxi(2)/12.0_mk
- dzitwelve = dxi(3)/12.0_mk
-
- wenoeps = 1.0e-6_mk
- wenotau = 0.5_mk*MINVAL(dx)
-
- rms = -HUGE(rms)
-
- DO isub=1,nsublist
- isubl = isublist(isub)
- DO k=1,ndata(3,isubl)
- DO j=1,ndata(2,isubl)
- DO i=1,ndata(1,isubl)
-
- DO ilap=1,3
- laps(2-ilap,1) = phi(i+offs(1,ilap),j,k,isub) &
- & -2.0_mk * phi(i+offs(2,ilap),j,k,isub) &
- & + phi(i+offs(3,ilap),j,k,isub)
- laps(2-ilap,2) = phi(i,j+offs(1,ilap),k,isub) &
- & -2.0_mk * phi(i,j+offs(2,ilap),k,isub) &
- & + phi(i,j+offs(3,ilap),k,isub)
- laps(2-ilap,3) = phi(i,j,k+offs(1,ilap),isub) &
- & -2.0_mk * phi(i,j,k+offs(2,ilap),isub) &
- & + phi(i,j,k+offs(3,ilap),isub)
- END DO
-
- rpos(1) = (wenoeps + laps( 1,1)**2)/(wenoeps + laps(0,1)**2)
- rneg(1) = (wenoeps + laps(-1,1)**2)/(wenoeps + laps(0,1)**2)
- rpos(2) = (wenoeps + laps( 1,2)**2)/(wenoeps + laps(0,2)**2)
- rneg(2) = (wenoeps + laps(-1,2)**2)/(wenoeps + laps(0,2)**2)
- rpos(3) = (wenoeps + laps( 1,3)**2)/(wenoeps + laps(0,3)**2)
- rneg(3) = (wenoeps + laps(-1,3)**2)/(wenoeps + laps(0,3)**2)
-
- opos(1) = 1.0_mk/(1.0_mk+2.0_mk*rpos(1)**2)
- opos(2) = 1.0_mk/(1.0_mk+2.0_mk*rpos(2)**2)
- opos(3) = 1.0_mk/(1.0_mk+2.0_mk*rpos(3)**2)
- oneg(1) = 1.0_mk/(1.0_mk+2.0_mk*rneg(1)**2)
- oneg(2) = 1.0_mk/(1.0_mk+2.0_mk*rneg(2)**2)
- oneg(3) = 1.0_mk/(1.0_mk+2.0_mk*rneg(3)**2)
-
- phimid(1) = phi(i+1,j,k,isub)-phi(i-1,j,k,isub)
- phimid(2) = phi(i,j+1,k,isub)-phi(i,j-1,k,isub)
- phimid(3) = phi(i,j,k+1,isub)-phi(i,j,k-1,isub)
-
- phip(1) = 0.5_mk*(phimid(1) - &
- & opos(1)*( &
- & phi(i+2,j,k,isub) - &
- & 3.0_mk*(phi(i+1,j,k,isub) - phi(i ,j,k,isub)) - &
- & phi(i-1,j,k,isub)))*dxi(1)
- phip(2) = 0.5_mk*(phimid(2) - &
- & opos(2)*( &
- & phi(i,j+2,k,isub) - &
- & 3.0_mk*(phi(i,j+1,k,isub) - phi(i ,j,k,isub)) - &
- & phi(i,j-1,k,isub)))*dxi(2)
- phip(3) = 0.5_mk*(phimid(3) - &
- & opos(3)*( &
- & phi(i,j,k+2,isub) - &
- & 3.0_mk*(phi(i,j,k+1,isub) - phi(i ,j,k,isub)) - &
- & phi(i,j,k-1,isub)))*dxi(3)
- phin(1) = 0.5_mk*(phimid(1) - &
- & oneg(1)*( &
- & phi(i+1,j,k,isub) - &
- & 3.0_mk*(phi(i ,j,k,isub) - phi(i-1,j,k,isub)) - &
- & phi(i-2,j,k,isub)))*dxi(1)
- phin(2) = 0.5_mk*(phimid(2) - &
- & oneg(2)*( &
- & phi(i,j+1,k,isub) - &
- & 3.0_mk*(phi(i,j ,k,isub) - phi(i,j-1,k,isub)) - &
- & phi(i,j-2,k,isub)))*dxi(2)
- phin(3) = 0.5_mk*(phimid(3) - &
- & oneg(3)*( &
- & phi(i,j,k+1,isub) - &
- & 3.0_mk*(phi(i,j,k ,isub) - phi(i,j,k-1,isub)) - &
- & phi(i,j,k-2,isub)))*dxi(3)
-
- jsub = isub
-#include "ppm_gmm_jacobian.inc"
-
- phinx(1) = jac(1,1)*phin(1)+jac(2,1)*phin(2)+jac(3,1)*phin(3)
- phinx(2) = jac(1,2)*phin(1)+jac(2,2)*phin(2)+jac(3,2)*phin(3)
- phinx(3) = jac(1,3)*phin(1)+jac(2,3)*phin(2)+jac(3,3)*phin(3)
- phipx(1) = jac(1,1)*phip(1)+jac(2,1)*phip(2)+jac(3,1)*phip(3)
- phipx(2) = jac(1,2)*phip(1)+jac(2,2)*phip(2)+jac(3,2)*phip(3)
- phipx(3) = jac(1,3)*phip(1)+jac(2,3)*phip(2)+jac(3,3)*phip(3)
-
-
- !--- collect
- IF(phi(i,j,k,isub).GT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(-MIN(phipx(1),0.0_mk),MAX(phinx(1),0.0_mk))**2+&
- & MAX(-MIN(phipx(2),0.0_mk),MAX(phinx(2),0.0_mk))**2+&
- & MAX(-MIN(phipx(3),0.0_mk),MAX(phinx(3),0.0_mk))**2)&
- & - trgt
- ELSEIF(phi(i,j,k,isub).LT.0.0_mk) THEN
- pbs = SQRT( &
- & MAX(MAX(phipx(1),0.0_mk),-MIN(phinx(1),0.0_mk))**2+&
- & MAX(MAX(phipx(2),0.0_mk),-MIN(phinx(2),0.0_mk))**2+&
- & MAX(MAX(phipx(3),0.0_mk),-MIN(phinx(3),0.0_mk))**2)&
- & - trgt
- ELSE
- pbs = 0.0_mk
- END IF
- dphi_dt = pbs * phi(i,j,k,isub) / &
- & SQRT(phi(i,j,k,isub)**2+0.25_mk*SUM(phimid**2))
- tphi(i,j,k,isub) = phi(i,j,k,isub) - wenotau * dphi_dt
-
- rms = MAX(rms,ABS(dphi_dt))
-
- END DO
-
- END DO
-
- END DO
-
- END DO
-
- res = rms
-
- CALL substop('ppm_hamjac_step_3d',t0,info)
-
-#if __KIND == __SINGLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_step_ref_3ds
-#elif __KIND == __DOUBLE_PRECISION
- END SUBROUTINE ppm_hamjac_reinit_step_ref_3dd
-#endif
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/src/ppm_module_bem.f b/src/ppm_module_bem.f
deleted file mode 100644
index 6e045b1296c3597f005082ba76bb6f0aa798d15b..0000000000000000000000000000000000000000
--- a/src/ppm_module_bem.f
+++ /dev/null
@@ -1,42 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_bem
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module contains the user-callable subroutines
- ! of the boundary element solver.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_bem.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:56 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.4 2004/07/27 09:19:11 oingo
- ! Added ppm_module_bem_quadrule_npoints since it has to be user callable
- !
- ! Revision 1.3 2004/07/26 13:40:28 ivos
- ! Initial implementation. These are meta-modules for the user-
- ! callable functions. Only these mod files will be given away
- ! to the user.
- !
- !-------------------------------------------------------------------------
- ! Perallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_bem
-
- !----------------------------------------------------------------------
- ! PPM modules
- !----------------------------------------------------------------------
- USE ppm_module_bem_basis
- USE ppm_module_bem_quadrule
- USE ppm_module_bem_quadrule_npoints
-
- END MODULE ppm_module_bem
diff --git a/src/ppm_module_bem_basis.f b/src/ppm_module_bem_basis.f
deleted file mode 100644
index 506be13a2d2ba233bd5fdba6a8422bbda9886536..0000000000000000000000000000000000000000
--- a/src/ppm_module_bem_basis.f
+++ /dev/null
@@ -1,78 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_bem_basis
- !-------------------------------------------------------------------------
- !
- ! Purpose : bem module
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_bem_basis.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:57 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2004/07/26 07:29:24 ivos
- ! First commit after spitting the old modules into single-interface
- ! units.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define data types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-
- MODULE ppm_module_bem_basis
-
- !-----------------------------------------------------------------------
- ! Define interface to ppm_bem_basis
- !-----------------------------------------------------------------------
- INTERFACE ppm_bem_basis
- MODULE PROCEDURE ppm_bem_basis_s
- MODULE PROCEDURE ppm_bem_basis_d
- END INTERFACE
-
- !-----------------------------------------------------------------------
- ! Include the sources
- !-----------------------------------------------------------------------
- CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_bem_basis.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_bem_basis.f"
-#undef __KIND
-
- END MODULE ppm_module_bem_basis
diff --git a/src/ppm_module_bem_quadrule.f b/src/ppm_module_bem_quadrule.f
deleted file mode 100644
index c6c9a19eafedab9c705ab0b58aedaec26d2a4846..0000000000000000000000000000000000000000
--- a/src/ppm_module_bem_quadrule.f
+++ /dev/null
@@ -1,78 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_bem_quadrule
- !-------------------------------------------------------------------------
- !
- ! Purpose : bem module
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_bem_quadrule.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:57 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2004/07/26 07:29:25 ivos
- ! First commit after spitting the old modules into single-interface
- ! units.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define data types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-
- MODULE ppm_module_bem_quadrule
-
- !-----------------------------------------------------------------------
- ! Define interface to ppm_bem_quadrule
- !-----------------------------------------------------------------------
- INTERFACE ppm_bem_quadrule
- MODULE PROCEDURE ppm_bem_quadrule_s
- MODULE PROCEDURE ppm_bem_quadrule_d
- END INTERFACE
-
- !-----------------------------------------------------------------------
- ! Include the sources
- !-----------------------------------------------------------------------
- CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_bem_quadrule.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_bem_quadrule.f"
-#undef __KIND
-
- END MODULE ppm_module_bem_quadrule
diff --git a/src/ppm_module_bem_quadrule_npoints.f b/src/ppm_module_bem_quadrule_npoints.f
deleted file mode 100644
index 32f17afb952e2c0d1e0ac14b6bfad28565e4c4e1..0000000000000000000000000000000000000000
--- a/src/ppm_module_bem_quadrule_npoints.f
+++ /dev/null
@@ -1,65 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_bem_quadrule_npoints
- !-------------------------------------------------------------------------
- !
- ! Purpose : bem module
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_bem_quadrule_npoints.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:57 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2004/07/26 07:29:25 ivos
- ! First commit after spitting the old modules into single-interface
- ! units.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_bem_quadrule_npoints
-
- !-----------------------------------------------------------------------
- ! Define interface to ppm_bem_get_quadrule_points
- !-----------------------------------------------------------------------
- INTERFACE ppm_bem_quadrule_npoints
- MODULE PROCEDURE ppm_bem_quadrule_npoints
- END INTERFACE
-
- !-----------------------------------------------------------------------
- ! Include the sources
- !-----------------------------------------------------------------------
- CONTAINS
-
-#include "ppm_bem_quadrule_npoints.f"
-
- END MODULE ppm_module_bem_quadrule_npoints
diff --git a/src/ppm_module_comp_part.f b/src/ppm_module_comp_part.f
deleted file mode 100644
index 477bf8c6a33aad8c90d137968af333ec04271b5d..0000000000000000000000000000000000000000
--- a/src/ppm_module_comp_part.f
+++ /dev/null
@@ -1,42 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_comp_part
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_comp_part
- !!! This module contains all user-callable routines to
- !!! compute kernel-PP interactions on a set of particles.
- !----------------------------------------------------------------------
- ! PPM modules
- !----------------------------------------------------------------------
- USE ppm_module_comp_pp_verlet
- USE ppm_module_comp_pp_cell
- USE ppm_module_comp_pp_ring
- USE ppm_module_comp_pp_correct
- USE ppm_module_comp_pp_mk_table
-
- END MODULE ppm_module_comp_part
diff --git a/src/ppm_module_comp_pp_cell.f b/src/ppm_module_comp_pp_cell.f
deleted file mode 100644
index 88e868b386f142338b5f7bec7ae3657a339de870..0000000000000000000000000000000000000000
--- a/src/ppm_module_comp_pp_cell.f
+++ /dev/null
@@ -1,122 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_comp_pp_cell
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 3
-#define __DOUBLE_PRECISION_COMPLEX 4
-
-#define __INTERNAL 5
-#define __USER_FUNCTION 6
-#define __LOOKUP_TABLE 7
-
- MODULE ppm_module_comp_pp_cell
- !!! This module provides the routines concerned
- !!! with computing kernel interactions within a set of particles.
- !----------------------------------------------------------------------
- ! Define interfaces to the cell list versions
- !----------------------------------------------------------------------
- INTERFACE ppm_comp_pp_cell
- MODULE PROCEDURE ppm_comp_pp_cell_si
- MODULE PROCEDURE ppm_comp_pp_cell_di
- MODULE PROCEDURE ppm_comp_pp_cell_sci
- MODULE PROCEDURE ppm_comp_pp_cell_dci
- MODULE PROCEDURE ppm_comp_pp_cell_su
- MODULE PROCEDURE ppm_comp_pp_cell_du
- MODULE PROCEDURE ppm_comp_pp_cell_scu
- MODULE PROCEDURE ppm_comp_pp_cell_dcu
- MODULE PROCEDURE ppm_comp_pp_cell_st
- MODULE PROCEDURE ppm_comp_pp_cell_dt
- MODULE PROCEDURE ppm_comp_pp_cell_sct
- MODULE PROCEDURE ppm_comp_pp_cell_dct
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KERNEL __INTERNAL
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __USER_FUNCTION
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __LOOKUP_TABLE
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_cell.f"
-#undef __KIND
-#undef __KERNEL
-
- END MODULE ppm_module_comp_pp_cell
diff --git a/src/ppm_module_comp_pp_correct.f b/src/ppm_module_comp_pp_correct.f
deleted file mode 100644
index feaea45b17ca09f1c5d5e013139ceae1041e9f86..0000000000000000000000000000000000000000
--- a/src/ppm_module_comp_pp_correct.f
+++ /dev/null
@@ -1,122 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_comp_pp_correct
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 3
-#define __DOUBLE_PRECISION_COMPLEX 4
-
-#define __INTERNAL 5
-#define __USER_FUNCTION 6
-#define __LOOKUP_TABLE 7
-
- MODULE ppm_module_comp_pp_correct
- !!! This module provides the routines concerned
- !!! with computing kernel interactions within a set of particles.
- !----------------------------------------------------------------------
- ! Define interfaces to the discretisation correction routine
- !----------------------------------------------------------------------
- INTERFACE ppm_comp_pp_correct
- MODULE PROCEDURE ppm_comp_pp_correct_si
- MODULE PROCEDURE ppm_comp_pp_correct_di
- MODULE PROCEDURE ppm_comp_pp_correct_sci
- MODULE PROCEDURE ppm_comp_pp_correct_dci
- MODULE PROCEDURE ppm_comp_pp_correct_su
- MODULE PROCEDURE ppm_comp_pp_correct_du
- MODULE PROCEDURE ppm_comp_pp_correct_scu
- MODULE PROCEDURE ppm_comp_pp_correct_dcu
- MODULE PROCEDURE ppm_comp_pp_correct_st
- MODULE PROCEDURE ppm_comp_pp_correct_dt
- MODULE PROCEDURE ppm_comp_pp_correct_sct
- MODULE PROCEDURE ppm_comp_pp_correct_dct
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KERNEL __INTERNAL
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __USER_FUNCTION
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __LOOKUP_TABLE
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_correct.f"
-#undef __KIND
-#undef __KERNEL
-
- END MODULE ppm_module_comp_pp_correct
diff --git a/src/ppm_module_comp_pp_doring.f b/src/ppm_module_comp_pp_doring.f
deleted file mode 100644
index bd1251ea87702382137c6d2f756f021f468fee16..0000000000000000000000000000000000000000
--- a/src/ppm_module_comp_pp_doring.f
+++ /dev/null
@@ -1,122 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_comp_pp_doring
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 3
-#define __DOUBLE_PRECISION_COMPLEX 4
-
-#define __INTERNAL 5
-#define __USER_FUNCTION 6
-#define __LOOKUP_TABLE 7
-
- MODULE ppm_module_comp_pp_doring
- !!! This module provides the routines concerned
- !!! with computing kernel interactions within a set of particles.
- !----------------------------------------------------------------------
- ! Define interfaces to the ring interaction subroutine
- !----------------------------------------------------------------------
- INTERFACE ppm_comp_pp_doring
- MODULE PROCEDURE ppm_comp_pp_doring_si
- MODULE PROCEDURE ppm_comp_pp_doring_di
- MODULE PROCEDURE ppm_comp_pp_doring_sci
- MODULE PROCEDURE ppm_comp_pp_doring_dci
- MODULE PROCEDURE ppm_comp_pp_doring_su
- MODULE PROCEDURE ppm_comp_pp_doring_du
- MODULE PROCEDURE ppm_comp_pp_doring_scu
- MODULE PROCEDURE ppm_comp_pp_doring_dcu
- MODULE PROCEDURE ppm_comp_pp_doring_st
- MODULE PROCEDURE ppm_comp_pp_doring_dt
- MODULE PROCEDURE ppm_comp_pp_doring_sct
- MODULE PROCEDURE ppm_comp_pp_doring_dct
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KERNEL __INTERNAL
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __USER_FUNCTION
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __LOOKUP_TABLE
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_doring.f"
-#undef __KIND
-#undef __KERNEL
-
- END MODULE ppm_module_comp_pp_doring
diff --git a/src/ppm_module_comp_pp_mk_table.f b/src/ppm_module_comp_pp_mk_table.f
deleted file mode 100644
index 0c86624460188bb2d9cc7cf53d6dff12ae4609a5..0000000000000000000000000000000000000000
--- a/src/ppm_module_comp_pp_mk_table.f
+++ /dev/null
@@ -1,100 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_comp_pp_mk_table
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 3
-#define __DOUBLE_PRECISION_COMPLEX 4
-
-#define __INTERNAL 5
-#define __USER_FUNCTION 6
-
- MODULE ppm_module_comp_pp_mk_table
- !!! [[ppm_comp_pp_mk_table]]
- !!! This module provides the routines concerned
- !!! with computing kernel interactions within a set of particles.
- !----------------------------------------------------------------------
- ! Define interfaces to the lookup table creation routine
- !----------------------------------------------------------------------
- INTERFACE ppm_comp_pp_mk_table
- MODULE PROCEDURE ppm_comp_pp_mk_table_si
- MODULE PROCEDURE ppm_comp_pp_mk_table_di
- MODULE PROCEDURE ppm_comp_pp_mk_table_sci
- MODULE PROCEDURE ppm_comp_pp_mk_table_dci
- MODULE PROCEDURE ppm_comp_pp_mk_table_su
- MODULE PROCEDURE ppm_comp_pp_mk_table_du
- MODULE PROCEDURE ppm_comp_pp_mk_table_scu
- MODULE PROCEDURE ppm_comp_pp_mk_table_dcu
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KERNEL __INTERNAL
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_mk_table.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_mk_table.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_mk_table.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_mk_table.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __USER_FUNCTION
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_mk_table.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_mk_table.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_mk_table.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_mk_table.f"
-#undef __KIND
-#undef __KERNEL
-
- END MODULE ppm_module_comp_pp_mk_table
diff --git a/src/ppm_module_comp_pp_ring.f b/src/ppm_module_comp_pp_ring.f
deleted file mode 100644
index 910f9ecd8bbb4e64223d8e6e6e5c0f67fad3c7d9..0000000000000000000000000000000000000000
--- a/src/ppm_module_comp_pp_ring.f
+++ /dev/null
@@ -1,122 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_comp_pp_ring
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 3
-#define __DOUBLE_PRECISION_COMPLEX 4
-
-#define __INTERNAL 5
-#define __USER_FUNCTION 6
-#define __LOOKUP_TABLE 7
-
- MODULE ppm_module_comp_pp_ring
- !!! This module provides the routines concerned
- !!! with computing kernel interactions within a set of particles.
- !----------------------------------------------------------------------
- ! Define interfaces to the ring versions
- !----------------------------------------------------------------------
- INTERFACE ppm_comp_pp_ring
- MODULE PROCEDURE ppm_comp_pp_ring_si
- MODULE PROCEDURE ppm_comp_pp_ring_di
- MODULE PROCEDURE ppm_comp_pp_ring_sci
- MODULE PROCEDURE ppm_comp_pp_ring_dci
- MODULE PROCEDURE ppm_comp_pp_ring_su
- MODULE PROCEDURE ppm_comp_pp_ring_du
- MODULE PROCEDURE ppm_comp_pp_ring_scu
- MODULE PROCEDURE ppm_comp_pp_ring_dcu
- MODULE PROCEDURE ppm_comp_pp_ring_st
- MODULE PROCEDURE ppm_comp_pp_ring_dt
- MODULE PROCEDURE ppm_comp_pp_ring_sct
- MODULE PROCEDURE ppm_comp_pp_ring_dct
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KERNEL __INTERNAL
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __USER_FUNCTION
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __LOOKUP_TABLE
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_ring.f"
-#undef __KIND
-#undef __KERNEL
-
- END MODULE ppm_module_comp_pp_ring
diff --git a/src/ppm_module_comp_pp_verlet.f b/src/ppm_module_comp_pp_verlet.f
deleted file mode 100644
index 3d866924df8402b8e9b90bd927592012d43bb91f..0000000000000000000000000000000000000000
--- a/src/ppm_module_comp_pp_verlet.f
+++ /dev/null
@@ -1,122 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_comp_pp_verlet
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 3
-#define __DOUBLE_PRECISION_COMPLEX 4
-
-#define __INTERNAL 5
-#define __USER_FUNCTION 6
-#define __LOOKUP_TABLE 7
-
- MODULE ppm_module_comp_pp_verlet
- !!! This module provides the routines concerned
- !!! with computing kernel interactions within a set of particles.
- !----------------------------------------------------------------------
- ! Define interfaces to the Verlet list versions
- !----------------------------------------------------------------------
- INTERFACE ppm_comp_pp_verlet
- MODULE PROCEDURE ppm_comp_pp_verlet_si
- MODULE PROCEDURE ppm_comp_pp_verlet_di
- MODULE PROCEDURE ppm_comp_pp_verlet_sci
- MODULE PROCEDURE ppm_comp_pp_verlet_dci
- MODULE PROCEDURE ppm_comp_pp_verlet_su
- MODULE PROCEDURE ppm_comp_pp_verlet_du
- MODULE PROCEDURE ppm_comp_pp_verlet_scu
- MODULE PROCEDURE ppm_comp_pp_verlet_dcu
- MODULE PROCEDURE ppm_comp_pp_verlet_st
- MODULE PROCEDURE ppm_comp_pp_verlet_dt
- MODULE PROCEDURE ppm_comp_pp_verlet_sct
- MODULE PROCEDURE ppm_comp_pp_verlet_dct
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KERNEL __INTERNAL
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __USER_FUNCTION
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-#undef __KERNEL
-
-#define __KERNEL __LOOKUP_TABLE
-#define __KIND __SINGLE_PRECISION
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_comp_pp_verlet.f"
-#undef __KIND
-#undef __KERNEL
-
- END MODULE ppm_module_comp_pp_verlet
diff --git a/src/ppm_module_data_fieldsolver.f b/src/ppm_module_data_fieldsolver.f
deleted file mode 100644
index 6932012a2f2ef53a5a2e4b4cefe19173eef37ab6..0000000000000000000000000000000000000000
--- a/src/ppm_module_data_fieldsolver.f
+++ /dev/null
@@ -1,81 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_data_fieldsolver
- !-------------------------------------------------------------------------
- !
- ! Purpose : data module of fieldsolver mostly containing the FFT
- ! plans
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_data_fieldsolver.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:57 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2005/02/17 17:47:00 hiebers
- ! Reimplementation
- !
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-MODULE ppm_module_data_fieldsolver
-
- USE ppm_module_data,ONLY:ppm_kind_single,ppm_kind_double
- PRIVATE :: ppm_kind_single,ppm_kind_double
-
- ! FFTW Plans
- INTEGER*8 Plan_fd_s, Plan_fd_d
- INTEGER*8 Plan_slab_fd_s,Plan_slab_fd_d
- INTEGER*8 Plan_fd_c_y, Plan_fd_cc_y
- INTEGER*8 Plan_fd_c_z, Plan_fd_cc_z
- INTEGER*8 Plan_bd_s, Plan_bd_d
- INTEGER*8 Plan_slab_bd_s,Plan_slab_bd_d
- INTEGER*8 Plan_bd_c_y, Plan_bd_cc_y
- INTEGER*8 Plan_bd_c_z, Plan_bd_cc_z
-
-
- ! MATHKEISAN variables for MathKeisan FFTs
- ! working storage
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: table_fd_s, table_bd_s
- REAL(ppm_kind_double), DIMENSION(:),POINTER :: table_fd_d, table_bd_d
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: table_fd_c_y, table_bd_c_y
- REAL(ppm_kind_double), DIMENSION(:),POINTER :: table_fd_cc_y,table_bd_cc_y
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: table_fd_c_z, table_bd_c_z
- REAL(ppm_kind_double), DIMENSION(:),POINTER :: table_fd_cc_z,table_bd_cc_z
-
- ! the size of the working storage
- INTEGER, DIMENSION(1) :: lda_table, lda_table_y, lda_table_z
-
-
-END MODULE ppm_module_data_fieldsolver
diff --git a/src/ppm_module_data_fmm.f b/src/ppm_module_data_fmm.f
deleted file mode 100644
index 318c74dd0fa42fab333d9723b3531b8f30f3a1de..0000000000000000000000000000000000000000
--- a/src/ppm_module_data_fmm.f
+++ /dev/null
@@ -1,317 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_data_fmm
- !-------------------------------------------------------------------------
- !
- ! Purpose : fast mulipole method, data
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_data_fmm.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:57 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.13 2006/09/04 18:34:52 pchatela
- ! Fixes and cleanups to make it compile for
- ! release-1-0
- !
- ! Revision 1.12 2006/06/29 10:28:36 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.11 2006/06/16 07:50:28 hiebers
- ! added list of topo IDs
- !
- ! Revision 1.10 2005/09/19 13:03:30 polasekb
- ! code cosmetics
- !
- ! Revision 1.9 2005/09/12 13:30:19 polasekb
- ! added ppm_subid
- !
- ! Revision 1.8 2005/08/11 15:13:33 polasekb
- ! added maxboxcost
- !
- ! Revision 1.7 2005/08/08 13:34:44 polasekb
- ! removed fmm_prec
- !
- ! Revision 1.6 2005/08/04 16:02:46 polasekb
- ! addes some new data
- !
- ! Revision 1.5 2005/07/29 12:36:51 polasekb
- ! changed diagonal to radius
- !
- ! Revision 1.4 2005/07/27 21:11:54 polasekb
- ! added totalmass (again)
- !
- ! Revision 1.3 2005/07/25 14:28:32 polasekb
- ! added some constants for the spherical harmonics
- !
- ! Revision 1.2 2005/06/02 13:55:16 polasekb
- ! removed totalmass
- !
- ! Revision 1.1 2005/05/27 08:04:09 polasekb
- ! initial implementation
- !
- !
- ! Revision 0 2004/11/11 4:04:15 polasekb
- ! Start.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-MODULE ppm_module_data_fmm
- !-------------------------------------------------------------------------
- !Modules
- !-------------------------------------------------------------------------
- USE ppm_module_data,ONLY:ppm_kind_single,ppm_kind_double
- PRIVATE :: ppm_kind_single,ppm_kind_double
-
- !-------------------------------------------------------------------------
- ! Define Initialization-FLAG
- !-------------------------------------------------------------------------
- LOGICAL :: ppm_fmm_initialized = .FALSE.
-
- !-------------------------------------------------------------------------
- ! Define order of expansion
- !-------------------------------------------------------------------------
- INTEGER :: order
-
- !-------------------------------------------------------------------------
- ! Define radius of tree boxes
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:),POINTER :: radius_s
- REAL(ppm_kind_double),DIMENSION(:),POINTER :: radius_d
-
- !-------------------------------------------------------------------------
- ! Define expansions of all tree boxes
- ! 1st index: boxid
- ! 2nd/3rd index: expansion
- !-------------------------------------------------------------------------
- COMPLEX(ppm_kind_single),DIMENSION(:,:,:) ,POINTER :: expansion_s_sf
- COMPLEX(ppm_kind_double),DIMENSION(:,:,:) ,POINTER :: expansion_d_sf
- COMPLEX(ppm_kind_single),DIMENSION(:,:,:,:),POINTER :: expansion_s_vf
- COMPLEX(ppm_kind_double),DIMENSION(:,:,:,:),POINTER :: expansion_d_vf
-
- !-------------------------------------------------------------------------
- ! Define center of mass of tree boxes
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:,:),POINTER :: centerofbox_s
- REAL(ppm_kind_double),DIMENSION(:,:),POINTER :: centerofbox_d
-
- !-------------------------------------------------------------------------
- ! Define totalmass of tree boxes
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:),POINTER :: totalmass_s
- REAL(ppm_kind_double),DIMENSION(:),POINTER :: totalmass_d
-
- !-------------------------------------------------------------------------
- ! Store tree output in data file
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define min_box, minimum extent of tree boxes
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:,:),POINTER :: min_box_s
- REAL(ppm_kind_double),DIMENSION(:,:),POINTER :: min_box_d
-
- !-------------------------------------------------------------------------
- ! Define max_box, maximum extent of tree boxes
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:,:),POINTER :: max_box_s
- REAL(ppm_kind_double),DIMENSION(:,:),POINTER :: max_box_d
-
- !-------------------------------------------------------------------------
- ! Define nbox, total number of boxes
- !-------------------------------------------------------------------------
- INTEGER :: nbox
-
- !-------------------------------------------------------------------------
- ! Define nchld, number of children of the box
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:),POINTER :: nchld
-
- !-------------------------------------------------------------------------
- ! Define lhbx, pointer to first and last point in box (in lpdx)
- ! 1st index: 1 or 2, first and last
- ! 2nd index: box id
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:,:),POINTER :: lhbx
-
- !-------------------------------------------------------------------------
- ! Define lpdx, permutation of xp, particles ordered according to tree
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:),POINTER :: lpdx
-
- !-------------------------------------------------------------------------
- ! Define boxcost
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:),POINTER :: boxcost_s
- REAL(ppm_kind_double),DIMENSION(:),POINTER :: boxcost_d
-
- !-------------------------------------------------------------------------
- ! Define parent, the partent of the box
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:),POINTER :: parent
-
- !-------------------------------------------------------------------------
- ! Define child, the child ids of the box
- ! 1st index: child number (1-8 in octtree)
- ! 2nd index: box id
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:,:),POINTER :: child
-
- !-------------------------------------------------------------------------
- ! Define blevel, level of box
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:),POINTER :: blevel
-
- !-------------------------------------------------------------------------
- ! Define nbpl, number of boxes per level
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:),POINTER :: nbpl
-
- !-------------------------------------------------------------------------
- ! Define nlevel, total number of levels
- !-------------------------------------------------------------------------
- INTEGER :: nlevel
-
- !-------------------------------------------------------------------------
- ! Define list of topo ids
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:),POINTER :: topoidlist
-
- !-------------------------------------------------------------------------
- ! End of Tree data definition
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define boxid, box id of sub id
- ! 1st index: sub id
- ! 2nd index: user topology id
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:,:),POINTER :: ppm_boxid
-
- !-------------------------------------------------------------------------
- ! Define subid. sub id of box id
- ! 1st index: box id
- ! 2nd index: user topology id
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:,:),POINTER :: ppm_subid
-
- !-------------------------------------------------------------------------
- ! Define boxpart, which particle is in which box
- !-------------------------------------------------------------------------
- INTEGER,DIMENSION(:),POINTER :: boxpart
-
- !-------------------------------------------------------------------------
- ! Define maxboxcost, the maximum nr of particles per box
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single) :: maxboxcost_s
- REAL(ppm_kind_double) :: maxboxcost_d
-
- !-------------------------------------------------------------------------
- ! Data for spherical harmonics
- !-------------------------------------------------------------------------
- !-------------------------------------------------------------------------
- ! Define Anm
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:,:),POINTER :: Anm_s
- REAL(ppm_kind_double),DIMENSION(:,:),POINTER :: Anm_d
-
- !-------------------------------------------------------------------------
- ! Define sqrtfac
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:,:),POINTER :: sqrtfac_s
- REAL(ppm_kind_double),DIMENSION(:,:),POINTER :: sqrtfac_d
-
- !-------------------------------------------------------------------------
- ! Define Cnm
- !-------------------------------------------------------------------------
- COMPLEX(ppm_kind_single),DIMENSION(:,:),POINTER :: Cnm_s_sf
- COMPLEX(ppm_kind_double),DIMENSION(:,:),POINTER :: Cnm_d_sf
- COMPLEX(ppm_kind_single),DIMENSION(:,:,:),POINTER :: Cnm_s_vf
- COMPLEX(ppm_kind_double),DIMENSION(:,:,:),POINTER :: Cnm_d_vf
-
- !-------------------------------------------------------------------------
- ! Define Inner
- !-------------------------------------------------------------------------
- COMPLEX(ppm_kind_single),DIMENSION(:,:),POINTER :: Inner_s
- COMPLEX(ppm_kind_double),DIMENSION(:,:),POINTER :: Inner_d
-
- !-------------------------------------------------------------------------
- ! Define Outer
- !-------------------------------------------------------------------------
- COMPLEX(ppm_kind_single),DIMENSION(:,:),POINTER :: Outer_s
- COMPLEX(ppm_kind_double),DIMENSION(:,:),POINTER :: Outer_d
-
- !-------------------------------------------------------------------------
- ! Define Ynm
- !-------------------------------------------------------------------------
- COMPLEX(ppm_kind_single),DIMENSION(:,:),POINTER :: Ynm_s
- COMPLEX(ppm_kind_double),DIMENSION(:,:),POINTER :: Ynm_d
-
- !-------------------------------------------------------------------------
- ! Define Pnm
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(:,:),POINTER :: Pnm_s
- REAL(ppm_kind_double),DIMENSION(:,:),POINTER :: Pnm_d
-
- !-------------------------------------------------------------------------
- ! Define fracfac
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(: ),POINTER :: fracfac_s
- REAL(ppm_kind_double),DIMENSION(: ),POINTER :: fracfac_d
-
- !-------------------------------------------------------------------------
- ! Define rho
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(: ),POINTER :: rho_s
- REAL(ppm_kind_double),DIMENSION(: ),POINTER :: rho_d
-
- !-------------------------------------------------------------------------
- ! Define theta
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(: ),POINTER :: theta_s
- REAL(ppm_kind_double),DIMENSION(: ),POINTER :: theta_d
-
- !-------------------------------------------------------------------------
- ! Define phi
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(: ),POINTER :: phi_s
- REAL(ppm_kind_double),DIMENSION(: ),POINTER :: phi_d
-
- !-------------------------------------------------------------------------
- ! Define fac
- !-------------------------------------------------------------------------
- REAL(ppm_kind_single),DIMENSION(: ),POINTER :: fac_s
- REAL(ppm_kind_double),DIMENSION(: ),POINTER :: fac_d
-
-END MODULE ppm_module_data_fmm
diff --git a/src/ppm_module_data_gmm.f b/src/ppm_module_data_gmm.f
deleted file mode 100644
index 7ec2cb3747d31aa23dfc1154a339eca100be2101..0000000000000000000000000000000000000000
--- a/src/ppm_module_data_gmm.f
+++ /dev/null
@@ -1,94 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_data_gmm
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module contains all data structures and
- ! definitions that are PRIVATE to the group
- ! marching method routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_data_gmm.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:57 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.5 2006/07/03 12:56:56 ivos
- ! Added comments to explain all the variables.
- !
- ! Revision 1.4 2005/04/27 01:06:14 ivos
- ! Convergence tests completed, cleaned up code, optmized code (Shark),
- ! and changed structure to allow faster compilation.
- !
- ! Revision 1.3 2005/04/21 04:48:25 ivos
- ! Cleaned interfaces and removed unnecessary overloaded versions.
- !
- ! Revision 1.2 2005/03/16 06:20:10 ivos
- ! Several bugfixes. 1st order version is now tested. Moved all large
- ! data to the module.
- !
- ! Revision 1.1 2005/03/10 01:37:17 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Perallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_data_gmm
-
- !----------------------------------------------------------------------
- ! Modules
- !----------------------------------------------------------------------
- USE ppm_module_data, ONLY: ppm_kind_single, ppm_kind_double
- PRIVATE :: ppm_kind_single, ppm_kind_double
-
- !----------------------------------------------------------------------
- ! Parameters
- !----------------------------------------------------------------------
- ! FLAGS for the three different types of points in GMM.
- ! It is important that far is 0 and far<close<accepted
- ! Otherwise the computation of the switches in gmm_slvupwnd needs to
- ! be adjusted !
- INTEGER, PARAMETER :: ppm_gmm_param_far = 0
- INTEGER, PARAMETER :: ppm_gmm_param_close = 1
- INTEGER, PARAMETER :: ppm_gmm_param_accepted = 2
-
- !----------------------------------------------------------------------
- ! Global values
- !----------------------------------------------------------------------
- ! GMM step size and max extent of mesh in all directions
- INTEGER :: incr,maxxhi,maxyhi,maxzhi
- ! topoID and meshID on which the GMM operates
- INTEGER :: gmm_topoid,gmm_meshid
-
- !----------------------------------------------------------------------
- ! Sparse matrix structure as workspace
- !----------------------------------------------------------------------
- ! locations (mesh indices) of the data points. Sparse structure.
- INTEGER , DIMENSION(:,:) , POINTER :: gmm_ipos
- ! values at these locations. Sparse structure.
- REAL(ppm_kind_double), DIMENSION(: ) , POINTER :: gmm_phid
- REAL(ppm_kind_single), DIMENSION(: ) , POINTER :: gmm_phis
- ! length of the sparse structure (i.e. number of points in ipos)
- INTEGER :: gmm_lsiz = -1
- ! positions of the closest points on the interface (for CPT)
- REAL(ppm_kind_double), DIMENSION(:,:) , POINTER :: gmm_clod
- REAL(ppm_kind_single), DIMENSION(:,:) , POINTER :: gmm_clos
- REAL(ppm_kind_double), DIMENSION(:,:) , POINTER :: gmm_clod2
- REAL(ppm_kind_single), DIMENSION(:,:) , POINTER :: gmm_clos2
- ! states of the mesh points (PARAMETER flags above)
- INTEGER , DIMENSION(:,:,:,:), POINTER :: gmm_state3d
- INTEGER , DIMENSION(:,:,:), POINTER :: gmm_state2d
- ! list of mesh points closest to the interface
- INTEGER , DIMENSION(:,:) , POINTER :: iptstmp
- INTEGER , DIMENSION(:,:) , POINTER :: iptstmp2
- ! index and sort key for ranking of points
- INTEGER , DIMENSION(: ) , POINTER :: idx,key
-
- END MODULE ppm_module_data_gmm
diff --git a/src/ppm_module_data_mg.f b/src/ppm_module_data_mg.f
deleted file mode 100644
index 589dfb0ba24475efd3fb2f2db12af6da50443772..0000000000000000000000000000000000000000
--- a/src/ppm_module_data_mg.f
+++ /dev/null
@@ -1,428 +0,0 @@
- !------------------------------------------------------------------------
- ! Module : ppm_module_data_mg
- !------------------------------------------------------------------------
- !
- !------------------------------------------------------------------------
- ! Parallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_data_mg
- !! multigrid data module
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
- USE ppm_module_data,ONLY:ppm_kind_single,ppm_kind_double
- PRIVATE :: ppm_kind_single,ppm_kind_double
- !-----------------------------------------------------------------------------
- !The boundary condition values!!
- !-----------------------------------------------------------------------------
-
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
- TYPE bc_value_2d_sca_s
- ! 1st index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue => NULL()
- END TYPE bc_value_2d_sca_s
-#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- TYPE bc_value_2d_sca_d
- !1st index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue => NULL()
- END TYPE bc_value_2d_sca_d
-#undef __KIND
-
-
-
-#define __KIND == __SINGLE_PRECISION
- !-----------------------------------------------------------------------------
- ! Our multigrid field with all its necessary components (Take a look at the
- ! theory)
- !-----------------------------------------------------------------------------
- TYPE mg_field_2d_sca_s
- !function corrections, error restrictions, errors
- !1st and 2nd index: mesh position(local)
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: uc => NULL()
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: fc => NULL()
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: err => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR RED (EVEN) MESH POINTS
- !-------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:),POINTER :: mask_red => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR BLACK (ODD) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:),POINTER :: mask_black => NULL()
-
- !lets save the boundary condition.index:face of the subdomain(1:4)
- TYPE(bc_value_2d_sca_s), DIMENSION(:), POINTER :: bcvalue => NULL()
- END TYPE mg_field_2d_sca_s
-#undef __KIND
-
-#define __KIND == __DOUBLE_PRECISION
-
- TYPE mg_field_2d_sca_d
- !function corrections, error restrictions, errors,
- !1st:3rd index: mesh position(local)
- REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: uc => NULL()
- REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: fc => NULL()
- REAL(ppm_kind_double), DIMENSION(:,:),POINTER :: err => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR RED (EVEN) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:),POINTER :: mask_red => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR BLACK (ODD) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:),POINTER :: mask_black => NULL()
- !lets save the boundary condition.index:face of the subdomain(1:4)
- TYPE(bc_value_2d_sca_d), DIMENSION(:), POINTER :: bcvalue => NULL()
- END TYPE mg_field_2d_sca_d
-#undef __KIND
-
-
-#define __KIND == __SINGLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_2d_sca_s), DIMENSION(:,:), POINTER :: mgfield_2d_sca_s => NULL()
-#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_2d_sca_d), DIMENSION(:,:), POINTER :: mgfield_2d_sca_d => NULL()
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
- TYPE bc_value_3d_sca_s
- ! 1st-2nd index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: pbcvalue => NULL()
- END TYPE bc_value_3d_sca_s
-#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- TYPE bc_value_3d_sca_d
- !1st-2nd index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:,:),POINTER :: pbcvalue => NULL()
- END TYPE bc_value_3d_sca_d
-#undef __KIND
-
-
-#define __KIND == __SINGLE_PRECISION
- !-----------------------------------------------------------------------------
- ! Our multigrid field with all its necessary components (Take a look at the
- ! theory)
- !-----------------------------------------------------------------------------
- TYPE mg_field_3d_sca_s
- !function corrections, error restrictions, errors
- !1st-3rd index: mesh position(local)
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: uc => NULL()
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: fc => NULL()
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: err => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR RED (EVEN) MESH POINTS
- !-------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR BLACK (ODD) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black => NULL()
-
- !lets save the boundary condition.index:face of the subdomain(1:6)
- TYPE(bc_value_3d_sca_s), DIMENSION(:), POINTER :: bcvalue => NULL()
- END TYPE mg_field_3d_sca_s
-#undef __KIND
-
-#define __KIND == __DOUBLE_PRECISION
-
- TYPE mg_field_3d_sca_d
- !function corrections, error restrictions, errors,
- !1st:3rd index: mesh position(local)
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: uc => NULL()
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: fc => NULL()
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: err => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR RED (EVEN) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR BLACK (ODD) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black => NULL()
- !lets save the boundary condition.index:face of the subdomain(1:6)
- TYPE(bc_value_3d_sca_d), DIMENSION(:), POINTER :: bcvalue => NULL()
- END TYPE mg_field_3d_sca_d
-#undef __KIND
-
-
-#define __KIND == __SINGLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_3d_sca_s), DIMENSION(:,:), POINTER :: mgfield_3d_sca_s => NULL()
-#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_3d_sca_d), DIMENSION(:,:), POINTER :: mgfield_3d_sca_d => NULL()
-#undef __KIND
-#undef __MESH_DIM
-
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
- TYPE bc_value_2d_vec_s
- ! 1st index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue => NULL()
- END TYPE bc_value_2d_vec_s
-#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- TYPE bc_value_2d_vec_d
- !1st index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:),POINTER :: pbcvalue => NULL()
- END TYPE bc_value_2d_vec_d
-#undef __KIND
-
-#define __KIND == __SINGLE_PRECISION
- !-----------------------------------------------------------------------------
- ! Our multigrid field with all its necessary components (Take a look at the
- ! theory)
- !-----------------------------------------------------------------------------
- TYPE mg_field_2d_vec_s
- !function corrections, error restrictions, errors
- !1st index component 2nd and 3rd index: mesh position(local)
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: uc => NULL()
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: fc => NULL()
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: err => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR RED (EVEN) MESH POINTS
- !-------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:),POINTER :: mask_red => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR BLACK (ODD) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:),POINTER :: mask_black => NULL()
-
- !lets save the boundary condition.index:component,face of the subdomain(1:4)
- TYPE(bc_value_2d_vec_s), DIMENSION(:,:), POINTER :: bcvalue => NULL()
- END TYPE mg_field_2d_vec_s
-#undef __KIND
-
-
-#define __KIND == __DOUBLE_PRECISION
- TYPE mg_field_2d_vec_d
- !function corrections, error restrictions, errors,
- !1st index: component 2nd:3rd index: mesh position(local)
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: uc => NULL()
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: fc => NULL()
- REAL(ppm_kind_double), DIMENSION(:,:,:),POINTER :: err => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR RED (EVEN) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:),POINTER :: mask_red => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR BLACK (ODD) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:),POINTER :: mask_black => NULL()
- !lets save the boundary condition.index:component,face of the subdomain(1:4)
- TYPE(bc_value_2d_vec_d), DIMENSION(:), POINTER :: bcvalue => NULL()
- END TYPE mg_field_2d_vec_d
-#undef __KIND
-
-
-#define __KIND == __SINGLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_2d_vec_s), DIMENSION(:,:), POINTER :: mgfield_2d_vec_s => NULL()
-#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_2d_vec_d), DIMENSION(:,:), POINTER :: mgfield_2d_vec_d => NULL()
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
- TYPE bc_value_3d_vec_s
- ! 1st-2nd index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: pbcvalue => NULL()
- END TYPE bc_value_3d_vec_s
-#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- TYPE bc_value_3d_vec_d
- !1st-2nd index mesh position locally
- REAL(ppm_kind_single), DIMENSION(:,:,:),POINTER :: pbcvalue => NULL()
- END TYPE bc_value_3d_vec_d
-#undef __KIND
-
-
-
-#define __KIND == __SINGLE_PRECISION
- !-----------------------------------------------------------------------------
- ! Our multigrid field with all its necessary components (Take a look at the
- ! theory)
- !-----------------------------------------------------------------------------
- TYPE mg_field_3d_vec_s
- !function corrections, error restrictions, errors
- !1st index: component 2nd-4th index: mesh position(local)
- REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: uc => NULL()
- REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: fc => NULL()
- REAL(ppm_kind_single), DIMENSION(:,:,:,:),POINTER :: err => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR RED (EVEN) MESH POINTS
- !-------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR BLACK (ODD) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black => NULL()
-
- !lets save the boundary condition.index:component,face of the subdomain(1:6)
- TYPE(bc_value_3d_vec_s), DIMENSION(:), POINTER :: bcvalue => NULL()
- END TYPE mg_field_3d_vec_s
-#undef __KIND
-
-#define __KIND == __DOUBLE_PRECISION
-
- TYPE mg_field_3d_vec_d
- !function corrections, error restrictions, errors,
- !1st index component,2nd:4th index: mesh position(local)
- REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: uc => NULL()
- REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: fc => NULL()
- REAL(ppm_kind_double), DIMENSION(:,:,:,:),POINTER :: err => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR RED (EVEN) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_red => NULL()
- !--------------------------------------------------------------------------
- !TRUE FOR BLACK (ODD) MESH POINTS
- !--------------------------------------------------------------------------
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_black => NULL()
- !lets save the boundary condition.index:face of the subdomain(1:6)
- TYPE(bc_value_3d_vec_d), DIMENSION(:), POINTER :: bcvalue => NULL()
- END TYPE mg_field_3d_vec_d
-#undef __KIND
-
-
-#define __KIND == __SINGLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_3d_vec_s), DIMENSION(:,:), POINTER :: mgfield_3d_vec_s => NULL()
-#undef __KIND
-#define __KIND == __DOUBLE_PRECISION
- !1st index: subdomain,2nd index : multigrid level
- TYPE(mg_field_3d_vec_d), DIMENSION(:,:), POINTER :: mgfield_3d_vec_d => NULL()
-#undef __KIND
-#undef __MESH_DIM
-
-#undef __DIM
- !-----------------------------------------------------------------------------
- !Starting index for the iteration through the mesh points.
- !-----------------------------------------------------------------------------
- INTEGER, DIMENSION(:,:,:), POINTER :: start => NULL()
- !-----------------------------------------------------------------------------
- ! Global starting index for the iteration through the mesh points.
- !-----------------------------------------------------------------------------
- INTEGER, DIMENSION(:,:,:), POINTER :: istart => NULL()
- !-----------------------------------------------------------------------------
- !Stopping index for the iteration through the mesh points.
- !-----------------------------------------------------------------------------
- INTEGER, DIMENSION(:,:,:), POINTER :: istop => NULL()
- !-----------------------------------------------------------------------------
- !Factor for coarsening the mesh
- !-----------------------------------------------------------------------------
- INTEGER, DIMENSION(:),POINTER :: factor => NULL()
- !-----------------------------------------------------------------------------
- !Array with MG meshids
- !-----------------------------------------------------------------------------
- INTEGER, DIMENSION(:),POINTER :: mg_meshid => NULL()
- !-----------------------------------------------------------------------------
- !Size of the ghostlayer. It is 1 for the multigrid since we do
- !for the time being second order finite differences
- !-----------------------------------------------------------------------------
- INTEGER, DIMENSION(:),POINTER :: ghostsize => NULL()
- !-----------------------------------------------------------------------------
- !BOUNDARY CONDITIONS of the computational domain.1st index:sub,2nd,face
- !-----------------------------------------------------------------------------
-#define __DIM == __SFIELD
- INTEGER, DIMENSION(:,:),POINTER :: bcdef_sca => NULL()
-#undef __DIM
-#define __DIM == __VFIELD
- INTEGER, DIMENSION(:,:,:),POINTER :: bcdef_vec => NULL()
-#undef __DIM
-
- !-----------------------------------------------------------------------------
- !Is the face of the cell at the boundary? Yes or no?1st index face,2nd:isub
- !-----------------------------------------------------------------------------
- LOGICAL, DIMENSION(:,:), POINTER :: lboundary => NULL()
- !----------------------------------------------------------------------------
- !V_CYCLE OR W_CYCLE AND TO PRINT OR NOT TO PRINT
- !----------------------------------------------------------------------------
- LOGICAL :: w_cycle
- !----------------------------------------------------------------------------
- !ARE ALL THE BOUNDARIES PERIODIC
- !----------------------------------------------------------------------------
- LOGICAL :: lperiodic
- !----------------------------------------------------------------------------
- !Order of the mg
- !---------------------------------------------------------------------------
- INTEGER :: order
- !-----------------------------------------------------------------------------
- !number of levels (theoretical value)
- !-----------------------------------------------------------------------------
- INTEGER :: maxlev
- !-----------------------------------------------------------------------------
- !number of subs
- !-----------------------------------------------------------------------------
- INTEGER :: nsubs
- !----------------------------------------------------------------------------
- !smoother
- !--------------------------------------------------------------------------
- INTEGER :: ismoother
- !-----------------------------------------------------------------------------
- !number of dimensions in the problem(if scalar fields=> vecdim=1)
- !-----------------------------------------------------------------------------
- INTEGER :: vecdim
- !-----------------------------------------------------------------------------
- !MASK DUMMY FOR COMPATIBILITY OF TYPE THAT I USE WITH FIELDS OF PPM
- !-----------------------------------------------------------------------------
-#define __MESH_DIM == __2D
- LOGICAL,DIMENSION(:,:,:),POINTER :: mask_dummy_2d => NULL()
-#undef __MESH_DIM
-#define __MESH_DIM == __3D
- LOGICAL,DIMENSION(:,:,:,:),POINTER :: mask_dummy_3d => NULL()
-#undef __MESH_DIM
-
- !-----------------------------------------------------------------------------
- ! Array with the maximum number of mesh points on each processor
- ! Due to the load ballancing the waste of memory (if existed) is
- ! minimal
- !-----------------------------------------------------------------------------
- INTEGER,DIMENSION(:,:),POINTER :: max_node => NULL()
-
-
-#define __KIND __SINGLE_PRECISION
- REAL(ppm_kind_single) :: rdx2_s,rdy2_s,rdz2_s
- REAL(ppm_kind_single) :: dx_s,dy_s,dz_s
- REAL(ppm_kind_single) :: EPSU_s
- REAL(ppm_kind_single) :: omega_s
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
- REAL(ppm_kind_double) :: rdx2_d,rdy2_d,rdz2_d
- REAL(ppm_kind_double) :: dx_d,dy_d,dz_d
- REAL(ppm_kind_double) :: EPSU_d
- REAL(ppm_kind_double) :: omega_d
-#undef __KIND
-
-END MODULE ppm_module_data_mg
-
-
diff --git a/src/ppm_module_fdsolver_fft_bd.f b/src/ppm_module_fdsolver_fft_bd.f
deleted file mode 100644
index 22ccfbd64a2760e4e5005857732d57780543bad3..0000000000000000000000000000000000000000
--- a/src/ppm_module_fdsolver_fft_bd.f
+++ /dev/null
@@ -1,139 +0,0 @@
-#ifdef __XLF
-@PROCESS NOHOT
-#endif
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fdsolver_fft_bd
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the fft
- ! routines
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fdsolver_fft_bd.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/02/16 12:07:35 hiebers
- ! initial implementation
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 5
-#define __DOUBLE_PRECISION_COMPLEX 6
-#define __SINGLE_PRECISION_COMPLEX_Z 7
-#define __DOUBLE_PRECISION_COMPLEX_Z 8
-
-#define __SLAB 10
-
-
- MODULE ppm_module_fdsolver_fft_bd
-
- !----------------------------------------------------------------------
- ! Define interface to ppm_fdsolver_fft_bd
- !----------------------------------------------------------------------
- INTERFACE ppm_fdsolver_fft_bd_slab
- MODULE PROCEDURE ppm_fdsolver_fft_bd_slab_3ds
- MODULE PROCEDURE ppm_fdsolver_fft_bd_slab_3dd
- END INTERFACE
-
- INTERFACE ppm_fdsolver_fft_bd
- MODULE PROCEDURE ppm_fdsolver_fft_bd_2ds
- MODULE PROCEDURE ppm_fdsolver_fft_bd_2dd
- MODULE PROCEDURE ppm_fdsolver_fft_bd_2dc
- MODULE PROCEDURE ppm_fdsolver_fft_bd_2dcc
-
- MODULE PROCEDURE ppm_fdsolver_fft_bd_3ds
- MODULE PROCEDURE ppm_fdsolver_fft_bd_3dd
- MODULE PROCEDURE ppm_fdsolver_fft_bd_3dc
- MODULE PROCEDURE ppm_fdsolver_fft_bd_3dcc
- END INTERFACE
-
- INTERFACE ppm_fdsolver_fft_bd_z
- MODULE PROCEDURE ppm_fdsolver_fft_bd_z_3dc
- MODULE PROCEDURE ppm_fdsolver_fft_bd_z_3dcc
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __CASE __SLAB
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_fft_bd_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_fft_bd_3d.f"
-#undef __KIND
-
-#undef __CASE
-
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_fft_bd_2d.f"
-#include "ppm_fdsolver_fft_bd_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_fft_bd_2d.f"
-#include "ppm_fdsolver_fft_bd_3d.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_fdsolver_fft_bd_2d.f"
-#include "ppm_fdsolver_fft_bd_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_fdsolver_fft_bd_2d.f"
-#include "ppm_fdsolver_fft_bd_3d.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX_Z
-#include "ppm_fdsolver_fft_bd_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX_Z
-#include "ppm_fdsolver_fft_bd_3d.f"
-#undef __KIND
-
- END MODULE ppm_module_fdsolver_fft_bd
diff --git a/src/ppm_module_fdsolver_fft_fd.f b/src/ppm_module_fdsolver_fft_fd.f
deleted file mode 100644
index 8fd1b198d5e97a62b596f6f29a4c7a2a2c3b8b5d..0000000000000000000000000000000000000000
--- a/src/ppm_module_fdsolver_fft_fd.f
+++ /dev/null
@@ -1,141 +0,0 @@
-#ifdef __XLF
-@PROCESS NOHOT
-#endif
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fdsolver_fft_fd
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the fft
- ! routines
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fdsolver_fft_fd.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/02/16 12:07:09 hiebers
- ! initial implementation
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 5
-#define __DOUBLE_PRECISION_COMPLEX 6
-#define __SINGLE_PRECISION_COMPLEX_Z 7
-#define __DOUBLE_PRECISION_COMPLEX_Z 8
-
-#define __SLAB 10
-
- MODULE ppm_module_fdsolver_fft_fd
-
- !----------------------------------------------------------------------
- ! Define interface to ppm_fdsolver_fft_fd
- !----------------------------------------------------------------------
- INTERFACE ppm_fdsolver_fft_fd_slab
- MODULE PROCEDURE ppm_fdsolver_fft_fd_slab_3ds
- MODULE PROCEDURE ppm_fdsolver_fft_fd_slab_3dd
- END INTERFACE
-
- INTERFACE ppm_fdsolver_fft_fd
- MODULE PROCEDURE ppm_fdsolver_fft_fd_2ds
- MODULE PROCEDURE ppm_fdsolver_fft_fd_2dd
- MODULE PROCEDURE ppm_fdsolver_fft_fd_2dc
- MODULE PROCEDURE ppm_fdsolver_fft_fd_2dcc
-
- MODULE PROCEDURE ppm_fdsolver_fft_fd_3ds
- MODULE PROCEDURE ppm_fdsolver_fft_fd_3dd
- MODULE PROCEDURE ppm_fdsolver_fft_fd_3dc
- MODULE PROCEDURE ppm_fdsolver_fft_fd_3dcc
- END INTERFACE
-
- INTERFACE ppm_fdsolver_fft_fd_z
- MODULE PROCEDURE ppm_fdsolver_fft_fd_z_3dc
- MODULE PROCEDURE ppm_fdsolver_fft_fd_z_3dcc
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __CASE __SLAB
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_fft_fd_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_fft_fd_3d.f"
-#undef __KIND
-
-#undef __CASE
-
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_fft_fd_2d.f"
-#include "ppm_fdsolver_fft_fd_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_fft_fd_2d.f"
-#include "ppm_fdsolver_fft_fd_3d.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_fdsolver_fft_fd_2d.f"
-#include "ppm_fdsolver_fft_fd_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_fdsolver_fft_fd_2d.f"
-#include "ppm_fdsolver_fft_fd_3d.f"
-#undef __KIND
-
-
-
-#define __KIND __SINGLE_PRECISION_COMPLEX_Z
-#include "ppm_fdsolver_fft_fd_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX_Z
-#include "ppm_fdsolver_fft_fd_3d.f"
-#undef __KIND
-
- END MODULE ppm_module_fdsolver_fft_fd
diff --git a/src/ppm_module_fdsolver_finalize.f b/src/ppm_module_fdsolver_finalize.f
deleted file mode 100644
index 639c740264fbb3a9e982d56eb1b49b8a30a0c983..0000000000000000000000000000000000000000
--- a/src/ppm_module_fdsolver_finalize.f
+++ /dev/null
@@ -1,69 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fdsolver_finalize
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for field solver
- ! routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-
-
-
-
- MODULE ppm_module_fdsolver_finalize
-
- !----------------------------------------------------------------------
- ! Define interface to ppm_fdsolver_finalize
- !----------------------------------------------------------------------
- INTERFACE ppm_fdsolver_finalize
- MODULE PROCEDURE ppm_fdsolver_finalize
- END INTERFACE
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-
-
-#include "ppm_fdsolver_finalize.f"
-
- END MODULE ppm_module_fdsolver_finalize
diff --git a/src/ppm_module_fdsolver_init.f b/src/ppm_module_fdsolver_init.f
deleted file mode 100644
index 8bf3daa6ee9c646baa6bd24206468f36c539218c..0000000000000000000000000000000000000000
--- a/src/ppm_module_fdsolver_init.f
+++ /dev/null
@@ -1,131 +0,0 @@
-#ifdef __XLF
-@PROCESS NOHOT
-#endif
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fdsolver_solve
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for field solver
- ! routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __COMPLEX 3
-#define __DOUBLE_COMPLEX 4
-
-#define __SFIELD 9
-#define __VFIELD 10
-
-#define __2D 22
-#define __3D 33
-
-
- MODULE ppm_module_fdsolver_init
-
- !----------------------------------------------------------------------
- ! Define interface to ppm_fdsolver_init
- !----------------------------------------------------------------------
- INTERFACE ppm_fdsolver_init
- MODULE PROCEDURE ppm_fdsolver_init_2d_sca_s
- MODULE PROCEDURE ppm_fdsolver_init_2d_sca_d
- MODULE PROCEDURE ppm_fdsolver_init_2d_vec_s
- MODULE PROCEDURE ppm_fdsolver_init_2d_vec_d
- MODULE PROCEDURE ppm_fdsolver_init_3d_sca_s
- MODULE PROCEDURE ppm_fdsolver_init_3d_sca_d
- MODULE PROCEDURE ppm_fdsolver_init_3d_vec_s
- MODULE PROCEDURE ppm_fdsolver_init_3d_vec_d
- END INTERFACE
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __MESH_DIM __2D
-#define __DIM __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_init.f"
-#undef __KIND
-#undef __DIM
-
-
-#define __DIM __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_init.f"
-#undef __KIND
-#undef __DIM
-#undef __MESH_DIM
-
-
-
-
-#define __MESH_DIM __3D
-#define __DIM __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_init.f"
-#undef __KIND
-#undef __DIM
-
-
-#define __DIM __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_init.f"
-#undef __KIND
-#undef __DIM
-#undef __MESH_DIM
-
-
- END MODULE ppm_module_fdsolver_init
diff --git a/src/ppm_module_fdsolver_map.f b/src/ppm_module_fdsolver_map.f
deleted file mode 100644
index d525ac9f9cb481038c607a21f7cc45ddbbd98a7a..0000000000000000000000000000000000000000
--- a/src/ppm_module_fdsolver_map.f
+++ /dev/null
@@ -1,133 +0,0 @@
-#ifdef __XLF
-@PROCESS NOHOT
-#endif
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fdsolver
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for field solver
- ! routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __COMPLEX 3
-#define __DOUBLE_COMPLEX 4
-
-#define __SFIELD 9
-#define __VFIELD 10
-
-
-
- MODULE ppm_module_fdsolver_map
-
- !----------------------------------------------------------------------
- ! Define interface to ppm_fdsolver_map
- !----------------------------------------------------------------------
- INTERFACE ppm_fdsolver_map
- MODULE PROCEDURE ppm_fdsolver_map_2d_sca_s
- MODULE PROCEDURE ppm_fdsolver_map_2d_sca_d
- MODULE PROCEDURE ppm_fdsolver_map_2d_sca_c
- MODULE PROCEDURE ppm_fdsolver_map_2d_sca_cc
- MODULE PROCEDURE ppm_fdsolver_map_2d_vec_s
- MODULE PROCEDURE ppm_fdsolver_map_2d_vec_d
- MODULE PROCEDURE ppm_fdsolver_map_2d_vec_c
- MODULE PROCEDURE ppm_fdsolver_map_2d_vec_cc
- MODULE PROCEDURE ppm_fdsolver_map_3d_sca_s
- MODULE PROCEDURE ppm_fdsolver_map_3d_sca_d
- MODULE PROCEDURE ppm_fdsolver_map_3d_sca_c
- MODULE PROCEDURE ppm_fdsolver_map_3d_sca_cc
- MODULE PROCEDURE ppm_fdsolver_map_3d_vec_s
- MODULE PROCEDURE ppm_fdsolver_map_3d_vec_d
- MODULE PROCEDURE ppm_fdsolver_map_3d_vec_c
- MODULE PROCEDURE ppm_fdsolver_map_3d_vec_cc
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_map_2d.f"
-#include "ppm_fdsolver_map_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_map_2d.f"
-#include "ppm_fdsolver_map_3d.f"
-#undef __KIND
-
-#define __KIND __COMPLEX
-#include "ppm_fdsolver_map_2d.f"
-#include "ppm_fdsolver_map_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_COMPLEX
-#include "ppm_fdsolver_map_2d.f"
-#include "ppm_fdsolver_map_3d.f"
-#undef __KIND
-#undef __DIM
-
-
-#define __DIM __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_map_2d.f"
-#include "ppm_fdsolver_map_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_map_2d.f"
-#include "ppm_fdsolver_map_3d.f"
-#undef __KIND
-
-#define __KIND __COMPLEX
-#include "ppm_fdsolver_map_2d.f"
-#include "ppm_fdsolver_map_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_COMPLEX
-#include "ppm_fdsolver_map_2d.f"
-#include "ppm_fdsolver_map_3d.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_fdsolver_map
diff --git a/src/ppm_module_fdsolver_poisson.f b/src/ppm_module_fdsolver_poisson.f
deleted file mode 100644
index ef0747f3a0bb84571feb9ca62926d7fe8858ac37..0000000000000000000000000000000000000000
--- a/src/ppm_module_fdsolver_poisson.f
+++ /dev/null
@@ -1,82 +0,0 @@
-#ifdef __XLF
-@PROCESS NOHOT
-#endif
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fdsolver_poisson
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for field solver
- ! routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __COMPLEX 3
-#define __DOUBLE_COMPLEX 4
-
-
-
- MODULE ppm_module_fdsolver_poisson
-
- INTERFACE ppm_fdsolver_poisson
- MODULE PROCEDURE ppm_fdsolver_poisson_2dc
- MODULE PROCEDURE ppm_fdsolver_poisson_2dcc
- MODULE PROCEDURE ppm_fdsolver_poisson_3dc
- MODULE PROCEDURE ppm_fdsolver_poisson_3dcc
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KIND __COMPLEX
-#include "ppm_fdsolver_poisson_2d.f"
-#include "ppm_fdsolver_poisson_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_COMPLEX
-#include "ppm_fdsolver_poisson_2d.f"
-#include "ppm_fdsolver_poisson_3d.f"
-#undef __KIND
-
-
-
- END MODULE ppm_module_fdsolver_poisson
diff --git a/src/ppm_module_fdsolver_solve.f b/src/ppm_module_fdsolver_solve.f
deleted file mode 100644
index 7447b0a5bfed6f21ee2150cd6456894e91519841..0000000000000000000000000000000000000000
--- a/src/ppm_module_fdsolver_solve.f
+++ /dev/null
@@ -1,188 +0,0 @@
-#include "ppm_define.h"
-#ifdef __XLF
-@PROCESS NOOPT
-#endif
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fdsolver_solve
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for field solver
- ! routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __COMPLEX 3
-#define __DOUBLE_COMPLEX 4
-
-#define __SFIELD 9
-#define __VFIELD 10
-
-#define __INIT 11
-#define __SLAB 12
-
-
- MODULE ppm_module_fdsolver_solve
-
- !----------------------------------------------------------------------
- ! Define interface to ppm_fdsolver_solve
- !----------------------------------------------------------------------
-
- INTERFACE ppm_fdsolver_solve_slab
- MODULE PROCEDURE ppm_fdsolver_solve_slab_3d_ss
- MODULE PROCEDURE ppm_fdsolver_solve_slab_3d_sd
- MODULE PROCEDURE ppm_fdsolver_solve_slab_3d_vs
- MODULE PROCEDURE ppm_fdsolver_solve_slab_3d_vd
- END INTERFACE
-
- INTERFACE ppm_fdsolver_solve_init
- MODULE PROCEDURE ppm_fdsolver_solve_init_2d_ss
- MODULE PROCEDURE ppm_fdsolver_solve_init_2d_sd
- MODULE PROCEDURE ppm_fdsolver_solve_init_2d_vs
- MODULE PROCEDURE ppm_fdsolver_solve_init_2d_vd
- MODULE PROCEDURE ppm_fdsolver_solve_init_3d_ss
- MODULE PROCEDURE ppm_fdsolver_solve_init_3d_sd
- MODULE PROCEDURE ppm_fdsolver_solve_init_3d_vs
- MODULE PROCEDURE ppm_fdsolver_solve_init_3d_vd
- END INTERFACE
-
-
- INTERFACE ppm_fdsolver_solve
- MODULE PROCEDURE ppm_fdsolver_solve_2d_ss
- MODULE PROCEDURE ppm_fdsolver_solve_2d_sd
- MODULE PROCEDURE ppm_fdsolver_solve_2d_vs
- MODULE PROCEDURE ppm_fdsolver_solve_2d_vd
- MODULE PROCEDURE ppm_fdsolver_solve_3d_ss
- MODULE PROCEDURE ppm_fdsolver_solve_3d_sd
- MODULE PROCEDURE ppm_fdsolver_solve_3d_vs
- MODULE PROCEDURE ppm_fdsolver_solve_3d_vd
- END INTERFACE
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __CASE __SLAB
-
-#define __DIM __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-#undef __DIM
-
-
-
-#define __DIM __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-#undef __DIM
-
-#undef __CASE
-
-#define __CASE __INIT
-
-#define __DIM __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_solve_2d.f"
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_solve_2d.f"
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-#undef __DIM
-
-
-
-#define __DIM __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_solve_2d.f"
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_solve_2d.f"
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-#undef __DIM
-
-#undef __CASE
-
-
-
-
-#define __DIM __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_solve_2d.f"
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_solve_2d.f"
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-#undef __DIM
-
-
-
-#define __DIM __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fdsolver_solve_2d.f"
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fdsolver_solve_2d.f"
-#include "ppm_fdsolver_solve_3d.f"
-#undef __KIND
-#undef __DIM
-
-
- END MODULE ppm_module_fdsolver_solve
diff --git a/src/ppm_module_fft.f b/src/ppm_module_fft.f
deleted file mode 100644
index 2324e2950e1b81db53ef24f1a576a5c814796fed..0000000000000000000000000000000000000000
--- a/src/ppm_module_fft.f
+++ /dev/null
@@ -1,161 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_module_fft
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! This modules contains routines for creating FFTW plans and executing them
- ! Plan routines are required for
- ! z means fft in x (1D)
- ! xy means fft in xy (2D)
- ! xyz means fft in xyz (3D)
- ! sca means scalar
- ! vec means vector
- ! f means forward fft
- ! b means backward fft
- ! c means complex
- ! r means real
- ! s means single precision
- ! d means double precision
- !
- ! e.g. 3d_vec_fr2c_xy_d: 3D vector array forward transform from
- ! real to complex and ffts in x and y directions
- ! (2d). For double data
- !
- ! The following variants have been implemented
- ! 3d_vec_fc2c_z_d
- ! 3d_vec_bc2c_z_d
- ! 3d_vec_fr2c_xy_d
- ! 3d_vec_bc2r_xy_d
- !
- ! a normalization routine exists for debugging purposes
- !
- ! sofar all fftw calls are to double precision routines!
- !
- ! All IFFT routines should be called with the 'realest' topoid/meshid
- !
- ! The routines respects the periodic N+1 points periodic BC cf topo%bcdef
- ! but also does full domain FFTs for freespace BC
- ! It does not work on mixed periodic/freespace BC in the XY direction
- ! topo%bcdef(1) is assumed to be in x, (2) to be in y, (3) z, (4) x...
- !-------------------------------------------------------------------------
-#define __SINGLE 0
-#define __DOUBLE 1
-
- MODULE ppm_module_fft
- !-------------------------------------------------------------------------
- ! 1D transforms
- !-------------------------------------------------------------------------
- INTERFACE ppm_fft_forward_1d
- MODULE PROCEDURE ppm_fft_plan_3d_vec_fc2c_z_s
- MODULE PROCEDURE ppm_fft_plan_3d_vec_fc2c_z_d
- END INTERFACE
-
- INTERFACE ppm_fft_backward_1d
- MODULE PROCEDURE ppm_fft_plan_3d_vec_bc2c_z_s
- MODULE PROCEDURE ppm_fft_plan_3d_vec_bc2c_z_d
- END INTERFACE
-
- INTERFACE ppm_fft_execute_1d
- MODULE PROCEDURE ppm_fft_exec_3d_vec_c2c_z_s
- MODULE PROCEDURE ppm_fft_exec_3d_vec_c2c_z_d
- END INTERFACE
-
- !-------------------------------------------------------------------------
- ! 2D transforms
- !-------------------------------------------------------------------------
- INTERFACE ppm_fft_forward_2d
- MODULE PROCEDURE ppm_fft_plan_3d_vec_fr2c_xy_s
- MODULE PROCEDURE ppm_fft_plan_3d_vec_fr2c_xy_d
- END INTERFACE
-
- INTERFACE ppm_fft_backward_2d
- MODULE PROCEDURE ppm_fft_plan_3d_vec_bc2r_xy_s
- MODULE PROCEDURE ppm_fft_plan_3d_vec_bc2r_xy_d
- END INTERFACE
-
- INTERFACE ppm_fft_execute_2d
- MODULE PROCEDURE ppm_fft_exec_3d_vec_fr2c_xy_s
- MODULE PROCEDURE ppm_fft_exec_3d_vec_bc2r_xy_s
- MODULE PROCEDURE ppm_fft_exec_3d_vec_fr2c_xy_d
- MODULE PROCEDURE ppm_fft_exec_3d_vec_bc2r_xy_d
- END INTERFACE
-
- !-------------------------------------------------------------------------
- ! Normalization
- !-------------------------------------------------------------------------
- INTERFACE ppm_fft_normalize
- MODULE PROCEDURE ppm_fft_normalize_rs
- MODULE PROCEDURE ppm_fft_normalize_cs
- MODULE PROCEDURE ppm_fft_normalize_rd
- MODULE PROCEDURE ppm_fft_normalize_cd
- END INTERFACE
-
- !-------------------------------------------------------------------------
- ! PPM FFT plan type
- !-------------------------------------------------------------------------
- !!! Type containing the FFTW plan and its settings
- TYPE ppm_fft_plan
- !!!array of plan pointers, index for subs
- INTEGER*8,DIMENSION(:),POINTER :: plan => NULL()
- !!!the dimension of the FFT (1D/2D/3D)
- INTEGER :: rank
- !!!number of points along each direction of the piece to be transformed
- !!!index is for rank and subs
- INTEGER,DIMENSION(:,:),POINTER :: nx
- !!!the direction of the transform (forward/backward)
- INTEGER :: sign
- !!!the method to setup the optimal plan
- INTEGER :: flag
- !!!the number of components to transform
- INTEGER :: howmany
- !!!the size of the input array, index is for rank
- INTEGER,DIMENSION(:),POINTER :: inembed
- !!!the size of the output array, index is for rank
- INTEGER,DIMENSION(:),POINTER :: onembed
- !!!istride tells how same component data points are spaced in memory
- INTEGER :: istride
- INTEGER :: ostride
- !!!idist tells how multiple arrays are spaced. I.e. a memory offset
- INTEGER :: idist
- INTEGER :: odist
- END TYPE ppm_fft_plan
-
- CONTAINS
-#define __KIND __SINGLE
-
- !FORWARD TRANSFORMS - PLAN
-#include "fft/ppm_fft_plan_3d_vec_fc2c_z.f"
-#include "fft/ppm_fft_plan_3d_vec_fr2c_xy.f"
- !BACKWARD TRANSFORMS - PLAN
-#include "fft/ppm_fft_plan_3d_vec_bc2c_z.f"
-#include "fft/ppm_fft_plan_3d_vec_bc2r_xy.f"
- !EXECUTION OF PLANS
-#include "fft/ppm_fft_exec_3d_vec_c2c_z.f"
-#include "fft/ppm_fft_exec_3d_vec_fr2c_xy.f"
-#include "fft/ppm_fft_exec_3d_vec_bc2r_xy.f"
- !NORMALIZATION
-#include "fft/ppm_fft_normalize_r.f"
-#include "fft/ppm_fft_normalize_c.f"
-
-#undef __KIND
-#define __KIND __DOUBLE
-
- !FORWARD TRANSFORMS - PLAN
-#include "fft/ppm_fft_plan_3d_vec_fc2c_z.f"
-#include "fft/ppm_fft_plan_3d_vec_fr2c_xy.f"
- !BACKWARD TRANSFORMS - PLAN
-#include "fft/ppm_fft_plan_3d_vec_bc2c_z.f"
-#include "fft/ppm_fft_plan_3d_vec_bc2r_xy.f"
- !EXECUTION OF PLANS
-#include "fft/ppm_fft_exec_3d_vec_c2c_z.f"
-#include "fft/ppm_fft_exec_3d_vec_fr2c_xy.f"
-#include "fft/ppm_fft_exec_3d_vec_bc2r_xy.f"
- !NORMALIZATION
-#include "fft/ppm_fft_normalize_r.f"
-#include "fft/ppm_fft_normalize_c.f"
-
-#undef __KIND
- END MODULE ppm_module_fft
-
-
diff --git a/src/ppm_module_fieldsolver.f b/src/ppm_module_fieldsolver.f
deleted file mode 100644
index 5c69271b52fcfa1af890de865c0c8618bc2ffdd1..0000000000000000000000000000000000000000
--- a/src/ppm_module_fieldsolver.f
+++ /dev/null
@@ -1,38 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fieldsolver
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module contains the user-callable functions of
- ! the FFT-based fieldsolver.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fieldsolver.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2004/07/26 13:40:29 ivos
- ! Initial implementation. These are meta-modules for the user-
- ! callable functions. Only these mod files will be given away
- ! to the user.
- !
- !-------------------------------------------------------------------------
- ! Perallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_fieldsolver
-
- !----------------------------------------------------------------------
- ! PPM modules
- !----------------------------------------------------------------------
- USE ppm_module_fdsolver_poisson
- USE ppm_module_fdsolver_solve
-
- END MODULE ppm_module_fieldsolver
diff --git a/src/ppm_module_fmm.f b/src/ppm_module_fmm.f
deleted file mode 100644
index f618e128b2b8aa2489791d63c59cf8a8b30aed82..0000000000000000000000000000000000000000
--- a/src/ppm_module_fmm.f
+++ /dev/null
@@ -1,43 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fmm
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module contains the user-callable functions of
- ! the fmm.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fmm.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2005/09/19 13:03:31 polasekb
- ! code cosmetics
- !
- ! Revision 1.1 2005/05/27 07:55:59 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/16 15:31:00 polasekb
- ! start
- !-------------------------------------------------------------------------
- ! Perallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_fmm
-
- !----------------------------------------------------------------------
- ! PPM modules
- !----------------------------------------------------------------------
- USE ppm_module_fmm_init
- USE ppm_module_fmm_finalize
- USE ppm_module_fmm_expansion
- USE ppm_module_fmm_potential
-
- END MODULE ppm_module_fmm
diff --git a/src/ppm_module_fmm_expansion.f b/src/ppm_module_fmm_expansion.f
deleted file mode 100644
index 6899ae37c7a7bc5b59908f2c6d19b5d687adcfef..0000000000000000000000000000000000000000
--- a/src/ppm_module_fmm_expansion.f
+++ /dev/null
@@ -1,108 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fmm_expansion
- !-------------------------------------------------------------------------
- !
- ! Purpose : fast multipole method module, expansion routine
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fmm_expansion.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2006/06/29 10:28:36 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.2 2005/09/19 13:03:30 polasekb
- ! code cosmetics
- !
- ! Revision 1.1 2005/05/27 07:57:11 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/25 16:38:33 polasekb
- ! Start
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-!#define __INTEGER 3
-!#define __LOGICAL 4
-!#define __2D 7
-!#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_fmm_expansion
-
- !-----------------------------------------------------------------------------
- ! Define Interface
- !-----------------------------------------------------------------------------
-
- INTERFACE ppm_fmm_expansion
- MODULE PROCEDURE ppm_fmm_expansion_s_sf
- MODULE PROCEDURE ppm_fmm_expansion_d_sf
- MODULE PROCEDURE ppm_fmm_expansion_s_vf
- MODULE PROCEDURE ppm_fmm_expansion_d_vf
- END INTERFACE
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __SFIELD
-#include "ppm_fmm_expansion.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_expansion.f"
-#undef __KIND
-#undef __DIM
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __VFIELD
-#include "ppm_fmm_expansion.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_expansion.f"
-#undef __KIND
-#undef __DIM
-
-
-END MODULE ppm_module_fmm_expansion
-
diff --git a/src/ppm_module_fmm_expchange.f b/src/ppm_module_fmm_expchange.f
deleted file mode 100644
index 926c5f61d496634cae3853309b243ac904203cc0..0000000000000000000000000000000000000000
--- a/src/ppm_module_fmm_expchange.f
+++ /dev/null
@@ -1,109 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fmm_expchange
- !-------------------------------------------------------------------------
- !
- ! Purpose : fast multipole method module, expchange routine
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fmm_expchange.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.4 2006/06/29 10:28:37 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.3 2005/09/19 13:03:31 polasekb
- ! code cosmetics
- !
- ! Revision 1.2 2005/08/23 14:30:54 polasekb
- ! now making difference between single/double precision
- !
- ! Revision 1.1 2005/05/27 07:58:29 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/11 16:38:33 polasekb
- ! Start
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-!#define __INTEGER 3
-!#define __LOGICAL 4
-!#define __2D 7
-!#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_fmm_expchange
-
- !-----------------------------------------------------------------------------
- ! Define Interface
- !-----------------------------------------------------------------------------
-
- INTERFACE ppm_fmm_expchange
- MODULE PROCEDURE ppm_fmm_expchange_s_sf
- MODULE PROCEDURE ppm_fmm_expchange_d_sf
- MODULE PROCEDURE ppm_fmm_expchange_s_vf
- MODULE PROCEDURE ppm_fmm_expchange_d_vf
- END INTERFACE
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __SFIELD
-#include "ppm_fmm_expchange.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_expchange.f"
-#undef __KIND
-#undef __DIM
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __VFIELD
-#include "ppm_fmm_expchange.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_expchange.f"
-#undef __KIND
-#undef __DIM
-
-END MODULE ppm_module_fmm_expchange
-
diff --git a/src/ppm_module_fmm_finalize.f b/src/ppm_module_fmm_finalize.f
deleted file mode 100644
index 6a2c0cfb69a7e174e06e58baebd64a8b48fdd2a8..0000000000000000000000000000000000000000
--- a/src/ppm_module_fmm_finalize.f
+++ /dev/null
@@ -1,86 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fmm_finalize
- !-------------------------------------------------------------------------
- !
- ! Purpose : fast multipole method finalize module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fmm_finalize.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.5 2006/06/29 10:28:37 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.3 2005/08/23 14:23:43 polasekb
- ! no difference between single/double
- !
- ! Revision 1.2 2005/05/27 08:42:39 polasekb
- ! removed dummy argument and single/double call
- !
- ! Revision 1.1 2005/05/27 08:03:09 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/11 16:35:45 polasekb
- ! Start
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-!#define __INTEGER 3
-!#define __LOGICAL 4
-!#define __2D 7
-!#define __3D 8
-!#define __SFIELD 9
-!#define __VFIELD 10
-
-MODULE ppm_module_fmm_finalize
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
- !-----------------------------------------------------------------------------
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
- CONTAINS
-
-#include "ppm_fmm_finalize.f"
-
-END MODULE ppm_module_fmm_finalize
-
diff --git a/src/ppm_module_fmm_init.f b/src/ppm_module_fmm_init.f
deleted file mode 100644
index 2485468e01f07cd75816194d0c2f66ccc3908cc7..0000000000000000000000000000000000000000
--- a/src/ppm_module_fmm_init.f
+++ /dev/null
@@ -1,107 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fmm_init
- !-------------------------------------------------------------------------
- !
- ! Purpose : fast multipole method module, initialization routine
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fmm_init.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2006/06/29 10:28:37 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.2 2005/09/19 13:03:32 polasekb
- ! code cosmetics
- !
- ! Revision 1.1 2005/05/27 07:55:20 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/11 16:38:33 polasekb
- ! Start
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-!#define __INTEGER 3
-!#define __LOGICAL 4
-!#define __2D 7
-!#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_fmm_init
-
- !-----------------------------------------------------------------------------
- ! Define Interface
- !-----------------------------------------------------------------------------
-
- INTERFACE ppm_fmm_init
- MODULE PROCEDURE ppm_fmm_init_s_sf
- MODULE PROCEDURE ppm_fmm_init_d_sf
- MODULE PROCEDURE ppm_fmm_init_s_vf
- MODULE PROCEDURE ppm_fmm_init_d_vf
- END INTERFACE
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __SFIELD
-#include "ppm_fmm_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_init.f"
-#undef __KIND
-#undef __DIM
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __VFIELD
-#include "ppm_fmm_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_init.f"
-#undef __KIND
-#undef __DIM
-
-
-END MODULE ppm_module_fmm_init
diff --git a/src/ppm_module_fmm_potential.f b/src/ppm_module_fmm_potential.f
deleted file mode 100644
index dd67da2640ab72664f9969b2b516c274b8615645..0000000000000000000000000000000000000000
--- a/src/ppm_module_fmm_potential.f
+++ /dev/null
@@ -1,107 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fmm_potential
- !-------------------------------------------------------------------------
- !
- ! Purpose : fast multipole method module, potential routine
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fmm_potential.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2006/06/29 10:28:37 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.2 2005/09/19 13:03:32 polasekb
- ! code cosmetics
- !
- ! Revision 1.1 2005/05/27 08:01:48 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/11/25 16:38:33 polasekb
- ! Start
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-!#define __INTEGER 3
-!#define __LOGICAL 4
-!#define __2D 7
-!#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_fmm_potential
-
- !----------------------------------------------------------------------------
- ! Define Interface
- !-----------------------------------------------------------------------------
-
- INTERFACE ppm_fmm_potential
- MODULE PROCEDURE ppm_fmm_potential_s_sf
- MODULE PROCEDURE ppm_fmm_potential_d_sf
- MODULE PROCEDURE ppm_fmm_potential_s_vf
- MODULE PROCEDURE ppm_fmm_potential_d_vf
- END INTERFACE
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __SFIELD
-#include "ppm_fmm_potential.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_potential.f"
-#undef __KIND
-#undef __DIM
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __VFIELD
-#include "ppm_fmm_potential.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_potential.f"
-#undef __KIND
-#undef __DIM
-
-
-END MODULE ppm_module_fmm_potential
-
diff --git a/src/ppm_module_fmm_pretraverse.f b/src/ppm_module_fmm_pretraverse.f
deleted file mode 100644
index 7276724a13ea415de9de682a061def9e1e3d9263..0000000000000000000000000000000000000000
--- a/src/ppm_module_fmm_pretraverse.f
+++ /dev/null
@@ -1,91 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fmm_pretraverse
- !-------------------------------------------------------------------------
- !
- ! Purpose : module for pretraverse
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fmm_pretraverse.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2006/06/29 10:28:37 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.2 2005/09/19 13:03:32 polasekb
- ! code cosmetics
- !
- ! Revision 1.1 2005/05/27 08:04:36 polasekb
- ! initial implementation
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-!#define __INTEGER 3
-!#define __LOGICAL 4
-!#define __2D 7
-!#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_fmm_pretraverse
-
- !-----------------------------------------------------------------------------
- ! Define Interface
- !-----------------------------------------------------------------------------
-
- INTERFACE ppm_fmm_pretraverse
- MODULE PROCEDURE ppm_fmm_pretraverse_s
- MODULE PROCEDURE ppm_fmm_pretraverse_d
- END INTERFACE
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_fmm_pretraverse.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_pretraverse.f"
-#undef __KIND
-
-END MODULE ppm_module_fmm_pretraverse
-
-
diff --git a/src/ppm_module_fmm_traverse.f b/src/ppm_module_fmm_traverse.f
deleted file mode 100644
index eb1d69a05969ba7b5fa7784c7b0e1abf55087bda..0000000000000000000000000000000000000000
--- a/src/ppm_module_fmm_traverse.f
+++ /dev/null
@@ -1,113 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_fmm_traverse
- !-------------------------------------------------------------------------
- !
- ! Purpose : fast multipole method module, tree traversing routine
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_fmm_traverse.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.5 2006/06/29 10:28:38 pchatela
- ! Added vector strengths support
- !
- ! Revision 1.4 2005/09/19 13:03:32 polasekb
- ! code cosmetics
- !
- ! Revision 1.3 2005/08/04 16:01:59 polasekb
- ! now really checking whether to use single or double prec.
- !
- ! Revision 1.2 2005/07/27 21:11:07 polasekb
- ! adapted to new subroutine call
- !
- ! Revision 1.1 2005/05/27 07:59:57 polasekb
- ! initial implementation
- !
- ! Revision 0 2004/12/02 15:38:33 polasekb
- ! Start
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-!#define __INTEGER 3
-!#define __LOGICAL 4
-!#define __2D 7
-!#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_fmm_traverse
-
- !-----------------------------------------------------------------------------
- ! Define Interface
- !-----------------------------------------------------------------------------
-
- INTERFACE ppm_fmm_traverse
- MODULE PROCEDURE ppm_fmm_traverse_s_sf
- MODULE PROCEDURE ppm_fmm_traverse_d_sf
- MODULE PROCEDURE ppm_fmm_traverse_s_vf
- MODULE PROCEDURE ppm_fmm_traverse_d_vf
- END INTERFACE
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __SFIELD
-#include "ppm_fmm_traverse.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_traverse.f"
-#undef __KIND
-#undef __DIM
-
-#define __KIND __SINGLE_PRECISION
-#define __DIM __VFIELD
-#include "ppm_fmm_traverse.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_fmm_traverse.f"
-#undef __KIND
-#undef __DIM
-
-
-END MODULE ppm_module_fmm_traverse
-
diff --git a/src/ppm_module_gmm.f b/src/ppm_module_gmm.f
deleted file mode 100644
index c02eece54ff8dd63e54021dc389e44cf5ca10269..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm.f
+++ /dev/null
@@ -1,47 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module contains all user-callable routines
- ! needed for the group marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2005/03/12 04:08:36 ivos
- ! Misc bug fixes.
- !
- ! Revision 1.2 2005/03/11 04:17:59 ivos
- ! Added ppm_gmm_extend and ppm_gmm_reinitialize.
- !
- ! Revision 1.1 2005/03/10 01:37:16 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Perallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_gmm
-
- !----------------------------------------------------------------------
- ! PPM modules
- !----------------------------------------------------------------------
- USE ppm_module_gmm_init
- USE ppm_module_gmm_kickoff
- USE ppm_module_gmm_march
- USE ppm_module_gmm_cpt
- USE ppm_module_gmm_reinitialize
- USE ppm_module_gmm_extend
- USE ppm_module_gmm_finalize
-
- END MODULE ppm_module_gmm
diff --git a/src/ppm_module_gmm_cpt.f b/src/ppm_module_gmm_cpt.f
deleted file mode 100644
index 77ac4fddd5795d02f14808d721c221506e3e9967..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_cpt.f
+++ /dev/null
@@ -1,95 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_cpt
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! cpt routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_cpt.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2005/04/21 04:48:24 ivos
- ! Cleaned interfaces and removed unnecessary overloaded versions.
- !
- ! Revision 1.1 2005/03/11 21:09:10 ivos
- ! Initial implementation.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-
- MODULE ppm_module_gmm_cpt
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_cpt
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_cpt
- MODULE PROCEDURE ppm_gmm_cpt_2ds
- MODULE PROCEDURE ppm_gmm_cpt_2dd
- MODULE PROCEDURE ppm_gmm_cpt_3ds
- MODULE PROCEDURE ppm_gmm_cpt_3dd
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_cpt.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_cpt.f"
-#undef __KIND
-#undef __DIM
-
-#define __DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_cpt.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_cpt.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_gmm_cpt
diff --git a/src/ppm_module_gmm_extend.f b/src/ppm_module_gmm_extend.f
deleted file mode 100644
index b70f6bf978e6b671ff0fa1f2cc2c418779b97b1d..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_extend.f
+++ /dev/null
@@ -1,204 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_extend
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! extend routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_extend.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.4 2005/04/21 04:48:24 ivos
- ! Cleaned interfaces and removed unnecessary overloaded versions.
- !
- ! Revision 1.3 2005/03/12 04:08:36 ivos
- ! Misc bug fixes.
- !
- ! Revision 1.2 2005/03/11 21:10:08 ivos
- ! Added thresholded extensions and closest point transform.
- !
- ! Revision 1.1 2005/03/11 04:15:59 ivos
- ! Initial implementation.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __VFIELD 3
-#define __SFIELD 4
-#define __2D 5
-#define __3D 6
-#define __YES 7
-#define __NO 8
-
- MODULE ppm_module_gmm_extend
-
- !----------------------------------------------------------------------
- ! Modules
- !----------------------------------------------------------------------
- USE ppm_module_data, ONLY: ppm_kind_single, ppm_kind_double
- PRIVATE :: ppm_kind_single, ppm_kind_double
-
- !----------------------------------------------------------------------
- ! Work memory
- !----------------------------------------------------------------------
- REAL(ppm_kind_single), DIMENSION(:,:,: ), POINTER :: ext_wrk_2ds
- REAL(ppm_kind_single), DIMENSION(:,:,:,:), POINTER :: ext_wrk_3ds
- REAL(ppm_kind_double), DIMENSION(:,:,: ), POINTER :: ext_wrk_2dd
- REAL(ppm_kind_double), DIMENSION(:,:,:,:), POINTER :: ext_wrk_3dd
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_extend
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_extend
- ! 2d scalar and vector field versions with cutoff
- MODULE PROCEDURE ppm_gmm_extend_2d_tsca_s
- MODULE PROCEDURE ppm_gmm_extend_2d_tsca_d
- MODULE PROCEDURE ppm_gmm_extend_2d_tvec_s
- MODULE PROCEDURE ppm_gmm_extend_2d_tvec_d
-
- ! 3d scalar and vector field versions with cutoff
- MODULE PROCEDURE ppm_gmm_extend_3d_tsca_s
- MODULE PROCEDURE ppm_gmm_extend_3d_tsca_d
- MODULE PROCEDURE ppm_gmm_extend_3d_tvec_s
- MODULE PROCEDURE ppm_gmm_extend_3d_tvec_d
-
- ! 2d scalar and vector field versions with function pointer
- MODULE PROCEDURE ppm_gmm_extend_2d_ksca_s
- MODULE PROCEDURE ppm_gmm_extend_2d_ksca_d
- MODULE PROCEDURE ppm_gmm_extend_2d_kvec_s
- MODULE PROCEDURE ppm_gmm_extend_2d_kvec_d
-
- ! 3d scalar and vector field versions with function pointer
- MODULE PROCEDURE ppm_gmm_extend_3d_ksca_s
- MODULE PROCEDURE ppm_gmm_extend_3d_ksca_d
- MODULE PROCEDURE ppm_gmm_extend_3d_kvec_s
- MODULE PROCEDURE ppm_gmm_extend_3d_kvec_d
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KICKOFF __NO
-#define __DIM __2D
-#define __TYPE __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#undef __TYPE
-
-#define __TYPE __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#undef __TYPE
-#undef __DIM
-
-#define __DIM __3D
-#define __TYPE __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#undef __TYPE
-
-#define __TYPE __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#undef __TYPE
-#undef __DIM
-#undef __KICKOFF
-
-#define __KICKOFF __YES
-#define __DIM __2D
-#define __TYPE __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#undef __TYPE
-
-#define __TYPE __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#undef __TYPE
-#undef __DIM
-
-#define __DIM __3D
-#define __TYPE __SFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#undef __TYPE
-
-#define __TYPE __VFIELD
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend.f"
-#undef __KIND
-#undef __TYPE
-#undef __DIM
-#undef __KICKOFF
-
- END MODULE ppm_module_gmm_extend
diff --git a/src/ppm_module_gmm_extend_bkwd.f b/src/ppm_module_gmm_extend_bkwd.f
deleted file mode 100644
index 05e2da3388bff9876d8f40957a67aaec6cd7e087..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_extend_bkwd.f
+++ /dev/null
@@ -1,94 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_extend_bkwd
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! backward extending routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_extend_bkwd.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/05/10 04:41:17 ivos
- ! Newly created during modularization of ppm_gmm_march. Marching
- ! and orthogonal extendion are now in separate routines for faster
- ! compilation.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-
- MODULE ppm_module_gmm_extend_bkwd
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_extend_bkwd
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_extend_bkwd
- MODULE PROCEDURE ppm_gmm_extend_bkwd_2ds
- MODULE PROCEDURE ppm_gmm_extend_bkwd_2dd
- MODULE PROCEDURE ppm_gmm_extend_bkwd_3ds
- MODULE PROCEDURE ppm_gmm_extend_bkwd_3dd
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend_bkwd.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend_bkwd.f"
-#undef __KIND
-#undef __DIM
-
-#define __DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend_bkwd.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend_bkwd.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_gmm_extend_bkwd
diff --git a/src/ppm_module_gmm_extend_fwd.f b/src/ppm_module_gmm_extend_fwd.f
deleted file mode 100644
index 3a0e29cae5d380d7fbe77b4efb4d0efde25a2ef3..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_extend_fwd.f
+++ /dev/null
@@ -1,94 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_extend_fwd
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! forward extending routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_extend_fwd.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/05/10 04:41:17 ivos
- ! Newly created during modularization of ppm_gmm_march. Marching
- ! and orthogonal extendion are now in separate routines for faster
- ! compilation.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-
- MODULE ppm_module_gmm_extend_fwd
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_extend_fwd
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_extend_fwd
- MODULE PROCEDURE ppm_gmm_extend_fwd_2ds
- MODULE PROCEDURE ppm_gmm_extend_fwd_2dd
- MODULE PROCEDURE ppm_gmm_extend_fwd_3ds
- MODULE PROCEDURE ppm_gmm_extend_fwd_3dd
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend_fwd.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend_fwd.f"
-#undef __KIND
-#undef __DIM
-
-#define __DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_extend_fwd.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_extend_fwd.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_gmm_extend_fwd
diff --git a/src/ppm_module_gmm_finalize.f b/src/ppm_module_gmm_finalize.f
deleted file mode 100644
index 94cb0e1c2bd76e00b2b624f618f78196e246ef27..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_finalize.f
+++ /dev/null
@@ -1,65 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_finalize
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! finalization routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_finalize.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/03/10 01:37:16 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_gmm_finalize
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_finalize
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_finalize
- MODULE PROCEDURE ppm_gmm_finalize
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#include "ppm_gmm_finalize.f"
-
- END MODULE ppm_module_gmm_finalize
diff --git a/src/ppm_module_gmm_init.f b/src/ppm_module_gmm_init.f
deleted file mode 100644
index b8cd2f89a5577629af266eeb6bc8963725ffa70f..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_init.f
+++ /dev/null
@@ -1,65 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_init
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! initialization routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_init.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/03/10 01:37:15 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_gmm_init
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_init
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_init
- MODULE PROCEDURE ppm_gmm_init
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#include "ppm_gmm_init.f"
-
- END MODULE ppm_module_gmm_init
diff --git a/src/ppm_module_gmm_kickoff.f b/src/ppm_module_gmm_kickoff.f
deleted file mode 100644
index ccd08e3a8660d6abeeddfae5f572dacfe8d73c9e..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_kickoff.f
+++ /dev/null
@@ -1,95 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_kickoff
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! kickoff routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_kickoff.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2005/04/21 04:48:23 ivos
- ! Cleaned interfaces and removed unnecessary overloaded versions.
- !
- ! Revision 1.1 2005/03/10 01:37:14 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-
- MODULE ppm_module_gmm_kickoff
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_kickoff
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_kickoff
- MODULE PROCEDURE ppm_gmm_kickoff_2ds
- MODULE PROCEDURE ppm_gmm_kickoff_2dd
- MODULE PROCEDURE ppm_gmm_kickoff_3ds
- MODULE PROCEDURE ppm_gmm_kickoff_3dd
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_kickoff.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_kickoff.f"
-#undef __KIND
-#undef __DIM
-
-#define __DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_kickoff.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_kickoff.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_gmm_kickoff
diff --git a/src/ppm_module_gmm_march.f b/src/ppm_module_gmm_march.f
deleted file mode 100644
index fdee1a450ffc4dc4bdbcedb01c84a80ca9f5f4f5..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_march.f
+++ /dev/null
@@ -1,95 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_march
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! marching routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_march.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2005/04/21 04:48:24 ivos
- ! Cleaned interfaces and removed unnecessary overloaded versions.
- !
- ! Revision 1.1 2005/03/10 01:37:14 ivos
- ! Initial check-in. BEWARE: Not tested in parallel yet!
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-
- MODULE ppm_module_gmm_march
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_march
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_march
- MODULE PROCEDURE ppm_gmm_march_2ds
- MODULE PROCEDURE ppm_gmm_march_2dd
- MODULE PROCEDURE ppm_gmm_march_3ds
- MODULE PROCEDURE ppm_gmm_march_3dd
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_march.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_march.f"
-#undef __KIND
-#undef __DIM
-
-#define __DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_march.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_march.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_gmm_march
diff --git a/src/ppm_module_gmm_march_bkwd.f b/src/ppm_module_gmm_march_bkwd.f
deleted file mode 100644
index 3972de019f6e1d8465766db76fa59668ae1474c4..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_march_bkwd.f
+++ /dev/null
@@ -1,92 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_march_bkwd
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! backward marching routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_march_bkwd.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/04/27 01:08:32 ivos
- ! Initial commit, but tested.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-
- MODULE ppm_module_gmm_march_bkwd
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_march_bkwd
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_march_bkwd
- MODULE PROCEDURE ppm_gmm_march_bkwd_2ds
- MODULE PROCEDURE ppm_gmm_march_bkwd_2dd
- MODULE PROCEDURE ppm_gmm_march_bkwd_3ds
- MODULE PROCEDURE ppm_gmm_march_bkwd_3dd
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_march_bkwd.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_march_bkwd.f"
-#undef __KIND
-#undef __DIM
-
-#define __DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_march_bkwd.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_march_bkwd.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_gmm_march_bkwd
diff --git a/src/ppm_module_gmm_march_fwd.f b/src/ppm_module_gmm_march_fwd.f
deleted file mode 100644
index 545855b2ae14ae6afd2801d5e32986dab01b9073..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_march_fwd.f
+++ /dev/null
@@ -1,92 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_march_fwd
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! forward marching routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_march_fwd.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/04/27 01:08:31 ivos
- ! Initial commit, but tested.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-
- MODULE ppm_module_gmm_march_fwd
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_march_fwd
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_march_fwd
- MODULE PROCEDURE ppm_gmm_march_fwd_2ds
- MODULE PROCEDURE ppm_gmm_march_fwd_2dd
- MODULE PROCEDURE ppm_gmm_march_fwd_3ds
- MODULE PROCEDURE ppm_gmm_march_fwd_3dd
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_march_fwd.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_march_fwd.f"
-#undef __KIND
-#undef __DIM
-
-#define __DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_march_fwd.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_march_fwd.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_gmm_march_fwd
diff --git a/src/ppm_module_gmm_reinitialize.f b/src/ppm_module_gmm_reinitialize.f
deleted file mode 100644
index 5ff1da14597884422d997ddb1ebf44289ad96df1..0000000000000000000000000000000000000000
--- a/src/ppm_module_gmm_reinitialize.f
+++ /dev/null
@@ -1,99 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_gmm_reinitialize
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the
- ! reinitialize routine of the marching method.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_gmm_reinitialize.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.3 2005/04/27 01:06:14 ivos
- ! Convergence tests completed, cleaned up code, optmized code (Shark),
- ! and changed structure to allow faster compilation.
- !
- ! Revision 1.2 2005/04/21 04:48:23 ivos
- ! Cleaned interfaces and removed unnecessary overloaded versions.
- !
- ! Revision 1.1 2005/03/11 04:16:00 ivos
- ! Initial implementation.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-
- MODULE ppm_module_gmm_reinitialize
-
- !----------------------------------------------------------------------
- ! Define interfaces to ppm_gmm_reinitialize
- !----------------------------------------------------------------------
- INTERFACE ppm_gmm_reinitialize
- MODULE PROCEDURE ppm_gmm_reinitialize_2ds
- MODULE PROCEDURE ppm_gmm_reinitialize_2dd
- MODULE PROCEDURE ppm_gmm_reinitialize_3ds
- MODULE PROCEDURE ppm_gmm_reinitialize_3dd
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_reinitialize.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_reinitialize.f"
-#undef __KIND
-#undef __DIM
-
-#define __DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "ppm_gmm_reinitialize.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_gmm_reinitialize.f"
-#undef __KIND
-#undef __DIM
-
- END MODULE ppm_module_gmm_reinitialize
diff --git a/src/ppm_module_hamjac.f b/src/ppm_module_hamjac.f
deleted file mode 100644
index d7b72bda8494244e45f2cae8d3590ffedbe97f3c..0000000000000000000000000000000000000000
--- a/src/ppm_module_hamjac.f
+++ /dev/null
@@ -1,36 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_hamjac
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module contains all user-callable routines for
- ! HamJac reinit and extension.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_hamjac.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/07/25 00:34:06 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Perallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_hamjac
-
- !----------------------------------------------------------------------
- ! PPM modules
- !----------------------------------------------------------------------
- USE ppm_module_hamjac_reinit
- USE ppm_module_hamjac_ext
-
- END MODULE ppm_module_hamjac
diff --git a/src/ppm_module_hamjac_ext.f b/src/ppm_module_hamjac_ext.f
deleted file mode 100644
index 888479b4549167acdb12ba27f15c052d5c43e422..0000000000000000000000000000000000000000
--- a/src/ppm_module_hamjac_ext.f
+++ /dev/null
@@ -1,140 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_hamjac_ext
- !-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_hamjac_ext
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_hamjac_ext.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:18:58 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2005/07/25 00:34:07 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-#define __VEC 5
-#define __SCA 6
-
- MODULE ppm_module_hamjac_ext
-
- !-----------------------------------------------------
- ! Interface
- !-----------------------------------------------------
- INTERFACE ppm_hamjac_ext_step
-
- MODULE PROCEDURE ppm_hamjac_ext_step_3ds
- MODULE PROCEDURE ppm_hamjac_ext_step_3dd
- MODULE PROCEDURE ppm_hamjac_ext_step_3dsv
- MODULE PROCEDURE ppm_hamjac_ext_step_3ddv
-
- END INTERFACE
-
- INTERFACE ppm_hamjac_ext
-
- MODULE PROCEDURE ppm_hamjac_ext_3ds
- MODULE PROCEDURE ppm_hamjac_ext_3dd
- MODULE PROCEDURE ppm_hamjac_ext_3dsv
- MODULE PROCEDURE ppm_hamjac_ext_3ddv
-
- END INTERFACE
-
-
- CONTAINS
-#define __DIME __3D
-#define __MODE __SCA
-#define __KIND __SINGLE_PRECISION
- ! 3D SCA SINGLE
-#include "ppm_hamjac_ext_step_3d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 3D SCA SINGLE
-#include "ppm_hamjac_ext_step_3d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
-#define __DIME __3D
-#define __MODE __SCA
-#define __KIND __SINGLE_PRECISION
- ! 3D SCA SINGLE
-#include "ppm_hamjac_ext_3d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 3D SCA SINGLE
-#include "ppm_hamjac_ext_3d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
-
-#define __DIME __3D
-#define __MODE __VEC
-#define __KIND __SINGLE_PRECISION
- ! 3D VEC SINGLE
-#include "ppm_hamjac_ext_step_3d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 3D VEC SINGLE
-#include "ppm_hamjac_ext_step_3d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
-#define __DIME __3D
-#define __MODE __VEC
-#define __KIND __SINGLE_PRECISION
- ! 3D VEC SINGLE
-#include "ppm_hamjac_ext_3d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 3D VEC SINGLE
-#include "ppm_hamjac_ext_3d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
-
-
-
- END MODULE ppm_module_hamjac_ext
-
-
-
-
diff --git a/src/ppm_module_hamjac_reinit.f b/src/ppm_module_hamjac_reinit.f
deleted file mode 100644
index 9d5485c9fa868332d62a69f132691e7e0c927307..0000000000000000000000000000000000000000
--- a/src/ppm_module_hamjac_reinit.f
+++ /dev/null
@@ -1,215 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_hamjac_reinit
- !-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_hamjac_reinit
- ! reinitialization routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_hamjac_reinit.f,v $
- ! Revision 1.1.1.1 2006/07/25 15:18:20 menahel
- ! initial import
- !
- ! Revision 1.1 2005/07/25 00:34:08 ivos
- ! Initial check-in.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 3
-#define __3D 4
-#define __VEC 5
-#define __SCA 6
-
- MODULE ppm_module_hamjac_reinit
-
- !-----------------------------------------------------
- ! Interface
- !-----------------------------------------------------
- INTERFACE ppm_hamjac_reinit_step
- MODULE PROCEDURE ppm_hamjac_reinit_step_3ds
- MODULE PROCEDURE ppm_hamjac_reinit_step_3dd
- MODULE PROCEDURE ppm_hamjac_reinit_step_3dsV
- MODULE PROCEDURE ppm_hamjac_reinit_step_3ddV
- MODULE PROCEDURE ppm_hamjac_reinit_step_2ds
- MODULE PROCEDURE ppm_hamjac_reinit_step_2dd
- END INTERFACE
-
- INTERFACE ppm_hamjac_reinit_loc_step
- MODULE PROCEDURE ppm_hamjac_reinit_loc_step_3ds
- MODULE PROCEDURE ppm_hamjac_reinit_loc_step_3dd
- MODULE PROCEDURE ppm_hamjac_reinit_loc_step_3dsV
- MODULE PROCEDURE ppm_hamjac_reinit_loc_step_3ddV
- END INTERFACE
-
- INTERFACE ppm_hamjac_reinit
- MODULE PROCEDURE ppm_hamjac_reinit_3ds
- MODULE PROCEDURE ppm_hamjac_reinit_3dd
- MODULE PROCEDURE ppm_hamjac_reinit_3dsV
- MODULE PROCEDURE ppm_hamjac_reinit_3ddV
- MODULE PROCEDURE ppm_hamjac_reinit_2ds
- MODULE PROCEDURE ppm_hamjac_reinit_2dd
- END INTERFACE
-
- INTERFACE ppm_hamjac_reinit_loc
- MODULE PROCEDURE ppm_hamjac_reinit_loc_3ds
- MODULE PROCEDURE ppm_hamjac_reinit_loc_3dd
- MODULE PROCEDURE ppm_hamjac_reinit_loc_3dsV
- MODULE PROCEDURE ppm_hamjac_reinit_loc_3ddV
- END INTERFACE
-
- INTERFACE ppm_hamjac_reinit_step_ref
- MODULE PROCEDURE ppm_hamjac_reinit_step_ref_3ds
- MODULE PROCEDURE ppm_hamjac_reinit_step_ref_3dd
- END INTERFACE
-
- INTERFACE ppm_hamjac_reinit_ref
- MODULE PROCEDURE ppm_hamjac_reinit_ref_3ds
- MODULE PROCEDURE ppm_hamjac_reinit_ref_3dd
- END INTERFACE
-
- INTERFACE ppm_hamjac_reinit_russo
- MODULE PROCEDURE ppm_hamjac_reinit_russo_3ds
- MODULE PROCEDURE ppm_hamjac_reinit_russo_3dd
- END INTERFACE
-
- INTERFACE ppm_hamjac_reinit_russo_step
- MODULE PROCEDURE ppm_hamjac_reinit_russo_step_3ds
- MODULE PROCEDURE ppm_hamjac_reinit_russo_step_3dd
- END INTERFACE
-
- CONTAINS
-#define __DIME __3D
-#define __MODE __SCA
-#define __KIND __SINGLE_PRECISION
- ! 3D SCA SINGLE
-#include "ppm_hamjac_reinit_step_3d.f"
-#include "ppm_hamjac_reinit_loc_step_3d.f"
-#include "ppm_hamjac_reinit_step_ref_3d.f"
-#include "ppm_hamjac_reinit_russo_step_3d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 3D SCA SINGLE
-#include "ppm_hamjac_reinit_step_3d.f"
-#include "ppm_hamjac_reinit_loc_step_3d.f"
-#include "ppm_hamjac_reinit_step_ref_3d.f"
-#include "ppm_hamjac_reinit_russo_step_3d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-#define __DIME __3D
-#define __MODE __VEC
-#define __KIND __SINGLE_PRECISION
- ! 3D VEC SINGLE
-#include "ppm_hamjac_reinit_step_3d.f"
-#include "ppm_hamjac_reinit_loc_step_3d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 3D VEC SINGLE
-#include "ppm_hamjac_reinit_step_3d.f"
-#include "ppm_hamjac_reinit_loc_step_3d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
-
-
-#define __DIME __2D
-#define __MODE __SCA
-#define __KIND __SINGLE_PRECISION
- ! 2D SCA SINGLE
-#include "ppm_hamjac_reinit_step_2d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 2D SCA DOUBLE
-#include "ppm_hamjac_reinit_step_2d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
-#define __DIME __3D
-#define __MODE __SCA
-#define __KIND __SINGLE_PRECISION
- ! 3D SCA SINGLE
-#include "ppm_hamjac_reinit_3d.f"
-#include "ppm_hamjac_reinit_loc_3d.f"
-#include "ppm_hamjac_reinit_ref_3d.f"
-#include "ppm_hamjac_reinit_russo_3d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 3D SCA DOUBLE
-#include "ppm_hamjac_reinit_3d.f"
-#include "ppm_hamjac_reinit_loc_3d.f"
-#include "ppm_hamjac_reinit_ref_3d.f"
-#include "ppm_hamjac_reinit_russo_3d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
-#define __DIME __3D
-#define __MODE __VEC
-#define __KIND __SINGLE_PRECISION
- ! 3D VEC SINGLE
-#include "ppm_hamjac_reinit_3d.f"
-#include "ppm_hamjac_reinit_loc_3d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 3D VEC DOUBLE
-#include "ppm_hamjac_reinit_3d.f"
-#include "ppm_hamjac_reinit_loc_3d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
-
-
-#define __DIME __2D
-#define __MODE __SCA
-#define __KIND __SINGLE_PRECISION
- ! 2D SCA SINGLE
-#include "ppm_hamjac_reinit_2d.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
- ! 2D SCA DOUBLE
-#include "ppm_hamjac_reinit_2d.f"
-#undef __KIND
-#undef __MODE
-#undef __DIME
-
- END MODULE ppm_module_hamjac_reinit
-
-
-
-
diff --git a/src/ppm_module_mg.f b/src/ppm_module_mg.f
deleted file mode 100644
index 2b853a77b154bee11c9fddefca28d303c4d9b5f1..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg.f
+++ /dev/null
@@ -1,43 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module contains the user-callable functions of
- ! the mg solver.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_mg.f,v $
- ! 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:39:26 kotsalie
- ! MG new version
- !
- !-------------------------------------------------------------------------
- ! Perallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
- !-------------------------------------------------------------------------
-
- MODULE ppm_module_mg
-
- !----------------------------------------------------------------------
- ! PPM modules
- !----------------------------------------------------------------------
- USE ppm_module_mg_init
- USE ppm_module_mg_solv
- USE ppm_module_mg_finalize
- USE ppm_module_mg_alloc
- USE ppm_module_mg_core
- USE ppm_module_mg_prolong
- USE ppm_module_mg_res
- USE ppm_module_mg_restrict
- USE ppm_module_mg_smooth
-
- END MODULE ppm_module_mg
diff --git a/src/ppm_module_mg_alloc.f b/src/ppm_module_mg_alloc.f
deleted file mode 100644
index 0c36715413988831d865f26ea741d1c2bd150c90..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_alloc.f
+++ /dev/null
@@ -1,148 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_alloc
- !-------------------------------------------------------------------------
- !
- ! Purpose : multigrid allocation module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_mg_alloc.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/09/22 18:23:34 kotsalie
- ! MG new version
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_mg_alloc
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
-
-
- INTERFACE ppm_mg_alloc
- MODULE PROCEDURE ppm_mg_alloc_field_2d_sca_s
- MODULE PROCEDURE ppm_mg_alloc_field_2d_sca_d
- MODULE PROCEDURE ppm_mg_alloc_field_3d_sca_s
- MODULE PROCEDURE ppm_mg_alloc_field_3d_sca_d
- MODULE PROCEDURE ppm_mg_alloc_field_2d_vec_s
- MODULE PROCEDURE ppm_mg_alloc_field_2d_vec_d
- MODULE PROCEDURE ppm_mg_alloc_field_3d_vec_s
- MODULE PROCEDURE ppm_mg_alloc_field_3d_vec_d
- MODULE PROCEDURE ppm_mg_alloc_bc_2d_sca_s
- MODULE PROCEDURE ppm_mg_alloc_bc_2d_sca_d
- MODULE PROCEDURE ppm_mg_alloc_bc_3d_sca_s
- MODULE PROCEDURE ppm_mg_alloc_bc_3d_sca_d
- MODULE PROCEDURE ppm_mg_alloc_bc_2d_vec_s
- MODULE PROCEDURE ppm_mg_alloc_bc_2d_vec_d
- MODULE PROCEDURE ppm_mg_alloc_bc_3d_vec_s
- MODULE PROCEDURE ppm_mg_alloc_bc_3d_vec_d
- END INTERFACE
-
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_alloc_field.f"
-#include "mg/ppm_mg_alloc_bc.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_alloc_field.f"
-#include "mg/ppm_mg_alloc_bc.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_alloc_field.f"
-#include "mg/ppm_mg_alloc_bc.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_alloc_field.f"
-#include "mg/ppm_mg_alloc_bc.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_alloc_field.f"
-#include "mg/ppm_mg_alloc_bc.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_alloc_field.f"
-#include "mg/ppm_mg_alloc_bc.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_alloc_field.f"
-#include "mg/ppm_mg_alloc_bc.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_alloc_field.f"
-#include "mg/ppm_mg_alloc_bc.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
-
-
-
-END MODULE ppm_module_mg_alloc
-
-
diff --git a/src/ppm_module_mg_core.f b/src/ppm_module_mg_core.f
deleted file mode 100644
index 6acd216d52b26bc4808848d6386088687e48cdf6..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_core.f
+++ /dev/null
@@ -1,117 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_core
- !-------------------------------------------------------------------------
- !
- ! Purpose : multigrid module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_mg_core.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2004/09/22 18:31:04 kotsalie
- ! MG new version
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_mg_core
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_core.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_core.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_core.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_core.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_core.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_core.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_core.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_core.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-END MODULE ppm_module_mg_core
-
-
diff --git a/src/ppm_module_mg_finalize.f b/src/ppm_module_mg_finalize.f
deleted file mode 100644
index 75eeb3dd9ac66b4302eee48b5f88effb4c464557..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_finalize.f
+++ /dev/null
@@ -1,117 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_finalize
- !-------------------------------------------------------------------------
- !
- ! Purpose : multigrid finalize module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_mg_finalize.f,v $
- ! 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:49:34 kotsalie
- ! MG new version
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_mg_finalize
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_finalize.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_finalize.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_finalize.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_finalize.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_finalize.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_finalize.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_finalize.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_finalize.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
-
-END MODULE ppm_module_mg_finalize
-
-
diff --git a/src/ppm_module_mg_init.f b/src/ppm_module_mg_init.f
deleted file mode 100644
index b6032734c3f5f780682cfd02a22fb8eaf519d05b..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_init.f
+++ /dev/null
@@ -1,123 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_init
- !-------------------------------------------------------------------------
- !
- ! Purpose : module of the initialization routine
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
- MODULE ppm_module_mg_init
- !-----------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------
-
- !-----------------------------------------------------------------
-
- INTERFACE ppm_mg_init
- MODULE PROCEDURE ppm_mg_init_2d_sca_s
- MODULE PROCEDURE ppm_mg_init_2d_sca_d
- MODULE PROCEDURE ppm_mg_init_3d_sca_s
- MODULE PROCEDURE ppm_mg_init_3d_sca_d
- MODULE PROCEDURE ppm_mg_init_2d_vec_s
- MODULE PROCEDURE ppm_mg_init_2d_vec_d
- MODULE PROCEDURE ppm_mg_init_3d_vec_s
- MODULE PROCEDURE ppm_mg_init_3d_vec_d
- END INTERFACE
-
- !-----------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------
-
- CONTAINS
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_init.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_init.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_init.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_init.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_init.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
- END MODULE ppm_module_mg_init
-
-
diff --git a/src/ppm_module_mg_prolong.f b/src/ppm_module_mg_prolong.f
deleted file mode 100644
index 5c206ee6eed3727de3b49f0409d98a633bc35ff1..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_prolong.f
+++ /dev/null
@@ -1,113 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_prolong
- !-------------------------------------------------------------------------
- !
- ! Purpose : multigrid module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log $
- !
- !-------------------------------------------------------------------------
- !
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_mg_prolong
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_prolong.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_prolong.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_prolong.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_prolong.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_prolong.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_prolong.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_prolong.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_prolong.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
-END MODULE ppm_module_mg_prolong
-
-
diff --git a/src/ppm_module_mg_res.f b/src/ppm_module_mg_res.f
deleted file mode 100644
index 9ad42525e35a1e1017bd3e9fb3ad1eac2846f2e3..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_res.f
+++ /dev/null
@@ -1,151 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_res
- !-------------------------------------------------------------------------
- !
- ! Purpose : multigrid module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_mg_res.f,v $
- ! 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:45:11 kotsalie
- ! MG new version
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_mg_res
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
-
- !---------------------------------------------------------------------------
- INTERFACE ppm_mg_res_sca
- MODULE PROCEDURE ppm_mg_res_coarse_2D_sca_s
- MODULE PROCEDURE ppm_mg_res_coarse_2D_sca_d
- MODULE PROCEDURE ppm_mg_res_coarse_3D_sca_s
- MODULE PROCEDURE ppm_mg_res_coarse_3D_sca_d
- MODULE PROCEDURE ppm_mg_res_fine_2D_sca_s
- MODULE PROCEDURE ppm_mg_res_fine_2D_sca_d
- MODULE PROCEDURE ppm_mg_res_fine_3D_sca_s
- MODULE PROCEDURE ppm_mg_res_fine_3D_sca_d
- END INTERFACE
-
- INTERFACE ppm_mg_res_vec
- MODULE PROCEDURE ppm_mg_res_coarse_2D_vec_s
- MODULE PROCEDURE ppm_mg_res_coarse_2D_vec_d
- MODULE PROCEDURE ppm_mg_res_coarse_3D_vec_s
- MODULE PROCEDURE ppm_mg_res_coarse_3D_vec_d
- MODULE PROCEDURE ppm_mg_res_fine_2D_vec_s
- MODULE PROCEDURE ppm_mg_res_fine_2D_vec_d
- MODULE PROCEDURE ppm_mg_res_fine_3D_vec_s
- MODULE PROCEDURE ppm_mg_res_fine_3D_vec_d
- END INTERFACE
-
-
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_res_coarse.f"
-#include "mg/ppm_mg_res_fine.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_res_coarse.f"
-#include "mg/ppm_mg_res_fine.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_res_coarse.f"
-#include "mg/ppm_mg_res_fine.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_res_coarse.f"
-#include "mg/ppm_mg_res_fine.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_res_coarse.f"
-#include "mg/ppm_mg_res_fine.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_res_coarse.f"
-#include "mg/ppm_mg_res_fine.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_res_coarse.f"
-#include "mg/ppm_mg_res_fine.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_res_coarse.f"
-#include "mg/ppm_mg_res_fine.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
-
-END MODULE ppm_module_mg_res
-
-
diff --git a/src/ppm_module_mg_restrict.f b/src/ppm_module_mg_restrict.f
deleted file mode 100644
index 3194e0fca0d7ea363056ef68fbdf029357d9ed2c..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_restrict.f
+++ /dev/null
@@ -1,121 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_restrict
- !-------------------------------------------------------------------------
- !
- !
- ! Purpose : multigrid module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_mg_restrict.f,v $
- ! 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:36:53 kotsalie
- ! MG new version
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_mg_restrict
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_restrict.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_restrict.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_restrict.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_restrict.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_restrict.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_restrict.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_restrict.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_restrict.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
-
-END MODULE ppm_module_mg_restrict
-
-
diff --git a/src/ppm_module_mg_smooth.f b/src/ppm_module_mg_smooth.f
deleted file mode 100644
index 9ee79e97d867258462b71c59d644f60414aeb969..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_smooth.f
+++ /dev/null
@@ -1,158 +0,0 @@
-
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_smooth
- !-------------------------------------------------------------------------
- !
- ! Purpose : multigrid module
- !
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_mg_smooth.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/11/05 18:08:49 kotsalie
- ! FINAL SPEEDUP BEFORE TEST
- !
- ! Revision 1.1 2004/09/22 18:41:49 kotsalie
- ! MG new version
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-#define __WITHOUTMASKS
-
-
-MODULE ppm_module_mg_smooth
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
-
- !---------------------------------------------------------------------------
- INTERFACE ppm_mg_smooth_sca
- MODULE PROCEDURE ppm_mg_smooth_coarse_2D_sca_s
- MODULE PROCEDURE ppm_mg_smooth_coarse_2D_sca_d
- MODULE PROCEDURE ppm_mg_smooth_coarse_3D_sca_s
- MODULE PROCEDURE ppm_mg_smooth_coarse_3D_sca_d
- MODULE PROCEDURE ppm_mg_smooth_fine_2D_sca_s
- MODULE PROCEDURE ppm_mg_smooth_fine_2D_sca_d
- MODULE PROCEDURE ppm_mg_smooth_fine_3D_sca_s
- MODULE PROCEDURE ppm_mg_smooth_fine_3D_sca_d
- END INTERFACE
-
- INTERFACE ppm_mg_smooth_vec
- MODULE PROCEDURE ppm_mg_smooth_fine_2D_vec_s
- MODULE PROCEDURE ppm_mg_smooth_fine_2D_vec_d
- MODULE PROCEDURE ppm_mg_smooth_fine_3D_vec_s
- MODULE PROCEDURE ppm_mg_smooth_fine_3D_vec_d
- MODULE PROCEDURE ppm_mg_smooth_coarse_2D_vec_s
- MODULE PROCEDURE ppm_mg_smooth_coarse_2D_vec_d
- MODULE PROCEDURE ppm_mg_smooth_coarse_3D_vec_s
- MODULE PROCEDURE ppm_mg_smooth_coarse_3D_vec_d
- END INTERFACE
-
-
-
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_smooth_coarse.f"
-#include "mg/ppm_mg_smooth_fine.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_smooth_coarse.f"
-#include "mg/ppm_mg_smooth_fine.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_smooth_coarse.f"
-#include "mg/ppm_mg_smooth_fine.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_smooth_coarse.f"
-#include "mg/ppm_mg_smooth_fine.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_smooth_coarse.f"
-#include "mg/ppm_mg_smooth_fine.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_smooth_coarse.f"
-#include "mg/ppm_mg_smooth_fine.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_smooth_coarse.f"
-#include "mg/ppm_mg_smooth_fine.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_smooth_coarse.f"
-#include "mg/ppm_mg_smooth_fine.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
-
-END MODULE ppm_module_mg_smooth
-
-
diff --git a/src/ppm_module_mg_solv.f b/src/ppm_module_mg_solv.f
deleted file mode 100644
index 180c41b42917fe27472a8c992cb149383e0774ea..0000000000000000000000000000000000000000
--- a/src/ppm_module_mg_solv.f
+++ /dev/null
@@ -1,133 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_mg_solv
- !-------------------------------------------------------------------------
- !
- ! Purpose : multigrid module for the solver
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_mg_solv.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/09/23 09:39:35 kotsalie
- ! details in the header
- !
- ! Revision 1.1 2004/09/22 18:28:42 kotsalie
- ! MG new version
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __INTEGER 3
-#define __LOGICAL 4
-#define __2D 7
-#define __3D 8
-#define __SFIELD 9
-#define __VFIELD 10
-
-MODULE ppm_module_mg_solv
- !--------------------------------------------------------------------------
- !Modules
- !-----------------------------------------------------------------------------
-
- !-----------------------------------------------------------------------------
-
-
- INTERFACE ppm_mg_solv
- MODULE PROCEDURE ppm_mg_solv_2d_sca_s
- MODULE PROCEDURE ppm_mg_solv_2d_sca_d
- MODULE PROCEDURE ppm_mg_solv_3d_sca_s
- MODULE PROCEDURE ppm_mg_solv_3d_sca_d
- MODULE PROCEDURE ppm_mg_solv_2d_vec_s
- MODULE PROCEDURE ppm_mg_solv_2d_vec_d
- MODULE PROCEDURE ppm_mg_solv_3d_vec_s
- MODULE PROCEDURE ppm_mg_solv_3d_vec_d
- END INTERFACE
- !-----------------------------------------------------------------------------
- ! INCLUDE THE SOURCES
- !-----------------------------------------------------------------------------
-
-CONTAINS
-
-#define __DIM __SFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_solv.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_solv.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_solv.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_solv.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-#define __DIM __VFIELD
-#define __MESH_DIM __2D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_solv.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_solv.f"
-#undef __KIND
-#undef __MESH_DIM
-
-#define __MESH_DIM __3D
-#define __KIND __SINGLE_PRECISION
-#include "mg/ppm_mg_solv.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "mg/ppm_mg_solv.f"
-#undef __KIND
-#undef __MESH_DIM
-#undef __DIM
-
-
-END MODULE ppm_module_mg_solv
-
-
diff --git a/src/ppm_module_ode.f b/src/ppm_module_ode.f
index cea9e1025fb03bcd6912b6bab83353117393d125..0ad1e5089badba42b3ddccfb375de1afd3c0fab7 100644
--- a/src/ppm_module_ode.f
+++ b/src/ppm_module_ode.f
@@ -1,42 +1,41 @@
!-------------------------------------------------------------------------
! Module : ppm_module_ode
!-------------------------------------------------------------------------
+ ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
+ ! Center for Fluid Dynamics (DTU)
!
- ! Purpose : This module contains the user-callable functions of
- ! the ode time integrator.
- !
- ! Remarks :
!
- ! References :
+ ! This file is part of the Parallel Particle Mesh Library (PPM).
!
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
+ ! PPM is free software: you can redistribute it and/or modify
+ ! it under the terms of the GNU Lesser General Public License
+ ! as published by the Free Software Foundation, either
+ ! version 3 of the License, or (at your option) any later
+ ! version.
!
- ! Revision 1.3 2004/07/26 13:41:34 ivos
- ! Initial implementation. These are meta-modules for the user-
- ! callable functions. Only these modules will be given away to
- ! the user.
+ ! PPM is distributed in the hope that it will be useful,
+ ! but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ! GNU General Public License for more details.
!
- !-------------------------------------------------------------------------
- ! Perallel Particle Mesh Library (PPM)
- ! Institute of Computational Science
- ! ETH Zentrum, Hirschengraben 84
- ! CH-8092 Zurich, Switzerland
+ ! You should have received a copy of the GNU General Public License
+ ! and the GNU Lesser General Public License along with PPM. If not,
+ ! see <http://www.gnu.org/licenses/>.
+ !
+ ! Parallel Particle Mesh Library (PPM)
+ ! ETH Zurich
+ ! CH-8092 Zurich, Switzerland
!-------------------------------------------------------------------------
MODULE ppm_module_ode
+ !!! This module contains the user-callable functions of
+ !!! the ode time integrator.
!----------------------------------------------------------------------
! PPM modules
!----------------------------------------------------------------------
USE ppm_module_ode_alldone
- USE ppm_module_ode_create_ode
- USE ppm_module_ode_finalize
- USE ppm_module_ode_init
+ USE ppm_module_ode_setup
USE ppm_module_ode_step
- USE ppm_module_ode_start
END MODULE ppm_module_ode
diff --git a/src/ppm_module_ode_alldone.f b/src/ppm_module_ode_alldone.f
index d6c4fa9b83b1119098d1a71b74689ad7a60e4211..7f0be4885a5e688696feb89fc594be19715e7957 100644
--- a/src/ppm_module_ode_alldone.f
+++ b/src/ppm_module_ode_alldone.f
@@ -1,33 +1,6 @@
!-------------------------------------------------------------------------
! Module : ppm_module_ode_alldone
!-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_ode_allone
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode_alldone.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.4 2004/07/26 11:57:45 michaebe
- ! replace module function by module procedure ;)
- !
- ! Revision 1.3 2004/07/26 11:39:49 michaebe
- ! replaced module procedure by module function
- !
- ! Revision 1.2 2004/07/26 11:20:13 michaebe
- ! added dummy interface
- !
- ! Revision 1.1 2004/07/26 07:45:46 michaebe
- ! Procedure modules created in the course of atomization.
- !
- !
- !-------------------------------------------------------------------------
! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
! Center for Fluid Dynamics (DTU)
!
@@ -52,7 +25,6 @@
! Parallel Particle Mesh Library (PPM)
! ETH Zurich
! CH-8092 Zurich, Switzerland
-
!-------------------------------------------------------------------------
MODULE ppm_module_ode_alldone
@@ -64,9 +36,6 @@
END INTERFACE
CONTAINS
-#include "ppm_ode_alldone.f"
+#include "ode/ppm_ode_alldone.f"
END MODULE ppm_module_ode_alldone
-
-
-
diff --git a/src/ppm_module_ode_create_ode.f b/src/ppm_module_ode_create_ode.f
deleted file mode 100644
index 3e9efde581d9064452a0b448b167f7c1b2591a9c..0000000000000000000000000000000000000000
--- a/src/ppm_module_ode_create_ode.f
+++ /dev/null
@@ -1,69 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_ode_create_ode
- !-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_ode_create_ode
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode_create_ode.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/07/26 11:20:29 michaebe
- ! added dummy interface
- !
- ! Revision 1.1 2004/07/26 07:45:47 michaebe
- ! Procedure modules created in the course of atomization.
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-
-
- MODULE ppm_module_ode_create_ode
-
- !-----------------------------------------------------
- ! Dummy interface
- !-----------------------------------------------------
- INTERFACE ppm_ode_create_ode
- MODULE PROCEDURE ppm_ode_create_ode
- END INTERFACE
-
- CONTAINS
-
-#include "ppm_ode_create_ode.f"
-
- END MODULE ppm_module_ode_create_ode
diff --git a/src/ppm_module_ode_finalize.f b/src/ppm_module_ode_finalize.f
deleted file mode 100644
index 41c7c2562be66d8e3f607f9d04e143c9d4d0341e..0000000000000000000000000000000000000000
--- a/src/ppm_module_ode_finalize.f
+++ /dev/null
@@ -1,66 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_ode_finalize
- !-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_ode_finalize
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode_finalize.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/07/26 11:21:04 michaebe
- ! added dummy interface
- !
- ! Revision 1.1 2004/07/26 07:45:47 michaebe
- ! Procedure modules created in the course of atomization.
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
- MODULE ppm_module_ode_finalize
-
- !-----------------------------------------------------
- ! Dummy interface
- !-----------------------------------------------------
- INTERFACE ppm_ode_finalize
- MODULE PROCEDURE ppm_ode_finalize
- END INTERFACE
-
- CONTAINS
-#include "ppm_ode_finalize.f"
-
- END MODULE ppm_module_ode_finalize
-
-
-
diff --git a/src/ppm_module_ode_map_push.f b/src/ppm_module_ode_map.f
similarity index 68%
rename from src/ppm_module_ode_map_push.f
rename to src/ppm_module_ode_map.f
index d5e150fc17de22fa8039248e34aae67e46aae3fc..5f53f5abb7ab935107e385e469b203434b8ae97a 100644
--- a/src/ppm_module_ode_map_push.f
+++ b/src/ppm_module_ode_map.f
@@ -1,26 +1,5 @@
!-------------------------------------------------------------------------
- ! Module : ppm_module_ode_map_push
- !-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_ode_map_push
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode_map_push.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/07/26 12:00:24 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.1 2004/07/26 07:45:49 michaebe
- ! Procedure modules created in the course of atomization.
- !
- !
+ ! Module : ppm_module_ode_map
!-------------------------------------------------------------------------
! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
! Center for Fluid Dynamics (DTU)
@@ -46,7 +25,6 @@
! Parallel Particle Mesh Library (PPM)
! ETH Zurich
! CH-8092 Zurich, Switzerland
-
!-------------------------------------------------------------------------
!-------------------------------------------------------------------------
@@ -55,7 +33,7 @@
#define __SINGLE_PRECISION 1
#define __DOUBLE_PRECISION 2
- MODULE ppm_module_ode_map_push
+ MODULE ppm_module_ode_map
!-----------------------------------------------------
! Interfaces
@@ -66,16 +44,19 @@
MODULE PROCEDURE ppm_ode_map_push_d
END INTERFACE
+ INTERFACE ppm_ode_map_pop
+ MODULE PROCEDURE ppm_ode_map_pop_s
+ MODULE PROCEDURE ppm_ode_map_pop_d
+ END INTERFACE
CONTAINS
#define __KIND __SINGLE_PRECISION
-#include "ppm_ode_map_push.f"
+#include "ode/ppm_ode_map_push.f"
+#include "ode/ppm_ode_map_pop.f"
#undef __KIND
#define __KIND __DOUBLE_PRECISION
-#include "ppm_ode_map_push.f"
+#include "ode/ppm_ode_map_push.f"
+#include "ode/ppm_ode_map_pop.f"
#undef __KIND
- END MODULE ppm_module_ode_map_push
-
-
-
+ END MODULE ppm_module_ode_map
diff --git a/src/ppm_module_ode_map_pop.f b/src/ppm_module_ode_map_pop.f
deleted file mode 100644
index bb3e64135b04f0f6077c3951b510f4d20303db22..0000000000000000000000000000000000000000
--- a/src/ppm_module_ode_map_pop.f
+++ /dev/null
@@ -1,81 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_ode_map_pop
- !-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_ode_map_pop
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode_map_pop.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/07/26 12:00:23 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.1 2004/07/26 07:45:48 michaebe
- ! Procedure modules created in the course of atomization.
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define data types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-
- MODULE ppm_module_ode_map_pop
-
- !-----------------------------------------------------------------------
- ! Interfaces
- !-----------------------------------------------------------------------
-
- INTERFACE ppm_ode_map_pop
- MODULE PROCEDURE ppm_ode_map_pop_s
- MODULE PROCEDURE ppm_ode_map_pop_d
- END INTERFACE
-
-
- CONTAINS
-#define __KIND __SINGLE_PRECISION
-#include "ppm_ode_map_pop.f"
-#undef __KIND
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_ode_map_pop.f"
-#undef __KIND
-
- END MODULE ppm_module_ode_map_pop
-
-
-
diff --git a/src/ppm_module_ode_init.f b/src/ppm_module_ode_setup.f
similarity index 65%
rename from src/ppm_module_ode_init.f
rename to src/ppm_module_ode_setup.f
index 0b58145dea7a648ee1a4d16939558f9e97b4a62a..c6518b8fed3dacf477e3b51c63cfb709eb26b9fa 100644
--- a/src/ppm_module_ode_init.f
+++ b/src/ppm_module_ode_setup.f
@@ -1,26 +1,5 @@
!-------------------------------------------------------------------------
- ! Module : ppm_module_ode_init
- !-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_ode_init
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode_init.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/07/26 11:21:24 michaebe
- ! added dummy interface
- !
- ! Revision 1.1 2004/07/26 07:45:48 michaebe
- ! Procedure modules created in the course of atomization.
- !
- !
+ ! Module : ppm_module_ode_setup
!-------------------------------------------------------------------------
! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
! Center for Fluid Dynamics (DTU)
@@ -46,9 +25,9 @@
! Parallel Particle Mesh Library (PPM)
! ETH Zurich
! CH-8092 Zurich, Switzerland
-
!-------------------------------------------------------------------------
- MODULE ppm_module_ode_init
+ MODULE ppm_module_ode_setup
+ !!! Module for ODE setup routines
!-----------------------------------------------------
! Dummy interface
@@ -56,11 +35,26 @@
INTERFACE ppm_ode_init
MODULE PROCEDURE ppm_ode_init
END INTERFACE
+
+ INTERFACE ppm_ode_finalize
+ MODULE PROCEDURE ppm_ode_finalize
+ END INTERFACE
+
+ INTERFACE ppm_ode_start
+ MODULE PROCEDURE ppm_ode_start
+ END INTERFACE
+
+ INTERFACE ppm_ode_create_ode
+ MODULE PROCEDURE ppm_ode_create_ode
+ END INTERFACE
CONTAINS
-#include "ppm_ode_init.f"
+#include "ode/ppm_ode_init.f"
- END MODULE ppm_module_ode_init
+#include "ode/ppm_ode_finalize.f"
+#include "ode/ppm_ode_start.f"
-
+#include "ode/ppm_ode_create_ode.f"
+
+ END MODULE ppm_module_ode_setup
diff --git a/src/ppm_module_ode_start.f b/src/ppm_module_ode_start.f
deleted file mode 100644
index b5286378cd7321ab2d4843ebfe1ed3a165bdbf2c..0000000000000000000000000000000000000000
--- a/src/ppm_module_ode_start.f
+++ /dev/null
@@ -1,66 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_ode_start
- !-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_ode_start
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode_start.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/07/26 11:21:25 michaebe
- ! added dummy interface
- !
- ! Revision 1.1 2004/07/26 07:45:49 michaebe
- ! Procedure modules created in the course of atomization.
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
- MODULE ppm_module_ode_start
-
- !-----------------------------------------------------
- ! Dummy interface
- !-----------------------------------------------------
- INTERFACE ppm_ode_start
- MODULE PROCEDURE ppm_ode_start
- END INTERFACE
-
- CONTAINS
-#include "ppm_ode_start.f"
-
- END MODULE ppm_module_ode_start
-
-
-
diff --git a/src/ppm_module_ode_step.f b/src/ppm_module_ode_step.f
index 9b632caef22a9b8073c9247ffbea82433d1afac4..18ccd8931217eb77704168cf26e894592300b7e0 100644
--- a/src/ppm_module_ode_step.f
+++ b/src/ppm_module_ode_step.f
@@ -1,36 +1,6 @@
!-------------------------------------------------------------------------
! Module : ppm_module_ode_step
!-------------------------------------------------------------------------
- !
- ! Purpose : procedure module for ppm_ode_step
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_ode_step.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.5 2004/07/26 14:58:05 michaebe
- ! renamed the preprocessing defines vector and scalar
- !
- ! Revision 1.4 2004/07/26 12:00:24 ivos
- ! Fixes to make it compile.
- !
- ! Revision 1.3 2004/07/26 11:48:28 michaebe
- ! added vector and scalar defines
- !
- ! Revision 1.2 2004/07/26 08:14:15 michaebe
- ! Added overloading for scalar lda.
- !
- ! Revision 1.1 2004/07/26 07:45:50 michaebe
- ! Procedure modules created in the course of atomization.
- !
- !
- !-------------------------------------------------------------------------
! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
! Center for Fluid Dynamics (DTU)
!
@@ -155,22 +125,19 @@
CONTAINS
#define __MODE __SCA
#define __KIND __SINGLE_PRECISION
-#include "ppm_ode_step.f"
+#include "ode/ppm_ode_step.f"
#undef __KIND
#define __KIND __DOUBLE_PRECISION
-#include "ppm_ode_step.f"
+#include "ode/ppm_ode_step.f"
#undef __KIND
#undef __MODE
#define __MODE __VEC
#define __KIND __SINGLE_PRECISION
-#include "ppm_ode_step.f"
+#include "ode/ppm_ode_step.f"
#undef __KIND
#define __KIND __DOUBLE_PRECISION
-#include "ppm_ode_step.f"
+#include "ode/ppm_ode_step.f"
#undef __KIND
#undef __MODE
END MODULE ppm_module_ode_step
-
-
-
diff --git a/src/ppm_module_poisson.f b/src/ppm_module_poisson.f
deleted file mode 100644
index 1a9d844a36025379767b35f0f5f8a64bc84f26ad..0000000000000000000000000000000000000000
--- a/src/ppm_module_poisson.f
+++ /dev/null
@@ -1,251 +0,0 @@
- !-------------------------------------------------------------------------
- ! Subroutine : ppm_module_poisson
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- ! Notes on the init routine:
- ! Arguments:
- ! topoid
- ! meshid
- ! ppmpoisson
- ! fieldin
- ! fieldout
- ! greens function: custom array, custom function, integer to build-in
- ! info - return variable
- ! periodic/freespace flag
- ! real/fourier greens function (optional, only for custom array)
- ! derivatives (optional): none,curl,gradient,laplace, - spectral/FD
- ! possibly the option to de- and reallocate arrays of slabs/pencils
- !
- ! The fields returned from the subroutine have been ghosted/extrapolated
- ! as necessary.
- !
- ! Add finalize routine
- ! Allow custom kernels/greens functions
- ! Add switch to allocate and deallocate all arrays to save memory
- !
- ! This routine needs to be modified to allow cell centred data
- ! These routines should all be renamed - potentially not just Poisson
- ! equations can be solved.
- !-------------------------------------------------------------------------
-#define __SINGLE 0
-#define __DOUBLE 1
-
-#define __DIM 3
-
- MODULE ppm_module_poisson
- !!! This module provides routines for solving the Poisson equation via
- !!! a Greens function. The Greens function is convolved with the RHS
- !!! spectrally using the FFTW library. The routines also do Helmholtz
- !!! reprojection to make fields solenoidal.
- !!!
- !!! Usage:
- !!! First a ppm_poisson_plan must initialised by calling ppm_poisson_init.
- !!! This is mainly done to initialise the FFTW library. An optional 'derive'
- !!! argument toggles various curl operations on the solution to the Poisson
- !!! equation.
- !!!
- !!! Then ppm_poisson_solve does the actual execution of the initialised FFTW
- !!! plans, convolutions, derivations, etc. The initialised Fourier
- !!! transformations and arrays may be used for some other operations;
- !!! presently just Helmholtz reprojection.
- !!!
- !!! So far no routine exists to remove any initialised ppm_poisson_plan
-
-
- USE ppm_module_fft
- USE ppm_module_substart
- USE ppm_module_substop
- USE ppm_module_write
- USE ppm_module_data,ONLY:ppm_rank,ppm_kind_single,ppm_kind_double,&
- &ppm_t_topo,ppm_t_equi_mesh,&
- &ppm_param_assign_internal,ppm_param_bcdef_periodic,&
- &ppm_param_bcdef_freespace,&
- &ppm_param_decomp_xy_slab,ppm_param_decomp_zpencil
-
- !-------------------------------------------------------------------------
- ! PPM Poisson type
- !-------------------------------------------------------------------------
- !!! Type containing the FFTW plan and its settings
- TYPE ppm_poisson_plan
- INTEGER :: derivatives
- INTEGER :: case
-
- REAL(ppm_kind_double) :: normkx
- REAL(ppm_kind_double) :: normky
- REAL(ppm_kind_double) :: normkz
-
- INTEGER, DIMENSION(__DIM) :: nmfft
- !!!Size of the FFT
-
- INTEGER :: topoidxy
- !!!Topology id of xy topology
- INTEGER :: meshidxy
- !!!mesh id for xy mesh
- REAL(ppm_kind_double), DIMENSION(:), POINTER :: costxy=>NULL()
- !!!sub cost for xy topology
- INTEGER , DIMENSION(:,:),POINTER :: istartxy=>NULL()
- !!!sub index start for xy topology
- INTEGER, DIMENSION(__DIM) :: nmxy
- !!!global number of grid points for xy topology
- INTEGER , DIMENSION(:,:),POINTER :: ndataxy=>NULL()
- !!!sub no. grid cells for xy topology
- INTEGER,DIMENSION(:),POINTER :: isublistxy=>NULL()
- !!!list of sub domains on current CPU on the xy topology
- INTEGER :: nsublistxy
- !!!number of sub domains for current CPU on the xy topology
- REAL(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER :: fldxyr=>NULL()
- !!!real slab field (xy topology)
- COMPLEX(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER:: fldxyc=>NULL()
- !!!complex slab field (xy topology)
-
- !COMPLEX(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER:: fldxyc2=>NULL() !@tmp3
-
- INTEGER :: topoidxyc
- !!!Topology id of complex xy topology
- INTEGER :: meshidxyc
- !!!mesh id for comple xy mesh
- REAL(ppm_kind_double), DIMENSION(:), POINTER :: costxyc=>NULL()
- !!!sub cost for xy topology
- INTEGER , DIMENSION(:,:),POINTER :: istartxyc=>NULL()
- !!!sub index start for complex xy topology
- INTEGER, DIMENSION(__DIM) :: nmxyc
- !!!global number of grid points for complex xy topology
- INTEGER , DIMENSION(:,:),POINTER :: ndataxyc=>NULL()
- !!!sub no. grid cells for complex xy topology
- INTEGER,DIMENSION(:),POINTER :: isublistxyc=>NULL()
- !!!list of sub domains on current CPU on the complex xy topology
- INTEGER :: nsublistxyc
- !!!number of sub domains for current CPU on the complex xy topology
- TYPE(ppm_fft_plan) :: planfxy
- !!!fft plans for r2c complex xy slab
- TYPE(ppm_fft_plan) :: planbxy
- !!!fft plans for c2r complex xy slab
-
- TYPE(ppm_fft_plan) :: planfz
- !!!fft plans for forward c2c z pencil
- TYPE(ppm_fft_plan) :: planbz
- !!!fft plans for backward c2c z pencil
- INTEGER :: topoidz
- !!!Topology id of z topology
- INTEGER :: meshidz
- !!!mesh id for z mesh
- REAL(ppm_kind_double), DIMENSION(:), POINTER :: costz =>NULL()
- !!!sub cost for z topology
- INTEGER , DIMENSION(:,:),POINTER :: istartz=>NULL()
- !!!sub index start for z topology
- INTEGER, DIMENSION(__DIM) :: nmz
- !!!global number of grid points for z topology
- INTEGER , DIMENSION(:,:),POINTER :: ndataz=>NULL()
- !!!sub no. grid cells for z topology
- INTEGER,DIMENSION(:),POINTER :: isublistz=>NULL()
- !!!list of sub domains on current CPU on the z topology
- INTEGER :: nsublistz
- !!!number of sub domains for current CPU on the z topology
- COMPLEX(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER:: fldzc1=>NULL()
- !!!complex pencil field 1 (z topology)
- COMPLEX(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER:: fldzc2=>NULL()
- !!!complex pencil field 2 (z topology)
-
- INTEGER :: topoidfr
- !!!Topology id of freespace topology
- INTEGER :: meshidfr
- !!!mesh id for freespace mesh
- REAL(ppm_kind_double), DIMENSION(:), POINTER :: costfr=>NULL()
- !!!sub cost
- INTEGER , DIMENSION(:,:),POINTER :: istartfr=>NULL()
- !!!sub index start
- INTEGER, DIMENSION(__DIM) :: nmfr
- !!!global number of grid points
- INTEGER , DIMENSION(:,:),POINTER :: ndatafr=>NULL()
- !!!sub no. grid cells
- INTEGER,DIMENSION(:),POINTER :: isublistfr=>NULL()
- !!!list of sub domains on current CPU on the freespace topology
- INTEGER :: nsublistfr
- !!!number of sub domains for current CPU on the freespace topology
-
- !These field are only allocated as necessary:
- REAL(ppm_kind_double),DIMENSION(:,:,:,:),POINTER :: fldfrs=>NULL()
- !!!dummy array for the right hand side, for free space, scalar fields
- REAL(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER :: fldfrv=>NULL()
- !!!dummy array for the right hand side, for free space, vector fields
- REAL(ppm_kind_double),DIMENSION(:,:,:,:),POINTER :: fldgrnr=>NULL()
- !!!real Greens field, z-pencils, scalar
- COMPLEX(ppm_kind_double),DIMENSION(:,:,:,:),POINTER :: fldgrnc=>NULL()
- !!!complex Greens field, z-pencils, scalar
- !REAL(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER :: drv_vr2=>NULL()
- REAL(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER :: drv_vr=>NULL()
- !!!dummy array for the right hand side, for free space, vector fields
-
- ! COMPLEX(ppm_kind_double),DIMENSION(:,:,:,:,:),POINTER:: fldgrnc3=>NULL()
- ! !!!complex Greens 3 component vector field intended for spectral
- ! !!!derivatives, z-pencils, scalar
- END TYPE ppm_poisson_plan
-
- INTEGER,PARAMETER :: ppm_poisson_drv_none =0
- INTEGER,PARAMETER :: ppm_poisson_drv_curl_sp =1
- INTEGER,PARAMETER :: ppm_poisson_drv_grad_sp =2
- INTEGER,PARAMETER :: ppm_poisson_drv_lapl_sp =3
- INTEGER,PARAMETER :: ppm_poisson_drv_div_sp =4
- INTEGER,PARAMETER :: ppm_poisson_drv_curl_fd2=11
- INTEGER,PARAMETER :: ppm_poisson_drv_grad_fd2=12
- INTEGER,PARAMETER :: ppm_poisson_drv_lapl_fd2=13
- INTEGER,PARAMETER :: ppm_poisson_drv_div_fd2 =14
- INTEGER,PARAMETER :: ppm_poisson_drv_curl_fd4=21
- INTEGER,PARAMETER :: ppm_poisson_drv_grad_fd4=22
- INTEGER,PARAMETER :: ppm_poisson_drv_lapl_fd4=23
- INTEGER,PARAMETER :: ppm_poisson_drv_div_fd4 =24
-
- INTEGER,PARAMETER :: ppm_poisson_grn_pois_per =1
- INTEGER,PARAMETER :: ppm_poisson_grn_pois_fre =2
- INTEGER,PARAMETER :: ppm_poisson_grn_reprojec =3
-
- INTERFACE ppm_poisson_init
- MODULE PROCEDURE ppm_poisson_init
- END INTERFACE
-
- INTERFACE ppm_poisson_solve
- MODULE PROCEDURE ppm_poisson_solve
- END INTERFACE
-
- INTERFACE ppm_poisson_fd
- MODULE PROCEDURE ppm_poisson_fd
- END INTERFACE
-
- INTERFACE ppm_poisson_extrapolateghost
- MODULE PROCEDURE ppm_poisson_extrapolateghost_vr
- END INTERFACE
-
- CONTAINS
-#define __KIND __SINGLE
-
-#define __PREC ppm_kind_double
- !!#define __CMPLXDEF DCMPLX
-#define __DIM 3
-#define __ZEROSI (/0,0,0/)
-#define __NCOM 3
-#define __ROUTINE ppm_poisson_init
-#include "poisson/ppm_poisson_init.f"
-#undef __ROUTINE
-#define __ROUTINE ppm_poisson_solve
-#include "poisson/ppm_poisson_solve.f"
-#undef __ROUTINE
-#define __ROUTINE ppm_poisson_fd
-#include "poisson/ppm_poisson_fd.f"
-#undef __ROUTINE
-#define __ROUTINE ppm_poisson_extrapolateghost_vr
-#include "poisson/ppm_poisson_extrapolateghost.f"
-#undef __ROUTINE
-#undef __ZEROSI
-#undef __DIM
-#undef __NCOM
-
-#undef __KIND
-#define __KIND __DOUBLE
-
-
-#undef __KIND
- END MODULE ppm_module_poisson
-
-
diff --git a/src/ppm_module_user_numerics.f b/src/ppm_module_user_numerics.f
index 3cd956014eed19f642fee896d52cfcabe19deeb9..54a0e03c4e1559c82c133cad3120fc47ac03d3ee 100644
--- a/src/ppm_module_user_numerics.f
+++ b/src/ppm_module_user_numerics.f
@@ -25,13 +25,6 @@
!----------------------------------------------------------------------
! PPM numerics routines
!----------------------------------------------------------------------
- USE ppm_module_comp_part
- USE ppm_module_bem
- USE ppm_module_fieldsolver
USE ppm_module_ode
- USE ppm_module_mg
- USE ppm_module_fmm
- USE ppm_module_gmm
- USE ppm_module_hamjac
END MODULE ppm_module_user_numerics
diff --git a/src/ppm_module_util_fft_backward.f b/src/ppm_module_util_fft_backward.f
deleted file mode 100644
index b6717e90288ef930d221c224f84a0e650d93aa80..0000000000000000000000000000000000000000
--- a/src/ppm_module_util_fft_backward.f
+++ /dev/null
@@ -1,106 +0,0 @@
-#ifdef __XLF
-@PROCESS NOHOT
-#endif
- !-------------------------------------------------------------------------
- ! Module : ppm_module_util_fft_backward
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the utility
- ! routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_util_fft_backward.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/11/05 18:16:38 michaebe
- ! added xlf compiler directives
- !
- ! Revision 1.1 2004/07/26 07:30:12 ivos
- ! First commit after spitting the old modules into single-interface
- ! units.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 5
-#define __DOUBLE_PRECISION_COMPLEX 6
-
- MODULE ppm_module_util_fft_backward
-
- !----------------------------------------------------------------------
- ! Define interface to ppm_util_fft_backward
- !----------------------------------------------------------------------
- INTERFACE ppm_util_fft_backward
- MODULE PROCEDURE ppm_util_fft_backward_2ds
- MODULE PROCEDURE ppm_util_fft_backward_2dd
- MODULE PROCEDURE ppm_util_fft_backward_2dc
- MODULE PROCEDURE ppm_util_fft_backward_2dcc
-
- MODULE PROCEDURE ppm_util_fft_backward_3ds
- MODULE PROCEDURE ppm_util_fft_backward_3dd
- MODULE PROCEDURE ppm_util_fft_backward_3dc
- MODULE PROCEDURE ppm_util_fft_backward_3dcc
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_util_fft_backward_2d.f"
-#include "ppm_util_fft_backward_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_util_fft_backward_2d.f"
-#include "ppm_util_fft_backward_3d.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_util_fft_backward_2d.f"
-#include "ppm_util_fft_backward_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_util_fft_backward_2d.f"
-#include "ppm_util_fft_backward_3d.f"
-#undef __KIND
-
- END MODULE ppm_module_util_fft_backward
diff --git a/src/ppm_module_util_fft_forward.f b/src/ppm_module_util_fft_forward.f
deleted file mode 100644
index a0b2fcb2f33b8849e518aeefe7a70a117486643a..0000000000000000000000000000000000000000
--- a/src/ppm_module_util_fft_forward.f
+++ /dev/null
@@ -1,106 +0,0 @@
-#ifdef __XLF
-@PROCESS NOHOT
-#endif
- !-------------------------------------------------------------------------
- ! Module : ppm_module_util_fft_forward
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the utility
- ! routines.
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_util_fft_forward.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.2 2004/11/05 18:16:38 michaebe
- ! added xlf compiler directives
- !
- ! Revision 1.1 2004/07/26 07:30:12 ivos
- ! First commit after spitting the old modules into single-interface
- ! units.
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-#define __SINGLE_PRECISION_COMPLEX 5
-#define __DOUBLE_PRECISION_COMPLEX 6
-
- MODULE ppm_module_util_fft_forward
-
- !----------------------------------------------------------------------
- ! Define interface to ppm_util_fft_forward
- !----------------------------------------------------------------------
- INTERFACE ppm_util_fft_forward
- MODULE PROCEDURE ppm_util_fft_forward_2ds
- MODULE PROCEDURE ppm_util_fft_forward_2dd
- MODULE PROCEDURE ppm_util_fft_forward_2dc
- MODULE PROCEDURE ppm_util_fft_forward_2dcc
-
- MODULE PROCEDURE ppm_util_fft_forward_3ds
- MODULE PROCEDURE ppm_util_fft_forward_3dd
- MODULE PROCEDURE ppm_util_fft_forward_3dc
- MODULE PROCEDURE ppm_util_fft_forward_3dcc
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_util_fft_forward_2d.f"
-#include "ppm_util_fft_forward_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_util_fft_forward_2d.f"
-#include "ppm_util_fft_forward_3d.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION_COMPLEX
-#include "ppm_util_fft_forward_2d.f"
-#include "ppm_util_fft_forward_3d.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION_COMPLEX
-#include "ppm_util_fft_forward_2d.f"
-#include "ppm_util_fft_forward_3d.f"
-#undef __KIND
-
- END MODULE ppm_module_util_fft_forward
diff --git a/src/ppm_module_util_gmres.f b/src/ppm_module_util_gmres.f
deleted file mode 100644
index afff521ce3d5c7bd6749b5e766a2eb517a15d85d..0000000000000000000000000000000000000000
--- a/src/ppm_module_util_gmres.f
+++ /dev/null
@@ -1,96 +0,0 @@
- !-------------------------------------------------------------------------
- ! Module : ppm_module_util_gmres
- !-------------------------------------------------------------------------
- !
- ! Purpose : This module includes the source code for the GMRES
- ! solver
- !
- ! Remarks :
- !
- ! References :
- !
- ! Revisions :
- !-------------------------------------------------------------------------
- ! $Log: ppm_module_util_gmres.f,v $
- ! Revision 1.1.1.1 2007/07/13 10:19:00 ivos
- ! CBL version of the PPM library
- !
- ! Revision 1.1 2006/05/11 10:27:00 pchatela
- ! Initial insertion
- !
- !
- !
- !-------------------------------------------------------------------------
- ! Copyright (c) 2012 CSE Lab (ETH Zurich), MOSAIC Group (ETH Zurich),
- ! Center for Fluid Dynamics (DTU)
- !
- !
- ! This file is part of the Parallel Particle Mesh Library (PPM).
- !
- ! PPM is free software: you can redistribute it and/or modify
- ! it under the terms of the GNU Lesser General Public License
- ! as published by the Free Software Foundation, either
- ! version 3 of the License, or (at your option) any later
- ! version.
- !
- ! PPM is distributed in the hope that it will be useful,
- ! but WITHOUT ANY WARRANTY; without even the implied warranty of
- ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ! GNU General Public License for more details.
- !
- ! You should have received a copy of the GNU General Public License
- ! and the GNU Lesser General Public License along with PPM. If not,
- ! see <http://www.gnu.org/licenses/>.
- !
- ! Parallel Particle Mesh Library (PPM)
- ! ETH Zurich
- ! CH-8092 Zurich, Switzerland
-
- !-------------------------------------------------------------------------
-
- !-------------------------------------------------------------------------
- ! Define types
- !-------------------------------------------------------------------------
-#define __SINGLE_PRECISION 1
-#define __DOUBLE_PRECISION 2
-
- MODULE ppm_module_util_gmres
- INTEGER, PARAMETER :: ppm_gmres_param_success = 0
- INTEGER, PARAMETER :: ppm_gmres_param_failure = 1
- INTEGER, PARAMETER :: ppm_gmres_param_maxiter = 2
-
- !----------------------------------------------------------------------
- ! Define interfaces to the routine(s)
- !----------------------------------------------------------------------
- INTERFACE ppm_util_gmres
- MODULE PROCEDURE ppm_util_gmres_s
- MODULE PROCEDURE ppm_util_gmres_d
- END INTERFACE
-
- INTERFACE ppm_util_gmres_solveupper
- MODULE PROCEDURE ppm_util_gmres_solveupper_s
- MODULE PROCEDURE ppm_util_gmres_solveupper_d
- END INTERFACE
-
- !----------------------------------------------------------------------
- ! include the source
- !----------------------------------------------------------------------
- CONTAINS
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_util_gmres_solveupper.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_util_gmres_solveupper.f"
-#undef __KIND
-
-#define __KIND __SINGLE_PRECISION
-#include "ppm_util_gmres.f"
-#undef __KIND
-
-#define __KIND __DOUBLE_PRECISION
-#include "ppm_util_gmres.f"
-#undef __KIND
-
- END MODULE ppm_module_util_gmres
diff --git a/src/ppm_util_fft_backward_2d.f b/src/util/ppm_util_fft_backward_2d.f
similarity index 100%
rename from src/ppm_util_fft_backward_2d.f
rename to src/util/ppm_util_fft_backward_2d.f
diff --git a/src/ppm_util_fft_backward_3d.f b/src/util/ppm_util_fft_backward_3d.f
similarity index 100%
rename from src/ppm_util_fft_backward_3d.f
rename to src/util/ppm_util_fft_backward_3d.f
diff --git a/src/ppm_util_fft_forward_2d.f b/src/util/ppm_util_fft_forward_2d.f
similarity index 100%
rename from src/ppm_util_fft_forward_2d.f
rename to src/util/ppm_util_fft_forward_2d.f
diff --git a/src/ppm_util_fft_forward_3d.f b/src/util/ppm_util_fft_forward_3d.f
similarity index 100%
rename from src/ppm_util_fft_forward_3d.f
rename to src/util/ppm_util_fft_forward_3d.f
diff --git a/src/ppm_util_gmres.f b/src/util/ppm_util_gmres.f
similarity index 100%
rename from src/ppm_util_gmres.f
rename to src/util/ppm_util_gmres.f
diff --git a/src/ppm_util_gmres_solveupper.f b/src/util/ppm_util_gmres_solveupper.f
similarity index 100%
rename from src/ppm_util_gmres_solveupper.f
rename to src/util/ppm_util_gmres_solveupper.f