Changeset 3837
- Timestamp:
- 2013-03-12T15:55:32+01:00 (11 years ago)
- Location:
- branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM
- Files:
-
- 2 added
- 33 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/LIM_SRC_2/ice_2.F90
r2715 r3837 181 181 ice_alloc_2 = MAXVAL( ierr ) 182 182 ! 183 IF( ice_alloc_2 /= 0 ) CALL ctl_warn('ice_alloc_2: failed to allocate arrays') 183 IF( ice_alloc_2 /= 0 )THEN 184 CALL ctl_warn('ice_alloc_2: failed to allocate arrays') 185 ELSE 186 ! Initialise stress tensor to zero 187 stress12_i(:,:) = 0.0_wp 188 stress1_i(:,:) = 0.0_wp 189 stress2_i(:,:) = 0.0_wp 190 END IF 184 191 ! 185 192 END FUNCTION ice_alloc_2 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/LIM_SRC_2/limdyn_2.F90
r2715 r3837 193 193 END DO 194 194 END DO 195 195 196 ! 196 197 ELSE ! no ice dynamics : transmit directly the atmospheric stress to the ocean -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90
r2717 r3837 34 34 USE dom_ice_2 ! LIM2: ice domain 35 35 #endif 36 ! USE arpdebugging, ONLY: dump_array 36 37 37 38 IMPLICIT NONE … … 169 170 REAL(wp) :: zindb ! ice (1) or not (0) 170 171 REAL(wp) :: zdummy ! dummy argument 172 INTEGER, SAVE :: count = 0 ! For dumping data to disk ARPDBG 171 173 !!------------------------------------------------------------------- 172 174 #if defined key_lim2 && ! defined key_lim2_vp … … 180 182 at_i(:,:) = 1. - frld(:,:) 181 183 #endif 184 185 count = count + 1 ! ARPDBG - for dump_array 186 182 187 ! 183 188 !------------------------------------------------------------------------------! … … 249 254 ! v_oce2: ocean v component on v points 250 255 256 !CALL dump_array(count,'tms',tms,withHalos=.TRUE.) 257 ! CALL dump_array(count,'e1t',e1t,withHalos=.TRUE.) 258 ! CALL dump_array(count,'e2t',e2t,withHalos=.TRUE.) 259 !CALL dump_array(count,'zc1',zc1,withHalos=.TRUE.) 260 251 261 DO jj = k_j1+1, k_jpj-1 252 262 DO ji = fs_2, fs_jpim1 … … 316 326 zs2 (:,:) = stress2_i (:,:) 317 327 zs12(:,:) = stress12_i(:,:) 328 329 ! CALL dump_array(count,'u_ice_pre_iter',u_ice,withHalos=.TRUE.) 330 ! CALL dump_array(count,'e2u_pre_iter' ,e2u ,withHalos=.TRUE.) 318 331 319 332 ! !----------------------! … … 475 488 END DO 476 489 END DO 490 477 491 ! 478 492 ! Computation of ice velocity … … 598 612 ENDIF 599 613 600 ! 614 ! ! ==================== ! 601 615 END DO ! end loop over jter ! 602 616 ! ! ==================== ! 603 617 618 ! CALL dump_array(count,'u_ice_pre4',u_ice,withHalos=.TRUE.) 604 619 ! 605 620 !------------------------------------------------------------------------------! -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90
r3211 r3837 32 32 PUBLIC clo_bat ! routine called in domzgr module 33 33 34 INTEGER, PUBLIC, PARAMETER :: jpncs = 4 !: number of closed sea35 INTEGER, PUBLIC, DIMENSION(jpncs) :: ncstt !: Type of closed sea36 INTEGER, PUBLIC, DIMENSION(jpncs) :: ncsi1, ncsj1 !: south-west closed sea limits (i,j)37 INTEGER, PUBLIC, DIMENSION(jpncs) :: ncsi2, ncsj2 !: north-east closed sea limits (i,j)38 INTEGER, PUBLIC, DIMENSION(jpncs) :: ncsnr !: number of point where run-off pours39 INTEGER, PUBLIC, DIMENSION(jpncs,4) :: ncsir, ncsjr !: Location of runoff40 41 REAL(wp), DIMENSION (jpncs+1) :: surf ! closed sea surface34 INTEGER, PUBLIC, PARAMETER :: jpncs = 4 !: number of closed sea 35 INTEGER, PUBLIC, SAVE, DIMENSION(jpncs) :: ncstt !: Type of closed sea 36 INTEGER, PUBLIC, SAVE, DIMENSION(jpncs) :: ncsi1, ncsj1 !: south-west closed sea limits (i,j) 37 INTEGER, PUBLIC, SAVE, DIMENSION(jpncs) :: ncsi2, ncsj2 !: north-east closed sea limits (i,j) 38 INTEGER, PUBLIC, SAVE, DIMENSION(jpncs) :: ncsnr !: number of point where run-off pours 39 INTEGER, PUBLIC, SAVE, DIMENSION(jpncs,4) :: ncsir, ncsjr !: Location of runoff 40 41 REAL(wp), SAVE, DIMENSION (jpncs+1) :: surf ! closed sea surface 42 42 43 43 !! * Control permutation of array indices -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90
r3211 r3837 124 124 125 125 ! control print 126 IF(lwp) WRITE(numout,'(a,i6,a,i2,a,i2,a,i6)')' ==============>> 1/2 time step before the start of the run DATE Y/M/D = ', & 127 & nyear, '/', nmonth, '/', nday, ' nsec_day:', nsec_day, ' nsec_week:', nsec_week 126 IF(lwp) WRITE(numout,"(' ==============>> 1/2 time step before the start of the run DATE Y/M/D = ',i6,'/',i2,'/',i2,' nsec_day:',i6,' nsec_week:',I)") nyear, nmonth, nday, nsec_day, nsec_week 128 127 129 128 ! Up to now, calendar parameters are related to the end of previous run (nit000-1) -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r3432 r3837 200 200 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & 201 201 & mbku, mbkv !: vertical index of the bottom last U- and W- ocean level 202 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkmax !: Max index of last ocean level on any grid 202 203 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bathy !: ocean depth (meters) 203 204 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior domain T-point mask … … 323 324 324 325 ALLOCATE( mbathy(jpi,jpj) , bathy(jpi,jpj) , & 325 & tmask_i(jpi,jpj) , bmask(jpi,jpj) , 326 & tmask_i(jpi,jpj) , bmask(jpi,jpj) , mbkmax(jpi,jpj), & 326 327 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv(jpi,jpj) , STAT=ierr(9) ) 327 328 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r3211 r3837 40 40 41 41 PUBLIC dom_init ! called by opa.F90 42 PUBLIC dom_nam ! called by nemogcm::recursive_partition 42 43 43 44 !! * Control permutation of array indices -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domcfg.F90
r3432 r3837 86 86 !!$ WRITE(*,*) 'ARPDBG: ',narea,': dom_glo: nld{i,j} = ',nldi,nldj 87 87 !!$ WRITE(*,*) 'ARPDBG: ',narea,': dom_glo: nlc{i,j} = ',nlci,nlcj 88 !!$ WRITE(*,*) 'ARPDBG: ',narea,': dom_glo: jp{i,j} = ',jpi,jpj 88 89 !!$ WRITE(*,*) 'ARPDBG: ',narea,': dom_glo: n{i,j}mpp = ',nimpp, njmpp 89 90 !!$ WRITE(*,*) 'ARPDBG: ',narea,': dom_glo: jp{i,j}zoom = ',jpizoom, jpjzoom … … 110 111 ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 111 112 ! !local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 112 #if defined key_mpp_rkpart 113 #if 0 114 !defined key_mpp_rkpart 113 115 mi0(1:nimpp-1) = 1 !nldi 114 116 DO ji = 0,iesub-1,1 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r3432 r3837 43 43 44 44 PUBLIC dom_zgr ! called by dom_init.F90 45 PUBLIC zgr_z, zgr_bat, zgr_zco, zgr_zps ! called by nemogcm::recursive_partition 46 PUBLIC fssig1 ! called by partition_mod::smooth_bathy 45 47 46 48 ! !!* Namelist namzgr_sco * … … 54 56 ! ! ( rn_bb=0; top only, rn_bb =1; top and bottom) 55 57 REAL(wp) :: rn_hc = 150._wp ! Critical depth for s-sigma coordinates 56 PUBLIC rn_sbot_min, rn_sbot_max, rn_theta, rn_thetb, rn_rmax, ln_s_sigma, rn_bb,rn_hc 58 PUBLIC rn_sbot_min, rn_sbot_max, rn_theta, rn_thetb, rn_rmax, & 59 ln_s_sigma, rn_bb, rn_hc 60 PUBLIC ln_zco, ln_zps, ln_sco 61 57 62 !! * Control permutation of array indices 58 63 # include "oce_ftrans.h90" … … 62 67 # include "domzgr_substitute.h90" 63 68 # include "vectopt_loop_substitute.h90" 69 70 NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco 71 NAMELIST/namzgr_sco/ rn_sbot_max, rn_sbot_min, rn_theta, rn_thetb, & 72 rn_rmax, ln_s_sigma, rn_bb, rn_hc 73 PUBLIC namzgr, namzgr_sco 64 74 !!---------------------------------------------------------------------- 65 75 !! NEMO/OPA 3.3.1 , NEMO Consortium (2011) … … 88 98 INTEGER :: ioptio = 0 ! temporary integer 89 99 ! 90 NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco91 !!---------------------------------------------------------------------- 92 93 REWIND( numnam ) ! Read Namelist namzgr : vertical coordinate '100 !NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco 101 !!---------------------------------------------------------------------- 102 103 REWIND( numnam ) ! Read Namelist namzgr : vertical coordinate 94 104 READ ( numnam, namzgr ) 95 105 … … 287 297 288 298 289 SUBROUTINE zgr_bat 299 SUBROUTINE zgr_bat(global_domain) 290 300 !!---------------------------------------------------------------------- 291 301 !! *** ROUTINE zgr_bat *** … … 317 327 !! - bathy : meter bathymetry (in meters) 318 328 !!---------------------------------------------------------------------- 329 LOGICAL, OPTIONAL, INTENT(in) :: global_domain ! Whether dealing with 330 ! whole domain (T) or a 331 ! sub-domain after domain 332 ! decomposition 333 ! Locals 319 334 INTEGER :: ji, jj, jl, jk ! dummy loop indices 320 335 INTEGER :: inum ! temporary logical unit … … 325 340 INTEGER , DIMENSION(jpidta,jpjdta) :: idta ! global domain integer data 326 341 REAL(wp), DIMENSION(jpidta,jpjdta) :: zdta ! global domain scalar data 342 LOGICAL :: is_global 327 343 !!---------------------------------------------------------------------- 328 344 … … 330 346 IF(lwp) WRITE(numout,*) ' zgr_bat : defines level and meter bathymetry' 331 347 IF(lwp) WRITE(numout,*) ' ~~~~~~~' 348 349 ! Set local flag to signal whether we're dealing with the global domain 350 ! (pre decomposition) or a local part of it. Required by the 351 ! recursive k-section partitioning. 352 is_global = .FALSE. 353 IF( PRESENT(global_domain) )THEN 354 IF( global_domain ) is_global = .TRUE. 355 END IF 332 356 333 357 ! ! ================== ! … … 347 371 ii_bump = jpidta / 2 ! i-index of the bump center 348 372 ij_bump = jpjdta / 2 ! j-index of the bump center 349 r_bump = 50000._wp ! bump radius (meters)350 h_bump = 2700._wp ! bump height (meters)373 r_bump = 0.165*MIN(jpidta,jpjdta) ! bump radius (grid cells) 374 h_bump = 3000._wp ! bump height (meters) 351 375 h_oce = gdepw_0(jpk) ! background ocean depth (meters) 352 376 IF(lwp) WRITE(numout,*) ' bump characteristics: ' 353 IF(lwp) WRITE(numout,*) ' bump center (i,j) = ', ii_bump, i i_bump377 IF(lwp) WRITE(numout,*) ' bump center (i,j) = ', ii_bump, ij_bump 354 378 IF(lwp) WRITE(numout,*) ' bump height = ', h_bump , ' meters' 355 IF(lwp) WRITE(numout,*) ' bump radius = ', r_bump , ' index'379 IF(lwp) WRITE(numout,*) ' bump radius = ', r_bump , ' cells' 356 380 IF(lwp) WRITE(numout,*) ' background ocean depth = ', h_oce , ' meters' 357 381 ! 358 382 DO jj = 1, jpjdta ! zdta : 359 383 DO ji = 1, jpidta 360 zi = FLOAT( ji - ii_bump ) * ppe1_m / r_bump 361 zj = FLOAT( jj - ij_bump ) * ppe2_m / r_bump 384 !zi = FLOAT( ji - ii_bump ) * ppe1_m / r_bump 385 !zj = FLOAT( jj - ij_bump ) * ppe2_m / r_bump 386 zi = FLOAT( ji - ii_bump ) / r_bump 387 zj = FLOAT( jj - ij_bump ) / r_bump 362 388 zdta(ji,jj) = h_oce - h_bump * EXP( -( zi*zi + zj*zj ) ) 363 389 END DO … … 412 438 ! 413 439 IF( ln_zco ) THEN ! zco : read level bathymetry 414 CALL iom_open ( 'bathy_level.nc', inum ) 415 CALL iom_get ( inum, jpdom_data, 'Bathy_level', bathy ) 440 CALL iom_open ( 'bathy_level.nc', inum ) 441 IF(is_global)THEN 442 CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , bathy, & 443 kstart=(/jpizoom,jpjzoom/), & 444 kcount=(/jpiglo,jpjglo/) ) 445 ELSE 446 CALL iom_get ( inum, jpdom_data, 'Bathy_level', bathy ) 447 END IF 448 416 449 CALL iom_close( inum ) 417 450 mbathy(:,:) = INT( bathy(:,:) ) … … 446 479 IF( ln_zps .OR. ln_sco ) THEN ! zps or sco : read meter bathymetry 447 480 CALL iom_open ( 'bathy_meter.nc', inum ) 448 CALL iom_get ( inum, jpdom_data, 'Bathymetry', bathy ) 481 IF(is_global)THEN 482 CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , bathy, & 483 kstart=(/jpizoom,jpjzoom/), & 484 kcount=(/jpiglo,jpjglo/) ) 485 ELSE 486 CALL iom_get ( inum, jpdom_data, 'Bathymetry', bathy ) 487 END IF 449 488 CALL iom_close( inum ) 450 489 ! ! ===================== … … 516 555 zhmin = gdepw_0(ik+1) ! minimum depth = ik+1 w-levels 517 556 WHERE( bathy(:,:) <= 0._wp ) ; bathy(:,:) = 0._wp ! min=0 over the lands 518 ELSE WHERE; bathy(:,:) = MAX( zhmin , bathy(:,:) ) ! min=zhmin over the oceans557 ELSEWHERE ; bathy(:,:) = MAX( zhmin , bathy(:,:) ) ! min=zhmin over the oceans 519 558 END WHERE 520 559 IF(lwp) write(numout,*) 'Minimum ocean depth: ', zhmin, ' minimum number of ocean levels : ', ik … … 730 769 !! (min value = 1 over land) 731 770 !!---------------------------------------------------------------------- 771 !USE arpdebugging, ONLY: dump_array 732 772 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 733 773 USE wrk_nemo, ONLY: zmbk => wrk_2d_1 … … 744 784 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' 745 785 ! 786 !CALL dump_array(0, 'mbathy', mbathy, withHalos=.TRUE.) 787 746 788 mbkt(:,:) = MAX( mbathy(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) 747 789 ! ! bottom k-index of W-level = mbkt+1 … … 755 797 zmbk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 756 798 zmbk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 799 ! 800 ! Compute and store the deepest bottom level of any grid-type at each grid point 801 ! For use in removing data below ocean floor from halo exchanges. 802 mbkmax(:,:) = MAX(mbkt(:,:)+1, mbku(:,:), mbkv(:,:)) 757 803 ! 758 804 IF( wrk_not_released(2, 1) ) CALL ctl_stop('zgr_bot_level: failed to release workspace array') … … 809 855 810 856 811 SUBROUTINE zgr_zps 857 SUBROUTINE zgr_zps(pre_domain_decomp) 812 858 !!---------------------------------------------------------------------- 813 859 !! *** ROUTINE zgr_zps *** … … 858 904 !! DCSE_NEMO: wrk_3d_1 renamed, need additional directive 859 905 !FTRANS zprt :I :I :z 906 LOGICAL, INTENT(in), OPTIONAL :: pre_domain_decomp 860 907 !! 861 908 INTEGER :: ji, jj, jk ! dummy loop indices … … 892 939 bathy(:,:) = MIN( zmax , bathy(:,:) ) ! bounded value of bathy (min already set at the end of zgr_bat) 893 940 WHERE( bathy(:,:) == 0._wp ) ; mbathy(:,:) = 0 ! land : set mbathy to 0 894 ELSE 941 ELSEWHERE ; mbathy(:,:) = jpkm1 ! ocean : initialize mbathy to the max ocean level 895 942 END WHERE 896 943 … … 903 950 WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth ) mbathy(:,:) = jk-1 904 951 END DO 952 953 ! If we've been called before domain decomposition then we only want to compute 954 ! mbathy and the return. 955 IF( PRESENT(pre_domain_decomp) )THEN 956 IF( pre_domain_decomp )RETURN 957 ENDIF 905 958 906 959 ! Scale factors and depth at T- and W-points … … 1208 1261 USE mapcomm_mod, ONLY: trimmed, cyclic_bc 1209 1262 USE mapcomm_mod, ONLY: nidx, eidx, sidx, widx 1210 ! USE arpdebugging, ONLY: dump_array 1263 1211 1264 !! DCSE_NEMO: wrk_nemo module variables renamed, need additional directives 1212 1265 !FTRANS gsigw3 :I :I :z … … 1227 1280 ! 1228 1281 1229 NAMELIST/namzgr_sco/ rn_sbot_max, rn_sbot_min, rn_theta, rn_thetb, rn_rmax, ln_s_sigma, rn_bb, rn_hc1282 ! NAMELIST/namzgr_sco/ rn_sbot_max, rn_sbot_min, rn_theta, rn_thetb, rn_rmax, ln_s_sigma, rn_bb, rn_hc 1230 1283 !!---------------------------------------------------------------------- 1231 1284 … … 1319 1372 jl, zrmax, INT( SUM(zmsk(:,:) ) ) 1320 1373 ! 1321 !!$ IF(jl < 6)THEN ! .OR. (MOD(jl,1000) == 0) )THEN1322 !!$ CALL dump_array(jl, 'zenv_before', zenv, withHalos=.TRUE.)1323 !!$ CALL dump_array(jl, 'ztmp_before', ztmp, withHalos=.TRUE.)1324 !!$ CALL dump_array(jl, 'zmsk_before', zmsk, withHalos=.TRUE.)1325 !!$ END IF1326 1374 1327 1375 ! Copy current surface before next smoothing iteration … … 1361 1409 ! Apply lateral boundary condition but do not zero on closed boundaries 1362 1410 CALL lbc_lnk( zenv, 'T', 1._wp, lzero=.FALSE. ) 1363 1364 !!$ IF(jl < 6)THEN ! .OR. (MOD(jl,1000) == 0) )THEN1365 !!$ CALL dump_array(jl, 'zenv', zenv, withHalos=.TRUE.)1366 !!$ CALL dump_array(jl, 'ztmp', ztmp, withHalos=.TRUE.)1367 !!$ CALL dump_array(jl, 'zmsk', zmsk, withHalos=.TRUE.)1368 !!$ END IF1369 1411 1370 1412 ! ! ================ ! … … 1709 1751 CALL ctl_stop( ctmp1 ) 1710 1752 ENDIF 1753 #if defined key_vvl 1711 1754 IF( gdepw_1(ji,jj,jk) < 0._wp .OR. gdept_1(ji,jj,jk) < 0._wp ) THEN 1712 1755 WRITE(ctmp1,*) 'zgr_sco : gdepw or gdept =< 0 at point (i,j,k)= ', ji, jj, jk 1713 1756 CALL ctl_stop( ctmp1 ) 1714 1757 ENDIF 1758 #endif 1715 1759 END DO 1716 1760 END DO -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90
r3432 r3837 166 166 ENDIF ! explicit case not coded yet with AGRIF 167 167 ENDIF 168 ! 168 169 169 END SUBROUTINE istate_init 170 170 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90
r2528 r3837 118 118 WRITE(numout,*) ' ',' jpij : ', jpij 119 119 WRITE(numout,*) ' mpp local domain info (mpp)' 120 #if defined key_mpp_rkpart 121 WRITE(numout,*) ' recursive k-section decomposition used. See file: domain_decomp.ps' 122 WRITE(numout,*) ' jpreci : ', jpreci, ' jprecj : ', jprecj 123 #else 124 ! These parameters are only used in the original, regular domain 125 ! decomposition scheme so we don't print them if we're using 126 ! recursive k-section partitioning. 120 127 WRITE(numout,*) ' jpni : ', jpni, ' jpreci : ', jpreci 121 128 WRITE(numout,*) ' jpnj : ', jpnj, ' jprecj : ', jprecj 122 129 WRITE(numout,*) ' jpnij : ', jpnij 130 #endif 123 131 WRITE(numout,*) ' lateral domain boundary condition type : jperio = ', jperio 124 132 WRITE(numout,*) -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90
r3432 r3837 102 102 USE oce , ONLY: ze3u_f => ta , ze3v_f => sa ! (ta,sa) used as 3D workspace 103 103 USE wrk_nemo, ONLY: zs_t => wrk_2d_1 , zs_u_1 => wrk_2d_2 , zs_v_1 => wrk_2d_3 104 USE arpdebugging, ONLY: dump_array 104 105 !! DCSE_NEMO: need additional directives for renamed module variables 105 106 !FTRANS ze3u_f :I :I :z … … 126 127 IF(lwp) WRITE(numout,*) '~~~~~~~' 127 128 ENDIF 129 130 ! CALL dump_array(kt, 'ua_nxt_start',ua(:,:,1),withHalos=.TRUE.) 128 131 129 132 #if defined key_dynspg_flt -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r3211 r3837 133 133 END DO 134 134 ENDIF 135 136 135 137 136 SELECT CASE ( nspg ) ! compute surf. pressure gradient trend and add it to the general trend -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90
r3211 r3837 112 112 !!--------------------------------------------------------------------- 113 113 USE oce, ONLY: zub => ta , zvb => sa ! (ta,sa) used as workspace 114 ! USE arpdebugging, ONLY: dump_array 114 115 !! DCSE_NEMO: need additional directives for renamed module variables 115 116 !FTRANS zub :I :I :z … … 137 138 ! ! gcx, gcxb 138 139 ENDIF 140 141 ! CALL dump_array(kt, 'spgu',spgu,withHalos=.TRUE.) 142 ! CALL dump_array(kt, 'sshn',sshn,withHalos=.TRUE.) 143 !#if defined key_z_first 144 ! CALL dump_array(kt, 'ua',ua(1,:,:),withHalos=.TRUE.) 145 !#else 146 ! CALL dump_array(kt, 'ua',ua(:,:,1),withHalos=.TRUE.) 147 !#endif 139 148 140 149 ! Local constant initialization -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynzad.F90
r3211 r3837 157 157 CALL trd_mod(ztrdu, ztrdv, jpdyn_trd_zad, 'DYN', kt) 158 158 ENDIF 159 159 160 ! ! Control print 160 161 IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' zad - Ua: ', mask1=umask, & -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90
r3211 r3837 63 63 USE oce , ONLY: zwd => ta , zws => sa ! (ta,sa) used as 3D workspace 64 64 USE wrk_nemo, ONLY: zwi => wrk_3d_3 ! 3D workspace 65 USE arpdebugging, ONLY: dump_array 65 66 !! DCSE_NEMO: need additional directives for renamed module variables 66 67 !FTRANS zwd :I :I :z … … 88 89 ! -------------------------------- 89 90 z1_p2dt = 1._wp / p2dt ! inverse of the timestep 91 92 !CALL dump_array(kt, 'utau_pre_zdf',utau(:,:),withHalos=.TRUE.) 93 !CALL dump_array(kt, 'utaub_pre_zdf',utau_b(:,:),withHalos=.TRUE.) 90 94 91 95 ! 1. Vertical diffusion on u -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/exchmod.F90
r3432 r3837 11 11 ! Make some key parameters from mapcomm_mod available to all who 12 12 ! USE this module 13 USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE 13 USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE, & 14 jeub 14 15 IMPLICIT none 15 16 … … 63 64 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north ! dim. ndim_rank_north, number 64 65 ! of the procs belonging to ncomm_north 66 LOGICAL, SAVE :: do_nfold ! Whether this PE contributes to N-fold exchange 67 ! - takes domain trimming into account. 65 68 INTEGER, PARAMETER :: num_nfold_rows = 4 ! No. of rows at the top of the 66 69 ! global domain to use in applying 67 70 ! the north-fold condition (no value 68 ! other than 4 currently supported) 71 ! other than 4 currently tested) 72 73 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nfold_npts ! How many points each 74 ! northern proc contrib 75 ! to nfold exchange 69 76 70 77 !FTRANS r3dptr :I :I :z … … 112 119 nrank_north, north_root, ndim_rank_north, & 113 120 ngrp_north, ngrp_world, ncomm_north, & 121 num_nfold_rows, do_nfold, nfold_npts, & 114 122 exchmod_alloc, add_exch, bound_exch_list, & 115 Iminus, Iplus, Jminus, Jplus, NONE, num_nfold_rows, & 116 lbc_exch3, lbc_exch2, & !lbc_exch3i, lbc_exch2i, & 117 MPI_COMM_WORLD, MPI_Wtime 123 Iminus, Iplus, Jminus, Jplus, NONE, & 124 lbc_exch3, lbc_exch2 125 126 #if defined key_mpp_mpi 127 PUBLIC MPI_COMM_WORLD, MPI_Wtime 128 #endif 118 129 119 130 ! MPI only … … 285 296 286 297 SUBROUTINE bound_exch_generic ( b2, ib2, b3, ib3, nhalo, nhexch, & 287 comm1, comm2, comm3, comm4, &288 cd_type, lfill, isgn, lzero )298 comm1, comm2, comm3, comm4, & 299 cd_type, lfill, pval, isgn, lzero ) 289 300 USE par_oce, ONLY: wp, jpreci, jprecj, jpim1 290 301 USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, & 291 nperio, nbondi, npolj302 nperio, nbondi, npolj, narea 292 303 USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc 304 USE mapcomm_mod, ONLY: trimmed, eidx, widx 293 305 IMPLICIT none 294 306 INTEGER, INTENT(in) :: nhalo,nhexch … … 302 314 CHARACTER(len=1), INTENT(in) :: cd_type 303 315 LOGICAL, OPTIONAL, INTENT(in) :: lfill 316 REAL(wp),OPTIONAL, INTENT(in) :: pval ! background value (used at closed boundaries) 304 317 INTEGER, OPTIONAL, INTENT(in) :: isgn 305 LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to zero halos on closed boundaries318 LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to set halo values on closed boundaries 306 319 ! Local arguments 307 320 INTEGER :: itag ! Communication handle … … 310 323 INTEGER :: ileft, iright ! First and last x-coord of internal points 311 324 INTEGER :: kdim1 325 INTEGER :: iland ! Land values - zero by default unless pval passed in. 326 REAL(wp) :: zland ! " " 312 327 LOGICAL :: lfillarg, lzeroarg 313 328 !!-------------------------------------------------------------------- … … 324 339 lfillarg = .FALSE. 325 340 isgnarg = 1 341 zland = 0.0_wp 326 342 327 343 IF( PRESENT(lfill) ) lfillarg = lfill 328 344 IF( PRESENT(isgn) ) isgnarg = isgn 329 345 IF( PRESENT(lzero) ) lzeroarg = lzero 346 IF( PRESENT(pval) ) zland = pval 347 iland=INT(zland) 330 348 331 349 ! Find out the size of 3rd dimension of the array … … 356 374 ! have cyclic E-W boundary conditions. 357 375 ileft = nldi 358 IF(ilbext .AND. cyclic_bc)ileft = ileft + 1 376 IF( (ilbext .AND. (.NOT. trimmed(widx,narea))) .AND. cyclic_bc) & 377 ileft = ileft + 1 359 378 360 379 iright = nlei 361 IF(iubext .AND. cyclic_bc)iright = iright - 1 380 IF( (iubext .AND. (.NOT. trimmed(eidx,narea))) .AND. cyclic_bc) & 381 iright = iright - 1 362 382 363 383 IF ( PRESENT(b2) ) THEN … … 527 547 END IF 528 548 529 ELSE ! lfillarg is .FALSE. 549 ELSE ! lfillarg is .FALSE. - standard closed or cyclic treatment 530 550 531 551 ! ! East-West boundaries 532 552 ! ! ==================== 553 ! nbondi == 2 when a single sub-domain spans the whole width 554 ! of the global domain 533 555 IF( nbondi == 2 .AND. & ! Cyclic east-west 534 556 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN … … 568 590 SELECT CASE ( cd_type ) 569 591 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 570 b2(1:jpreci , :) = 0._wp! Western halo571 b2(nlci-jpreci+1:jpi, :) = 0._wp! Eastern halo592 b2(1:jpreci , :) = zland ! Western halo 593 b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo 572 594 CASE ( 'F' ) 573 b2(nlci-jpreci+1:jpi, :) = 0._wp! Eastern halo595 b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo 574 596 END SELECT 575 597 ELSE IF ( PRESENT(ib2) ) THEN 576 598 SELECT CASE ( cd_type ) 577 599 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 578 ib2(1:jpreci , :) = 0! Western halo579 ib2(nlci-jpreci+1:jpi, :) = 0! Eastern halo600 ib2(1:jpreci , :) = iland ! Western halo 601 ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo 580 602 CASE ( 'F' ) 581 ib2(nlci-jpreci+1:jpi, :) = 0! Eastern halo603 ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo 582 604 END SELECT 583 605 ELSE IF ( PRESENT(b3) ) THEN … … 588 610 DO ji=1,jpreci,1 589 611 DO jk=1,jpk,1 590 b3(ji, jj, jk) = 0._wp612 b3(ji, jj, jk) = zland 591 613 END DO 592 614 END DO 593 615 DO ji=nlci-jpreci+1,jpi,1 594 616 DO jk=1,jpk,1 595 b3(ji, jj, jk) = 0._wp617 b3(ji, jj, jk) = zland 596 618 END DO 597 619 END DO 598 620 END DO 599 621 #else 600 b3(1:jpreci , :, :) = 0._wp601 b3(nlci-jpreci+1:jpi, :, :) = 0._wp622 b3(1:jpreci , :, :) = zland 623 b3(nlci-jpreci+1:jpi, :, :) = zland 602 624 #endif 603 625 CASE ( 'F' ) … … 606 628 DO ji = nlci-jpreci+1,jpi,1 607 629 DO jk = 1,jpk,1 608 b3(ji, jj, jk) = 0._wp630 b3(ji, jj, jk) = zland 609 631 END DO 610 632 END DO 611 633 END DO 612 634 #else 613 b3(nlci-jpreci+1:jpi, :, :) = 0._wp635 b3(nlci-jpreci+1:jpi, :, :) = zland 614 636 #endif 615 637 END SELECT … … 617 639 SELECT CASE ( cd_type ) 618 640 CASE ( 'T', 'U', 'V', 'W' ) 619 ib3(1:jpreci , :, :) = 0620 ib3(nlci-jpreci+1:jpi, :, :) = 0641 ib3(1:jpreci , :, :) = iland 642 ib3(nlci-jpreci+1:jpi, :, :) = iland 621 643 CASE ( 'F' ) 622 ib3(nlci-jpreci+1:jpi, :, :) = 0644 ib3(nlci-jpreci+1:jpi, :, :) = iland 623 645 END SELECT 624 646 END IF … … 630 652 IF( lzeroarg )THEN 631 653 632 ! ! North-South boundaries633 ! 654 ! ! North-South boundaries (always closed) 655 ! ! ====================== 634 656 IF ( PRESENT(b2) ) THEN 635 657 SELECT CASE ( cd_type ) 636 658 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 637 b2(:,1:nldj-1 ) = 0._wp 638 b2(:,nlcj-jprecj+1:jpj) = 0._wp 659 !b2(:,1:nldj-1 ) = zland 660 ! Below is what is done in original lib_mpp.F90 661 b2(:,1:jprecj ) = zland 662 b2(:,nlcj-jprecj+1:jpj) = zland 639 663 CASE ( 'F' ) 640 b2(:,nlcj-jprecj+1:jpj) = 0._wp664 b2(:,nlcj-jprecj+1:jpj) = zland 641 665 END SELECT 642 666 ELSE IF ( PRESENT(ib2) ) THEN 643 667 SELECT CASE ( cd_type ) 644 668 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 645 ib2(:,1:jprecj ) = 0646 ib2(:,nlcj-jprecj+1:jpj) = 0669 ib2(:,1:jprecj ) = iland 670 ib2(:,nlcj-jprecj+1:jpj) = iland 647 671 CASE ( 'F' ) 648 ib2(:,nlcj-jprecj+1:jpj) = 0672 ib2(:,nlcj-jprecj+1:jpj) = iland 649 673 END SELECT 650 674 ELSE IF ( PRESENT(b3) ) THEN … … 652 676 CASE ( 'T', 'U', 'V', 'W' ) 653 677 #if defined key_z_first 654 DO jj=1, nldj-1,1678 DO jj=1,jprecj,1 655 679 DO ji=1,jpi,1 656 680 DO jk = 1,jpk,1 657 b3(ji, jj, jk) = 0._wp681 b3(ji, jj, jk) = zland 658 682 END DO 659 683 END DO … … 662 686 DO ji=1,jpi,1 663 687 DO jk = 1,jpk,1 664 b3(ji, jj, jk) = 0._wp688 b3(ji, jj, jk) = zland 665 689 END DO 666 690 END DO 667 691 END DO 668 692 #else 669 b3(:, 1: nldj-1 , :) = 0._wp670 b3(:, nlcj-jprecj+1:jpj, :) = 0._wp693 b3(:, 1:jprecj , :) = zland 694 b3(:, nlcj-jprecj+1:jpj, :) = zland 671 695 #endif 672 696 CASE ( 'F' ) … … 675 699 DO ji=1,jpi,1 676 700 DO jk = 1,jpk,1 677 b3(ji, jj, jk) = 0._wp701 b3(ji, jj, jk) = zland 678 702 END DO 679 703 END DO 680 704 END DO 681 705 #else 682 b3(:, nlcj-jprecj+1:jpj, :) = 0._wp706 b3(:, nlcj-jprecj+1:jpj, :) = zland 683 707 #endif 684 708 END SELECT … … 686 710 SELECT CASE ( cd_type ) 687 711 CASE ( 'T', 'U', 'V', 'W' ) 688 ib3(:, 1:jprecj , :) = 0689 ib3(:, nlcj-jprecj+1:jpj, :) = 0712 ib3(:, 1:jprecj , :) = iland 713 ib3(:, nlcj-jprecj+1:jpj, :) = iland 690 714 CASE ( 'F' ) 691 ib3(:, nlcj-jprecj+1:jpj, :) = 0715 ib3(:, nlcj-jprecj+1:jpj, :) = iland 692 716 END SELECT 693 717 END IF … … 726 750 ! We only need to repeat the East and West halo swap if there 727 751 ! IS a north-fold in the configuration. 728 SELECT CASE (npolj) 729 730 CASE ( 3, 4, 5, 6 ) 731 732 ! Update East and West halos as required 752 !SELECT CASE (npolj) 753 754 !CASE ( 3, 4, 5, 6 ) 755 IF(ndim_rank_north > 0)THEN 756 757 ! Update East and West halos as required - no data sent north 758 ! as it's only the northern-most PEs that have been affected 759 ! by the north-fold condition. 733 760 ! ARPDBG - inefficient since all PEs do halo swap and only 734 761 ! those affected by the north fold actually need to - can 735 762 ! this be done within apply_north_fold? 736 763 CALL exchs_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, & 737 nhexch=nhexch, handle=itag, &738 comm1=Iplus,comm2=Iminus,comm3=NONE,comm4=NONE, &739 cd_type=cd_type, lfill=lfillarg)764 nhexch=nhexch, handle=itag, & 765 comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & 766 cd_type=cd_type, lfill=lfillarg) 740 767 741 768 !CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, & … … 743 770 ! comm1=Iplus,comm2=Iminus,comm3=NONE,comm4=NONE) 744 771 ! comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 ) 745 END SELECT ! npolj 772 END IF ! ndim_rank_north > 0 773 !END SELECT ! npolj 746 774 747 775 END IF … … 1160 1188 1161 1189 DO ifield = 1, nfields, 1 1162 IF( npolj /= 0 )THEN ! only for northern procs.1190 IF( npolj /= 0 .AND. do_nfold )THEN ! only for northern procs. 1163 1191 1164 1192 IF(ASSOCIATED(list(ifield)%r2dptr))THEN … … 1180 1208 END DO 1181 1209 1182 !!$ IF( npolj /= 0 ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs.1210 !!$ IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs. 1183 1211 1184 1212 END SELECT ! jpni … … 1943 1971 1944 1972 CASE DEFAULT ! more than 1 proc along I 1945 IF( npolj /= 0 )CALL mpp_lbc_north( b2, cd_type, psgn ) ! only for northern procs.1973 IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north( b2, cd_type, psgn ) ! only for northern procs. 1946 1974 1947 1975 END SELECT ! jpni … … 2074 2102 2075 2103 CASE DEFAULT ! more than 1 proc along I 2076 IF( npolj /= 0 )CALL mpp_lbc_north( ib2, cd_type, isgn ) ! only for northern procs.2104 IF( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north( ib2, cd_type, isgn ) ! only for northern procs. 2077 2105 2078 2106 END SELECT ! jpni … … 2285 2313 2286 2314 CASE DEFAULT ! more than 1 proc along I 2287 IF ( npolj /= 0 ) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs.2315 IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs. 2288 2316 2289 2317 END SELECT ! jpni … … 2493 2521 2494 2522 CASE DEFAULT ! more than 1 proc along I 2495 IF ( npolj /= 0 ) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs.2523 IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs. 2496 2524 2497 2525 END SELECT ! jpni … … 2557 2585 ELSE 2558 2586 ! This section is both for error checking and allows me to be lazy in the 2559 ! testing code - I don't have to check which arrays I've been passed. 2587 ! testing code - I don't have to check which arrays I've been passed 2588 ! before I call this routine. 2560 2589 WRITE (*,*) 'WARNING: add_exch called without a ptr to an array - will be ignored' 2561 2590 RETURN … … 2588 2617 SUBROUTINE bound_exch2 (b, nhalo, nhexch, & 2589 2618 comm1, comm2, comm3, comm4, & 2590 cd_type, lfill, isgn, lzero )2619 cd_type, lfill, pval, isgn, lzero ) 2591 2620 !!---------------------------------------------------------------------- 2592 2621 !!---------------------------------------------------------------------- … … 2600 2629 INTEGER, OPTIONAL, INTENT(in) :: isgn 2601 2630 LOGICAL, OPTIONAL, INTENT(in) :: lzero 2631 REAL(wp),OPTIONAL, INTENT(in) :: pval 2602 2632 2603 2633 CALL bound_exch_generic( b2=b,nhalo=nhalo,nhexch=nhexch, & 2604 2634 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & 2605 cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero ) 2635 cd_type=cd_type, lfill=lfill, pval=pval, & 2636 isgn=isgn, lzero=lzero ) 2606 2637 RETURN 2607 2638 END SUBROUTINE bound_exch2 … … 2609 2640 2610 2641 SUBROUTINE bound_exch2i (b, nhalo, nhexch, comm1, comm2, comm3, comm4, & 2611 cd_type, lfill, isgn, lzero )2642 cd_type, lfill, pval, isgn, lzero ) 2612 2643 !!---------------------------------------------------------------------- 2613 2644 !!---------------------------------------------------------------------- … … 2621 2652 INTEGER, OPTIONAL, INTENT(in) :: isgn 2622 2653 LOGICAL, OPTIONAL, INTENT(in) :: lzero 2654 REAL(wp),OPTIONAL, INTENT(in) :: pval 2623 2655 2624 2656 CALL bound_exch_generic (ib2=b,nhalo=nhalo,nhexch=nhexch, & 2625 2657 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & 2626 cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero ) 2658 cd_type=cd_type, lfill=lfill, pval=pval, & 2659 isgn=isgn, lzero=lzero ) 2627 2660 RETURN 2628 2661 END SUBROUTINE bound_exch2i … … 2630 2663 2631 2664 SUBROUTINE bound_exch3 (b, nhalo, nhexch, comm1, comm2, comm3, & 2632 comm4, cd_type, lfill, isgn, lzero)2665 comm4, cd_type, lfill, pval, isgn, lzero) 2633 2666 !!---------------------------------------------------------------------- 2634 2667 !!---------------------------------------------------------------------- … … 2642 2675 INTEGER, OPTIONAL, INTENT(in) :: isgn 2643 2676 LOGICAL, OPTIONAL, INTENT(in) :: lzero 2677 REAL(wp),OPTIONAL, INTENT(in) :: pval 2644 2678 2645 2679 CALL bound_exch_generic ( b3=b,nhalo=nhalo,nhexch=nhexch,& 2646 2680 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & 2647 cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero ) 2681 cd_type=cd_type, lfill=lfill, pval=pval, & 2682 isgn=isgn, lzero=lzero ) 2648 2683 RETURN 2649 2684 END SUBROUTINE bound_exch3 … … 2651 2686 2652 2687 SUBROUTINE bound_exch3i (b, nhalo, nhexch, comm1, comm2, comm3, & 2653 comm4, cd_type, lfill, isgn, lzero)2688 comm4, cd_type, lfill, pval, isgn, lzero) 2654 2689 !!---------------------------------------------------------------------- 2655 2690 !!---------------------------------------------------------------------- … … 2662 2697 INTEGER, OPTIONAL, INTENT(in) :: isgn 2663 2698 LOGICAL, OPTIONAL, INTENT(in) :: lzero 2699 REAL(wp),OPTIONAL, INTENT(in) :: pval 2664 2700 2665 2701 CALL bound_exch_generic ( ib3=b,nhalo=nhalo,nhexch=nhexch, & 2666 2702 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & 2667 cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero ) 2703 cd_type=cd_type, lfill=lfill, pval=pval, & 2704 isgn=isgn, lzero=lzero ) 2668 2705 2669 2706 END SUBROUTINE bound_exch3i … … 2695 2732 LOGICAL :: lfill 2696 2733 2697 ! ARPDBG - don't know whether pval currently maps into exchmod framework2698 IF(PRESENT(pval))THEN2699 CALL ctl_stop('STOP','lbc_exch2: got pval argument - NOT IMPLEMENTED')2700 RETURN2701 END IF2702 2703 2734 lfill = .FALSE. 2704 2735 IF(PRESENT(cd_mpp))THEN … … 2708 2739 CALL bound_exch_generic( b2=pt2d,nhalo=jpreci,nhexch=jpreci, & 2709 2740 comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & 2710 cd_type=cd_type, lfill=lfill, isgn=INT(psgn), lzero=lzero ) 2741 cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), & 2742 lzero=lzero ) 2711 2743 2712 2744 END SUBROUTINE lbc_exch2 … … 2731 2763 LOGICAL :: lfill 2732 2764 2733 ! ARPDBG - don't know whether pval currently maps into exchmod framework2734 IF(PRESENT(pval))THEN2735 CALL ctl_stop('STOP','lbc_exch3: got pval argument - NOT IMPLEMENTED')2736 RETURN2737 END IF2738 2739 2765 lfill = .FALSE. 2740 2766 IF(PRESENT(cd_mpp))THEN … … 2742 2768 END IF 2743 2769 2744 CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci,& 2745 comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & 2746 cd_type=cd_type, lfill=lfill, isgn=INT(psgn), lzero=lzero ) 2770 CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci, & 2771 comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & 2772 cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), & 2773 lzero=lzero ) 2747 2774 2748 2775 END SUBROUTINE lbc_exch3 … … 2773 2800 USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, & 2774 2801 IminusJminus, IplusJminus, IminusJplus, & 2775 nsend, nxsend, nysend, nxsendp,nysendp,nsendp, & 2802 nsend, nxsend, nysend, nxsendp,nysendp,nzsendp, & 2803 nsendp, & 2776 2804 destination,dirsend, dirrecv, & 2777 2805 isrcsendp,jsrcsendp, idesrecvp, jdesrecvp, & 2778 nrecv, nxrecv,nyrecv,nxrecvp,nyrecvp,nrecvp, & 2806 nrecv, & 2807 nxrecvp,nyrecvp,nzrecvp, nrecvp, nrecvp2d, & 2779 2808 source, iesub, jesub, & 2780 2809 MaxCommDir, MaxComm, cyclic_bc, & 2781 2810 nrecvp, npatchsend, npatchrecv 2782 USE lib_mpp, ONLY: mpi_comm_opa, ctl_stop 2811 USE lib_mpp, ONLY: ctl_stop 2812 #if defined key_mpp_mpi 2813 USE lib_mpp, ONLY: mpi_comm_opa 2814 #endif 2783 2815 #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS 2784 2816 USE dom_oce, ONLY: narea … … 2793 2825 2794 2826 LOGICAL :: enabled(0:MaxCommDir, maxExchItems) 2795 INTEGER :: ides, ierr, irecv, isend, & 2796 isrc, jdes, jsrc, nxr, nyr, & 2797 nxs, nys, tag, tag_orig, & 2827 INTEGER :: ides, ierr, irecv, isend, & 2828 isrc, jdes, jsrc, tag, tag_orig, & 2798 2829 ibeg, iend, jbeg, jend 2799 2830 INTEGER :: i, j, k, ic, ifield, ipatch ! Loop counters … … 2801 2832 INTEGER :: npacked 2802 2833 INTEGER :: handle 2834 #if defined key_mpp_mpi 2803 2835 INTEGER :: status(MPI_status_size) 2804 2836 INTEGER :: astatus(MPI_status_size,MaxComm) 2837 #endif 2805 2838 INTEGER :: r2dcount, r3dcount, i2dcount, i3dcount 2806 2839 ! Indices into int and real copy buffers … … 2826 2859 #endif 2827 2860 2828 CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat)2861 !CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat) 2829 2862 2830 2863 ! Allocate a communications tag/handle and a flags array. … … 2841 2874 ! Check halo width is in range. 2842 2875 IF ( list(ifield)%halo_width.GT.jpreci ) THEN 2843 CALL ctl_stop('STOP','exchs: halo width greater than maximum') 2876 CALL ctl_stop('STOP', & 2877 'exchs_generic_list: halo width greater than maximum') 2844 2878 RETURN 2845 2879 ENDIF … … 2881 2915 IF( have_real_field )THEN 2882 2916 2883 ALLOCATE(recvBuff( jpkdta*maxrecvpts*nfields,nrecv),stat=ierr)2917 ALLOCATE(recvBuff(maxrecvpts*nfields,nrecv),stat=ierr) 2884 2918 !WRITE(*,"('Allocated ',I7,' reals for recv buff')") & 2885 2919 ! jpkdta*maxrecvpts*nfields … … 2898 2932 IF( have_int_field .AND. (ierr == 0) )THEN 2899 2933 2900 ALLOCATE(recvIBuff( jpkdta*maxrecvpts*nfields,nrecv),stat=ierr)2934 ALLOCATE(recvIBuff(maxrecvpts*nfields,nrecv),stat=ierr) 2901 2935 !WRITE(*,"('Allocated ',I7,' ints for recv buff')") & 2902 2936 ! jpkdta*maxrecvpts*nfields … … 2927 2961 i3dcount = 0 2928 2962 2929 IF(source(irecv).GE.0 .AND. nrecvp(irecv,1).GT.0 ) THEN 2963 IF( source(irecv).GE.0 .AND. & 2964 ( (nrecvp(irecv,1) > 0) .OR. (nrecvp2d(irecv,1) > 0) ) ) THEN 2930 2965 2931 2966 ! This loop is to allow for different fields to have different … … 2935 2970 IF ( enabled(dirrecv(irecv), ifield) ) THEN 2936 2971 IF( ASSOCIATED(list(ifield)%r2dptr) )THEN 2937 r2dcount = r2dcount + 12972 r2dcount = r2dcount + nrecvp2d(irecv,1) 2938 2973 ELSE IF( ASSOCIATED(list(ifield)%i2dptr) )THEN 2939 i2dcount = i2dcount + 12974 i2dcount = i2dcount + nrecvp2d(irecv,1) 2940 2975 ELSE IF( ASSOCIATED(list(ifield)%r3dptr) )THEN 2941 2976 ! Allow for varying size of third dimension 2942 r3dcount = r3dcount + SIZE(list(ifield)%r3dptr, index_z)2977 r3dcount = r3dcount + nrecvp(irecv,1) 2943 2978 ELSE IF( ASSOCIATED(list(ifield)%i3dptr) )THEN 2944 2979 ! Allow for varying size of third dimension 2945 i3dcount = i3dcount + SIZE(list(ifield)%i3dptr, index_z)2980 i3dcount = i3dcount + nrecvp(irecv,1) 2946 2981 END IF 2947 2982 END IF … … 2957 2992 2958 2993 IF ( r2dcount > 0 .OR. r3dcount > 0 ) THEN 2959 CALL MPI_irecv (recvBuff(1,irecv),( (r2dcount+r3dcount)*nrecvp(irecv,1)), &2994 CALL MPI_irecv (recvBuff(1,irecv),(r2dcount+r3dcount), & 2960 2995 MPI_DOUBLE_PRECISION, source(irecv), tag, mpi_comm_opa, & 2961 2996 exch_flags(handle,irecv,indexr), ierr) 2962 2997 END IF 2963 2998 IF ( i2dcount > 0 .OR. i3dcount > 0 ) THEN 2964 CALL MPI_irecv (recvIBuff(1,irecv),( (i2dcount+i3dcount)*nrecvp(irecv,1)), &2999 CALL MPI_irecv (recvIBuff(1,irecv),(i2dcount+i3dcount), & 2965 3000 MPI_INTEGER, source(irecv),tag, mpi_comm_opa, & 2966 3001 exch_flags(handle,irecv,indexr),ierr) … … 2993 3028 2994 3029 ierr = 0 2995 newSize = jpkdta*maxsendpts*nfields3030 newSize = maxsendpts*nfields 2996 3031 IF( have_real_field .AND. newSize > sendBuffSize)THEN 2997 3032 sendBuffSize=newSize … … 3010 3045 3011 3046 IF (ierr .ne. 0) THEN 3012 WRITE(*,*) 'ARPDBG: failed to allocate send buf'3013 3047 CALL ctl_stop('STOP','exchs_generic_list: unable to allocate send buff') 3014 3048 END IF … … 3111 3145 DO j=jbeg, jend, 1 3112 3146 DO i=ibeg, iend, 1 3113 DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 3114 #else 3115 DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 3147 !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 3148 DO k=1, nzsendp(ipatch,isend,1), 1 3149 #else 3150 !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 3151 DO k=1, nzsendp(ipatch,isend,1), 1 3116 3152 DO j=jbeg, jend, 1 3117 3153 DO i=ibeg, iend, 1 … … 3124 3160 3125 3161 npacked = nxsendp(ipatch,isend,1) * & 3126 nysendp(ipatch,isend,1) 3127 rstart = rstart + npacked*SIZE(list(ifield)%r3dptr, index_z) 3128 r3dcount = r3dcount + npacked*SIZE(list(ifield)%r3dptr, index_z) 3162 nysendp(ipatch,isend,1) * & 3163 nzsendp(ipatch,isend,1) 3164 rstart = rstart + npacked 3165 r3dcount = r3dcount + npacked 3166 3129 3167 END DO pack_patches3r 3130 3168 … … 3143 3181 DO j=jbeg, jend, 1 3144 3182 DO i=ibeg, iend, 1 3145 DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 3146 #else 3147 DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 3183 !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 3184 DO k=1, nzsendp(ipatch,isend,1), 1 3185 #else 3186 !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 3187 DO k=1, nzsendp(ipatch,isend,1), 1 3148 3188 DO j=jbeg, jend, 1 3149 3189 DO i=ibeg, iend, 1 … … 3155 3195 END DO 3156 3196 3157 istart = istart + nxs*nys*SIZE(list(ifield)%i3dptr, index_z) 3158 i3dcount = i3dcount + nxs*nys*SIZE(list(ifield)%i3dptr, index_z) 3197 npacked = nxsendp(ipatch,isend,1)* & 3198 nysendp(ipatch,isend,1)* & 3199 nzsendp(ipatch,isend,1) 3200 istart = istart + npacked 3201 i3dcount = i3dcount + npacked 3159 3202 END DO pack_patches3i 3160 3203 … … 3172 3215 ! Now do the send(s) for all fields 3173 3216 IF(r2dcount > 0 .OR. r3dcount > 0 )THEN 3174 CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount),MPI_DOUBLE_PRECISION, & 3175 destination(isend),tag,mpi_comm_opa, & 3217 CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount), & 3218 MPI_DOUBLE_PRECISION, & 3219 destination(isend),tag,mpi_comm_opa, & 3176 3220 exch_flags(handle,isend,indexs),ierr) 3177 3221 END IF … … 3228 3272 3229 3273 ! Increment starting index for next field data in buffer 3230 rstart = rstart + nrecvp(irecv,1)3274 rstart = ic + 1 !rstart + nrecvp(irecv,1) 3231 3275 3232 3276 ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN … … 3250 3294 3251 3295 ! Increment starting index for next field data in buffer 3252 istart = i start + nrecvp(irecv,1)3296 istart = ic + 1 !istart + nrecvp(irecv,1) 3253 3297 3254 3298 ELSE IF (ASSOCIATED(list(ifield)%r3dptr) ) THEN … … 3264 3308 DO j=jbeg, jend, 1 3265 3309 DO i=ibeg, iend, 1 3266 DO k=1, SIZE(list(ifield)%r3dptr, index_z), 13267 #else 3268 DO k=1, SIZE(list(ifield)%r3dptr, index_z), 13310 DO k=1, nzrecvp(ipatch,irecv,1), 1 3311 #else 3312 DO k=1, nzrecvp(ipatch,irecv,1), 1 3269 3313 DO j=jbeg, jend, 1 3270 3314 DO i=ibeg, iend, 1 … … 3278 3322 3279 3323 ! Increment starting index for next field data in buffer 3280 rstart = rstart + nrecvp(irecv,1)*SIZE(list(ifield)%r3dptr,index_z)3324 rstart = ic + 1 ! rstart + nrecvp(irecv,1) !*SIZE(list(ifield)%r3dptr,index_z) 3281 3325 3282 3326 ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN … … 3292 3336 DO j=jbeg, jend, 1 3293 3337 DO i=ibeg, iend, 1 3294 DO k=1, SIZE(list(ifield)%i3dptr,index_z),13295 #else 3296 DO k=1, SIZE(list(ifield)%i3dptr,index_z),13338 DO k=1,nzrecvp(ipatch,irecv,1),1 3339 #else 3340 DO k=1,nzrecvp(ipatch,irecv,1),1 3297 3341 DO j=jbeg, jend, 1 3298 3342 DO i=ibeg, iend, 1 … … 3306 3350 3307 3351 ! Increment starting index for next field data in buffer 3308 istart = i start + nrecvp(irecv,1)*SIZE(list(ifield)%i3dptr,index_z)3352 istart = ic + 1 !istart + nrecvp(irecv,1) !*SIZE(list(ifield)%i3dptr,index_z) 3309 3353 3310 3354 END IF … … 3395 3439 CALL free_exch_handle(handle) 3396 3440 3397 CALL prof_region_end(ARPEXCHS_LIST, iprofStat)3441 !CALL prof_region_end(ARPEXCHS_LIST, iprofStat) 3398 3442 3399 3443 END SUBROUTINE exchs_generic_list … … 3431 3475 ! ******************************************************************* 3432 3476 USE par_oce, ONLY: wp, jpreci, jprecj, jpni, jpkdta 3433 USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, & 3434 IminusJminus, IplusJminus, IminusJplus, & 3435 nrecv, nsend, nrecvp, nsendp, nxsend,nysend,& 3436 destination,dirsend, dirrecv, & 3437 isrcsend, jsrcsend, idesrecv, jdesrecv, & 3438 isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, & 3439 nxrecv,nyrecv,source, iesub, jesub, & 3440 MaxCommDir, MaxComm, idessend, jdessend, & 3441 nxsendp, nysendp, nxrecvp, nyrecvp, & 3442 npatchsend, npatchrecv, & 3443 cyclic_bc 3444 USE lib_mpp, ONLY: mpi_comm_opa, ctl_stop 3477 USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, & 3478 IminusJminus, IplusJminus, IminusJplus, & 3479 nrecv, nsend, nrecvp, nsendp, & 3480 nrecvp2d, nsendp2d, nxsend, nysend, & 3481 destination,dirsend, dirrecv, & 3482 isrcsend, jsrcsend, idesrecv, jdesrecv, & 3483 isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, & 3484 nxrecv,source, iesub, jesub, & 3485 MaxCommDir, MaxComm, idessend, jdessend, & 3486 nxsendp, nysendp, nzsendp, & 3487 nxrecvp, nyrecvp, nzrecvp, & 3488 npatchsend, npatchrecv, cyclic_bc 3489 USE lib_mpp, ONLY: ctl_stop 3490 #if defined key_mpp_mpi 3491 USE lib_mpp, ONLY: mpi_comm_opa 3492 #endif 3445 3493 USE dom_oce, ONLY: narea 3446 3494 USE in_out_manager, ONLY: numout … … 3474 3522 INTEGER :: index ! To hold index returned from MPI_waitany 3475 3523 INTEGER, DIMENSION(3) :: isubsizes, istarts ! isizes 3524 #if defined key_mpp_mpi 3476 3525 INTEGER :: status(MPI_status_size) 3477 3526 INTEGER :: astatus(MPI_status_size,MaxComm) 3527 #endif 3478 3528 LOGICAL, SAVE :: first_time = .TRUE. 3479 3529 #if defined key_z_first … … 3489 3539 3490 3540 !CALL prof_region_begin(ARPEXCHS_GENERIC, "Exchs_indiv", iprofStat) 3491 !CALL timing_start('exchs_generic')3541 !CALL timing_start('exchs_generic') 3492 3542 3493 3543 ierr = 0 3494 3544 3495 ! Find out the sizes of the arrays.3496 3497 kdim1 = 13498 IF ( PRESENT(b3) ) THEN3499 kdim1 = SIZE(b3,dim=index_z)3500 ELSEIF ( PRESENT(ib3) ) THEN3501 kdim1 = SIZE(ib3,dim=index_z)3502 ELSEIF ( PRESENT(b2) ) THEN3503 kdim1 = SIZE(b2,dim=2)3504 ELSEIF ( PRESENT(ib2) ) THEN3505 kdim1 = SIZE(ib2,dim=2)3506 ENDIF3507 3508 3545 ! Check nhexch is in range. 3509 3546 3510 3547 IF ( nhexch.GT.jpreci ) THEN 3511 STOP 'exchs: halo width greater than maximum'3548 CALL ctl_stop('STOP','exchs: halo width greater than maximum') 3512 3549 ENDIF 3513 3550 … … 3544 3581 IF(.NOT. ALLOCATED(sendBuff))THEN 3545 3582 ! Only allocate the sendBuff once 3546 ALLOCATE(recvBuff( jpkdta*maxrecvpts,nrecv), &3547 sendBuff( jpkdta*maxsendpts,nsend),stat=ierr)3583 ALLOCATE(recvBuff(maxrecvpts,nrecv), & 3584 sendBuff(maxsendpts,nsend),stat=ierr) 3548 3585 ELSE 3549 ALLOCATE(recvBuff( jpkdta*maxrecvpts,nrecv),stat=ierr)3586 ALLOCATE(recvBuff(maxrecvpts,nrecv),stat=ierr) 3550 3587 END IF 3551 3588 ELSE IF(PRESENT(ib2) .OR. PRESENT(ib3))THEN 3552 3589 IF(.NOT. ALLOCATED(sendIBuff))THEN 3553 ALLOCATE(recvIBuff( jpkdta*maxrecvpts,nrecv), &3554 sendIBuff( jpkdta*maxsendpts,nsend),stat=ierr)3590 ALLOCATE(recvIBuff(maxrecvpts,nrecv), & 3591 sendIBuff(maxsendpts,nsend),stat=ierr) 3555 3592 ELSE 3556 ALLOCATE(recvIBuff( jpkdta*maxrecvpts,nrecv),stat=ierr)3593 ALLOCATE(recvIBuff(maxrecvpts,nrecv),stat=ierr) 3557 3594 END IF 3558 3595 END IF … … 3578 3615 ! that isn't used 3579 3616 IF ( PRESENT(b2) ) THEN 3580 CALL MPI_irecv (recvBuff(1,irecv),nrecvp (irecv,1),&3617 CALL MPI_irecv (recvBuff(1,irecv),nrecvp2d(irecv,1), & 3581 3618 MPI_DOUBLE_PRECISION, source(irecv), & 3582 3619 tag, mpi_comm_opa, & 3583 3620 exch_flags(handle,irecv,indexr), ierr) 3584 3621 ELSEIF ( PRESENT(ib2) ) THEN 3622 CALL MPI_irecv (recvIBuff(1,irecv),nrecvp2d(irecv,1), & 3623 MPI_INTEGER, source(irecv), & 3624 tag, mpi_comm_opa, & 3625 exch_flags(handle,irecv,indexr),ierr) 3626 ELSEIF ( PRESENT(b3) ) THEN 3627 CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1), & 3628 MPI_DOUBLE_PRECISION, source(irecv), & 3629 tag, mpi_comm_opa, & 3630 exch_flags(handle,irecv,indexr),ierr) 3631 ELSEIF ( PRESENT(ib3) ) THEN 3585 3632 CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1), & 3586 3633 MPI_INTEGER, source(irecv), & 3587 3634 tag, mpi_comm_opa, & 3588 3635 exch_flags(handle,irecv,indexr),ierr) 3589 ELSEIF ( PRESENT(b3) ) THEN3590 CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1)*kdim1, &3591 MPI_DOUBLE_PRECISION, source(irecv), &3592 tag, mpi_comm_opa, &3593 exch_flags(handle,irecv,indexr),ierr)3594 ELSEIF ( PRESENT(ib3) ) THEN3595 CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1)*kdim1, &3596 MPI_INTEGER, source(irecv), &3597 tag, mpi_comm_opa, &3598 exch_flags(handle,irecv,indexr),ierr)3599 3636 ENDIF 3600 IF ( ierr.NE.0 ) THEN 3601 WRITE (numout,*) 'ARPDBG - irecv hit error' 3602 CALL flush(numout) 3603 CALL MPI_abort(mpi_comm_opa,1,ierr) 3604 END IF 3637 ! No point checking for MPI errors because default MPI error handler 3638 ! aborts run without returning control to calling program. 3639 !IF ( ierr.NE.0 ) THEN 3640 ! WRITE (numout,*) 'ARPDBG - irecv hit error' 3641 ! CALL flush(numout) 3642 ! CALL MPI_abort(mpi_comm_opa,1,ierr) 3643 !END IF 3605 3644 3606 3645 #if defined DEBUG_COMMS 3607 3646 WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' src = ',I3,' tag = ',I4,' npoints = ',I6)") & 3608 3647 narea-1,handle,dirrecv(irecv), & 3609 source(irecv), tag, nrecvp(irecv,1) *kdim13648 source(irecv), tag, nrecvp(irecv,1) 3610 3649 #endif 3611 3650 … … 3635 3674 3636 3675 IF ( enabled(dirsend(isend)) .AND. & 3637 destination(isend) .GE.0 .AND. nxsend(isend).GT.0 ) THEN3676 destination(isend) >= 0 .AND. nxsend(isend) > 0 ) THEN 3638 3677 3639 3678 isrc = isrcsend(isend) … … 3647 3686 IF(PRESENT(b3))THEN 3648 3687 WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & 3649 narea-1, handle, tag, destination(isend),nsendp(isend,1) *kdim1,dirsend(isend)3688 narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend) 3650 3689 ELSE IF(PRESENT(b2))THEN 3651 3690 WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & 3652 narea-1, handle, tag, destination(isend),nsendp (isend,1),dirsend(isend)3691 narea-1, handle, tag, destination(isend),nsendp2d(isend,1),dirsend(isend) 3653 3692 END IF 3654 3693 #endif … … 3673 3712 END DO 3674 3713 3714 !!$ ! For 'stupid' compiler that refuses to do a memcpy for above 3675 3715 !!$ CALL do_real8_copy( nxsendp(patch,isend,1)*nysendp(patch,isend,1), & 3676 3716 !!$ b2(istart,jstart), & … … 3709 3749 ELSEIF ( PRESENT(b3) )THEN 3710 3750 3711 !CALL timing_start('3dr_pack')3751 ! CALL timing_start('3dr_pack') 3712 3752 ic = 0 3713 3753 pack_patches3r: DO ipatch=1,npatchsend(isend,1) … … 3720 3760 DO j=jstart, jend, 1 3721 3761 DO i=istart, iend, 1 3722 DO k=1, kdim1,13723 #else 3724 DO k=1, kdim1,13762 DO k=1,nzsendp(ipatch,isend,1),1 3763 #else 3764 DO k=1,nzsendp(ipatch,isend,1),1 3725 3765 DO j=jstart, jend, 1 3726 3766 DO i=istart, iend, 1 … … 3732 3772 END DO 3733 3773 END DO pack_patches3r 3734 ! CALL timing_stop('3dr_pack') 3774 3775 ! CALL timing_stop('3dr_pack') 3735 3776 3736 3777 CALL MPI_Isend(sendBuff(1,isend),ic, & … … 3740 3781 3741 3782 #if defined DEBUG_COMMS 3742 WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &3783 WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") & 3743 3784 narea-1, npatchsend(isend,1),ic, & 3744 3785 destination(isend) … … 3756 3797 DO j=jstart, jend, 1 3757 3798 DO i=istart, iend, 1 3758 DO k=1, kdim1,13759 #else 3760 DO k=1, kdim1,13799 DO k=1,nzsendp(ipatch,isend,1),1 3800 #else 3801 DO k=1,nzsendp(ipatch,isend,1),1 3761 3802 DO j=jstart, jend, 1 3762 3803 DO i=istart, iend, 1 … … 3775 3816 ENDIF 3776 3817 3777 IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)3818 !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) 3778 3819 3779 3820 ELSE … … 3785 3826 ENDDO ! Loop over sends 3786 3827 3787 !CALL timing_stop('mpi_sends')3828 ! CALL timing_stop('mpi_sends') 3788 3829 3789 3830 #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS … … 3793 3834 ! Wait on the receives that were posted earlier 3794 3835 3795 !CALL timing_start('mpi_recvs')3836 ! CALL timing_start('mpi_recvs') 3796 3837 3797 3838 ! Copy just the set of flags we're interested in for passing … … 3814 3855 WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1 3815 3856 END IF 3816 CALL ctl_stop('STOP' )3857 CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error') 3817 3858 END IF 3818 3859 … … 3821 3862 IF ( PRESENT(b2) ) THEN 3822 3863 3823 !CALL timing_start('2dr_unpack')3864 ! CALL timing_start('2dr_unpack') 3824 3865 3825 3866 ! Copy received data back into array … … 3839 3880 END DO unpack_patches2r 3840 3881 3841 !CALL timing_stop('2dr_unpack')3882 ! CALL timing_stop('2dr_unpack') 3842 3883 3843 3884 ELSE IF ( PRESENT(ib2) ) THEN … … 3861 3902 ELSE IF (PRESENT(b3) ) THEN 3862 3903 3863 !CALL timing_start('3dr_unpack')3904 ! CALL timing_start('3dr_unpack') 3864 3905 ic = 0 3865 3906 unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch) … … 3872 3913 DO j=jstart, jend, 1 3873 3914 DO i=istart, iend, 1 3874 DO k=1, kdim1,13875 #else 3876 DO k=1, kdim1,13915 DO k=1,nzrecvp(ipatch,irecv,1),1 3916 #else 3917 DO k=1,nzrecvp(ipatch,irecv,1),1 3877 3918 DO j=jstart, jend, 1 3878 3919 DO i=istart, iend, 1 … … 3881 3922 b3(i,j,k) = recvBuff(ic,irecv) 3882 3923 END DO 3924 #if defined key_z_first 3925 ! ARPDBG - wipe anything below the ocean bottom 3926 DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1 3927 b3(i,j,k) = 0.0_wp 3928 END DO 3929 #endif 3883 3930 END DO 3884 3931 END DO 3932 3933 ! ARPDBG - wipe anything below the ocean bottom 3934 #if ! defined key_z_first 3935 DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1 3936 DO j=jstart, jend, 1 3937 DO i=istart, iend, 1 3938 b3(i,j,k) = 0.0_wp 3939 END DO 3940 END DO 3941 END DO 3942 #endif 3943 3885 3944 END DO unpack_patches3r 3886 3945 … … 3899 3958 DO j=jstart, jend, 1 3900 3959 DO i=istart, iend, 1 3901 DO k=1, kdim1,13902 #else 3903 DO k=1, kdim1,13960 DO k=1,nzrecvp(ipatch,irecv,1),1 3961 #else 3962 DO k=1,nzrecvp(ipatch,irecv,1),1 3904 3963 DO j=jstart, jend, 1 3905 3964 DO i=istart, iend, 1 … … 3915 3974 3916 3975 CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr) 3917 IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)3976 !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) 3918 3977 3919 3978 END DO ! while irecv != MPI_UNDEFINED 3920 3979 3921 !CALL timing_stop('mpi_recvs')3980 ! CALL timing_stop('mpi_recvs') 3922 3981 3923 3982 ! All receives done and unpacked so can deallocate the associated 3924 3983 ! buffers 3925 IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)3926 IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)3984 !IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff) 3985 !IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff) 3927 3986 3928 3987 #if defined DEBUG_COMMS … … 3940 3999 ! loop! 3941 4000 IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN 4001 4002 ! Find out the sizes of the arrays. 4003 kdim1 = 1 4004 IF ( PRESENT(b3) ) THEN 4005 kdim1 = SIZE(b3,dim=index_z) 4006 ELSEIF ( PRESENT(ib3) ) THEN 4007 kdim1 = SIZE(ib3,dim=index_z) 4008 ENDIF 4009 3942 4010 3943 4011 IF ( enabled(Iplus) ) THEN … … 3996 4064 ENDIF 3997 4065 3998 ENDIF 4066 ENDIF ! cyclic_bc .AND. jpni == 1 3999 4067 4000 4068 ! Copy just the set of flags we're interested in for passing to … … 4009 4077 IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff) 4010 4078 4011 !CALL timing_stop('exchs_generic')4079 ! CALL timing_stop('exchs_generic') 4012 4080 !CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat) 4013 4081 … … 4313 4381 CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat) 4314 4382 4383 #if defined key_mpp_mpi 4384 4315 4385 ! If we get into this routine it's because : North fold condition and mpp 4316 4386 ! with more than one PE across i : we deal only with the North condition 4317 4387 4318 4388 ! Set no. of rows from a module parameter that is also used in exchtestmod 4389 ! and mpp_ini_north 4319 4390 ijpj = num_nfold_rows 4320 4391 … … 5244 5315 CALL prof_region_end(NORTHLISTSCATTER, iprofStat) 5245 5316 5317 #endif /* key_mpp_mpi */ 5318 5246 5319 CALL prof_region_end(ARPNORTHLISTCOMMS, iprofStat) 5247 5320 … … 5255 5328 !! 5256 5329 !! ** Purpose : 5257 !! Ensure proper north fold horizontal bondary condition in mpp configuration5258 !! in case of jpn1 > 1 (for 2d array )5330 !! Ensure proper north fold horizontal bondary condition in mpp 5331 !! configuration in case of jpn1 > 1 (for 2d array ) 5259 5332 !! 5260 5333 !! ** Method : … … 5266 5339 !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north 5267 5340 !! from lbc routine 5268 !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk 5341 !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding 5342 !! rules of lbc_lnk 5269 5343 !!---------------------------------------------------------------------- 5270 5344 USE par_oce, ONLY : jpni, jpi, jpj … … 5273 5347 USE mapcomm_mod, ONLY : pielb, piesub 5274 5348 USE lib_mpp, ONLY : ctl_stop 5349 USE arpdebugging, ONLY: dump_array 5275 5350 IMPLICIT none 5276 5351 !! * Arguments … … 5287 5362 !! * Local declarations 5288 5363 5289 INTEGER , PARAMETER :: ijpj = 45364 INTEGER :: ijpj 5290 5365 INTEGER :: ji, jj, jr, jproc 5291 5366 INTEGER :: ierr … … 5303 5378 ! with more than one PE across i : we deal only with the North condition 5304 5379 5380 ! Set local from public PARAMETER 5381 ijpj = num_nfold_rows 5382 5305 5383 CALL prof_region_begin(ARPNORTHCOMMS2D, "North2D", iprofStat) 5306 5384 5385 #if defined key_mpp_mpi 5386 5307 5387 IF(.not. ALLOCATED(ztab2))THEN 5308 5388 5309 ALLOCATE(ztab2(jpiglo, 4), &5310 znorthgloio2(nwidthmax, 4,jpni), &5311 znorthloc2(nwidthmax, 4), &5389 ALLOCATE(ztab2(jpiglo,ijpj), & 5390 znorthgloio2(nwidthmax,ijpj,ndim_rank_north), & 5391 znorthloc2(nwidthmax,ijpj), & 5312 5392 STAT=ierr) 5313 5393 IF(ierr .ne. 0)THEN … … 5321 5401 ijpjm1=ijpj-1 5322 5402 5323 ! put the last 4jlines of pt2d into znorthloc25403 ! put the last ijpj jlines of pt2d into znorthloc2 5324 5404 znorthloc2(:,:) = 0_wp ! because of padding for nwidthmax 5325 DO ij = 1, ijpj, 1 5405 5406 ! jeub is the upper j limit of current domain in global coords 5407 ! 5408 ! |======================= jpjglo ^ 5409 ! <Trimmed> | /|\ 5410 ! |----------------------- jpjglo-1 | 5411 ! | | 5412 ! |---------jeub-------------------------------- 5413 ! | | j 5414 ! |-------------------------------------------- 5415 ! | | | 5416 ! |-------------------------------------------- | 5417 ! 5418 ! No. of trimmed rows = jpjglo - jeub 5419 ! No. of valid rows for n-fold = ijpj - <no. trimmed rows> 5420 ! = ijpj - jpjglo + jeub 5421 ! Need an iterator that ends with max value ijpj and has (ijpj-jpjglo+jeub) 5422 ! distinct values so start point must be: 5423 ! ij_start = ijpj - (ijpj-jpjglo+jeub) + 1 = jpjglo - jeub + 1 5424 ! => if jeub == jpjglo then we recover a starting value of 1. 5425 ! if jeub == jpjglo - 10 then ij_start = 11 so no loop iterations 5426 ! will be performed. 5427 5428 #if defined NO_NFOLD_GATHER 5429 ! Post receives for other PE's north-fold data 5430 DO iproc = 1, ndim_rank_north, 1 5431 5432 IF( iproc-1 == nrank_north(iproc) ) CYCLE ! Skip this PE 5433 5434 CALL MPI_IRecv(znorthgloio2(), north_pts(iproc), MPI_DOUBLE_PRECISION, & 5435 nrank_north(iproc), iproc, tag, ncomm_north, & 5436 nexch_flag(iproc) ) 5437 END DO 5438 #endif 5439 5440 DO ij = jpjglo - jeub + 1, ijpj, 1 5441 5326 5442 jj = nlcj - ijpj + ij 5327 5443 znorthloc2(nldi:nlei,ij)=pt2d(nldi:nlei,jj) 5328 5444 END DO 5445 5446 ! CALL dump_array(0,'znorthloc2',znorthloc2,withHalos=.TRUE.,toGlobal=.FALSE.) 5329 5447 5330 5448 IF (npolj /= 0 ) THEN … … 5335 5453 znorthgloio2,itaille,MPI_DOUBLE_PRECISION, & 5336 5454 0, ncomm_north, ierr) 5455 5337 5456 ENDIF 5338 5457 5339 5458 IF (narea == north_root+1 ) THEN 5340 5459 ! recover the global north array 5460 ! ztab2 has full width of global domain 5341 5461 ztab2(:,:) = 0_wp 5342 5462 … … 5350 5470 END DO 5351 5471 5472 ! CALL dump_array(0,'ztab2',ztab2,withHalos=.TRUE.,toGlobal=.FALSE.) 5352 5473 5353 5474 ! 2. North-Fold boundary conditions … … 5495 5616 ENDIF 5496 5617 5497 ! put in the last ijpj jlines of pt2d znorthloc2 5498 DO ij = 1, ijpj, 1 5618 ! Put the last ijpj jlines of pt2d into znorthloc2 while allowing 5619 ! for any trimming of domain (see earlier comments and diagram) 5620 DO ij = jpjglo - jeub + 1, ijpj, 1 5499 5621 jj = nlcj - ijpj + ij 5500 5622 pt2d(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij) 5501 5623 END DO 5624 5625 #endif /* key_mpp_mpi */ 5502 5626 5503 5627 CALL prof_region_end(ARPNORTHCOMMS2D, iprofStat) … … 5512 5636 !! 5513 5637 !! ** Purpose : 5514 !! Ensure proper north fold horizontal bondary condition in mpp configuration5515 !! in case of jpn1 > 1 (for 2d array )5638 !! Ensure proper north fold horizontal bondary condition in mpp 5639 !! configuration in case of jpn1 > 1 (for 2d array ) 5516 5640 !! 5517 5641 !! ** Method : … … 5545 5669 !! * Local declarations 5546 5670 5547 INTEGER , PARAMETER :: ijpj = 45671 INTEGER :: ijpj 5548 5672 INTEGER :: ji, jj, jr, jproc 5549 5673 INTEGER :: ierr … … 5561 5685 ! with more than one PE across i : we deal only with the North condition 5562 5686 5687 #if defined key_mpp_mpi 5688 5689 ijpj = num_nfold_rows 5690 ijpjm1=ijpj - 1 5691 5692 5563 5693 IF(.not. ALLOCATED(ztab2))THEN 5564 5694 5565 ALLOCATE(ztab2(jpiglo, 4), &5566 znorthgloio2(nwidthmax, 4,jpni), &5567 znorthloc2(nwidthmax, 4), &5695 ALLOCATE(ztab2(jpiglo,ijpj), & 5696 znorthgloio2(nwidthmax,ijpj,jpni), & 5697 znorthloc2(nwidthmax,ijpj), & 5568 5698 STAT=ierr) 5569 5699 IF(ierr .ne. 0)THEN … … 5575 5705 ! --------------- 5576 5706 5577 ijpjm1=ijpj - 15578 5579 ! put in znorthloc2 the last 4 jlines of ib25707 ! Put the last ijpj jlines of ib2 into znorthloc2 while allowing 5708 ! for any trimming of domain (see earlier comments and diagram in 5709 ! mpp_lbc_north_2d). 5580 5710 znorthloc2(:,:) = 0 ! because of padding for nwidthmax 5581 DO ij = 1, ijpj, 15711 DO ij = jpjglo - jeub + 1, ijpj, 1 5582 5712 jj = nlcj - ijpj + ij 5583 5713 znorthloc2(nldi:nlei,ij)=ib2(nldi:nlei,jj) … … 5602 5732 ilei=nleit (jproc) 5603 5733 iilb=pielb(jproc) 5604 WRITE (*,*)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',ildi, ilei, iilb, ijpj 5734 !WRITE (*,*)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',& 5735 ! ildi, ilei, iilb, ijpj 5605 5736 ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) = & 5606 5737 znorthgloio2(ildi:ilei,1:ijpj,jr) … … 5740 5871 ilei=nleit (jproc) 5741 5872 iilb=pielb(jproc) 5742 znorthgloio2(ildi:ilei,1:ijpj,jr)=ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) 5873 znorthgloio2(ildi:ilei,1:ijpj,jr) = & 5874 ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) 5743 5875 END DO 5744 5876 … … 5752 5884 ENDIF 5753 5885 5754 ! put in the last ijpj jlines of ib2 znorthloc2 5755 DO ij = 1, ijpj, 1 5886 ! put in the last ijpj jlines of ib2 from znorthloc2 while allowing 5887 ! for any trimming of domain (see earlier comments and diagram in 5888 ! mpp_lbc_north_2d). 5889 DO ij = jpjglo - jeub + 1, ijpj, 1 5756 5890 jj = nlcj - ijpj + ij 5757 5891 ib2(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij) 5758 5892 END DO 5759 5893 WRITE(*,*) 'ARPDBG: finished in mpp_lbc_north_i2d' 5894 5895 #endif /* key_mpp_mpi */ 5896 5760 5897 END SUBROUTINE mpp_lbc_north_i2d 5761 5898 … … 5797 5934 5798 5935 !! * Local declarations 5799 INTEGER , PARAMETER :: ijpj = 45936 INTEGER :: ijpj 5800 5937 INTEGER :: ji, jj, jk, jr, jproc 5801 5938 INTEGER :: ierr … … 5814 5951 ! mpp with more than one proc across i : we deal only with the North 5815 5952 ! condition 5953 #if defined key_mpp_mpi 5954 5955 ijpj = num_nfold_rows 5956 ijpjm1=ijpj - 1 5816 5957 5817 5958 IF(.not. ALLOCATED(ztab))THEN 5818 5959 5819 ALLOCATE(ztab(jpiglo, 4,jpk), &5820 znorthgloio(nwidthmax, 4,jpk,jpni), &5821 znorthloc(nwidthmax, 4,jpk), &5960 ALLOCATE(ztab(jpiglo,ijpj,jpk), & 5961 znorthgloio(nwidthmax,ijpj,jpk,jpni), & 5962 znorthloc(nwidthmax,ijpj,jpk), & 5822 5963 STAT=ierr) 5823 5964 IF(ierr .ne. 0)THEN … … 5835 5976 ! --------------- 5836 5977 5837 ijpjm1=ijpj - 1 5838 5839 ! Put the last ijpj jlines of pt3d into znorthloc 5840 !ARPDBG znorthloc(:,:,:) = 999_wp ! because of padding for nwidthmax - 999 is 5841 ! for debugging 5842 #if defined key_z_first 5843 DO ij = 1, ijpj, 1 5978 ! Put the last ijpj jlines of pt3d into znorthloc while allowing 5979 ! for any trimming of domain (see earlier comments and diagram in 5980 ! mpp_lbc_north_2d). 5981 ! Have to initialise all to zero in case chunks are missing due to domain 5982 ! trimming 5983 znorthloc(:,:,:) = 0.0_wp 5984 #if defined key_z_first 5985 DO ij = jpjglo - jeub + 1, ijpj, 1 5844 5986 jj = nlcj - ijpj + ij 5845 5987 DO jk = 1, jpk 5846 5988 #else 5847 5989 DO jk = 1, jpk 5848 DO ij = 1, ijpj, 15990 DO ij = jpjglo - jeub + 1, ijpj, 1 5849 5991 jj = nlcj - ijpj + ij 5850 5992 #endif … … 5856 5998 IF (npolj /= 0 ) THEN 5857 5999 ! Build in proc 0 of ncomm_north the znorthgloio 5858 !ARPDBG znorthgloio(:,:,:,:) = 0_wp5859 6000 5860 6001 #ifdef key_mpp_shmem … … 5875 6016 IF (narea == north_root+1 ) THEN 5876 6017 ! recover the global north array 5877 !ARPDBGztab(:,:,:) = 0_wp6018 ztab(:,:,:) = 0_wp 5878 6019 5879 6020 DO jr = 1, ndim_rank_north … … 5890 6031 ! =============== 5891 6032 #if defined key_z_first 5892 5893 6033 5894 6034 ! 2. North-Fold boundary conditions … … 6179 6319 #endif 6180 6320 6181 ! put in the last ijpj jlines of pt3d znorthloc 6182 #if defined key_z_first 6183 DO ij = 1, ijpj, 1 6321 ! put in the last ijpj jlines of pt3d znorthloc while allowing 6322 ! for any trimming of domain (see earlier comments and diagram in 6323 ! mpp_lbc_north_2d). 6324 #if defined key_z_first 6325 DO ij = jpjglo - jeub + 1, ijpj, 1 6184 6326 jj = nlcj - ijpj + ij 6185 6327 DO jk = 1 , jpk 6186 6328 #else 6187 6329 DO jk = 1 , jpk 6188 DO ij = 1, ijpj, 16330 DO ij = jpjglo - jeub + 1, ijpj, 1 6189 6331 jj = nlcj - ijpj + ij 6190 6332 #endif … … 6194 6336 6195 6337 CALL prof_region_end(NORTH3DSCATTER, iprofStat) 6338 6339 #endif /* key_mpp_mpi */ 6196 6340 6197 6341 END SUBROUTINE mpp_lbc_north_3d … … 6235 6379 6236 6380 !! * Local declarations 6237 INTEGER , PARAMETER :: ijpj = 46238 INTEGER , PARAMETER :: ijpjm1 = ijpj -16381 INTEGER :: ijpj 6382 INTEGER :: ijpjm1 6239 6383 INTEGER :: ii, ji, jj, jk, jr, jproc 6240 6384 INTEGER :: ierr … … 6254 6398 ! mpp with more than one proc across i : we deal only with the North 6255 6399 ! condition 6400 6401 ijpj = num_nfold_rows 6402 ijpjm1 = ijpj - 1 6256 6403 6257 6404 IF(.not. ALLOCATED(ztab))THEN … … 6269 6416 ! --------------- 6270 6417 6271 ! put in znorthloc the last ijpj jlines of pt3d 6272 znorthloc(:,:,:) = 0 ! because of padding for nwidthmax 6273 #if defined key_z_first 6274 DO ij = 1, ijpj, 1 6418 ! put in znorthloc the last ijpj jlines of pt3d while allowing 6419 ! for any trimming of domain (see earlier comments and diagram in 6420 ! mpp_lbc_north_2d). 6421 znorthloc(:,:,:) = 0 ! because of padding for nwidthmax and domain 6422 ! trimming 6423 #if defined key_z_first 6424 DO ij = jpjglo - jeub + 1, ijpj, 1 6275 6425 jj = nlcj - ijpj + ij 6276 6426 DO jk = 1, jpk 6277 6427 #else 6278 6428 DO jk = 1, jpk 6279 DO ij = 1, ijpj, 16429 DO ij = jpjglo - jeub + 1, ijpj, 1 6280 6430 jj = nlcj - ijpj + ij 6281 6431 #endif … … 6608 6758 #endif 6609 6759 6610 ! put in the last ijpj jlines of pt3d znorthloc 6611 #if defined key_z_first 6612 DO ij = 1, ijpj, 1 6760 ! put in the last ijpj jlines of pt3d znorthloc while allowing 6761 ! for any trimming of domain (see earlier comments and diagram in 6762 ! mpp_lbc_north_2d). 6763 #if defined key_z_first 6764 DO ij = jpjglo - jeub + 1, ijpj, 1 6613 6765 jj = nlcj - ijpj + ij 6614 6766 DO ii = nldi, nlei, 1 … … 6616 6768 #else 6617 6769 DO jk = 1 , jpk 6618 DO ij = 1, ijpj, 16770 DO ij = jpjglo - jeub + 1, ijpj, 1 6619 6771 jj = nlcj - ijpj + ij 6620 6772 DO ii = nldi, nlei, 1 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/exchtestmod.F90
r3432 r3837 7 7 ! once these tests are complete 8 8 #if defined key_mpp_rkpart 9 compare_exch_methods= . TRUE., & ! Do both packed and10 do_integer_tests = .FALSE., & ! indiv. exchanges and compare output11 do_real_tests = .TRUE. , &12 do_integer_timings = .FALSE., &13 do_real_timings = . TRUE., &14 use_exch_list = . TRUE. ! Whether to use the halo9 compare_exch_methods= .FALSE., & ! Do both packed and 10 do_integer_tests = .FALSE., & ! indiv. exchanges and compare output 11 do_real_tests = .TRUE. , & 12 do_integer_timings = .FALSE., & 13 do_real_timings = .FALSE., & 14 use_exch_list = .FALSE. ! Whether to use the halo 15 15 ! packing API for the tests 16 16 ! - NOT currently working! 17 17 #else 18 compare_exch_methods= .FALSE., & ! Do both packed and 19 do_integer_tests = .FALSE., & ! indiv. exchanges and compare output 18 compare_exch_methods= .FALSE., & 19 ! WARNING: test code not supported for non rkpart build! 20 do_integer_tests = .FALSE., & 20 21 do_real_tests = .FALSE., & 21 22 do_integer_timings = .FALSE., & 22 do_real_timings = . TRUE.,&23 do_real_timings = .FALSE., & 23 24 use_exch_list = .FALSE. ! Whether to use the halo 24 25 ! packing API for the tests … … 42 43 INTEGER, DIMENSION(:,:), ALLOCATABLE, TARGET :: i2d, i2d_2 43 44 45 ! Last ocean level above ocean floor 46 INTEGER, DIMENSION(:,:), POINTER :: pmaxdepth 47 44 48 ! Unit to use for outputting log of results 45 49 INTEGER, PARAMETER :: LOG_UNIT = 1002 … … 62 66 !==================================================================== 63 67 64 SUBROUTINE mpp_test_comms(depth )68 SUBROUTINE mpp_test_comms(depth, lmaxdepth) 65 69 USE par_oce, ONLY: jpi, jpj, jpk, jpreci 66 70 USE par_kind, ONLY: wp 67 71 USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE 68 USE lib_mpp, ONLY: mpi_comm_opa, ctl_stop72 USE lib_mpp, ONLY: ctl_stop, ctl_warn 69 73 USE dom_oce, ONLY: narea 70 USE arpdebugging, Only: dump_array71 74 USE exchmod, ONLY: add_exch, bound_exch_list, bound_exch 72 75 USE timing, ONLY: timing_finalize 73 76 USE profile 77 #if defined key_mpp_mpi 78 USE lib_mpp, ONLY: mpi_comm_opa 74 79 USE mpi 80 #endif 75 81 IMPLICIT none 76 82 ! Routine arguments 77 INTEGER, DIMENSION(:,:) :: depth ! Mask (1 for ocean, 0 for land) 83 INTEGER, DIMENSION(:,:), INTENT(in) :: depth ! Mask (1 for ocean, 0 for land) 84 INTEGER, DIMENSION(:,:), TARGET :: lmaxdepth ! Last level above ocean floor 78 85 ! Local vars 79 86 INTEGER :: ierr 80 87 CHARACTER(len=256) :: name 81 88 89 #if ! defined key_mpp_mpi 90 CALL ctl_warn('mpp_test_comms: not built with MPI so nothing to do!') 91 RETURN 92 #endif 93 82 94 CALL prof_tracing_on() 83 95 … … 87 99 ALLOCATE(r3d(jpi,jpj,jpk), r3d_2(jpi,jpj,jpk), r3d_3(jpi,jpj,jpk), & 88 100 r2d(jpi,jpj), r2d_2(jpi,jpj), Stat=ierr) 101 102 ! Set module member variable to point to max-depth data so we can access it 103 ! when checking results of halo swaps. 104 pmaxdepth => lmaxdepth 89 105 90 106 IF(ierr .ne. 0)THEN … … 135 151 IF(narea == 1) WRITE (*,*) 'Test 3 done.' 136 152 137 ! 4. Test halo exchanges for a 3D REAL array at 'T' point... 153 ! 4. Test halo exchanges for a 2D REAL array at 'T' point... 154 155 name = '2D REAL array at T point' 156 CALL exch_test(name, 'T', GLOBAL_LOCN_TEST, depth, r2d1=r2d, & 157 isgn=1, lfill=.FALSE.) 158 159 IF(narea == 1) WRITE (*,*) 'Test 4 done.' 160 161 162 ! 5. Test halo exchanges for a 3D REAL array at 'T' point... 138 163 139 164 name = '3D REAL array at T point' … … 144 169 CALL exch_test(name, 'T', GLOBAL_LOCN_TEST, depth, r3d1=r3d) 145 170 146 IF(narea == 1) WRITE (*,*) 'Test 4done.'147 148 ! 5. Test halo exchanges for a 3D REAL array at 'V' point...171 IF(narea == 1) WRITE (*,*) 'Test 5 done.' 172 173 ! 6. Test halo exchanges for a 3D REAL array at 'V' point... 149 174 150 175 name = '3D REAL array at V point' … … 152 177 isgn=-999, lfill=.TRUE.) 153 178 154 IF(narea == 1) WRITE (*,*) 'Test 5done.'155 156 ! 6. Test halo exchanges for _two_ 2D REAL arrays at 'V' point...179 IF(narea == 1) WRITE (*,*) 'Test 6 done.' 180 181 ! 7. Test halo exchanges for _two_ 2D REAL arrays at 'V' point... 157 182 158 183 name = 'Two 2D REAL arrays at V point' … … 160 185 isgn=-999, lfill=.TRUE.) 161 186 162 IF(narea == 1) WRITE (*,*) 'Test 6done.'163 164 ! 7. Test halo exchanges for _two_ 3D REAL arrays at 'V' point...187 IF(narea == 1) WRITE (*,*) 'Test 7 done.' 188 189 ! 8. Test halo exchanges for _two_ 3D REAL arrays at 'V' point... 165 190 166 191 name = 'Two 3D REAL arrays at V point' … … 168 193 isgn=-999, lfill=.TRUE.) 169 194 170 IF(narea == 1) WRITE (*,*) 'Test 7done.'171 172 ! 8. Test halo exchanges for _three_ 3D REAL arrays at 'T' point...195 IF(narea == 1) WRITE (*,*) 'Test 8 done.' 196 197 ! 9. Test halo exchanges for _three_ 3D REAL arrays at 'T' point... 173 198 174 199 name = 'Three 3D REAL arrays at T point' … … 177 202 isgn=-999, lfill=.TRUE.) 178 203 179 IF(narea == 1) WRITE (*,*) 'Test 8done.'204 IF(narea == 1) WRITE (*,*) 'Test 9 done.' 180 205 181 206 END IF … … 302 327 DEALLOCATE(i3d, i3d_2, i2d, i2d_2) 303 328 329 #if defined key_mpp_mpi 304 330 ! Check for success or otherwise of tests on all PEs 305 331 CALL mpi_allreduce(MPI_IN_PLACE, test_failed, 1, MPI_LOGICAL, MPI_LOR, & 306 332 mpi_comm_opa, ierr ) 333 #endif 307 334 308 335 IF(stop_after_testing .OR. test_failed )THEN … … 316 343 ! Generate a timing report 317 344 CALL timing_finalize() 318 ! Dirty way of killing NEMO345 ! Dirty way of causing NEMO to stop immediately 319 346 CALL ctl_stop('STOP', 'Stopping now that comms tests are complete') 320 347 END IF … … 331 358 USE exchmod, ONLY: add_exch, bound_exch_list, bound_exch 332 359 USE lbclnk, ONLY: lbc_lnk 333 USE arpdebugging, ONLY: dump_array360 USE lib_mpp, ONLY: ctl_warn 334 361 USE dom_oce, ONLY: narea 335 362 IMPLICIT none … … 360 387 !!----------------------------------------------------------------------- 361 388 389 #if ! defined key_mpp_rkpart 390 CALL ctl_warn('exch_test: halo exchange testing not supported for build without key_mpp_rkpart defined') 391 RETURN 392 #endif 393 362 394 ! Initialise arrays being exchanged 363 395 ! A correct exchange process (but without north-fold) won't change … … 1356 1388 lfill, stat) 1357 1389 USE par_kind, ONLY: wp 1358 USE par_oce, ONLY: jpi, jpj, jpk, jpreci 1390 USE par_oce, ONLY: jpi, jpj, jpk, jpreci, jpiglo 1359 1391 USE dom_oce, ONLY: nlci, nldi, nlei, nldj, nlej, nimpp, njmpp, narea 1360 1392 USE mapcomm_mod, ONLY: jlbext, jubext, ilbext, iubext … … 1374 1406 LOGICAL, INTENT(out) :: stat 1375 1407 ! Locals 1376 INTEGER :: ik, ij, ii 1408 INTEGER :: ik, ij, ii, ipt 1377 1409 LOGICAL :: hit_error, local_lfill 1378 1410 INTEGER :: gVal, jstart, jstop, istart, istop … … 1495 1527 DO ii=1,jpi,1 1496 1528 #endif 1497 IF( depth(ii+nimpp-1,ij+njmpp-1)*r3d(ii,ij,ik) < 0.0 )THEN 1498 hit_error = .TRUE. 1499 WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, r3d(',2(I3,','),I3,') = ',F10.0)") & 1529 IF(ik <= pmaxdepth(ii+nimpp-1,ij+njmpp-1))THEN 1530 IF( depth(ii+nimpp-1,ij+njmpp-1)*r3d(ii,ij,ik) < 0.0 )THEN 1531 hit_error = .TRUE. 1532 WRITE(LOG_UNIT, & 1533 FMT="(I4,': ERROR: ',A1,' pt, r3d(',2(I3,','),I3,') = ',F10.0)") & 1500 1534 #if defined key_z_first 1501 narea-1, gridType, ik, ii, ij, r3d(ii, ij, ik)1535 narea-1, gridType, ik, ii, ij, r3d(ii, ij, ik) 1502 1536 #else 1503 narea-1, gridType, ii, ij, ik, r3d(ii, ij, ik) 1504 #endif 1537 narea-1, gridType, ii, ij, ik, r3d(ii, ij, ik) 1538 #endif 1539 END IF 1505 1540 END IF 1506 1541 END DO … … 1517 1552 DO ii=istart,istop,1 1518 1553 1519 gval = gcoords_to_int(ii,ij,ik) 1520 1521 ! depth is the mask for the whole simulation domain so must 1522 ! convert from local to domain coordinates 1523 IF( (depth(ii+nimpp-1,ij+njmpp-1) > 0) .AND. & 1524 (INT(r3d(ii,ij,ik)) /= gVal) )THEN 1525 WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, r3d(',2(I3,','),I3,') = ',I10.9,' /= gVal = ',I10.9)") & 1554 IF(ik <= pmaxdepth(ii+nimpp-1,ij+njmpp-1))THEN 1555 1556 ipt = ii+nimpp-1 1557 ! Treat halo regions on E/W edges of global domain 1558 ! with care when cyclic boundary conditions are 1559 ! enabled. 1560 IF(cyclic_bc)THEN 1561 IF( (ii+nimpp-1) == jpiglo )THEN 1562 ! Eastern edge of global domain - this halo 1563 ! should therefore contain values from the 1564 ! first non-halo column on the Western edge. 1565 ipt = 2 1566 ELSE IF( (ii+nimpp-1) == 1 )THEN 1567 ! Western edge of global domain - this halo 1568 ! should therefore contain values from the 1569 ! last non-halo column on the Eastern edge. 1570 ipt = jpiglo-1 1571 END IF 1572 END IF 1573 1574 gval = gcoords_to_int(ipt, (ij+njmpp-1), ik, & 1575 are_global=.TRUE.) 1576 1577 ! depth is the mask for the whole simulation domain so 1578 ! must convert from local to domain coordinates 1579 IF( (depth(ii+nimpp-1,ij+njmpp-1) > 0) .AND. & 1580 (INT(r3d(ii,ij,ik)) /= gVal) )THEN 1581 1582 WRITE(LOG_UNIT, & 1583 FMT="(I4,': ERROR: ',A1,' pt, r3d(',2(I3,','),I3,') = ',I10.9,' /= gVal = ',I10.9)") & 1526 1584 #if defined key_z_first 1527 1585 narea-1, gridType, ik, ii, ij, & … … 1530 1588 #endif 1531 1589 INT(r3d(ii, ij, ik)), gVal 1532 WRITE (LOG_UNIT,"(I4,': depth(',I3,',',I3,') = ',I2)") &1590 WRITE (LOG_UNIT,"(I4,': depth(',I3,',',I3,') = ',I2,' bot. level = ',I3)") & 1533 1591 narea-1, ii+nimpp-1,ij+njmpp-1, & 1534 depth(ii+nimpp-1,ij+njmpp-1) 1535 hit_error = .TRUE. 1592 depth(ii+nimpp-1,ij+njmpp-1), & 1593 pmaxdepth(ii+nimpp-1,ij+njmpp-1) 1594 1595 hit_error = .TRUE. 1596 END IF 1536 1597 END IF 1598 1537 1599 END DO 1538 1600 END DO … … 1556 1618 END DO 1557 1619 1558 !!$ IF( ANY( MASK=(r2d(istart:istop,jstart:jstop) < 0.0) ) )THEN1559 !!$ hit_error = .TRUE.1560 !!$1561 !!$ DO ij=jstart, jstop, 11562 !!$ DO ii=istart, istop, 11563 !!$ IF(r2d(ii,ij) < 0.0)THEN1564 !!$ WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, r2d(',I3,',',I3,') = ',F10.0)") &1565 !!$ narea-1, gridType, ii, ij, r2d(ii, ij)1566 !!$ END IF1567 !!$ END DO1568 !!$ END DO1569 !!$ END IF1570 1571 1620 IF(testType .eq. GLOBAL_LOCN_TEST)THEN 1572 1621 1573 1622 DO ij=jstart, jstop, 1 1574 1623 DO ii=istart, istop, 1 1575 gval = gcoords_to_int(ii,ij) 1624 1625 ipt = ii+nimpp-1 1626 ! Treat halo regions on E/W edges of global domain 1627 ! with care when cyclic boundary conditions are 1628 ! enabled. 1629 IF(cyclic_bc)THEN 1630 IF( (ii+nimpp-1) == jpiglo )THEN 1631 ! Eastern edge of global domain - this halo 1632 ! should therefore contain values from the 1633 ! first non-halo column on the Western edge. 1634 ipt = 2 1635 ELSE IF( (ii+nimpp-1) == 1 )THEN 1636 ! Western edge of global domain - this halo 1637 ! should therefore contain values from the 1638 ! last non-halo column on the Eastern edge. 1639 ipt = jpiglo-1 1640 END IF 1641 END IF 1642 1643 gval = gcoords_to_int(ipt, (ij+njmpp-1), & 1644 are_global=.TRUE.) 1645 1646 ! gval = gcoords_to_int(ii,ij) 1647 1576 1648 IF( (depth(ii+nimpp-1,ij+njmpp-1) > 0) .AND. & 1577 1649 (INT(r2d(ii,ij)) /= gval) )THEN … … 1595 1667 DO ij=jstart,jstop,1 1596 1668 DO ii=1,jpi,1 1597 IF(i3d(ii,ij,ik) < 0.0)THEN 1669 IF( (i3d(ii,ij,ik) < 0.0) .AND. & 1670 (ik <= pmaxdepth(ii+nimpp-1,ij+njmpp-1)) )THEN 1671 1598 1672 WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, i3d(',2(I3,','),I3,') = ',I10.9)") & 1599 1673 #if defined key_z_first … … 1618 1692 DO ii=istart,istop,1 1619 1693 gval = gcoords_to_int(ii,ij,ik) 1620 IF(i3d(ii,ij,ik) /= gval )THEN 1694 IF( (i3d(ii,ij,ik) /= gval) .AND. & 1695 (ik <= pmaxdepth(ii+nimpp-1,ij+njmpp-1)) )THEN 1621 1696 WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, i3d(',2(I3,','),I3,') = ',I10.9,' /= gVal = ',I10.9)") & 1622 1697 #if defined key_z_first … … 1677 1752 END SUBROUTINE array_check 1678 1753 1679 FUNCTION gcoords_to_int(ii, ij, ik ) RESULT(value)1754 FUNCTION gcoords_to_int(ii, ij, ik, are_global) RESULT(value) 1680 1755 USE dom_oce, ONLY: nimpp, njmpp, nldi, nldj 1681 1756 IMPLICIT None 1682 ! Encode the specified global coordinates into a single1683 ! floating pointnumber.1757 ! Convert the specified coordinates in the local domain into global 1758 ! coordinates and encode into a single integer number. 1684 1759 INTEGER, INTENT(in) :: ii, ij 1685 1760 INTEGER, INTENT(in), OPTIONAL :: ik 1761 LOGICAL, INTENT(in), OPTIONAL :: are_global ! Whether input coordinates 1762 ! are already global rather 1763 ! than just relative to local 1764 ! domain 1686 1765 ! Locals 1687 1766 INTEGER :: value 1688 1689 value = (ii + nimpp - 1)*1000000 + & 1690 (ij + njmpp - 1)*1000 1767 LOGICAL :: lglobal 1768 !!==================================================================== 1769 1770 lglobal = .FALSE. 1771 IF( PRESENT(are_global) )lglobal = are_global 1772 1773 IF(lglobal)THEN 1774 ! ii and ij are already global coordinates 1775 value = ii*1000000 + & 1776 ij*1000 1777 ELSE 1778 value = (ii + nimpp - 1)*1000000 + & 1779 (ij + njmpp - 1)*1000 1780 END IF 1781 1691 1782 IF(PRESENT(ik))THEN 1692 1783 value = value + ik … … 1695 1786 END FUNCTION gcoords_to_int 1696 1787 1788 1697 1789 END MODULE exchtestmod -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r3432 r3837 18 18 USE exchmod ! Comms for irregular domain decomposition 19 19 20 ! This is important - it determines which set of comms routines are 21 ! called when lbc_lnk() is invoked. 20 22 INTERFACE lbc_lnk 21 23 #if defined key_mpp_rkpart … … 104 106 105 107 106 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 108 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval, lzero ) 109 USE lib_mpp, ONLY: ctl_stop 107 110 !!--------------------------------------------------------------------- 108 111 !! *** ROUTINE lbc_lnk_3d *** … … 124 127 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 125 128 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 129 LOGICAL , INTENT(in ), OPTIONAL :: lzero ! Whether to zero halos on closed boundaries 130 126 131 !! 127 132 REAL(wp) :: zland … … 132 137 ENDIF 133 138 139 IF( PRESENT( lzero ) )THEN 140 CALL ctl_stop('STOP','lbc_lnk_3d: IMPLEMENT lzero option!') 141 ENDIF 134 142 135 143 IF( PRESENT( cd_mpp ) ) THEN … … 197 205 198 206 199 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 207 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval, lzero ) 208 USE lib_mpp, ONLY: ctl_stop 200 209 !!--------------------------------------------------------------------- 201 210 !! *** ROUTINE lbc_lnk_2d *** … … 214 223 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 215 224 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 225 LOGICAL , INTENT(in ), OPTIONAL :: lzero ! Whether to zero halos on closed boundaries 216 226 !! 217 227 REAL(wp) :: zland … … 220 230 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 221 231 ELSE ; zland = 0.e0 232 ENDIF 233 234 IF( PRESENT( lzero ) )THEN 235 CALL ctl_stop('STOP','lbc_lnk_2d: IMPLEMENT lzero option!') 222 236 ENDIF 223 237 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r3432 r3837 279 279 WRITE(ldtxt(ii),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer ; ii = ii + 1 280 280 WRITE(ldtxt(ii),*) ' whether to trim dry points nn_pttrim = ', nn_pttrim ; ii = ii + 1 281 WRITE(ldtxt(ii),*) ' number of cores per compute node nn_cpn 281 WRITE(ldtxt(ii),*) ' number of cores per compute node nn_cpnode = ', nn_cpnode ; ii = ii + 1 282 282 #if defined key_agrif 283 283 IF( .NOT. Agrif_Root() ) THEN … … 469 469 470 470 #if defined key_mpp_rkpart 471 CALL ctl_stop('mpp_lnk_3d: should not have been called when key_mpp_rkpart defined!') 471 CALL ctl_stop('STOP', & 472 'mpp_lnk_3d: should not have been called when key_mpp_rkpart defined!') 472 473 RETURN 473 474 #endif … … 2308 2309 !!---------------------------------------------------------------------- 2309 2310 ! 2311 #if defined key_mpp_rkpart 2312 WRITE(*,*)'ARPDBG - should not be calling this version of mpp_ini_north!' 2313 CALL MPI_ABORT(mpi_comm_opa, -1) 2314 RETURN 2315 #endif 2316 2310 2317 njmppmax = MAXVAL( njmppt ) 2311 2318 ! -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/mapcomm_mod.F90
r3432 r3837 1 1 MODULE mapcomm_mod 2 2 USE in_out_manager, ONLY: numout, lwp 3 USE par_oce, ONLY: jpiglo, jpjglo, jpreci, jprecj, jpi 3 USE par_oce, ONLY: jpiglo, jpjglo, jpreci, jprecj, jpi, jpk 4 4 USE dom_oce, ONLY: nlei, nlej, nldi, nldj, nlci, nlcj, narea, & 5 5 nleit, nlejt, nldit, nldjt, nlcit, nlcjt, & … … 7 7 IMPLICIT NONE 8 8 9 !#define ARPDEBUG9 #define ARPDEBUG 10 10 11 11 PRIVATE … … 62 62 isrcrecv,jsrcrecv, & 63 63 idessend,jdessend, & 64 nxsend,nysend, 64 nxsend,nysend,nzsend, & 65 65 idesrecv,jdesrecv, & 66 nxrecv,nyrecv 66 nxrecv,nyrecv,nzrecv 67 67 INTEGER, SAVE :: nsend,nrecv 68 68 69 69 ! SMP 22 Sep 2009 70 ! Alternat erun-length encoded communications lists70 ! Alternative, run-length encoded communications lists 71 71 ! omitting permanently dry points. 72 ! Of these, i dessendp, jdessendp, isrcrecp, jsrcrecvp72 ! Of these, isrcrecp, jsrcrecvp 73 73 ! are set up but not currently used, 74 74 ! and could be eliminated. … … 79 79 INTEGER, SAVE, DIMENSION(MaxPatch,MaxComm,jpreci) :: & 80 80 isrcsendp, jsrcsendp,& 81 !idessendp, jdessendp,& 82 nxsendp, nysendp, & 81 nxsendp, nysendp, nzsendp, & 83 82 isrcrecvp, jsrcrecvp,& 84 83 idesrecvp, jdesrecvp,& 85 nxrecvp, nyrecvp 84 nxrecvp, nyrecvp, nzrecvp 86 85 INTEGER, SAVE, DIMENSION(MaxComm,jpreci) :: npatchsend, npatchrecv 87 86 ! Total number of points in each message 88 INTEGER, SAVE, DIMENSION(MaxComm,jpreci) :: nsendp, n recvp87 INTEGER, SAVE, DIMENSION(MaxComm,jpreci) :: nsendp, nsendp2d, nrecvp, nrecvp2d 89 88 90 89 ! Process dependent partitioning information. … … 132 131 ,south = (/ 0, 0, 1, 0, 1, 0, 0, 1 /) & 133 132 ,north = (/ 0, 0, 0, 1, 0, 1, 1, 0 /) 134 !1 2 3 4 5 6 7 8135 !W E S N SW NE NW SE133 ! 1 2 3 4 5 6 7 8 134 ! W E S N SW NE NW SE 136 135 137 136 ! cyclic_bc True if a cyclic boundary condition is to be applied … … 150 149 INTEGER, PARAMETER :: LAND = 0 151 150 152 ! nextra is a safety factor because NEMO actually computes 153 ! its wet/dry mask in dommsk _after_ it has smoothed the 154 ! bathymetry read from file (when ln_sco is set). This means 155 ! that points on the coast that are dry here can actually 156 ! subsequently become wet. Therefore, rather than trim to a point 157 ! immediately next to a wet point, we back off nextra points. 158 INTEGER, PARAMETER :: nextra = 2 151 ! Rather than trim to a point immediately next to a wet point, we 152 ! back off nextra points. If we don't do this then the sea-ice 153 ! computation goes wrong because it does use values over the land 154 ! that immediately border the ocean. 155 INTEGER, SAVE :: nextra 159 156 160 157 ! Public routines … … 164 161 PUBLIC :: MaxComm,nsend,nrecv,nxsend,nysend,destination,dirrecv, & 165 162 dirsend,isrcsend,jsrcsend,idesrecv, jdesrecv, & 166 nxrecv, nyrecv,source, cyclic_bc, idessend, jdessend167 168 PUBLIC :: nsendp,n recvp,npatchsend,npatchrecv, &169 nxsendp,nysendp, nxrecvp,nyrecvp,&163 nxrecv, nyrecv, source, cyclic_bc, idessend, jdessend 164 165 PUBLIC :: nsendp,nsendp2d,nrecvp,nrecvp2d,npatchsend,npatchrecv, & 166 nxsendp,nysendp,nzsendp,nxrecvp,nyrecvp,nzrecvp, & 170 167 idesrecvp,jdesrecvp,isrcsendp,jsrcsendp 171 168 … … 190 187 PUBLIC :: trimmed, nidx, eidx, sidx, widx, nextra 191 188 192 ! Switch for outputting px mapping to file193 !LOGICAL, PARAMETER :: outmap = .TRUE.194 195 189 ! Switch for trimming dry points from halo swaps 196 LOGICAL, PARAMETER :: msgtrim = .TRUE. 190 LOGICAL, PARAMETER :: msgtrim = .TRUE. 191 192 ! Switch for trimming points below ocean floor from halo swaps 193 !LOGICAL, PARAMETER :: msgtrim_z = .TRUE. ! .FALSE. 194 LOGICAL, PUBLIC, SAVE :: msgtrim_z 197 195 198 196 CONTAINS 199 197 200 SUBROUTINE mapcomms ( depth, nx, ny, jperio, ierr )198 SUBROUTINE mapcomms ( depth, ibotlvl, nx, ny, jperio, ierr ) 201 199 !!------------------------------------------------------------------ 202 200 ! Maps out the communications requirements for the partitioned … … 209 207 ! Subroutine arguments. 210 208 INTEGER, INTENT(in) :: nx, ny 211 INTEGER, INTENT(in) :: depth(nx,ny)! Global mask: 0 for land, 1 for ocean 212 INTEGER, INTENT(in) :: jperio ! Periodicity of the mesh 209 INTEGER, INTENT(in) :: depth(nx,ny) ! Global mask: 0 for land, 1 for ocean 210 INTEGER, INTENT(in) :: ibotlvl(nx,ny)! Last vert level above sea floor 211 INTEGER, INTENT(in) :: jperio ! Periodicity of the mesh 213 212 INTEGER, INTENT(out):: ierr 214 213 … … 268 267 nxsend = -999 269 268 nysend = -999 269 nzsend = -999 270 270 dirrecv = -999 271 271 source = -999 … … 274 274 nxrecv = -999 275 275 nyrecv = -999 276 nzrecv = -999 276 277 277 278 ! For each of the eight communication directions on a 2d grid of … … 457 458 CALL addsend (nsend,Iplus,procid(iproc), & 458 459 isrcs,jsrcs,idess,jdess, & 459 nxs,nys,depth,i err)460 nxs,nys,depth,ibotlvl,ierr) 460 461 IF ( ierr.NE.0 ) RETURN 461 462 … … 464 465 CALL addrecv (nrecv,Iminus,procid(iproc), & 465 466 isrcr,jsrcr,idesr,jdesr, & 466 nxr,nyr,depth,i err)467 nxr,nyr,depth,ibotlvl,ierr) 467 468 IF ( ierr.NE.0 ) RETURN 468 469 #if defined ARPDEBUG … … 641 642 ! of border. 642 643 643 CALL addsend (nsend,Iminus,procid(iproc), & 644 isrcs,jsrcs,idess,jdess,nxs,nys,depth,ierr) 644 CALL addsend (nsend,Iminus,procid(iproc), & 645 isrcs,jsrcs,idess,jdess,nxs,nys,& 646 depth,ibotlvl,ierr) 645 647 IF ( ierr.NE.0 ) RETURN 646 648 #if defined ARPDEBUG … … 651 653 #endif 652 654 653 CALL addrecv (nrecv,Iplus,procid(iproc), & 654 isrcr,jsrcr,idesr,jdesr,nxr,nyr,depth,ierr) 655 CALL addrecv (nrecv,Iplus,procid(iproc), & 656 isrcr,jsrcr,idesr,jdesr,nxr,nyr, & 657 depth,ibotlvl,ierr) 655 658 IF ( ierr.NE.0 ) RETURN 656 659 … … 853 856 ! of border. 854 857 855 CALL addsend (nsend,Jplus,procid(iproc) & 856 ,isrcs,jsrcs,idess,jdess,nxs,nys,depth,ierr) 858 CALL addsend (nsend,Jplus,procid(iproc), & 859 isrcs,jsrcs,idess,jdess,nxs,nys, & 860 depth,ibotlvl,ierr) 857 861 IF ( ierr.NE.0 ) RETURN 858 862 859 CALL addrecv (nrecv,Jminus,procid(iproc) & 860 ,isrcr,jsrcr,idesr,jdesr,nxr,nyr,depth,ierr) 863 CALL addrecv (nrecv,Jminus,procid(iproc), & 864 isrcr,jsrcr,idesr,jdesr,nxr,nyr, & 865 depth,ibotlvl,ierr) 861 866 IF ( ierr.NE.0 ) RETURN 862 867 … … 1029 1034 ! of border. 1030 1035 1031 CALL addsend (nsend,Jminus,procid(iproc) & 1032 ,isrcs,jsrcs,idess,jdess,nxs,nys,depth,ierr) 1036 CALL addsend (nsend,Jminus,procid(iproc), & 1037 isrcs,jsrcs,idess,jdess,nxs,nys, & 1038 depth,ibotlvl,ierr) 1033 1039 IF ( ierr.NE.0 ) RETURN 1034 1040 1035 CALL addrecv (nrecv,Jplus,procid(iproc) & 1036 ,isrcr,jsrcr,idesr,jdesr,nxr,nyr,depth,ierr) 1041 CALL addrecv (nrecv,Jplus,procid(iproc), & 1042 isrcr,jsrcr,idesr,jdesr,nxr,nyr, & 1043 depth,ibotlvl,ierr) 1037 1044 IF ( ierr.NE.0 ) RETURN 1038 1045 … … 1057 1064 1058 1065 ! Loop over the four corner directions 1066 ! i = 1 2 3 4 5 6 7 8 1067 ! W E S N SW NE NW SE 1068 1059 1069 1060 1070 DO i=5,8 … … 1063 1073 1064 1074 addcorner = .FALSE. 1065 1066 ! Look at the processors to the X and Y directions.1067 1068 !!$ iprocx = iprocmap(ielb-west(i)+east(i)*iesub &1069 !!$ ,jelb+north(i)*(jesub-1))1070 1071 !!$ iprocy = iprocmap(ielb+east(i)*(iesub-1) &1072 !!$ ,jelb-south(i)+north(i)*jesub)1073 1075 1074 1076 ! i1 is to be x-coord just OUTSIDE our domain … … 1080 1082 i1 = ielb 1081 1083 i2 = ielb 1082 IF(ilbext )THEN1084 IF(ilbext .AND. (.NOT. trimmed(widx,narea)) )THEN 1083 1085 i2 = i2+west(i) ! If on W boundary with cyclic bc's, ielb _is_ the halo column 1084 1086 ! so add 1 to move inside domain … … 1086 1088 i1 = i1-west(i) 1087 1089 END IF 1088 IF(iubext )THEN1090 IF(iubext .AND. (.NOT. trimmed(eidx,narea)) )THEN 1089 1091 ! If upper bound is on domain boundary then iesub already 1090 1092 ! includes the halo column … … 1101 1103 END IF 1102 1104 1103 ! For a NW corner:1104 ! |1105 ! iproc | iprocy1106 ! ________|______1107 ! |1108 ! iprocx | Me1109 ! |1105 ! For a NW corner: 1106 ! | 1107 ! iproc | iprocy 1108 ! ________|______ 1109 ! | 1110 ! iprocx | Me 1111 ! | 1110 1112 1111 1113 ! x coord just OUTSIDE our domain but y INSIDE … … 1141 1143 1142 1144 ! Ensure we don't include halos from the global borders if we 1143 1145 ! have cyclic E/W boundaries. 1144 1146 ielb_iproc = pielb(iproc) 1145 1147 ieub_iproc = pieub(iproc) … … 1178 1180 ! Allow for wrap-around if necessary 1179 1181 IF(cyclic_bc)THEN 1180 IF(ldiff0 < 1) ldiff0 = ldiff0 + (jpiglo - 2) !ARPDBG -2 for consistency with procmap 1181 IF(ldiff1 < 1) ldiff1 = ldiff1 + (jpiglo - 2) !ARPDBG -2 for consistency with procmap 1182 IF(ldiff0 < 1)THEN 1183 !ARPDBG -2 for consistency with procmap 1184 ldiff0 = ldiff0 + (jpiglo - 2) 1185 END IF 1186 IF(ldiff1 < 1)THEN 1187 !ARPDBG -2 for consistency with procmap 1188 ldiff1 = ldiff1 + (jpiglo - 2) 1189 END IF 1182 1190 END IF 1183 1191 nxs (ihalo) = ihalo - east(i)*(ldiff0-1) & 1184 1192 - west(i)*(ldiff1-1) 1193 ! Have no cyclic b.c.'s in N/S direction so probably don't need 1194 ! the following checks on ldiff{0,1} 1185 1195 ldiff0 = pjelb(iprocc) - jeub 1186 1196 IF(ldiff0 < 1) ldiff0 = ldiff0 + jpjglo … … 1194 1204 isrcs(ihalo) = east(i) *(iesub-nxs(ihalo)) + nldi 1195 1205 jsrcs(ihalo) = north(i)*(jesub-nys(ihalo)) + nldj 1196 IF( cyclic_bc)THEN1206 IF( cyclic_bc )THEN 1197 1207 IF( ilbext )THEN 1198 1208 ! nldi is still within halo for domains on W edge of … … 1221 1231 ! Source for a receive must be in an internal region of the REMOTE domain 1222 1232 isrcr(ihalo) = west(i)*(piesub(iprocc)-nxs(ihalo)) + nldit(iprocc) 1223 IF(cyclic_bc)THEN 1233 IF( cyclic_bc )THEN 1234 1235 ! This _could_ be a corner exchange wrapped around by the cyclic 1236 ! boundary conditions: 1237 ! 1238 ! ||------| || 1239 ! || | | || 1240 ! ||a_____|__ _ _ | || 1241 ! || -----------|| 1242 ! || | a|| 1243 ! || |________|| 1244 1224 1245 IF(pilbext(iprocc))THEN 1225 1246 ! nldi is still within halo for domains on E edge of 1226 1247 ! global domain 1227 isrcr(ihalo) = isrcr(ihalo) + 11248 isrcr(ihalo) = isrcr(ihalo) + east(i) 1228 1249 ELSE IF(piubext(iprocc))THEN 1229 1250 ! Final column is actually halo for domains on W edge of 1230 1251 ! global domain 1231 isrcr(ihalo) = isrcr(ihalo) - 11252 isrcr(ihalo) = isrcr(ihalo) - west(i) 1232 1253 END IF 1233 1254 END IF … … 1281 1302 IF ( addcorner ) THEN 1282 1303 #if defined ARPDEBUG 1283 WRITE (*,FMT="(I3,': ARPDBG adding corner send to ',I2,', dir = ',I1)") narea-1, procid(iprocc),i 1284 #endif 1285 CALL addsend (nsend,i,procid(iprocc) & 1286 ,isrcs,jsrcs,idess,jdess,nxs,nys,depth,ierr) 1304 WRITE (*,FMT="(I3,': ARPDBG adding corner send to ',I2,', dir = ',I1)") & 1305 narea-1, procid(iprocc),i 1306 #endif 1307 CALL addsend (nsend,i,procid(iprocc), & 1308 isrcs,jsrcs,idess,jdess,nxs,nys, & 1309 depth,ibotlvl,ierr) 1287 1310 IF ( ierr.NE.0 ) RETURN 1288 1311 … … 1291 1314 1292 1315 #if defined ARPDEBUG 1293 WRITE (*,FMT="(I3,': ARPDBG adding corner recv. from ',I3,', old dir = ',I1,' new dir = ',I1)") narea-1, procid(iprocc),i, j 1294 #endif 1295 CALL addrecv (nrecv,j,procid(iprocc) & 1296 ,isrcr,jsrcr,idesr,jdesr,nxr,nyr,depth,ierr) 1316 WRITE (*,FMT="(I3,': ARPDBG adding corner recv. from ',I3,', old dir = ',I1,' new dir = ',I1)") & 1317 narea-1, procid(iprocc),i, j 1318 #endif 1319 CALL addrecv (nrecv,j,procid(iprocc), & 1320 isrcr,jsrcr,idesr,jdesr,nxr,nyr, & 1321 depth,ibotlvl,ierr) 1297 1322 IF ( ierr.NE.0 ) RETURN 1298 1323 … … 1366 1391 1367 1392 SUBROUTINE addsend ( icomm, dir, proc, isrc, jsrc, & 1368 ides, jdes, nx, ny, depth, i err )1393 ides, jdes, nx, ny, depth, ibotlvl, ierr ) 1369 1394 !!------------------------------------------------------------------ 1370 1395 ! Adds a send communication specified by the parameters dir through … … 1372 1397 ! icomm points to the last entry and is incremented and returned 1373 1398 ! if successful. 1374 1399 ! 1375 1400 ! icomm int in/out Location in comms list. 1376 1401 ! dir int input Direction. … … 1384 1409 ! depth input Global mask, 0 for land, 1 for wet 1385 1410 ! ierr int output Error flag. 1386 1411 ! 1387 1412 ! Mike Ashworth, CLRC Daresbury Laboratory, March 1999 1388 1413 ! Stephen Pickles, STFC Daresbury Laboratory … … 1397 1422 ! Global mask: 0 for land, 1 for ocean 1398 1423 INTEGER, DIMENSION(:,:), INTENT( in ) :: depth 1424 INTEGER, DIMENSION(:,:), INTENT( in ) :: ibotlvl 1399 1425 INTEGER, INTENT( out ) :: ierr 1400 1426 INTEGER, DIMENSION(jpreci), INTENT( in ) :: isrc, jsrc, & 1401 1427 ides, jdes, nx, ny 1402 1428 ! Values of corresponding input arguments after clipping 1403 INTEGER, DIMENSION(jpreci) :: cisrc,cjsrc,cides,cjdes,cnx,cny 1429 INTEGER, DIMENSION(jpreci) :: cisrc,cjsrc,cides,cjdes,cnx,cny,cnz 1404 1430 ! Run-length encoded versions corresponding to above 1405 INTEGER, dimension(MaxPatch,jpreci) :: risrc,rjsrc,rides,rjdes,rnx,rny1431 INTEGER, DIMENSION(MaxPatch,jpreci) :: risrc,rjsrc,rides,rjdes,rnx,rny,rnz 1406 1432 ! Number of patches in run-length encoded message 1407 1433 INTEGER, DIMENSION(jpreci) :: npatches 1408 1434 INTEGER :: ihalo, ipatch 1435 INTEGER :: nsendp_untrimmedz ! How many pts we'd be sending without 1436 ! trimming in z direction 1409 1437 ! Whether there is still a message after clipping 1410 1438 LOGICAL :: something_left … … 1421 1449 ! Can the message be clipped ? 1422 1450 1423 CALL clip_msg(depth, isrc, jsrc, ides, jdes, nx, ny, & 1424 cisrc,cjsrc,cides,cjdes,cnx,cny, & 1425 risrc,rjsrc,rides,rjdes,rnx,rny, & 1451 CALL clip_msg(depth, ibotlvl, & 1452 isrc, jsrc, ides, jdes, nx, ny, & 1453 cisrc,cjsrc,cides,cjdes,cnx,cny,cnz, & 1454 risrc,rjsrc,rides,rjdes,rnx,rny,rnz, & 1426 1455 npatches, something_left) 1427 1456 … … 1451 1480 nxsend(icomm) = cnx(1) 1452 1481 nysend(icomm) = cny(1) 1482 IF(msgtrim_z)THEN 1483 nzsend(icomm) = cnz(1) 1484 ELSE 1485 nzsend(icomm) = jpk 1486 END IF 1487 1488 ! Zero count of untrimmed pts to send 1489 nsendp_untrimmedz = 0 1453 1490 1454 1491 ! Also set up the comms lists encoded as the start points and 1455 1492 ! lengths of the contiguous runs of wet points. 1456 1493 DO ihalo=1,jpreci 1457 nsendp(icomm,ihalo) = 0 1494 1495 nsendp2d(icomm,ihalo) = 0 1496 nsendp(icomm,ihalo) = 0 1458 1497 npatchsend(icomm,ihalo) = npatches(ihalo) 1498 1459 1499 DO ipatch=1,npatches(ihalo) 1500 1460 1501 isrcsendp(ipatch,icomm,ihalo) = risrc(ipatch,ihalo) 1461 1502 jsrcsendp(ipatch,icomm,ihalo) = rjsrc(ipatch,ihalo) 1462 !idessendp(ipatch,icomm,ihalo) = rides(ipatch,ihalo) 1463 !jdessendp(ipatch,icomm,ihalo) = rjdes(ipatch,ihalo) 1503 1464 1504 nxsendp(ipatch,icomm,ihalo) = rnx(ipatch,ihalo) 1465 1505 nysendp(ipatch,icomm,ihalo) = rny(ipatch,ihalo) 1506 IF(msgtrim_z)THEN 1507 nzsendp(ipatch,icomm,ihalo)= rnz(ipatch,ihalo) 1508 ELSE 1509 nzsendp(ipatch,icomm,ihalo) = jpk 1510 END IF 1511 1466 1512 ! Sum the no. of points to be sent over all 1467 ! patches 1468 nsendp(icomm,ihalo) = nsendp(icomm,ihalo) & 1469 + rnx(ipatch,ihalo)*rny(ipatch,ihalo) 1513 ! patches for both 2D-array halos and 3D-array halos 1514 nsendp2d(icomm,ihalo) = nsendp2d(icomm,ihalo) + & 1515 nxsendp(ipatch,icomm,ihalo)* & 1516 nysendp(ipatch,icomm,ihalo) 1517 nsendp(icomm,ihalo) = nsendp(icomm,ihalo) + & 1518 nxsendp(ipatch,icomm,ihalo)* & 1519 nysendp(ipatch,icomm,ihalo)* & 1520 nzsendp(ipatch,icomm,ihalo) 1521 IF(msgtrim_z)THEN 1522 nsendp_untrimmedz = nsendp_untrimmedz + & 1523 nxsendp(ipatch,icomm,ihalo)* & 1524 nysendp(ipatch,icomm,ihalo)* & 1525 jpk 1526 END IF 1470 1527 END DO 1471 1528 END DO 1472 1529 1473 1530 #if defined ARPDEBUG 1474 WRITE (*,FMT="(I3,': ARPDBG adding SEND:')") narea-1 1475 WRITE (*,FMT="(I3,': ARPDBG: icomm = ',I2)") narea-1,icomm 1476 WRITE (*,FMT="(I3,': ARPDBG: dir = ',I2)") narea-1,dirsend(icomm) 1477 WRITE (*,FMT="(I3,': ARPDBG: proc = ',I3)") narea-1,destination(icomm) 1478 WRITE (*,FMT="(I3,': ARPDBG: isrc = ',I3)") narea-1,isrcsend(icomm) 1479 WRITE (*,FMT="(I3,': ARPDBG: jsrc = ',I3)") narea-1,jsrcsend(icomm) 1480 WRITE (*,FMT="(I3,': ARPDBG: ides = ',I3)") narea-1,idessend(icomm) 1481 WRITE (*,FMT="(I3,': ARPDBG: jdes = ',I3)") narea-1,jdessend(icomm) 1482 WRITE (*,FMT="(I3,': ARPDBG: nx = ',I3)") narea-1,nxsend(icomm) 1483 WRITE (*,FMT="(I3,': ARPDBG: ny = ',I3)") narea-1,nysend(icomm) 1484 WRITE (*,FMT="(I3,': ARPDBG:npatch = ',I3)") narea-1,npatches(1) 1531 WRITE (*,FMT="(I4,': ARPDBG adding SEND:')") narea-1 1532 WRITE (*,FMT="(I4,': ARPDBG: icomm = ',I2)") narea-1,icomm 1533 WRITE (*,FMT="(I4,': ARPDBG: dir = ',I2)") narea-1,dirsend(icomm) 1534 WRITE (*,FMT="(I4,': ARPDBG: proc = ',I4)") narea-1,destination(icomm) 1535 WRITE (*,FMT="(I4,': ARPDBG: isrc = ',I4)") narea-1,isrcsend(icomm) 1536 WRITE (*,FMT="(I4,': ARPDBG: jsrc = ',I4)") narea-1,jsrcsend(icomm) 1537 WRITE (*,FMT="(I4,': ARPDBG: ides = ',I4)") narea-1,idessend(icomm) 1538 WRITE (*,FMT="(I4,': ARPDBG: jdes = ',I4)") narea-1,jdessend(icomm) 1539 WRITE (*,FMT="(I4,': ARPDBG: nx = ',I4)") narea-1,nxsend(icomm) 1540 WRITE (*,FMT="(I4,': ARPDBG: ny = ',I4)") narea-1,nysend(icomm) 1541 WRITE (*,FMT="(I4,': ARPDBG: nz = ',I4)") narea-1,nzsend(icomm) 1542 WRITE (*,FMT="(I4,': ARPDBG:npatch = ',I3)") narea-1,npatches(1) 1485 1543 1486 1544 DO ipatch=1,npatches(1) 1487 WRITE (*,FMT="(I 3,': ARPDBG: patch ',I2,': isrc = ',I3)") &1545 WRITE (*,FMT="(I4,': ARPDBG: patch ',I2,': isrc = ',I4)") & 1488 1546 narea-1,ipatch,isrcsendp(ipatch,icomm,1) 1489 WRITE (*,FMT="(I 3,': ARPDBG: patch ',I2,': jsrc = ',I3)") &1547 WRITE (*,FMT="(I4,': ARPDBG: patch ',I2,': jsrc = ',I4)") & 1490 1548 narea-1,ipatch,jsrcsendp(ipatch,icomm,1) 1491 !WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': ides = ',I3)") & 1492 ! narea-1,ipatch,idessendp(ipatch,icomm,1) 1493 !WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': jdes = ',I3)") & 1494 ! narea-1,ipatch,jdessendp(ipatch,icomm,1) 1495 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': nx = ',I3)") & 1549 WRITE (*,FMT="(I4,': ARPDBG: patch ',I2,': nx = ',I4)") & 1496 1550 narea-1,ipatch,nxsendp(ipatch,icomm,1) 1497 WRITE (*,FMT="(I 3,': ARPDBG: patch ',I2,': ny = ',I3)") &1551 WRITE (*,FMT="(I4,': ARPDBG: patch ',I2,': ny = ',I4)") & 1498 1552 narea-1,ipatch,nysendp(ipatch,icomm,1) 1553 WRITE (*,FMT="(I4,': ARPDBG: patch ',I2,': nz = ',I4)") & 1554 narea-1,ipatch,nzsendp(ipatch,icomm,1) 1499 1555 END DO 1500 1556 1501 WRITE (*,FMT="(I3,': ARPDBG:nsendp = ',I4)") narea-1,nsendp(icomm,1) 1502 WRITE (*,FMT="(I3,': ARPDBG SEND ends')") narea-1 1557 WRITE (*,FMT="(I4,': ARPDBG:nsendp = ',I4)") narea-1,nsendp(icomm,1) 1558 IF(msgtrim_z)THEN 1559 WRITE (*,FMT="(I4,': ARPDBG:nsendp WITHOUT z trim = ',I4)") & 1560 narea-1,nsendp_untrimmedz 1561 END IF 1562 WRITE (*,FMT="(I4,': ARPDBG SEND ends')") narea-1 1503 1563 #endif 1504 1564 … … 1508 1568 1509 1569 SUBROUTINE addrecv ( icomm, dir, proc, isrc, jsrc, & 1510 ides, jdes, nx, ny, depth, i err )1511 !!------------------------------------------------------------------1512 !Adds a recv communication specified by the parameters dir through1513 !to ny to the recv communication list at the next position.1514 !icomm points to the last entry and is incremented and returned1515 !if successful.1516 1517 !icomm int in/out Location in comms list.1518 !dir int input Direction.1519 !proc int input Process id.1520 !isrc int input X coordinate of source data.1521 !jsrc int input Y coordinate of source data.1522 ! ides int input X coordinate of destinationdata.1523 ! jdes int input Y coordinate of destinationdata.1524 !nx int input Size in X of data to be sent.1525 !ny int input Size in Y of data to be sent.1526 !ierr int output Error flag.1527 1528 !Mike Ashworth, CLRC Daresbury Laboratory, March 19991529 !!------------------------------------------------------------------1570 ides, jdes, nx, ny, depth, ibotlvl, ierr ) 1571 !!------------------------------------------------------------------ 1572 ! Adds a recv communication specified by the parameters dir through 1573 ! to ny to the recv communication list at the next position. 1574 ! icomm points to the last entry and is incremented and returned 1575 ! if successful. 1576 ! 1577 ! icomm int in/out Location in comms list. 1578 ! dir int input Direction. 1579 ! proc int input Process id. 1580 ! isrc int input X coordinate of source data. 1581 ! jsrc int input Y coordinate of source data. 1582 ! ides int input X coordinate of dest. data. 1583 ! jdes int input Y coordinate of dest. data. 1584 ! nx int input Size in X of data to be sent. 1585 ! ny int input Size in Y of data to be sent. 1586 ! ierr int output Error flag. 1587 ! 1588 ! Mike Ashworth, CLRC Daresbury Laboratory, March 1999 1589 !!------------------------------------------------------------------ 1530 1590 IMPLICIT NONE 1531 1591 … … 1535 1595 INTEGER, INTENT(out) :: ierr 1536 1596 INTEGER, DIMENSION(:,:), INTENT( in ) :: depth 1597 INTEGER, DIMENSION(:,:), INTENT( in ) :: ibotlvl 1537 1598 INTEGER, DIMENSION(jpreci) :: isrc, jsrc, ides, jdes, nx, ny 1538 1599 … … 1540 1601 1541 1602 ! Values of corresponding input arguments after clipping 1542 INTEGER, DIMENSION(jpreci) :: cisrc,cjsrc,cides,cjdes,cnx,cny 1603 INTEGER, DIMENSION(jpreci) :: cisrc,cjsrc,cides,cjdes,cnx,cny,cnz 1543 1604 ! Run-length encoded versions corresponding to above 1544 INTEGER, dimension(MaxPatch,jpreci) :: risrc,rjsrc,rides,rjdes,rnx,rny 1605 INTEGER, dimension(MaxPatch,jpreci) :: risrc,rjsrc,rides,rjdes,rnx,rny,rnz 1545 1606 ! Number of patches in run-length encoded message 1546 1607 INTEGER, DIMENSION(jpreci) :: npatches … … 1561 1622 ! Can the message be clipped ? 1562 1623 1563 CALL clip_msg(depth, ides, jdes, isrc, jsrc, nx, ny, & 1564 cides,cjdes,cisrc,cjsrc,cnx,cny, & 1565 rides,rjdes,risrc,rjsrc,rnx,rny, & 1624 CALL clip_msg(depth, ibotlvl, & 1625 ides, jdes, isrc, jsrc, nx, ny, & 1626 cides,cjdes,cisrc,cjsrc,cnx,cny,cnz, & 1627 rides,rjdes,risrc,rjsrc,rnx,rny,rnz, & 1566 1628 npatches, something_left) 1567 1629 … … 1589 1651 idesrecv(icomm) = cides(1) 1590 1652 jdesrecv(icomm) = cjdes(1) 1653 1591 1654 nxrecv(icomm) = cnx(1) 1592 1655 nyrecv(icomm) = cny(1) 1656 IF(msgtrim_z)THEN 1657 nzrecv(icomm) = cnz(1) 1658 ELSE 1659 nzrecv(icomm) = jpk 1660 END IF 1593 1661 1594 1662 DO ihalo=1,jpreci 1595 nrecvp(icomm,ihalo) = 0 1663 1664 nrecvp2d(icomm,ihalo) = 0 1665 nrecvp(icomm,ihalo) = 0 1596 1666 npatchrecv(icomm,ihalo) = npatches(ihalo) 1667 1597 1668 DO ipatch=1,npatches(ihalo) 1598 1669 isrcrecvp(ipatch,icomm,ihalo) = risrc(ipatch,ihalo) … … 1602 1673 nxrecvp(ipatch,icomm,ihalo) = rnx(ipatch,ihalo) 1603 1674 nyrecvp(ipatch,icomm,ihalo) = rny(ipatch,ihalo) 1675 IF(msgtrim_z)THEN 1676 nzrecvp(ipatch,icomm,ihalo) = rnz(ipatch,ihalo) 1677 ELSE 1678 nzrecvp(ipatch,icomm,ihalo) = jpk 1679 END IF 1680 1604 1681 ! Sum the no. of points to be received over all 1605 1682 ! patches 1606 nrecvp(icomm,ihalo) = nrecvp(icomm,ihalo) + & 1607 rnx(ipatch,ihalo)*rny(ipatch,ihalo) 1683 nrecvp2d(icomm,ihalo) = nrecvp2d(icomm,ihalo) + & 1684 nxrecvp(ipatch,icomm,ihalo)* & 1685 nyrecvp(ipatch,icomm,ihalo) 1686 1687 nrecvp(icomm,ihalo) = nrecvp(icomm,ihalo) + & 1688 nxrecvp(ipatch,icomm,ihalo)* & 1689 nyrecvp(ipatch,icomm,ihalo)* & 1690 nzrecvp(ipatch,icomm,ihalo) 1608 1691 END DO 1609 1692 END DO … … 1613 1696 WRITE (*,FMT="(I3,': ARPDBG: icomm = ',I2)") narea-1,icomm 1614 1697 WRITE (*,FMT="(I3,': ARPDBG: dir = ',I2)") narea-1,dir 1615 WRITE (*,FMT="(I3,': ARPDBG: proc = ',I3)") narea-1,proc 1616 WRITE (*,FMT="(I3,': ARPDBG: isrc = ',I3)") narea-1,cisrc(1) 1617 WRITE (*,FMT="(I3,': ARPDBG: jsrc = ',I3)") narea-1,cjsrc(1) 1618 WRITE (*,FMT="(I3,': ARPDBG: ides = ',I3)") narea-1,cides(1) 1619 WRITE (*,FMT="(I3,': ARPDBG: jdes = ',I3)") narea-1,cjdes(1) 1620 WRITE (*,FMT="(I3,': ARPDBG: nx = ',I3)") narea-1,cnx(1) 1621 WRITE (*,FMT="(I3,': ARPDBG: ny = ',I3)") narea-1,cny(1) 1698 WRITE (*,FMT="(I3,': ARPDBG: proc = ',I4)") narea-1,proc 1699 WRITE (*,FMT="(I3,': ARPDBG: isrc = ',I4)") narea-1,isrcrecv(icomm) 1700 WRITE (*,FMT="(I3,': ARPDBG: jsrc = ',I4)") narea-1,jsrcrecv(icomm) 1701 WRITE (*,FMT="(I3,': ARPDBG: ides = ',I4)") narea-1,idesrecv(icomm) 1702 WRITE (*,FMT="(I3,': ARPDBG: jdes = ',I4)") narea-1,jdesrecv(icomm) 1703 WRITE (*,FMT="(I3,': ARPDBG: nx = ',I4)") narea-1,nxrecv(icomm) 1704 WRITE (*,FMT="(I3,': ARPDBG: ny = ',I4)") narea-1,nyrecv(icomm) 1705 WRITE (*,FMT="(I3,': ARPDBG: nz = ',I4)") narea-1,nzrecv(icomm) 1622 1706 WRITE (*,FMT="(I3,': ARPDBG:npatch = ',I3)") narea-1,npatches(1) 1623 1707 DO ipatch=1,npatches(1) 1624 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': isrc = ',I 3)") &1708 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': isrc = ',I4)") & 1625 1709 narea-1,ipatch,isrcrecvp(ipatch,icomm,1) 1626 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': jsrc = ',I 3)") &1710 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': jsrc = ',I4)") & 1627 1711 narea-1,ipatch,jsrcrecvp(ipatch,icomm,1) 1628 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': ides = ',I 3)") &1712 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': ides = ',I4)") & 1629 1713 narea-1,ipatch,idesrecvp(ipatch,icomm,1) 1630 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': jdes = ',I 3)") &1714 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': jdes = ',I4)") & 1631 1715 narea-1,ipatch,jdesrecvp(ipatch,icomm,1) 1632 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': nx = ',I 3)") &1716 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': nx = ',I4)") & 1633 1717 narea-1,ipatch,nxrecvp(ipatch,icomm,1) 1634 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': ny = ',I 3)") &1718 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': ny = ',I4)") & 1635 1719 narea-1,ipatch,nyrecvp(ipatch,icomm,1) 1720 WRITE (*,FMT="(I3,': ARPDBG: patch ',I2,': nz = ',I4)") & 1721 narea-1,ipatch,nzrecvp(ipatch,icomm,1) 1636 1722 END DO 1637 1723 WRITE (*,FMT="(I3,': ARPDBG:nrecvp = ',I4)") narea-1,nrecvp(icomm,1) … … 1644 1730 1645 1731 1646 SUBROUTINE clip_msg(depth, iloc, jloc, irem, jrem, nx, ny, & 1647 ciloc,cjloc,cirem,cjrem,cnx,cny,& 1648 riloc,rjloc,rirem,rjrem,rnx,rny,& 1732 SUBROUTINE clip_msg(depth, ibotlvl, & 1733 iloc, jloc, irem, jrem, nx, ny, & 1734 ciloc,cjloc,cirem,cjrem,cnx,cny,cnz, & 1735 riloc,rjloc,rirem,rjrem,rnx,rny,rnz, & 1649 1736 npatches, something_left) 1650 !!------------------------------------------------------------------ 1651 ! 1652 ! Clip any exterior rows or columns that are permanently dry 1653 ! from the message. 1654 ! 1655 ! depth real input Land/sea mask - global coords 1656 ! iloc int input local X coordinate of data start 1657 ! jloc int input local Y coordinate of data start 1658 ! irem int input remote X coordinate of data 1659 ! jrem int input remote Y coordinate of data 1660 ! nx int input Size in X of data to be sent 1661 ! ny int input Size in Y of data to be sent 1662 ! ciloc int output As iloc, after clipping 1663 ! cjloc int output As jloc, after clipping 1664 ! cirem int output As irem, after clipping 1665 ! cjrem int output As jrem, after clipping 1666 ! cnx int output As nx, after clipping 1667 ! cny int output As ny, after clipping 1668 ! 1669 ! The run-length encoded versions split a message into one 1670 ! or more patches, leaving out permanently dry rows/columns 1671 ! 1672 ! riloc int output As iloc, run-length encoded 1673 ! rjloc int output As jloc, run-length encoded 1674 ! rirem int output As irem, run-length encoded 1675 ! rjrem int output As jrem, run-length encoded 1676 ! rnx int output As nx, run-length encoded 1677 ! rny int output As ny, run-length encoded 1678 ! npatches int output Number of patches 1679 ! 1680 ! something_left logical output 1681 ! 1682 ! Stephen Pickles, STFC Daresbury Laboratory, August 2009 1683 ! - Written 1684 ! Stephen Pickles, STFC Daresbury Laboratory, September 2009 1685 ! - Added run-length encoding 1686 !!------------------------------------------------------------------ 1737 !!------------------------------------------------------------------ 1738 ! 1739 ! Clip any exterior rows or columns that are permanently dry 1740 ! from the message. Also remove any vertical levels that are 1741 ! beneath the ocean floor. 1742 ! 1743 ! depth int input Land/sea mask - global coords 1744 ! ibotlvl int input Index of the last vertical level 1745 ! above sea floor 1746 ! iloc int input local X coordinate of data start 1747 ! jloc int input local Y coordinate of data start 1748 ! irem int input remote X coordinate of data 1749 ! jrem int input remote Y coordinate of data 1750 ! nx int input Size in X of data to be sent 1751 ! ny int input Size in Y of data to be sent 1752 ! ciloc int output As iloc, after clipping 1753 ! cjloc int output As jloc, after clipping 1754 ! cirem int output As irem, after clipping 1755 ! cjrem int output As jrem, after clipping 1756 ! cnx int output As nx, after clipping 1757 ! cny int output As ny, after clipping 1758 ! 1759 ! The run-length encoded versions split a message into one 1760 ! or more patches, leaving out permanently dry rows/columns 1761 ! 1762 ! riloc int output As iloc, run-length encoded 1763 ! rjloc int output As jloc, run-length encoded 1764 ! rirem int output As irem, run-length encoded 1765 ! rjrem int output As jrem, run-length encoded 1766 ! rnx int output As nx, run-length encoded 1767 ! rny int output As ny, run-length encoded 1768 ! rnz int output Max depth (level) of this patch 1769 ! npatches int output Number of patches 1770 ! 1771 ! something_left logical output 1772 ! 1773 ! Stephen Pickles, STFC Daresbury Laboratory, August 2009 1774 ! - Written 1775 ! Stephen Pickles, STFC Daresbury Laboratory, September 2009 1776 ! - Added run-length encoding 1777 ! Andrew Porter, STFC Daresbury Laboratory, January 2013 1778 ! - Added trimming of levels below sea floor 1779 !!------------------------------------------------------------------ 1687 1780 USE dom_oce, ONLY: nimpp, njmpp 1688 1781 IMPLICIT none 1689 1782 ! Subroutine arguments. 1690 1783 INTEGER, DIMENSION(:,:), INTENT(in) :: depth ! Global mask (0 dry, 1 wet) 1784 INTEGER, DIMENSION(:,:), INTENT(in) :: ibotlvl ! Bottom level of ocean 1691 1785 INTEGER, DIMENSION(jpreci) :: iloc, jloc, irem, jrem, nx, ny 1692 INTEGER, DIMENSION(jpreci) :: ciloc,cjloc,cirem,cjrem,cnx,cny 1693 INTEGER, DIMENSION(MaxPatch,jpreci) :: riloc,rjloc,rirem,rjrem,rnx,rny 1786 INTEGER, DIMENSION(jpreci) :: ciloc,cjloc,cirem,cjrem,cnx,cny,cnz 1787 INTEGER, DIMENSION(MaxPatch,jpreci) :: riloc,rjloc,rirem,rjrem,rnx,rny,rnz 1694 1788 INTEGER, DIMENSION(jpreci), INTENT(out) :: npatches 1695 LOGICAL, INTENT(out):: something_left1789 LOGICAL, INTENT(out) :: something_left 1696 1790 ! Local variables. 1697 1791 INTEGER :: h, i, j, patch 1698 1792 LOGICAL :: all_dry 1699 1793 1700 ! i, j limits of the halo patch, in local co-ordinates1794 ! i, j, k limits of the halo patch, in local co-ordinates 1701 1795 ! These are set from input arguments, then updated as we trim 1702 1796 INTEGER :: ilo, ihi, jlo, jhi … … 1708 1802 cnx(:) = nx(:) 1709 1803 cny(:) = ny(:) 1804 cnz(:) = jpk 1710 1805 riloc(1,:) = iloc(:) 1711 1806 rjloc(1,:) = jloc(:) … … 1714 1809 rnx(1,:) = nx(:) 1715 1810 rny(1,:) = ny(:) 1811 rnz(:,:) = jpk 1716 1812 npatches(:) = 1 1717 1813 something_left = .TRUE. … … 1730 1826 1731 1827 ! Can any points along the left (low i) edge be trimmed? 1732 left_edge: DO i=ilo, ihi 1828 left_edge: DO i=ilo, ihi - nextra 1733 1829 DO j=jlo, jhi 1734 1830 ! depth is global mask, i and j are local coords 1735 IF (depth(i+nimpp-1,j+njmpp-1) .NE. land) EXIT left_edge 1831 ! ARPDBG - not sure that nextra needed below? 1832 !IF (depth(i+nimpp-1+nextra,j+njmpp-1) .NE. LAND) EXIT left_edge 1833 IF (depth(i+nimpp-1,j+njmpp-1) .NE. LAND) EXIT left_edge 1736 1834 END DO 1737 1835 ciloc(h) = ciloc(h) + 1 … … 1743 1841 cnx(h) = 0 1744 1842 cny(h) = 0 1843 cnz(h) = 0 1745 1844 ciloc(h) = iloc(h) 1746 1845 npatches(h) = 0 … … 1757 1856 1758 1857 ! Can any points along the right (high i) edge be trimmed? 1759 right_edge: DO i=ihi, ilo , -11858 right_edge: DO i=ihi, ilo + nextra, -1 1760 1859 DO j=jlo, jhi 1860 ! IF (depth(i+nimpp-1-nextra,j+njmpp-1) .ne. land) exit right_edge 1761 1861 IF (depth(i+nimpp-1,j+njmpp-1) .ne. land) exit right_edge 1762 1862 END DO … … 1808 1908 make_patches_x: DO WHILE (patch .lt. MaxPatch) 1809 1909 1810 add_sea_cols: DO WHILE (i .lt. ihi) 1811 all_dry = .true. 1812 DO j=jlo, jhi 1813 IF (depth(i+nimpp-1,j+njmpp-1) .NE. land) THEN 1814 all_dry = .FALSE. 1815 END IF 1816 END DO 1817 IF (all_dry) EXIT add_sea_cols 1818 i = i+1 1819 rnx(patch,h) = rnx(patch,h) + 1 1820 END DO add_sea_cols 1910 IF(i == ihi)THEN 1911 1912 rnx(patch,h) = 1 1913 ELSE 1914 1915 add_sea_cols: DO WHILE (i .lt. ihi) 1916 ! Check this strip in y to see whether all points are dry 1917 ! !all_dry = .TRUE. 1918 !IF( ANY( depth(ilo+nimpp-1:ihi+nimpp-2,j+njmpp-1) .NE. LAND ) )all_dry = .FALSE. 1919 !IF( ALL( depth(i+nimpp-1,jlo+njmpp-1:jhi+njmpp-1) == LAND ) )EXIT add_sea_cols 1920 1921 all_dry = .TRUE. 1922 DO j=jlo, jhi 1923 IF (depth(i+nimpp-1,j+njmpp-1) .NE. land) THEN 1924 all_dry = .FALSE. 1925 END IF 1926 END DO 1927 IF (all_dry) EXIT add_sea_cols 1928 1929 rnx(patch,h) = rnx(patch,h) + 1 1930 i = i+1 1931 END DO add_sea_cols 1932 END IF 1821 1933 1822 1934 ! This patch is now finished. 1935 1936 ! Store max depth of ocean bottom in this patch. riloc holds the starting 1937 ! point of current patch in local coords. 1938 ! riloc(patch,h) + nimpp - 1 is same point in global coords 1939 ! End of patch is then at <start> + <length> - 1 1940 rnz(patch,h) = MAXVAL(ibotlvl(riloc(patch,h)+nimpp-1: & 1941 riloc(patch,h)+rnx(patch,h)+nimpp-2, & 1942 jlo+njmpp-1:jhi+njmpp-1) ) 1943 1823 1944 ! Skip land cols before starting the next patch. 1824 1945 … … 1849 1970 ! Finish the last patch 1850 1971 rnx(npatches(h),h) = ihi - riloc(npatches(h),h) + 1 1972 rnz(npatches(h),h) = MAXVAL(ibotlvl(riloc(npatches(h),h)+nimpp-1: & 1973 riloc(npatches(h),h)+rnx(npatches(h),h)+nimpp-2, & 1974 jlo+njmpp-1:jhi+njmpp-1) ) 1851 1975 1852 1976 ELSE … … 1856 1980 rnx(1,h) = cnx(h) 1857 1981 1858 make_patches_y: do while (patch .lt. MaxPatch) 1859 1860 add_sea_rows: do while (j .lt. jhi) 1861 all_dry = .true. 1862 do i=ilo, ihi 1863 if (depth(i+nimpp-1,j+njmpp-1) .ne. land) then 1864 all_dry = .false. 1865 end if 1866 end do 1867 if (all_dry) exit add_sea_rows 1868 j = j+1 1869 rny(patch,h) = rny(patch,h) + 1 1870 end do add_sea_rows 1871 1872 ! This patch is now finished. 1873 ! Skip land rows before starting the next patch. 1874 1875 skip_land_rows: do while (j .lt. jhi) 1876 do i=ilo, ihi 1877 if (depth(i+nimpp-1,j+njmpp-1) .ne. land) then 1878 exit skip_land_rows 1879 end if 1880 end do 1881 j = j+1 1882 end do skip_land_rows 1982 make_patches_y: DO WHILE (patch .lt. MaxPatch) 1983 1984 add_sea_rows: DO WHILE (j .lt. jhi) 1985 1986 ! IF( ALL( depth(ilo+nimpp-1:ihi+nimpp-1, & 1987 ! j+njmpp-1) == LAND ) )EXIT add_sea_rows 1988 1989 all_dry = .TRUE. 1990 DO i=ilo, ihi 1991 if (depth(i+nimpp-1,j+njmpp-1) .ne. land) then 1992 all_dry = .FALSE. 1993 end if 1994 END DO 1995 IF (all_dry) EXIT add_sea_rows 1996 1997 rny(patch,h) = rny(patch,h) + 1 1998 j = j+1 1999 END DO add_sea_rows 2000 2001 ! This patch is now finished. 2002 2003 ! Store max depth of ocean bottom in this patch 2004 rnz(patch,h) = MAXVAL(ibotlvl(ilo+nimpp-1:ihi+nimpp-1, & 2005 rjloc(patch,h)+njmpp-1: & 2006 rjloc(patch,h)+rny(patch,h)+njmpp-2) ) 2007 2008 ! Skip land rows before starting the next patch. 2009 2010 skip_land_rows: DO WHILE (j .lt. jhi) 2011 DO i=ilo, ihi 2012 IF (depth(i+nimpp-1,j+njmpp-1) .NE. LAND) THEN 2013 EXIT skip_land_rows 2014 END IF 2015 END DO 2016 j = j+1 2017 END DO skip_land_rows 1883 2018 1884 ! No more wet points? 1885 if (j .ge. jhi) exit make_patches_y 1886 1887 ! Start next patch 1888 patch = patch + 1 1889 npatches(h) = patch 1890 riloc(patch,h) = ilo 1891 rjloc(patch,h) = j 1892 rirem(patch,h) = cirem(h) 1893 rjrem(patch,h) = cjrem(h)+j-jlo 1894 rnx(patch,h) = cnx(h) 1895 rny(patch,h) = 0 1896 1897 end do make_patches_y 1898 1899 ! Finish the last patch 1900 rny(npatches(h),h) = jhi - rjloc(npatches(h),h) + 1 1901 1902 end if 2019 ! No more wet points? 2020 IF (j .ge. jhi) EXIT make_patches_y 2021 2022 ! Start next patch 2023 patch = patch + 1 2024 npatches(h) = patch 2025 riloc(patch,h) = ilo 2026 rjloc(patch,h) = j 2027 rirem(patch,h) = cirem(h) 2028 rjrem(patch,h) = cjrem(h)+j-jlo 2029 rnx(patch,h) = cnx(h) 2030 rny(patch,h) = 0 2031 2032 END DO make_patches_y 2033 2034 ! Finish the last patch 2035 rny(npatches(h),h) = jhi - rjloc(npatches(h),h) + 1 2036 rnz(npatches(h),h) = MAXVAL(ibotlvl(ilo+nimpp-1:ihi+nimpp-1, & 2037 rjloc(npatches(h),h)+njmpp-1: & 2038 rjloc(npatches(h),h)+rny(npatches(h),h)+njmpp-2) ) 2039 2040 END IF 2041 2042 ! Max depth for whole message is the maximum of the maximum depth of each 2043 ! patch. 2044 cnz(h) = MAXVAL(rnz(:,h)) 1903 2045 1904 2046 END DO haloes -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90
r3432 r3837 136 136 INTEGER, DIMENSION(jpni,jpnj) :: iimppt, ijmppt, ilcit, ilcjt ! local workspace 137 137 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: imask ! Local fake global land mask 138 INTEGER, ALLOCATABLE, DIMENSION(:,:), TARGET :: maxdepth ! Local fake global max depth mask 138 139 !!---------------------------------------------------------------------- 139 140 … … 427 428 428 429 ! ARPDBG - test comms setup 429 ALLOCATE(imask(jpiglo,jpjglo) )430 ALLOCATE(imask(jpiglo,jpjglo),maxdepth(jpiglo,jpjglo)) 430 431 imask(:,:) = 1 431 CALL mpp_test_comms(imask) 432 DEALLOCATE(imask) 432 maxdepth(:,:) = jpk 433 CALL mpp_test_comms(imask, maxdepth) 434 DEALLOCATE(imask, maxdepth) 433 435 434 436 END SUBROUTINE mpp_init -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/partition_mod.F90
r3432 r3837 1 1 MODULE partition_mod 2 USE par_oce, ONLY: jpni, jpnj, jp nij, jpi, jpj, jpim1, jpjm1, jpij, &2 USE par_oce, ONLY: jpni, jpnj, jpi, jpj, jpim1, jpjm1, jpij, & 3 3 jpreci, jprecj, jpk, jpkm1, jperio, jpiglo, jpjglo 4 4 USE dom_oce, ONLY: ln_zco, nbondi, nbondj, nidom, npolj, & … … 15 15 nwidthmax, & ! Width of widest northern domain 16 16 narea ! ID of local area (= rank + 1) 17 USE lib_mpp, ONLY: mppsize, mppsync, mpi_comm_opa, mpp_ini_north, & 18 ctl_stop, MAX_FACTORS, xfactors, yfactors, & 19 nn_pttrim, nn_cpnode 17 #if defined key_mpp_mpi 18 USE lib_mpp, ONLY: mppsize, mppsync, mpi_comm_opa, & 19 MAX_FACTORS, xfactors, yfactors, nn_pttrim, & 20 nn_cpnode 21 #endif 22 USE lib_mpp, ONLY: ctl_stop, ctl_warn 20 23 USE in_out_manager, ONLY: numout, lwp 21 24 USE mapcomm_mod, ONLY: ielb, ieub, mapcomms, pielb, pjelb, pieub, pjeub,& 22 25 iesub, jesub, jeub, ilbext, iubext, jubext, & 23 26 jlbext, pnactive, piesub, pjesub, jelb, pilbext, & 24 piubext, pjlbext, pjubext, 27 piubext, pjlbext, pjubext, nextra, & 25 28 nprocp ! No. of PEs to partition over 26 29 USE iom, ONLY: wp, jpdom_unknown, iom_open, iom_get, iom_close … … 31 34 ! (1 for ocean, 0 for land) 32 35 ! set in nemogcm.F90 36 INTEGER, SAVE, ALLOCATABLE, DIMENSION(:,:), TARGET :: ibotlevel ! Holds the bottom level of the ocean at each grid point - used for trimming halos in z direction 33 37 34 38 ! Parameters for the cost function used when evaluating different … … 67 71 REAL(wp),PARAMETER :: pv_awful = 1.0e20 68 72 69 !#define PARTIT_DEBUG70 71 PUBLIC imask, smooth_bathy73 #define PARTIT_DEBUG 74 75 PUBLIC imask, ibotlevel, smooth_global_bathy, global_bot_level, partition_mask_alloc 72 76 PUBLIC mpp_init3, partition_rk, partition_mca_rk, write_partition_map 73 77 74 78 CONTAINS 79 80 SUBROUTINE partition_mask_alloc(xsize, ysize, ierr) 81 !!------------------------------------------------------------------ 82 !! *** ROUTINE partition_mask_alloc *** 83 !! 84 !! Called from nemogcm to allocate the masks that are members of 85 !! this module 86 !! 87 !!------------------------------------------------------------------ 88 INTEGER, INTENT(in) :: xsize, ysize 89 INTEGER, INTENT(out):: ierr 90 91 ALLOCATE(imask(xsize,ysize), ibotlevel(xsize,ysize), Stat=ierr) 92 93 END SUBROUTINE partition_mask_alloc 94 75 95 76 96 SUBROUTINE mpp_init3() … … 240 260 241 261 ! Map out the communications for the partitioned domain. 242 CALL mapcomms (imask, jpiglo, jpjglo, jperio, ierr)262 CALL mapcomms (imask, ibotlevel, jpiglo, jpjglo, jperio, ierr) 243 263 IF ( ierr.NE.0 ) THEN 244 264 IF ( lwp ) WRITE(numout,*) 'Communications mapping failed : ',ierr … … 247 267 248 268 ! Prepare mpp north fold 249 IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 250 CALL mpp_ini_north 251 END IF 269 #if defined key_mpp_mpi 270 ! This invokes the version of the routine contained in this module 271 ! and not the original in lib_mpp.F90 272 CALL mpp_ini_north() 273 #endif 252 274 253 275 ! From mppini_2.h90: … … 271 293 272 294 ! ARPDBG - test comms setup 273 CALL mpp_test_comms(imask )295 CALL mpp_test_comms(imask, ibotlevel) 274 296 275 297 ! Free array holding mask used for partitioning … … 326 348 ENDIF 327 349 328 CALL flio_dom_set ( jpnij, narea-1, idid, iglo, iloc, iabsf, iabsl, & 350 #if defined key_mpp_mpi 351 CALL flio_dom_set ( mppsize, narea-1, idid, iglo, iloc, iabsf, iabsl, & 329 352 ihals, ihale, 'BOX', nidom) 353 #endif 330 354 331 355 END SUBROUTINE mpp_init_ioipsl … … 347 371 USE iom, ONLY: jpiglo, jpjglo, wp 348 372 USE par_oce, ONLY: jpni, jpnj 373 #if defined key_mpp_mpi 349 374 USE lib_mpp, ONLY: mppsize 375 #endif 350 376 IMPLICIT NONE 351 377 … … 355 381 INTEGER, INTENT(in) :: mask(:,:) 356 382 ! Local variables 383 #if defined key_mpp_mpi 357 384 INTEGER, DIMENSION(MAX_FACTORS) :: fx,fy 385 #endif 358 386 INTEGER :: f,gnactive & 359 387 ,i,ifax,ifin,ifx,ify,ilb,iproc,ist,isub,isub_old & … … 365 393 ! Clear the error flag. 366 394 ierr = 0 395 396 #if defined key_mpp_mpi 367 397 368 398 ! IMPORTANT: Set the number of PEs to partition over (mapcomm_mod … … 398 428 CALL finish_partition() 399 429 430 #endif 431 400 432 END SUBROUTINE partition_rk 401 433 … … 404 436 #if defined key_mpp_mpi 405 437 USE mpi 406 #endif 407 USE lib_mpp, ONLY: mppsize, ctl_stop, mpi_comm_opa, & 438 USE lib_mpp, ONLY: mppsize, mpi_comm_opa, & 408 439 nxfactors, nyfactors, xfactors, yfactors 440 #endif 441 USE lib_mpp, ONLY: ctl_stop 409 442 USE dom_oce, ONLY: narea 410 443 IMPLICIT NONE … … 423 456 ! Local variables 424 457 INTEGER :: ii 458 #if defined key_mpp_mpi 425 459 INTEGER, DIMENSION(MAX_FACTORS) :: fx, fy, factors 426 460 INTEGER, DIMENSION(MAX_FACTORS) :: df, multiplicity 461 #endif 427 462 INTEGER :: nfx, nfy, nfactors, ndf, nperms 428 463 INTEGER :: check_nprocx, check_nprocy, check_nprocp … … 437 472 INTEGER :: best_perm 438 473 REAL(wp), DIMENSION(2,pv_num_scores) :: best, gbest, wrst, gwrst 474 475 #if defined key_mpp_mpi 439 476 440 477 ! NEMO only has narea public and not the actual PE rank so … … 641 678 END IF 642 679 680 ! Set corresponding NEMO variables for PE grid, even though it is now 681 ! rather irregular 682 jpni = nprocx 683 jpnj = nprocy 684 643 685 IF (lwp) THEN 644 686 WRITE (numout,'(A39)',advance='no') & … … 688 730 END IF 689 731 732 #endif 733 690 734 END SUBROUTINE partition_mca_rk 691 735 … … 693 737 SUBROUTINE partition_rk_core( mask, nx, ny, maxfax, fx, nfx, fy, nfy, & 694 738 ierr ) 739 #if defined key_mpp_mpi 695 740 USE lib_mpp, ONLY: mppsize 741 #endif 696 742 IMPLICIT NONE 697 743 !!------------------------------------------------------------------ … … 1171 1217 1172 1218 IF ( depth(i,j) == 1 ) THEN 1173 newbound = MAX(i - jpreci , pielb(iproc))1219 newbound = MAX(i - jpreci - nextra, pielb(iproc)) 1174 1220 #if defined TRIM_DEBUG 1175 1221 IF ( lwp ) THEN … … 1213 1259 ! We've found a wet point in this column so this is as far 1214 1260 ! as we can trim. 1215 newbound = MIN(i + jpreci , pieub(iproc))1261 newbound = MIN(i + jpreci + nextra, pieub(iproc)) 1216 1262 #if defined TRIM_DEBUG 1217 1263 IF ( lwp ) THEN … … 1255 1301 DO i=MAX(1,pielb(iproc)-jpreci),MIN(jpiglo,pieub(iproc)+jpreci) 1256 1302 IF ( depth(i,j) == 1) THEN 1257 newbound = MAX(j - jpreci , pjelb(iproc))1303 newbound = MAX(j - jpreci - nextra, pjelb(iproc)) 1258 1304 #if defined TRIM_DEBUG 1259 1305 IF ( lwp ) THEN … … 1298 1344 DO i=MAX(1,pielb(iproc)-jpreci),MIN(jpiglo,pieub(iproc)+jpreci) 1299 1345 IF ( depth(i,j) == 1 ) THEN 1300 newbound = MIN(j + jpreci , pjeub(iproc))1346 newbound = MIN(j + jpreci + nextra, pjeub(iproc)) 1301 1347 #if defined TRIM_DEBUG 1302 1348 IF ( lwp ) then … … 1371 1417 END IF 1372 1418 1419 #if defined key_mpp_mpi 1373 1420 IF ( nn_pttrim ) THEN 1421 nextra = 2 1374 1422 CALL part_trim ( imask, trimmed, ierr ) 1375 1423 ELSE 1424 ! Need non-zero nextra because otherwise hit trouble with fields 1425 ! not being read from disk over land regions 1426 nextra = 2 1427 !nextra = 0 ! Don't need to back-off on message trimming 1428 ! if we're not trimming the domains 1376 1429 trimmed(1:4,1:nprocp) = .FALSE. 1377 1430 ENDIF 1431 #else 1432 trimmed(1:4,1:nprocp) = .FALSE. 1433 #endif 1378 1434 1379 1435 ! Lower boundary (long.) of sub-domain, GLOBAL coords … … 1475 1531 njmpp = njmpp - jprecj 1476 1532 END IF 1533 ! ARPDBG - should we allow for trimming of northern edge of 1534 ! sub-domains here? 1477 1535 jubext = pjubext(narea) 1478 1536 IF(jubext)THEN … … 1481 1539 END IF 1482 1540 1483 jelb = pjelb (narea) ! Lower bound of internal domain1484 jeub = pjeub (narea) ! Upper bound of internal domain1485 jesub = pjesub(narea) ! Extent of internal domain1486 1487 jpj = jesub + 2*jprecj ! jpj is the same for all domains - this is1488 ! what original decomposition did1489 nlcj = jpj1541 jelb = pjelb (narea) ! Lower bound of internal domain 1542 jeub = pjeub (narea) ! Upper bound of internal domain 1543 jesub = pjesub(narea) ! Extent of internal domain 1544 1545 jpj = jesub + 2*jprecj ! jpj is the same for all domains - this is 1546 ! what original decomposition did 1547 nlcj = jpj 1490 1548 1491 1549 ! Unlike the East-West boundaries, the global domain does not include … … 1540 1598 END SUBROUTINE finish_partition 1541 1599 1542 !!$ ARPDBG - we don't want to change the North-fold code for the minute 1543 !!$ SUBROUTINE mpp_ini_north 1544 !!$ !!---------------------------------------------------------------------- 1545 !!$ !! *** routine mpp_ini_north *** 1546 !!$ !! 1547 !!$ !! ** Purpose : Initialize special communicator for north folding 1548 !!$ !! condition together with global variables needed in the mpp folding 1549 !!$ !! 1550 !!$ !! ** Method : - Look for northern processors 1551 !!$ !! - Put their number in nrank_north 1552 !!$ !! - Create groups for the world processors and the north processors 1553 !!$ !! - Create a communicator for northern processors 1554 !!$ !! 1555 !!$ !! ** output 1556 !!$ !! njmppmax = njmpp for northern procs 1557 !!$ !! ndim_rank_north = number of processors in the northern line 1558 !!$ !! nrank_north (ndim_rank_north) = number of the northern procs. 1559 !!$ !! ngrp_world = group ID for the world processors 1560 !!$ !! ngrp_north = group ID for the northern processors 1561 !!$ !! ncomm_north = communicator for the northern procs. 1562 !!$ !! north_root = number (in the world) of proc 0 in the northern comm. 1563 !!$ !! nwidthmax = width of widest northern domain 1564 !!$ !! 1565 !!$ !! History : 1566 !!$ !! ! 03-09 (J.M. Molines, MPI only ) 1567 !!$ !! ! 08-09 (A.R. Porter - for new decomposition) 1568 !!$ !!---------------------------------------------------------------------- 1569 !!$ USE exchmod, ONLY: nrank_north, north_root, ndim_rank_north, & 1570 !!$ ncomm_north, ngrp_world, ngrp_north 1571 !!$ IMPLICIT none 1572 !!$#ifdef key_mpp_shmem 1573 !!$ CALL ctl_stop( ' mpp_ini_north not available in SHMEM' ) 1574 !!$# elif key_mpp_mpi 1575 !!$ INTEGER :: ierr 1576 !!$ INTEGER :: jproc 1577 !!$ INTEGER :: ii,ji 1578 !!$ !!---------------------------------------------------------------------- 1579 !!$ 1580 !!$ ! Look for how many procs on the northern boundary 1581 !!$ ! 1582 !!$ ndim_rank_north = 0 1583 !!$ nwidthmax = 0 1584 !!$ 1585 !!$ DO jproc=1,jpnij 1586 !!$ IF ( pjubext(jproc) ) THEN 1587 !!$ ndim_rank_north = ndim_rank_north + 1 1588 !!$ 1589 !!$ ! and for the width of the widest northern domain... 1590 !!$ IF(piesub(jproc) > nwidthmax)THEN 1591 !!$ nwidthmax = piesub(jproc) 1592 !!$ END IF 1593 !!$ END IF 1594 !!$ END DO 1595 !!$ nwidthmax = nwidthmax + 2*jpreci ! Allow for halos 1596 !!$ 1597 !!$ ! Allocate the right size to nrank_north 1598 !!$ ! 1599 !!$ ALLOCATE(nrank_north(ndim_rank_north)) 1600 !!$ 1601 !!$ ! Fill the nrank_north array with proc. number of northern procs. 1602 !!$ ! Note : the rank start at 0 in MPI 1603 !!$ ! 1604 !!$ ii=0 1605 !!$ DO ji = 1, jpnij 1606 !!$ IF ( pjubext(ji) ) THEN 1607 !!$ ii=ii+1 1608 !!$ nrank_north(ii)=ji-1 1609 !!$ END IF 1610 !!$ END DO 1611 !!$ ! create the world group 1612 !!$ ! 1613 !!$ CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 1614 !!$ ! 1615 !!$ ! Create the North group from the world group 1616 !!$ CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_north,nrank_north,ngrp_north,ierr) 1617 !!$ 1618 !!$ ! Create the North communicator , ie the pool of procs in the north group 1619 !!$ ! 1620 !!$ CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_north,ncomm_north,ierr) 1621 !!$ 1622 !!$ 1623 !!$ ! find proc number in the world of proc 0 in the north 1624 !!$ CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_north,1,0,ngrp_world,north_root,ierr) 1625 !!$#endif 1626 !!$ 1627 !!$ END SUBROUTINE mpp_ini_north 1628 1629 SUBROUTINE eval_partition( nx, ny, mask, score ) 1630 1631 ! Compute the cost function for the current partition 1632 ! 1633 ! Assume that the time taken for a run is proportional 1634 ! to the maximum over processors of: 1635 ! w_processing * cost_processing 1636 ! + w_communications * cost_communications 1637 ! Assume further that cost_processing goes as 1638 ! (number of wet points) + f_proc * (number of dry points) 1639 ! (with f_proc << 1) 1640 ! and that cost_communications goes as 1641 ! (cost of intra-node communications) + 1642 ! f_comm * (cost of inter-node communications) 1643 ! (with f_comm << 1) 1644 ! 1645 ! However, because of the possiblity of network contention, 1646 ! other factors may also matter, especially: 1647 ! total over sub-domains of halo points with off-node neighbours 1648 ! max over nodes of total off-node halo points and message counts 1649 ! 1650 ! With this in mind, we construct the ansatz 1651 ! maximum over processors of { 1652 ! w_1 * (number of wet points) 1653 ! + w_2 * (number of dry points) 1654 ! + w_3 * (halo points with off-node neighbours) 1655 ! + w_4 * (halo points with on-node neighbours) 1656 ! + ... 1657 ! } 1658 USE lib_mpp, ONLY: mppsize 1659 USE mapcomm_mod, ONLY: iprocmap, land 1660 IMPLICIT NONE 1661 ! Arguments 1600 1601 SUBROUTINE mpp_ini_north 1602 !!---------------------------------------------------------------------- 1603 !! *** routine mpp_ini_north *** 1604 !! 1605 !! ** Purpose : Initialize special communicator for north folding 1606 !! condition together with global variables needed in the mpp folding 1607 !! 1608 !! ** Method : - Look for northern processors 1609 !! - Put their number in nrank_north 1610 !! - Create groups for the world processors and the north 1611 !! processors 1612 !! - Create a communicator for northern processors 1613 !! 1614 !! ** output 1615 !! njmppmax = njmpp for northern procs 1616 !! ndim_rank_north = number of processors in the northern line 1617 !! nrank_north (ndim_rank_north) = number of the northern procs. 1618 !! ngrp_world = group ID for the world processors 1619 !! ngrp_north = group ID for the northern processors 1620 !! ncomm_north = communicator for the northern procs. 1621 !! north_root = number (in the world) of proc 0 in the northern comm. 1622 !! nwidthmax = width of widest northern domain 1623 !! 1624 !! History : 1625 !! ! 03-09 (J.M. Molines, MPI only ) 1626 !! ! 08-09 (A.R. Porter - for new decomposition) 1627 !!---------------------------------------------------------------------- 1628 USE par_oce, ONLY: jperio, jpni 1629 USE exchmod, ONLY: nrank_north, north_root, ndim_rank_north, & 1630 ncomm_north, ngrp_world, ngrp_north, & 1631 do_nfold, num_nfold_rows, nfold_npts 1632 USE dom_oce, ONLY: narea 1633 IMPLICIT none 1634 #ifdef key_mpp_shmem 1635 CALL ctl_stop('STOP', ' mpp_ini_north not available in SHMEM' ) 1636 # elif key_mpp_mpi 1637 INTEGER :: ierr 1638 INTEGER :: jproc 1639 INTEGER :: ii,ji 1640 !!---------------------------------------------------------------------- 1641 1642 ! Look for how many procs on the northern boundary 1643 ! 1644 ndim_rank_north = 0 1645 nwidthmax = 0 1646 do_nfold = .FALSE. 1647 1648 IF (.NOT. (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1) ) THEN 1649 ! No northern boundary to worry about 1650 RETURN 1651 END IF 1652 1653 DO jproc=1,mppsize,1 1654 IF ( pjubext(jproc) ) THEN 1655 1656 ! If trimming of dry land from sub-domains is enabled 1657 ! then check that this PE does actually have data to 1658 ! contribute to the N-fold. If trimming is not enabled 1659 ! then this condition will always be true for northern 1660 ! PEs. 1661 IF( pjeub(jproc) > (jpjglo - num_nfold_rows) )THEN 1662 1663 ndim_rank_north = ndim_rank_north + 1 1664 1665 ! and for the width of the widest northern domain... 1666 nwidthmax = MAX(nwidthmax, piesub(jproc)) 1667 ENDIF 1668 1669 END IF 1670 END DO 1671 nwidthmax = nwidthmax + 2*jpreci ! Allow for halos 1672 1673 ! Allocate the right size to nrank_north 1674 ! 1675 ALLOCATE(nrank_north(ndim_rank_north), nfold_npts(ndim_rank_north), & 1676 Stat=ierr) 1677 IF( ierr /= 0 )THEN 1678 CALL ctl_stop('STOP','mpp_ini_north: failed to allocate arrays') 1679 END IF 1680 1681 #if defined PARTIT_DEBUG 1682 IF(lwp)THEN 1683 WRITE(*,*) 'mpp_ini_north: no. of northern PEs = ',ndim_rank_north 1684 WRITE(*,*) 'mpp_ini_north: nwidthmax = ',nwidthmax 1685 END IF 1686 #endif 1687 ! Fill the nrank_north array with proc. number of northern procs. 1688 ! Note : ranks start at 0 in MPI 1689 ! 1690 ii=0 1691 DO ji = 1, mppsize, 1 1692 IF ( pjubext(ji) .AND. & 1693 (pjeub(ji) > (jpjglo - num_nfold_rows)) ) THEN 1694 ii=ii+1 1695 nrank_north(ii)=ji-1 1696 1697 ! Flag that this PE does do North-fold (with trimming, checking 1698 ! npolj is no longer sufficient) 1699 IF(ji == narea) do_nfold = .TRUE. 1700 1701 #if defined NO_NFOLD_GATHER 1702 ! How many data points will this PE have to send for N-fold? 1703 1704 ! No. of valid rows for n-fold = num_nfold_rows - <no. trimmed rows> 1705 ! = num_nfold_rows - jpjglo + pjeub(ji) 1706 1707 ! ARPDBG - could trim land-only rows/cols from this... 1708 nfold_npts(ii) = MAX(num_nfold_rows - jpjglo + pjeub(ji), 0) * & 1709 ( nleit(ji) - nldit(ji) + 1 ) 1710 #endif 1711 END IF 1712 END DO 1713 ! create the world group 1714 ! 1715 CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 1716 ! 1717 ! Create the North group from the world group 1718 CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_north,nrank_north, & 1719 ngrp_north,ierr) 1720 1721 ! Create the North communicator , ie the pool of procs in the north group 1722 ! 1723 CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_north,ncomm_north,ierr) 1724 1725 1726 ! find proc number in the world of proc 0 in the north 1727 CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_north,1,0,ngrp_world,north_root,ierr) 1728 1729 #endif 1730 1731 END SUBROUTINE mpp_ini_north 1732 1733 1734 SUBROUTINE eval_partition( nx, ny, mask, score ) 1735 1736 ! Compute the cost function for the current partition 1737 ! 1738 ! Assume that the time taken for a run is proportional 1739 ! to the maximum over processors of: 1740 ! w_processing * cost_processing 1741 ! + w_communications * cost_communications 1742 ! Assume further that cost_processing goes as 1743 ! (number of wet points) + f_proc * (number of dry points) 1744 ! (with f_proc << 1) 1745 ! and that cost_communications goes as 1746 ! (cost of intra-node communications) + 1747 ! f_comm * (cost of inter-node communications) 1748 ! (with f_comm << 1) 1749 ! 1750 ! However, because of the possiblity of network contention, 1751 ! other factors may also matter, especially: 1752 ! total over sub-domains of halo points with off-node neighbours 1753 ! max over nodes of total off-node halo points and message counts 1754 ! 1755 ! With this in mind, we construct the ansatz 1756 ! maximum over processors of { 1757 ! w_1 * (number of wet points) 1758 ! + w_2 * (number of dry points) 1759 ! + w_3 * (halo points with off-node neighbours) 1760 ! + w_4 * (halo points with on-node neighbours) 1761 ! + ... 1762 ! } 1763 #if defined key_mpp_mpi 1764 USE lib_mpp, ONLY: mppsize 1765 #endif 1766 USE mapcomm_mod, ONLY: iprocmap, land 1767 IMPLICIT NONE 1768 ! Arguments 1662 1769 INTEGER, INTENT(in) :: nx, ny 1663 1770 INTEGER, INTENT(in) :: mask(nx,ny) … … 1704 1811 ! next nn_cpnode ranks are assigned to node 1, etc 1705 1812 INTEGER, ALLOCATABLE :: node(:) 1813 1814 #if defined key_mpp_mpi 1706 1815 1707 1816 ALLOCATE(node(nprocp)) … … 1940 2049 DEALLOCATE(node) 1941 2050 2051 #endif 2052 1942 2053 END SUBROUTINE eval_partition 1943 2054 … … 2395 2506 2396 2507 2397 SUBROUTINE smooth_ bathy(inbathy)2508 SUBROUTINE smooth_global_bathy(inbathy, imask) 2398 2509 USE dom_oce 2399 USE domzgr 2510 USE domzgr, ONLY: rn_sbot_min, rn_sbot_max, rn_theta, rn_thetb, & 2511 rn_rmax, ln_s_sigma, rn_bb, rn_hc, fssig1, & 2512 namzgr_sco 2400 2513 USE in_out_manager, ONLY: numnam 2401 2514 IMPLICIT none 2402 2515 !!---------------------------------------------------------------------- 2403 !! Routine smooth_ bathy2516 !! Routine smooth_global_bathy 2404 2517 !! Replicates the smoothing done on the decomposed domain in zgr_sco() 2405 2518 !! in domzgr.F90. However, here the domain is NOT decomposed and … … 2408 2521 !! is done using a mask that is the same as that which is eventually 2409 2522 !! computed after zgr_sco() has been called. (The smoothing process 2410 !! below can change whether grid points are wet or dry.)2523 !! below can (erroneously) change whether grid points are wet or dry.) 2411 2524 !!---------------------------------------------------------------------- 2412 2525 REAL(wp), INTENT(inout), DIMENSION(:,:) :: inbathy ! The bathymetry to 2413 2526 ! be smoothed 2527 INTEGER, INTENT(inout), DIMENSION(:,:) :: imask ! Mask holding index of 2528 ! bottom level 2414 2529 ! Locals 2415 INTEGER :: ji, jj, j l, ierr2530 INTEGER :: ji, jj, jk, jl, ierr 2416 2531 INTEGER :: iip1, ijp1, iim1, ijm1 ! temporary integers 2417 2532 INTEGER :: x_size, y_size 2418 REAL(wp) :: zrmax, zri, zrj 2533 REAL(wp) :: zrmax, zri, zrj, zcoeft 2419 2534 REAL(wp), PARAMETER :: TOL_ZERO = 1.0E-20_wp ! Any value less than 2420 2535 ! this assumed zero 2421 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zenv, ztmp, zmsk, zbot 2536 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zenv, ztmp, zmsk, zbot, & 2537 zscosrf, zhbatt 2538 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgsigt3, zgdept 2422 2539 ! 2423 NAMELIST/namzgr_sco/ rn_sbot_max, rn_sbot_min, rn_theta, rn_thetb, &2424 rn_rmax, ln_s_sigma, rn_bb, rn_hc2425 2540 !!---------------------------------------------------------------------- 2426 2541 … … 2431 2546 2432 2547 ALLOCATE(zenv(x_size,y_size), ztmp(x_size,y_size), zmsk(x_size,y_size), & 2433 zbot(x_size,y_size), Stat=ierr) 2548 zbot(x_size,y_size), zgdept(x_size,y_size,jpkdta), zhbatt(x_size, y_size), & 2549 zscosrf(x_size,y_size), zgsigt3(x_size,y_size,jpkdta), Stat=ierr) 2434 2550 IF( ierr /= 0 ) THEN 2435 CALL ctl_stop('smooth_ bathy: ERROR - failed to allocate workspace arrays')2551 CALL ctl_stop('smooth_global_bathy: ERROR - failed to allocate workspace arrays') 2436 2552 RETURN 2437 2553 ENDIF … … 2441 2557 READ ( numnam, namzgr_sco ) 2442 2558 2559 zscosrf(:,:) = 0._wp ! ocean surface depth (here zero: no under ice-shelf sea) 2443 2560 zbot(:,:) = inbathy(:,:) ! ocean bottom depth 2444 2561 ! ! set maximum ocean depth … … 2477 2594 2478 2595 ! 2479 IF(lwp)WRITE(numout,"('smooth_ bathy : iter=',I5,' rmax=',F8.4,' nb of pt= ',I8)") &2596 IF(lwp)WRITE(numout,"('smooth_global_bathy : iter=',I5,' rmax=',F8.4,' nb of pt= ',I8)") & 2480 2597 jl, zrmax, INT( SUM(zmsk(:,:) ) ) 2481 2598 ! … … 2491 2608 ijm1 = MAX( jj-1, 1 ) ! first raw (jj=nlcj) 2492 2609 IF( zmsk(ji,jj) == 1._wp ) THEN 2493 ztmp(ji,jj) = (&2494 & zenv(iim1,ijp1)*zmsk(iim1,ijp1) + zenv(ji,ijp1)*zmsk(ji,ijp1) + zenv(iip1,ijp1)*zmsk(iip1,ijp1)&2495 & + zenv(iim1,jj )*zmsk(iim1,jj ) + zenv(ji,jj )* 2._wp + zenv(iip1,jj )*zmsk(iip1,jj )&2496 & + zenv(iim1,ijm1)*zmsk(iim1,ijm1) + zenv(ji,ijm1)*zmsk(ji,ijm1) + zenv(iip1,ijm1)*zmsk(iip1,ijm1)&2497 & ) / (&2498 & zmsk(iim1,ijp1) + zmsk(ji,ijp1) + zmsk(iip1,ijp1)&2499 & + zmsk(iim1,jj ) + 2._wp + zmsk(iip1,jj )&2500 & + zmsk(iim1,ijm1) + zmsk(ji,ijm1) + zmsk(iip1,ijm1)&2501 & 2610 ztmp(ji,jj) = ( & 2611 & zenv(iim1,ijp1)*zmsk(iim1,ijp1) + zenv(ji,ijp1)*zmsk(ji,ijp1) + zenv(iip1,ijp1)*zmsk(iip1,ijp1) & 2612 & + zenv(iim1,jj )*zmsk(iim1,jj ) + zenv(ji,jj )* 2._wp + zenv(iip1,jj )*zmsk(iip1,jj ) & 2613 & + zenv(iim1,ijm1)*zmsk(iim1,ijm1) + zenv(ji,ijm1)*zmsk(ji,ijm1) + zenv(iip1,ijm1)*zmsk(iip1,ijm1) & 2614 & ) / ( & 2615 & zmsk(iim1,ijp1) + zmsk(ji,ijp1) + zmsk(iip1,ijp1) & 2616 & + zmsk(iim1,jj ) + 2._wp + zmsk(iip1,jj ) & 2617 & + zmsk(iim1,ijm1) + zmsk(ji,ijm1) + zmsk(iip1,ijm1) & 2618 & ) 2502 2619 ENDIF 2503 2620 END DO … … 2514 2631 ! ! ================ ! 2515 2632 ! 2633 ! ! envelop bathymetry saved in zhbatt 2634 zhbatt(:,:) = zenv(:,:) 2635 ! gphit calculated in nemo_init->dom_init->dom_hgr and dom_hgr requires that 2636 ! partitioning already done. Could repeat its calculation here but since AMM doesn't 2637 ! require it we leave it out for the moment ARPDBG 2638 CALL ctl_warn( ' ARPDBG - NOT checking whether s-coordinates are tapered in vicinity of the Equator' ) 2639 !!$ IF( MINVAL( gphit(:,:) ) * MAXVAL( gphit(:,:) ) <= 0._wp ) THEN 2640 !!$ CALL ctl_warn( ' s-coordinates are tapered in vicinity of the Equator' ) 2641 !!$ DO jj = 1, jpj 2642 !!$ DO ji = 1, jpi 2643 !!$ ztaper = EXP( -(gphit(ji,jj)/8._wp)**2 ) 2644 !!$ hbatt(ji,jj) = rn_sbot_max * ztaper + hbatt(ji,jj) * ( 1._wp - ztaper ) 2645 !!$ END DO 2646 !!$ END DO 2647 !!$ ENDIF 2648 2516 2649 ! Subtract off rn_sbot_min so can check for land using zenv = LAND (0) 2517 2650 inbathy(:,:) = zenv(:,:) - rn_sbot_min 2518 2651 2519 !!$ IF(lwp)THEN 2520 !!$ OPEN(UNIT=1098, FILE='bathy_bottom.dat', STATUS='REPLACE', & 2521 !!$ ACTION='WRITE', IOSTAT=jj) 2522 !!$ IF(jj == 0)THEN 2523 !!$ DO jj = 1, y_size 2524 !!$ DO ji = 1, x_size 2525 !!$ WRITE (1098,"(I4,1x,I4,3(E14.4,1x))") ji, jj, & 2526 !!$ inbathy(ji,jj), zbot(ji,jj), & 2527 !!$ (inbathy(ji,jj)-zbot(ji,jj)) 2528 !!$ END DO 2529 !!$ WRITE (1098,*) 2530 !!$ END DO 2531 !!$ CLOSE(1098) 2532 !!$ END IF 2533 !!$ END IF 2534 2535 END SUBROUTINE smooth_bathy 2652 2653 ! ! ======================= 2654 ! ! s-ccordinate fields (gdep., e3.) 2655 ! ! ======================= 2656 ! 2657 ! non-dimensional "sigma" for model level depth at w- and t-levels 2658 2659 IF( ln_s_sigma ) THEN ! Song and Haidvogel style stretched sigma for depths 2660 ! ! below rn_hc, with uniform sigma in shallower waters 2661 DO ji = 1, x_size 2662 DO jj = 1, y_size 2663 2664 IF( zhbatt(ji,jj) > rn_hc ) THEN !deep water, stretched sigma 2665 DO jk = 1, jpk 2666 zgsigt3(ji,jj,jk) = -fssig1( REAL(jk,wp) , rn_bb ) 2667 END DO 2668 ELSE ! shallow water, uniform sigma 2669 DO jk = 1, jpk 2670 zgsigt3(ji,jj,jk) = ( REAL(jk-1,wp) + 0.5_wp ) / REAL(jpk-1,wp) 2671 END DO 2672 ENDIF 2673 ! 2674 DO jk = 1, jpk 2675 zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 2676 zgdept (ji,jj,jk) = zscosrf(ji,jj) + (zhbatt(ji,jj)-rn_hc)*zgsigt3(ji,jj,jk)+rn_hc*zcoeft 2677 END DO 2678 ! 2679 END DO ! for all jj's 2680 END DO ! for all ji's 2681 ELSE 2682 CALL ctl_stop('STOP', & 2683 'partition_mod::smooth_global_bathy() only supports ln_s_sigma = .TRUE. currently!') 2684 END IF 2685 2686 ! HYBRID scheme 2687 DO jj = 1, y_size 2688 DO ji = 1, x_size 2689 DO jk = 1, jpkm1 2690 IF( zbot(ji,jj) >= zgdept(ji,jj,jk) ) imask(ji,jj) = MAX( 2, jk ) 2691 IF( zbot(ji,jj) == 0._wp ) imask(ji,jj) = 0 2692 END DO 2693 END DO 2694 END DO 2695 2696 ! Dump to file for debugging ARPDBG 2697 IF(lwp)THEN 2698 OPEN(UNIT=1098, FILE='smoothed_bathy.dat', STATUS='REPLACE', & 2699 ACTION='WRITE', IOSTAT=jj) 2700 IF(jj == 0)THEN 2701 DO jj = 1, y_size 2702 DO ji = 1, x_size 2703 WRITE (1098,"(I4,1x,I4,3(E14.4,1x),I4)") ji, jj, & 2704 inbathy(ji,jj), zbot(ji,jj), & 2705 inbathy(ji,jj)-zbot(ji,jj), imask(ji,jj) 2706 END DO 2707 WRITE (1098,*) 2708 END DO 2709 CLOSE(1098) 2710 END IF 2711 END IF 2712 2713 END SUBROUTINE smooth_global_bathy 2714 2715 2716 SUBROUTINE global_bot_level(imask) 2717 USE par_oce, ONLY: jperio 2718 IMPLICIT none 2719 !!---------------------------------------------------------------------- 2720 !! Compute the deepest level for any of the u,v,w or T grids. (Code 2721 !! taken from zgr_bot_level() and intermediate arrays for U and V 2722 !! removed.) 2723 !!---------------------------------------------------------------------- 2724 INTEGER, DIMENSION(:,:), INTENT(inout) :: imask 2725 ! Locals 2726 INTEGER :: ji, jj 2727 INTEGER :: x_size, y_size 2728 2729 ! Do this because we've not decomposed the domain yet and therefore 2730 ! jpi,jpj,nlc{i,j} etc. are not set. 2731 x_size = SIZE(imask, 1) 2732 y_size = SIZE(imask, 2) 2733 2734 imask(:,:) = MAX( imask(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) 2735 2736 ! 2737 ! Compute and store the deepest bottom k-index of any grid-type at 2738 ! each grid point. 2739 ! For use in removing data below ocean floor from halo exchanges. 2740 DO jj = 1, y_size-1 2741 DO ji = 1, x_size-1 2742 imask(ji,jj) = MAX(imask(ji,jj)+1, & ! W (= T-level + 1) 2743 MIN( imask(ji+1,jj ) , imask(ji,jj) ), & ! U 2744 MIN( imask(ji ,jj+1) , imask(ji,jj) ) ) ! V 2745 END DO 2746 imask(x_size,jj) = imask(x_size-1,jj) 2747 END DO 2748 2749 ! Check on jperio because we've not set cyclic_bc in mapcomms yet 2750 IF(jperio == 1 .OR. jperio == 4 .OR. jperio == 6)THEN 2751 ! Impose global cyclic boundary conditions on the array holding the 2752 ! deepest level 2753 imask(1,:) = imask(x_size - 1, :) 2754 imask(x_size,:) = imask(2,:) 2755 END IF 2756 2757 ! Dump to file for debugging ARPDBG 2758 IF(lwp)THEN 2759 OPEN(UNIT=1098, FILE='bathy_bottom.dat', STATUS='REPLACE', & 2760 ACTION='WRITE', IOSTAT=jj) 2761 IF(jj == 0)THEN 2762 DO jj = 1, y_size 2763 DO ji = 1, x_size 2764 WRITE (1098,"(I4,1x,I4,1x,I4)") ji, jj, imask(ji,jj) 2765 END DO 2766 WRITE (1098,*) 2767 END DO 2768 CLOSE(1098) 2769 END IF 2770 END IF 2771 2772 END SUBROUTINE global_bot_level 2536 2773 2537 2774 END MODULE partition_mod -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c3d.h90
r2715 r3837 281 281 zahmeq = 5.0 * aht0 282 282 zahmm = min( 160000.0, ahm0) 283 zemax = MAXVAL ( e1t(:,:) * e2t(:,:), tmask(:,:,1) .GE. 0.5 ) 284 zemin = MINVAL ( e1t(:,:) * e2t(:,:), tmask(:,:,1) .GE. 0.5 ) 285 zeref = MAXVAL ( e1t(:,:) * e2t(:,:), & 286 & tmask(:,:,1) .GE. 0.5 .AND. ABS(gphit(:,:)) .GT. 50. ) 283 zemax = MAXVAL ( e1t(:,:) * e2t(:,:), MASK=(tmask(:,:,1) .GE. 0.5) ) 284 zemin = MINVAL ( e1t(:,:) * e2t(:,:), MASK=(tmask(:,:,1) .GE. 0.5) ) 285 zeref = MAXVAL ( e1t(:,:) * e2t(:,:), & 286 MASK=( (tmask(:,:,1) .GE. 0.5) .AND. & 287 (ABS(gphit(:,:)) .GT. 50.) ) ) 287 288 288 289 DO jj = 1, jpj -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r3432 r3837 706 706 IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//TRIM( sdf_n(jf)%wname ) 707 707 sdf(jf)%vcomp = sdf_n(jf)%vcomp 708 sdf(jf)%rotn = .FALSE. 709 ! Initialise arrays allocated in calling routine 710 sdf(jf)%fnow(:,:,:) = 0.0_wp 711 IF(ALLOCATED(sdf(jf)%fdta))sdf(jf)%fdta(:,:,:,:) = 0.0_wp 708 712 END DO 709 713 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r3432 r3837 179 179 END DO 180 180 ! ! fill sf with slf_i and control print 181 CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_core', 'flux formulation for ocean surface boundary condition', 'namsbc_core' ) 181 CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_core', & 182 'flux formulation for ocean surface boundary condition', & 183 'namsbc_core' ) 182 184 ! 183 185 ENDIF … … 258 260 END DO 259 261 END DO 262 260 263 CALL lbc_lnk( zwnd_i(:,:) , 'T', -1. ) 261 264 CALL lbc_lnk( zwnd_j(:,:) , 'T', -1. ) … … 346 349 END DO 347 350 END DO 351 348 352 CALL lbc_lnk( utau(:,:), 'U', -1. ) 349 353 CALL lbc_lnk( vtau(:,:), 'V', -1. ) -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SOL/solpcg.F90
r3211 r3837 89 89 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 90 90 USE wrk_nemo, ONLY: zgcr => wrk_2d_1 91 ! USE arpdebugging, ONLY: dump_array 91 92 !! 92 93 INTEGER, INTENT(inout) :: kindic ! solver indicator, < 0 if the conver- … … 97 98 REAL(wp) :: zgcad ! temporary scalars 98 99 REAL(wp), DIMENSION(2) :: zsum 100 INTEGER, SAVE :: istep = 0 ! ARPDBG 99 101 !!---------------------------------------------------------------------- 100 102 … … 107 109 zgcr = 0._wp 108 110 gcr = 0._wp 111 ! CALL dump_array(istep, 'gcx_pre_lbc', gcx, withHalos=.TRUE.) 109 112 110 113 CALL lbc_lnk( gcx, c_solver_pt, 1. ) ! lateral boundary condition 114 115 istep = istep + 1 116 ! CALL dump_array(istep, 'gcx', gcx, withHalos=.TRUE.) 117 ! CALL dump_array(istep, 'gcp', gcp(:,:,1), withHalos=.TRUE.) 118 ! CALL dump_array(istep, 'gcb', gcb, withHalos=.TRUE.) 119 ! CALL dump_array(istep, 'ua', ua(:,:,1), withHalos=.TRUE.) 111 120 112 121 ! gcr = gcb-a.gcx -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r3432 r3837 98 98 !! ** Action : Update pta arrays with the before rotated diffusion 99 99 !!---------------------------------------------------------------------- 100 ! USE arpdebugging, ONLY: dump_array 100 101 USE timing, ONLY: timing_start, timing_stop 101 102 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released … … 158 159 ENDIF 159 160 ! 161 ! CALL dump_array(kt, 'ptb', ptb(:,:,1,1), withHalos=.TRUE.) 160 162 ! ! =========== 161 163 !DIR$ SHORTLOOP -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90
r3211 r3837 235 235 IF( zdf_ddm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_ddm_init : unable to allocate arrays' ) 236 236 ! 237 ! Initialise new array 238 avs(:,:,:) = 0.0_wp 239 237 240 END SUBROUTINE zdf_ddm_init 238 241 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/arpdebugging.f90
r3432 r3837 11 11 CONTAINS 12 12 13 SUBROUTINE dump_rarray(count, name, field1, field2, withHalos) 13 SUBROUTINE dump_rarray(count, name, field1, field2, withHalos, & 14 toGlobal) 14 15 IMPLICIT none 15 16 INTEGER, INTENT(in) :: count ! What timestep we're on … … 18 19 REAL, INTENT(in), DIMENSION(:,:), OPTIONAL :: field2 19 20 LOGICAL, INTENT(in), OPTIONAL :: withHalos 21 LOGICAL, INTENT(in), OPTIONAL :: toGlobal 20 22 ! Locals 21 23 INTEGER :: ji, jj 22 24 CHARACTER (len=4) :: crank,ccount 23 LOGICAL :: lwithHalos 25 LOGICAL :: lwithHalos, ltoGlobal 24 26 INTEGER :: ibound, jbound 25 27 INTEGER, DIMENSION(2) :: shape1, shape2 … … 37 39 lwithHalos = .false. 38 40 IF(present(withHalos))lwithHalos = withHalos 41 ! By default we convert to global coordinates rather than those local 42 ! to this process 43 ltoGlobal = .true. 44 IF(present(toGlobal))ltoGlobal = toGlobal 39 45 40 46 WRITE(crank,FMT="(I4)") narea-1 … … 57 63 END DO 58 64 ELSE 59 DO jj=nldj,nlej,1 60 DO ji=nldi,nlei,1 61 WRITE(997,FMT=fmt_var) mig(ji),mjg(jj), & 62 field1(ji,jj) 63 END DO 64 END DO 65 66 IF(ltoGlobal)THEN 67 DO jj=nldj,nlej,1 68 DO ji=nldi,nlei,1 69 WRITE(997,FMT=fmt_var) mig(ji),mjg(jj), & 70 field1(ji,jj) 71 END DO 72 END DO 73 ELSE 74 DO jj=nldj,nlej,1 75 DO ji=nldi,nlei,1 76 WRITE(997,FMT=fmt_var) ji,jj, field1(ji,jj) 77 END DO 78 END DO 79 END IF 65 80 END IF 66 81 … … 71 86 72 87 IF(PRESENT(field2))THEN 73 DO ji=1,ibound,1 74 DO jj=1,jbound,1 75 WRITE(997,FMT=fmt_var) mig(ji), mjg(jj), & 76 field1(ji,jj),field2(ji,jj) 77 END DO 78 WRITE(997,*) 79 END DO 80 ELSE 81 DO ji=1,ibound,1 82 DO jj=1,jbound,1 83 WRITE(997,FMT=fmt_var) mig(ji), mjg(jj), field1(ji,jj) 84 END DO 85 WRITE(997,*) 86 END DO 88 IF(ltoGlobal)THEN 89 DO ji=1,ibound,1 90 DO jj=1,jbound,1 91 WRITE(997,FMT=fmt_var) mig(ji), mjg(jj), & 92 field1(ji,jj),field2(ji,jj) 93 END DO 94 WRITE(997,*) 95 END DO 96 ELSE 97 DO ji=1,ibound,1 98 DO jj=1,jbound,1 99 WRITE(997,FMT=fmt_var) ji, jj, field1(ji,jj), field2(ji,jj) 100 END DO 101 WRITE(997,*) 102 END DO 103 END IF 104 ELSE 105 IF(ltoGlobal)THEN 106 DO ji=1,ibound,1 107 DO jj=1,jbound,1 108 WRITE(997,FMT=fmt_var) mig(ji), mjg(jj), field1(ji,jj) 109 END DO 110 WRITE(997,*) 111 END DO 112 ELSE 113 DO ji=1,ibound,1 114 DO jj=1,jbound,1 115 WRITE(997,FMT=fmt_var) ji, jj, field1(ji,jj) 116 END DO 117 WRITE(997,*) 118 END DO 119 END IF 87 120 END IF 88 121 … … 94 127 95 128 96 SUBROUTINE dump_iarray(count, name, field1, field2, withHalos) 129 SUBROUTINE dump_iarray(count, name, field1, field2, withHalos, & 130 toGlobal) 97 131 IMPLICIT none 98 132 INTEGER, INTENT(in) :: count ! What timestep we're on … … 101 135 INTEGER, INTENT(in), DIMENSION(:,:), OPTIONAL :: field2 102 136 LOGICAL, INTENT(in), OPTIONAL :: withHalos 137 LOGICAL, INTENT(in), OPTIONAL :: toGlobal 103 138 ! Locals 104 139 INTEGER :: ji, jj 105 140 CHARACTER (len=4) :: crank,ccount 106 LOGICAL :: lwithHalos 141 LOGICAL :: lwithHalos, ltoGlobal 107 142 INTEGER :: ibound, jbound 108 143 INTEGER, DIMENSION(2) :: shape1, shape2 … … 120 155 lwithHalos = .false. 121 156 IF(present(withHalos))lwithHalos = withHalos 157 ! By default we convert to global coordinates rather than those local 158 ! to this process 159 ltoGlobal = .true. 160 IF(present(toGlobal))ltoGlobal = toGlobal 122 161 123 162 WRITE(crank,FMT="(I4)") narea-1 … … 156 195 DO ji=1,ibound,1 157 196 DO jj=1,jbound,1 158 WRITE(997,FMT=fmt_var) ji, jj, &197 WRITE(997,FMT=fmt_var) mig(ji), mjg(jj), & 159 198 field1(ji,jj),field2(ji,jj) 160 199 END DO … … 164 203 DO ji=1,ibound,1 165 204 DO jj=1,jbound,1 166 WRITE(997,FMT=fmt_var) ji, jj, field1(ji,jj)205 WRITE(997,FMT=fmt_var) mig(ji), mjg(jj), field1(ji,jj) 167 206 END DO 168 207 WRITE(997,*) -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r3432 r3837 76 76 USE timing, ONLY: timing_init, timing_finalize, timing_disable, timing_enable 77 77 78 !#define ARPDEBUG78 #define ARPDEBUG 79 79 80 80 IMPLICIT NONE … … 235 235 lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print 236 236 237 ! Calculate domain z dimensions as needed when partitioning. 238 ! This used to be done in par_oce.F90 when they were parameters rather 239 ! than variables 240 IF( Agrif_Root() ) THEN 241 jpk = jpkdta ! third dim 242 jpkm1 = jpk-1 ! inner domain indices 243 ENDIF 244 237 245 CALL timing_init ! Init timing module 238 246 CALL timing_disable ! but disable during startup … … 251 259 jpnj = 1 252 260 jpnij = jpni*jpnj 261 #endif 262 263 #if defined key_mpp_rkpart 264 ELSE 265 CALL ctl_stop( 'STOP', 'nemo_init : invalid inputs in namelist - cannot specify jpn{i,j}>0 when using recursive k-section paritioning!' ) 253 266 #endif 254 267 END IF … … 265 278 jpij = jpi*jpj ! jpi x j 266 279 #endif 267 jpk = jpkdta ! third dim268 jpkm1 = jpk-1 ! inner domain indices269 280 ENDIF 270 281 … … 581 592 582 593 SUBROUTINE nemo_recursive_partition( num_pes ) 583 USE dom_oce, ONLY: ln_zco, ntopo 584 USE iom, ONLY: jpiglo, jpjglo, wp, jpdom_unknown, & 585 iom_open, iom_get, iom_close 594 USE in_out_manager, ONLY: numnam 595 USE dom_oce, ONLY: ln_zco, ntopo 596 USE dom_oce, ONLY: gdepw_0, gdept_0, e3w_0, e3t_0, & 597 mig, mjg, mi0, mi1, mj0, mj1, mbathy, bathy 598 USE domzgr, ONLY: zgr_z, zgr_bat, namzgr, zgr_zco, zgr_zps 599 USE closea, ONLY: dom_clo 600 USE domain, ONLY: dom_nam 601 USE iom, ONLY: jpiglo, jpjglo, wp, jpdom_unknown, & 602 iom_open, iom_get, iom_close 586 603 USE mapcomm_mod, ONLY: ielb, ieub, pielb, pjelb, pieub, pjeub, & 587 604 iesub, jesub, jeub, ilbext, iubext, jubext, & 588 605 jlbext, pnactive, piesub, pjesub, jelb, pilbext, & 589 piubext, pjlbext, pjubext, LAND 590 USE partition_mod, ONLY: partition_rk, partition_mca_rk, imask, smooth_bathy 606 piubext, pjlbext, pjubext, LAND, msgtrim_z 607 USE partition_mod, ONLY: partition_rk, partition_mca_rk, & 608 imask, ibotlevel, partition_mask_alloc, & 609 smooth_global_bathy, global_bot_level 591 610 USE par_oce, ONLY: do_exchanges 592 611 #if defined key_mpp_mpi … … 607 626 INTEGER :: ii,jj,iproc ! Loop index 608 627 INTEGER :: jparray(2) ! Small array for gathering 628 CHARACTER(LEN=8) :: lstr ! Local string for reading env. var. 629 INTEGER :: lztrim ! Local int for " " " 609 630 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdta ! temporary data workspace 610 631 !!---------------------------------------------------------------------- 611 632 612 ! Allocate masking array (stored in partition_mod) and workspace array 613 ! for this routine 614 ALLOCATE(imask(jpiglo,jpjglo), zdta(jpiglo,jpjglo), Stat=ierr) 633 ! Allocate masking arrays used in partitioning 634 CALL partition_mask_alloc(jpiglo,jpjglo,ierr) 635 IF(ierr /= 0)THEN 636 CALL ctl_stop('nemo_recursive_partition: failed to allocate masking arrays') 637 RETURN 638 END IF 639 640 ! Allocate local workspace array for this routine 641 ALLOCATE(zdta(jpiglo,jpjglo), Stat=ierr) 615 642 IF(ierr /= 0)THEN 616 643 CALL ctl_stop('nemo_recursive_partition: failed to allocate workspace arrays') … … 618 645 END IF 619 646 647 ! Check whether user has specified halo trimming in z via environment variable 648 ! Halo trimming in z is on by default 649 msgtrim_z = .TRUE. 650 CALL GET_ENVIRONMENT_VARIABLE(NAME='NEMO_MSGTRIM_Z', VALUE=lstr, STATUS=ierr) 651 IF( ierr == 0)THEN 652 READ(lstr,FMT="(I)",IOSTAT=ierr) lztrim 653 IF(ierr == 0)THEN 654 IF (lztrim == 0) msgtrim_z = .FALSE. 655 ELSE 656 CALL ctl_warn('nemo_recursive_partition: failed to parse value of NEMO_MSGTRIM_Z environment variable: '//TRIM(lstr)) 657 END IF 658 END IF 659 660 WRITE(*,*) 'ARPDBG: msgtrim_z = ',msgtrim_z 661 620 662 ! Factorise the number of MPI PEs to get jpi and jpj as usual 621 663 CALL nemo_partition(num_pes) 622 664 623 ! Generate a global mask... 624 !!$#if defined ARPDEBUG 625 !!$ IF(lwp)THEN 626 !!$ WRITE(*,*) 'ARPDBG: nemo_recursive_partition: generating mask...' 627 !!$ WRITE(*,*) 'ARPDBG: nemo_recursive_partition: jp{i,j}glo = ',jpiglo,jpjglo 628 !!$ END IF 629 !!$#endif 630 631 ! ARPDBG - this is the correct variable to check but the dom_nam section 632 ! of the namelist file hasn't been read in at this stage. 633 ! IF( ntopo == 1 )THEN 634 ! open the file 635 ierr = 0 636 !!$ IF ( ln_zco ) THEN 637 !!$ ! Setting ldstop prevents ctl_stop() from being called if the file 638 !!$ ! doesn't exist 639 !!$ CALL iom_open ( 'bathy_level.nc', inum, ldstop=.FALSE. ) ! Level bathymetry 640 !!$ IF(inum > 0)CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, & 641 !!$ kstart=(/jpizoom,jpjzoom/), & 642 !!$ kcount=(/jpiglo,jpjglo/) ) 643 !!$ ELSE 644 CALL iom_open ( 'bathy_meter.nc', inum, ldstop=.FALSE. ) ! Meter bathy in case of partial steps 645 IF(inum > 0)CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, & 646 kstart=(/jpizoom,jpjzoom/), & 647 kcount=(/jpiglo,jpjglo/) ) 648 !!$ ENDIF 649 IF(inum > 0)THEN 650 CALL iom_close (inum) 651 ELSE 652 ! Flag that an error occurred when reading the file 653 ierr = 1 654 ENDIF 655 ! ELSE 656 ! ! Topography not read from file in this case 657 ! ierr = 1 658 ! END IF 659 660 ! If ln_sco defined then the bathymetry gets smoothed before the 661 ! simulation begins and that process can alter the coastlines 662 ! therefore we do it here too before calculating our mask. 663 ! IF(ln_sco) 664 CALL smooth_bathy(zdta) 665 ! ============================ 666 ! Generate a global mask from the model bathymetry 667 ! ============================ 668 669 ! Read the z-coordinate options from the namelist file 670 REWIND(numnam) 671 READ (numnam, namzgr) 672 673 ! Read domain options from namelist file 674 CALL dom_nam() 675 676 ! Allocate these arrays so we can use domzgr::zgr_z routine; free them at 677 ! when we're done so as not to upset the 'official' allocation once 678 ! the domain decomposition is done. 679 ALLOCATE(gdepw_0(jpk), gdept_0(jpk), e3w_0(jpk), e3t_0(jpk), & 680 ! Need many global, 3D arrays if zgr_zco is to be called 681 !gdepw(jpiglo,jpjglo,jpk), gdept(jpiglo,jpjglo,jpk), & 682 !gdep3w(jpiglo,jpjglo,jpk), e3t(jpiglo,jpjglo,jpk), & 683 mig(jpiglo), mjg(jpjglo), & 684 mbathy(jpiglo,jpjglo), bathy(jpiglo,jpjglo), Stat=ierr) 685 IF(ierr /= 0)THEN 686 CALL ctl_stop('nemo_recursive_partition: failed to allocate zgr_z() arrays') 687 RETURN 688 END IF 689 690 ! Set-up reference depth coordinates 691 CALL zgr_z() 692 693 ! Set-up sub-domain limits as global domain for zgr_bat() 694 nldi = 2 ; nlci = jpiglo - 1 695 nldj = 2 ; nlcj = jpjglo - 1 696 jpi = jpiglo 697 jpj = jpjglo 698 699 ! Set-up fake m{i,j}g arrays for zgr_bat() call 700 DO ii = 1, jpiglo, 1 701 mig(ii) = ii 702 mi0(ii) = ii 703 mi1(ii) = ii 704 END DO 705 DO jj = 1, jpjglo, 1 706 mjg(jj) = jj 707 mj0(jj) = jj 708 mj1(jj) = jj 709 END DO 710 711 ! Initialise closed seas so loop over closed seas in zgr_bat works 712 CALL dom_clo() 713 714 ! Read-in bathy (if required) of global domain 715 CALL zgr_bat(.TRUE.) 665 716 666 717 ! land/sea mask (zero on land, 1 otherwise) over the global/zoom domain 667 718 imask(:,:)=1 668 IF(ierr == 1)THEN 669 ! Failed to read bathymetry so assume all ocean 670 WRITE(*,*) 'ARPDBG: nemo_recursive_partition: no bathymetry file so setting mask to unity' 671 672 ! Mess with otherwise uniform mask to get an irregular decomposition 673 ! for testing ARPDBG 674 CALL generate_fake_land(imask) 675 ELSE 676 ! Comment-out line below to achieve a regular partition 677 WHERE ( zdta(:,:) <= 1.0E-20 ) imask = LAND 719 720 ! Copy bathymetry in case we need to smooth it 721 zdta(:,:) = bathy(:,:) 722 723 IF(ln_sco)THEN 724 ! If ln_sco defined then the bathymetry gets smoothed before the 725 ! simulation begins and that process can alter the coastlines (bug!) 726 ! therefore we do it here too before calculating our mask. 727 CALL smooth_global_bathy(zdta, mbathy) 728 ELSE IF(ln_zps)THEN 729 CALL zgr_zps(.TRUE.) 730 ELSE IF(ln_zco)THEN 731 ! Not certain this is required since mbathy computed in zgr_bat() 732 ! in this case. 733 !CALL zgr_zco() 678 734 END IF 735 736 ! Compute the deepest/last ocean level for every point on the grid 737 ibotlevel(:,:) = mbathy(:,:) 738 CALL global_bot_level(ibotlevel) 739 740 ! Comment-out line below to achieve a regular partition 741 WHERE ( zdta(:,:) <= 1.0E-20 ) imask = LAND 679 742 680 743 ! Allocate partitioning arrays. … … 694 757 695 758 ! Now we can do recursive k-section partitioning 696 ! ARPDBG - BUG if limits on array below are set to anything other than 697 ! 1 and jp{i,j}glo then check for external boundaries in a few lines 698 ! time WILL FAIL! 699 ! CALL partition_rk ( imask, 1, jpiglo, 1, jpjglo, ierr ) 700 701 ! Multi-core aware version of recursive k-section partitioning 759 ! ARPDBG - BUG if limits on array below are set to anything other than 760 ! 1 and jp{i,j}glo then check for external boundaries in a few lines 761 ! time WILL FAIL! 762 ! CALL partition_rk ( imask, 1, jpiglo, 1, jpjglo, ierr ) 763 764 ! Multi-core aware version of recursive k-section partitioning. Currently 765 ! only accounts for whether a grid point is wet or dry. It has no knowledge 766 ! of the number of wet levels at a point. 702 767 CALL partition_mca_rk ( imask, 1, jpiglo, 1, jpjglo, ierr ) 703 768 … … 708 773 ENDIF 709 774 710 ! Set the mask correctly now we've partitioned 775 ! If we used generate_fake_land() above then we must set 776 ! the mask correctly now we've partitioned. This is only 777 ! necessary when testing. 711 778 !WHERE ( zdta(:,:) <= 0. ) imask = 0 712 779 713 ! ARPDBG Quick and dirty dump to stdout in gnuplot form 714 !!$ IF(narea == 1)THEN 715 !!$ OPEN(UNIT=998, FILE="imask.dat", & 716 !!$ STATUS='REPLACE', ACTION='WRITE', IOSTAT=jj) 717 !!$ IF( jj == 0 )THEN 718 !!$ WRITE (998,*) '# Depth map' 719 !!$ DO jj = 1, jpjglo, 1 720 !!$ DO ii = 1, jpiglo, 1 721 !!$ WRITE (998,*) ii, jj, zdta(ii,jj) ! imask(ii,jj) 722 !!$ END DO 723 !!$ WRITE (998,*) 724 !!$ END DO 725 !!$ CLOSE(998) 726 !!$ END IF 727 !!$ END IF 780 ! ARPDBG Quick and dirty dump to stdout in gnuplot form 781 IF(narea == 1)THEN 782 OPEN(UNIT=998, FILE="imask.dat", & 783 STATUS='REPLACE', ACTION='WRITE', IOSTAT=jj) 784 IF( jj == 0 )THEN 785 WRITE (998,*) '# Depth map' 786 WRITE (998,*) '# i j bathy imask ibotlevel mbathy' 787 DO jj = 1, jpjglo, 1 788 DO ii = 1, jpiglo, 1 789 WRITE (998,"(I4,1x,I4,1x,E16.6,1x,I4,1x,I4,1x,I4)") & 790 ii, jj, zdta(ii,jj), imask(ii,jj), ibotlevel(ii,jj), mbathy(ii,jj) 791 END DO 792 WRITE (998,*) 793 END DO 794 CLOSE(998) 795 END IF 796 END IF 728 797 729 798 jpkm1 = jpk - 1 … … 742 811 743 812 #if defined ARPDEBUG 813 ! This output is REQUIRED by the check_nemo_comms.pl test script 744 814 WRITE (*,FMT="(I4,' : ARPDBG: ielb, ieub, iesub = ',3I5)") narea-1,& 745 815 ielb, ieub, iesub … … 758 828 ! false. 759 829 do_exchanges = .TRUE. 830 831 ! Free the domzgr/_oce member arrays that we used earlier in zgr_z() and 832 ! zgr_bat(). 833 DEALLOCATE(gdepw_0, gdept_0, e3w_0, e3t_0, mig, mjg, & 834 mbathy, bathy) 760 835 761 836 END SUBROUTINE nemo_recursive_partition -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/step.F90
r3432 r3837 38 38 USE asminc ! assimilation increments (tra_asm_inc, dyn_asm_inc routines) 39 39 USE timing, ONLY: timing_start, timing_stop, timing_reset, timing_disable 40 USE arpdebugging, ONLY: dump_array 40 41 IMPLICIT NONE 41 42 PRIVATE … … 266 267 IF( ln_asmiau .AND. & 267 268 & ln_dyninc ) CALL dyn_asm_inc( kstp ) ! apply dynamics assimilation increment 269 !CALL dump_array(kstp,'un_pre_adv',un(:,:,27), & 270 ! withHalos=.TRUE.) 271 268 272 !CALL timing_start('dyn_adv') 269 273 CALL dyn_adv( kstp ) ! advection (vector or flux form) 270 274 !CALL timing_stop('dyn_adv','section') 271 275 276 !CALL dump_array(kstp,'ua_pre_vor',ua(:,:,27), & 277 ! withHalos=.TRUE.) 278 272 279 !CALL timing_start('dyn_vor') 273 280 CALL dyn_vor( kstp ) ! vorticity term including Coriolis 274 281 !CALL timing_stop('dyn_vor','section') 275 282 283 !CALL dump_array(kstp,'ua_pre_ldf',ua(:,:,27), & 284 ! withHalos=.TRUE.) 285 276 286 !CALL timing_start('dyn_ldf') 277 287 CALL dyn_ldf( kstp ) ! lateral mixing … … 281 291 IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_dyn ! momemtum sponge 282 292 #endif 293 !CALL dump_array(kstp,'ua_pre_hpg',ua(:,:,27), & 294 ! withHalos=.TRUE.) 295 283 296 !CALL timing_start('dyn_hpg') 284 297 CALL dyn_hpg( kstp ) ! horizontal gradient of Hydrostatic pressure 285 298 !CALL timing_stop('dyn_hpg','section') 286 299 300 !CALL dump_array(kstp,'ua_pre_bfr',ua(:,:,27), & 301 ! withHalos=.TRUE.) 302 287 303 !CALL timing_start('dyn_bfr') 288 304 CALL dyn_bfr( kstp ) ! bottom friction 289 305 !CALL timing_stop('dyn_bfr','section') 306 307 !CALL dump_array(kstp,'ua_pre_zdf',ua(:,:,27), & 308 ! withHalos=.TRUE.) 290 309 291 310 !CALL timing_start('dyn_zdf') 292 311 CALL dyn_zdf( kstp ) ! vertical diffusion 293 312 !CALL timing_stop('dyn_zdf','section') 313 314 !CALL dump_array(kstp,'ua_pre_spg',ua(:,:,27), & 315 ! withHalos=.TRUE.) 294 316 295 317 !CALL timing_start('dyn_spg') 296 318 CALL dyn_spg( kstp, indic ) ! surface pressure gradient 297 319 !CALL timing_stop('dyn_spg','section') 320 !CALL dump_array(kstp,'ua_spg',ua(:,:,27), & 321 ! withHalos=.TRUE.) 298 322 299 323 !CALL timing_start('dyn_nxt') 300 324 CALL dyn_nxt( kstp ) ! lateral velocity at next time step 325 !CALL timing_stop('dyn_nxt','section') 326 301 327 !CALL timing_stop('dyn_nxt','section') 302 328 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/timing.F90
r3432 r3837 370 370 s_wrk => NULL() 371 371 s_timer => s_timer_root 372 373 IF(.NOT. ASSOCIATED(s_timer_root))THEN 374 WRITE(numtime,*) 'No timing information available!' 375 WRITE(numtime,*) '(Have any timed sections been executed?)' 376 RETURN 377 END IF 378 372 379 DO 373 380 ll_ord = .TRUE. … … 776 783 TYPE(timer), POINTER, INTENT(inout) :: ptr 777 784 ! 785 IF(.NOT. ASSOCIATED(ptr))RETURN 786 778 787 IF( ASSOCIATED(ptr%next) ) CALL timing_list(ptr%next) 779 788 IF(lwp) WRITE(numout,*)' ', ptr%cname … … 816 825 ! 817 826 TYPE(timer), POINTER :: sl_temp 818 827 828 IF(.NOT. ASSOCIATED(sd_ptr)) RETURN 829 819 830 sl_temp => sd_ptr 820 831 sd_ptr => sd_ptr%next
Note: See TracChangeset
for help on using the changeset viewer.