source: XIOS3/trunk/src/interface/fortran/ilogical_bool_conversion.f90

Last change on this file was 2622, checked in by jderouillat, 4 months ago

Logical comparison requires eqv (not eq)
File size: 9.0 KB
Line 
1MODULE logical_bool_conversion
2
3  USE, INTRINSIC :: ISO_C_BINDING
4  INTERFACE
5    FUNCTION cxios_set_logical_true() BIND(C)
6      USE ISO_C_BINDING
7      LOGICAL(kind=C_BOOL) :: cxios_set_logical_true
8    END FUNCTION cxios_set_logical_true
9
10    FUNCTION cxios_set_logical_false() BIND(C)
11      USE ISO_C_BINDING
12      LOGICAL(kind=C_BOOL) :: cxios_set_logical_false
13    END FUNCTION cxios_set_logical_false
14  END INTERFACE
15
16CONTAINS
17  SUBROUTINE xios_logical_to_bool_0d(tmp)
18    IMPLICIT NONE
19    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp
20    LOGICAL (KIND=C_BOOL) :: ctrue, cfalse
21    ctrue  =  cxios_set_logical_true()
22    cfalse =  cxios_set_logical_false()
23    if (tmp.eqv..false.) then
24      tmp = cfalse
25    else
26      tmp = ctrue
27    endif
28  END SUBROUTINE xios_logical_to_bool_0d
29
30  SUBROUTINE xios_logical_to_bool_1d(tmp, ni_)
31    IMPLICIT NONE
32    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:)
33    INTEGER, INTENT(IN) :: ni_(:)
34    INTEGER :: ij
35    LOGICAL (KIND=C_BOOL) :: ctrue, cfalse
36    ctrue  =  cxios_set_logical_true()
37    cfalse =  cxios_set_logical_false()
38    do ij=1,ni_(1)
39       if (tmp(ij).eqv..false.) then
40          tmp(ij) = cfalse
41       else
42          tmp(ij) = ctrue
43       endif
44    enddo
45  END SUBROUTINE xios_logical_to_bool_1d
46
47  SUBROUTINE xios_logical_to_bool_2d(tmp, ni_)
48    IMPLICIT NONE
49    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:)
50    INTEGER, INTENT(IN) :: ni_(:)
51    INTEGER :: i,j
52    LOGICAL (KIND=C_BOOL) :: ctrue, cfalse
53    ctrue  =  cxios_set_logical_true()
54    cfalse =  cxios_set_logical_false()
55    do j=1,ni_(2)
56      do i=1,ni_(1)
57        if (tmp(i,j).eqv..false.) then
58          tmp(i,j) = cfalse
59        else
60          tmp(i,j) = ctrue
61        endif
62      enddo
63    enddo
64  END SUBROUTINE xios_logical_to_bool_2d
65
66  SUBROUTINE xios_logical_to_bool_3d(tmp, ni_)
67    IMPLICIT NONE
68    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:)
69    INTEGER, INTENT(IN) :: ni_(:)
70    INTEGER :: i,j,k
71    LOGICAL (KIND=C_BOOL) :: ctrue, cfalse
72    ctrue  =  cxios_set_logical_true()
73    cfalse =  cxios_set_logical_false()
74    do k=1,ni_(3)
75      do j=1,ni_(2)
76        do i=1,ni_(1)
77          if (tmp(i,j,k).eqv..false.) then
78            tmp(i,j,k) = cfalse
79          else
80            tmp(i,j,k) = ctrue
81          endif
82        enddo
83      enddo
84    enddo
85  END SUBROUTINE xios_logical_to_bool_3d
86 
87  SUBROUTINE xios_logical_to_bool_4d(tmp, ni_)
88    IMPLICIT NONE
89    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:,:)
90    INTEGER, INTENT(IN) :: ni_(:)
91    INTEGER :: i,j,k,l
92    LOGICAL (KIND=C_BOOL) :: ctrue, cfalse
93    ctrue  =  cxios_set_logical_true()
94    cfalse =  cxios_set_logical_false()
95    do l=1,ni_(4)
96      do k=1,ni_(3)
97        do j=1,ni_(2)
98          do i=1,ni_(1)
99            if (tmp(i,j,k,l).eqv..false.) then
100              tmp(i,j,k,l) = cfalse
101            else
102              tmp(i,j,k,l) = ctrue
103            endif
104          enddo
105        enddo
106      enddo
107    enddo
108  END SUBROUTINE xios_logical_to_bool_4d
109
110  SUBROUTINE xios_logical_to_bool_5d(tmp, ni_)
111    IMPLICIT NONE
112    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:,:,:)
113    INTEGER, INTENT(IN) :: ni_(:)
114    INTEGER :: i,j,k,l,m
115    LOGICAL (KIND=C_BOOL) :: ctrue, cfalse
116    ctrue  =  cxios_set_logical_true()
117    cfalse =  cxios_set_logical_false()
118    do m=1,ni_(5)
119      do l=1,ni_(4)
120        do k=1,ni_(3)
121          do j=1,ni_(2)
122            do i=1,ni_(1)
123              if (tmp(i,j,k,l,m).eqv..false.) then
124                tmp(i,j,k,l,m) = cfalse
125              else
126                tmp(i,j,k,l,m) = ctrue
127              endif
128            enddo
129          enddo
130        enddo
131      enddo
132    enddo
133  END SUBROUTINE xios_logical_to_bool_5d
134 
135  SUBROUTINE xios_logical_to_bool_6d(tmp, ni_)
136    IMPLICIT NONE
137    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:,:,:,:)
138    INTEGER, INTENT(IN) :: ni_(:)
139    INTEGER :: i,j,k,l,m,p
140    LOGICAL (KIND=C_BOOL) :: ctrue, cfalse
141    ctrue  =  cxios_set_logical_true()
142    cfalse =  cxios_set_logical_false()
143    do p=1,ni_(6)
144      do m=1,ni_(5)
145        do l=1,ni_(4)
146          do k=1,ni_(3)
147            do j=1,ni_(2)
148              do i=1,ni_(1)
149                if (tmp(i,j,k,l,m,p).eqv..false.) then
150                  tmp(i,j,k,l,m,p) = cfalse
151                else
152                  tmp(i,j,k,l,m,p) = ctrue
153                endif
154              enddo
155            enddo
156          enddo
157        enddo
158      enddo
159    enddo
160  END SUBROUTINE xios_logical_to_bool_6d
161 
162  SUBROUTINE xios_logical_to_bool_7d(tmp, ni_)
163    IMPLICIT NONE
164    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:,:,:,:,:)
165    INTEGER, INTENT(IN) :: ni_(:)
166    INTEGER :: i,j,k,l,m,p,q
167    LOGICAL (KIND=C_BOOL) :: ctrue, cfalse
168    ctrue  =  cxios_set_logical_true()
169    cfalse =  cxios_set_logical_false()
170    do q=1,ni_(7)
171      do p=1,ni_(6)
172        do m=1,ni_(5)
173          do l=1,ni_(4)
174            do k=1,ni_(3)
175              do j=1,ni_(2)
176                do i=1,ni_(1)
177                  if (tmp(i,j,k,l,m,p,q).eqv..false.) then
178                    tmp(i,j,k,l,m,p,q) = cfalse
179                  else
180                    tmp(i,j,k,l,m,p,q) = ctrue
181                  endif
182                enddo
183              enddo
184            enddo
185          enddo
186        enddo
187      enddo
188    enddo
189  END SUBROUTINE xios_logical_to_bool_7d
190
191
192  SUBROUTINE xios_bool_to_logical_0d(tmp)
193    IMPLICIT NONE
194    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp
195    if (tmp.eqv..false.) then
196      tmp = .false.
197    else
198      tmp = .true.
199    endif
200  END SUBROUTINE xios_bool_to_logical_0d
201
202  SUBROUTINE xios_bool_to_logical_1d(tmp, ni_)
203    IMPLICIT NONE
204    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:)
205    INTEGER, INTENT(IN) :: ni_(:)
206    INTEGER :: ij
207    do ij=1,ni_(1)
208       if (tmp(ij).eqv..false.) then
209          tmp(ij) = .false.
210       else
211          tmp(ij) = .true.
212       endif
213    enddo
214  END SUBROUTINE xios_bool_to_logical_1d
215
216  SUBROUTINE xios_bool_to_logical_2d(tmp, ni_)
217    IMPLICIT NONE
218    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:)
219    INTEGER, INTENT(IN) :: ni_(:)
220    INTEGER :: i,j
221    do j=1,ni_(2)
222      do i=1,ni_(1)
223        if (tmp(i,j).eqv..false.) then
224          tmp(i,j) = .false.
225        else
226          tmp(i,j) = .true.
227        endif
228      enddo
229    enddo
230  END SUBROUTINE xios_bool_to_logical_2d
231
232  SUBROUTINE xios_bool_to_logical_3d(tmp, ni_)
233    IMPLICIT NONE
234    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:)
235    INTEGER, INTENT(IN) :: ni_(:)
236    INTEGER :: i,j,k
237    do k=1,ni_(3)
238      do j=1,ni_(2)
239        do i=1,ni_(1)
240          if (tmp(i,j,k).eqv..false.) then
241            tmp(i,j,k) = .false.
242          else
243            tmp(i,j,k) = .true.
244          endif
245        enddo
246      enddo
247    enddo
248  END SUBROUTINE xios_bool_to_logical_3d
249 
250  SUBROUTINE xios_bool_to_logical_4d(tmp, ni_)
251    IMPLICIT NONE
252    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:,:)
253    INTEGER, INTENT(IN) :: ni_(:)
254    INTEGER :: i,j,k,l
255    do l=1,ni_(4)
256      do k=1,ni_(3)
257        do j=1,ni_(2)
258          do i=1,ni_(1)
259            if (tmp(i,j,k,l).eqv..false.) then
260              tmp(i,j,k,l) = .false.
261            else
262              tmp(i,j,k,l) = .true.
263            endif
264          enddo
265        enddo
266      enddo
267    enddo
268  END SUBROUTINE xios_bool_to_logical_4d
269
270  SUBROUTINE xios_bool_to_logical_5d(tmp, ni_)
271    IMPLICIT NONE
272    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:,:,:)
273    INTEGER, INTENT(IN) :: ni_(:)
274    INTEGER :: i,j,k,l,m
275    do m=1,ni_(5)
276      do l=1,ni_(4)
277        do k=1,ni_(3)
278          do j=1,ni_(2)
279            do i=1,ni_(1)
280              if (tmp(i,j,k,l,m).eqv..false.) then
281                tmp(i,j,k,l,m) = .false.
282              else
283                tmp(i,j,k,l,m) = .true.
284              endif
285            enddo
286          enddo
287        enddo
288      enddo
289    enddo
290  END SUBROUTINE xios_bool_to_logical_5d
291 
292  SUBROUTINE xios_bool_to_logical_6d(tmp, ni_)
293    IMPLICIT NONE
294    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:,:,:,:)
295    INTEGER, INTENT(IN) :: ni_(:)
296    INTEGER :: i,j,k,l,m,p
297    do p=1,ni_(6)
298      do m=1,ni_(5)
299        do l=1,ni_(4)
300          do k=1,ni_(3)
301            do j=1,ni_(2)
302              do i=1,ni_(1)
303                if (tmp(i,j,k,l,m,p).eqv..false.) then
304                  tmp(i,j,k,l,m,p) = .false.
305                else
306                  tmp(i,j,k,l,m,p) = .true.
307                endif
308              enddo
309            enddo
310          enddo
311        enddo
312      enddo
313    enddo
314  END SUBROUTINE xios_bool_to_logical_6d
315 
316  SUBROUTINE xios_bool_to_logical_7d(tmp, ni_)
317    IMPLICIT NONE
318    LOGICAL (KIND=C_BOOL), INTENT(INOUT) :: tmp(:,:,:,:,:,:,:)
319    INTEGER, INTENT(IN) :: ni_(:)
320    INTEGER :: i,j,k,l,m,p,q
321    do q=1,ni_(7)
322      do p=1,ni_(6)
323        do m=1,ni_(5)
324          do l=1,ni_(4)
325            do k=1,ni_(3)
326              do j=1,ni_(2)
327                do i=1,ni_(1)
328                  if (tmp(i,j,k,l,m,p,q).eqv..false.) then
329                    tmp(i,j,k,l,m,p,q) = .false.
330                  else
331                    tmp(i,j,k,l,m,p,q) = .true.
332                  endif
333                enddo
334              enddo
335            enddo
336          enddo
337        enddo
338      enddo
339    enddo
340  END SUBROUTINE xios_bool_to_logical_7d
341 
342END MODULE logical_bool_conversion
343
344
Note: See TracBrowser for help on using the repository browser.