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

Last change on this file since 10314 was 10314, checked in by smasson, 2 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
RevLine 
[2003]1MODULE lib_fortran
2   !!======================================================================
3   !!                       ***  MODULE  lib_fortran  ***
4   !! Fortran utilities:  includes some low levels fortran functionality
5   !!======================================================================
[2307]6   !! History :  3.2  !  2010-05  (M. Dunphy, R. Benshila)  Original code
[4161]7   !!            3.4  !  2013-06  (C. Rousset)  add glob_min, glob_max
8   !!                                           + 3d dim. of input is fexible (jpk, jpl...)
[7646]9   !!            4.0  !  2016-06  (T. Lovato)  double precision global sum by default
[2003]10   !!----------------------------------------------------------------------
[2307]11
[2003]12   !!----------------------------------------------------------------------
[3764]13   !!   glob_sum    : generic interface for global masked summation over
[2307]14   !!                 the interior domain for 1 or 2 2D or 3D arrays
[3764]15   !!                 it works only for T points
[2307]16   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
17   !!                 of intrinsinc sign function
18   !!----------------------------------------------------------------------
[3632]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
[2003]23
24   IMPLICIT NONE
25   PRIVATE
26
[6140]27   PUBLIC   glob_sum      ! used in many places (masked with tmask_i)
[7646]28   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos)
[6140]29   PUBLIC   DDPDD         ! also used in closea module
[4161]30   PUBLIC   glob_min, glob_max
[2341]31#if defined key_nosignedzero
[2003]32   PUBLIC SIGN
33#endif
34
35   INTERFACE glob_sum
[10314]36      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d
[2003]37   END INTERFACE
[6140]38   INTERFACE glob_sum_full
39      MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d
40   END INTERFACE
[4161]41   INTERFACE glob_min
[10314]42      MODULE PROCEDURE glob_min_2d, glob_min_3d
[4161]43   END INTERFACE
44   INTERFACE glob_max
[10314]45      MODULE PROCEDURE glob_max_2d, glob_max_3d
[4161]46   END INTERFACE
[2003]47
[3764]48#if defined key_nosignedzero
[2003]49   INTERFACE SIGN
[2307]50      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
[3764]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
[2003]53   END INTERFACE
54#endif
55
[2307]56   !!----------------------------------------------------------------------
[9598]57   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
[3764]58   !! $Id$
[10068]59   !! Software governed by the CeCILL license (see ./LICENSE)
[2307]60   !!----------------------------------------------------------------------
[3764]61CONTAINS
[2003]62
[10314]63#  define GLOBSUM_CODE
[3764]64
[10314]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
[2307]70
[10314]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
[2307]83
[10314]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
[2307]96
[10314]97#  undef GLOBSUM_CODE
[2307]98
[2003]99
[10314]100#  define GLOBMINMAX_CODE
[2307]101
[10314]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
[2307]114
[10314]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
[6140]128
129
[2003]130   SUBROUTINE DDPDD( ydda, yddb )
131      !!----------------------------------------------------------------------
132      !!               ***  ROUTINE DDPDD ***
[3764]133      !!
[2003]134      !! ** Purpose : Add a scalar element to a sum
135      !!
[3764]136      !!
137      !! ** Method  : The code uses the compensated summation with doublet
[2003]138      !!              (sum,error) emulated useing complex numbers. ydda is the
[3764]139      !!               scalar to add to the summ yddb
[2003]140      !!
[3764]141      !! ** Action  : This does only work for MPI.
142      !!
[2003]143      !! References : Using Acurate Arithmetics to Improve Numerical
144      !!              Reproducibility and Sability in Parallel Applications
[3764]145      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
[2003]146      !!----------------------------------------------------------------------
[2307]147      COMPLEX(wp), INTENT(in   ) ::   ydda
148      COMPLEX(wp), INTENT(inout) ::   yddb
149      !
[2003]150      REAL(wp) :: zerr, zt1, zt2  ! local work variables
[2307]151      !!-----------------------------------------------------------------------
152      !
[2003]153      ! Compute ydda + yddb using Knuth's trick.
[2307]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      !
[2003]159      ! The result is t1 + t2, after normalization.
[2307]160      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
161      !
[2003]162   END SUBROUTINE DDPDD
163
164#if defined key_nosignedzero
[2307]165   !!----------------------------------------------------------------------
166   !!   'key_nosignedzero'                                         F90 SIGN
167   !!----------------------------------------------------------------------
[3764]168
[2307]169   FUNCTION SIGN_SCALAR( pa, pb )
[2003]170      !!-----------------------------------------------------------------------
171      !!                  ***  FUNCTION SIGN_SCALAR  ***
172      !!
173      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
174      !!-----------------------------------------------------------------------
175      REAL(wp) :: pa,pb          ! input
[2307]176      REAL(wp) :: SIGN_SCALAR    ! result
177      !!-----------------------------------------------------------------------
178      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
179      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
[2003]180      ENDIF
181   END FUNCTION SIGN_SCALAR
182
[2307]183
[3764]184   FUNCTION SIGN_ARRAY_1D( pa, pb )
[2003]185      !!-----------------------------------------------------------------------
186      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
187      !!
188      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
189      !!-----------------------------------------------------------------------
[2307]190      REAL(wp) :: pa,pb(:)                   ! input
[2003]191      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
[2307]192      !!-----------------------------------------------------------------------
193      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
194      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
[2003]195      END WHERE
196   END FUNCTION SIGN_ARRAY_1D
197
[2307]198
[3764]199   FUNCTION SIGN_ARRAY_2D(pa,pb)
[2003]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
[2307]207      !!-----------------------------------------------------------------------
208      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
209      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
[2003]210      END WHERE
211   END FUNCTION SIGN_ARRAY_2D
212
[3764]213   FUNCTION SIGN_ARRAY_3D(pa,pb)
[2003]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
[2307]221      !!-----------------------------------------------------------------------
222      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
223      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
[2003]224      END WHERE
225   END FUNCTION SIGN_ARRAY_3D
226
[2307]227
[3764]228   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
[2003]229      !!-----------------------------------------------------------------------
230      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
231      !!
232      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
233      !!-----------------------------------------------------------------------
234      REAL(wp) :: pa(:),pb(:)      ! input
[2307]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)
[2003]239      END WHERE
240   END FUNCTION SIGN_ARRAY_1D_A
241
[2307]242
[3764]243   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
[2003]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
[2307]251      !!-----------------------------------------------------------------------
252      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
253      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
[2003]254      END WHERE
255   END FUNCTION SIGN_ARRAY_2D_A
256
[2307]257
[3764]258   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
[2003]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
[2307]266      !!-----------------------------------------------------------------------
267      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
268      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
[2003]269      END WHERE
270   END FUNCTION SIGN_ARRAY_3D_A
271
[2307]272
[3764]273   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
[2003]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
[2307]281      !!-----------------------------------------------------------------------
282      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
283      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
[2003]284      ENDIF
285   END FUNCTION SIGN_ARRAY_1D_B
286
[2307]287
[3764]288   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
[2003]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
[2307]296      !!-----------------------------------------------------------------------
297      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
298      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
[2003]299      ENDIF
300   END FUNCTION SIGN_ARRAY_2D_B
301
[2307]302
[3764]303   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
[2003]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
[2307]311      !!-----------------------------------------------------------------------
312      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
313      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
[2003]314      ENDIF
315   END FUNCTION SIGN_ARRAY_3D_B
316#endif
317
[2307]318   !!======================================================================
[2003]319END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.