Changeset 13090
 Timestamp:
 20200610T16:44:43+02:00 (2 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

NEMO/branches/UKMO/NEMO_4.0_mirror_SI3_GPU/src/OCE/lib_fortran.F90
r10888 r13090 69 69 !! 70 70 CONTAINS 71 72 # define GLOBSUM_CODE 73 74 # define DIM_1d 75 # define FUNCTION_GLOBSUM glob_sum_1d 76 # include "lib_fortran_generic.h90" 77 # undef FUNCTION_GLOBSUM 78 # undef DIM_1d 79 80 # define DIM_2d 81 # define OPERATION_GLOBSUM 82 # define FUNCTION_GLOBSUM glob_sum_2d 83 # include "lib_fortran_generic.h90" 84 # undef FUNCTION_GLOBSUM 85 # undef OPERATION_GLOBSUM 86 # define OPERATION_FULL_GLOBSUM 87 # define FUNCTION_GLOBSUM glob_sum_full_2d 88 # include "lib_fortran_generic.h90" 89 # undef FUNCTION_GLOBSUM 90 # undef OPERATION_FULL_GLOBSUM 91 # undef DIM_2d 92 93 # define DIM_3d 94 # define OPERATION_GLOBSUM 95 # define FUNCTION_GLOBSUM glob_sum_3d 96 # include "lib_fortran_generic.h90" 97 # undef FUNCTION_GLOBSUM 98 # undef OPERATION_GLOBSUM 99 # define OPERATION_FULL_GLOBSUM 100 # define FUNCTION_GLOBSUM glob_sum_full_3d 101 # include "lib_fortran_generic.h90" 102 # undef FUNCTION_GLOBSUM 103 # undef OPERATION_FULL_GLOBSUM 104 # undef DIM_3d 105 106 # undef GLOBSUM_CODE 107 108 109 # define GLOBMINMAX_CODE 110 111 # define DIM_2d 112 # define OPERATION_GLOBMIN 113 # define FUNCTION_GLOBMINMAX glob_min_2d 114 # include "lib_fortran_generic.h90" 115 # undef FUNCTION_GLOBMINMAX 116 # undef OPERATION_GLOBMIN 117 # define OPERATION_GLOBMAX 118 # define FUNCTION_GLOBMINMAX glob_max_2d 119 # include "lib_fortran_generic.h90" 120 # undef FUNCTION_GLOBMINMAX 121 # undef OPERATION_GLOBMAX 122 # undef DIM_2d 123 124 # define DIM_3d 125 # define OPERATION_GLOBMIN 126 # define FUNCTION_GLOBMINMAX glob_min_3d 127 # include "lib_fortran_generic.h90" 128 # undef FUNCTION_GLOBMINMAX 129 # undef OPERATION_GLOBMIN 130 # define OPERATION_GLOBMAX 131 # define FUNCTION_GLOBMINMAX glob_max_3d 132 # include "lib_fortran_generic.h90" 133 # undef FUNCTION_GLOBMINMAX 134 # undef OPERATION_GLOBMAX 135 # undef DIM_3d 136 # undef GLOBMINMAX_CODE 137 138 ! ! FUNCTION local_sum ! 139 140 FUNCTION local_sum_2d( ptab ) 141 !! 142 REAL(wp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied 143 COMPLEX(wp) :: local_sum_2d 144 ! 145 !! 146 ! 147 COMPLEX(wp):: ctmp 148 REAL(wp) :: ztmp 149 INTEGER :: ji, jj ! dummy loop indices 150 INTEGER :: ipi, ipj ! dimensions 71 ! ! FUNCTION glob_sum_1d ! 72 FUNCTION glob_sum_c1d(ptab, kdim, ldcom, cdname) 73 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 74 INTEGER, INTENT(IN) :: kdim 75 COMPLEX(KIND = wp), INTENT(IN), DIMENSION(kdim) :: ptab 76 LOGICAL, INTENT(IN) :: ldcom 77 REAL(KIND = wp) :: glob_sum_c1d 78 79 COMPLEX(KIND = wp) :: ctmp 80 INTEGER :: ji 81 82 ctmp = CMPLX(0.E0, 0.E0, wp) 83 84 DO ji = 1, kdim 85 CALL DDPDD(ptab(ji), ctmp) 86 END DO 87 88 IF (ldcom) CALL mpp_sum(cdname, ctmp) 89 90 glob_sum_c1d = REAL(ctmp, wp) 91 92 END FUNCTION glob_sum_c1d 93 94 FUNCTION glob_sum_1d( cdname, ptab ) 95 !! 96 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 97 REAL(wp) , INTENT(in ) :: ptab(:) ! array on which operation is applied 98 REAL(wp) :: glob_sum_1d 99 ! 100 !! 101 ! 102 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 103 !! 104 COMPLEX(wp):: ctmp 105 REAL(wp) :: ztmp 106 INTEGER :: ji, jj, jk ! dummy loop indices 107 INTEGER :: ipi, ipj, ipk ! dimensions 108 !! 109 ! 110 ipi = SIZE(ptab,1) ! 1st dimension 111 ipj = 1 ! 2nd dimension 112 ipk = 1 ! 3rd dimension 113 ! 114 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated 115 116 DO jk = 1, ipk 117 DO jj = 1, ipj 118 DO ji = 1, ipi 119 ztmp = ptab(ji) * 1. 120 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 121 END DO 122 END DO 123 END DO 124 CALL mpp_sum( cdname, ctmp ) ! sum over the global domain 125 glob_sum_1d = REAL(ctmp,wp) 126 127 END FUNCTION glob_sum_1d 128 129 ! 130 131 ! ! FUNCTION glob_sum_2d ! 132 133 FUNCTION glob_sum_2d( cdname, ptab ) 134 !! 135 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 136 REAL(wp) , INTENT(in ) :: ptab(:,:) ! array on which operation is applied 137 REAL(wp) :: glob_sum_2d 138 ! 139 !! 140 ! 141 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 142 !! 143 COMPLEX(wp):: ctmp 144 REAL(wp) :: ztmp 145 INTEGER :: ji, jj, jk ! dummy loop indices 146 INTEGER :: ipi, ipj, ipk ! dimensions 147 COMPLEX(KIND = wp), allocatable :: hsum(:) 151 148 !! 152 149 ! 153 150 ipi = SIZE(ptab,1) ! 1st dimension 154 151 ipj = SIZE(ptab,2) ! 2nd dimension 155 ! 156 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated 157 158 DO jj = 1, ipj 159 DO ji = 1, ipi 160 ztmp = ptab(ji,jj) * tmask_i(ji,jj) 161 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 162 END DO 163 END DO 164 ! 165 local_sum_2d = ctmp 166 167 END FUNCTION local_sum_2d 168 169 FUNCTION local_sum_3d( ptab ) 170 !! 171 REAL(wp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 172 COMPLEX(wp) :: local_sum_3d 173 ! 174 !! 175 ! 152 ipk = 1 ! 3rd dimension 153 154 ALLOCATE(hsum(ipj)) 155 156 DO jk = 1, ipk 157 DO jj = 1, ipj 158 ctmp = CMPLX( 0.e0, 0.e0, wp ) 159 DO ji = 1, ipi 160 ztmp = ptab(ji,jj) * tmask_i(ji,jj) 161 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 162 END DO 163 hsum(jj) = ctmp 164 END DO 165 END DO 166 167 glob_sum_2d = glob_sum_c1d(hsum, ipj, .TRUE..AND.lk_mpp, cdname) 168 169 DEALLOCATE(hsum) 170 171 END FUNCTION glob_sum_2d 172 173 ! 174 ! ! FUNCTION glob_sum_full_2d ! 175 176 FUNCTION glob_sum_full_2d( cdname, ptab ) 177 !! 178 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 179 REAL(wp) , INTENT(in ) :: ptab(:,:) ! array on which operation is applied 180 REAL(wp) :: glob_sum_full_2d 181 ! 182 !! 183 ! 184 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 185 !! 176 186 COMPLEX(wp):: ctmp 177 187 REAL(wp) :: ztmp 178 188 INTEGER :: ji, jj, jk ! dummy loop indices 179 189 INTEGER :: ipi, ipj, ipk ! dimensions 190 COMPLEX(KIND = wp), allocatable :: hsum(:) 191 !! 192 ! 193 ipi = SIZE(ptab,1) ! 1st dimension 194 ipj = SIZE(ptab,2) ! 2nd dimension 195 ipk = 1 ! 3rd dimension 196 ALLOCATE(hsum(ipj)) 197 ! 198 DO jk = 1, ipk 199 DO jj = 1, ipj 200 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated 201 DO ji = 1, ipi 202 ztmp = ptab(ji,jj) * tmask_h(ji,jj) 203 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 204 END DO 205 hsum(jj) = ctmp 206 END DO 207 END DO 208 209 glob_sum_full_2d = glob_sum_c1d(hsum, ipj, .TRUE..AND.lk_mpp, cdname) 210 211 DEALLOCATE(hsum) 212 213 END FUNCTION glob_sum_full_2d 214 215 ! 216 217 ! ! FUNCTION glob_sum_3d ! 218 219 FUNCTION glob_sum_3d( cdname, ptab ) 220 !! 221 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 222 REAL(wp) , INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 223 REAL(wp) :: glob_sum_3d 224 ! 225 !! 226 ! 227 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 228 !! 229 COMPLEX(wp):: ctmp 230 REAL(wp) :: ztmp 231 INTEGER :: ji, jj, jk ! dummy loop indices 232 INTEGER :: ipi, ipj, ipk ! dimensions 233 COMPLEX(KIND = wp), allocatable :: hsum(:) 180 234 !! 181 235 ! … … 184 238 ipk = SIZE(ptab,3) ! 3rd dimension 185 239 ! 186 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated187 240 ALLOCATE(hsum(ipk)) 241 188 242 DO jk = 1, ipk 243 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated 189 244 DO jj = 1, ipj 190 245 DO ji = 1, ipi … … 193 248 END DO 194 249 END DO 195 END DO 196 ! 197 local_sum_3d = ctmp 250 hsum(jk) = ctmp 251 END DO 252 253 glob_sum_3d = glob_sum_c1d(hsum, ipk, .TRUE..AND.lk_mpp, cdname) 254 255 DEALLOCATE(hsum) 256 257 END FUNCTION glob_sum_3d 258 259 ! 260 ! ! FUNCTION glob_sum_full_3d ! 261 262 FUNCTION glob_sum_full_3d( cdname, ptab ) 263 !! 264 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 265 REAL(wp) , INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 266 REAL(wp) :: glob_sum_full_3d 267 ! 268 !! 269 ! 270 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 271 !! 272 COMPLEX(wp):: ctmp 273 REAL(wp) :: ztmp 274 INTEGER :: ji, jj, jk ! dummy loop indices 275 INTEGER :: ipi, ipj, ipk ! dimensions 276 COMPLEX(KIND = wp), allocatable :: hsum(:) 277 !! 278 ! 279 ipi = SIZE(ptab,1) ! 1st dimension 280 ipj = SIZE(ptab,2) ! 2nd dimension 281 ipk = SIZE(ptab,3) ! 3rd dimension 282 ! 283 ALLOCATE(hsum(ipk)) 284 285 DO jk = 1, ipk 286 ctmp = CMPLX( 0.e0, 0.e0, wp ) 287 DO jj = 1, ipj 288 DO ji = 1, ipi 289 ztmp = ptab(ji,jj,jk) * tmask_h(ji,jj) 290 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 291 END DO 292 END DO 293 hsum(jk) = ctmp 294 END DO 295 296 glob_sum_full_3d = glob_sum_c1d(hsum, ipk, .TRUE..AND.lk_mpp, cdname) 297 298 DEALLOCATE(hsum) 299 300 END FUNCTION glob_sum_full_3d 301 302 ! 303 304 305 306 307 ! ! FUNCTION glob_min_2d ! 308 309 FUNCTION glob_min_2d( cdname, ptab ) 310 !! 311 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 312 REAL(wp) , INTENT(in ) :: ptab(:,:) ! array on which operation is applied 313 REAL(wp) :: glob_min_2d 314 ! 315 !! 316 ! 317 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 318 !! 319 COMPLEX(wp):: ctmp 320 REAL(wp) :: ztmp 321 INTEGER :: jk ! dummy loop indices 322 INTEGER :: ipk ! dimensions 323 !! 324 ! 325 ipk = 1 ! 3rd dimension 326 ! 327 ztmp = minval( ptab(:,:)*tmask_i(:,:) ) 328 329 CALL mpp_min( cdname, ztmp) 330 331 glob_min_2d = ztmp 332 333 334 END FUNCTION glob_min_2d 335 336 ! ! FUNCTION glob_max_2d ! 337 338 FUNCTION glob_max_2d( cdname, ptab ) 339 !! 340 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 341 REAL(wp) , INTENT(in ) :: ptab(:,:) ! array on which operation is applied 342 REAL(wp) :: glob_max_2d 343 ! 344 !! 345 ! 346 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 347 !! 348 COMPLEX(wp):: ctmp 349 REAL(wp) :: ztmp 350 INTEGER :: jk ! dummy loop indices 351 INTEGER :: ipk ! dimensions 352 !! 353 ! 354 ipk = 1 ! 3rd dimension 355 ! 356 ztmp = maxval( ptab(:,:)*tmask_i(:,:) ) 357 358 CALL mpp_max( cdname, ztmp) 359 360 glob_max_2d = ztmp 361 362 363 END FUNCTION glob_max_2d 364 365 366 ! ! FUNCTION glob_min_3d ! 367 368 FUNCTION glob_min_3d( cdname, ptab ) 369 !! 370 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 371 REAL(wp) , INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 372 REAL(wp) :: glob_min_3d 373 ! 374 !! 375 ! 376 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 377 !! 378 COMPLEX(wp):: ctmp 379 REAL(wp) :: ztmp 380 INTEGER :: jk ! dummy loop indices 381 INTEGER :: ipk ! dimensions 382 !! 383 ! 384 ipk = SIZE(ptab,3) ! 3rd dimension 385 ! 386 ztmp = minval( ptab(:,:,1)*tmask_i(:,:) ) 387 DO jk = 2, ipk 388 ztmp = min(ztmp, minval( ptab(:,:,jk)*tmask_i(:,:) )) 389 ENDDO 390 391 CALL mpp_min( cdname, ztmp) 392 393 glob_min_3d = ztmp 394 395 396 END FUNCTION glob_min_3d 397 398 ! ! FUNCTION glob_max_3d ! 399 400 FUNCTION glob_max_3d( cdname, ptab ) 401 !! 402 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 403 REAL(wp) , INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 404 REAL(wp) :: glob_max_3d 405 ! 406 !! 407 ! 408 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 409 !! 410 COMPLEX(wp):: ctmp 411 REAL(wp) :: ztmp 412 INTEGER :: jk ! dummy loop indices 413 INTEGER :: ipk ! dimensions 414 !! 415 ! 416 ipk = SIZE(ptab,3) ! 3rd dimension 417 ! 418 ztmp = maxval( ptab(:,:,1)*tmask_i(:,:) ) 419 DO jk = 2, ipk 420 ztmp = max(ztmp, maxval( ptab(:,:,jk)*tmask_i(:,:) )) 421 ENDDO 422 423 CALL mpp_max( cdname, ztmp) 424 425 glob_max_3d = ztmp 426 427 428 END FUNCTION glob_max_3d 429 430 431 ! ! FUNCTION local_sum ! 432 433 FUNCTION local_sum_2d( ptab ) 434 !! 435 REAL(wp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied 436 COMPLEX(wp) :: local_sum_2d 437 ! 438 !! 439 ! 440 COMPLEX(wp):: ctmp 441 REAL(wp) :: ztmp 442 INTEGER :: ji, jj ! dummy loop indices 443 INTEGER :: ipi, ipj ! dimensions 444 COMPLEX(KIND = wp), allocatable :: hsum(:) 445 !! 446 ! 447 ipi = SIZE(ptab,1) ! 1st dimension 448 ipj = SIZE(ptab,2) ! 2nd dimension 449 ! 450 ALLOCATE(hsum(ipj)) 451 452 DO jj = 1, ipj 453 ctmp = CMPLX( 0.e0, 0.e0, wp ) 454 DO ji = 1, ipi 455 ztmp = ptab(ji,jj) * tmask_i(ji,jj) 456 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 457 END DO 458 hsum(jj) = ctmp 459 END DO 460 ! 461 local_sum_2d = glob_sum_c1d(hsum, ipj, .FALSE., 'NONE') 462 463 DEALLOCATE(hsum) 198 464 465 END FUNCTION local_sum_2d 466 467 FUNCTION local_sum_3d( ptab ) 468 !! 469 REAL(wp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 470 COMPLEX(wp) :: local_sum_3d 471 ! 472 !! 473 ! 474 COMPLEX(wp):: ctmp 475 REAL(wp) :: ztmp 476 INTEGER :: ji, jj, jk ! dummy loop indices 477 INTEGER :: ipi, ipj, ipk ! dimensions 478 COMPLEX(KIND = wp), allocatable :: hsum(:) 479 !! 480 ! 481 ipi = SIZE(ptab,1) ! 1st dimension 482 ipj = SIZE(ptab,2) ! 2nd dimension 483 ipk = SIZE(ptab,3) ! 3rd dimension 484 ! 485 ALLOCATE(hsum(ipk)) 486 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated 487 488 DO jk = 1, ipk 489 ctmp = CMPLX( 0.e0, 0.e0, wp ) 490 DO jj = 1, ipj 491 DO ji = 1, ipi 492 ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) 493 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 494 END DO 495 END DO 496 hsum(jk) = ctmp 497 END DO 498 ! 499 local_sum_3d = glob_sum_c1d(hsum, ipk, .FALSE., 'NONE') 500 501 DEALLOCATE(hsum) 502 199 503 END FUNCTION local_sum_3d 200 504
Note: See TracChangeset
for help on using the changeset viewer.