- Timestamp:
- 2018-11-15T17:27:18+01:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/lib_fortran.F90
r10297 r10314 34 34 35 35 INTERFACE glob_sum 36 MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, & 37 & glob_sum_2d_a, glob_sum_3d_a 36 MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d 38 37 END INTERFACE 39 38 INTERFACE glob_sum_full … … 41 40 END INTERFACE 42 41 INTERFACE glob_min 43 MODULE PROCEDURE glob_min_2d, glob_min_3d ,glob_min_2d_a, glob_min_3d_a42 MODULE PROCEDURE glob_min_2d, glob_min_3d 44 43 END INTERFACE 45 44 INTERFACE glob_max 46 MODULE PROCEDURE glob_max_2d, glob_max_3d ,glob_max_2d_a, glob_max_3d_a45 MODULE PROCEDURE glob_max_2d, glob_max_3d 47 46 END INTERFACE 48 47 … … 62 61 CONTAINS 63 62 64 ! --- SUM --- 65 FUNCTION glob_sum_1d( ptab, kdim ) 66 !!---------------------------------------------------------------------- 67 !! *** FUNCTION glob_sum_1d *** 68 !! 69 !! ** Purpose : perform a sum in calling DDPDD routine 70 !!---------------------------------------------------------------------- 71 INTEGER , INTENT(in) :: kdim 72 REAL(wp), INTENT(in), DIMENSION(kdim) :: ptab 73 REAL(wp) :: glob_sum_1d ! global sum 74 !! 75 COMPLEX(wp):: ctmp 76 REAL(wp) :: ztmp 77 INTEGER :: ji ! dummy loop indices 78 !!----------------------------------------------------------------------- 79 ! 80 ztmp = 0.e0 81 ctmp = CMPLX( 0.e0, 0.e0, wp ) 82 DO ji = 1, kdim 83 ztmp = ptab(ji) 84 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 85 END DO 86 IF( lk_mpp ) CALL mpp_sum( 'lib_fortran', ctmp ) ! sum over the global domain 87 glob_sum_1d = REAL(ctmp,wp) 88 ! 89 END FUNCTION glob_sum_1d 90 91 FUNCTION glob_sum_2d( ptab ) 92 !!---------------------------------------------------------------------- 93 !! *** FUNCTION glob_sum_2d *** 94 !! 95 !! ** Purpose : perform a sum in calling DDPDD routine 96 !!---------------------------------------------------------------------- 97 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab 98 REAL(wp) :: glob_sum_2d ! global masked sum 99 !! 100 COMPLEX(wp):: ctmp 101 REAL(wp) :: ztmp 102 INTEGER :: ji, jj ! dummy loop indices 103 !!----------------------------------------------------------------------- 104 ! 105 ztmp = 0.e0 106 ctmp = CMPLX( 0.e0, 0.e0, wp ) 107 DO jj = 1, jpj 108 DO ji =1, jpi 109 ztmp = ptab(ji,jj) * tmask_i(ji,jj) 110 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 111 END DO 112 END DO 113 IF( lk_mpp ) CALL mpp_sum( 'lib_fortran', ctmp ) ! sum over the global domain 114 glob_sum_2d = REAL(ctmp,wp) 115 ! 116 END FUNCTION glob_sum_2d 117 118 119 FUNCTION glob_sum_3d( ptab ) 120 !!---------------------------------------------------------------------- 121 !! *** FUNCTION glob_sum_3d *** 122 !! 123 !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine 124 !!---------------------------------------------------------------------- 125 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab 126 REAL(wp) :: glob_sum_3d ! global masked sum 127 !! 128 COMPLEX(wp):: ctmp 129 REAL(wp) :: ztmp 130 INTEGER :: ji, jj, jk ! dummy loop indices 131 INTEGER :: ijpk ! local variables: size of ptab 132 !!----------------------------------------------------------------------- 133 ! 134 ijpk = SIZE(ptab,3) 135 ! 136 ztmp = 0.e0 137 ctmp = CMPLX( 0.e0, 0.e0, wp ) 138 DO jk = 1, ijpk 139 DO jj = 1, jpj 140 DO ji =1, jpi 141 ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) 142 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 143 END DO 144 END DO 145 END DO 146 IF( lk_mpp ) CALL mpp_sum( 'lib_fortran', ctmp ) ! sum over the global domain 147 glob_sum_3d = REAL(ctmp,wp) 148 ! 149 END FUNCTION glob_sum_3d 150 151 152 FUNCTION glob_sum_2d_a( ptab1, ptab2 ) 153 !!---------------------------------------------------------------------- 154 !! *** FUNCTION glob_sum_2d_a *** 155 !! 156 !! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine 157 !!---------------------------------------------------------------------- 158 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 159 REAL(wp) :: glob_sum_2d_a ! global masked sum 160 !! 161 COMPLEX(wp):: ctmp 162 REAL(wp) :: ztmp 163 INTEGER :: ji, jj ! dummy loop indices 164 !!----------------------------------------------------------------------- 165 ! 166 ztmp = 0.e0 167 ctmp = CMPLX( 0.e0, 0.e0, wp ) 168 DO jj = 1, jpj 169 DO ji =1, jpi 170 ztmp = ptab1(ji,jj) * tmask_i(ji,jj) 171 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 172 ztmp = ptab2(ji,jj) * tmask_i(ji,jj) 173 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 174 END DO 175 END DO 176 IF( lk_mpp ) CALL mpp_sum( 'lib_fortran', ctmp ) ! sum over the global domain 177 glob_sum_2d_a = REAL(ctmp,wp) 178 ! 179 END FUNCTION glob_sum_2d_a 180 181 182 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) 183 !!---------------------------------------------------------------------- 184 !! *** FUNCTION glob_sum_3d_a *** 185 !! 186 !! ** Purpose : perform a sum on two 3D array in calling DDPDD routine 187 !!---------------------------------------------------------------------- 188 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 189 REAL(wp) :: glob_sum_3d_a ! global masked sum 190 !! 191 COMPLEX(wp):: ctmp 192 REAL(wp) :: ztmp 193 INTEGER :: ji, jj, jk ! dummy loop indices 194 INTEGER :: ijpk ! local variables: size of ptab 195 !!----------------------------------------------------------------------- 196 ! 197 ijpk = SIZE(ptab1,3) 198 ! 199 ztmp = 0.e0 200 ctmp = CMPLX( 0.e0, 0.e0, wp ) 201 DO jk = 1, ijpk 202 DO jj = 1, jpj 203 DO ji = 1, jpi 204 ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj) 205 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 206 ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj) 207 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 208 END DO 209 END DO 210 END DO 211 IF( lk_mpp ) CALL mpp_sum( 'lib_fortran', ctmp ) ! sum over the global domain 212 glob_sum_3d_a = REAL(ctmp,wp) 213 ! 214 END FUNCTION glob_sum_3d_a 215 216 FUNCTION glob_sum_full_2d( ptab ) 217 !!---------------------------------------------------------------------- 218 !! *** FUNCTION glob_sum_full_2d *** 219 !! 220 !! ** Purpose : perform a sum in calling DDPDD routine 221 !!---------------------------------------------------------------------- 222 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab 223 REAL(wp) :: glob_sum_full_2d ! global sum (nomask) 224 !! 225 COMPLEX(wp):: ctmp 226 REAL(wp) :: ztmp 227 INTEGER :: ji, jj ! dummy loop indices 228 !!----------------------------------------------------------------------- 229 ! 230 ztmp = 0.e0 231 ctmp = CMPLX( 0.e0, 0.e0, wp ) 232 DO jj = 1, jpj 233 DO ji =1, jpi 234 ztmp = ptab(ji,jj) * tmask_h(ji,jj) 235 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 236 END DO 237 END DO 238 IF( lk_mpp ) CALL mpp_sum( 'lib_fortran', ctmp ) ! sum over the global domain 239 glob_sum_full_2d = REAL(ctmp,wp) 240 ! 241 END FUNCTION glob_sum_full_2d 242 243 FUNCTION glob_sum_full_3d( ptab ) 244 !!---------------------------------------------------------------------- 245 !! *** FUNCTION glob_sum_full_3d *** 246 !! 247 !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine 248 !!---------------------------------------------------------------------- 249 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab 250 REAL(wp) :: glob_sum_full_3d ! global sum (nomask) 251 !! 252 COMPLEX(wp):: ctmp 253 REAL(wp) :: ztmp 254 INTEGER :: ji, jj, jk ! dummy loop indices 255 INTEGER :: ijpk ! local variables: size of ptab 256 !!----------------------------------------------------------------------- 257 ! 258 ijpk = SIZE(ptab,3) 259 ! 260 ztmp = 0.e0 261 ctmp = CMPLX( 0.e0, 0.e0, wp ) 262 DO jk = 1, ijpk 263 DO jj = 1, jpj 264 DO ji =1, jpi 265 ztmp = ptab(ji,jj,jk) * tmask_h(ji,jj) 266 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 267 END DO 268 END DO 269 END DO 270 IF( lk_mpp ) CALL mpp_sum( 'lib_fortran', ctmp ) ! sum over the global domain 271 glob_sum_full_3d = REAL(ctmp,wp) 272 ! 273 END FUNCTION glob_sum_full_3d 274 275 ! --- MIN --- 276 FUNCTION glob_min_2d( ptab ) 277 !!----------------------------------------------------------------------- 278 !! *** FUNCTION glob_min_2D *** 279 !! 280 !! ** Purpose : perform a masked min on the inner global domain of a 2D array 281 !!----------------------------------------------------------------------- 282 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array 283 REAL(wp) :: glob_min_2d ! global masked min 284 !!----------------------------------------------------------------------- 285 ! 286 glob_min_2d = MINVAL( ptab(:,:)*tmask_i(:,:) ) 287 IF( lk_mpp ) CALL mpp_min( 'lib_fortran', glob_min_2d ) 288 ! 289 END FUNCTION glob_min_2d 290 291 FUNCTION glob_min_3d( ptab ) 292 !!----------------------------------------------------------------------- 293 !! *** FUNCTION glob_min_3D *** 294 !! 295 !! ** Purpose : perform a masked min on the inner global domain of a 3D array 296 !!----------------------------------------------------------------------- 297 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array 298 REAL(wp) :: glob_min_3d ! global masked min 299 !! 300 INTEGER :: jk 301 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 302 !!----------------------------------------------------------------------- 303 ! 304 ijpk = SIZE(ptab,3) 305 ! 306 glob_min_3d = MINVAL( ptab(:,:,1)*tmask_i(:,:) ) 307 DO jk = 2, ijpk 308 glob_min_3d = MIN( glob_min_3d, MINVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) 309 END DO 310 IF( lk_mpp ) CALL mpp_min( 'lib_fortran', glob_min_3d ) 311 ! 312 END FUNCTION glob_min_3d 313 314 315 FUNCTION glob_min_2d_a( ptab1, ptab2 ) 316 !!----------------------------------------------------------------------- 317 !! *** FUNCTION glob_min_2D _a *** 318 !! 319 !! ** Purpose : perform a masked min on the inner global domain of two 2D array 320 !!----------------------------------------------------------------------- 321 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array 322 REAL(wp) , DIMENSION(2) :: glob_min_2d_a ! global masked min 323 !!----------------------------------------------------------------------- 324 ! 325 glob_min_2d_a(1) = MINVAL( ptab1(:,:)*tmask_i(:,:) ) 326 glob_min_2d_a(2) = MINVAL( ptab2(:,:)*tmask_i(:,:) ) 327 IF( lk_mpp ) CALL mpp_min( 'lib_fortran', glob_min_2d_a, 2 ) 328 ! 329 END FUNCTION glob_min_2d_a 330 331 332 FUNCTION glob_min_3d_a( ptab1, ptab2 ) 333 !!----------------------------------------------------------------------- 334 !! *** FUNCTION glob_min_3D_a *** 335 !! 336 !! ** Purpose : perform a masked min on the inner global domain of two 3D array 337 !!----------------------------------------------------------------------- 338 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array 339 REAL(wp) , DIMENSION(2) :: glob_min_3d_a ! global masked min 340 !! 341 INTEGER :: jk 342 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 343 !!----------------------------------------------------------------------- 344 ! 345 ijpk = SIZE(ptab1,3) 346 ! 347 glob_min_3d_a(1) = MINVAL( ptab1(:,:,1)*tmask_i(:,:) ) 348 glob_min_3d_a(2) = MINVAL( ptab2(:,:,1)*tmask_i(:,:) ) 349 DO jk = 2, ijpk 350 glob_min_3d_a(1) = MIN( glob_min_3d_a(1), MINVAL( ptab1(:,:,jk)*tmask_i(:,:) ) ) 351 glob_min_3d_a(2) = MIN( glob_min_3d_a(2), MINVAL( ptab2(:,:,jk)*tmask_i(:,:) ) ) 352 END DO 353 IF( lk_mpp ) CALL mpp_min( 'lib_fortran', glob_min_3d_a, 2 ) 354 ! 355 END FUNCTION glob_min_3d_a 356 357 ! --- MAX --- 358 FUNCTION glob_max_2d( ptab ) 359 !!----------------------------------------------------------------------- 360 !! *** FUNCTION glob_max_2D *** 361 !! 362 !! ** Purpose : perform a masked max on the inner global domain of a 2D array 363 !!----------------------------------------------------------------------- 364 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array 365 REAL(wp) :: glob_max_2d ! global masked max 366 !!----------------------------------------------------------------------- 367 ! 368 glob_max_2d = MAXVAL( ptab(:,:)*tmask_i(:,:) ) 369 IF( lk_mpp ) CALL mpp_max( 'lib_fortran', glob_max_2d ) 370 ! 371 END FUNCTION glob_max_2d 372 373 FUNCTION glob_max_3d( ptab ) 374 !!----------------------------------------------------------------------- 375 !! *** FUNCTION glob_max_3D *** 376 !! 377 !! ** Purpose : perform a masked max on the inner global domain of a 3D array 378 !!----------------------------------------------------------------------- 379 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array 380 REAL(wp) :: glob_max_3d ! global masked max 381 !! 382 INTEGER :: jk 383 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 384 !!----------------------------------------------------------------------- 385 ! 386 ijpk = SIZE(ptab,3) 387 ! 388 glob_max_3d = MAXVAL( ptab(:,:,1)*tmask_i(:,:) ) 389 DO jk = 2, ijpk 390 glob_max_3d = MAX( glob_max_3d, MAXVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) 391 END DO 392 IF( lk_mpp ) CALL mpp_max( 'lib_fortran', glob_max_3d ) 393 ! 394 END FUNCTION glob_max_3d 395 396 397 FUNCTION glob_max_2d_a( ptab1, ptab2 ) 398 !!----------------------------------------------------------------------- 399 !! *** FUNCTION glob_max_2D _a *** 400 !! 401 !! ** Purpose : perform a masked max on the inner global domain of two 2D array 402 !!----------------------------------------------------------------------- 403 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array 404 REAL(wp) , DIMENSION(2) :: glob_max_2d_a ! global masked max 405 !!----------------------------------------------------------------------- 406 ! 407 glob_max_2d_a(1) = MAXVAL( ptab1(:,:)*tmask_i(:,:) ) 408 glob_max_2d_a(2) = MAXVAL( ptab2(:,:)*tmask_i(:,:) ) 409 IF( lk_mpp ) CALL mpp_max( 'lib_fortran', glob_max_2d_a, 2 ) 410 ! 411 END FUNCTION glob_max_2d_a 412 413 414 FUNCTION glob_max_3d_a( ptab1, ptab2 ) 415 !!----------------------------------------------------------------------- 416 !! *** FUNCTION glob_max_3D_a *** 417 !! 418 !! ** Purpose : perform a masked max on the inner global domain of two 3D array 419 !!----------------------------------------------------------------------- 420 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array 421 REAL(wp) , DIMENSION(2) :: glob_max_3d_a ! global masked max 422 !! 423 INTEGER :: jk 424 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 425 !!----------------------------------------------------------------------- 426 ! 427 ijpk = SIZE(ptab1,3) 428 ! 429 glob_max_3d_a(1) = MAXVAL( ptab1(:,:,1)*tmask_i(:,:) ) 430 glob_max_3d_a(2) = MAXVAL( ptab2(:,:,1)*tmask_i(:,:) ) 431 DO jk = 2, ijpk 432 glob_max_3d_a(1) = MAX( glob_max_3d_a(1), MAXVAL( ptab1(:,:,jk)*tmask_i(:,:) ) ) 433 glob_max_3d_a(2) = MAX( glob_max_3d_a(2), MAXVAL( ptab2(:,:,jk)*tmask_i(:,:) ) ) 434 END DO 435 IF( lk_mpp ) CALL mpp_max( 'lib_fortran', glob_max_3d_a, 2 ) 436 ! 437 END FUNCTION glob_max_3d_a 63 # define GLOBSUM_CODE 64 65 # define DIM_1d 66 # define FUNCTION_GLOBSUM glob_sum_1d 67 # include "lib_fortran_generic.h90" 68 # undef FUNCTION_GLOBSUM 69 # undef DIM_1d 70 71 # define DIM_2d 72 # define OPERATION_GLOBSUM 73 # define FUNCTION_GLOBSUM glob_sum_2d 74 # include "lib_fortran_generic.h90" 75 # undef FUNCTION_GLOBSUM 76 # undef OPERATION_GLOBSUM 77 # define OPERATION_FULL_GLOBSUM 78 # define FUNCTION_GLOBSUM glob_sum_full_2d 79 # include "lib_fortran_generic.h90" 80 # undef FUNCTION_GLOBSUM 81 # undef OPERATION_FULL_GLOBSUM 82 # undef DIM_2d 83 84 # define DIM_3d 85 # define OPERATION_GLOBSUM 86 # define FUNCTION_GLOBSUM glob_sum_3d 87 # include "lib_fortran_generic.h90" 88 # undef FUNCTION_GLOBSUM 89 # undef OPERATION_GLOBSUM 90 # define OPERATION_FULL_GLOBSUM 91 # define FUNCTION_GLOBSUM glob_sum_full_3d 92 # include "lib_fortran_generic.h90" 93 # undef FUNCTION_GLOBSUM 94 # undef OPERATION_FULL_GLOBSUM 95 # undef DIM_3d 96 97 # undef GLOBSUM_CODE 98 99 100 # define GLOBMINMAX_CODE 101 102 # define DIM_2d 103 # define OPERATION_GLOBMIN 104 # define FUNCTION_GLOBMINMAX glob_min_2d 105 # include "lib_fortran_generic.h90" 106 # undef FUNCTION_GLOBMINMAX 107 # undef OPERATION_GLOBMIN 108 # define OPERATION_GLOBMAX 109 # define FUNCTION_GLOBMINMAX glob_max_2d 110 # include "lib_fortran_generic.h90" 111 # undef FUNCTION_GLOBMINMAX 112 # undef OPERATION_GLOBMAX 113 # undef DIM_2d 114 115 # define DIM_3d 116 # define OPERATION_GLOBMIN 117 # define FUNCTION_GLOBMINMAX glob_min_3d 118 # include "lib_fortran_generic.h90" 119 # undef FUNCTION_GLOBMINMAX 120 # undef OPERATION_GLOBMIN 121 # define OPERATION_GLOBMAX 122 # define FUNCTION_GLOBMINMAX glob_max_3d 123 # include "lib_fortran_generic.h90" 124 # undef FUNCTION_GLOBMINMAX 125 # undef OPERATION_GLOBMAX 126 # undef DIM_3d 127 # undef GLOBMINMAX_CODE 438 128 439 129
Note: See TracChangeset
for help on using the changeset viewer.
