- Timestamp:
- 2013-01-23T15:33:04+01:00 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90
r3632 r3764 8 8 9 9 !!---------------------------------------------------------------------- 10 !! glob_sum : generic interface for global masked summation over 10 !! glob_sum : generic interface for global masked summation over 11 11 !! the interior domain for 1 or 2 2D or 3D arrays 12 !! it works only for T points 12 !! it works only for T points 13 13 !! SIGN : generic interface for SIGN to overwrite f95 behaviour 14 14 !! of intrinsinc sign function … … 29 29 30 30 INTERFACE glob_sum 31 MODULE PROCEDURE glob_sum_2d, glob_sum_3d,glob_sum_2d_a, glob_sum_3d_a 31 MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, & 32 & glob_sum_2d_a, glob_sum_3d_a 32 33 END INTERFACE 33 34 34 #if defined key_nosignedzero 35 #if defined key_nosignedzero 35 36 INTERFACE SIGN 36 37 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 38 & SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A, & 39 & SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B 39 40 END INTERFACE 40 41 #endif … … 42 43 !!---------------------------------------------------------------------- 43 44 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 44 !! $Id$ 45 !! $Id$ 45 46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 46 47 !!---------------------------------------------------------------------- 47 CONTAINS 48 CONTAINS 48 49 49 50 #if ! defined key_mpp_rep 50 51 FUNCTION glob_sum_2d( ptab ) 51 FUNCTION glob_sum_1d( ptab, kdim ) 52 !!----------------------------------------------------------------------- 53 !! *** FUNCTION glob_sum_1D *** 54 !! 55 !! ** Purpose : perform a masked sum on the inner global domain of a 1D array 56 !!----------------------------------------------------------------------- 57 INTEGER :: kdim 58 REAL(wp), INTENT(in), DIMENSION(kdim) :: ptab ! input 1D array 59 REAL(wp) :: glob_sum_1d ! global sum 60 !!----------------------------------------------------------------------- 61 ! 62 glob_sum_1d = SUM( ptab(:) ) 63 IF( lk_mpp ) CALL mpp_sum( glob_sum_1d ) 64 ! 65 END FUNCTION glob_sum_1d 66 67 FUNCTION glob_sum_2d( ptab ) 52 68 !!----------------------------------------------------------------------- 53 69 !! *** FUNCTION glob_sum_2D *** … … 63 79 ! 64 80 END FUNCTION glob_sum_2d 65 66 67 FUNCTION glob_sum_3d( ptab ) 81 82 83 FUNCTION glob_sum_3d( ptab ) 68 84 !!----------------------------------------------------------------------- 69 85 !! *** FUNCTION glob_sum_3D *** … … 86 102 87 103 88 FUNCTION glob_sum_2d_a( ptab1, ptab2 ) 104 FUNCTION glob_sum_2d_a( ptab1, ptab2 ) 89 105 !!----------------------------------------------------------------------- 90 106 !! *** FUNCTION glob_sum_2D _a *** … … 95 111 REAL(wp) , DIMENSION(2) :: glob_sum_2d_a ! global masked sum 96 112 !!----------------------------------------------------------------------- 97 ! 113 ! 98 114 glob_sum_2d_a(1) = SUM( ptab1(:,:)*tmask_i(:,:) ) 99 115 glob_sum_2d_a(2) = SUM( ptab2(:,:)*tmask_i(:,:) ) … … 101 117 ! 102 118 END FUNCTION glob_sum_2d_a 103 104 105 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) 119 120 121 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) 106 122 !!----------------------------------------------------------------------- 107 123 !! *** FUNCTION glob_sum_3D_a *** … … 124 140 END FUNCTION glob_sum_3d_a 125 141 126 #else 142 #else 127 143 !!---------------------------------------------------------------------- 128 144 !! 'key_mpp_rep' MPP reproducibility 129 145 !!---------------------------------------------------------------------- 130 131 FUNCTION glob_sum_2d( ptab ) 146 147 FUNCTION glob_sum_1d( ptab, kdim ) 148 !!---------------------------------------------------------------------- 149 !! *** FUNCTION glob_sum_1d *** 150 !! 151 !! ** Purpose : perform a sum in calling DDPDD routine 152 !!---------------------------------------------------------------------- 153 INTEGER , INTENT(in) :: kdim 154 REAL(wp), INTENT(in), DIMENSION(kdim) :: ptab 155 REAL(wp) :: glob_sum_1d ! global sum 156 !! 157 COMPLEX(wp):: ctmp 158 REAL(wp) :: ztmp 159 INTEGER :: ji ! dummy loop indices 160 !!----------------------------------------------------------------------- 161 ! 162 ztmp = 0.e0 163 ctmp = CMPLX( 0.e0, 0.e0, wp ) 164 DO ji = 1, kdim 165 ztmp = ptab(ji) 166 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 167 END DO 168 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 169 glob_sum_1d = REAL(ctmp,wp) 170 ! 171 END FUNCTION glob_sum_1d 172 173 FUNCTION glob_sum_2d( ptab ) 132 174 !!---------------------------------------------------------------------- 133 175 !! *** FUNCTION glob_sum_2d *** … … 154 196 glob_sum_2d = REAL(ctmp,wp) 155 197 ! 156 END FUNCTION glob_sum_2d 157 158 159 FUNCTION glob_sum_3d( ptab ) 198 END FUNCTION glob_sum_2d 199 200 201 FUNCTION glob_sum_3d( ptab ) 160 202 !!---------------------------------------------------------------------- 161 203 !! *** FUNCTION glob_sum_3d *** … … 179 221 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 180 222 END DO 181 END DO 223 END DO 182 224 END DO 183 225 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 184 226 glob_sum_3d = REAL(ctmp,wp) 185 227 ! 186 END FUNCTION glob_sum_3d 187 188 189 FUNCTION glob_sum_2d_a( ptab1, ptab2 ) 228 END FUNCTION glob_sum_3d 229 230 231 FUNCTION glob_sum_2d_a( ptab1, ptab2 ) 190 232 !!---------------------------------------------------------------------- 191 233 !! *** FUNCTION glob_sum_2d_a *** … … 214 256 glob_sum_2d_a = REAL(ctmp,wp) 215 257 ! 216 END FUNCTION glob_sum_2d_a 217 218 219 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) 258 END FUNCTION glob_sum_2d_a 259 260 261 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) 220 262 !!---------------------------------------------------------------------- 221 263 !! *** FUNCTION glob_sum_3d_a *** … … 241 283 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 242 284 END DO 243 END DO 285 END DO 244 286 END DO 245 287 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 246 288 glob_sum_3d_a = REAL(ctmp,wp) 247 289 ! 248 END FUNCTION glob_sum_3d_a 290 END FUNCTION glob_sum_3d_a 249 291 250 292 #endif … … 253 295 !!---------------------------------------------------------------------- 254 296 !! *** ROUTINE DDPDD *** 255 !! 297 !! 256 298 !! ** Purpose : Add a scalar element to a sum 257 !! 258 !! 259 !! ** Method : The code uses the compensated summation with doublet 299 !! 300 !! 301 !! ** Method : The code uses the compensated summation with doublet 260 302 !! (sum,error) emulated useing complex numbers. ydda is the 261 !! scalar to add to the summ yddb 262 !! 263 !! ** Action : This does only work for MPI. 303 !! scalar to add to the summ yddb 304 !! 305 !! ** Action : This does only work for MPI. 264 306 !! 265 307 !! References : Using Acurate Arithmetics to Improve Numerical 266 308 !! Reproducibility and Sability in Parallel Applications 267 !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 309 !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 268 310 !!---------------------------------------------------------------------- 269 311 COMPLEX(wp), INTENT(in ) :: ydda … … 288 330 !! 'key_nosignedzero' F90 SIGN 289 331 !!---------------------------------------------------------------------- 290 332 291 333 FUNCTION SIGN_SCALAR( pa, pb ) 292 334 !!----------------------------------------------------------------------- … … 304 346 305 347 306 FUNCTION SIGN_ARRAY_1D( pa, pb ) 348 FUNCTION SIGN_ARRAY_1D( pa, pb ) 307 349 !!----------------------------------------------------------------------- 308 350 !! *** FUNCTION SIGN_ARRAY_1D *** … … 319 361 320 362 321 FUNCTION SIGN_ARRAY_2D(pa,pb) 363 FUNCTION SIGN_ARRAY_2D(pa,pb) 322 364 !!----------------------------------------------------------------------- 323 365 !! *** FUNCTION SIGN_ARRAY_2D *** … … 333 375 END FUNCTION SIGN_ARRAY_2D 334 376 335 FUNCTION SIGN_ARRAY_3D(pa,pb) 377 FUNCTION SIGN_ARRAY_3D(pa,pb) 336 378 !!----------------------------------------------------------------------- 337 379 !! *** FUNCTION SIGN_ARRAY_3D *** … … 348 390 349 391 350 FUNCTION SIGN_ARRAY_1D_A(pa,pb) 392 FUNCTION SIGN_ARRAY_1D_A(pa,pb) 351 393 !!----------------------------------------------------------------------- 352 394 !! *** FUNCTION SIGN_ARRAY_1D_A *** … … 363 405 364 406 365 FUNCTION SIGN_ARRAY_2D_A(pa,pb) 407 FUNCTION SIGN_ARRAY_2D_A(pa,pb) 366 408 !!----------------------------------------------------------------------- 367 409 !! *** FUNCTION SIGN_ARRAY_2D_A *** … … 378 420 379 421 380 FUNCTION SIGN_ARRAY_3D_A(pa,pb) 422 FUNCTION SIGN_ARRAY_3D_A(pa,pb) 381 423 !!----------------------------------------------------------------------- 382 424 !! *** FUNCTION SIGN_ARRAY_3D_A *** … … 393 435 394 436 395 FUNCTION SIGN_ARRAY_1D_B(pa,pb) 437 FUNCTION SIGN_ARRAY_1D_B(pa,pb) 396 438 !!----------------------------------------------------------------------- 397 439 !! *** FUNCTION SIGN_ARRAY_1D_B *** … … 408 450 409 451 410 FUNCTION SIGN_ARRAY_2D_B(pa,pb) 452 FUNCTION SIGN_ARRAY_2D_B(pa,pb) 411 453 !!----------------------------------------------------------------------- 412 454 !! *** FUNCTION SIGN_ARRAY_2D_B *** … … 423 465 424 466 425 FUNCTION SIGN_ARRAY_3D_B(pa,pb) 467 FUNCTION SIGN_ARRAY_3D_B(pa,pb) 426 468 !!----------------------------------------------------------------------- 427 469 !! *** FUNCTION SIGN_ARRAY_3D_B ***
Note: See TracChangeset
for help on using the changeset viewer.
