ppm_base.f90 3.25 KB
Newer Older
1
! ppm_base.f90 --- Fortran 90 interface to core functions
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
!
! Copyright  (C)  2010  Thomas Jahns <jahns@dkrz.de>
!
! Version: 1.0
! Keywords: core wrapper
! Author: Thomas Jahns <jahns@dkrz.de>
! Maintainer: Thomas Jahns <jahns@dkrz.de>
! URL: https://www.dkrz.de/redmine/projects/show/scales-ppm
!
! Redistribution and use in source and binary forms, with or without
! modification, are  permitted provided that the following conditions are
! met:
!
! Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
!
! Neither the name of the DKRZ GmbH nor the names of its contributors
! may be used to endorse or promote products derived from this software
! without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! Commentary:
!
! Look into core.c for functionality common to Fortran and C parts of PPM
! Also provides extra functionality for concise expressions.
!
! Code:
!
45
MODULE ppm_base
46
  IMPLICIT NONE
47
#ifdef USE_MPI
48
  INCLUDE 'mpif.h'
49
50
51
#else
  INTEGER, PARAMETER :: mpi_comm_world = 0
#endif
52
53
54
55
56
57
58
59
  PRIVATE
  PUBLIC :: abort_ppm, assertion
CONTAINS
  SUBROUTINE abort_ppm(msg, source, line, comm)
    CHARACTER(len=*), INTENT(in) :: source, msg
    INTEGER, INTENT(in) :: line
    INTEGER, OPTIONAL, INTENT(in) :: comm
    INTEGER :: comm_dummy
60
61
62
63
64
    IF (PRESENT(comm)) THEN
      comm_dummy = comm
    ELSE
      comm_dummy = mpi_comm_world
    END IF
65
66
67
    CALL abort_ppm_f(comm_dummy, msg, source, line)
  END SUBROUTINE abort_ppm

68
  SUBROUTINE assertion(cond, origfile, origline, msg)
69
    LOGICAL, INTENT(in) :: cond
70
    CHARACTER(len=*), OPTIONAL, INTENT(in) :: origfile, msg
71
72
73
    INTEGER, OPTIONAL, INTENT(in) :: origline
    CHARACTER(len=255) :: file
    INTEGER :: line
74
    CHARACTER(*), PARAMETER :: default_msg = 'assertion failed'
75
76
77
78
79
80
81
82
83
84
85

    IF (PRESENT(origfile)) THEN
      file = origfile
    ELSE
      file = 'unknown'
    ENDIF
    IF (PRESENT(origline)) THEN
      line = origline
    ELSE
      line = -1
    ENDIF
86
87
88
89
90
    IF (PRESENT(msg)) THEN
      IF (.NOT. cond) CALL abort_ppm(msg, TRIM(file), line)
    ELSE
      IF (.NOT. cond) CALL abort_ppm(default_msg, TRIM(file), line)
    END IF
91
92
  END SUBROUTINE assertion

93
END MODULE ppm_base
94
95
96
97
98
!
! Local Variables:
! license-project-url: "https://www.dkrz.de/redmine/projects/show/scales-ppm"
! license-default: "bsd"
! End: