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/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC – NEMO

source: branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90 @ 5619

Last change on this file since 5619 was 5619, checked in by mathiot, 9 years ago

ocean/ice sheet coupling: initial commit

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