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

source: trunk/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90 @ 5215

Last change on this file since 5215 was 4161, checked in by cetlod, 10 years ago

dev_LOCEAN_2013 : merge in the 3rd dev branch dev_r4028_CNRS_LIM3, see ticket #1169

  • Property svn:keywords set to Id
File size: 28.4 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   DDPDD      ! also used in closea module
28   PUBLIC   glob_min, glob_max
29#if defined key_nosignedzero
30   PUBLIC SIGN
31#endif
32
33   INTERFACE glob_sum
34      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, &
35         &             glob_sum_2d_a, glob_sum_3d_a
36   END INTERFACE
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
43
44#if defined key_nosignedzero
45   INTERFACE SIGN
46      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
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
49   END INTERFACE
50#endif
51
52   !!----------------------------------------------------------------------
53   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
54   !! $Id$
55   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
56   !!----------------------------------------------------------------------
57CONTAINS
58
59#if ! defined key_mpp_rep
60   ! --- SUM ---
61
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
77
78   FUNCTION glob_sum_2d( ptab )
79      !!-----------------------------------------------------------------------
80      !!                  ***  FUNCTION  glob_sum_2D  ***
81      !!
82      !! ** Purpose : perform a masked sum on the inner global domain of a 2D array
83      !!-----------------------------------------------------------------------
84      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
85      REAL(wp)                             ::   glob_sum_2d   ! global masked sum
86      !!-----------------------------------------------------------------------
87      !
88      glob_sum_2d = SUM( ptab(:,:)*tmask_i(:,:) )
89      IF( lk_mpp )   CALL mpp_sum( glob_sum_2d )
90      !
91   END FUNCTION glob_sum_2d
92
93
94   FUNCTION glob_sum_3d( ptab )
95      !!-----------------------------------------------------------------------
96      !!                  ***  FUNCTION  glob_sum_3D  ***
97      !!
98      !! ** Purpose : perform a masked sum on the inner global domain of a 3D array
99      !!-----------------------------------------------------------------------
100      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
101      REAL(wp)                               ::   glob_sum_3d   ! global masked sum
102      !!
103      INTEGER :: jk
104      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
105      !!-----------------------------------------------------------------------
106      !
107      ijpk = SIZE(ptab,3)
108      !
109      glob_sum_3d = 0.e0
110      DO jk = 1, ijpk
111         glob_sum_3d = glob_sum_3d + SUM( ptab(:,:,jk)*tmask_i(:,:) )
112      END DO
113      IF( lk_mpp )   CALL mpp_sum( glob_sum_3d )
114      !
115   END FUNCTION glob_sum_3d
116
117
118   FUNCTION glob_sum_2d_a( ptab1, ptab2 )
119      !!-----------------------------------------------------------------------
120      !!                  ***  FUNCTION  glob_sum_2D _a ***
121      !!
122      !! ** Purpose : perform a masked sum on the inner global domain of two 2D array
123      !!-----------------------------------------------------------------------
124      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
125      REAL(wp)            , DIMENSION(2)   ::   glob_sum_2d_a   ! global masked sum
126      !!-----------------------------------------------------------------------
127      !
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 )
131      !
132   END FUNCTION glob_sum_2d_a
133
134
135   FUNCTION glob_sum_3d_a( ptab1, ptab2 )
136      !!-----------------------------------------------------------------------
137      !!                  ***  FUNCTION  glob_sum_3D_a ***
138      !!
139      !! ** Purpose : perform a masked sum on the inner global domain of two 3D array
140      !!-----------------------------------------------------------------------
141      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
142      REAL(wp)            , DIMENSION(2)     ::   glob_sum_3d_a   ! global masked sum
143      !!
144      INTEGER :: jk
145      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
146      !!-----------------------------------------------------------------------
147      !
148      ijpk = SIZE(ptab1,3)
149      !
150      glob_sum_3d_a(:) = 0.e0
151      DO jk = 1, ijpk
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(:,:) )
154      END DO
155      IF( lk_mpp )   CALL mpp_sum( glob_sum_3d_a, 2 )
156      !
157   END FUNCTION glob_sum_3d_a
158
159#else 
160   !!----------------------------------------------------------------------
161   !!   'key_mpp_rep'                                   MPP reproducibility
162   !!----------------------------------------------------------------------
163   
164   ! --- SUM ---
165   FUNCTION glob_sum_1d( ptab, kdim )
166      !!----------------------------------------------------------------------
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      !!----------------------------------------------------------------------
193      !!                  ***  FUNCTION  glob_sum_2d ***
194      !!
195      !! ** Purpose : perform a sum in calling DDPDD routine
196      !!----------------------------------------------------------------------
197      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab
198      REAL(wp)                             ::   glob_sum_2d   ! global masked sum
199      !!
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
214      glob_sum_2d = REAL(ctmp,wp)
215      !
216   END FUNCTION glob_sum_2d
217
218
219   FUNCTION glob_sum_3d( ptab )
220      !!----------------------------------------------------------------------
221      !!                  ***  FUNCTION  glob_sum_3d ***
222      !!
223      !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine
224      !!----------------------------------------------------------------------
225      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab
226      REAL(wp)                               ::   glob_sum_3d   ! global masked sum
227      !!
228      COMPLEX(wp)::   ctmp
229      REAL(wp)   ::   ztmp
230      INTEGER    ::   ji, jj, jk   ! dummy loop indices
231      INTEGER    ::   ijpk ! local variables: size of ptab
232      !!-----------------------------------------------------------------------
233      !
234      ijpk = SIZE(ptab,3)
235      !
236      ztmp = 0.e0
237      ctmp = CMPLX( 0.e0, 0.e0, wp )
238      DO jk = 1, ijpk
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
244         END DO
245      END DO
246      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
247      glob_sum_3d = REAL(ctmp,wp)
248      !
249   END FUNCTION glob_sum_3d
250
251
252   FUNCTION glob_sum_2d_a( ptab1, ptab2 )
253      !!----------------------------------------------------------------------
254      !!                  ***  FUNCTION  glob_sum_2d_a ***
255      !!
256      !! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine
257      !!----------------------------------------------------------------------
258      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2
259      REAL(wp)                             ::   glob_sum_2d_a   ! global masked sum
260      !!
261      COMPLEX(wp)::   ctmp
262      REAL(wp)   ::   ztmp
263      INTEGER    ::   ji, jj   ! dummy loop indices
264      !!-----------------------------------------------------------------------
265      !
266      ztmp = 0.e0
267      ctmp = CMPLX( 0.e0, 0.e0, wp )
268      DO jj = 1, jpj
269         DO ji =1, jpi
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 )
274         END DO
275      END DO
276      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
277      glob_sum_2d_a = REAL(ctmp,wp)
278      !
279   END FUNCTION glob_sum_2d_a
280
281
282   FUNCTION glob_sum_3d_a( ptab1, ptab2 )
283      !!----------------------------------------------------------------------
284      !!                  ***  FUNCTION  glob_sum_3d_a ***
285      !!
286      !! ** Purpose : perform a sum on two 3D array in calling DDPDD routine
287      !!----------------------------------------------------------------------
288      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2
289      REAL(wp)                               ::   glob_sum_3d_a   ! global masked sum
290      !!
291      COMPLEX(wp)::   ctmp
292      REAL(wp)   ::   ztmp
293      INTEGER    ::   ji, jj, jk   ! dummy loop indices
294      INTEGER    ::   ijpk ! local variables: size of ptab
295      !!-----------------------------------------------------------------------
296      !
297      ijpk = SIZE(ptab1,3)
298      !
299      ztmp = 0.e0
300      ctmp = CMPLX( 0.e0, 0.e0, wp )
301      DO jk = 1, ijpk
302         DO jj = 1, jpj
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 )
308            END DO
309         END DO   
310      END DO
311      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
312      glob_sum_3d_a = REAL(ctmp,wp)
313      !
314   END FUNCTION glob_sum_3d_a   
315
316#endif
317
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
483   SUBROUTINE DDPDD( ydda, yddb )
484      !!----------------------------------------------------------------------
485      !!               ***  ROUTINE DDPDD ***
486      !!
487      !! ** Purpose : Add a scalar element to a sum
488      !!
489      !!
490      !! ** Method  : The code uses the compensated summation with doublet
491      !!              (sum,error) emulated useing complex numbers. ydda is the
492      !!               scalar to add to the summ yddb
493      !!
494      !! ** Action  : This does only work for MPI.
495      !!
496      !! References : Using Acurate Arithmetics to Improve Numerical
497      !!              Reproducibility and Sability in Parallel Applications
498      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
499      !!----------------------------------------------------------------------
500      COMPLEX(wp), INTENT(in   ) ::   ydda
501      COMPLEX(wp), INTENT(inout) ::   yddb
502      !
503      REAL(wp) :: zerr, zt1, zt2  ! local work variables
504      !!-----------------------------------------------------------------------
505      !
506      ! Compute ydda + yddb using Knuth's trick.
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      !
512      ! The result is t1 + t2, after normalization.
513      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
514      !
515   END SUBROUTINE DDPDD
516
517#if defined key_nosignedzero
518   !!----------------------------------------------------------------------
519   !!   'key_nosignedzero'                                         F90 SIGN
520   !!----------------------------------------------------------------------
521
522   FUNCTION SIGN_SCALAR( pa, pb )
523      !!-----------------------------------------------------------------------
524      !!                  ***  FUNCTION SIGN_SCALAR  ***
525      !!
526      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
527      !!-----------------------------------------------------------------------
528      REAL(wp) :: pa,pb          ! input
529      REAL(wp) :: SIGN_SCALAR    ! result
530      !!-----------------------------------------------------------------------
531      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
532      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
533      ENDIF
534   END FUNCTION SIGN_SCALAR
535
536
537   FUNCTION SIGN_ARRAY_1D( pa, pb )
538      !!-----------------------------------------------------------------------
539      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
540      !!
541      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
542      !!-----------------------------------------------------------------------
543      REAL(wp) :: pa,pb(:)                   ! input
544      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
545      !!-----------------------------------------------------------------------
546      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
547      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
548      END WHERE
549   END FUNCTION SIGN_ARRAY_1D
550
551
552   FUNCTION SIGN_ARRAY_2D(pa,pb)
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
560      !!-----------------------------------------------------------------------
561      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
562      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
563      END WHERE
564   END FUNCTION SIGN_ARRAY_2D
565
566   FUNCTION SIGN_ARRAY_3D(pa,pb)
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
574      !!-----------------------------------------------------------------------
575      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
576      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
577      END WHERE
578   END FUNCTION SIGN_ARRAY_3D
579
580
581   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
582      !!-----------------------------------------------------------------------
583      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
584      !!
585      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
586      !!-----------------------------------------------------------------------
587      REAL(wp) :: pa(:),pb(:)      ! input
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)
592      END WHERE
593   END FUNCTION SIGN_ARRAY_1D_A
594
595
596   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
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
604      !!-----------------------------------------------------------------------
605      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
606      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
607      END WHERE
608   END FUNCTION SIGN_ARRAY_2D_A
609
610
611   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
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
619      !!-----------------------------------------------------------------------
620      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
621      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
622      END WHERE
623   END FUNCTION SIGN_ARRAY_3D_A
624
625
626   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
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
634      !!-----------------------------------------------------------------------
635      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
636      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
637      ENDIF
638   END FUNCTION SIGN_ARRAY_1D_B
639
640
641   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
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
649      !!-----------------------------------------------------------------------
650      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
651      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
652      ENDIF
653   END FUNCTION SIGN_ARRAY_2D_B
654
655
656   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
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
664      !!-----------------------------------------------------------------------
665      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
666      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
667      ENDIF
668   END FUNCTION SIGN_ARRAY_3D_B
669#endif
670
671   !!======================================================================
672END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.