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 branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC – NEMO

source: branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90 @ 6486

Last change on this file since 6486 was 6486, checked in by davestorkey, 8 years ago

Remove SVN keywords from UKMO/dev_r5518_GO6_package branch.

File size: 28.4 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...)
[2003]9   !!----------------------------------------------------------------------
[2307]10
[2003]11   !!----------------------------------------------------------------------
[3764]12   !!   glob_sum    : generic interface for global masked summation over
[2307]13   !!                 the interior domain for 1 or 2 2D or 3D arrays
[3764]14   !!                 it works only for T points
[2307]15   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
16   !!                 of intrinsinc sign function
17   !!----------------------------------------------------------------------
[3632]18   USE par_oce         ! Ocean parameter
19   USE dom_oce         ! ocean domain
20   USE in_out_manager  ! I/O manager
21   USE lib_mpp         ! distributed memory computing
[2003]22
23   IMPLICIT NONE
24   PRIVATE
25
[3632]26   PUBLIC   glob_sum   ! used in many places
27   PUBLIC   DDPDD      ! also used in closea module
[4161]28   PUBLIC   glob_min, glob_max
[2341]29#if defined key_nosignedzero
[2003]30   PUBLIC SIGN
31#endif
32
33   INTERFACE glob_sum
[3764]34      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, &
35         &             glob_sum_2d_a, glob_sum_3d_a
[2003]36   END INTERFACE
[4161]37   INTERFACE glob_min
38      MODULE PROCEDURE glob_min_2d, glob_min_3d,glob_min_2d_a, glob_min_3d_a 
39   END INTERFACE
40   INTERFACE glob_max
41      MODULE PROCEDURE glob_max_2d, glob_max_3d,glob_max_2d_a, glob_max_3d_a 
42   END INTERFACE
[2003]43
[3764]44#if defined key_nosignedzero
[2003]45   INTERFACE SIGN
[2307]46      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
[3764]47         &             SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,          &
48         &             SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
[2003]49   END INTERFACE
50#endif
51
[2307]52   !!----------------------------------------------------------------------
53   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
[3764]54   !! $Id$
[2307]55   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
56   !!----------------------------------------------------------------------
[3764]57CONTAINS
[2003]58
[2307]59#if ! defined key_mpp_rep
[4161]60   ! --- SUM ---
61
[3764]62   FUNCTION glob_sum_1d( ptab, kdim )
63      !!-----------------------------------------------------------------------
64      !!                  ***  FUNCTION  glob_sum_1D  ***
65      !!
66      !! ** Purpose : perform a masked sum on the inner global domain of a 1D array
67      !!-----------------------------------------------------------------------
68      INTEGER :: kdim
69      REAL(wp), INTENT(in), DIMENSION(kdim) ::   ptab        ! input 1D array
70      REAL(wp)                              ::   glob_sum_1d ! global sum
71      !!-----------------------------------------------------------------------
72      !
73      glob_sum_1d = SUM( ptab(:) )
74      IF( lk_mpp )   CALL mpp_sum( glob_sum_1d )
75      !
76   END FUNCTION glob_sum_1d
[3632]77
[3764]78   FUNCTION glob_sum_2d( ptab )
[2003]79      !!-----------------------------------------------------------------------
80      !!                  ***  FUNCTION  glob_sum_2D  ***
81      !!
[2307]82      !! ** Purpose : perform a masked sum on the inner global domain of a 2D array
[2003]83      !!-----------------------------------------------------------------------
[3294]84      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
85      REAL(wp)                             ::   glob_sum_2d   ! global masked sum
[2003]86      !!-----------------------------------------------------------------------
[2307]87      !
[3294]88      glob_sum_2d = SUM( ptab(:,:)*tmask_i(:,:) )
89      IF( lk_mpp )   CALL mpp_sum( glob_sum_2d )
[2307]90      !
[2003]91   END FUNCTION glob_sum_2d
[3764]92
93
94   FUNCTION glob_sum_3d( ptab )
[2003]95      !!-----------------------------------------------------------------------
96      !!                  ***  FUNCTION  glob_sum_3D  ***
97      !!
[2307]98      !! ** Purpose : perform a masked sum on the inner global domain of a 3D array
[2003]99      !!-----------------------------------------------------------------------
[3294]100      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
101      REAL(wp)                               ::   glob_sum_3d   ! global masked sum
[2307]102      !!
[2003]103      INTEGER :: jk
[4161]104      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
[2003]105      !!-----------------------------------------------------------------------
[2307]106      !
[4161]107      ijpk = SIZE(ptab,3)
108      !
[3294]109      glob_sum_3d = 0.e0
[4161]110      DO jk = 1, ijpk
[3294]111         glob_sum_3d = glob_sum_3d + SUM( ptab(:,:,jk)*tmask_i(:,:) )
[2003]112      END DO
[3294]113      IF( lk_mpp )   CALL mpp_sum( glob_sum_3d )
[2307]114      !
[2003]115   END FUNCTION glob_sum_3d
116
[2307]117
[3764]118   FUNCTION glob_sum_2d_a( ptab1, ptab2 )
[2003]119      !!-----------------------------------------------------------------------
120      !!                  ***  FUNCTION  glob_sum_2D _a ***
121      !!
[2307]122      !! ** Purpose : perform a masked sum on the inner global domain of two 2D array
[2003]123      !!-----------------------------------------------------------------------
[3294]124      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
125      REAL(wp)            , DIMENSION(2)   ::   glob_sum_2d_a   ! global masked sum
[2003]126      !!-----------------------------------------------------------------------
[3764]127      !
[3294]128      glob_sum_2d_a(1) = SUM( ptab1(:,:)*tmask_i(:,:) )
129      glob_sum_2d_a(2) = SUM( ptab2(:,:)*tmask_i(:,:) )
130      IF( lk_mpp )   CALL mpp_sum( glob_sum_2d_a, 2 )
[2307]131      !
[2003]132   END FUNCTION glob_sum_2d_a
[3764]133
134
135   FUNCTION glob_sum_3d_a( ptab1, ptab2 )
[2003]136      !!-----------------------------------------------------------------------
137      !!                  ***  FUNCTION  glob_sum_3D_a ***
138      !!
[2307]139      !! ** Purpose : perform a masked sum on the inner global domain of two 3D array
[2003]140      !!-----------------------------------------------------------------------
[3294]141      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
142      REAL(wp)            , DIMENSION(2)     ::   glob_sum_3d_a   ! global masked sum
[2307]143      !!
[2003]144      INTEGER :: jk
[4161]145      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
[2003]146      !!-----------------------------------------------------------------------
[2307]147      !
[4161]148      ijpk = SIZE(ptab1,3)
149      !
[3294]150      glob_sum_3d_a(:) = 0.e0
[4161]151      DO jk = 1, ijpk
[3294]152         glob_sum_3d_a(1) = glob_sum_3d_a(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) )
153         glob_sum_3d_a(2) = glob_sum_3d_a(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) )
[2003]154      END DO
[3294]155      IF( lk_mpp )   CALL mpp_sum( glob_sum_3d_a, 2 )
[2307]156      !
[2003]157   END FUNCTION glob_sum_3d_a
158
[4161]159#else 
[2307]160   !!----------------------------------------------------------------------
161   !!   'key_mpp_rep'                                   MPP reproducibility
162   !!----------------------------------------------------------------------
[4161]163   
164   ! --- SUM ---
[3764]165   FUNCTION glob_sum_1d( ptab, kdim )
[2003]166      !!----------------------------------------------------------------------
[3764]167      !!                  ***  FUNCTION  glob_sum_1d ***
168      !!
169      !! ** Purpose : perform a sum in calling DDPDD routine
170      !!----------------------------------------------------------------------
171      INTEGER , INTENT(in) :: kdim
172      REAL(wp), INTENT(in), DIMENSION(kdim) ::   ptab
173      REAL(wp)                              ::   glob_sum_1d   ! global sum
174      !!
175      COMPLEX(wp)::   ctmp
176      REAL(wp)   ::   ztmp
177      INTEGER    ::   ji   ! dummy loop indices
178      !!-----------------------------------------------------------------------
179      !
180      ztmp = 0.e0
181      ctmp = CMPLX( 0.e0, 0.e0, wp )
182      DO ji = 1, kdim
183         ztmp =  ptab(ji)
184         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
185         END DO
186      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
187      glob_sum_1d = REAL(ctmp,wp)
188      !
189   END FUNCTION glob_sum_1d
190
191   FUNCTION glob_sum_2d( ptab )
192      !!----------------------------------------------------------------------
[2307]193      !!                  ***  FUNCTION  glob_sum_2d ***
[2003]194      !!
195      !! ** Purpose : perform a sum in calling DDPDD routine
[2307]196      !!----------------------------------------------------------------------
[4161]197      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab
198      REAL(wp)                             ::   glob_sum_2d   ! global masked sum
[2003]199      !!
[2307]200      COMPLEX(wp)::   ctmp
201      REAL(wp)   ::   ztmp
202      INTEGER    ::   ji, jj   ! dummy loop indices
203      !!-----------------------------------------------------------------------
204      !
205      ztmp = 0.e0
206      ctmp = CMPLX( 0.e0, 0.e0, wp )
207      DO jj = 1, jpj
208         DO ji =1, jpi
209         ztmp =  ptab(ji,jj) * tmask_i(ji,jj)
210         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
211         END DO
212      END DO
213      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
[3294]214      glob_sum_2d = REAL(ctmp,wp)
[2307]215      !
[3764]216   END FUNCTION glob_sum_2d
[2307]217
218
[3764]219   FUNCTION glob_sum_3d( ptab )
[2003]220      !!----------------------------------------------------------------------
[2307]221      !!                  ***  FUNCTION  glob_sum_3d ***
222      !!
223      !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine
224      !!----------------------------------------------------------------------
[4161]225      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab
226      REAL(wp)                               ::   glob_sum_3d   ! global masked sum
[2307]227      !!
228      COMPLEX(wp)::   ctmp
229      REAL(wp)   ::   ztmp
230      INTEGER    ::   ji, jj, jk   ! dummy loop indices
[4161]231      INTEGER    ::   ijpk ! local variables: size of ptab
[2307]232      !!-----------------------------------------------------------------------
[2003]233      !
[4161]234      ijpk = SIZE(ptab,3)
235      !
[2307]236      ztmp = 0.e0
237      ctmp = CMPLX( 0.e0, 0.e0, wp )
[4161]238      DO jk = 1, ijpk
[2307]239         DO jj = 1, jpj
240            DO ji =1, jpi
241            ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj)
242            CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
243            END DO
[3764]244         END DO
[2307]245      END DO
246      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
[3294]247      glob_sum_3d = REAL(ctmp,wp)
[2307]248      !
[3764]249   END FUNCTION glob_sum_3d
[2307]250
251
[3764]252   FUNCTION glob_sum_2d_a( ptab1, ptab2 )
[2307]253      !!----------------------------------------------------------------------
254      !!                  ***  FUNCTION  glob_sum_2d_a ***
255      !!
256      !! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine
257      !!----------------------------------------------------------------------
[4161]258      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2
259      REAL(wp)                             ::   glob_sum_2d_a   ! global masked sum
[2307]260      !!
261      COMPLEX(wp)::   ctmp
262      REAL(wp)   ::   ztmp
263      INTEGER    ::   ji, jj   ! dummy loop indices
[2003]264      !!-----------------------------------------------------------------------
[2307]265      !
[2003]266      ztmp = 0.e0
[2307]267      ctmp = CMPLX( 0.e0, 0.e0, wp )
268      DO jj = 1, jpj
[2003]269         DO ji =1, jpi
[2307]270         ztmp =  ptab1(ji,jj) * tmask_i(ji,jj)
271         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
272         ztmp =  ptab2(ji,jj) * tmask_i(ji,jj)
273         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
[2003]274         END DO
275      END DO
276      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
[3294]277      glob_sum_2d_a = REAL(ctmp,wp)
[2307]278      !
[3764]279   END FUNCTION glob_sum_2d_a
[2003]280
[2307]281
[3764]282   FUNCTION glob_sum_3d_a( ptab1, ptab2 )
[2307]283      !!----------------------------------------------------------------------
284      !!                  ***  FUNCTION  glob_sum_3d_a ***
285      !!
286      !! ** Purpose : perform a sum on two 3D array in calling DDPDD routine
287      !!----------------------------------------------------------------------
[4161]288      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2
289      REAL(wp)                               ::   glob_sum_3d_a   ! global masked sum
[2307]290      !!
291      COMPLEX(wp)::   ctmp
292      REAL(wp)   ::   ztmp
293      INTEGER    ::   ji, jj, jk   ! dummy loop indices
[4161]294      INTEGER    ::   ijpk ! local variables: size of ptab
[2307]295      !!-----------------------------------------------------------------------
296      !
[4161]297      ijpk = SIZE(ptab1,3)
298      !
[2307]299      ztmp = 0.e0
300      ctmp = CMPLX( 0.e0, 0.e0, wp )
[4161]301      DO jk = 1, ijpk
[2307]302         DO jj = 1, jpj
[4161]303            DO ji = 1, jpi
304               ztmp =  ptab1(ji,jj,jk) * tmask_i(ji,jj)
305               CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
306               ztmp =  ptab2(ji,jj,jk) * tmask_i(ji,jj)
307               CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
[2307]308            END DO
[4161]309         END DO   
[2307]310      END DO
311      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
[3294]312      glob_sum_3d_a = REAL(ctmp,wp)
[2307]313      !
[4161]314   END FUNCTION glob_sum_3d_a   
[2307]315
[3632]316#endif
[2307]317
[4161]318   ! --- MIN ---
319   FUNCTION glob_min_2d( ptab ) 
320      !!-----------------------------------------------------------------------
321      !!                  ***  FUNCTION  glob_min_2D  ***
322      !!
323      !! ** Purpose : perform a masked min on the inner global domain of a 2D array
324      !!-----------------------------------------------------------------------
325      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
326      REAL(wp)                             ::   glob_min_2d   ! global masked min
327      !!-----------------------------------------------------------------------
328      !
329      glob_min_2d = MINVAL( ptab(:,:)*tmask_i(:,:) )
330      IF( lk_mpp )   CALL mpp_min( glob_min_2d )
331      !
332   END FUNCTION glob_min_2d
333 
334   FUNCTION glob_min_3d( ptab ) 
335      !!-----------------------------------------------------------------------
336      !!                  ***  FUNCTION  glob_min_3D  ***
337      !!
338      !! ** Purpose : perform a masked min on the inner global domain of a 3D array
339      !!-----------------------------------------------------------------------
340      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
341      REAL(wp)                               ::   glob_min_3d   ! global masked min
342      !!
343      INTEGER :: jk
344      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
345      !!-----------------------------------------------------------------------
346      !
347      ijpk = SIZE(ptab,3)
348      !
349      glob_min_3d = MINVAL( ptab(:,:,1)*tmask_i(:,:) )
350      DO jk = 2, ijpk
351         glob_min_3d = MIN( glob_min_3d, MINVAL( ptab(:,:,jk)*tmask_i(:,:) ) )
352      END DO
353      IF( lk_mpp )   CALL mpp_min( glob_min_3d )
354      !
355   END FUNCTION glob_min_3d
356
357
358   FUNCTION glob_min_2d_a( ptab1, ptab2 ) 
359      !!-----------------------------------------------------------------------
360      !!                  ***  FUNCTION  glob_min_2D _a ***
361      !!
362      !! ** Purpose : perform a masked min on the inner global domain of two 2D array
363      !!-----------------------------------------------------------------------
364      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
365      REAL(wp)            , DIMENSION(2)   ::   glob_min_2d_a   ! global masked min
366      !!-----------------------------------------------------------------------
367      !             
368      glob_min_2d_a(1) = MINVAL( ptab1(:,:)*tmask_i(:,:) )
369      glob_min_2d_a(2) = MINVAL( ptab2(:,:)*tmask_i(:,:) )
370      IF( lk_mpp )   CALL mpp_min( glob_min_2d_a, 2 )
371      !
372   END FUNCTION glob_min_2d_a
373 
374 
375   FUNCTION glob_min_3d_a( ptab1, ptab2 ) 
376      !!-----------------------------------------------------------------------
377      !!                  ***  FUNCTION  glob_min_3D_a ***
378      !!
379      !! ** Purpose : perform a masked min on the inner global domain of two 3D array
380      !!-----------------------------------------------------------------------
381      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
382      REAL(wp)            , DIMENSION(2)     ::   glob_min_3d_a   ! global masked min
383      !!
384      INTEGER :: jk
385      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
386      !!-----------------------------------------------------------------------
387      !
388      ijpk = SIZE(ptab1,3)
389      !
390      glob_min_3d_a(1) = MINVAL( ptab1(:,:,1)*tmask_i(:,:) )
391      glob_min_3d_a(2) = MINVAL( ptab2(:,:,1)*tmask_i(:,:) )
392      DO jk = 2, ijpk
393         glob_min_3d_a(1) = MIN( glob_min_3d_a(1), MINVAL( ptab1(:,:,jk)*tmask_i(:,:) ) )
394         glob_min_3d_a(2) = MIN( glob_min_3d_a(2), MINVAL( ptab2(:,:,jk)*tmask_i(:,:) ) )
395      END DO
396      IF( lk_mpp )   CALL mpp_min( glob_min_3d_a, 2 )
397      !
398   END FUNCTION glob_min_3d_a
399
400   ! --- MAX ---
401   FUNCTION glob_max_2d( ptab ) 
402      !!-----------------------------------------------------------------------
403      !!                  ***  FUNCTION  glob_max_2D  ***
404      !!
405      !! ** Purpose : perform a masked max on the inner global domain of a 2D array
406      !!-----------------------------------------------------------------------
407      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
408      REAL(wp)                             ::   glob_max_2d   ! global masked max
409      !!-----------------------------------------------------------------------
410      !
411      glob_max_2d = MAXVAL( ptab(:,:)*tmask_i(:,:) )
412      IF( lk_mpp )   CALL mpp_max( glob_max_2d )
413      !
414   END FUNCTION glob_max_2d
415 
416   FUNCTION glob_max_3d( ptab ) 
417      !!-----------------------------------------------------------------------
418      !!                  ***  FUNCTION  glob_max_3D  ***
419      !!
420      !! ** Purpose : perform a masked max on the inner global domain of a 3D array
421      !!-----------------------------------------------------------------------
422      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
423      REAL(wp)                               ::   glob_max_3d   ! global masked max
424      !!
425      INTEGER :: jk
426      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
427      !!-----------------------------------------------------------------------
428      !
429      ijpk = SIZE(ptab,3)
430      !
431      glob_max_3d = MAXVAL( ptab(:,:,1)*tmask_i(:,:) )
432      DO jk = 2, ijpk
433         glob_max_3d = MAX( glob_max_3d, MAXVAL( ptab(:,:,jk)*tmask_i(:,:) ) )
434      END DO
435      IF( lk_mpp )   CALL mpp_max( glob_max_3d )
436      !
437   END FUNCTION glob_max_3d
438
439
440   FUNCTION glob_max_2d_a( ptab1, ptab2 ) 
441      !!-----------------------------------------------------------------------
442      !!                  ***  FUNCTION  glob_max_2D _a ***
443      !!
444      !! ** Purpose : perform a masked max on the inner global domain of two 2D array
445      !!-----------------------------------------------------------------------
446      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
447      REAL(wp)            , DIMENSION(2)   ::   glob_max_2d_a   ! global masked max
448      !!-----------------------------------------------------------------------
449      !             
450      glob_max_2d_a(1) = MAXVAL( ptab1(:,:)*tmask_i(:,:) )
451      glob_max_2d_a(2) = MAXVAL( ptab2(:,:)*tmask_i(:,:) )
452      IF( lk_mpp )   CALL mpp_max( glob_max_2d_a, 2 )
453      !
454   END FUNCTION glob_max_2d_a
455 
456 
457   FUNCTION glob_max_3d_a( ptab1, ptab2 ) 
458      !!-----------------------------------------------------------------------
459      !!                  ***  FUNCTION  glob_max_3D_a ***
460      !!
461      !! ** Purpose : perform a masked max on the inner global domain of two 3D array
462      !!-----------------------------------------------------------------------
463      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
464      REAL(wp)            , DIMENSION(2)     ::   glob_max_3d_a   ! global masked max
465      !!
466      INTEGER :: jk
467      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
468      !!-----------------------------------------------------------------------
469      !
470      ijpk = SIZE(ptab1,3)
471      !
472      glob_max_3d_a(1) = MAXVAL( ptab1(:,:,1)*tmask_i(:,:) )
473      glob_max_3d_a(2) = MAXVAL( ptab2(:,:,1)*tmask_i(:,:) )
474      DO jk = 2, ijpk
475         glob_max_3d_a(1) = MAX( glob_max_3d_a(1), MAXVAL( ptab1(:,:,jk)*tmask_i(:,:) ) )
476         glob_max_3d_a(2) = MAX( glob_max_3d_a(2), MAXVAL( ptab2(:,:,jk)*tmask_i(:,:) ) )
477      END DO
478      IF( lk_mpp )   CALL mpp_max( glob_max_3d_a, 2 )
479      !
480   END FUNCTION glob_max_3d_a
481
482
[2003]483   SUBROUTINE DDPDD( ydda, yddb )
484      !!----------------------------------------------------------------------
485      !!               ***  ROUTINE DDPDD ***
[3764]486      !!
[2003]487      !! ** Purpose : Add a scalar element to a sum
488      !!
[3764]489      !!
490      !! ** Method  : The code uses the compensated summation with doublet
[2003]491      !!              (sum,error) emulated useing complex numbers. ydda is the
[3764]492      !!               scalar to add to the summ yddb
[2003]493      !!
[3764]494      !! ** Action  : This does only work for MPI.
495      !!
[2003]496      !! References : Using Acurate Arithmetics to Improve Numerical
497      !!              Reproducibility and Sability in Parallel Applications
[3764]498      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
[2003]499      !!----------------------------------------------------------------------
[2307]500      COMPLEX(wp), INTENT(in   ) ::   ydda
501      COMPLEX(wp), INTENT(inout) ::   yddb
502      !
[2003]503      REAL(wp) :: zerr, zt1, zt2  ! local work variables
[2307]504      !!-----------------------------------------------------------------------
505      !
[2003]506      ! Compute ydda + yddb using Knuth's trick.
[2307]507      zt1  = REAL(ydda) + REAL(yddb)
508      zerr = zt1 - REAL(ydda)
509      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
510         &   + AIMAG(ydda)         + AIMAG(yddb)
511      !
[2003]512      ! The result is t1 + t2, after normalization.
[2307]513      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
514      !
[2003]515   END SUBROUTINE DDPDD
516
517#if defined key_nosignedzero
[2307]518   !!----------------------------------------------------------------------
519   !!   'key_nosignedzero'                                         F90 SIGN
520   !!----------------------------------------------------------------------
[3764]521
[2307]522   FUNCTION SIGN_SCALAR( pa, pb )
[2003]523      !!-----------------------------------------------------------------------
524      !!                  ***  FUNCTION SIGN_SCALAR  ***
525      !!
526      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
527      !!-----------------------------------------------------------------------
528      REAL(wp) :: pa,pb          ! input
[2307]529      REAL(wp) :: SIGN_SCALAR    ! result
530      !!-----------------------------------------------------------------------
531      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
532      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
[2003]533      ENDIF
534   END FUNCTION SIGN_SCALAR
535
[2307]536
[3764]537   FUNCTION SIGN_ARRAY_1D( pa, pb )
[2003]538      !!-----------------------------------------------------------------------
539      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
540      !!
541      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
542      !!-----------------------------------------------------------------------
[2307]543      REAL(wp) :: pa,pb(:)                   ! input
[2003]544      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
[2307]545      !!-----------------------------------------------------------------------
546      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
547      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
[2003]548      END WHERE
549   END FUNCTION SIGN_ARRAY_1D
550
[2307]551
[3764]552   FUNCTION SIGN_ARRAY_2D(pa,pb)
[2003]553      !!-----------------------------------------------------------------------
554      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
555      !!
556      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
557      !!-----------------------------------------------------------------------
558      REAL(wp) :: pa,pb(:,:)      ! input
559      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
[2307]560      !!-----------------------------------------------------------------------
561      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
562      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
[2003]563      END WHERE
564   END FUNCTION SIGN_ARRAY_2D
565
[3764]566   FUNCTION SIGN_ARRAY_3D(pa,pb)
[2003]567      !!-----------------------------------------------------------------------
568      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
569      !!
570      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
571      !!-----------------------------------------------------------------------
572      REAL(wp) :: pa,pb(:,:,:)      ! input
573      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
[2307]574      !!-----------------------------------------------------------------------
575      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
576      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
[2003]577      END WHERE
578   END FUNCTION SIGN_ARRAY_3D
579
[2307]580
[3764]581   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
[2003]582      !!-----------------------------------------------------------------------
583      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
584      !!
585      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
586      !!-----------------------------------------------------------------------
587      REAL(wp) :: pa(:),pb(:)      ! input
[2307]588      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
589      !!-----------------------------------------------------------------------
590      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
591      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
[2003]592      END WHERE
593   END FUNCTION SIGN_ARRAY_1D_A
594
[2307]595
[3764]596   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
[2003]597      !!-----------------------------------------------------------------------
598      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
599      !!
600      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
601      !!-----------------------------------------------------------------------
602      REAL(wp) :: pa(:,:),pb(:,:)      ! input
603      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
[2307]604      !!-----------------------------------------------------------------------
605      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
606      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
[2003]607      END WHERE
608   END FUNCTION SIGN_ARRAY_2D_A
609
[2307]610
[3764]611   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
[2003]612      !!-----------------------------------------------------------------------
613      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
614      !!
615      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
616      !!-----------------------------------------------------------------------
617      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
618      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
[2307]619      !!-----------------------------------------------------------------------
620      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
621      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
[2003]622      END WHERE
623   END FUNCTION SIGN_ARRAY_3D_A
624
[2307]625
[3764]626   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
[2003]627      !!-----------------------------------------------------------------------
628      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
629      !!
630      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
631      !!-----------------------------------------------------------------------
632      REAL(wp) :: pa(:),pb      ! input
633      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
[2307]634      !!-----------------------------------------------------------------------
635      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
636      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
[2003]637      ENDIF
638   END FUNCTION SIGN_ARRAY_1D_B
639
[2307]640
[3764]641   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
[2003]642      !!-----------------------------------------------------------------------
643      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
644      !!
645      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
646      !!-----------------------------------------------------------------------
647      REAL(wp) :: pa(:,:),pb      ! input
648      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
[2307]649      !!-----------------------------------------------------------------------
650      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
651      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
[2003]652      ENDIF
653   END FUNCTION SIGN_ARRAY_2D_B
654
[2307]655
[3764]656   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
[2003]657      !!-----------------------------------------------------------------------
658      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
659      !!
660      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
661      !!-----------------------------------------------------------------------
662      REAL(wp) :: pa(:,:,:),pb      ! input
663      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
[2307]664      !!-----------------------------------------------------------------------
665      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
666      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
[2003]667      ENDIF
668   END FUNCTION SIGN_ARRAY_3D_B
669#endif
670
[2307]671   !!======================================================================
[2003]672END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.