- Timestamp:
- 2020-09-14T17:40:34+02:00 (4 years ago)
- Location:
- NEMO/branches/2019/dev_r11351_fldread_with_XIOS
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/lib_fortran.F90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r11351_fldread_with_XIOS
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEADext/AGRIF5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 9 # SETTE 10 ^/utils/CI/sette@13382 sette
-
- Property svn:externals
-
NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/OCE/lib_fortran.F90
r10425 r13463 63 63 #endif 64 64 65 !! * Substitutions 66 # include "do_loop_substitute.h90" 65 67 !!---------------------------------------------------------------------- 66 68 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 141 143 !!---------------------------------------------------------------------- 142 144 REAL(wp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied 143 COMPLEX( wp) :: local_sum_2d144 ! 145 !!----------------------------------------------------------------------- 146 ! 147 COMPLEX( wp):: ctmp145 COMPLEX(dp) :: local_sum_2d 146 ! 147 !!----------------------------------------------------------------------- 148 ! 149 COMPLEX(dp):: ctmp 148 150 REAL(wp) :: ztmp 149 151 INTEGER :: ji, jj ! dummy loop indices … … 159 161 DO ji = 1, ipi 160 162 ztmp = ptab(ji,jj) * tmask_i(ji,jj) 161 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )163 CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 162 164 END DO 163 165 END DO … … 170 172 !!---------------------------------------------------------------------- 171 173 REAL(wp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 172 COMPLEX( wp) :: local_sum_3d173 ! 174 !!----------------------------------------------------------------------- 175 ! 176 COMPLEX( wp):: ctmp174 COMPLEX(dp) :: local_sum_3d 175 ! 176 !!----------------------------------------------------------------------- 177 ! 178 COMPLEX(dp):: ctmp 177 179 REAL(wp) :: ztmp 178 180 INTEGER :: ji, jj, jk ! dummy loop indices … … 190 192 DO ji = 1, ipi 191 193 ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) 192 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )194 CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 193 195 END DO 194 196 END DO … … 215 217 IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) 216 218 ! 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 219 ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) 220 ! 221 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 222 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & 223 & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box 224 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 225 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box 226 IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain 227 p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2)) 228 ENDIF 229 ENDIF 230 END_2D 231 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 232 ! no need for 2nd exchange when nn_hls = 2 233 IF( nn_hls /= 2 ) THEN 234 IF( nbondi /= -1 ) THEN 235 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) 236 IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) 237 ENDIF 238 IF( nbondi /= 1 ) THEN 239 IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) 240 IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) 241 ENDIF 242 IF( nbondj /= -1 ) THEN 243 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) 244 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) 245 ENDIF 246 IF( nbondj /= 1 ) THEN 247 IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) 248 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) 249 ENDIF 250 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 251 ENDIF 252 253 END SUBROUTINE sum3x3_2d 254 255 SUBROUTINE sum3x3_3d( p3d ) 256 !!----------------------------------------------------------------------- 257 !! *** routine sum3x3_3d *** 258 !! 259 !! ** Purpose : sum over 3x3 boxes 260 !!---------------------------------------------------------------------- 261 REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: p3d 262 ! 263 INTEGER :: ji, ji2, jj, jj2, jn ! dummy loop indices 264 INTEGER :: ipn ! Third dimension size 265 !!---------------------------------------------------------------------- 266 ! 267 IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 268 IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 269 ipn = SIZE(p3d,3) 270 ! 271 DO jn = 1, ipn 272 ! 273 ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) 274 ! 275 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 276 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & 277 & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box 220 278 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 221 279 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box 222 280 IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain 223 p 2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))281 p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn)) 224 282 ENDIF 225 283 ENDIF 226 END DO284 END_2D 227 285 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,:) 286 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 287 ! no need for 2nd exchange when nn_hls = 2 288 IF( nn_hls /= 2 ) THEN 289 IF( nbondi /= -1 ) THEN 290 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) 291 IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:) 292 ENDIF 293 IF( nbondi /= 1 ) THEN 294 IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:) 295 IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:) 296 ENDIF 297 IF( nbondj /= -1 ) THEN 298 IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:) 299 IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:) 300 ENDIF 301 IF( nbondj /= 1 ) THEN 302 IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:) 303 IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) 304 ENDIF 305 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 232 306 ENDIF 233 IF( nbondi /= 1 ) THEN234 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 ENDIF237 IF( nbondj /= -1 ) THEN238 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2)239 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1)240 ENDIF241 IF( nbondj /= 1 ) THEN242 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 ENDIF245 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. )246 247 END SUBROUTINE sum3x3_2d248 249 SUBROUTINE sum3x3_3d( p3d )250 !!-----------------------------------------------------------------------251 !! *** routine sum3x3_3d ***252 !!253 !! ** Purpose : sum over 3x3 boxes254 !!----------------------------------------------------------------------255 REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: p3d256 !257 INTEGER :: ji, ji2, jj, jj2, jn ! dummy loop indices258 INTEGER :: ipn ! Third dimension size259 !!----------------------------------------------------------------------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, ipn266 DO jj = 1, jpj267 DO ji = 1, jpi268 IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box269 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box270 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box271 IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain272 p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn))273 ENDIF274 ENDIF275 END DO276 END DO277 END DO278 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )279 IF( nbondi /= -1 ) THEN280 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:)281 IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:)282 ENDIF283 IF( nbondi /= 1 ) THEN284 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 ENDIF287 IF( nbondj /= -1 ) THEN288 IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:)289 IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:)290 ENDIF291 IF( nbondj /= 1 ) THEN292 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 ENDIF295 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )296 307 297 308 END SUBROUTINE sum3x3_3d … … 315 326 !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 316 327 !!---------------------------------------------------------------------- 317 COMPLEX( wp), INTENT(in ) :: ydda318 COMPLEX( wp), INTENT(inout) :: yddb319 ! 320 REAL( wp) :: zerr, zt1, zt2 ! local work variables328 COMPLEX(dp), INTENT(in ) :: ydda 329 COMPLEX(dp), INTENT(inout) :: yddb 330 ! 331 REAL(dp) :: zerr, zt1, zt2 ! local work variables 321 332 !!----------------------------------------------------------------------- 322 333 !
Note: See TracChangeset
for help on using the changeset viewer.
