New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lib_fortran.F90 in NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE – NEMO

source: NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/lib_fortran.F90 @ 10372

Last change on this file since 10372 was 10314, checked in by smasson, 5 years ago

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 2: add generic glob_min/max/sum and locmin/max, complete timing and report (including bdy and icb), see #2133

  • Property svn:keywords set to Id
File size: 13.0 KB
Line 
1MODULE lib_fortran
2   !!======================================================================
3   !!                       ***  MODULE  lib_fortran  ***
4   !! Fortran utilities:  includes some low levels fortran functionality
5   !!======================================================================
6   !! History :  3.2  !  2010-05  (M. Dunphy, R. Benshila)  Original code
7   !!            3.4  !  2013-06  (C. Rousset)  add glob_min, glob_max
8   !!                                           + 3d dim. of input is fexible (jpk, jpl...)
9   !!            4.0  !  2016-06  (T. Lovato)  double precision global sum by default
10   !!----------------------------------------------------------------------
11
12   !!----------------------------------------------------------------------
13   !!   glob_sum    : generic interface for global masked summation over
14   !!                 the interior domain for 1 or 2 2D or 3D arrays
15   !!                 it works only for T points
16   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
17   !!                 of intrinsinc sign function
18   !!----------------------------------------------------------------------
19   USE par_oce         ! Ocean parameter
20   USE dom_oce         ! ocean domain
21   USE in_out_manager  ! I/O manager
22   USE lib_mpp         ! distributed memory computing
23
24   IMPLICIT NONE
25   PRIVATE
26
27   PUBLIC   glob_sum      ! used in many places (masked with tmask_i)
28   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos)
29   PUBLIC   DDPDD         ! also used in closea module
30   PUBLIC   glob_min, glob_max
31#if defined key_nosignedzero
32   PUBLIC SIGN
33#endif
34
35   INTERFACE glob_sum
36      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d
37   END INTERFACE
38   INTERFACE glob_sum_full
39      MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d
40   END INTERFACE
41   INTERFACE glob_min
42      MODULE PROCEDURE glob_min_2d, glob_min_3d
43   END INTERFACE
44   INTERFACE glob_max
45      MODULE PROCEDURE glob_max_2d, glob_max_3d
46   END INTERFACE
47
48#if defined key_nosignedzero
49   INTERFACE SIGN
50      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
51         &             SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,          &
52         &             SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
53   END INTERFACE
54#endif
55
56   !!----------------------------------------------------------------------
57   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
58   !! $Id$
59   !! Software governed by the CeCILL license (see ./LICENSE)
60   !!----------------------------------------------------------------------
61CONTAINS
62
63#  define GLOBSUM_CODE
64
65#     define DIM_1d
66#     define FUNCTION_GLOBSUM           glob_sum_1d
67#     include "lib_fortran_generic.h90"
68#     undef FUNCTION_GLOBSUM
69#     undef DIM_1d
70
71#     define DIM_2d
72#     define OPERATION_GLOBSUM
73#     define FUNCTION_GLOBSUM           glob_sum_2d
74#     include "lib_fortran_generic.h90"
75#     undef FUNCTION_GLOBSUM
76#     undef OPERATION_GLOBSUM
77#     define OPERATION_FULL_GLOBSUM
78#     define FUNCTION_GLOBSUM           glob_sum_full_2d
79#     include "lib_fortran_generic.h90"
80#     undef FUNCTION_GLOBSUM
81#     undef OPERATION_FULL_GLOBSUM
82#     undef DIM_2d
83
84#     define DIM_3d
85#     define OPERATION_GLOBSUM
86#     define FUNCTION_GLOBSUM           glob_sum_3d
87#     include "lib_fortran_generic.h90"
88#     undef FUNCTION_GLOBSUM
89#     undef OPERATION_GLOBSUM
90#     define OPERATION_FULL_GLOBSUM
91#     define FUNCTION_GLOBSUM           glob_sum_full_3d
92#     include "lib_fortran_generic.h90"
93#     undef FUNCTION_GLOBSUM
94#     undef OPERATION_FULL_GLOBSUM
95#     undef DIM_3d
96
97#  undef GLOBSUM_CODE
98
99
100#  define GLOBMINMAX_CODE
101
102#     define DIM_2d
103#     define OPERATION_GLOBMIN
104#     define FUNCTION_GLOBMINMAX           glob_min_2d
105#     include "lib_fortran_generic.h90"
106#     undef FUNCTION_GLOBMINMAX
107#     undef OPERATION_GLOBMIN
108#     define OPERATION_GLOBMAX
109#     define FUNCTION_GLOBMINMAX           glob_max_2d
110#     include "lib_fortran_generic.h90"
111#     undef FUNCTION_GLOBMINMAX
112#     undef OPERATION_GLOBMAX
113#     undef DIM_2d
114
115#     define DIM_3d
116#     define OPERATION_GLOBMIN
117#     define FUNCTION_GLOBMINMAX           glob_min_3d
118#     include "lib_fortran_generic.h90"
119#     undef FUNCTION_GLOBMINMAX
120#     undef OPERATION_GLOBMIN
121#     define OPERATION_GLOBMAX
122#     define FUNCTION_GLOBMINMAX           glob_max_3d
123#     include "lib_fortran_generic.h90"
124#     undef FUNCTION_GLOBMINMAX
125#     undef OPERATION_GLOBMAX
126#     undef DIM_3d
127#  undef GLOBMINMAX_CODE
128
129
130   SUBROUTINE DDPDD( ydda, yddb )
131      !!----------------------------------------------------------------------
132      !!               ***  ROUTINE DDPDD ***
133      !!
134      !! ** Purpose : Add a scalar element to a sum
135      !!
136      !!
137      !! ** Method  : The code uses the compensated summation with doublet
138      !!              (sum,error) emulated useing complex numbers. ydda is the
139      !!               scalar to add to the summ yddb
140      !!
141      !! ** Action  : This does only work for MPI.
142      !!
143      !! References : Using Acurate Arithmetics to Improve Numerical
144      !!              Reproducibility and Sability in Parallel Applications
145      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
146      !!----------------------------------------------------------------------
147      COMPLEX(wp), INTENT(in   ) ::   ydda
148      COMPLEX(wp), INTENT(inout) ::   yddb
149      !
150      REAL(wp) :: zerr, zt1, zt2  ! local work variables
151      !!-----------------------------------------------------------------------
152      !
153      ! Compute ydda + yddb using Knuth's trick.
154      zt1  = REAL(ydda) + REAL(yddb)
155      zerr = zt1 - REAL(ydda)
156      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
157         &   + AIMAG(ydda)         + AIMAG(yddb)
158      !
159      ! The result is t1 + t2, after normalization.
160      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
161      !
162   END SUBROUTINE DDPDD
163
164#if defined key_nosignedzero
165   !!----------------------------------------------------------------------
166   !!   'key_nosignedzero'                                         F90 SIGN
167   !!----------------------------------------------------------------------
168
169   FUNCTION SIGN_SCALAR( pa, pb )
170      !!-----------------------------------------------------------------------
171      !!                  ***  FUNCTION SIGN_SCALAR  ***
172      !!
173      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
174      !!-----------------------------------------------------------------------
175      REAL(wp) :: pa,pb          ! input
176      REAL(wp) :: SIGN_SCALAR    ! result
177      !!-----------------------------------------------------------------------
178      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
179      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
180      ENDIF
181   END FUNCTION SIGN_SCALAR
182
183
184   FUNCTION SIGN_ARRAY_1D( pa, pb )
185      !!-----------------------------------------------------------------------
186      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
187      !!
188      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
189      !!-----------------------------------------------------------------------
190      REAL(wp) :: pa,pb(:)                   ! input
191      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
192      !!-----------------------------------------------------------------------
193      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
194      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
195      END WHERE
196   END FUNCTION SIGN_ARRAY_1D
197
198
199   FUNCTION SIGN_ARRAY_2D(pa,pb)
200      !!-----------------------------------------------------------------------
201      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
202      !!
203      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
204      !!-----------------------------------------------------------------------
205      REAL(wp) :: pa,pb(:,:)      ! input
206      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
207      !!-----------------------------------------------------------------------
208      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
209      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
210      END WHERE
211   END FUNCTION SIGN_ARRAY_2D
212
213   FUNCTION SIGN_ARRAY_3D(pa,pb)
214      !!-----------------------------------------------------------------------
215      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
216      !!
217      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
218      !!-----------------------------------------------------------------------
219      REAL(wp) :: pa,pb(:,:,:)      ! input
220      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
221      !!-----------------------------------------------------------------------
222      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
223      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
224      END WHERE
225   END FUNCTION SIGN_ARRAY_3D
226
227
228   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
229      !!-----------------------------------------------------------------------
230      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
231      !!
232      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
233      !!-----------------------------------------------------------------------
234      REAL(wp) :: pa(:),pb(:)      ! input
235      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
236      !!-----------------------------------------------------------------------
237      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
238      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
239      END WHERE
240   END FUNCTION SIGN_ARRAY_1D_A
241
242
243   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
244      !!-----------------------------------------------------------------------
245      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
246      !!
247      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
248      !!-----------------------------------------------------------------------
249      REAL(wp) :: pa(:,:),pb(:,:)      ! input
250      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
251      !!-----------------------------------------------------------------------
252      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
253      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
254      END WHERE
255   END FUNCTION SIGN_ARRAY_2D_A
256
257
258   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
259      !!-----------------------------------------------------------------------
260      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
261      !!
262      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
263      !!-----------------------------------------------------------------------
264      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
265      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
266      !!-----------------------------------------------------------------------
267      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
268      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
269      END WHERE
270   END FUNCTION SIGN_ARRAY_3D_A
271
272
273   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
274      !!-----------------------------------------------------------------------
275      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
276      !!
277      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
278      !!-----------------------------------------------------------------------
279      REAL(wp) :: pa(:),pb      ! input
280      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
281      !!-----------------------------------------------------------------------
282      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
283      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
284      ENDIF
285   END FUNCTION SIGN_ARRAY_1D_B
286
287
288   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
289      !!-----------------------------------------------------------------------
290      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
291      !!
292      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
293      !!-----------------------------------------------------------------------
294      REAL(wp) :: pa(:,:),pb      ! input
295      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
296      !!-----------------------------------------------------------------------
297      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
298      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
299      ENDIF
300   END FUNCTION SIGN_ARRAY_2D_B
301
302
303   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
304      !!-----------------------------------------------------------------------
305      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
306      !!
307      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
308      !!-----------------------------------------------------------------------
309      REAL(wp) :: pa(:,:,:),pb      ! input
310      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
311      !!-----------------------------------------------------------------------
312      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
313      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
314      ENDIF
315   END FUNCTION SIGN_ARRAY_3D_B
316#endif
317
318   !!======================================================================
319END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.