- Timestamp:
- 2013-11-07T11:01:27+01:00 (10 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90
r3764 r4161 5 5 !!====================================================================== 6 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...) 7 9 !!---------------------------------------------------------------------- 8 10 … … 24 26 PUBLIC glob_sum ! used in many places 25 27 PUBLIC DDPDD ! also used in closea module 28 PUBLIC glob_min, glob_max 26 29 #if defined key_nosignedzero 27 30 PUBLIC SIGN … … 31 34 MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, & 32 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 33 42 END INTERFACE 34 43 … … 49 58 50 59 #if ! defined key_mpp_rep 60 ! --- SUM --- 61 51 62 FUNCTION glob_sum_1d( ptab, kdim ) 52 63 !!----------------------------------------------------------------------- … … 91 102 !! 92 103 INTEGER :: jk 93 !!----------------------------------------------------------------------- 104 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 105 !!----------------------------------------------------------------------- 106 ! 107 ijpk = SIZE(ptab,3) 94 108 ! 95 109 glob_sum_3d = 0.e0 96 DO jk = 1, jpk110 DO jk = 1, ijpk 97 111 glob_sum_3d = glob_sum_3d + SUM( ptab(:,:,jk)*tmask_i(:,:) ) 98 112 END DO … … 129 143 !! 130 144 INTEGER :: jk 131 !!----------------------------------------------------------------------- 145 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 146 !!----------------------------------------------------------------------- 147 ! 148 ijpk = SIZE(ptab1,3) 132 149 ! 133 150 glob_sum_3d_a(:) = 0.e0 134 DO jk = 1, jpk151 DO jk = 1, ijpk 135 152 glob_sum_3d_a(1) = glob_sum_3d_a(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) ) 136 153 glob_sum_3d_a(2) = glob_sum_3d_a(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) ) … … 140 157 END FUNCTION glob_sum_3d_a 141 158 142 #else 159 #else 143 160 !!---------------------------------------------------------------------- 144 161 !! 'key_mpp_rep' MPP reproducibility 145 162 !!---------------------------------------------------------------------- 146 163 164 ! --- SUM --- 147 165 FUNCTION glob_sum_1d( ptab, kdim ) 148 166 !!---------------------------------------------------------------------- … … 177 195 !! ** Purpose : perform a sum in calling DDPDD routine 178 196 !!---------------------------------------------------------------------- 179 REAL(wp), INTENT(in), DIMENSION( jpi,jpj) :: ptab180 REAL(wp) 197 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab 198 REAL(wp) :: glob_sum_2d ! global masked sum 181 199 !! 182 200 COMPLEX(wp):: ctmp … … 205 223 !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine 206 224 !!---------------------------------------------------------------------- 207 REAL(wp), INTENT(in), DIMENSION( jpi,jpj,jpk) :: ptab208 REAL(wp) 225 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab 226 REAL(wp) :: glob_sum_3d ! global masked sum 209 227 !! 210 228 COMPLEX(wp):: ctmp 211 229 REAL(wp) :: ztmp 212 230 INTEGER :: ji, jj, jk ! dummy loop indices 213 !!----------------------------------------------------------------------- 231 INTEGER :: ijpk ! local variables: size of ptab 232 !!----------------------------------------------------------------------- 233 ! 234 ijpk = SIZE(ptab,3) 214 235 ! 215 236 ztmp = 0.e0 216 237 ctmp = CMPLX( 0.e0, 0.e0, wp ) 217 DO jk = 1, jpk238 DO jk = 1, ijpk 218 239 DO jj = 1, jpj 219 240 DO ji =1, jpi … … 235 256 !! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine 236 257 !!---------------------------------------------------------------------- 237 REAL(wp), INTENT(in), DIMENSION( jpi,jpj) :: ptab1, ptab2238 REAL(wp) 258 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 259 REAL(wp) :: glob_sum_2d_a ! global masked sum 239 260 !! 240 261 COMPLEX(wp):: ctmp … … 265 286 !! ** Purpose : perform a sum on two 3D array in calling DDPDD routine 266 287 !!---------------------------------------------------------------------- 267 REAL(wp), INTENT(in), DIMENSION( jpi,jpj,jpk) :: ptab1, ptab2268 REAL(wp) 288 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 289 REAL(wp) :: glob_sum_3d_a ! global masked sum 269 290 !! 270 291 COMPLEX(wp):: ctmp 271 292 REAL(wp) :: ztmp 272 293 INTEGER :: ji, jj, jk ! dummy loop indices 273 !!----------------------------------------------------------------------- 294 INTEGER :: ijpk ! local variables: size of ptab 295 !!----------------------------------------------------------------------- 296 ! 297 ijpk = SIZE(ptab1,3) 274 298 ! 275 299 ztmp = 0.e0 276 300 ctmp = CMPLX( 0.e0, 0.e0, wp ) 277 DO jk = 1, jpk301 DO jk = 1, ijpk 278 302 DO jj = 1, jpj 279 DO ji = 1, jpi280 ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj)281 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )282 ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj)283 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )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 ) 284 308 END DO 285 END DO 309 END DO 286 310 END DO 287 311 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 288 312 glob_sum_3d_a = REAL(ctmp,wp) 289 313 ! 290 END FUNCTION glob_sum_3d_a 314 END FUNCTION glob_sum_3d_a 291 315 292 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 293 482 294 483 SUBROUTINE DDPDD( ydda, yddb )
Note: See TracChangeset
for help on using the changeset viewer.
