Yet Another eXchange Tool  0.9.0
xt_request_f.f90
Go to the documentation of this file.
1 
13 
14 !
15 ! Keywords:
16 ! Maintainer: Jörg Behrens <behrens@dkrz.de>
17 ! Moritz Hanke <hanke@dkrz.de>
18 ! Thomas Jahns <jahns@dkrz.de>
19 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
20 !
21 ! Redistribution and use in source and binary forms, with or without
22 ! modification, are permitted provided that the following conditions are
23 ! met:
24 !
25 ! Redistributions of source code must retain the above copyright notice,
26 ! this list of conditions and the following disclaimer.
27 !
28 ! Redistributions in binary form must reproduce the above copyright
29 ! notice, this list of conditions and the following disclaimer in the
30 ! documentation and/or other materials provided with the distribution.
31 !
32 ! Neither the name of the DKRZ GmbH nor the names of its contributors
33 ! may be used to endorse or promote products derived from this software
34 ! without specific prior written permission.
35 !
36 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37 ! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38 ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39 ! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40 ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
47 !
48 
50  USE iso_c_binding, ONLY: c_null_ptr, c_ptr, c_associated, c_int
51  IMPLICIT NONE
52  PRIVATE
53 
54  TYPE, BIND(C), PUBLIC :: xt_request
55 #ifndef __G95__
56  PRIVATE
57 #endif
58  TYPE(c_ptr) :: cptr = c_null_ptr
59  END TYPE xt_request
60 
62  xt_is_null
63 
64  INTERFACE
65  ! this function must not be implemented in Fortran because
66  ! PGI 11.x chokes on that
67  FUNCTION xt_request_f2c(request) bind(c, name='xt_request_f2c') RESULT(p)
68  IMPORT :: c_ptr, xt_request
69  IMPLICIT NONE
70  TYPE(xt_request), INTENT(in) :: request
71  TYPE(c_ptr) :: p
72  END FUNCTION xt_request_f2c
73 
74  SUBROUTINE xt_request_wait(request) bind(C, name='xt_request_wait')
75  IMPORT :: xt_request
76  TYPE(xt_request), INTENT(inout) :: request
77  END SUBROUTINE xt_request_wait
78 
79  END INTERFACE
80 
81  TYPE(xt_request), PARAMETER, PUBLIC :: xt_request_null = xt_request(c_null_ptr)
82 
83  INTERFACE xt_is_null
84  MODULE PROCEDURE xt_request_is_null
85  END INTERFACE xt_is_null
86 
87 CONTAINS
88 
89  SUBROUTINE xt_request_init(request, cptr)
90  TYPE(xt_request),INTENT(out) :: request
91  TYPE(c_ptr), INTENT(in) :: cptr
92  request%cptr = cptr
93  END SUBROUTINE xt_request_init
94 
95 
96  SUBROUTINE xt_request_test(request, flag)
97  TYPE(xt_request), INTENT(inout) :: request
98  LOGICAL, INTENT(out) :: flag
99  INTEGER(c_int) :: flag_c
100  INTERFACE
101  SUBROUTINE xt_request_test_c(request_c, flag_c) &
102  bind(c, name='xt_request_test')
103  import:: c_ptr, c_int
104  TYPE(c_ptr), INTENT(inout) :: request_c
105  INTEGER(c_int), INTENT(out) :: flag_c
106  END SUBROUTINE xt_request_test_c
107  END INTERFACE
108  CALL xt_request_test_c(request%cptr, flag_c)
109  flag = flag_c /= 0
110  END SUBROUTINE xt_request_test
111 
112  FUNCTION xt_request_is_null(request) RESULT(p)
113  TYPE(xt_request), INTENT(in) :: request
114  LOGICAL :: p
115  p = .NOT. c_associated(request%cptr)
116  END FUNCTION xt_request_is_null
117 
118 END MODULE xt_requests
119 !
120 ! Local Variables:
121 ! f90-continuation-indent: 5
122 ! coding: utf-8
123 ! indent-tabs-mode: nil
124 ! show-trailing-whitespace: t
125 ! require-trailing-newline: t
126 ! End:
127 !
subroutine, public xt_request_init(request, cptr)
type(xt_request), parameter, public xt_request_null
void xt_request_wait(Xt_request *request)
Definition: xt_request.c:57
void xt_request_test(Xt_request *request, int *flag)
Definition: xt_request.c:65