Changeset 10425 for NEMO/trunk/src/OCE/lib_fortran.F90
- Timestamp:
- 2018-12-19T22:54:16+01:00 (5 years ago)
- File:
-
- 1 edited
-
NEMO/trunk/src/OCE/lib_fortran.F90 (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/lib_fortran.F90
r10068 r10425 21 21 USE in_out_manager ! I/O manager 22 22 USE lib_mpp ! distributed memory computing 23 USE lbclnk ! ocean lateral boundary conditions 23 24 24 25 IMPLICIT NONE … … 27 28 PUBLIC glob_sum ! used in many places (masked with tmask_i) 28 29 PUBLIC glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos) 30 PUBLIC local_sum ! used in trcrad, local operation before glob_sum_delay 31 PUBLIC sum3x3 ! used in trcrad, do a sum over 3x3 boxes 29 32 PUBLIC DDPDD ! also used in closea module 30 33 PUBLIC glob_min, glob_max … … 34 37 35 38 INTERFACE glob_sum 36 MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, & 37 & glob_sum_2d_a, glob_sum_3d_a 39 MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d 38 40 END INTERFACE 39 41 INTERFACE glob_sum_full 40 42 MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d 41 43 END INTERFACE 44 INTERFACE local_sum 45 MODULE PROCEDURE local_sum_2d, local_sum_3d 46 END INTERFACE 47 INTERFACE sum3x3 48 MODULE PROCEDURE sum3x3_2d, sum3x3_3d 49 END INTERFACE 42 50 INTERFACE glob_min 43 MODULE PROCEDURE glob_min_2d, glob_min_3d ,glob_min_2d_a, glob_min_3d_a51 MODULE PROCEDURE glob_min_2d, glob_min_3d 44 52 END INTERFACE 45 53 INTERFACE glob_max 46 MODULE PROCEDURE glob_max_2d, glob_max_3d ,glob_max_2d_a, glob_max_3d_a54 MODULE PROCEDURE glob_max_2d, glob_max_3d 47 55 END INTERFACE 48 56 … … 62 70 CONTAINS 63 71 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 !! 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 ! 75 147 COMPLEX(wp):: ctmp 76 148 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( 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 ) 149 INTEGER :: ji, jj ! dummy loop indices 150 INTEGER :: ipi, ipj ! dimensions 151 !!----------------------------------------------------------------------- 152 ! 153 ipi = SIZE(ptab,1) ! 1st dimension 154 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 ) 111 162 END DO 112 163 END DO 113 IF( lk_mpp ) CALL mpp_sum( 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 !! 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 ! 128 176 COMPLEX(wp):: ctmp 129 177 REAL(wp) :: ztmp 130 178 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 179 INTEGER :: ipi, ipj, ipk ! dimensions 180 !!----------------------------------------------------------------------- 181 ! 182 ipi = SIZE(ptab,1) ! 1st dimension 183 ipj = SIZE(ptab,2) ! 2nd dimension 184 ipk = SIZE(ptab,3) ! 3rd dimension 185 ! 186 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated 187 188 DO jk = 1, ipk 189 DO jj = 1, ipj 190 DO ji = 1, ipi 191 ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) 192 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 193 END DO 194 END DO 195 END DO 196 ! 197 local_sum_3d = ctmp 198 199 END FUNCTION local_sum_3d 200 201 ! ! FUNCTION sum3x3 ! 202 203 SUBROUTINE sum3x3_2d( p2d ) 204 !!----------------------------------------------------------------------- 205 !! *** routine sum3x3_2d *** 206 !! 207 !! ** Purpose : sum over 3x3 boxes 208 !!---------------------------------------------------------------------- 209 REAL(wp), DIMENSION (:,:), INTENT(inout) :: p2d 210 ! 211 INTEGER :: ji, ji2, jj, jj2 ! dummy loop indices 212 !!---------------------------------------------------------------------- 213 ! 214 IF( SIZE(p2d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the first dimension is not equal to jpi' ) 215 IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) 216 ! 217 DO jj = 1, jpj 218 DO ji = 1, jpi 219 IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box 220 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 221 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box 222 IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain 223 p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2)) 224 ENDIF 225 ENDIF 226 END DO 227 END DO 228 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. ) 229 IF( nbondi /= -1 ) THEN 230 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) 231 IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) 232 ENDIF 233 IF( nbondi /= 1 ) THEN 234 IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) 235 IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) 236 ENDIF 237 IF( nbondj /= -1 ) THEN 238 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) 239 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) 240 ENDIF 241 IF( nbondj /= 1 ) THEN 242 IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) 243 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) 244 ENDIF 245 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. ) 246 247 END SUBROUTINE sum3x3_2d 248 249 SUBROUTINE sum3x3_3d( p3d ) 250 !!----------------------------------------------------------------------- 251 !! *** routine sum3x3_3d *** 252 !! 253 !! ** Purpose : sum over 3x3 boxes 254 !!---------------------------------------------------------------------- 255 REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: p3d 256 ! 257 INTEGER :: ji, ji2, jj, jj2, jn ! dummy loop indices 258 INTEGER :: ipn ! Third dimension size 259 !!---------------------------------------------------------------------- 260 ! 261 IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 262 IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 263 ipn = SIZE(p3d,3) 264 ! 265 DO jn = 1, ipn 139 266 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 ) 267 DO ji = 1, jpi 268 IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box 269 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 270 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box 271 IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain 272 p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn)) 273 ENDIF 274 ENDIF 143 275 END DO 144 276 END DO 145 277 END DO 146 IF( lk_mpp ) CALL mpp_sum( 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( 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( 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( 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( 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( 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( 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( 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( 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( 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( 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( 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( glob_max_3d_a, 2 ) 436 ! 437 END FUNCTION glob_max_3d_a 278 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. ) 279 IF( nbondi /= -1 ) THEN 280 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) 281 IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:) 282 ENDIF 283 IF( nbondi /= 1 ) THEN 284 IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:) 285 IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:) 286 ENDIF 287 IF( nbondj /= -1 ) THEN 288 IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:) 289 IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:) 290 ENDIF 291 IF( nbondj /= 1 ) THEN 292 IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:) 293 IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) 294 ENDIF 295 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. ) 296 297 END SUBROUTINE sum3x3_3d 438 298 439 299
Note: See TracChangeset
for help on using the changeset viewer.
