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

source: branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90 @ 2304

Last change on this file since 2304 was 2304, checked in by rblod, 14 years ago

Choose one option for mpp reproducibility, see ticket #743
  • Property svn:keywords set to Id
File size: 12.6 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  Michael Dunphy, Rachid BENSHILA Original code
7   !!----------------------------------------------------------------------
8   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
9   !! $Id$
10   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
11   !!----------------------------------------------------------------------
12   USE par_oce 
13   USE par_kind
14   USE lib_mpp         ! distributed memory computing
15   USE dom_oce 
16   USE in_out_manager
17
18   IMPLICIT NONE
19   PRIVATE
20
21   PUBLIC glob_sum
22#if defined key_nosignedzeo
23   PUBLIC SIGN
24#endif
25
26   INTERFACE glob_sum
27#if defined key_mpp_rep
28      MODULE PROCEDURE mpp_sum_cmpx
29#else
30      MODULE PROCEDURE glob_sum_2d, glob_sum_3d,glob_sum_2d_a, glob_sum_3d_a 
31#endif
32   END INTERFACE
33
34#if defined key_nosignedzeo   
35   INTERFACE SIGN
36      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D, &
37                       SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,  & 
38                       SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B 
39   END INTERFACE
40#endif
41
42CONTAINS
43
44   FUNCTION glob_sum_2d( ptab )
45      !!-----------------------------------------------------------------------
46      !!                  ***  FUNCTION  glob_sum_2D  ***
47      !!
48      !! ** Purpose : perform a sum on the global domain of a 2D array
49      !!-----------------------------------------------------------------------
50      REAL(wp), DIMENSION(:,:),INTENT(in) :: ptab
51      REAL(wp) :: glob_sum_2d
52      !!-----------------------------------------------------------------------
53
54      glob_sum_2d = SUM( ptab(:,:)*tmask_i(:,:) )
55      IF( lk_mpp )   CALL mpp_sum( glob_sum_2d )
56       
57   END FUNCTION glob_sum_2d
58 
59   FUNCTION glob_sum_3d( ptab )
60      !!-----------------------------------------------------------------------
61      !!                  ***  FUNCTION  glob_sum_3D  ***
62      !!
63      !! ** Purpose : perform a sum on the global domain of a 3D array
64      !!-----------------------------------------------------------------------
65      REAL(wp), DIMENSION(:,:,:) :: ptab
66      REAL(wp) :: glob_sum_3d
67      !
68      INTEGER :: jk
69      !!-----------------------------------------------------------------------
70       
71      GLOB_SUM_3D = 0.e0
72      DO jk = 1, jpk
73         glob_sum_3d = glob_sum_3d + SUM( ptab(:,:,jk)*tmask_i(:,:) )
74      END DO
75      IF( lk_mpp )   CALL mpp_sum( glob_sum_3d )
76       
77   END FUNCTION glob_sum_3d
78
79   FUNCTION glob_sum_2d_a( ptab1, ptab2 )
80      !!-----------------------------------------------------------------------
81      !!                  ***  FUNCTION  glob_sum_2D _a ***
82      !!
83      !! ** Purpose : perform a sum on the global domain of two 2D array
84      !!-----------------------------------------------------------------------
85      REAL(wp), DIMENSION(:,:) :: ptab1, ptab2
86      REAL(wp), DIMENSION(2)   :: glob_sum_2d_a
87      !!-----------------------------------------------------------------------
88                   
89      glob_sum_2d_a(1) = SUM( ptab1(:,:)*tmask_i(:,:) )
90      glob_sum_2d_a(2) = SUM( ptab2(:,:)*tmask_i(:,:) )
91      IF( lk_mpp )   CALL mpp_sum( glob_sum_2d_a,2 )
92       
93   END FUNCTION glob_sum_2d_a
94 
95   FUNCTION glob_sum_3d_a( ptab1, ptab2 )
96      !!-----------------------------------------------------------------------
97      !!                  ***  FUNCTION  glob_sum_3D_a ***
98      !!
99      !! ** Purpose : perform a sum on the global domain of two 3D array
100      !!-----------------------------------------------------------------------
101      REAL(wp), DIMENSION(:,:,:) :: ptab1, ptab2
102      REAL(wp), DIMENSION(2)     :: glob_sum_3d_a
103      !
104      INTEGER :: jk
105      !!-----------------------------------------------------------------------
106       
107      glob_sum_3d_a(:) = 0.e0
108      DO jk = 1, jpk
109         glob_sum_3d_a(1) = glob_sum_3d_a(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) )
110         glob_sum_3d_a(2) = glob_sum_3d_a(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) )
111      END DO
112      IF( lk_mpp )   CALL mpp_sum( glob_sum_3d_a,2 )
113       
114   END FUNCTION glob_sum_3d_a
115
116#if defined key_mpp_rep 
117   FUNCTION mpp_sum_cmpx( pval )
118      !!----------------------------------------------------------------------
119      !!                  ***  FUNCTION  mpp_sum_cmpx ***
120      !!
121      !! ** Purpose : perform a sum in calling DDPDD routine
122      !!
123      !!----------------------------------------------------------------------
124      REAL(wp) :: mpp_sum_cmpx
125      !
126      REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: &
127         & pval
128      COMPLEX(wp):: ctmp
129      REAL(wp) ::ztmp
130      INTEGER :: ji,jj
131      !!-----------------------------------------------------------------------
132     
133      ztmp = 0.e0
134      ctmp = CMPLX(0.e0,0.e0,wp)
135      DO jj = 1,jpj
136         DO ji =1, jpi
137         ztmp =  pval(ji,jj) * tmask_i(ji,jj)
138         CALL DDPDD(CMPLX(ztmp,0.e0,wp),ctmp)
139         END DO
140      END DO
141      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
142      mpp_sum_cmpx= REAL(ctmp,wp)
143       
144   END FUNCTION mpp_sum_cmpx
145
146   SUBROUTINE DDPDD( ydda, yddb )
147      !!----------------------------------------------------------------------
148      !!               ***  ROUTINE DDPDD ***
149      !!         
150      !! ** Purpose : Add a scalar element to a sum
151      !!             
152      !!
153      !! ** Method  : The code uses the compensated summation with doublet
154      !!              (sum,error) emulated useing complex numbers. ydda is the
155      !!               scalar to add to the summ yddb
156      !!
157      !! ** Action  : This does only work for MPI.
158      !!
159      !! References : Using Acurate Arithmetics to Improve Numerical
160      !!              Reproducibility and Sability in Parallel Applications
161      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing
162      !!                                            18, 259-277, 2001
163      !!----------------------------------------------------------------------
164
165      COMPLEX(wp), INTENT(in)     :: ydda
166      COMPLEX(wp), INTENT(inout)  :: yddb
167     
168      REAL(wp) :: zerr, zt1, zt2  ! local work variables
169
170      ! Compute ydda + yddb using Knuth's trick.
171      zt1  = real(ydda) + real(yddb)
172      zerr = zt1 - real(ydda)
173      zt2  = ((real(yddb) - zerr) + (real(ydda) - (zt1 - zerr))) &
174            + aimag(ydda) + aimag(yddb)
175
176      ! The result is t1 + t2, after normalization.
177      yddb = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
178     
179   END SUBROUTINE DDPDD
180#endif
181
182#if defined key_nosignedzero
183   FUNCTION SIGN_SCALAR(pa,pb)
184      !!-----------------------------------------------------------------------
185      !!                  ***  FUNCTION SIGN_SCALAR  ***
186      !!
187      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
188      !!-----------------------------------------------------------------------
189      REAL(wp) :: pa,pb          ! input
190      REAL(wp) :: SIGN_SCALAR  ! result
191      IF ( pb >= 0.e0) THEN
192         SIGN_SCALAR = ABS(pa)
193      ELSE
194         SIGN_SCALAR =-ABS(pa)
195      ENDIF
196
197   END FUNCTION SIGN_SCALAR
198
199   FUNCTION SIGN_ARRAY_1D(pa,pb) 
200      !!-----------------------------------------------------------------------
201      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
202      !!
203      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
204      !!-----------------------------------------------------------------------
205      REAL(wp) :: pa,pb(:)      ! input
206      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
207      WHERE ( pb >= 0.e0 )
208         SIGN_ARRAY_1D = ABS(pa)
209      ELSEWHERE
210         SIGN_ARRAY_1D =-ABS(pa)
211      END WHERE
212
213   END FUNCTION SIGN_ARRAY_1D
214
215   FUNCTION SIGN_ARRAY_2D(pa,pb) 
216      !!-----------------------------------------------------------------------
217      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
218      !!
219      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
220      !!-----------------------------------------------------------------------
221      REAL(wp) :: pa,pb(:,:)      ! input
222      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
223
224      WHERE ( pb >= 0.e0 )
225         SIGN_ARRAY_2D = ABS(pa)
226      ELSEWHERE
227         SIGN_ARRAY_2D =-ABS(pa)
228      END WHERE
229
230   END FUNCTION SIGN_ARRAY_2D
231
232   FUNCTION SIGN_ARRAY_3D(pa,pb) 
233      !!-----------------------------------------------------------------------
234      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
235      !!
236      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
237      !!-----------------------------------------------------------------------
238      REAL(wp) :: pa,pb(:,:,:)      ! input
239      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
240      WHERE ( pb >= 0.e0 )
241         SIGN_ARRAY_3D = ABS(pa)
242      ELSEWHERE
243         SIGN_ARRAY_3D =-ABS(pa)
244      END WHERE
245
246   END FUNCTION SIGN_ARRAY_3D
247
248   FUNCTION SIGN_ARRAY_1D_A(pa,pb) 
249      !!-----------------------------------------------------------------------
250      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
251      !!
252      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
253      !!-----------------------------------------------------------------------
254      REAL(wp) :: pa(:),pb(:)      ! input
255      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(b,1))  ! result
256
257      WHERE ( pb >= 0.e0 )
258         SIGN_ARRAY_1D_A = ABS(pa)
259      ELSEWHERE
260         SIGN_ARRAY_1D_A =-ABS(pa)
261      END WHERE
262
263   END FUNCTION SIGN_ARRAY_1D_A
264
265   FUNCTION SIGN_ARRAY_2D_A(pa,pb) 
266      !!-----------------------------------------------------------------------
267      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
268      !!
269      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
270      !!-----------------------------------------------------------------------
271      REAL(wp) :: pa(:,:),pb(:,:)      ! input
272      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
273
274      WHERE ( pb >= 0.e0 )
275         SIGN_ARRAY_2D_A = ABS(pa)
276      ELSEWHERE
277         SIGN_ARRAY_2D_A =-ABS(pa)
278      END WHERE
279
280   END FUNCTION SIGN_ARRAY_2D_A
281
282   FUNCTION SIGN_ARRAY_3D_A(pa,pb) 
283      !!-----------------------------------------------------------------------
284      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
285      !!
286      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
287      !!-----------------------------------------------------------------------
288      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
289      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
290
291      WHERE ( pb >= 0.e0 )
292         SIGN_ARRAY_3D_A = ABS(pa)
293      ELSEWHERE
294         SIGN_ARRAY_3D_A =-ABS(pa)
295      END WHERE
296
297   END FUNCTION SIGN_ARRAY_3D_A
298
299   FUNCTION SIGN_ARRAY_1D_B(pa,pb) 
300      !!-----------------------------------------------------------------------
301      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
302      !!
303      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
304      !!-----------------------------------------------------------------------
305      REAL(wp) :: pa(:),pb      ! input
306      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
307
308      IF ( pb >= 0.e0 ) THEN
309         SIGN_ARRAY_1D_B = ABS(pa)
310      ELSE
311         SIGN_ARRAY_1D_B =-ABS(pa)
312      ENDIF
313
314   END FUNCTION SIGN_ARRAY_1D_B
315
316   FUNCTION SIGN_ARRAY_2D_B(pa,pb) 
317      !!-----------------------------------------------------------------------
318      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
319      !!
320      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
321      !!-----------------------------------------------------------------------
322      REAL(wp) :: pa(:,:),pb      ! input
323      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
324
325      IF ( pb >= 0.e0 ) THEN
326         SIGN_ARRAY_2D_B = ABS(pa)
327      ELSE
328         SIGN_ARRAY_2D_B =-ABS(pa)
329      ENDIF
330
331   END FUNCTION SIGN_ARRAY_2D_B
332
333   FUNCTION SIGN_ARRAY_3D_B(pa,pb) 
334      !!-----------------------------------------------------------------------
335      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
336      !!
337      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
338      !!-----------------------------------------------------------------------
339      REAL(wp) :: pa(:,:,:),pb      ! input
340      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
341
342      IF (pb >= 0.e0 ) THEN
343         SIGN_ARRAY_3D_B = ABS(pa)
344      ELSE
345         SIGN_ARRAY_3D_B =-ABS(pa)
346      ENDIF
347 
348   END FUNCTION SIGN_ARRAY_3D_B
349#endif
350
351END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.