- Timestamp:
- 2019-12-05T12:06:36+01:00 (4 years ago)
- Location:
- NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE
- Files:
-
- 3 deleted
- 111 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ASM/asminc.F90
r10425 r12065 147 147 REWIND( numnam_ref ) ! Namelist nam_asminc in reference namelist : Assimilation increment 148 148 READ ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901) 149 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_asminc in reference namelist' , lwp)149 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_asminc in reference namelist' ) 150 150 REWIND( numnam_cfg ) ! Namelist nam_asminc in configuration namelist : Assimilation increment 151 151 READ ( numnam_cfg, nam_asminc, IOSTAT = ios, ERR = 902 ) 152 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' , lwp)152 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' ) 153 153 IF(lwm) WRITE ( numond, nam_asminc ) 154 154 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdy_oce.F90
r10425 r12065 22 22 INTEGER , DIMENSION(jpbgrd) :: nblen 23 23 INTEGER , DIMENSION(jpbgrd) :: nblenrim 24 INTEGER , DIMENSION(jpbgrd) :: nblenrim0 24 25 INTEGER , POINTER, DIMENSION(:,:) :: nbi 25 26 INTEGER , POINTER, DIMENSION(:,:) :: nbj 26 27 INTEGER , POINTER, DIMENSION(:,:) :: nbr 27 28 INTEGER , POINTER, DIMENSION(:,:) :: nbmap 29 INTEGER , POINTER, DIMENSION(:,:) :: ntreat 28 30 REAL(wp), POINTER, DIMENSION(:,:) :: nbw 29 31 REAL(wp), POINTER, DIMENSION(:,:) :: nbd … … 40 42 TYPE, PUBLIC :: OBC_DATA !: Storage for external data 41 43 INTEGER , DIMENSION(2) :: nread 42 LOGICAL :: ll_ssh 43 LOGICAL :: ll_u2d 44 LOGICAL :: ll_v2d 45 LOGICAL :: ll_u3d 46 LOGICAL :: ll_v3d 47 LOGICAL :: ll_tem 48 LOGICAL :: ll_sal 49 LOGICAL :: ll_fvl 44 LOGICAL :: lneed_ssh 45 LOGICAL :: lneed_dyn2d 46 LOGICAL :: lneed_dyn3d 47 LOGICAL :: lneed_tra 48 LOGICAL :: lneed_ice 50 49 REAL(wp), POINTER, DIMENSION(:) :: ssh 51 50 REAL(wp), POINTER, DIMENSION(:) :: u2d … … 55 54 REAL(wp), POINTER, DIMENSION(:,:) :: tem 56 55 REAL(wp), POINTER, DIMENSION(:,:) :: sal 57 #if defined key_si3 58 LOGICAL :: ll_a_i 59 LOGICAL :: ll_h_i 60 LOGICAL :: ll_h_s 61 REAL(wp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology 62 REAL(wp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology 63 REAL(wp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness 64 #endif 56 REAL(wp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology 57 REAL(wp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology 58 REAL(wp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness 59 REAL(wp), POINTER, DIMENSION(:,:) :: t_i !: now ice temperature 60 REAL(wp), POINTER, DIMENSION(:,:) :: t_s !: now snow temperature 61 REAL(wp), POINTER, DIMENSION(:,:) :: tsu !: now surf temperature 62 REAL(wp), POINTER, DIMENSION(:,:) :: s_i !: now ice salinity 63 REAL(wp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration 64 REAL(wp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth 65 65 #if defined key_top 66 66 CHARACTER(LEN=20) :: cn_obc !: type of boundary condition to apply … … 74 74 !! Namelist variables 75 75 !!---------------------------------------------------------------------- 76 ! !!** nambdy ** 76 77 LOGICAL, PUBLIC :: ln_bdy !: Unstructured Ocean Boundary Condition 77 78 … … 85 86 ! 86 87 INTEGER :: nb_bdy !: number of open boundary sets 87 INTEGER :: nb_jpk_bdy !: number of levels in the bdy data (set < 0 if consistent with planned run)88 88 INTEGER, DIMENSION(jp_bdy) :: nn_rimwidth !: boundary rim width for Flow Relaxation Scheme 89 89 INTEGER :: nn_volctl !: = 0 the total volume will have the variability of the surface Flux E-P … … 108 108 INTEGER , DIMENSION(jp_bdy) :: nn_ice_dta !: = 0 use the initial state as bdy dta ; 109 109 !: = 1 read it in a NetCDF file 110 REAL(wp), DIMENSION(jp_bdy) :: rn_ice_tem !: choice of the temperature of incoming sea ice 111 REAL(wp), DIMENSION(jp_bdy) :: rn_ice_sal !: choice of the salinity of incoming sea ice 112 REAL(wp), DIMENSION(jp_bdy) :: rn_ice_age !: choice of the age of incoming sea ice 110 ! 111 ! !!** nambdy_dta ** 112 REAL(wp), DIMENSION(jp_bdy) :: rice_tem !: temperature of incoming sea ice 113 REAL(wp), DIMENSION(jp_bdy) :: rice_sal !: salinity of incoming sea ice 114 REAL(wp), DIMENSION(jp_bdy) :: rice_age !: age of incoming sea ice 115 REAL(wp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice 116 REAL(wp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice 113 117 ! 114 115 118 !!---------------------------------------------------------------------- 116 119 !! Global variables … … 128 131 INTEGER, DIMENSION(jp_bdy) :: nn_dta !: =0 => *all* data is set to initial conditions 129 132 !: =1 => some data to be read in from data files 130 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global !: workspace for reading in global data arrays (unstr. bdy)131 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global_z !: workspace for reading in global depth arrays (unstr. bdy)132 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global_dz !: workspace for reading in global depth arrays (unstr. bdy)133 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2 !: workspace for reading in global data arrays (struct. bdy)134 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2_z !: workspace for reading in global depth arrays (struct. bdy)135 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2_dz !: workspace for reading in global depth arrays (struct. bdy)136 133 !$AGRIF_DO_NOT_TREAT 137 134 TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET :: idx_bdy !: bdy indices (local process) 138 135 TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET :: dta_bdy !: bdy external data (local process) 139 136 !$AGRIF_END_DO_NOT_TREAT 137 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdy !: mark needed communication for given boundary, grid and neighbour 138 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdy !: when searching in any direction 139 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyint !: mark needed communication for given boundary, grid and neighbour 140 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyint !: when searching towards the interior of the computational domain 141 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyext !: mark needed communication for given boundary, grid and neighbour 142 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyext !: when searching towards the exterior of the computational domain 140 143 !!---------------------------------------------------------------------- 141 144 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdydta.F90
r12059 r12065 43 43 PUBLIC bdy_dta_init ! routine called by nemogcm.F90 44 44 45 INTEGER, ALLOCATABLE, DIMENSION(:) :: nb_bdy_fld ! Number of fields to update for each boundary set. 46 INTEGER :: nb_bdy_fld_sum ! Total number of fields to update for all boundary sets. 47 LOGICAL, DIMENSION(jp_bdy) :: ln_full_vel_array ! =T => full velocities in 3D boundary conditions 48 ! =F => baroclinic velocities in 3D boundary conditions 45 INTEGER , PARAMETER :: jpbdyfld = 16 ! maximum number of files to read 46 INTEGER , PARAMETER :: jp_bdyssh = 1 ! 47 INTEGER , PARAMETER :: jp_bdyu2d = 2 ! 48 INTEGER , PARAMETER :: jp_bdyv2d = 3 ! 49 INTEGER , PARAMETER :: jp_bdyu3d = 4 ! 50 INTEGER , PARAMETER :: jp_bdyv3d = 5 ! 51 INTEGER , PARAMETER :: jp_bdytem = 6 ! 52 INTEGER , PARAMETER :: jp_bdysal = 7 ! 53 INTEGER , PARAMETER :: jp_bdya_i = 8 ! 54 INTEGER , PARAMETER :: jp_bdyh_i = 9 ! 55 INTEGER , PARAMETER :: jp_bdyh_s = 10 ! 56 INTEGER , PARAMETER :: jp_bdyt_i = 11 ! 57 INTEGER , PARAMETER :: jp_bdyt_s = 12 ! 58 INTEGER , PARAMETER :: jp_bdytsu = 13 ! 59 INTEGER , PARAMETER :: jp_bdys_i = 14 ! 60 INTEGER , PARAMETER :: jp_bdyaip = 15 ! 61 INTEGER , PARAMETER :: jp_bdyhip = 16 ! 62 #if ! defined key_si3 63 INTEGER , PARAMETER :: jpl = 1 64 #endif 65 49 66 !$AGRIF_DO_NOT_TREAT 50 TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(: ), TARGET :: bf! structure of input fields (file informations, fields read)67 TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:,:), TARGET :: bf ! structure of input fields (file informations, fields read) 51 68 !$AGRIF_END_DO_NOT_TREAT 52 TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr ! array of pointers to nbmap53 54 #if defined key_si355 INTEGER :: nice_cat ! number of categories in the input file56 INTEGER :: jfld_hti, jfld_hts, jfld_ai ! indices of ice thickness, snow thickness and concentration in bf structure57 INTEGER, DIMENSION(jp_bdy) :: jfld_htit, jfld_htst, jfld_ait58 #endif59 69 60 70 !!---------------------------------------------------------------------- … … 65 75 CONTAINS 66 76 67 SUBROUTINE bdy_dta( kt, jit, time_offset )77 SUBROUTINE bdy_dta( kt, kit, kt_offset ) 68 78 !!---------------------------------------------------------------------- 69 79 !! *** SUBROUTINE bdy_dta *** … … 75 85 !!---------------------------------------------------------------------- 76 86 INTEGER, INTENT(in) :: kt ! ocean time-step index 77 INTEGER, INTENT(in), OPTIONAL :: jit ! subcycle time-step index (for timesplitting option)78 INTEGER, INTENT(in), OPTIONAL :: time_offset ! time offset in units of timesteps. NB. if jit87 INTEGER, INTENT(in), OPTIONAL :: kit ! subcycle time-step index (for timesplitting option) 88 INTEGER, INTENT(in), OPTIONAL :: kt_offset ! time offset in units of timesteps. NB. if kit 79 89 ! ! is present then units = subcycle timesteps. 80 ! ! time_offset = 0 => get data at "now" time level81 ! ! time_offset = -1 => get data at "before" time level82 ! ! time_offset = +1 => get data at "after" time level90 ! ! kt_offset = 0 => get data at "now" time level 91 ! ! kt_offset = -1 => get data at "before" time level 92 ! ! kt_offset = +1 => get data at "after" time level 83 93 ! ! etc. 84 94 ! 85 INTEGER :: jbdy, jfld, jstart, jend, ib, jl ! dummy loop indices 86 INTEGER :: ii, ij, ik, igrd ! local integers 87 INTEGER, DIMENSION(jpbgrd) :: ilen1 88 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts 89 TYPE(OBC_DATA), POINTER :: dta ! short cut 95 INTEGER :: jbdy, jfld, jstart, jend, ib, jl ! dummy loop indices 96 INTEGER :: ii, ij, ik, igrd, ipl ! local integers 97 INTEGER, DIMENSION(jpbgrd) :: ilen1 98 INTEGER, DIMENSION(:), POINTER :: nblen, nblenrim ! short cuts 99 TYPE(OBC_DATA) , POINTER :: dta_alias ! short cut 100 TYPE(FLD), DIMENSION(:), POINTER :: bf_alias 90 101 !!--------------------------------------------------------------------------- 91 102 ! … … 94 105 ! Initialise data arrays once for all from initial conditions where required 95 106 !--------------------------------------------------------------------------- 96 IF( kt == nit000 .AND. .NOT.PRESENT( jit) ) THEN107 IF( kt == nit000 .AND. .NOT.PRESENT(kit) ) THEN 97 108 98 109 ! Calculate depth-mean currents 99 110 !----------------------------- 100 111 101 112 DO jbdy = 1, nb_bdy 102 113 ! 103 114 nblen => idx_bdy(jbdy)%nblen 104 115 nblenrim => idx_bdy(jbdy)%nblenrim 105 dta => dta_bdy(jbdy)106 116 ! 107 117 IF( nn_dyn2d_dta(jbdy) == 0 ) THEN 108 118 ilen1(:) = nblen(:) 109 IF( dta %ll_ssh ) THEN119 IF( dta_bdy(jbdy)%lneed_ssh ) THEN 110 120 igrd = 1 111 121 DO ib = 1, ilen1(igrd) … … 113 123 ij = idx_bdy(jbdy)%nbj(ib,igrd) 114 124 dta_bdy(jbdy)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1) 115 END DO 116 ENDIF 117 IF( dta %ll_u2d) THEN125 END DO 126 ENDIF 127 IF( dta_bdy(jbdy)%lneed_dyn2d) THEN 118 128 igrd = 2 119 129 DO ib = 1, ilen1(igrd) … … 121 131 ij = idx_bdy(jbdy)%nbj(ib,igrd) 122 132 dta_bdy(jbdy)%u2d(ib) = un_b(ii,ij) * umask(ii,ij,1) 123 END DO 124 ENDIF 125 IF( dta%ll_v2d ) THEN 133 END DO 126 134 igrd = 3 127 135 DO ib = 1, ilen1(igrd) … … 129 137 ij = idx_bdy(jbdy)%nbj(ib,igrd) 130 138 dta_bdy(jbdy)%v2d(ib) = vn_b(ii,ij) * vmask(ii,ij,1) 131 END DO 139 END DO 132 140 ENDIF 133 141 ENDIF … … 135 143 IF( nn_dyn3d_dta(jbdy) == 0 ) THEN 136 144 ilen1(:) = nblen(:) 137 IF( dta %ll_u3d ) THEN145 IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN 138 146 igrd = 2 139 147 DO ib = 1, ilen1(igrd) … … 143 151 dta_bdy(jbdy)%u3d(ib,ik) = ( un(ii,ij,ik) - un_b(ii,ij) ) * umask(ii,ij,ik) 144 152 END DO 145 END DO 146 ENDIF 147 IF( dta%ll_v3d ) THEN 153 END DO 148 154 igrd = 3 149 155 DO ib = 1, ilen1(igrd) … … 152 158 ij = idx_bdy(jbdy)%nbj(ib,igrd) 153 159 dta_bdy(jbdy)%v3d(ib,ik) = ( vn(ii,ij,ik) - vn_b(ii,ij) ) * vmask(ii,ij,ik) 154 155 END DO 160 END DO 161 END DO 156 162 ENDIF 157 163 ENDIF … … 159 165 IF( nn_tra_dta(jbdy) == 0 ) THEN 160 166 ilen1(:) = nblen(:) 161 IF( dta %ll_tem) THEN167 IF( dta_bdy(jbdy)%lneed_tra ) THEN 162 168 igrd = 1 163 169 DO ib = 1, ilen1(igrd) … … 166 172 ij = idx_bdy(jbdy)%nbj(ib,igrd) 167 173 dta_bdy(jbdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik) 168 END DO169 END DO170 ENDIF171 IF( dta%ll_sal ) THEN172 igrd = 1173 DO ib = 1, ilen1(igrd)174 DO ik = 1, jpkm1175 ii = idx_bdy(jbdy)%nbi(ib,igrd)176 ij = idx_bdy(jbdy)%nbj(ib,igrd)177 174 dta_bdy(jbdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik) 178 175 END DO 179 END DO 176 END DO 180 177 ENDIF 181 178 ENDIF … … 184 181 IF( nn_ice_dta(jbdy) == 0 ) THEN ! set ice to initial values 185 182 ilen1(:) = nblen(:) 186 IF( dta %ll_a_i) THEN183 IF( dta_bdy(jbdy)%lneed_ice ) THEN 187 184 igrd = 1 188 185 DO jl = 1, jpl … … 190 187 ii = idx_bdy(jbdy)%nbi(ib,igrd) 191 188 ij = idx_bdy(jbdy)%nbj(ib,igrd) 192 dta_bdy(jbdy)%a_i (ib,jl) = a_i(ii,ij,jl) * tmask(ii,ij,1) 193 END DO 194 END DO 195 ENDIF 196 IF( dta%ll_h_i ) THEN 197 igrd = 1 198 DO jl = 1, jpl 199 DO ib = 1, ilen1(igrd) 200 ii = idx_bdy(jbdy)%nbi(ib,igrd) 201 ij = idx_bdy(jbdy)%nbj(ib,igrd) 202 dta_bdy(jbdy)%h_i (ib,jl) = h_i(ii,ij,jl) * tmask(ii,ij,1) 203 END DO 204 END DO 205 ENDIF 206 IF( dta%ll_h_s ) THEN 207 igrd = 1 208 DO jl = 1, jpl 209 DO ib = 1, ilen1(igrd) 210 ii = idx_bdy(jbdy)%nbi(ib,igrd) 211 ij = idx_bdy(jbdy)%nbj(ib,igrd) 212 dta_bdy(jbdy)%h_s (ib,jl) = h_s(ii,ij,jl) * tmask(ii,ij,1) 189 dta_bdy(jbdy)%a_i(ib,jl) = a_i (ii,ij,jl) * tmask(ii,ij,1) 190 dta_bdy(jbdy)%h_i(ib,jl) = h_i (ii,ij,jl) * tmask(ii,ij,1) 191 dta_bdy(jbdy)%h_s(ib,jl) = h_s (ii,ij,jl) * tmask(ii,ij,1) 192 dta_bdy(jbdy)%t_i(ib,jl) = SUM(t_i (ii,ij,:,jl)) * r1_nlay_i * tmask(ii,ij,1) 193 dta_bdy(jbdy)%t_s(ib,jl) = SUM(t_s (ii,ij,:,jl)) * r1_nlay_s * tmask(ii,ij,1) 194 dta_bdy(jbdy)%tsu(ib,jl) = t_su(ii,ij,jl) * tmask(ii,ij,1) 195 dta_bdy(jbdy)%s_i(ib,jl) = s_i (ii,ij,jl) * tmask(ii,ij,1) 196 ! melt ponds 197 dta_bdy(jbdy)%aip(ib,jl) = a_ip(ii,ij,jl) * tmask(ii,ij,1) 198 dta_bdy(jbdy)%hip(ib,jl) = h_ip(ii,ij,jl) * tmask(ii,ij,1) 213 199 END DO 214 200 END DO … … 222 208 ! update external data from files 223 209 !-------------------------------- 224 225 jstart = 1 226 DO jbdy = 1, nb_bdy 227 dta => dta_bdy(jbdy) 228 IF( nn_dta(jbdy) == 1 ) THEN ! skip this bit if no external data required 229 230 IF( PRESENT(jit) ) THEN 231 ! Update barotropic boundary conditions only 232 ! jit is optional argument for fld_read and bdytide_update 233 IF( cn_dyn2d(jbdy) /= 'none' ) THEN 234 IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 235 IF( dta%ll_ssh ) dta%ssh(:) = 0._wp 236 IF( dta%ll_u2d ) dta%u2d(:) = 0._wp 237 IF( dta%ll_u3d ) dta%v2d(:) = 0._wp 238 ENDIF 239 IF (cn_tra(jbdy) /= 'runoff') THEN 240 IF( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) THEN 241 242 jend = jstart + dta%nread(2) - 1 243 IF( ln_full_vel_array(jbdy) ) THEN 244 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), & 245 & kit=jit, kt_offset=time_offset , jpk_bdy=nb_jpk_bdy, & 246 & fvl=ln_full_vel_array(jbdy) ) 247 ELSE 248 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), & 249 & kit=jit, kt_offset=time_offset ) 250 ENDIF 251 252 ! If full velocities in boundary data then extract barotropic velocities from 3D fields 253 IF( ln_full_vel_array(jbdy) .AND. & 254 & ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR. & 255 & nn_dyn3d_dta(jbdy) == 1 ) )THEN 256 257 igrd = 2 ! zonal velocity 258 dta%u2d(:) = 0._wp 259 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 260 ii = idx_bdy(jbdy)%nbi(ib,igrd) 261 ij = idx_bdy(jbdy)%nbj(ib,igrd) 262 DO ik = 1, jpkm1 263 dta%u2d(ib) = dta%u2d(ib) & 264 & + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 265 END DO 266 dta%u2d(ib) = dta%u2d(ib) * r1_hu_n(ii,ij) 267 END DO 268 igrd = 3 ! meridional velocity 269 dta%v2d(:) = 0._wp 270 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 271 ii = idx_bdy(jbdy)%nbi(ib,igrd) 272 ij = idx_bdy(jbdy)%nbj(ib,igrd) 273 DO ik = 1, jpkm1 274 dta%v2d(ib) = dta%v2d(ib) & 275 & + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 276 END DO 277 dta%v2d(ib) = dta%v2d(ib) * r1_hv_n(ii,ij) 278 END DO 279 ENDIF 280 ENDIF 281 IF( nn_dyn2d_dta(jbdy) .ge. 2 ) THEN ! update tidal harmonic forcing 282 CALL bdytide_update( kt=kt, idx=idx_bdy(jbdy), dta=dta, td=tides(jbdy), & 283 & jit=jit, time_offset=time_offset ) 284 ENDIF 285 ENDIF 286 ENDIF 287 ELSE 288 IF (cn_tra(jbdy) == 'runoff') then ! runoff condition 289 jend = nb_bdy_fld(jbdy) 290 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 291 & map=nbmap_ptr(jstart:jend), kt_offset=time_offset ) 292 ! 293 igrd = 2 ! zonal velocity 294 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 295 ii = idx_bdy(jbdy)%nbi(ib,igrd) 296 ij = idx_bdy(jbdy)%nbj(ib,igrd) 297 dta%u2d(ib) = dta%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 298 END DO 299 ! 300 igrd = 3 ! meridional velocity 301 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 302 ii = idx_bdy(jbdy)%nbi(ib,igrd) 303 ij = idx_bdy(jbdy)%nbj(ib,igrd) 304 dta%v2d(ib) = dta%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 305 END DO 306 ELSE 307 IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 308 IF( dta%ll_ssh ) dta%ssh(:) = 0._wp 309 IF( dta%ll_u2d ) dta%u2d(:) = 0._wp 310 IF( dta%ll_v2d ) dta%v2d(:) = 0._wp 311 ENDIF 312 IF( dta%nread(1) .gt. 0 ) THEN ! update external data 313 jend = jstart + dta%nread(1) - 1 314 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 315 & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy, & 316 & fvl=ln_full_vel_array(jbdy) ) 317 ENDIF 318 ! If full velocities in boundary data then split into barotropic and baroclinic data 319 IF( ln_full_vel_array(jbdy) .and. & 320 & ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR. & 321 & nn_dyn3d_dta(jbdy) == 1 ) ) THEN 322 igrd = 2 ! zonal velocity 323 dta%u2d(:) = 0._wp 324 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 325 ii = idx_bdy(jbdy)%nbi(ib,igrd) 326 ij = idx_bdy(jbdy)%nbj(ib,igrd) 327 DO ik = 1, jpkm1 328 dta%u2d(ib) = dta%u2d(ib) & 329 & + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 330 END DO 331 dta%u2d(ib) = dta%u2d(ib) * r1_hu_n(ii,ij) 332 DO ik = 1, jpkm1 333 dta%u3d(ib,ik) = dta%u3d(ib,ik) - dta%u2d(ib) 334 END DO 335 END DO 336 igrd = 3 ! meridional velocity 337 dta%v2d(:) = 0._wp 338 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 339 ii = idx_bdy(jbdy)%nbi(ib,igrd) 340 ij = idx_bdy(jbdy)%nbj(ib,igrd) 341 DO ik = 1, jpkm1 342 dta%v2d(ib) = dta%v2d(ib) & 343 & + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 344 END DO 345 dta%v2d(ib) = dta%v2d(ib) * r1_hv_n(ii,ij) 346 DO ik = 1, jpkm1 347 dta%v3d(ib,ik) = dta%v3d(ib,ik) - dta%v2d(ib) 348 END DO 349 END DO 350 ENDIF 351 352 ENDIF 210 211 DO jbdy = 1, nb_bdy 212 213 dta_alias => dta_bdy(jbdy) 214 bf_alias => bf(:,jbdy) 215 216 ! read/update all bdy data 217 ! ------------------------ 218 CALL fld_read( kt, 1, bf_alias, kit = kit, kt_offset = kt_offset ) 219 220 ! apply some corrections in some specific cases... 221 ! -------------------------------------------------- 222 ! 223 ! if runoff condition: change river flow we read (in m3/s) into barotropic velocity (m/s) 224 IF( cn_tra(jbdy) == 'runoff' .AND. TRIM(bf_alias(jp_bdyu2d)%clrootname) /= 'NOT USED' ) THEN ! runoff and we read u/v2d 225 ! 226 igrd = 2 ! zonal flow (m3/s) to barotropic zonal velocity (m/s) 227 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 228 ii = idx_bdy(jbdy)%nbi(ib,igrd) 229 ij = idx_bdy(jbdy)%nbj(ib,igrd) 230 dta_alias%u2d(ib) = dta_alias%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 231 END DO 232 igrd = 3 ! meridional flow (m3/s) to barotropic meridional velocity (m/s) 233 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 234 ii = idx_bdy(jbdy)%nbi(ib,igrd) 235 ij = idx_bdy(jbdy)%nbj(ib,igrd) 236 dta_alias%v2d(ib) = dta_alias%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 237 END DO 238 ENDIF 239 240 ! tidal harmonic forcing ONLY: initialise arrays 241 IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! we did not read ssh, u/v2d 242 IF( dta_alias%lneed_ssh ) dta_alias%ssh(:) = 0._wp 243 IF( dta_alias%lneed_dyn2d ) dta_alias%u2d(:) = 0._wp 244 IF( dta_alias%lneed_dyn2d ) dta_alias%v2d(:) = 0._wp 245 ENDIF 246 247 ! If full velocities in boundary data, then split it into barotropic and baroclinic component 248 IF( bf_alias(jp_bdyu3d)%ltotvel ) THEN ! if we read 3D total velocity (can be true only if u3d was read) 249 ! 250 igrd = 2 ! zonal velocity 251 dta_alias%u2d(:) = 0._wp ! compute barotrope zonal velocity and put it in u2d 252 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 253 ii = idx_bdy(jbdy)%nbi(ib,igrd) 254 ij = idx_bdy(jbdy)%nbj(ib,igrd) 255 DO ik = 1, jpkm1 256 dta_alias%u2d(ib) = dta_alias%u2d(ib) + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) 257 END DO 258 dta_alias%u2d(ib) = dta_alias%u2d(ib) * r1_hu_n(ii,ij) 259 DO ik = 1, jpkm1 ! compute barocline zonal velocity and put it in u3d 260 dta_alias%u3d(ib,ik) = dta_alias%u3d(ib,ik) - dta_alias%u2d(ib) 261 END DO 262 END DO 263 igrd = 3 ! meridional velocity 264 dta_alias%v2d(:) = 0._wp ! compute barotrope meridional velocity and put it in v2d 265 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 266 ii = idx_bdy(jbdy)%nbi(ib,igrd) 267 ij = idx_bdy(jbdy)%nbj(ib,igrd) 268 DO ik = 1, jpkm1 269 dta_alias%v2d(ib) = dta_alias%v2d(ib) + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) 270 END DO 271 dta_alias%v2d(ib) = dta_alias%v2d(ib) * r1_hv_n(ii,ij) 272 DO ik = 1, jpkm1 ! compute barocline meridional velocity and put it in v3d 273 dta_alias%v3d(ib,ik) = dta_alias%v3d(ib,ik) - dta_alias%v2d(ib) 274 END DO 275 END DO 276 ENDIF ! ltotvel 277 278 ! update tidal harmonic forcing 279 IF( PRESENT(kit) .AND. nn_dyn2d_dta(jbdy) .GE. 2 ) THEN 280 CALL bdytide_update( kt = kt, idx = idx_bdy(jbdy), dta = dta_alias, td = tides(jbdy), & 281 & kit = kit, kt_offset = kt_offset ) 282 ENDIF 283 284 ! atm surface pressure : add inverted barometer effect to ssh if it was read 285 IF ( ln_apr_obc .AND. TRIM(bf_alias(jp_bdyssh)%clrootname) /= 'NOT USED' ) THEN 286 igrd = 1 287 DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is used only on the rim 288 ii = idx_bdy(jbdy)%nbi(ib,igrd) 289 ij = idx_bdy(jbdy)%nbj(ib,igrd) 290 dta_alias%ssh(ib) = dta_alias%ssh(ib) + ssh_ib(ii,ij) 291 END DO 292 ENDIF 293 353 294 #if defined key_si3 354 ! convert N-cat fields (input) into jpl-cat (output) 355 IF( cn_ice(jbdy) /= 'none' .AND. nn_ice_dta(jbdy) == 1 ) THEN 356 jfld_hti = jfld_htit(jbdy) 357 jfld_hts = jfld_htst(jbdy) 358 jfld_ai = jfld_ait(jbdy) 359 IF ( jpl /= 1 .AND. nice_cat == 1 ) THEN ! case input cat = 1 360 CALL ice_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 361 & dta_bdy(jbdy)%h_i , dta_bdy(jbdy)%h_s , dta_bdy(jbdy)%a_i ) 362 ELSEIF( jpl /= 1 .AND. nice_cat /= 1 .AND. nice_cat /= jpl ) THEN ! case input cat /=1 and /=jpl 363 CALL ice_var_itd2( bf(jfld_hti)%fnow(:,1,:), bf(jfld_hts)%fnow(:,1,:), bf(jfld_ai)%fnow(:,1,:), & 364 & dta_bdy(jbdy)%h_i , dta_bdy(jbdy)%h_s , dta_bdy(jbdy)%a_i ) 365 ENDIF 366 ENDIF 295 IF( dta_alias%lneed_ice ) THEN 296 ! fill temperature and salinity arrays 297 IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_i)%fnow(:,1,:) = rice_tem (jbdy) 298 IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_s)%fnow(:,1,:) = rice_tem (jbdy) 299 IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy) 300 IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy) 301 IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * & ! rice_apnd is the pond fraction 302 & bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd * a_i ) 303 IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy) 304 ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 305 IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & 306 & bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdytsu)%fnow(:,1,:) + 271.15 ) 307 ! if T_su is read and not T_s, set T_s = T_su 308 IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) & 309 & bf_alias(jp_bdyt_s)%fnow(:,1,:) = bf_alias(jp_bdytsu)%fnow(:,1,:) 310 ! if T_s is read and not T_su, set T_su = T_s 311 IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & 312 & bf_alias(jp_bdytsu)%fnow(:,1,:) = bf_alias(jp_bdyt_s)%fnow(:,1,:) 313 ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 314 IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & 315 & bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdyt_s)%fnow(:,1,:) + 271.15 ) 316 317 ! make sure ponds = 0 if no ponds scheme 318 IF ( .NOT.ln_pnd ) THEN 319 bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp 320 bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp 321 ENDIF 322 323 ! convert N-cat fields (input) into jpl-cat (output) 324 ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3) 325 IF( ipl /= jpl ) THEN ! ice: convert N-cat fields (input) into jpl-cat (output) 326 CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & 327 & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & 328 & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & 329 & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & 330 & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), & 331 & dta_alias%t_i , dta_alias%t_s , & 332 & dta_alias%tsu , dta_alias%s_i , & 333 & dta_alias%aip , dta_alias%hip ) 334 ENDIF 335 ENDIF 367 336 #endif 368 ENDIF369 jstart = jstart + dta%nread(1)370 ENDIF ! nn_dta(jbdy) = 1371 337 END DO ! jbdy 372 373 IF ( ln_apr_obc ) THEN374 DO jbdy = 1, nb_bdy375 IF (cn_tra(jbdy) /= 'runoff')THEN376 igrd = 1 ! meridional velocity377 DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd)378 ii = idx_bdy(jbdy)%nbi(ib,igrd)379 ij = idx_bdy(jbdy)%nbj(ib,igrd)380 dta_bdy(jbdy)%ssh(ib) = dta_bdy(jbdy)%ssh(ib) + ssh_ib(ii,ij)381 END DO382 ENDIF383 END DO384 ENDIF385 338 386 339 IF ( ln_tide ) THEN 387 340 IF (ln_dynspg_ts) THEN ! Fill temporary arrays with slow-varying bdy data 388 DO jbdy = 1, nb_bdy ! Tidal component added in ts loop389 IF ( nn_dyn2d_dta(jbdy) . ge. 2 ) THEN341 DO jbdy = 1, nb_bdy ! Tidal component added in ts loop 342 IF ( nn_dyn2d_dta(jbdy) .GE. 2 ) THEN 390 343 nblen => idx_bdy(jbdy)%nblen 391 344 nblenrim => idx_bdy(jbdy)%nblenrim 392 IF( cn_dyn2d(jbdy) == 'frs' ) THEN; ilen1(:)=nblen(:) ; ELSE ; ilen1(:)=nblenrim(:) ; ENDIF 393 IF ( dta_bdy(jbdy)%ll_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) 394 IF ( dta_bdy(jbdy)%ll_u2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2)) 395 IF ( dta_bdy(jbdy)%ll_v2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3)) 396 ENDIF 397 END DO 398 ELSE ! Add tides if not split-explicit free surface else this is done in ts loop 399 ! 400 CALL bdy_dta_tides( kt=kt, time_offset=time_offset ) 401 ENDIF 402 ENDIF 403 404 ! 405 IF( ln_timing ) CALL timing_stop('bdy_dta') 406 ! 407 END SUBROUTINE bdy_dta 345 IF( cn_dyn2d(jbdy) == 'frs' ) THEN ; ilen1(:)=nblen(:) ; ELSE ; ilen1(:)=nblenrim(:) ; ENDIF 346 IF ( dta_bdy(jbdy)%lneed_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) 347 IF ( dta_bdy(jbdy)%lneed_dyn2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2)) 348 IF ( dta_bdy(jbdy)%lneed_dyn2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3)) 349 ENDIF 350 END DO 351 ELSE ! Add tides if not split-explicit free surface else this is done in ts loop 352 ! 353 CALL bdy_dta_tides( kt=kt, kt_offset=kt_offset ) 354 ENDIF 355 ENDIF 356 ! 357 IF( ln_timing ) CALL timing_stop('bdy_dta') 358 ! 359 END SUBROUTINE bdy_dta 408 360 409 361 … … 418 370 !! 419 371 !!---------------------------------------------------------------------- 420 INTEGER :: jbdy, jfld, jstart, jend, ierror, ios ! Local integers 372 INTEGER :: jbdy, jfld ! Local integers 373 INTEGER :: ierror, ios ! 421 374 ! 375 CHARACTER(len=3) :: cl3 ! 422 376 CHARACTER(len=100) :: cn_dir ! Root directory for location of data files 423 CHARACTER(len=100), DIMENSION(nb_bdy) :: cn_dir_array ! Root directory for location of data files424 CHARACTER(len = 256):: clname ! temporary file name425 377 LOGICAL :: ln_full_vel ! =T => full velocities in 3D boundary data 426 378 ! ! =F => baroclinic velocities in 3D boundary data 427 INTEGER :: ilen_global ! Max length required for global bdy dta arrays428 INTEGER, ALLOCATABLE, DIMENSION(:) :: ilen1, ilen3 ! size of 1st and 3rd dimensions of local arrays429 INTEGER , ALLOCATABLE, DIMENSION(:) :: ibdy ! bdy set for a particular jfld430 INTEGER , ALLOCATABLE, DIMENSION(:) :: igrid ! index for grid type (1,2,3 = T,U,V)431 INTEGER , POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts432 TYPE(OBC_DATA), POINTER :: dta ! short cut433 #if defined key_si3 434 INTEGER :: kndims ! number of dimensions in an array (i.e. 3 = wo ice cat; 4 = w ice cat)435 INTEGER, DIMENSION(4) :: kdimsz ! size of dimensions436 INTEGER :: inum,id1 ! local integer437 #endif 438 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: blf_i ! array of namelist information structures439 TYPE(FLD_N) :: bn_tem, bn_sal, bn_u3d, bn_v3d !440 TYPE(FLD_N) :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read441 #if defined key_si3 442 TYPE(FLD _N) :: bn_a_i, bn_h_i, bn_h_s443 #endif 379 LOGICAL :: ln_zinterp ! =T => requires a vertical interpolation of the bdydta 380 REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd 381 INTEGER :: ipk,ipl ! 382 INTEGER :: idvar ! variable ID 383 INTEGER :: indims ! number of dimensions of the variable 384 INTEGER :: iszdim ! number of dimensions of the variable 385 INTEGER, DIMENSION(4) :: i4dimsz ! size of variable dimensions 386 INTEGER :: igrd ! index for grid type (1,2,3 = T,U,V) 387 LOGICAL :: lluld ! is the variable using the unlimited dimension 388 LOGICAL :: llneed ! 389 LOGICAL :: llread ! 390 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_tem, bn_sal, bn_u3d, bn_v3d ! must be an array to be used with fld_fill 391 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read 392 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip 393 TYPE(FLD_N), DIMENSION(:), POINTER :: bn_alias ! must be an array to be used with fld_fill 394 TYPE(FLD ), DIMENSION(:), POINTER :: bf_alias 395 ! 444 396 NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d 445 #if defined key_si3 446 NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s 447 #endif 448 NAMELIST/nambdy_dta/ ln_full_vel, nb_jpk_bdy 397 NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip 398 NAMELIST/nambdy_dta/ rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd 399 NAMELIST/nambdy_dta/ ln_full_vel, ln_zinterp 449 400 !!--------------------------------------------------------------------------- 450 401 ! … … 454 405 IF(lwp) WRITE(numout,*) '' 455 406 456 ! Set nn_dta 457 DO jbdy = 1, nb_bdy 458 nn_dta(jbdy) = MAX( nn_dyn2d_dta (jbdy) & 459 & , nn_dyn3d_dta (jbdy) & 460 & , nn_tra_dta (jbdy) & 461 #if defined key_si3 462 & , nn_ice_dta (jbdy) & 463 #endif 464 ) 465 IF(nn_dta(jbdy) > 1) nn_dta(jbdy) = 1 466 END DO 467 468 ! Work out upper bound of how many fields there are to read in and allocate arrays 469 ! --------------------------------------------------------------------------- 470 ALLOCATE( nb_bdy_fld(nb_bdy) ) 471 nb_bdy_fld(:) = 0 472 DO jbdy = 1, nb_bdy 473 IF( cn_dyn2d(jbdy) /= 'none' .AND. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) THEN 474 nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3 475 ENDIF 476 IF( cn_dyn3d(jbdy) /= 'none' .AND. nn_dyn3d_dta(jbdy) == 1 ) THEN 477 nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2 478 ENDIF 479 IF( cn_tra(jbdy) /= 'none' .AND. nn_tra_dta(jbdy) == 1 ) THEN 480 nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2 481 ENDIF 482 #if defined key_si3 483 IF( cn_ice(jbdy) /= 'none' .AND. nn_ice_dta(jbdy) == 1 ) THEN 484 nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3 485 ENDIF 486 #endif 487 IF(lwp) WRITE(numout,*) 'Maximum number of files to open =', nb_bdy_fld(jbdy) 488 END DO 489 490 nb_bdy_fld_sum = SUM( nb_bdy_fld ) 491 492 ALLOCATE( bf(nb_bdy_fld_sum), STAT=ierror ) 407 ALLOCATE( bf(jpbdyfld,nb_bdy), STAT=ierror ) 493 408 IF( ierror > 0 ) THEN 494 409 CALL ctl_stop( 'bdy_dta: unable to allocate bf structure' ) ; RETURN 495 410 ENDIF 496 ALLOCATE( blf_i(nb_bdy_fld_sum), STAT=ierror ) 497 IF( ierror > 0 ) THEN 498 CALL ctl_stop( 'bdy_dta: unable to allocate blf_i structure' ) ; RETURN 499 ENDIF 500 ALLOCATE( nbmap_ptr(nb_bdy_fld_sum), STAT=ierror ) 501 IF( ierror > 0 ) THEN 502 CALL ctl_stop( 'bdy_dta: unable to allocate nbmap_ptr structure' ) ; RETURN 503 ENDIF 504 ALLOCATE( ilen1(nb_bdy_fld_sum), ilen3(nb_bdy_fld_sum) ) 505 ALLOCATE( ibdy(nb_bdy_fld_sum) ) 506 ALLOCATE( igrid(nb_bdy_fld_sum) ) 507 411 bf(:,:)%clrootname = 'NOT USED' ! default definition used as a flag in fld_read to do nothing. 412 bf(:,:)%lzint = .FALSE. ! default definition 413 bf(:,:)%ltotvel = .FALSE. ! default definition 414 508 415 ! Read namelists 509 416 ! -------------- 510 REWIND(numnam_ref)511 417 REWIND(numnam_cfg) 512 jfld = 0 513 DO jbdy = 1, nb_bdy 514 IF( nn_dta(jbdy) == 1 ) THEN 515 READ ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) 516 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_dta in reference namelist', lwp ) 418 DO jbdy = 1, nb_bdy 419 420 WRITE(ctmp1, '(a,i2)') 'BDY number ', jbdy 421 WRITE(ctmp2, '(a,i2)') 'block nambdy_dta number ', jbdy 422 423 ! There is only one nambdy_dta block in namelist_ref -> use it for each bdy so we do a rewind 424 REWIND(numnam_ref) 425 READ ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) 426 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_dta in reference namelist' ) 427 428 ! by-pass nambdy_dta reading if no input data used in this bdy 429 IF( ( dta_bdy(jbdy)%lneed_dyn2d .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ) & 430 & .OR. ( dta_bdy(jbdy)%lneed_dyn3d .AND. nn_dyn3d_dta(jbdy) == 1 ) & 431 & .OR. ( dta_bdy(jbdy)%lneed_tra .AND. nn_tra_dta(jbdy) == 1 ) & 432 & .OR. ( dta_bdy(jbdy)%lneed_ice .AND. nn_ice_dta(jbdy) == 1 ) ) THEN 433 ! WARNING: we don't do a rewind here, each bdy reads its own nambdy_dta block one after another 517 434 READ ( numnam_cfg, nambdy_dta, IOSTAT = ios, ERR = 902 ) 518 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist', lwp ) 519 IF(lwm) WRITE( numond, nambdy_dta ) 520 521 cn_dir_array(jbdy) = cn_dir 522 ln_full_vel_array(jbdy) = ln_full_vel 523 524 nblen => idx_bdy(jbdy)%nblen 525 nblenrim => idx_bdy(jbdy)%nblenrim 526 dta => dta_bdy(jbdy) 527 dta%nread(2) = 0 528 529 ! Only read in necessary fields for this set. 530 ! Important that barotropic variables come first. 531 IF( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN 532 533 IF( dta%ll_ssh ) THEN 534 if(lwp) write(numout,*) '++++++ reading in ssh field' 535 jfld = jfld + 1 536 blf_i(jfld) = bn_ssh 537 ibdy(jfld) = jbdy 538 igrid(jfld) = 1 539 ilen1(jfld) = nblen(igrid(jfld)) 540 ilen3(jfld) = 1 541 dta%nread(2) = dta%nread(2) + 1 542 ENDIF 543 544 IF( dta%ll_u2d .and. .not. ln_full_vel_array(jbdy) ) THEN 545 if(lwp) write(numout,*) '++++++ reading in u2d field' 546 jfld = jfld + 1 547 blf_i(jfld) = bn_u2d 548 ibdy(jfld) = jbdy 549 igrid(jfld) = 2 550 ilen1(jfld) = nblen(igrid(jfld)) 551 ilen3(jfld) = 1 552 dta%nread(2) = dta%nread(2) + 1 553 ENDIF 554 555 IF( dta%ll_v2d .and. .not. ln_full_vel_array(jbdy) ) THEN 556 if(lwp) write(numout,*) '++++++ reading in v2d field' 557 jfld = jfld + 1 558 blf_i(jfld) = bn_v2d 559 ibdy(jfld) = jbdy 560 igrid(jfld) = 3 561 ilen1(jfld) = nblen(igrid(jfld)) 562 ilen3(jfld) = 1 563 dta%nread(2) = dta%nread(2) + 1 564 ENDIF 565 566 ENDIF 567 568 ! read 3D velocities if baroclinic velocities require OR if 569 ! barotropic velocities required and ln_full_vel set to .true. 570 IF( nn_dyn3d_dta(jbdy) == 1 .OR. & 571 & ( ln_full_vel_array(jbdy) .AND. ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN 572 573 IF( dta%ll_u3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN 574 if(lwp) write(numout,*) '++++++ reading in u3d field' 575 jfld = jfld + 1 576 blf_i(jfld) = bn_u3d 577 ibdy(jfld) = jbdy 578 igrid(jfld) = 2 579 ilen1(jfld) = nblen(igrid(jfld)) 580 ilen3(jfld) = jpk 581 IF( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) dta%nread(2) = dta%nread(2) + 1 582 ENDIF 583 584 IF( dta%ll_v3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN 585 if(lwp) write(numout,*) '++++++ reading in v3d field' 586 jfld = jfld + 1 587 blf_i(jfld) = bn_v3d 588 ibdy(jfld) = jbdy 589 igrid(jfld) = 3 590 ilen1(jfld) = nblen(igrid(jfld)) 591 ilen3(jfld) = jpk 592 IF( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) dta%nread(2) = dta%nread(2) + 1 593 ENDIF 594 595 ENDIF 596 597 ! temperature and salinity 598 IF( nn_tra_dta(jbdy) == 1 ) THEN 599 600 IF( dta%ll_tem ) THEN 601 if(lwp) write(numout,*) '++++++ reading in tem field' 602 jfld = jfld + 1 603 blf_i(jfld) = bn_tem 604 ibdy(jfld) = jbdy 605 igrid(jfld) = 1 606 ilen1(jfld) = nblen(igrid(jfld)) 607 ilen3(jfld) = jpk 608 ENDIF 609 610 IF( dta%ll_sal ) THEN 611 if(lwp) write(numout,*) '++++++ reading in sal field' 612 jfld = jfld + 1 613 blf_i(jfld) = bn_sal 614 ibdy(jfld) = jbdy 615 igrid(jfld) = 1 616 ilen1(jfld) = nblen(igrid(jfld)) 617 ilen3(jfld) = jpk 618 ENDIF 619 620 ENDIF 435 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist' ) 436 IF(lwm) WRITE( numond, nambdy_dta ) 437 ENDIF 438 439 ! get the number of ice categories in bdy data file (use a_i information to do this) 440 ipl = jpl ! default definition 441 IF( dta_bdy(jbdy)%lneed_ice ) THEN ! if we need ice bdy data 442 IF( nn_ice_dta(jbdy) == 1 ) THEN ! if we get ice bdy data from netcdf file 443 CALL fld_fill( bf(jp_bdya_i,jbdy:jbdy), bn_a_i, cn_dir, 'bdy_dta', 'a_i'//' '//ctmp1, ctmp2 ) ! use namelist info 444 CALL fld_clopn( bf(jp_bdya_i,jbdy), nyear, nmonth, nday ) ! not a problem when we call it again after 445 idvar = iom_varid( bf(jp_bdya_i,jbdy)%num, bf(jp_bdya_i,jbdy)%clvar, kndims=indims, kdimsz=i4dimsz, lduld=lluld ) 446 IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN ; ipl = i4dimsz(3) ! xylt or xyl 447 ELSE ; ipl = 1 ! xy or xyt 448 ENDIF 449 bf(jp_bdya_i,jbdy)%clrootname = 'NOT USED' ! reset to default value as this subdomain may not need to read this bdy 450 ENDIF 451 ENDIF 621 452 622 453 #if defined key_si3 623 ! sea ice 624 IF( nn_ice_dta(jbdy) == 1 ) THEN 625 ! Test for types of ice input (1cat or Xcat) 626 ! Build file name to find dimensions 627 clname=TRIM( cn_dir )//TRIM(bn_a_i%clname) 628 IF( .NOT. bn_a_i%ln_clim ) THEN 629 WRITE(clname, '(a,"_y",i4.4)' ) TRIM( clname ), nyear ! add year 630 IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname ), nmonth ! add month 631 ELSE 632 IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( clname ), nmonth ! add month 633 ENDIF 634 IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) & 635 & WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), nday ! add day 454 IF( .NOT.ln_pnd ) THEN 455 rn_ice_apnd = 0. ; rn_ice_hpnd = 0. 456 CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 when no ponds' ) 457 ENDIF 458 #endif 459 460 ! temp, salt, age and ponds of incoming ice 461 rice_tem (jbdy) = rn_ice_tem 462 rice_sal (jbdy) = rn_ice_sal 463 rice_age (jbdy) = rn_ice_age 464 rice_apnd(jbdy) = rn_ice_apnd 465 rice_hpnd(jbdy) = rn_ice_hpnd 466 467 468 DO jfld = 1, jpbdyfld 469 470 ! ===================== 471 ! ssh 472 ! ===================== 473 IF( jfld == jp_bdyssh ) THEN 474 cl3 = 'ssh' 475 igrd = 1 ! T point 476 ipk = 1 ! surface data 477 llneed = dta_bdy(jbdy)%lneed_ssh ! dta_bdy(jbdy)%ssh will be needed 478 llread = MOD(nn_dyn2d_dta(jbdy),2) == 1 ! get data from NetCDF file 479 bf_alias => bf(jp_bdyssh,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy 480 bn_alias => bn_ssh ! alias for ssh structure of nambdy_dta 481 iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! length of this bdy on this MPI processus : used only on the rim 482 ENDIF 483 ! ===================== 484 ! dyn2d 485 ! ===================== 486 IF( jfld == jp_bdyu2d ) THEN 487 cl3 = 'u2d' 488 igrd = 2 ! U point 489 ipk = 1 ! surface data 490 llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%ssh will be needed 491 llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get u2d from u3d and read NetCDF file 492 bf_alias => bf(jp_bdyu2d,jbdy:jbdy) ! alias for u2d structure of bdy number jbdy 493 bn_alias => bn_u2d ! alias for u2d structure of nambdy_dta 494 IF( ln_full_vel ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) ! will be computed from u3d -> need on the full bdy 495 ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! used only on the rim 496 ENDIF 497 ENDIF 498 IF( jfld == jp_bdyv2d ) THEN 499 cl3 = 'v2d' 500 igrd = 3 ! V point 501 ipk = 1 ! surface data 502 llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%ssh will be needed 503 llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get v2d from v3d and read NetCDF file 504 bf_alias => bf(jp_bdyv2d,jbdy:jbdy) ! alias for v2d structure of bdy number jbdy 505 bn_alias => bn_v2d ! alias for v2d structure of nambdy_dta 506 IF( ln_full_vel ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) ! will be computed from v3d -> need on the full bdy 507 ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! used only on the rim 508 ENDIF 509 ENDIF 510 ! ===================== 511 ! dyn3d 512 ! ===================== 513 IF( jfld == jp_bdyu3d ) THEN 514 cl3 = 'u3d' 515 igrd = 2 ! U point 516 ipk = jpk ! 3d data 517 llneed = dta_bdy(jbdy)%lneed_dyn3d .OR. & ! dta_bdy(jbdy)%u3d will be needed 518 & ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel ) ! u3d needed to compute u2d 519 llread = nn_dyn3d_dta(jbdy) == 1 ! get data from NetCDF file 520 bf_alias => bf(jp_bdyu3d,jbdy:jbdy) ! alias for u3d structure of bdy number jbdy 521 bn_alias => bn_u3d ! alias for u3d structure of nambdy_dta 522 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 523 ENDIF 524 IF( jfld == jp_bdyv3d ) THEN 525 cl3 = 'v3d' 526 igrd = 3 ! V point 527 ipk = jpk ! 3d data 528 llneed = dta_bdy(jbdy)%lneed_dyn3d .OR. & ! dta_bdy(jbdy)%v3d will be needed 529 & ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel ) ! v3d needed to compute v2d 530 llread = nn_dyn3d_dta(jbdy) == 1 ! get data from NetCDF file 531 bf_alias => bf(jp_bdyv3d,jbdy:jbdy) ! alias for v3d structure of bdy number jbdy 532 bn_alias => bn_v3d ! alias for v3d structure of nambdy_dta 533 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 534 ENDIF 535 536 ! ===================== 537 ! tra 538 ! ===================== 539 IF( jfld == jp_bdytem ) THEN 540 cl3 = 'tem' 541 igrd = 1 ! T point 542 ipk = jpk ! 3d data 543 llneed = dta_bdy(jbdy)%lneed_tra ! dta_bdy(jbdy)%tem will be needed 544 llread = nn_tra_dta(jbdy) == 1 ! get data from NetCDF file 545 bf_alias => bf(jp_bdytem,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy 546 bn_alias => bn_tem ! alias for ssh structure of nambdy_dta 547 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 548 ENDIF 549 IF( jfld == jp_bdysal ) THEN 550 cl3 = 'sal' 551 igrd = 1 ! T point 552 ipk = jpk ! 3d data 553 llneed = dta_bdy(jbdy)%lneed_tra ! dta_bdy(jbdy)%sal will be needed 554 llread = nn_tra_dta(jbdy) == 1 ! get data from NetCDF file 555 bf_alias => bf(jp_bdysal,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy 556 bn_alias => bn_sal ! alias for ssh structure of nambdy_dta 557 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 558 ENDIF 559 560 ! ===================== 561 ! ice 562 ! ===================== 563 IF( jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. & 564 & jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. & 565 & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip ) THEN 566 igrd = 1 ! T point 567 ipk = ipl ! jpl-cat data 568 llneed = dta_bdy(jbdy)%lneed_ice ! ice will be needed 569 llread = nn_ice_dta(jbdy) == 1 ! get data from NetCDF file 570 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 571 ENDIF 572 IF( jfld == jp_bdya_i ) THEN 573 cl3 = 'a_i' 574 bf_alias => bf(jp_bdya_i,jbdy:jbdy) ! alias for a_i structure of bdy number jbdy 575 bn_alias => bn_a_i ! alias for a_i structure of nambdy_dta 576 ENDIF 577 IF( jfld == jp_bdyh_i ) THEN 578 cl3 = 'h_i' 579 bf_alias => bf(jp_bdyh_i,jbdy:jbdy) ! alias for h_i structure of bdy number jbdy 580 bn_alias => bn_h_i ! alias for h_i structure of nambdy_dta 581 ENDIF 582 IF( jfld == jp_bdyh_s ) THEN 583 cl3 = 'h_s' 584 bf_alias => bf(jp_bdyh_s,jbdy:jbdy) ! alias for h_s structure of bdy number jbdy 585 bn_alias => bn_h_s ! alias for h_s structure of nambdy_dta 586 ENDIF 587 IF( jfld == jp_bdyt_i ) THEN 588 cl3 = 't_i' 589 bf_alias => bf(jp_bdyt_i,jbdy:jbdy) ! alias for t_i structure of bdy number jbdy 590 bn_alias => bn_t_i ! alias for t_i structure of nambdy_dta 591 ENDIF 592 IF( jfld == jp_bdyt_s ) THEN 593 cl3 = 't_s' 594 bf_alias => bf(jp_bdyt_s,jbdy:jbdy) ! alias for t_s structure of bdy number jbdy 595 bn_alias => bn_t_s ! alias for t_s structure of nambdy_dta 596 ENDIF 597 IF( jfld == jp_bdytsu ) THEN 598 cl3 = 'tsu' 599 bf_alias => bf(jp_bdytsu,jbdy:jbdy) ! alias for tsu structure of bdy number jbdy 600 bn_alias => bn_tsu ! alias for tsu structure of nambdy_dta 601 ENDIF 602 IF( jfld == jp_bdys_i ) THEN 603 cl3 = 's_i' 604 bf_alias => bf(jp_bdys_i,jbdy:jbdy) ! alias for s_i structure of bdy number jbdy 605 bn_alias => bn_s_i ! alias for s_i structure of nambdy_dta 606 ENDIF 607 IF( jfld == jp_bdyaip ) THEN 608 cl3 = 'aip' 609 bf_alias => bf(jp_bdyaip,jbdy:jbdy) ! alias for aip structure of bdy number jbdy 610 bn_alias => bn_aip ! alias for aip structure of nambdy_dta 611 ENDIF 612 IF( jfld == jp_bdyhip ) THEN 613 cl3 = 'hip' 614 bf_alias => bf(jp_bdyhip,jbdy:jbdy) ! alias for hip structure of bdy number jbdy 615 bn_alias => bn_hip ! alias for hip structure of nambdy_dta 616 ENDIF 617 618 IF( llneed .AND. iszdim > 0 ) THEN ! dta_bdy(jbdy)%xxx will be needed 619 ! ! -> must be associated with an allocated target 620 ALLOCATE( bf_alias(1)%fnow( iszdim, 1, ipk ) ) ! allocate the target 636 621 ! 637 CALL iom_open ( clname, inum ) 638 id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=kdimsz, kndims=kndims, ldstop = .FALSE. ) 639 CALL iom_close ( inum ) 640 641 IF ( kndims == 4 ) THEN 642 nice_cat = kdimsz(4) ! Xcat input 643 ELSE 644 nice_cat = 1 ! 1cat input 645 ENDIF 646 ! End test 647 648 IF( dta%ll_a_i ) THEN 649 jfld = jfld + 1 650 blf_i(jfld) = bn_a_i 651 ibdy(jfld) = jbdy 652 igrid(jfld) = 1 653 ilen1(jfld) = nblen(igrid(jfld)) 654 ilen3(jfld) = nice_cat 655 ENDIF 656 657 IF( dta%ll_h_i ) THEN 658 jfld = jfld + 1 659 blf_i(jfld) = bn_h_i 660 ibdy(jfld) = jbdy 661 igrid(jfld) = 1 662 ilen1(jfld) = nblen(igrid(jfld)) 663 ilen3(jfld) = nice_cat 664 ENDIF 665 666 IF( dta%ll_h_s ) THEN 667 jfld = jfld + 1 668 blf_i(jfld) = bn_h_s 669 ibdy(jfld) = jbdy 670 igrid(jfld) = 1 671 ilen1(jfld) = nblen(igrid(jfld)) 672 ilen3(jfld) = nice_cat 673 ENDIF 674 675 ENDIF 676 #endif 677 ! Recalculate field counts 678 !------------------------- 679 IF( jbdy == 1 ) THEN 680 nb_bdy_fld_sum = 0 681 nb_bdy_fld(jbdy) = jfld 682 nb_bdy_fld_sum = jfld 683 ELSE 684 nb_bdy_fld(jbdy) = jfld - nb_bdy_fld_sum 685 nb_bdy_fld_sum = nb_bdy_fld_sum + nb_bdy_fld(jbdy) 686 ENDIF 687 688 dta%nread(1) = nb_bdy_fld(jbdy) 689 690 ENDIF ! nn_dta == 1 691 ENDDO ! jbdy 692 693 DO jfld = 1, nb_bdy_fld_sum 694 ALLOCATE( bf(jfld)%fnow(ilen1(jfld),1,ilen3(jfld)) ) 695 IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 696 nbmap_ptr(jfld)%ptr => idx_bdy(ibdy(jfld))%nbmap(:,igrid(jfld)) 697 nbmap_ptr(jfld)%ll_unstruc = ln_coords_file(ibdy(jfld)) 698 ENDDO 699 700 ! fill bf with blf_i and control print 701 !------------------------------------- 702 jstart = 1 703 DO jbdy = 1, nb_bdy 704 jend = jstart - 1 + nb_bdy_fld(jbdy) 705 CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(jbdy), 'bdy_dta', & 706 & 'open boundary conditions', 'nambdy_dta' ) 707 jstart = jend + 1 708 ENDDO 709 710 DO jfld = 1, nb_bdy_fld_sum 711 bf(jfld)%igrd = igrid(jfld) 712 bf(jfld)%ibdy = ibdy(jfld) 713 ENDDO 714 715 ! Initialise local boundary data arrays 716 ! nn_xxx_dta=0 : allocate space - will be filled from initial conditions later 717 ! nn_xxx_dta=1 : point to "fnow" arrays 718 !------------------------------------- 719 720 jfld = 0 721 DO jbdy=1, nb_bdy 722 723 nblen => idx_bdy(jbdy)%nblen 724 dta => dta_bdy(jbdy) 725 726 if(lwp) then 727 write(numout,*) '++++++ dta%ll_ssh = ',dta%ll_ssh 728 write(numout,*) '++++++ dta%ll_u2d = ',dta%ll_u2d 729 write(numout,*) '++++++ dta%ll_v2d = ',dta%ll_v2d 730 write(numout,*) '++++++ dta%ll_u3d = ',dta%ll_u3d 731 write(numout,*) '++++++ dta%ll_v3d = ',dta%ll_v3d 732 write(numout,*) '++++++ dta%ll_tem = ',dta%ll_tem 733 write(numout,*) '++++++ dta%ll_sal = ',dta%ll_sal 734 endif 735 736 IF ( nn_dyn2d_dta(jbdy) == 0 .or. nn_dyn2d_dta(jbdy) == 2 ) THEN 737 if(lwp) write(numout,*) '++++++ dta%ssh/u2d/u3d allocated space' 738 IF( dta%ll_ssh ) ALLOCATE( dta%ssh(nblen(1)) ) 739 IF( dta%ll_u2d ) ALLOCATE( dta%u2d(nblen(2)) ) 740 IF( dta%ll_v2d ) ALLOCATE( dta%v2d(nblen(3)) ) 741 ENDIF 742 IF ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN 743 IF( dta%ll_ssh ) THEN 744 if(lwp) write(numout,*) '++++++ dta%ssh pointing to fnow' 745 jfld = jfld + 1 746 dta%ssh => bf(jfld)%fnow(:,1,1) 747 ENDIF 748 IF ( dta%ll_u2d ) THEN 749 IF ( ln_full_vel_array(jbdy) ) THEN 750 if(lwp) write(numout,*) '++++++ dta%u2d allocated space' 751 ALLOCATE( dta%u2d(nblen(2)) ) 752 ELSE 753 if(lwp) write(numout,*) '++++++ dta%u2d pointing to fnow' 754 jfld = jfld + 1 755 dta%u2d => bf(jfld)%fnow(:,1,1) 756 ENDIF 757 ENDIF 758 IF ( dta%ll_v2d ) THEN 759 IF ( ln_full_vel_array(jbdy) ) THEN 760 if(lwp) write(numout,*) '++++++ dta%v2d allocated space' 761 ALLOCATE( dta%v2d(nblen(3)) ) 762 ELSE 763 if(lwp) write(numout,*) '++++++ dta%v2d pointing to fnow' 764 jfld = jfld + 1 765 dta%v2d => bf(jfld)%fnow(:,1,1) 766 ENDIF 767 ENDIF 768 ENDIF 769 770 IF ( nn_dyn3d_dta(jbdy) == 0 ) THEN 771 if(lwp) write(numout,*) '++++++ dta%u3d/v3d allocated space' 772 IF( dta%ll_u3d ) ALLOCATE( dta_bdy(jbdy)%u3d(nblen(2),jpk) ) 773 IF( dta%ll_v3d ) ALLOCATE( dta_bdy(jbdy)%v3d(nblen(3),jpk) ) 774 ENDIF 775 IF ( nn_dyn3d_dta(jbdy) == 1 .or. & 776 & ( ln_full_vel_array(jbdy) .and. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN 777 IF ( dta%ll_u3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN 778 if(lwp) write(numout,*) '++++++ dta%u3d pointing to fnow' 779 jfld = jfld + 1 780 dta_bdy(jbdy)%u3d => bf(jfld)%fnow(:,1,:) 781 ENDIF 782 IF ( dta%ll_v3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN 783 if(lwp) write(numout,*) '++++++ dta%v3d pointing to fnow' 784 jfld = jfld + 1 785 dta_bdy(jbdy)%v3d => bf(jfld)%fnow(:,1,:) 786 ENDIF 787 ENDIF 788 789 IF( nn_tra_dta(jbdy) == 0 ) THEN 790 if(lwp) write(numout,*) '++++++ dta%tem/sal allocated space' 791 IF( dta%ll_tem ) ALLOCATE( dta_bdy(jbdy)%tem(nblen(1),jpk) ) 792 IF( dta%ll_sal ) ALLOCATE( dta_bdy(jbdy)%sal(nblen(1),jpk) ) 793 ELSE 794 IF( dta%ll_tem ) THEN 795 if(lwp) write(numout,*) '++++++ dta%tem pointing to fnow' 796 jfld = jfld + 1 797 dta_bdy(jbdy)%tem => bf(jfld)%fnow(:,1,:) 798 ENDIF 799 IF( dta%ll_sal ) THEN 800 if(lwp) write(numout,*) '++++++ dta%sal pointing to fnow' 801 jfld = jfld + 1 802 dta_bdy(jbdy)%sal => bf(jfld)%fnow(:,1,:) 803 ENDIF 804 ENDIF 805 806 #if defined key_si3 807 IF (cn_ice(jbdy) /= 'none') THEN 808 IF( nn_ice_dta(jbdy) == 0 ) THEN 809 ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) ) 810 ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) ) 811 ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) ) 812 ELSE 813 IF ( nice_cat == jpl ) THEN ! case input cat = jpl 814 jfld = jfld + 1 815 dta_bdy(jbdy)%a_i => bf(jfld)%fnow(:,1,:) 816 jfld = jfld + 1 817 dta_bdy(jbdy)%h_i => bf(jfld)%fnow(:,1,:) 818 jfld = jfld + 1 819 dta_bdy(jbdy)%h_s => bf(jfld)%fnow(:,1,:) 820 ELSE ! case input cat = 1 OR (/=1 and /=jpl) 821 jfld_ait(jbdy) = jfld + 1 822 jfld_htit(jbdy) = jfld + 2 823 jfld_htst(jbdy) = jfld + 3 824 jfld = jfld + 3 825 ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) ) 826 ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) ) 827 ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) ) 828 dta_bdy(jbdy)%a_i(:,:) = 0._wp 829 dta_bdy(jbdy)%h_i(:,:) = 0._wp 830 dta_bdy(jbdy)%h_s(:,:) = 0._wp 831 ENDIF 832 833 ENDIF 834 ENDIF 835 #endif 622 IF( llread ) THEN ! get data from NetCDF file 623 CALL fld_fill( bf_alias, bn_alias, cn_dir, 'bdy_dta', cl3//' '//ctmp1, ctmp2 ) ! use namelist info 624 IF( bf_alias(1)%ln_tint ) ALLOCATE( bf_alias(1)%fdta( iszdim, 1, ipk, 2 ) ) 625 bf_alias(1)%imap => idx_bdy(jbdy)%nbmap(1:iszdim,igrd) ! associate the mapping used for this bdy 626 bf_alias(1)%igrd = igrd ! used only for vertical integration of 3D arrays 627 bf_alias(1)%ibdy = jbdy ! " " " " " " " " 628 bf_alias(1)%ltotvel = ln_full_vel ! T if u3d is full velocity 629 bf_alias(1)%lzint = ln_zinterp ! T if it requires a vertical interpolation 630 ENDIF 631 632 ! associate the pointer and get rid of the dimensions with a size equal to 1 633 IF( jfld == jp_bdyssh ) dta_bdy(jbdy)%ssh => bf_alias(1)%fnow(:,1,1) 634 IF( jfld == jp_bdyu2d ) dta_bdy(jbdy)%u2d => bf_alias(1)%fnow(:,1,1) 635 IF( jfld == jp_bdyv2d ) dta_bdy(jbdy)%v2d => bf_alias(1)%fnow(:,1,1) 636 IF( jfld == jp_bdyu3d ) dta_bdy(jbdy)%u3d => bf_alias(1)%fnow(:,1,:) 637 IF( jfld == jp_bdyv3d ) dta_bdy(jbdy)%v3d => bf_alias(1)%fnow(:,1,:) 638 IF( jfld == jp_bdytem ) dta_bdy(jbdy)%tem => bf_alias(1)%fnow(:,1,:) 639 IF( jfld == jp_bdysal ) dta_bdy(jbdy)%sal => bf_alias(1)%fnow(:,1,:) 640 IF( jfld == jp_bdya_i ) THEN 641 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%a_i => bf_alias(1)%fnow(:,1,:) 642 ELSE ; ALLOCATE( dta_bdy(jbdy)%a_i(iszdim,jpl) ) 643 ENDIF 644 ENDIF 645 IF( jfld == jp_bdyh_i ) THEN 646 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%h_i => bf_alias(1)%fnow(:,1,:) 647 ELSE ; ALLOCATE( dta_bdy(jbdy)%h_i(iszdim,jpl) ) 648 ENDIF 649 ENDIF 650 IF( jfld == jp_bdyh_s ) THEN 651 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%h_s => bf_alias(1)%fnow(:,1,:) 652 ELSE ; ALLOCATE( dta_bdy(jbdy)%h_s(iszdim,jpl) ) 653 ENDIF 654 ENDIF 655 IF( jfld == jp_bdyt_i ) THEN 656 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%t_i => bf_alias(1)%fnow(:,1,:) 657 ELSE ; ALLOCATE( dta_bdy(jbdy)%t_i(iszdim,jpl) ) 658 ENDIF 659 ENDIF 660 IF( jfld == jp_bdyt_s ) THEN 661 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%t_s => bf_alias(1)%fnow(:,1,:) 662 ELSE ; ALLOCATE( dta_bdy(jbdy)%t_s(iszdim,jpl) ) 663 ENDIF 664 ENDIF 665 IF( jfld == jp_bdytsu ) THEN 666 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%tsu => bf_alias(1)%fnow(:,1,:) 667 ELSE ; ALLOCATE( dta_bdy(jbdy)%tsu(iszdim,jpl) ) 668 ENDIF 669 ENDIF 670 IF( jfld == jp_bdys_i ) THEN 671 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%s_i => bf_alias(1)%fnow(:,1,:) 672 ELSE ; ALLOCATE( dta_bdy(jbdy)%s_i(iszdim,jpl) ) 673 ENDIF 674 ENDIF 675 IF( jfld == jp_bdyaip ) THEN 676 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%aip => bf_alias(1)%fnow(:,1,:) 677 ELSE ; ALLOCATE( dta_bdy(jbdy)%aip(iszdim,jpl) ) 678 ENDIF 679 ENDIF 680 IF( jfld == jp_bdyhip ) THEN 681 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hip => bf_alias(1)%fnow(:,1,:) 682 ELSE ; ALLOCATE( dta_bdy(jbdy)%hip(iszdim,jpl) ) 683 ENDIF 684 ENDIF 685 ENDIF 686 687 END DO ! jpbdyfld 836 688 ! 837 689 END DO ! jbdy 838 690 ! 839 691 END SUBROUTINE bdy_dta_init 840 692 841 693 !!============================================================================== 842 694 END MODULE bdydta -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdydyn2d.F90
r10529 r12065 14 14 !! bdy_ssh : Duplicate sea level across open boundaries 15 15 !!---------------------------------------------------------------------- 16 USE oce ! ocean dynamics and tracers17 16 USE dom_oce ! ocean space and time domain 18 17 USE bdy_oce ! ocean open boundary conditions … … 50 49 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh 51 50 !! 52 INTEGER :: ib_bdy ! Loop counter 53 54 DO ib_bdy=1, nb_bdy 55 56 SELECT CASE( cn_dyn2d(ib_bdy) ) 57 CASE('none') 58 CYCLE 59 CASE('frs') 60 CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) 61 CASE('flather') 62 CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr ) 63 CASE('orlanski') 64 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 65 & pua2d, pva2d, pub2d, pvb2d, ll_npo=.false.) 66 CASE('orlanski_npo') 67 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 68 & pua2d, pva2d, pub2d, pvb2d, ll_npo=.true. ) 69 CASE DEFAULT 70 CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 71 END SELECT 72 ENDDO 73 51 INTEGER :: ib_bdy, ir ! BDY set index, rim index 52 LOGICAL :: llrim0 ! indicate if rim 0 is treated 53 LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out 54 55 llsend2(:) = .false. ; llrecv2(:) = .false. 56 llsend3(:) = .false. ; llrecv3(:) = .false. 57 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 58 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 59 ELSE ; llrim0 = .FALSE. 60 END IF 61 DO ib_bdy=1, nb_bdy 62 SELECT CASE( cn_dyn2d(ib_bdy) ) 63 CASE('none') 64 CYCLE 65 CASE('frs') ! treat the whole boundary at once 66 IF( llrim0 ) CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) 67 CASE('flather') 68 CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) 69 CASE('orlanski') 70 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 71 & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.false. ) 72 CASE('orlanski_npo') 73 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 74 & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.true. ) 75 CASE DEFAULT 76 CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 77 END SELECT 78 ENDDO 79 ! 80 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 81 IF( nn_hls == 1 ) THEN 82 llsend2(:) = .false. ; llrecv2(:) = .false. 83 llsend3(:) = .false. ; llrecv3(:) = .false. 84 END IF 85 DO ib_bdy=1, nb_bdy 86 SELECT CASE( cn_dyn2d(ib_bdy) ) 87 CASE('flather') 88 llsend2(1:2) = llsend2(1:2) .OR. lsend_bdyint(ib_bdy,2,1:2,ir) ! west/east, U points 89 llsend2(1) = llsend2(1) .OR. lsend_bdyext(ib_bdy,2,1,ir) ! neighbour might search point towards its east bdy 90 llrecv2(1:2) = llrecv2(1:2) .OR. lrecv_bdyint(ib_bdy,2,1:2,ir) ! west/east, U points 91 llrecv2(2) = llrecv2(2) .OR. lrecv_bdyext(ib_bdy,2,2,ir) ! might search point towards bdy on the east 92 llsend3(3:4) = llsend3(3:4) .OR. lsend_bdyint(ib_bdy,3,3:4,ir) ! north/south, V points 93 llsend3(3) = llsend3(3) .OR. lsend_bdyext(ib_bdy,3,3,ir) ! neighbour might search point towards its north bdy 94 llrecv3(3:4) = llrecv3(3:4) .OR. lrecv_bdyint(ib_bdy,3,3:4,ir) ! north/south, V points 95 llrecv3(4) = llrecv3(4) .OR. lrecv_bdyext(ib_bdy,3,4,ir) ! might search point towards bdy on the north 96 CASE('orlanski', 'orlanski_npo') 97 llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points 98 llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points 99 llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points 100 llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points 101 END SELECT 102 END DO 103 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 104 CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 105 END IF 106 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 107 CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 108 END IF 109 ! 110 END DO ! ir 111 ! 74 112 END SUBROUTINE bdy_dyn2d 75 113 … … 90 128 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 91 129 !! 92 INTEGER :: jb , jk! dummy loop indices130 INTEGER :: jb ! dummy loop indices 93 131 INTEGER :: ii, ij, igrd ! local integers 94 132 REAL(wp) :: zwgt ! boundary weight … … 110 148 pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) 111 149 END DO 112 CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )113 CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy) ! Boundary points should be updated114 150 ! 115 151 END SUBROUTINE bdy_dyn2d_frs 116 152 117 153 118 SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr )154 SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) 119 155 !!---------------------------------------------------------------------- 120 156 !! *** SUBROUTINE bdy_dyn2d_fla *** … … 139 175 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 140 176 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 141 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssh, phur, phvr 142 177 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssh, phur, phvr 178 LOGICAL , INTENT(in) :: llrim0 ! indicate if rim 0 is treated 179 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 143 180 INTEGER :: jb, igrd ! dummy loop indices 144 INTEGER :: ii, ij, iim1, iip1, ijm1, ijp1 ! 2D addresses 145 REAL(wp), POINTER :: flagu, flagv ! short cuts 146 REAL(wp) :: zcorr ! Flather correction 147 REAL(wp) :: zforc ! temporary scalar 148 REAL(wp) :: zflag, z1_2 ! " " 181 INTEGER :: ii, ij ! 2D addresses 182 INTEGER :: iiTrim, ijTrim ! T pts i/j-indice on the rim 183 INTEGER :: iiToce, ijToce, iiUoce, ijVoce ! T, U and V pts i/j-indice of the ocean next to the rim 184 REAL(wp) :: flagu, flagv ! short cuts 185 REAL(wp) :: zfla ! Flather correction 186 REAL(wp) :: z1_2 ! 187 REAL(wp), DIMENSION(jpi,jpj) :: sshdta ! 2D version of dta%ssh 149 188 !!---------------------------------------------------------------------- 150 189 … … 153 192 ! ---------------------------------! 154 193 ! Flather boundary conditions :! 155 ! ---------------------------------! 156 157 !!! REPLACE spgu with nemo_wrk work space 158 159 ! Fill temporary array with ssh data (here spgu): 194 ! ---------------------------------! 195 196 ! Fill temporary array with ssh data (here we use spgu with the alias sshdta): 160 197 igrd = 1 161 spgu(:,:) = 0.0 162 DO jb = 1, idx%nblenrim(igrd) 198 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 199 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 200 END IF 201 ! 202 DO jb = ibeg, iend 163 203 ii = idx%nbi(jb,igrd) 164 204 ij = idx%nbj(jb,igrd) 165 IF( ll_wd ) THEN 166 spgu(ii, ij) = dta%ssh(jb) - ssh_ref 167 ELSE 168 spgu(ii, ij) = dta%ssh(jb) 205 IF( ll_wd ) THEN ; sshdta(ii, ij) = dta%ssh(jb) - ssh_ref 206 ELSE ; sshdta(ii, ij) = dta%ssh(jb) 169 207 ENDIF 170 208 END DO 171 172 CALL lbc_bdy_lnk( 'bdydyn2d', spgu(:,:), 'T', 1., ib_bdy ) 173 ! 174 igrd = 2 ! Flather bc on u-velocity; 209 ! 210 igrd = 2 ! Flather bc on u-velocity 175 211 ! ! remember that flagu=-1 if normal velocity direction is outward 176 212 ! ! I think we should rather use after ssh ? 177 DO jb = 1, idx%nblenrim(igrd) 178 ii = idx%nbi(jb,igrd) 179 ij = idx%nbj(jb,igrd) 180 flagu => idx%flagu(jb,igrd) 181 iim1 = ii + MAX( 0, INT( flagu ) ) ! T pts i-indice inside the boundary 182 iip1 = ii - MIN( 0, INT( flagu ) ) ! T pts i-indice outside the boundary 183 ! 184 zcorr = - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iim1, ij) - spgu(iip1,ij) ) 185 186 ! jchanut tschanges: Set zflag to 0 below to revert to Flather scheme 187 ! Use characteristics method instead 188 zflag = ABS(flagu) 189 zforc = dta%u2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pua2d(iim1,ij) 190 pua2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * umask(ii,ij,1) 213 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 214 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 215 END IF 216 DO jb = ibeg, iend 217 ii = idx%nbi(jb,igrd) 218 ij = idx%nbj(jb,igrd) 219 flagu = idx%flagu(jb,igrd) 220 IF( flagu == 0. ) THEN 221 pua2d(ii,ij) = dta%u2d(jb) 222 ELSE ! T pts j-indice on the rim on the ocean next to the rim on T and U points 223 IF( flagu == 1. ) THEN ; iiTrim = ii ; iiToce = ii+1 ; iiUoce = ii+1 ; ENDIF 224 IF( flagu == -1. ) THEN ; iiTrim = ii+1 ; iiToce = ii ; iiUoce = ii-1 ; ENDIF 225 ! 226 ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received 227 IF( iiTrim > jpi .OR. iiToce > jpi .OR. iiUoce > jpi .OR. iiUoce < 1 ) CYCLE 228 ! 229 zfla = dta%u2d(jb) - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iiToce,ij) - sshdta(iiTrim,ij) ) 230 ! 231 ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : 232 ! mix Flather scheme with velocity of the ocean next to the rim 233 pua2d(ii,ij) = z1_2 * ( pua2d(iiUoce,ij) + zfla ) 234 END IF 191 235 END DO 192 236 ! 193 237 igrd = 3 ! Flather bc on v-velocity 194 238 ! ! remember that flagv=-1 if normal velocity direction is outward 195 DO jb = 1, idx%nblenrim(igrd) 196 ii = idx%nbi(jb,igrd) 197 ij = idx%nbj(jb,igrd) 198 flagv => idx%flagv(jb,igrd) 199 ijm1 = ij + MAX( 0, INT( flagv ) ) ! T pts j-indice inside the boundary 200 ijp1 = ij - MIN( 0, INT( flagv ) ) ! T pts j-indice outside the boundary 201 ! 202 zcorr = - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii, ijm1) - spgu(ii,ijp1) ) 203 204 ! jchanut tschanges: Set zflag to 0 below to revert to std Flather scheme 205 ! Use characteristics method instead 206 zflag = ABS(flagv) 207 zforc = dta%v2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pva2d(ii,ijm1) 208 pva2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * vmask(ii,ij,1) 209 END DO 210 CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy ) ! Boundary points should be updated 211 CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy ) ! 239 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 240 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 241 END IF 242 DO jb = ibeg, iend 243 ii = idx%nbi(jb,igrd) 244 ij = idx%nbj(jb,igrd) 245 flagv = idx%flagv(jb,igrd) 246 IF( flagv == 0. ) THEN 247 pva2d(ii,ij) = dta%v2d(jb) 248 ELSE ! T pts j-indice on the rim on the ocean next to the rim on T and V points 249 IF( flagv == 1. ) THEN ; ijTrim = ij ; ijToce = ij+1 ; ijVoce = ij+1 ; ENDIF 250 IF( flagv == -1. ) THEN ; ijTrim = ij+1 ; ijToce = ij ; ijVoce = ij-1 ; ENDIF 251 ! 252 ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received 253 IF( ijTrim > jpj .OR. ijToce > jpj .OR. ijVoce > jpj .OR. ijVoce < 1 ) CYCLE 254 ! 255 zfla = dta%v2d(jb) - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii,ijToce) - sshdta(ii,ijTrim) ) 256 ! 257 ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : 258 ! mix Flather scheme with velocity of the ocean next to the rim 259 pva2d(ii,ij) = z1_2 * ( pva2d(ii,ijVoce) + zfla ) 260 END IF 261 END DO 212 262 ! 213 263 END SUBROUTINE bdy_dyn2d_fla 214 264 215 265 216 SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, ll _npo )266 SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo ) 217 267 !!---------------------------------------------------------------------- 218 268 !! *** SUBROUTINE bdy_dyn2d_orlanski *** … … 231 281 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d 232 282 LOGICAL, INTENT(in) :: ll_npo ! flag for NPO version 233 283 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 234 284 INTEGER :: ib, igrd ! dummy loop indices 235 285 INTEGER :: ii, ij, iibm1, ijbm1 ! indices … … 238 288 igrd = 2 ! Orlanski bc on u-velocity; 239 289 ! 240 CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, ll _npo )290 CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, llrim0, ll_npo ) 241 291 242 292 igrd = 3 ! Orlanski bc on v-velocity 243 293 ! 244 CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ll_npo ) 245 ! 246 CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy ) ! Boundary points should be updated 247 CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy ) ! 294 CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, llrim0, ll_npo ) 248 295 ! 249 296 END SUBROUTINE bdy_dyn2d_orlanski … … 257 304 !! 258 305 !!---------------------------------------------------------------------- 259 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zssh ! Sea level 260 !! 261 INTEGER :: ib_bdy, ib, igrd ! local integers 262 INTEGER :: ii, ij, zcoef, zcoef1, zcoef2, ip, jp ! " " 263 264 igrd = 1 ! Everything is at T-points here 265 266 DO ib_bdy = 1, nb_bdy 267 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 268 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 269 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 270 ! Set gradient direction: 271 zcoef1 = bdytmask(ii-1,ij ) + bdytmask(ii+1,ij ) 272 zcoef2 = bdytmask(ii ,ij-1) + bdytmask(ii ,ij+1) 273 IF ( zcoef1+zcoef2 == 0 ) THEN ! corner 274 zcoef = bdytmask(ii-1,ij-1) + bdytmask(ii+1,ij+1) + bdytmask(ii+1,ij-1) + bdytmask(ii-1,ij+1) 275 zssh(ii,ij) = zssh( ii-1, ij-1 ) * bdytmask( ii-1, ij-1) + & 276 & zssh( ii+1, ij+1 ) * bdytmask( ii+1, ij+1) + & 277 & zssh( ii+1, ij-1 ) * bdytmask( ii+1, ij-1) + & 278 & zssh( ii-1, ij+1 ) * bdytmask( ii-1, ij+1) 279 zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 280 ELSE 281 ip = bdytmask(ii+1,ij ) - bdytmask(ii-1,ij ) 282 jp = bdytmask(ii ,ij+1) - bdytmask(ii ,ij-1) 283 zssh(ii,ij) = zssh(ii+ip,ij+jp) * tmask(ii+ip,ij+jp,1) 284 ENDIF 306 REAL(wp), DIMENSION(jpi,jpj,1), INTENT(inout) :: zssh ! Sea level, need 3 dimensions to be used by bdy_nmn 307 !! 308 INTEGER :: ib_bdy, ir ! bdy index, rim index 309 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 310 LOGICAL :: llrim0 ! indicate if rim 0 is treated 311 LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out 312 !!---------------------------------------------------------------------- 313 llsend1(:) = .false. ; llrecv1(:) = .false. 314 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 315 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF 316 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 317 ELSE ; llrim0 = .FALSE. 318 END IF 319 DO ib_bdy = 1, nb_bdy 320 CALL bdy_nmn( idx_bdy(ib_bdy), 1, zssh, llrim0 ) ! zssh is masked 321 llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 322 llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 285 323 END DO 286 287 ! Boundary points should be updated 288 CALL lbc_bdy_lnk( 'bdydyn2d', zssh(:,:), 'T', 1., ib_bdy ) 289 END DO 290 324 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 325 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 326 CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 327 END IF 328 END DO 329 ! 291 330 END SUBROUTINE bdy_ssh 292 331 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdydyn3d.F90
r10529 r12065 42 42 INTEGER, INTENT(in) :: kt ! Main time step counter 43 43 ! 44 INTEGER :: ib_bdy ! loop index 45 !!---------------------------------------------------------------------- 46 ! 47 DO ib_bdy=1, nb_bdy 44 INTEGER :: ib_bdy, ir ! BDY set index, rim index 45 LOGICAL :: llrim0 ! indicate if rim 0 is treated 46 LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out 47 48 !!---------------------------------------------------------------------- 49 llsend2(:) = .false. ; llrecv2(:) = .false. 50 llsend3(:) = .false. ; llrecv3(:) = .false. 51 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 52 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 53 ELSE ; llrim0 = .FALSE. 54 END IF 55 DO ib_bdy=1, nb_bdy 56 ! 57 SELECT CASE( cn_dyn3d(ib_bdy) ) 58 CASE('none') ; CYCLE 59 CASE('frs' ) ! treat the whole boundary at once 60 IF( ir == 0) CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 61 CASE('specified') ! treat the whole rim at once 62 IF( ir == 0) CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 63 CASE('zero') ! treat the whole rim at once 64 IF( ir == 0) CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 65 CASE('orlanski' ) ; CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.false. ) 66 CASE('orlanski_npo'); CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.true. ) 67 CASE('zerograd') ; CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy, llrim0 ) 68 CASE('neumann') ; CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy, llrim0 ) 69 CASE DEFAULT ; CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 70 END SELECT 71 END DO 48 72 ! 49 SELECT CASE( cn_dyn3d(ib_bdy) ) 50 CASE('none') ; CYCLE 51 CASE('frs' ) ; CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 52 CASE('specified') ; CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 53 CASE('zero') ; CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 54 CASE('orlanski' ) ; CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 55 CASE('orlanski_npo'); CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 56 CASE('zerograd') ; CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 57 CASE('neumann') ; CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy ) 58 CASE DEFAULT ; CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 59 END SELECT 60 END DO 73 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 74 IF( nn_hls == 1 ) THEN 75 llsend2(:) = .false. ; llrecv2(:) = .false. 76 llsend3(:) = .false. ; llrecv3(:) = .false. 77 END IF 78 DO ib_bdy=1, nb_bdy 79 SELECT CASE( cn_dyn3d(ib_bdy) ) 80 CASE('orlanski', 'orlanski_npo') 81 llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points 82 llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points 83 llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points 84 llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points 85 CASE('zerograd') 86 llsend2(3:4) = llsend2(3:4) .OR. lsend_bdyint(ib_bdy,2,3:4,ir) ! north/south, U points 87 llrecv2(3:4) = llrecv2(3:4) .OR. lrecv_bdyint(ib_bdy,2,3:4,ir) ! north/south, U points 88 llsend3(1:2) = llsend3(1:2) .OR. lsend_bdyint(ib_bdy,3,1:2,ir) ! west/east, V points 89 llrecv3(1:2) = llrecv3(1:2) .OR. lrecv_bdyint(ib_bdy,3,1:2,ir) ! west/east, V points 90 CASE('neumann') 91 llsend2(:) = llsend2(:) .OR. lsend_bdyint(ib_bdy,2,:,ir) ! possibly every direction, U points 92 llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(ib_bdy,2,:,ir) ! possibly every direction, U points 93 llsend3(:) = llsend3(:) .OR. lsend_bdyint(ib_bdy,3,:,ir) ! possibly every direction, V points 94 llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(ib_bdy,3,:,ir) ! possibly every direction, V points 95 END SELECT 96 END DO 97 ! 98 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 99 CALL lbc_lnk( 'bdydyn2d', ua, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 100 END IF 101 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 102 CALL lbc_lnk( 'bdydyn2d', va, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 103 END IF 104 END DO ! ir 61 105 ! 62 106 END SUBROUTINE bdy_dyn3d … … 78 122 INTEGER :: jb, jk ! dummy loop indices 79 123 INTEGER :: ii, ij, igrd ! local integers 80 REAL(wp) :: zwgt ! boundary weight81 124 !!---------------------------------------------------------------------- 82 125 ! … … 98 141 END DO 99 142 END DO 100 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated101 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )102 !103 IF( kt == nit000 ) CLOSE( unit = 102 )104 143 ! 105 144 END SUBROUTINE bdy_dyn3d_spe 106 145 107 146 108 SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt , ib_bdy)147 SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt, ib_bdy, llrim0 ) 109 148 !!---------------------------------------------------------------------- 110 149 !! *** SUBROUTINE bdy_dyn3d_zgrad *** … … 114 153 !!---------------------------------------------------------------------- 115 154 INTEGER :: kt 116 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 117 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 118 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 155 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 156 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 157 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 158 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 119 159 !! 120 160 INTEGER :: jb, jk ! dummy loop indices 121 161 INTEGER :: ii, ij, igrd ! local integers 122 REAL(wp) :: zwgt ! boundary weight123 INTEGER :: fu, fv162 INTEGER :: flagu, flagv ! short cuts 163 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) 124 164 !!---------------------------------------------------------------------- 125 165 ! 126 166 igrd = 2 ! Copying tangential velocity into bdy points 127 DO jb = 1, idx%nblenrim(igrd) 128 DO jk = 1, jpkm1 129 ii = idx%nbi(jb,igrd) 130 ij = idx%nbj(jb,igrd) 131 fu = ABS( ABS (NINT( idx%flagu(jb,igrd) ) ) - 1 ) 132 ua(ii,ij,jk) = ua(ii,ij,jk) * REAL( 1 - fu) + ( ua(ii,ij+fu,jk) * umask(ii,ij+fu,jk) & 133 &+ ua(ii,ij-fu,jk) * umask(ii,ij-fu,jk) ) * umask(ii,ij,jk) * REAL( fu ) 134 END DO 167 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 168 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 169 ENDIF 170 DO jb = ibeg, iend 171 ii = idx%nbi(jb,igrd) 172 ij = idx%nbj(jb,igrd) 173 flagu = NINT(idx%flagu(jb,igrd)) 174 flagv = NINT(idx%flagv(jb,igrd)) 175 ! 176 IF( flagu == 0 ) THEN ! north/south bdy 177 IF( ij+flagv > jpj .OR. ij+flagv < 1 ) CYCLE 178 ! 179 DO jk = 1, jpkm1 180 ua(ii,ij,jk) = ua(ii,ij+flagv,jk) * umask(ii,ij+flagv,jk) 181 END DO 182 ! 183 END IF 135 184 END DO 136 185 ! 137 186 igrd = 3 ! Copying tangential velocity into bdy points 138 DO jb = 1, idx%nblenrim(igrd) 139 DO jk = 1, jpkm1 140 ii = idx%nbi(jb,igrd) 141 ij = idx%nbj(jb,igrd) 142 fv = ABS( ABS (NINT( idx%flagv(jb,igrd) ) ) - 1 ) 143 va(ii,ij,jk) = va(ii,ij,jk) * REAL( 1 - fv ) + ( va(ii+fv,ij,jk) * vmask(ii+fv,ij,jk) & 144 &+ va(ii-fv,ij,jk) * vmask(ii-fv,ij,jk) ) * vmask(ii,ij,jk) * REAL( fv ) 145 END DO 146 END DO 147 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 148 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 149 ! 150 IF( kt == nit000 ) CLOSE( unit = 102 ) 187 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 188 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 189 ENDIF 190 DO jb = ibeg, iend 191 ii = idx%nbi(jb,igrd) 192 ij = idx%nbj(jb,igrd) 193 flagu = NINT(idx%flagu(jb,igrd)) 194 flagv = NINT(idx%flagv(jb,igrd)) 195 ! 196 IF( flagv == 0 ) THEN ! west/east bdy 197 IF( ii+flagu > jpi .OR. ii+flagu < 1 ) CYCLE 198 ! 199 DO jk = 1, jpkm1 200 va(ii,ij,jk) = va(ii+flagu,ij,jk) * vmask(ii+flagu,ij,jk) 201 END DO 202 ! 203 END IF 204 END DO 151 205 ! 152 206 END SUBROUTINE bdy_dyn3d_zgrad … … 167 221 INTEGER :: ib, ik ! dummy loop indices 168 222 INTEGER :: ii, ij, igrd ! local integers 169 REAL(wp) :: zwgt ! boundary weight170 223 !!---------------------------------------------------------------------- 171 224 ! … … 178 231 END DO 179 232 END DO 180 233 ! 181 234 igrd = 3 ! Everything is at T-points here 182 235 DO ib = 1, idx%nblenrim(igrd) … … 187 240 END DO 188 241 END DO 189 !190 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ; CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1.,ib_bdy ) ! Boundary points should be updated191 !192 IF( kt == nit000 ) CLOSE( unit = 102 )193 242 ! 194 243 END SUBROUTINE bdy_dyn3d_zro … … 234 283 va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta%v3d(jb,jk) - va(ii,ij,jk) ) ) * vmask(ii,ij,jk) 235 284 END DO 236 END DO 237 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 238 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 239 ! 240 IF( kt == nit000 ) CLOSE( unit = 102 ) 285 END DO 241 286 ! 242 287 END SUBROUTINE bdy_dyn3d_frs 243 288 244 289 245 SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, ll _npo )290 SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, llrim0, ll_npo ) 246 291 !!---------------------------------------------------------------------- 247 292 !! *** SUBROUTINE bdy_dyn3d_orlanski *** … … 255 300 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 256 301 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 257 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 258 LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version 302 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 303 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 304 LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version 259 305 260 306 INTEGER :: jb, igrd ! dummy loop indices … … 265 311 igrd = 2 ! Orlanski bc on u-velocity; 266 312 ! 267 CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo )313 CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo, llrim0 ) 268 314 269 315 igrd = 3 ! Orlanski bc on v-velocity 270 316 ! 271 CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo ) 272 ! 273 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 274 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 317 CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo, llrim0 ) 275 318 ! 276 319 END SUBROUTINE bdy_dyn3d_orlanski … … 320 363 END DO 321 364 ! 322 CALL lbc_lnk_multi( 'bdydyn3d', ua, 'U', -1., va, 'V', -1. ) ! Boundary points should be updated323 !324 365 IF( ln_timing ) CALL timing_stop('bdy_dyn3d_dmp') 325 366 ! … … 327 368 328 369 329 SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy )370 SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy, llrim0 ) 330 371 !!---------------------------------------------------------------------- 331 372 !! *** SUBROUTINE bdy_dyn3d_nmn *** … … 336 377 !! 337 378 !!---------------------------------------------------------------------- 338 TYPE(OBC_INDEX), INTENT(in) :: idx! OBC indices339 INTEGER, INTENT(in) :: ib_bdy! BDY set index340 341 INTEGER :: jb, igrd ! dummy loop indices379 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 380 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 381 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 382 INTEGER :: igrd ! dummy indice 342 383 !!---------------------------------------------------------------------- 343 384 ! … … 346 387 igrd = 2 ! Neumann bc on u-velocity; 347 388 ! 348 CALL bdy_nmn( idx, igrd, ua )389 CALL bdy_nmn( idx, igrd, ua, llrim0 ) ! ua is masked 349 390 350 391 igrd = 3 ! Neumann bc on v-velocity 351 392 ! 352 CALL bdy_nmn( idx, igrd, va ) 353 ! 354 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 355 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 393 CALL bdy_nmn( idx, igrd, va, llrim0 ) ! va is masked 356 394 ! 357 395 END SUBROUTINE bdy_dyn3d_nmn -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdyice.F90
r10425 r12065 55 55 INTEGER, INTENT(in) :: kt ! Main time step counter 56 56 ! 57 INTEGER :: jbdy ! BDY set index 57 INTEGER :: jbdy, ir ! BDY set index, rim index 58 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 59 LOGICAL :: llrim0 ! indicate if rim 0 is treated 60 LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out 58 61 !!---------------------------------------------------------------------- 59 ! 60 IF( ln_timing ) CALL timing_start('bdy_ice_thd') 62 ! controls 63 IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing 64 IF( ln_icediachk ) CALL ice_cons_hsm(0,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 65 IF( ln_icediachk ) CALL ice_cons2D (0,'bdy_ice_thd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation 61 66 ! 62 67 CALL ice_var_glo2eqv 63 68 ! 64 DO jbdy = 1, nb_bdy 69 llsend1(:) = .false. ; llrecv1(:) = .false. 70 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 71 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 72 ELSE ; llrim0 = .FALSE. 73 END IF 74 DO jbdy = 1, nb_bdy 75 ! 76 SELECT CASE( cn_ice(jbdy) ) 77 CASE('none') ; CYCLE 78 CASE('frs' ) ; CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy, llrim0 ) 79 CASE DEFAULT 80 CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) 81 END SELECT 82 ! 83 END DO 65 84 ! 66 SELECT CASE( cn_ice(jbdy) ) 67 CASE('none') ; CYCLE 68 CASE('frs' ) ; CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy ) 69 CASE DEFAULT 70 CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) 71 END SELECT 72 ! 73 END DO 85 ! Update bdy points 86 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 87 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF 88 DO jbdy = 1, nb_bdy 89 IF( cn_ice(jbdy) == 'frs' ) THEN 90 llsend1(:) = llsend1(:) .OR. lsend_bdyint(jbdy,1,:,ir) ! possibly every direction, T points 91 llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(jbdy,1,:,ir) ! possibly every direction, T points 92 END IF 93 END DO ! jbdy 94 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 95 ! exchange 3d arrays 96 CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1., h_i , 'T', 1., h_s , 'T', 1., oa_i, 'T', 1. & 97 & , a_ip, 'T', 1., v_ip, 'T', 1., s_i , 'T', 1., t_su, 'T', 1. & 98 & , v_i , 'T', 1., v_s , 'T', 1., sv_i, 'T', 1. & 99 & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 100 ! exchange 4d arrays : third dimension = 1 and then third dimension = jpk 101 CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1., e_s , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 102 CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1., e_i , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 END IF 104 END DO ! ir 74 105 ! 75 106 CALL ice_cor( kt , 0 ) ! -- In case categories are out of bounds, do a remapping … … 78 109 CALL ice_var_agg(1) 79 110 ! 80 IF( ln_icectl ) CALL ice_prt( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) 81 IF( ln_timing ) CALL timing_stop('bdy_ice_thd') 111 ! controls 112 IF( ln_icectl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints 113 IF( ln_icediachk ) CALL ice_cons_hsm(1,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 114 IF( ln_icediachk ) CALL ice_cons2D (1,'bdy_ice_thd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation 115 IF( ln_timing ) CALL timing_stop ('bdy_ice_thd') ! timing 82 116 ! 83 117 END SUBROUTINE bdy_ice 84 118 85 119 86 SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy )120 SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy, llrim0 ) 87 121 !!------------------------------------------------------------------------------ 88 122 !! *** SUBROUTINE bdy_ice_frs *** … … 93 127 !! dimensional baroclinic ocean model with realistic topography. Tellus, 365-382. 94 128 !!------------------------------------------------------------------------------ 95 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 96 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 97 INTEGER, INTENT(in) :: kt ! main time-step counter 98 INTEGER, INTENT(in) :: jbdy ! BDY set index 129 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 130 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 131 INTEGER, INTENT(in) :: kt ! main time-step counter 132 INTEGER, INTENT(in) :: jbdy ! BDY set index 133 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 99 134 ! 100 135 INTEGER :: jpbound ! 0 = incoming ice 101 136 ! ! 1 = outgoing ice 137 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 102 138 INTEGER :: i_bdy, jgrd ! dummy loop indices 103 139 INTEGER :: ji, jj, jk, jl, ib, jb 104 140 REAL(wp) :: zwgt, zwgt1 ! local scalar 105 141 REAL(wp) :: ztmelts, zdh 142 REAL(wp), POINTER :: flagu, flagv ! short cuts 106 143 !!------------------------------------------------------------------------------ 107 144 ! 108 145 jgrd = 1 ! Everything is at T-points here 146 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(jgrd) 147 ELSE ; ibeg = idx%nblenrim0(jgrd)+1 ; iend = idx%nblenrim(jgrd) 148 END IF 109 149 ! 110 150 DO jl = 1, jpl 111 DO i_bdy = 1, idx%nblenrim(jgrd)151 DO i_bdy = ibeg, iend 112 152 ji = idx%nbi(i_bdy,jgrd) 113 153 jj = idx%nbj(i_bdy,jgrd) 114 154 zwgt = idx%nbw(i_bdy,jgrd) 115 155 zwgt1 = 1.e0 - idx%nbw(i_bdy,jgrd) 116 a_i(ji,jj,jl) = ( a_i(ji,jj,jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Leads fraction 117 h_i(ji,jj,jl) = ( h_i(ji,jj,jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice depth 118 h_s(ji,jj,jl) = ( h_s(ji,jj,jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow depth 119 156 a_i (ji,jj, jl) = ( a_i (ji,jj, jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice concentration 157 h_i (ji,jj, jl) = ( h_i (ji,jj, jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice depth 158 h_s (ji,jj, jl) = ( h_s (ji,jj, jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow depth 159 t_i (ji,jj,:,jl) = ( t_i (ji,jj,:,jl) * zwgt1 + dta%t_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice temperature 160 t_s (ji,jj,:,jl) = ( t_s (ji,jj,:,jl) * zwgt1 + dta%t_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow temperature 161 t_su(ji,jj, jl) = ( t_su(ji,jj, jl) * zwgt1 + dta%tsu(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Surf temperature 162 s_i (ji,jj, jl) = ( s_i (ji,jj, jl) * zwgt1 + dta%s_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice salinity 163 a_ip(ji,jj, jl) = ( a_ip(ji,jj, jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond concentration 164 h_ip(ji,jj, jl) = ( h_ip(ji,jj, jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond depth 165 ! 166 sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) 167 ! 168 ! make sure ponds = 0 if no ponds scheme 169 IF( .NOT.ln_pnd ) THEN 170 a_ip(ji,jj,jl) = 0._wp 171 h_ip(ji,jj,jl) = 0._wp 172 ENDIF 173 ! 120 174 ! ----------------- 121 175 ! Pathological case … … 132 186 h_i(ji,jj,jl) = MIN( hi_max(jl), h_i(ji,jj,jl) + zdh ) 133 187 h_s(ji,jj,jl) = MAX( 0._wp, h_s(ji,jj,jl) - zdh * rhoi / rhos ) 134 188 ! 135 189 ENDDO 136 190 ENDDO 137 CALL lbc_bdy_lnk( 'bdyice', a_i(:,:,:), 'T', 1., jbdy )138 CALL lbc_bdy_lnk( 'bdyice', h_i(:,:,:), 'T', 1., jbdy )139 CALL lbc_bdy_lnk( 'bdyice', h_s(:,:,:), 'T', 1., jbdy )140 191 141 192 DO jl = 1, jpl 142 DO i_bdy = 1, idx%nblenrim(jgrd)193 DO i_bdy = ibeg, iend 143 194 ji = idx%nbi(i_bdy,jgrd) 144 195 jj = idx%nbj(i_bdy,jgrd) 145 196 flagu => idx%flagu(i_bdy,jgrd) 197 flagv => idx%flagv(i_bdy,jgrd) 146 198 ! condition on ice thickness depends on the ice velocity 147 199 ! if velocity is outward (strictly), then ice thickness, volume... must be equal to adjacent values 148 200 jpbound = 0 ; ib = ji ; jb = jj 149 201 ! 150 IF( u_ice(ji+1,jj ) < 0. .AND. umask(ji-1,jj ,1) == 0. ) jpbound = 1 ; ib = ji+1 ; jb = jj 151 IF( u_ice(ji-1,jj ) > 0. .AND. umask(ji+1,jj ,1) == 0. ) jpbound = 1 ; ib = ji-1 ; jb = jj 152 IF( v_ice(ji ,jj+1) < 0. .AND. vmask(ji ,jj-1,1) == 0. ) jpbound = 1 ; ib = ji ; jb = jj+1 153 IF( v_ice(ji ,jj-1) > 0. .AND. vmask(ji ,jj+1,1) == 0. ) jpbound = 1 ; ib = ji ; jb = jj-1 202 IF( flagu == 1. ) THEN 203 IF( ji+1 > jpi ) CYCLE 204 IF( u_ice(ji ,jj ) < 0. ) jpbound = 1 ; ib = ji+1 205 END IF 206 IF( flagu == -1. ) THEN 207 IF( ji-1 < 1 ) CYCLE 208 IF( u_ice(ji-1,jj ) < 0. ) jpbound = 1 ; ib = ji-1 209 END IF 210 IF( flagv == 1. ) THEN 211 IF( jj+1 > jpj ) CYCLE 212 IF( v_ice(ji ,jj ) < 0. ) jpbound = 1 ; jb = jj+1 213 END IF 214 IF( flagv == -1. ) THEN 215 IF( jj-1 < 1 ) CYCLE 216 IF( v_ice(ji ,jj-1) < 0. ) jpbound = 1 ; jb = jj-1 217 END IF 154 218 ! 155 219 IF( nn_ice_dta(jbdy) == 0 ) jpbound = 0 ; ib = ji ; jb = jj ! case ice boundaries = initial conditions … … 158 222 IF( a_i(ib,jb,jl) > 0._wp ) THEN ! there is ice at the boundary 159 223 ! 160 a_i(ji,jj,jl) = a_i(ib,jb,jl) ! concentration 161 h_i(ji,jj,jl) = h_i(ib,jb,jl) ! thickness ice 162 h_s(ji,jj,jl) = h_s(ib,jb,jl) ! thickness snw 163 ! 164 SELECT CASE( jpbound ) 165 ! 166 CASE( 0 ) ! velocity is inward 167 ! 168 oa_i(ji,jj, jl) = rn_ice_age(jbdy) * a_i(ji,jj,jl) ! age 169 a_ip(ji,jj, jl) = 0._wp ! pond concentration 170 v_ip(ji,jj, jl) = 0._wp ! pond volume 171 t_su(ji,jj, jl) = rn_ice_tem(jbdy) ! temperature surface 172 t_s (ji,jj,:,jl) = rn_ice_tem(jbdy) ! temperature snw 173 t_i (ji,jj,:,jl) = rn_ice_tem(jbdy) ! temperature ice 174 s_i (ji,jj, jl) = rn_ice_sal(jbdy) ! salinity 175 sz_i(ji,jj,:,jl) = rn_ice_sal(jbdy) ! salinity profile 176 ! 177 CASE( 1 ) ! velocity is outward 178 ! 179 oa_i(ji,jj, jl) = oa_i(ib,jb, jl) ! age 180 a_ip(ji,jj, jl) = a_ip(ib,jb, jl) ! pond concentration 181 v_ip(ji,jj, jl) = v_ip(ib,jb, jl) ! pond volume 182 t_su(ji,jj, jl) = t_su(ib,jb, jl) ! temperature surface 183 t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) ! temperature snw 184 t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) ! temperature ice 185 s_i (ji,jj, jl) = s_i (ib,jb, jl) ! salinity 186 sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) ! salinity profile 187 ! 188 END SELECT 224 a_i (ji,jj, jl) = a_i (ib,jb, jl) 225 h_i (ji,jj, jl) = h_i (ib,jb, jl) 226 h_s (ji,jj, jl) = h_s (ib,jb, jl) 227 t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) 228 t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) 229 t_su(ji,jj, jl) = t_su(ib,jb, jl) 230 s_i (ji,jj, jl) = s_i (ib,jb, jl) 231 a_ip(ji,jj, jl) = a_ip(ib,jb, jl) 232 h_ip(ji,jj, jl) = h_ip(ib,jb, jl) 233 ! 234 sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) 235 ! 236 ! ice age 237 IF ( jpbound == 0 ) THEN ! velocity is inward 238 oa_i(ji,jj,jl) = rice_age(jbdy) * a_i(ji,jj,jl) 239 ELSEIF( jpbound == 1 ) THEN ! velocity is outward 240 oa_i(ji,jj,jl) = oa_i(ib,jb,jl) 241 ENDIF 189 242 ! 190 243 IF( nn_icesal == 1 ) THEN ! if constant salinity … … 211 264 END DO 212 265 ! 266 ! melt ponds 267 IF( a_i(ji,jj,jl) > epsi10 ) THEN 268 a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i (ji,jj,jl) 269 ELSE 270 a_ip_frac(ji,jj,jl) = 0._wp 271 ENDIF 272 v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) 273 ! 213 274 ELSE ! no ice at the boundary 214 275 ! … … 222 283 t_s (ji,jj,:,jl) = rt0 223 284 t_i (ji,jj,:,jl) = rt0 285 286 a_ip_frac(ji,jj,jl) = 0._wp 287 h_ip (ji,jj,jl) = 0._wp 288 a_ip (ji,jj,jl) = 0._wp 289 v_ip (ji,jj,jl) = 0._wp 224 290 225 291 IF( nn_icesal == 1 ) THEN ! if constant salinity … … 243 309 ! 244 310 END DO ! jl 245 246 CALL lbc_bdy_lnk( 'bdyice', a_i (:,:,:) , 'T', 1., jbdy )247 CALL lbc_bdy_lnk( 'bdyice', h_i (:,:,:) , 'T', 1., jbdy )248 CALL lbc_bdy_lnk( 'bdyice', h_s (:,:,:) , 'T', 1., jbdy )249 CALL lbc_bdy_lnk( 'bdyice', oa_i(:,:,:) , 'T', 1., jbdy )250 CALL lbc_bdy_lnk( 'bdyice', a_ip(:,:,:) , 'T', 1., jbdy )251 CALL lbc_bdy_lnk( 'bdyice', v_ip(:,:,:) , 'T', 1., jbdy )252 CALL lbc_bdy_lnk( 'bdyice', s_i (:,:,:) , 'T', 1., jbdy )253 CALL lbc_bdy_lnk( 'bdyice', t_su(:,:,:) , 'T', 1., jbdy )254 CALL lbc_bdy_lnk( 'bdyice', v_i (:,:,:) , 'T', 1., jbdy )255 CALL lbc_bdy_lnk( 'bdyice', v_s (:,:,:) , 'T', 1., jbdy )256 CALL lbc_bdy_lnk( 'bdyice', sv_i(:,:,:) , 'T', 1., jbdy )257 CALL lbc_bdy_lnk( 'bdyice', t_s (:,:,:,:), 'T', 1., jbdy )258 CALL lbc_bdy_lnk( 'bdyice', e_s (:,:,:,:), 'T', 1., jbdy )259 CALL lbc_bdy_lnk( 'bdyice', t_i (:,:,:,:), 'T', 1., jbdy )260 CALL lbc_bdy_lnk( 'bdyice', e_i (:,:,:,:), 'T', 1., jbdy )261 311 ! 262 312 END SUBROUTINE bdy_ice_frs … … 276 326 CHARACTER(len=1), INTENT(in) :: cd_type ! nature of velocity grid-points 277 327 ! 278 INTEGER :: i_bdy, jgrd ! dummy loop indices 279 INTEGER :: ji, jj ! local scalar 280 INTEGER :: jbdy ! BDY set index 328 INTEGER :: i_bdy, jgrd ! dummy loop indices 329 INTEGER :: ji, jj ! local scalar 330 INTEGER :: jbdy, ir ! BDY set index, rim index 331 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 281 332 REAL(wp) :: zmsk1, zmsk2, zflag 333 LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out 282 334 !!------------------------------------------------------------------------------ 283 335 IF( ln_timing ) CALL timing_start('bdy_ice_dyn') 284 336 ! 285 DO jbdy=1, nb_bdy 337 llsend2(:) = .false. ; llrecv2(:) = .false. 338 llsend3(:) = .false. ; llrecv3(:) = .false. 339 DO ir = 1, 0, -1 340 DO jbdy = 1, nb_bdy 341 ! 342 SELECT CASE( cn_ice(jbdy) ) 343 ! 344 CASE('none') 345 CYCLE 346 ! 347 CASE('frs') 348 ! 349 IF( nn_ice_dta(jbdy) == 0 ) CYCLE ! case ice boundaries = initial conditions 350 ! ! do not change ice velocity (it is only computed by rheology) 351 SELECT CASE ( cd_type ) 352 ! 353 CASE ( 'U' ) 354 jgrd = 2 ! u velocity 355 IF( ir == 0 ) THEN ; ibeg = 1 ; iend = idx_bdy(jbdy)%nblenrim0(jgrd) 356 ELSE ; ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1 ; iend = idx_bdy(jbdy)%nblenrim(jgrd) 357 END IF 358 DO i_bdy = ibeg, iend 359 ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 360 jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 361 zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) 362 ! i-1 i i | ! i i i+1 | ! i i i+1 | 363 ! > ice > | ! o > ice | ! o > o | 364 ! => set at u_ice(i-1) ! => set to O ! => unchanged 365 IF( zflag == -1. .AND. ji > 1 .AND. ji < jpi ) THEN 366 IF ( vt_i(ji ,jj) > 0. ) THEN ; u_ice(ji,jj) = u_ice(ji-1,jj) 367 ELSEIF( vt_i(ji+1,jj) > 0. ) THEN ; u_ice(ji,jj) = 0._wp 368 END IF 369 END IF 370 ! | i i+1 i+1 ! | i i i+1 ! | i i i+1 371 ! | > ice > ! | ice > o ! | o > o 372 ! => set at u_ice(i+1) ! => set to O ! => unchanged 373 IF( zflag == 1. .AND. ji+1 < jpi+1 ) THEN 374 IF ( vt_i(ji+1,jj) > 0. ) THEN ; u_ice(ji,jj) = u_ice(ji+1,jj) 375 ELSEIF( vt_i(ji ,jj) > 0. ) THEN ; u_ice(ji,jj) = 0._wp 376 END IF 377 END IF 378 ! 379 IF( zflag == 0. ) u_ice(ji,jj) = 0._wp ! u_ice = 0 if north/south bdy 380 ! 381 END DO 382 ! 383 CASE ( 'V' ) 384 jgrd = 3 ! v velocity 385 IF( ir == 0 ) THEN ; ibeg = 1 ; iend = idx_bdy(jbdy)%nblenrim0(jgrd) 386 ELSE ; ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1 ; iend = idx_bdy(jbdy)%nblenrim(jgrd) 387 END IF 388 DO i_bdy = ibeg, iend 389 ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 390 jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 391 zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) 392 ! ! ice (jj+1) ! o (jj+1) 393 ! ^ (jj ) ! ^ (jj ) ! ^ (jj ) 394 ! ice (jj ) ! o (jj ) ! o (jj ) 395 ! ^ (jj-1) ! ! 396 ! => set to u_ice(jj-1) ! => set to 0 ! => unchanged 397 IF( zflag == -1. .AND. jj > 1 .AND. jj < jpj ) THEN 398 IF ( vt_i(ji,jj ) > 0. ) THEN ; v_ice(ji,jj) = v_ice(ji,jj-1) 399 ELSEIF( vt_i(ji,jj+1) > 0. ) THEN ; v_ice(ji,jj) = 0._wp 400 END IF 401 END IF 402 ! ^ (jj+1) ! ! 403 ! ice (jj+1) ! o (jj+1) ! o (jj+1) 404 ! ^ (jj ) ! ^ (jj ) ! ^ (jj ) 405 ! ________________ ! ____ice___(jj )_ ! _____o____(jj ) 406 ! => set to u_ice(jj+1) ! => set to 0 ! => unchanged 407 IF( zflag == 1. .AND. jj < jpj ) THEN 408 IF ( vt_i(ji,jj+1) > 0. ) THEN ; v_ice(ji,jj) = v_ice(ji,jj+1) 409 ELSEIF( vt_i(ji,jj ) > 0. ) THEN ; v_ice(ji,jj) = 0._wp 410 END IF 411 END IF 412 ! 413 IF( zflag == 0. ) v_ice(ji,jj) = 0._wp ! v_ice = 0 if west/east bdy 414 ! 415 END DO 416 ! 417 END SELECT 418 ! 419 CASE DEFAULT 420 CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' ) 421 END SELECT 422 ! 423 END DO ! jbdy 286 424 ! 287 SELECT CASE( cn_ice(jbdy) ) 288 ! 289 CASE('none') 290 CYCLE 291 ! 292 CASE('frs') 293 ! 294 IF( nn_ice_dta(jbdy) == 0 ) CYCLE ! case ice boundaries = initial conditions 295 ! ! do not change ice velocity (it is only computed by rheology) 296 SELECT CASE ( cd_type ) 297 ! 298 CASE ( 'U' ) 299 jgrd = 2 ! u velocity 300 DO i_bdy = 1, idx_bdy(jbdy)%nblenrim(jgrd) 301 ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 302 jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 303 zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) 304 ! 305 IF ( ABS( zflag ) == 1. ) THEN ! eastern and western boundaries 306 ! one of the two zmsk is always 0 (because of zflag) 307 zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji+1,jj) ) ) ! 0 if no ice 308 zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji-1,jj) ) ) ! 0 if no ice 309 ! 310 ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then do not change u_ice) 311 u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 312 & u_ice(ji-1,jj) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 313 & u_ice(ji ,jj) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 314 ELSE ! everywhere else 315 u_ice(ji,jj) = 0._wp 316 ENDIF 317 ! 318 END DO 319 CALL lbc_bdy_lnk( 'bdyice', u_ice(:,:), 'U', -1., jbdy ) 320 ! 321 CASE ( 'V' ) 322 jgrd = 3 ! v velocity 323 DO i_bdy = 1, idx_bdy(jbdy)%nblenrim(jgrd) 324 ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 325 jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 326 zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) 327 ! 328 IF ( ABS( zflag ) == 1. ) THEN ! northern and southern boundaries 329 ! one of the two zmsk is always 0 (because of zflag) 330 zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj+1) ) ) ! 0 if no ice 331 zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj-1) ) ) ! 0 if no ice 332 ! 333 ! v_ice = v_ice of the adjacent grid point except if this grid point is ice-free (then do not change v_ice) 334 v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 335 & v_ice(ji,jj-1) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 336 & v_ice(ji,jj ) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 337 ELSE ! everywhere else 338 v_ice(ji,jj) = 0._wp 339 ENDIF 340 ! 341 END DO 342 CALL lbc_bdy_lnk( 'bdyice', v_ice(:,:), 'V', -1., jbdy ) 343 ! 344 END SELECT 345 ! 346 CASE DEFAULT 347 CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' ) 425 SELECT CASE ( cd_type ) 426 CASE ( 'U' ) 427 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 428 IF( nn_hls == 1 ) THEN ; llsend2(:) = .false. ; llrecv2(:) = .false. ; END IF 429 DO jbdy = 1, nb_bdy 430 IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN 431 llsend2(:) = llsend2(:) .OR. lsend_bdyint(jbdy,2,:,ir) ! possibly every direction, U points 432 llsend2(1) = llsend2(1) .OR. lsend_bdyext(jbdy,2,1,ir) ! neighbour might search point towards its west bdy 433 llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(jbdy,2,:,ir) ! possibly every direction, U points 434 llrecv2(2) = llrecv2(2) .OR. lrecv_bdyext(jbdy,2,2,ir) ! might search point towards east bdy 435 END IF 436 END DO 437 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 438 CALL lbc_lnk( 'bdyice', u_ice, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 439 END IF 440 CASE ( 'V' ) 441 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 442 IF( nn_hls == 1 ) THEN ; llsend3(:) = .false. ; llrecv3(:) = .false. ; END IF 443 DO jbdy = 1, nb_bdy 444 IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN 445 llsend3(:) = llsend3(:) .OR. lsend_bdyint(jbdy,3,:,ir) ! possibly every direction, V points 446 llsend3(3) = llsend3(3) .OR. lsend_bdyext(jbdy,3,3,ir) ! neighbour might search point towards its south bdy 447 llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(jbdy,3,:,ir) ! possibly every direction, V points 448 llrecv3(4) = llrecv3(4) .OR. lrecv_bdyext(jbdy,3,4,ir) ! might search point towards north bdy 449 END IF 450 END DO 451 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 452 CALL lbc_lnk( 'bdyice', v_ice, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 453 END IF 348 454 END SELECT 349 ! 350 END DO 455 END DO ! ir 351 456 ! 352 457 IF( ln_timing ) CALL timing_stop('bdy_ice_dyn') -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdyini.F90
r10773 r12065 33 33 PRIVATE 34 34 35 PUBLIC bdy_init ! routine called in nemo_init 35 PUBLIC bdy_init ! routine called in nemo_init 36 PUBLIC find_neib ! routine called in bdy_nmn 36 37 37 38 INTEGER, PARAMETER :: jp_nseg = 100 ! 38 INTEGER, PARAMETER :: nrimmax = 20 ! maximum rimwidth in structured39 ! open boundary data files40 39 ! Straight open boundary segment parameters: 41 40 INTEGER :: nbdysege, nbdysegw, nbdysegn, nbdysegs … … 68 67 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 69 68 & cn_ice, nn_ice_dta, & 70 & rn_ice_tem, rn_ice_sal, rn_ice_age, & 71 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 69 & ln_vol, nn_volctl, nn_rimwidth 72 70 ! 73 71 INTEGER :: ios ! Local integer output status for namelist read … … 79 77 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries 80 78 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 901) 81 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp ) 79 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) 80 ! make sur that all elements of the namelist variables have a default definition from namelist_ref 81 ln_coords_file (2:jp_bdy) = ln_coords_file (1) 82 cn_coords_file (2:jp_bdy) = cn_coords_file (1) 83 cn_dyn2d (2:jp_bdy) = cn_dyn2d (1) 84 nn_dyn2d_dta (2:jp_bdy) = nn_dyn2d_dta (1) 85 cn_dyn3d (2:jp_bdy) = cn_dyn3d (1) 86 nn_dyn3d_dta (2:jp_bdy) = nn_dyn3d_dta (1) 87 cn_tra (2:jp_bdy) = cn_tra (1) 88 nn_tra_dta (2:jp_bdy) = nn_tra_dta (1) 89 ln_tra_dmp (2:jp_bdy) = ln_tra_dmp (1) 90 ln_dyn3d_dmp (2:jp_bdy) = ln_dyn3d_dmp (1) 91 rn_time_dmp (2:jp_bdy) = rn_time_dmp (1) 92 rn_time_dmp_out(2:jp_bdy) = rn_time_dmp_out(1) 93 cn_ice (2:jp_bdy) = cn_ice (1) 94 nn_ice_dta (2:jp_bdy) = nn_ice_dta (1) 82 95 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries 83 96 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 902 ) 84 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' , lwp)97 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) 85 98 IF(lwm) WRITE ( numond, nambdy ) 86 99 87 100 IF( .NOT. Agrif_Root() ) ln_bdy = .FALSE. ! forced for Agrif children 101 102 IF( nb_bdy == 0 ) ln_bdy = .FALSE. 88 103 89 104 ! ----------------------------------------- … … 96 111 ! 97 112 ! Open boundaries definition (arrays and masks) 98 CALL bdy_segs 113 CALL bdy_def 114 IF( ln_meshmask ) CALL bdy_meshwri() 99 115 ! 100 116 ! Open boundaries initialisation of external data arrays … … 114 130 115 131 116 SUBROUTINE bdy_ segs132 SUBROUTINE bdy_def 117 133 !!---------------------------------------------------------------------- 118 134 !! *** ROUTINE bdy_init *** … … 125 141 !! ** Input : bdy_init.nc, input file for unstructured open boundaries 126 142 !!---------------------------------------------------------------------- 127 INTEGER :: ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 128 INTEGER :: icount, icountr, ibr_max, ilen1, ibm1 ! local integers 143 INTEGER :: ib_bdy, ii, ij, igrd, ib, ir, iseg ! dummy loop indices 144 INTEGER :: icount, icountr, icountr0, ibr_max ! local integers 145 INTEGER :: ilen1 ! - - 129 146 INTEGER :: iwe, ies, iso, ino, inum, id_dummy ! - - 130 INTEGER :: igrd_start, igrd_end, jpbdta ! - - 131 INTEGER :: jpbdtau, jpbdtas ! - - 147 INTEGER :: jpbdta ! - - 132 148 INTEGER :: ib_bdy1, ib_bdy2, ib1, ib2 ! - - 133 INTEGER :: i_offset, j_offset ! - - 134 INTEGER , POINTER :: nbi, nbj, nbr ! short cuts 135 REAL(wp), POINTER, DIMENSION(:,:) :: pmask ! pointer to 2D mask fields 136 REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars 137 INTEGER, DIMENSION (2) :: kdimsz 138 INTEGER, DIMENSION(jpbgrd,jp_bdy) :: nblendta ! Length of index arrays 139 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of bdy dta 140 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points 141 CHARACTER(LEN=1),DIMENSION(jpbgrd) :: cgrid 142 INTEGER :: com_east, com_west, com_south, com_north ! Flags for boundaries sending 143 INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b ! Flags for boundaries receiving 144 INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4) ! Arrays for neighbours coordinates 145 REAL(wp), TARGET, DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) 146 !! 147 CHARACTER(LEN=1) :: ctypebdy ! - - 148 INTEGER :: nbdyind, nbdybeg, nbdyend 149 !! 150 NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend 151 INTEGER :: ios ! Local integer output status for namelist read 149 INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3 ! - - 150 INTEGER :: iibe, ijbe, iibi, ijbi ! - - 151 INTEGER :: flagu, flagv ! short cuts 152 INTEGER :: nbdyind, nbdybeg, nbdyend 153 INTEGER , DIMENSION(4) :: kdimsz 154 INTEGER , DIMENSION(jpbgrd,jp_bdy) :: nblendta ! Length of index arrays 155 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of bdy dta 156 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points 157 CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid 158 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zz_read ! work space for 2D global boundary data 159 REAL(wp), POINTER , DIMENSION(:,:) :: zmask ! pointer to 2D mask fields 160 REAL(wp) , DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) 161 REAL(wp) , DIMENSION(jpi,jpj) :: ztmask, zumask, zvmask ! temporary u/v mask array 152 162 !!---------------------------------------------------------------------- 153 163 ! … … 160 170 & ' and general open boundary condition are not compatible' ) 161 171 162 IF( nb_bdy == 0 ) THEN 163 IF(lwp) WRITE(numout,*) 'nb_bdy = 0, NO OPEN BOUNDARIES APPLIED.' 164 ELSE 165 IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy 172 IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy 173 174 DO ib_bdy = 1,nb_bdy 175 176 IF(lwp) THEN 177 WRITE(numout,*) ' ' 178 WRITE(numout,*) '------ Open boundary data set ',ib_bdy,' ------' 179 IF( ln_coords_file(ib_bdy) ) THEN 180 WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy)) 181 ELSE 182 WRITE(numout,*) 'Boundary defined in namelist.' 183 ENDIF 184 WRITE(numout,*) 185 ENDIF 186 187 ! barotropic bdy 188 !---------------- 189 IF(lwp) THEN 190 WRITE(numout,*) 'Boundary conditions for barotropic solution: ' 191 SELECT CASE( cn_dyn2d(ib_bdy) ) 192 CASE( 'none' ) ; WRITE(numout,*) ' no open boundary condition' 193 CASE( 'frs' ) ; WRITE(numout,*) ' Flow Relaxation Scheme' 194 CASE( 'flather' ) ; WRITE(numout,*) ' Flather radiation condition' 195 CASE( 'orlanski' ) ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 196 CASE( 'orlanski_npo' ) ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 197 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) 198 END SELECT 199 ENDIF 200 201 dta_bdy(ib_bdy)%lneed_ssh = cn_dyn2d(ib_bdy) == 'flather' 202 dta_bdy(ib_bdy)%lneed_dyn2d = cn_dyn2d(ib_bdy) /= 'none' 203 204 IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn2d ) THEN 205 SELECT CASE( nn_dyn2d_dta(ib_bdy) ) ! 206 CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' 207 CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' 208 CASE( 2 ) ; WRITE(numout,*) ' tidal harmonic forcing taken from file' 209 CASE( 3 ) ; WRITE(numout,*) ' boundary data AND tidal harmonic forcing taken from files' 210 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) 211 END SELECT 212 ENDIF 213 IF ( dta_bdy(ib_bdy)%lneed_dyn2d .AND. nn_dyn2d_dta(ib_bdy) .GE. 2 .AND. .NOT.ln_tide ) THEN 214 CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' ) 215 ENDIF 216 IF(lwp) WRITE(numout,*) 217 218 ! baroclinic bdy 219 !---------------- 220 IF(lwp) THEN 221 WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' 222 SELECT CASE( cn_dyn3d(ib_bdy) ) 223 CASE('none') ; WRITE(numout,*) ' no open boundary condition' 224 CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' 225 CASE('specified') ; WRITE(numout,*) ' Specified value' 226 CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' 227 CASE('zerograd') ; WRITE(numout,*) ' Zero gradient for baroclinic velocities' 228 CASE('zero') ; WRITE(numout,*) ' Zero baroclinic velocities (runoff case)' 229 CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 230 CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 231 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) 232 END SELECT 233 ENDIF 234 235 dta_bdy(ib_bdy)%lneed_dyn3d = cn_dyn3d(ib_bdy) == 'frs' .OR. cn_dyn3d(ib_bdy) == 'specified' & 236 & .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' 237 238 IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn3d ) THEN 239 SELECT CASE( nn_dyn3d_dta(ib_bdy) ) ! 240 CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' 241 CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' 242 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) 243 END SELECT 244 END IF 245 246 IF ( ln_dyn3d_dmp(ib_bdy) ) THEN 247 IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN 248 IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' 249 ln_dyn3d_dmp(ib_bdy) = .false. 250 ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN 251 CALL ctl_stop( 'Use FRS OR relaxation' ) 252 ELSE 253 IF(lwp) WRITE(numout,*) ' + baroclinic velocities relaxation zone' 254 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' 255 IF(rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 256 dta_bdy(ib_bdy)%lneed_dyn3d = .TRUE. 257 ENDIF 258 ELSE 259 IF(lwp) WRITE(numout,*) ' NO relaxation on baroclinic velocities' 260 ENDIF 261 IF(lwp) WRITE(numout,*) 262 263 ! tra bdy 264 !---------------- 265 IF(lwp) THEN 266 WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' 267 SELECT CASE( cn_tra(ib_bdy) ) 268 CASE('none') ; WRITE(numout,*) ' no open boundary condition' 269 CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' 270 CASE('specified') ; WRITE(numout,*) ' Specified value' 271 CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' 272 CASE('runoff') ; WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity' 273 CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 274 CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 275 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' ) 276 END SELECT 277 ENDIF 278 279 dta_bdy(ib_bdy)%lneed_tra = cn_tra(ib_bdy) == 'frs' .OR. cn_tra(ib_bdy) == 'specified' & 280 & .OR. cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' 281 282 IF( lwp .AND. dta_bdy(ib_bdy)%lneed_tra ) THEN 283 SELECT CASE( nn_tra_dta(ib_bdy) ) ! 284 CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' 285 CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' 286 CASE DEFAULT ; CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) 287 END SELECT 288 ENDIF 289 290 IF ( ln_tra_dmp(ib_bdy) ) THEN 291 IF ( cn_tra(ib_bdy) == 'none' ) THEN 292 IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' 293 ln_tra_dmp(ib_bdy) = .false. 294 ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN 295 CALL ctl_stop( 'Use FRS OR relaxation' ) 296 ELSE 297 IF(lwp) WRITE(numout,*) ' + T/S relaxation zone' 298 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' 299 IF(lwp) WRITE(numout,*) ' Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' 300 IF(lwp.AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 301 dta_bdy(ib_bdy)%lneed_tra = .TRUE. 302 ENDIF 303 ELSE 304 IF(lwp) WRITE(numout,*) ' NO T/S relaxation' 305 ENDIF 306 IF(lwp) WRITE(numout,*) 307 308 #if defined key_si3 309 IF(lwp) THEN 310 WRITE(numout,*) 'Boundary conditions for sea ice: ' 311 SELECT CASE( cn_ice(ib_bdy) ) 312 CASE('none') ; WRITE(numout,*) ' no open boundary condition' 313 CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' 314 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice' ) 315 END SELECT 316 ENDIF 317 318 dta_bdy(ib_bdy)%lneed_ice = cn_ice(ib_bdy) /= 'none' 319 320 IF( lwp .AND. dta_bdy(ib_bdy)%lneed_ice ) THEN 321 SELECT CASE( nn_ice_dta(ib_bdy) ) ! 322 CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' 323 CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' 324 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_dta must be 0 or 1' ) 325 END SELECT 326 ENDIF 327 #else 328 dta_bdy(ib_bdy)%lneed_ice = .FALSE. 329 #endif 330 ! 331 IF(lwp) WRITE(numout,*) 332 IF(lwp) WRITE(numout,*) ' Width of relaxation zone = ', nn_rimwidth(ib_bdy) 333 IF(lwp) WRITE(numout,*) 334 ! 335 END DO ! nb_bdy 336 337 IF( lwp ) THEN 338 IF( ln_vol ) THEN ! check volume conservation (nn_volctl value) 339 WRITE(numout,*) 'Volume correction applied at open boundaries' 340 WRITE(numout,*) 341 SELECT CASE ( nn_volctl ) 342 CASE( 1 ) ; WRITE(numout,*) ' The total volume will be constant' 343 CASE( 0 ) ; WRITE(numout,*) ' The total volume will vary according to the surface E-P flux' 344 CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 345 END SELECT 346 WRITE(numout,*) 347 ! 348 ! sanity check if used with tides 349 IF( ln_tide ) THEN 350 WRITE(numout,*) ' The total volume correction is not working with tides. ' 351 WRITE(numout,*) ' Set ln_vol to .FALSE. ' 352 WRITE(numout,*) ' or ' 353 WRITE(numout,*) ' equilibriate your bdy input files ' 354 CALL ctl_stop( 'The total volume correction is not working with tides.' ) 355 END IF 356 ELSE 357 WRITE(numout,*) 'No volume correction applied at open boundaries' 358 WRITE(numout,*) 359 ENDIF 166 360 ENDIF 167 168 DO ib_bdy = 1,nb_bdy169 IF(lwp) WRITE(numout,*) ' '170 IF(lwp) WRITE(numout,*) '------ Open boundary data set ',ib_bdy,'------'171 172 IF( ln_coords_file(ib_bdy) ) THEN173 IF(lwp) WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy))174 ELSE175 IF(lwp) WRITE(numout,*) 'Boundary defined in namelist.'176 ENDIF177 IF(lwp) WRITE(numout,*)178 179 IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution: '180 SELECT CASE( cn_dyn2d(ib_bdy) )181 CASE( 'none' )182 IF(lwp) WRITE(numout,*) ' no open boundary condition'183 dta_bdy(ib_bdy)%ll_ssh = .false.184 dta_bdy(ib_bdy)%ll_u2d = .false.185 dta_bdy(ib_bdy)%ll_v2d = .false.186 CASE( 'frs' )187 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme'188 dta_bdy(ib_bdy)%ll_ssh = .false.189 dta_bdy(ib_bdy)%ll_u2d = .true.190 dta_bdy(ib_bdy)%ll_v2d = .true.191 CASE( 'flather' )192 IF(lwp) WRITE(numout,*) ' Flather radiation condition'193 dta_bdy(ib_bdy)%ll_ssh = .true.194 dta_bdy(ib_bdy)%ll_u2d = .true.195 dta_bdy(ib_bdy)%ll_v2d = .true.196 CASE( 'orlanski' )197 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging'198 dta_bdy(ib_bdy)%ll_ssh = .false.199 dta_bdy(ib_bdy)%ll_u2d = .true.200 dta_bdy(ib_bdy)%ll_v2d = .true.201 CASE( 'orlanski_npo' )202 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging'203 dta_bdy(ib_bdy)%ll_ssh = .false.204 dta_bdy(ib_bdy)%ll_u2d = .true.205 dta_bdy(ib_bdy)%ll_v2d = .true.206 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' )207 END SELECT208 IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN209 SELECT CASE( nn_dyn2d_dta(ib_bdy) ) !210 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data'211 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file'212 CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' tidal harmonic forcing taken from file'213 CASE( 3 ) ; IF(lwp) WRITE(numout,*) ' boundary data AND tidal harmonic forcing taken from files'214 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' )215 END SELECT216 IF (( nn_dyn2d_dta(ib_bdy) .ge. 2 ).AND.(.NOT.ln_tide)) THEN217 CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' )218 ENDIF219 ENDIF220 IF(lwp) WRITE(numout,*)221 222 IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities: '223 SELECT CASE( cn_dyn3d(ib_bdy) )224 CASE('none')225 IF(lwp) WRITE(numout,*) ' no open boundary condition'226 dta_bdy(ib_bdy)%ll_u3d = .false.227 dta_bdy(ib_bdy)%ll_v3d = .false.228 CASE('frs')229 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme'230 dta_bdy(ib_bdy)%ll_u3d = .true.231 dta_bdy(ib_bdy)%ll_v3d = .true.232 CASE('specified')233 IF(lwp) WRITE(numout,*) ' Specified value'234 dta_bdy(ib_bdy)%ll_u3d = .true.235 dta_bdy(ib_bdy)%ll_v3d = .true.236 CASE('neumann')237 IF(lwp) WRITE(numout,*) ' Neumann conditions'238 dta_bdy(ib_bdy)%ll_u3d = .false.239 dta_bdy(ib_bdy)%ll_v3d = .false.240 CASE('zerograd')241 IF(lwp) WRITE(numout,*) ' Zero gradient for baroclinic velocities'242 dta_bdy(ib_bdy)%ll_u3d = .false.243 dta_bdy(ib_bdy)%ll_v3d = .false.244 CASE('zero')245 IF(lwp) WRITE(numout,*) ' Zero baroclinic velocities (runoff case)'246 dta_bdy(ib_bdy)%ll_u3d = .false.247 dta_bdy(ib_bdy)%ll_v3d = .false.248 CASE('orlanski')249 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging'250 dta_bdy(ib_bdy)%ll_u3d = .true.251 dta_bdy(ib_bdy)%ll_v3d = .true.252 CASE('orlanski_npo')253 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging'254 dta_bdy(ib_bdy)%ll_u3d = .true.255 dta_bdy(ib_bdy)%ll_v3d = .true.256 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' )257 END SELECT258 IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN259 SELECT CASE( nn_dyn3d_dta(ib_bdy) ) !260 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data'261 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file'262 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' )263 END SELECT264 ENDIF265 266 IF ( ln_dyn3d_dmp(ib_bdy) ) THEN267 IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN268 IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.'269 ln_dyn3d_dmp(ib_bdy)=.false.270 ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN271 CALL ctl_stop( 'Use FRS OR relaxation' )272 ELSE273 IF(lwp) WRITE(numout,*) ' + baroclinic velocities relaxation zone'274 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days'275 IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' )276 dta_bdy(ib_bdy)%ll_u3d = .true.277 dta_bdy(ib_bdy)%ll_v3d = .true.278 ENDIF279 ELSE280 IF(lwp) WRITE(numout,*) ' NO relaxation on baroclinic velocities'281 ENDIF282 IF(lwp) WRITE(numout,*)283 284 IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity: '285 SELECT CASE( cn_tra(ib_bdy) )286 CASE('none')287 IF(lwp) WRITE(numout,*) ' no open boundary condition'288 dta_bdy(ib_bdy)%ll_tem = .false.289 dta_bdy(ib_bdy)%ll_sal = .false.290 CASE('frs')291 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme'292 dta_bdy(ib_bdy)%ll_tem = .true.293 dta_bdy(ib_bdy)%ll_sal = .true.294 CASE('specified')295 IF(lwp) WRITE(numout,*) ' Specified value'296 dta_bdy(ib_bdy)%ll_tem = .true.297 dta_bdy(ib_bdy)%ll_sal = .true.298 CASE('neumann')299 IF(lwp) WRITE(numout,*) ' Neumann conditions'300 dta_bdy(ib_bdy)%ll_tem = .false.301 dta_bdy(ib_bdy)%ll_sal = .false.302 CASE('runoff')303 IF(lwp) WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity'304 dta_bdy(ib_bdy)%ll_tem = .false.305 dta_bdy(ib_bdy)%ll_sal = .false.306 CASE('orlanski')307 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging'308 dta_bdy(ib_bdy)%ll_tem = .true.309 dta_bdy(ib_bdy)%ll_sal = .true.310 CASE('orlanski_npo')311 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging'312 dta_bdy(ib_bdy)%ll_tem = .true.313 dta_bdy(ib_bdy)%ll_sal = .true.314 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' )315 END SELECT316 IF( cn_tra(ib_bdy) /= 'none' ) THEN317 SELECT CASE( nn_tra_dta(ib_bdy) ) !318 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data'319 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file'320 CASE DEFAULT ; CALL ctl_stop( 'nn_tra_dta must be 0 or 1' )321 END SELECT322 ENDIF323 324 IF ( ln_tra_dmp(ib_bdy) ) THEN325 IF ( cn_tra(ib_bdy) == 'none' ) THEN326 IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.'327 ln_tra_dmp(ib_bdy)=.false.328 ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN329 CALL ctl_stop( 'Use FRS OR relaxation' )330 ELSE331 IF(lwp) WRITE(numout,*) ' + T/S relaxation zone'332 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days'333 IF(lwp) WRITE(numout,*) ' Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days'334 IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' )335 dta_bdy(ib_bdy)%ll_tem = .true.336 dta_bdy(ib_bdy)%ll_sal = .true.337 ENDIF338 ELSE339 IF(lwp) WRITE(numout,*) ' NO T/S relaxation'340 ENDIF341 IF(lwp) WRITE(numout,*)342 343 #if defined key_si3344 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: '345 SELECT CASE( cn_ice(ib_bdy) )346 CASE('none')347 IF(lwp) WRITE(numout,*) ' no open boundary condition'348 dta_bdy(ib_bdy)%ll_a_i = .false.349 dta_bdy(ib_bdy)%ll_h_i = .false.350 dta_bdy(ib_bdy)%ll_h_s = .false.351 CASE('frs')352 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme'353 dta_bdy(ib_bdy)%ll_a_i = .true.354 dta_bdy(ib_bdy)%ll_h_i = .true.355 dta_bdy(ib_bdy)%ll_h_s = .true.356 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice' )357 END SELECT358 IF( cn_ice(ib_bdy) /= 'none' ) THEN359 SELECT CASE( nn_ice_dta(ib_bdy) ) !360 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data'361 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file'362 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_dta must be 0 or 1' )363 END SELECT364 ENDIF365 IF(lwp) WRITE(numout,*)366 IF(lwp) WRITE(numout,*) ' tem of bdy sea-ice = ', rn_ice_tem(ib_bdy)367 IF(lwp) WRITE(numout,*) ' sal of bdy sea-ice = ', rn_ice_sal(ib_bdy)368 IF(lwp) WRITE(numout,*) ' age of bdy sea-ice = ', rn_ice_age(ib_bdy)369 #endif370 371 IF(lwp) WRITE(numout,*) ' Width of relaxation zone = ', nn_rimwidth(ib_bdy)372 IF(lwp) WRITE(numout,*)373 !374 END DO375 376 IF( nb_bdy > 0 ) THEN377 IF( ln_vol ) THEN ! check volume conservation (nn_volctl value)378 IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries'379 IF(lwp) WRITE(numout,*)380 SELECT CASE ( nn_volctl )381 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' The total volume will be constant'382 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' The total volume will vary according to the surface E-P flux'383 CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' )384 END SELECT385 IF(lwp) WRITE(numout,*)386 !387 ! sanity check if used with tides388 IF( ln_tide ) THEN389 IF(lwp) WRITE(numout,*) ' The total volume correction is not working with tides. '390 IF(lwp) WRITE(numout,*) ' Set ln_vol to .FALSE. '391 IF(lwp) WRITE(numout,*) ' or '392 IF(lwp) WRITE(numout,*) ' equilibriate your bdy input files '393 CALL ctl_stop( 'The total volume correction is not working with tides.' )394 END IF395 ELSE396 IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries'397 IF(lwp) WRITE(numout,*)398 ENDIF399 IF( nb_jpk_bdy > 0 ) THEN400 IF(lwp) WRITE(numout,*) '*** open boundary will be interpolate in the vertical onto the native grid ***'401 ELSE402 IF(lwp) WRITE(numout,*) '*** open boundary will be read straight onto the native grid without vertical interpolation ***'403 ENDIF404 ENDIF405 361 406 362 ! ------------------------------------------------- … … 408 364 ! ------------------------------------------------- 409 365 410 ! Work out global dimensions of boundary data411 ! ---------------------------------------------412 366 REWIND( numnam_cfg ) 413 414 367 nblendta(:,:) = 0 415 368 nbdysege = 0 … … 417 370 nbdysegn = 0 418 371 nbdysegs = 0 419 icount = 0 ! count user defined segments 420 ! Dimensions below are used to allocate arrays to read external data 421 jpbdtas = 1 ! Maximum size of boundary data (structured case) 422 jpbdtau = 1 ! Maximum size of boundary data (unstructured case) 423 372 373 ! Define all boundaries 374 ! --------------------- 424 375 DO ib_bdy = 1, nb_bdy 425 426 IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! Work out size of global arrays from namelist parameters 427 428 icount = icount + 1 429 ! No REWIND here because may need to read more than one nambdy_index namelist. 430 ! Read only namelist_cfg to avoid unseccessfull overwrite 431 ! keep full control of the configuration namelist 432 READ ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 ) 433 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in configuration namelist', lwp ) 434 IF(lwm) WRITE ( numond, nambdy_index ) 435 436 SELECT CASE ( TRIM(ctypebdy) ) 437 CASE( 'N' ) 438 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 439 nbdyind = jpjglo - 2 ! set boundary to whole side of model domain. 440 nbdybeg = 2 441 nbdyend = jpiglo - 1 442 ENDIF 443 nbdysegn = nbdysegn + 1 444 npckgn(nbdysegn) = ib_bdy ! Save bdy package number 445 jpjnob(nbdysegn) = nbdyind 446 jpindt(nbdysegn) = nbdybeg 447 jpinft(nbdysegn) = nbdyend 448 ! 449 CASE( 'S' ) 450 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 451 nbdyind = 2 ! set boundary to whole side of model domain. 452 nbdybeg = 2 453 nbdyend = jpiglo - 1 454 ENDIF 455 nbdysegs = nbdysegs + 1 456 npckgs(nbdysegs) = ib_bdy ! Save bdy package number 457 jpjsob(nbdysegs) = nbdyind 458 jpisdt(nbdysegs) = nbdybeg 459 jpisft(nbdysegs) = nbdyend 460 ! 461 CASE( 'E' ) 462 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 463 nbdyind = jpiglo - 2 ! set boundary to whole side of model domain. 464 nbdybeg = 2 465 nbdyend = jpjglo - 1 466 ENDIF 467 nbdysege = nbdysege + 1 468 npckge(nbdysege) = ib_bdy ! Save bdy package number 469 jpieob(nbdysege) = nbdyind 470 jpjedt(nbdysege) = nbdybeg 471 jpjeft(nbdysege) = nbdyend 472 ! 473 CASE( 'W' ) 474 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 475 nbdyind = 2 ! set boundary to whole side of model domain. 476 nbdybeg = 2 477 nbdyend = jpjglo - 1 478 ENDIF 479 nbdysegw = nbdysegw + 1 480 npckgw(nbdysegw) = ib_bdy ! Save bdy package number 481 jpiwob(nbdysegw) = nbdyind 482 jpjwdt(nbdysegw) = nbdybeg 483 jpjwft(nbdysegw) = nbdyend 484 ! 485 CASE DEFAULT ; CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) 486 END SELECT 487 488 ! For simplicity we assume that in case of straight bdy, arrays have the same length 489 ! (even if it is true that last tangential velocity points 490 ! are useless). This simplifies a little bit boundary data format (and agrees with format 491 ! used so far in obc package) 492 493 nblendta(1:jpbgrd,ib_bdy) = (nbdyend - nbdybeg + 1) * nn_rimwidth(ib_bdy) 494 jpbdtas = MAX(jpbdtas, (nbdyend - nbdybeg + 1)) 495 IF (lwp.and.(nn_rimwidth(ib_bdy)>nrimmax)) & 496 & CALL ctl_stop( 'rimwidth must be lower than nrimmax' ) 497 498 ELSE ! Read size of arrays in boundary coordinates file. 376 ! 377 IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! build bdy coordinates with segments defined in namelist 378 379 CALL bdy_read_seg( ib_bdy, nblendta(:,ib_bdy) ) 380 381 ELSE ! Read size of arrays in boundary coordinates file. 382 499 383 CALL iom_open( cn_coords_file(ib_bdy), inum ) 500 384 DO igrd = 1, jpbgrd 501 385 id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz ) 502 386 nblendta(igrd,ib_bdy) = MAXVAL(kdimsz) 503 jpbdtau = MAX(jpbdtau, MAXVAL(kdimsz))504 387 END DO 505 388 CALL iom_close( inum ) 506 ! 507 ENDIF 389 ENDIF 508 390 ! 509 391 END DO ! ib_bdy 510 392 511 IF (nb_bdy>0) THEN512 jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy))513 514 ! Allocate arrays515 !---------------516 ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), &517 & nbrdta(jpbdta, jpbgrd, nb_bdy) )518 519 IF( nb_jpk_bdy>0 ) THEN520 ALLOCATE( dta_global(jpbdtau, 1, nb_jpk_bdy) )521 ALLOCATE( dta_global_z(jpbdtau, 1, nb_jpk_bdy) )522 ALLOCATE( dta_global_dz(jpbdtau, 1, nb_jpk_bdy) )523 ELSE524 ALLOCATE( dta_global(jpbdtau, 1, jpk) )525 ALLOCATE( dta_global_z(jpbdtau, 1, jpk) ) ! needed ?? TODO526 ALLOCATE( dta_global_dz(jpbdtau, 1, jpk) )! needed ?? TODO527 ENDIF528 529 IF ( icount>0 ) THEN530 IF( nb_jpk_bdy>0 ) THEN531 ALLOCATE( dta_global2(jpbdtas, nrimmax, nb_jpk_bdy) )532 ALLOCATE( dta_global2_z(jpbdtas, nrimmax, nb_jpk_bdy) )533 ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, nb_jpk_bdy) )534 ELSE535 ALLOCATE( dta_global2(jpbdtas, nrimmax, jpk) )536 ALLOCATE( dta_global2_z(jpbdtas, nrimmax, jpk) ) ! needed ?? TODO537 ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, jpk) )! needed ?? TODO538 ENDIF539 ENDIF540 !541 ENDIF542 543 393 ! Now look for crossings in user (namelist) defined open boundary segments: 544 !-------------------------------------------------------------------------- 545 IF( icount>0 ) CALL bdy_ctl_seg 546 394 IF( nbdysege > 0 .OR. nbdysegw > 0 .OR. nbdysegn > 0 .OR. nbdysegs > 0) CALL bdy_ctl_seg 395 396 ! Allocate arrays 397 !--------------- 398 jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) 399 ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), nbrdta(jpbdta, jpbgrd, nb_bdy) ) 400 547 401 ! Calculate global boundary index arrays or read in from file 548 402 !------------------------------------------------------------ … … 552 406 IF( ln_coords_file(ib_bdy) ) THEN 553 407 ! 408 ALLOCATE( zz_read( MAXVAL(nblendta), 1 ) ) 554 409 CALL iom_open( cn_coords_file(ib_bdy), inum ) 410 ! 555 411 DO igrd = 1, jpbgrd 556 CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )412 CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 557 413 DO ii = 1,nblendta(igrd,ib_bdy) 558 nbidta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )414 nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 559 415 END DO 560 CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )416 CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 561 417 DO ii = 1,nblendta(igrd,ib_bdy) 562 nbjdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )418 nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 563 419 END DO 564 CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )420 CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 565 421 DO ii = 1,nblendta(igrd,ib_bdy) 566 nbrdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )422 nbrdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 567 423 END DO 568 424 ! … … 572 428 IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_bdy) 573 429 IF (ibr_max < nn_rimwidth(ib_bdy)) & 574 CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) 575 END DO 430 CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) 431 END DO 432 ! 576 433 CALL iom_close( inum ) 434 DEALLOCATE( zz_read ) 577 435 ! 578 ENDIF 579 ! 580 END DO 581 436 ENDIF 437 ! 438 END DO 439 582 440 ! 2. Now fill indices corresponding to straight open boundary arrays: 583 ! East 584 !----- 585 DO iseg = 1, nbdysege 586 ib_bdy = npckge(iseg) 587 ! 588 ! ------------ T points ------------- 589 igrd=1 590 icount=0 591 DO ir = 1, nn_rimwidth(ib_bdy) 592 DO ij = jpjedt(iseg), jpjeft(iseg) 593 icount = icount + 1 594 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 595 nbjdta(icount, igrd, ib_bdy) = ij 596 nbrdta(icount, igrd, ib_bdy) = ir 597 ENDDO 598 ENDDO 599 ! 600 ! ------------ U points ------------- 601 igrd=2 602 icount=0 603 DO ir = 1, nn_rimwidth(ib_bdy) 604 DO ij = jpjedt(iseg), jpjeft(iseg) 605 icount = icount + 1 606 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 607 nbjdta(icount, igrd, ib_bdy) = ij 608 nbrdta(icount, igrd, ib_bdy) = ir 609 ENDDO 610 ENDDO 611 ! 612 ! ------------ V points ------------- 613 igrd=3 614 icount=0 615 DO ir = 1, nn_rimwidth(ib_bdy) 616 ! DO ij = jpjedt(iseg), jpjeft(iseg) - 1 617 DO ij = jpjedt(iseg), jpjeft(iseg) 618 icount = icount + 1 619 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 620 nbjdta(icount, igrd, ib_bdy) = ij 621 nbrdta(icount, igrd, ib_bdy) = ir 622 ENDDO 623 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 624 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 625 ENDDO 626 ENDDO 627 ! 628 ! West 629 !----- 630 DO iseg = 1, nbdysegw 631 ib_bdy = npckgw(iseg) 632 ! 633 ! ------------ T points ------------- 634 igrd=1 635 icount=0 636 DO ir = 1, nn_rimwidth(ib_bdy) 637 DO ij = jpjwdt(iseg), jpjwft(iseg) 638 icount = icount + 1 639 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 640 nbjdta(icount, igrd, ib_bdy) = ij 641 nbrdta(icount, igrd, ib_bdy) = ir 642 ENDDO 643 ENDDO 644 ! 645 ! ------------ U points ------------- 646 igrd=2 647 icount=0 648 DO ir = 1, nn_rimwidth(ib_bdy) 649 DO ij = jpjwdt(iseg), jpjwft(iseg) 650 icount = icount + 1 651 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 652 nbjdta(icount, igrd, ib_bdy) = ij 653 nbrdta(icount, igrd, ib_bdy) = ir 654 ENDDO 655 ENDDO 656 ! 657 ! ------------ V points ------------- 658 igrd=3 659 icount=0 660 DO ir = 1, nn_rimwidth(ib_bdy) 661 ! DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 662 DO ij = jpjwdt(iseg), jpjwft(iseg) 663 icount = icount + 1 664 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 665 nbjdta(icount, igrd, ib_bdy) = ij 666 nbrdta(icount, igrd, ib_bdy) = ir 667 ENDDO 668 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 669 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 670 ENDDO 671 ENDDO 672 ! 673 ! North 674 !----- 675 DO iseg = 1, nbdysegn 676 ib_bdy = npckgn(iseg) 677 ! 678 ! ------------ T points ------------- 679 igrd=1 680 icount=0 681 DO ir = 1, nn_rimwidth(ib_bdy) 682 DO ii = jpindt(iseg), jpinft(iseg) 683 icount = icount + 1 684 nbidta(icount, igrd, ib_bdy) = ii 685 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 686 nbrdta(icount, igrd, ib_bdy) = ir 687 ENDDO 688 ENDDO 689 ! 690 ! ------------ U points ------------- 691 igrd=2 692 icount=0 693 DO ir = 1, nn_rimwidth(ib_bdy) 694 ! DO ii = jpindt(iseg), jpinft(iseg) - 1 695 DO ii = jpindt(iseg), jpinft(iseg) 696 icount = icount + 1 697 nbidta(icount, igrd, ib_bdy) = ii 698 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 699 nbrdta(icount, igrd, ib_bdy) = ir 700 ENDDO 701 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 702 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 703 ENDDO 704 ! 705 ! ------------ V points ------------- 706 igrd=3 707 icount=0 708 DO ir = 1, nn_rimwidth(ib_bdy) 709 DO ii = jpindt(iseg), jpinft(iseg) 710 icount = icount + 1 711 nbidta(icount, igrd, ib_bdy) = ii 712 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 713 nbrdta(icount, igrd, ib_bdy) = ir 714 ENDDO 715 ENDDO 716 ENDDO 717 ! 718 ! South 719 !----- 720 DO iseg = 1, nbdysegs 721 ib_bdy = npckgs(iseg) 722 ! 723 ! ------------ T points ------------- 724 igrd=1 725 icount=0 726 DO ir = 1, nn_rimwidth(ib_bdy) 727 DO ii = jpisdt(iseg), jpisft(iseg) 728 icount = icount + 1 729 nbidta(icount, igrd, ib_bdy) = ii 730 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 731 nbrdta(icount, igrd, ib_bdy) = ir 732 ENDDO 733 ENDDO 734 ! 735 ! ------------ U points ------------- 736 igrd=2 737 icount=0 738 DO ir = 1, nn_rimwidth(ib_bdy) 739 ! DO ii = jpisdt(iseg), jpisft(iseg) - 1 740 DO ii = jpisdt(iseg), jpisft(iseg) 741 icount = icount + 1 742 nbidta(icount, igrd, ib_bdy) = ii 743 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 744 nbrdta(icount, igrd, ib_bdy) = ir 745 ENDDO 746 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 747 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 748 ENDDO 749 ! 750 ! ------------ V points ------------- 751 igrd=3 752 icount=0 753 DO ir = 1, nn_rimwidth(ib_bdy) 754 DO ii = jpisdt(iseg), jpisft(iseg) 755 icount = icount + 1 756 nbidta(icount, igrd, ib_bdy) = ii 757 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 758 nbrdta(icount, igrd, ib_bdy) = ir 759 ENDDO 760 ENDDO 761 ENDDO 441 CALL bdy_coords_seg( nbidta, nbjdta, nbrdta ) 762 442 763 443 ! Deal with duplicated points … … 773 453 DO ib2 = 1, nblendta(igrd,ib_bdy2) 774 454 IF ((nbidta(ib1, igrd, ib_bdy1)==nbidta(ib2, igrd, ib_bdy2)).AND. & 775 & (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN776 ! IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', &777 ! & nbidta(ib1, igrd, ib_bdy1), &778 ! & nbjdta(ib2, igrd, ib_bdy2)455 & (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN 456 ! IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', & 457 ! & nbidta(ib1, igrd, ib_bdy1), & 458 ! & nbjdta(ib2, igrd, ib_bdy2) 779 459 ! keep only points with the lowest distance to boundary: 780 460 IF (nbrdta(ib1, igrd, ib_bdy1)<nbrdta(ib2, igrd, ib_bdy2)) THEN 781 nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2782 nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2461 nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2 462 nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2 783 463 ELSEIF (nbrdta(ib1, igrd, ib_bdy1)>nbrdta(ib2, igrd, ib_bdy2)) THEN 784 nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1785 nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1786 ! Arbitrary choice if distances are the same:464 nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 465 nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 466 ! Arbitrary choice if distances are the same: 787 467 ELSE 788 nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1789 nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1468 nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 469 nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 790 470 ENDIF 791 471 END IF … … 796 476 END DO 797 477 END DO 798 799 ! Work out dimensions of boundary data on each processor 800 ! ------------------------------------------------------ 801 802 ! Rather assume that boundary data indices are given on global domain 803 ! TO BE DISCUSSED ? 804 ! iw = mig(1) + 1 ! if monotasking and no zoom, iw=2 805 ! ie = mig(1) + nlci-1 - 1 ! if monotasking and no zoom, ie=jpim1 806 ! is = mjg(1) + 1 ! if monotasking and no zoom, is=2 807 ! in = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 808 iwe = mig(1) - 1 + 2 ! if monotasking and no zoom, iw=2 809 ies = mig(1) + nlci-1 - 1 ! if monotasking and no zoom, ie=jpim1 810 iso = mjg(1) - 1 + 2 ! if monotasking and no zoom, is=2 811 ino = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 812 813 ALLOCATE( nbondi_bdy(nb_bdy)) 814 ALLOCATE( nbondj_bdy(nb_bdy)) 815 nbondi_bdy(:)=2 816 nbondj_bdy(:)=2 817 ALLOCATE( nbondi_bdy_b(nb_bdy)) 818 ALLOCATE( nbondj_bdy_b(nb_bdy)) 819 nbondi_bdy_b(:)=2 820 nbondj_bdy_b(:)=2 821 822 ! Work out dimensions of boundary data on each neighbour process 823 IF(nbondi == 0) THEN 824 iw_b(1) = 1 + nimppt(nowe+1) 825 ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 826 is_b(1) = 1 + njmppt(nowe+1) 827 in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 828 829 iw_b(2) = 1 + nimppt(noea+1) 830 ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 831 is_b(2) = 1 + njmppt(noea+1) 832 in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 833 ELSEIF(nbondi == 1) THEN 834 iw_b(1) = 1 + nimppt(nowe+1) 835 ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 836 is_b(1) = 1 + njmppt(nowe+1) 837 in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 838 ELSEIF(nbondi == -1) THEN 839 iw_b(2) = 1 + nimppt(noea+1) 840 ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 841 is_b(2) = 1 + njmppt(noea+1) 842 in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 843 ENDIF 844 845 IF(nbondj == 0) THEN 846 iw_b(3) = 1 + nimppt(noso+1) 847 ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 848 is_b(3) = 1 + njmppt(noso+1) 849 in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 850 851 iw_b(4) = 1 + nimppt(nono+1) 852 ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 853 is_b(4) = 1 + njmppt(nono+1) 854 in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 855 ELSEIF(nbondj == 1) THEN 856 iw_b(3) = 1 + nimppt(noso+1) 857 ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 858 is_b(3) = 1 + njmppt(noso+1) 859 in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 860 ELSEIF(nbondj == -1) THEN 861 iw_b(4) = 1 + nimppt(nono+1) 862 ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 863 is_b(4) = 1 + njmppt(nono+1) 864 in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 865 ENDIF 866 478 ! 479 ! Find lenght of boundaries and rim on local mpi domain 480 !------------------------------------------------------ 481 ! 482 iwe = mig(1) 483 ies = mig(jpi) 484 iso = mjg(1) 485 ino = mjg(jpj) 486 ! 867 487 DO ib_bdy = 1, nb_bdy 868 488 DO igrd = 1, jpbgrd 869 icount = 0 870 icountr = 0 871 idx_bdy(ib_bdy)%nblen(igrd) = 0 872 idx_bdy(ib_bdy)%nblenrim(igrd) = 0 489 icount = 0 ! initialization of local bdy length 490 icountr = 0 ! initialization of local rim 0 and rim 1 bdy length 491 icountr0 = 0 ! initialization of local rim 0 bdy length 492 idx_bdy(ib_bdy)%nblen(igrd) = 0 493 idx_bdy(ib_bdy)%nblenrim(igrd) = 0 494 idx_bdy(ib_bdy)%nblenrim0(igrd) = 0 873 495 DO ib = 1, nblendta(igrd,ib_bdy) 874 496 ! check that data is in correct order in file 875 ibm1 = MAX(1,ib-1) 876 IF(lwp) THEN ! Since all procs read global data only need to do this check on one proc... 877 IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ibm1,igrd,ib_bdy) ) THEN 497 IF( ib > 1 ) THEN 498 IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ib-1,igrd,ib_bdy) ) THEN 878 499 CALL ctl_stop('bdy_segs : ERROR : boundary data in file must be defined ', & 879 880 881 ENDIF 500 & ' in order of distance from edge nbr A utility for re-ordering ', & 501 & ' boundary coordinates and data files exists in the TOOLS/OBC directory') 502 ENDIF 882 503 ENDIF 883 504 ! check if point is in local domain … … 885 506 & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino ) THEN 886 507 ! 887 icount = icount 888 !889 IF( nbrdta(ib,igrd,ib_bdy) == 1 ) icountr = icountr+1508 icount = icount + 1 509 IF( nbrdta(ib,igrd,ib_bdy) == 1 .OR. nbrdta(ib,igrd,ib_bdy) == 0 ) icountr = icountr + 1 510 IF( nbrdta(ib,igrd,ib_bdy) == 0 ) icountr0 = icountr0 + 1 890 511 ENDIF 891 512 END DO 892 idx_bdy(ib_bdy)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc 893 idx_bdy(ib_bdy)%nblen (igrd) = icount !: length of boundary data on each proc 894 END DO ! igrd 513 idx_bdy(ib_bdy)%nblen (igrd) = icount !: length of boundary data on each proc 514 idx_bdy(ib_bdy)%nblenrim (igrd) = icountr !: length of rim 0 and rim 1 boundary data on each proc 515 idx_bdy(ib_bdy)%nblenrim0(igrd) = icountr0 !: length of rim 0 boundary data on each proc 516 END DO ! igrd 895 517 896 518 ! Allocate index arrays for this boundary set … … 902 524 & idx_bdy(ib_bdy)%nbd (ilen1,jpbgrd) , & 903 525 & idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) , & 526 & idx_bdy(ib_bdy)%ntreat(ilen1,jpbgrd) , & 904 527 & idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) , & 905 528 & idx_bdy(ib_bdy)%nbw (ilen1,jpbgrd) , & … … 909 532 ! Dispatch mapping indices and discrete distances on each processor 910 533 ! ----------------------------------------------------------------- 911 912 com_east = 0913 com_west = 0914 com_south = 0915 com_north = 0916 917 com_east_b = 0918 com_west_b = 0919 com_south_b = 0920 com_north_b = 0921 922 534 DO igrd = 1, jpbgrd 923 535 icount = 0 924 ! Loop on rimwidth to ensure outermost points come first in the local arrays.925 DO ir =1, nn_rimwidth(ib_bdy)536 ! Outer loop on rimwidth to ensure outermost points come first in the local arrays. 537 DO ir = 0, nn_rimwidth(ib_bdy) 926 538 DO ib = 1, nblendta(igrd,ib_bdy) 927 539 ! check if point is in local domain and equals ir … … 931 543 ! 932 544 icount = icount + 1 933 934 ! Rather assume that boundary data indices are given on global domain 935 ! TO BE DISCUSSED ? 936 ! idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 937 ! idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 938 idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 939 idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 940 ! check if point has to be sent 941 ii = idx_bdy(ib_bdy)%nbi(icount,igrd) 942 ij = idx_bdy(ib_bdy)%nbj(icount,igrd) 943 if((com_east .ne. 1) .and. (ii == (nlci-1)) .and. (nbondi .le. 0)) then 944 com_east = 1 945 elseif((com_west .ne. 1) .and. (ii == 2) .and. (nbondi .ge. 0) .and. (nbondi .ne. 2)) then 946 com_west = 1 947 endif 948 if((com_south .ne. 1) .and. (ij == 2) .and. (nbondj .ge. 0) .and. (nbondj .ne. 2)) then 949 com_south = 1 950 elseif((com_north .ne. 1) .and. (ij == (nlcj-1)) .and. (nbondj .le. 0)) then 951 com_north = 1 952 endif 545 idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 ! global to local indexes 546 idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 ! global to local indexes 953 547 idx_bdy(ib_bdy)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_bdy) 954 548 idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib 955 549 ENDIF 956 ! check if point has to be received from a neighbour 957 IF(nbondi == 0) THEN 958 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND. & 959 & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND. & 960 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 961 ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 962 if((com_west_b .ne. 1) .and. (ii == (nlcit(nowe+1)-1))) then 963 ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 964 if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 965 com_south = 1 966 elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 967 com_north = 1 968 endif 969 com_west_b = 1 970 endif 971 ENDIF 972 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND. & 973 & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND. & 974 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 975 ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 976 if((com_east_b .ne. 1) .and. (ii == 2)) then 977 ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 978 if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 979 com_south = 1 980 elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 981 com_north = 1 982 endif 983 com_east_b = 1 984 endif 985 ENDIF 986 ELSEIF(nbondi == 1) THEN 987 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND. & 988 & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND. & 989 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 990 ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 991 if((com_west_b .ne. 1) .and. (ii == (nlcit(nowe+1)-1))) then 992 ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 993 if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 994 com_south = 1 995 elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 996 com_north = 1 997 endif 998 com_west_b = 1 999 endif 1000 ENDIF 1001 ELSEIF(nbondi == -1) THEN 1002 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND. & 1003 & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND. & 1004 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1005 ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 1006 if((com_east_b .ne. 1) .and. (ii == 2)) then 1007 ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 1008 if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 1009 com_south = 1 1010 elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 1011 com_north = 1 1012 endif 1013 com_east_b = 1 1014 endif 1015 ENDIF 1016 ENDIF 1017 IF(nbondj == 0) THEN 1018 IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1 & 1019 & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 1020 & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 1021 com_north_b = 1 1022 ENDIF 1023 IF(com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 & 1024 &.OR. nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 1025 & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 1026 com_south_b = 1 1027 ENDIF 1028 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND. & 1029 & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND. & 1030 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1031 ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 1032 if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then 1033 com_south_b = 1 1034 endif 1035 ENDIF 1036 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND. & 1037 & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND. & 1038 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1039 ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 1040 if((com_north_b .ne. 1) .and. (ij == 2)) then 1041 com_north_b = 1 1042 endif 1043 ENDIF 1044 ELSEIF(nbondj == 1) THEN 1045 IF( com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 .OR. & 1046 & nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 1047 & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 1048 com_south_b = 1 1049 ENDIF 1050 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND. & 1051 & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND. & 1052 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1053 ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 1054 if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then 1055 com_south_b = 1 1056 endif 1057 ENDIF 1058 ELSEIF(nbondj == -1) THEN 1059 IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1 & 1060 & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 1061 & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 1062 com_north_b = 1 1063 ENDIF 1064 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND. & 1065 & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND. & 1066 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1067 ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 1068 if((com_north_b .ne. 1) .and. (ij == 2)) then 1069 com_north_b = 1 1070 endif 1071 ENDIF 1072 ENDIF 1073 ENDDO 1074 ENDDO 1075 ENDDO 1076 1077 ! definition of the i- and j- direction local boundaries arrays used for sending the boundaries 1078 IF( (com_east == 1) .and. (com_west == 1) ) THEN ; nbondi_bdy(ib_bdy) = 0 1079 ELSEIF( (com_east == 1) .and. (com_west == 0) ) THEN ; nbondi_bdy(ib_bdy) = -1 1080 ELSEIF( (com_east == 0) .and. (com_west == 1) ) THEN ; nbondi_bdy(ib_bdy) = 1 1081 ENDIF 1082 IF( (com_north == 1) .and. (com_south == 1) ) THEN ; nbondj_bdy(ib_bdy) = 0 1083 ELSEIF( (com_north == 1) .and. (com_south == 0) ) THEN ; nbondj_bdy(ib_bdy) = -1 1084 ELSEIF( (com_north == 0) .and. (com_south == 1) ) THEN ; nbondj_bdy(ib_bdy) = 1 1085 ENDIF 1086 1087 ! definition of the i- and j- direction local boundaries arrays used for receiving the boundaries 1088 IF( (com_east_b == 1) .and. (com_west_b == 1) ) THEN ; nbondi_bdy_b(ib_bdy) = 0 1089 ELSEIF( (com_east_b == 1) .and. (com_west_b == 0) ) THEN ; nbondi_bdy_b(ib_bdy) = -1 1090 ELSEIF( (com_east_b == 0) .and. (com_west_b == 1) ) THEN ; nbondi_bdy_b(ib_bdy) = 1 1091 ENDIF 1092 IF( (com_north_b == 1) .and. (com_south_b == 1) ) THEN ; nbondj_bdy_b(ib_bdy) = 0 1093 ELSEIF( (com_north_b == 1) .and. (com_south_b == 0) ) THEN ; nbondj_bdy_b(ib_bdy) = -1 1094 ELSEIF( (com_north_b == 0) .and. (com_south_b == 1) ) THEN ; nbondj_bdy_b(ib_bdy) = 1 1095 ENDIF 550 END DO 551 END DO 552 END DO ! igrd 553 554 END DO ! ib_bdy 555 556 ! Initialize array indicating communications in bdy 557 ! ------------------------------------------------- 558 ALLOCATE( lsend_bdy(nb_bdy,jpbgrd,4,0:1), lrecv_bdy(nb_bdy,jpbgrd,4,0:1) ) 559 lsend_bdy(:,:,:,:) = .false. 560 lrecv_bdy(:,:,:,:) = .false. 561 562 DO ib_bdy = 1, nb_bdy 563 DO igrd = 1, jpbgrd 564 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! only the rim triggers communications, see bdy routines 565 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 566 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 567 IF( ib .LE. idx_bdy(ib_bdy)%nblenrim0(igrd) ) THEN ; ir = 0 568 ELSE ; ir = 1 569 END IF 570 ! 571 ! check if point has to be sent to a neighbour 572 ! W neighbour and on the inner left side 573 IF( ii == 2 .and. (nbondi == 0 .or. nbondi == 1) ) lsend_bdy(ib_bdy,igrd,1,ir) = .true. 574 ! E neighbour and on the inner right side 575 IF( ii == jpi-1 .and. (nbondi == 0 .or. nbondi == -1) ) lsend_bdy(ib_bdy,igrd,2,ir) = .true. 576 ! S neighbour and on the inner down side 577 IF( ij == 2 .and. (nbondj == 0 .or. nbondj == 1) ) lsend_bdy(ib_bdy,igrd,3,ir) = .true. 578 ! N neighbour and on the inner up side 579 IF( ij == jpj-1 .and. (nbondj == 0 .or. nbondj == -1) ) lsend_bdy(ib_bdy,igrd,4,ir) = .true. 580 ! 581 ! check if point has to be received from a neighbour 582 ! W neighbour and on the outter left side 583 IF( ii == 1 .and. (nbondi == 0 .or. nbondi == 1) ) lrecv_bdy(ib_bdy,igrd,1,ir) = .true. 584 ! E neighbour and on the outter right side 585 IF( ii == jpi .and. (nbondi == 0 .or. nbondi == -1) ) lrecv_bdy(ib_bdy,igrd,2,ir) = .true. 586 ! S neighbour and on the outter down side 587 IF( ij == 1 .and. (nbondj == 0 .or. nbondj == 1) ) lrecv_bdy(ib_bdy,igrd,3,ir) = .true. 588 ! N neighbour and on the outter up side 589 IF( ij == jpj .and. (nbondj == 0 .or. nbondj == -1) ) lrecv_bdy(ib_bdy,igrd,4,ir) = .true. 590 ! 591 END DO 592 END DO ! igrd 1096 593 1097 594 ! Compute rim weights for FRS scheme … … 1099 596 DO igrd = 1, jpbgrd 1100 597 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 1101 nbr => idx_bdy(ib_bdy)%nbr(ib,igrd)1102 idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( nbr - 1 ) *0.5 ) ! tanh formulation1103 ! idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic1104 ! idx_bdy(ib_bdy)%nbw(ib,igrd) = REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)) ! linear1105 END DO 1106 END DO 598 ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same weights 599 idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( ir - 1 ) *0.5 ) ! tanh formulation 600 ! idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic 601 ! idx_bdy(ib_bdy)%nbw(ib,igrd) = REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)) ! linear 602 END DO 603 END DO 1107 604 1108 605 ! Compute damping coefficients … … 1110 607 DO igrd = 1, jpbgrd 1111 608 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 1112 nbr => idx_bdy(ib_bdy)%nbr(ib,igrd)609 ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same damping coefficients 1113 610 idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) & 1114 & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic611 & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic 1115 612 idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) & 1116 & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic1117 END DO 1118 END DO 1119 1120 END DO 613 & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic 614 END DO 615 END DO 616 617 END DO ! ib_bdy 1121 618 1122 619 ! ------------------------------------------------------ 1123 620 ! Initialise masks and find normal/tangential directions 1124 621 ! ------------------------------------------------------ 622 623 ! ------------------------------------------ 624 ! handle rim0, do as if rim 1 was free ocean 625 ! ------------------------------------------ 626 627 ztmask(:,:) = tmask(:,:,1) ; zumask(:,:) = umask(:,:,1) ; zvmask(:,:) = vmask(:,:,1) 628 ! For the flagu/flagv calculation below we require a version of fmask without 629 ! the land boundary condition (shlat) included: 630 DO ij = 1, jpjm1 631 DO ii = 1, jpim1 632 zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & 633 & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) 634 END DO 635 END DO 636 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 1125 637 1126 638 ! Read global 2D mask at T-points: bdytmask … … 1128 640 ! bdytmask = 1 on the computational domain AND on open boundaries 1129 641 ! = 0 elsewhere 1130 642 1131 643 bdytmask(:,:) = ssmask(:,:) 1132 644 1133 645 ! Derive mask on U and V grid from mask on T grid 1134 1135 bdyumask(:,:) = 0._wp1136 bdyvmask(:,:) = 0._wp1137 646 DO ij = 1, jpjm1 1138 647 DO ii = 1, jpim1 1139 bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1, ij)648 bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1,ij ) 1140 649 bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii ,ij+1) 1141 650 END DO 1142 651 END DO 1143 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1. , bdyvmask, 'V', 1. ) ! Lateral boundary cond. 1144 1145 ! bdy masks are now set to zero on boundary points: 1146 ! 1147 igrd = 1 652 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1., bdyvmask, 'V', 1. ) ! Lateral boundary cond. 653 654 ! bdy masks are now set to zero on rim 0 points: 1148 655 DO ib_bdy = 1, nb_bdy 1149 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1150 bdytmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 1151 END DO 1152 END DO 1153 ! 1154 igrd = 2 656 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 657 bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 658 END DO 659 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 660 bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 661 END DO 662 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 663 bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 664 END DO 665 END DO 666 667 CALL bdy_rim_treat( zumask, zvmask, zfmask, .true. ) ! compute flagu, flagv, ntreat on rim 0 668 669 ! ------------------------------------ 670 ! handle rim1, do as if rim 0 was land 671 ! ------------------------------------ 672 673 ! z[tuv]mask are now set to zero on rim 0 points: 1155 674 DO ib_bdy = 1, nb_bdy 1156 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1157 bdyumask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 1158 END DO 1159 END DO 1160 ! 1161 igrd = 3 675 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 676 ztmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 677 END DO 678 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 679 zumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 680 END DO 681 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 682 zvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 683 END DO 684 END DO 685 686 ! Recompute zfmask 687 DO ij = 1, jpjm1 688 DO ii = 1, jpim1 689 zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & 690 & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) 691 END DO 692 END DO 693 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 694 695 ! bdy masks are now set to zero on rim1 points: 1162 696 DO ib_bdy = 1, nb_bdy 1163 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1164 bdyvmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 1165 END DO 1166 END DO 1167 1168 ! For the flagu/flagv calculation below we require a version of fmask without 1169 ! the land boundary condition (shlat) included: 1170 zfmask(:,:) = 0 1171 DO ij = 2, jpjm1 1172 DO ii = 2, jpim1 1173 zfmask(ii,ij) = tmask(ii,ij ,1) * tmask(ii+1,ij ,1) & 1174 & * tmask(ii,ij+1,1) * tmask(ii+1,ij+1,1) 1175 END DO 1176 END DO 1177 1178 ! Lateral boundary conditions 1179 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 1180 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1. , bdyvmask, 'V', 1., bdytmask, 'T', 1. ) 697 DO ib = idx_bdy(ib_bdy)%nblenrim0(1) + 1, idx_bdy(ib_bdy)%nblenrim(1) ! extent of rim 1 698 bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 699 END DO 700 DO ib = idx_bdy(ib_bdy)%nblenrim0(2) + 1, idx_bdy(ib_bdy)%nblenrim(2) ! extent of rim 1 701 bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 702 END DO 703 DO ib = idx_bdy(ib_bdy)%nblenrim0(3) + 1, idx_bdy(ib_bdy)%nblenrim(3) ! extent of rim 1 704 bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 705 END DO 706 END DO 707 708 CALL bdy_rim_treat( zumask, zvmask, zfmask, .false. ) ! compute flagu, flagv, ntreat on rim 1 709 ! 710 ! Check which boundaries might need communication 711 ALLOCATE( lsend_bdyint(nb_bdy,jpbgrd,4,0:1), lrecv_bdyint(nb_bdy,jpbgrd,4,0:1) ) 712 lsend_bdyint(:,:,:,:) = .false. 713 lrecv_bdyint(:,:,:,:) = .false. 714 ALLOCATE( lsend_bdyext(nb_bdy,jpbgrd,4,0:1), lrecv_bdyext(nb_bdy,jpbgrd,4,0:1) ) 715 lsend_bdyext(:,:,:,:) = .false. 716 lrecv_bdyext(:,:,:,:) = .false. 717 ! 718 DO igrd = 1, jpbgrd 719 DO ib_bdy = 1, nb_bdy 720 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 721 IF( idx_bdy(ib_bdy)%ntreat(ib,igrd) == -1 ) CYCLE 722 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 723 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 724 ir = idx_bdy(ib_bdy)%nbr(ib,igrd) 725 flagu = NINT(idx_bdy(ib_bdy)%flagu(ib,igrd)) 726 flagv = NINT(idx_bdy(ib_bdy)%flagv(ib,igrd)) 727 iibe = ii - flagu ! neighbouring point towards the exterior of the computational domain 728 ijbe = ij - flagv 729 iibi = ii + flagu ! neighbouring point towards the interior of the computational domain 730 ijbi = ij + flagv 731 CALL find_neib( ii, ij, idx_bdy(ib_bdy)%ntreat(ib,igrd), ii1, ij1, ii2, ij2, ii3, ij3 ) ! free ocean neighbours 732 ! 733 ! search neighbour in the west/east direction 734 ! Rim is on the halo and computed ocean is towards exterior of mpi domain 735 ! <-- (o exterior) --> 736 ! (1) o|x OR (2) x|o 737 ! |___ ___| 738 IF( iibi == 0 .OR. ii1 == 0 .OR. ii2 == 0 .OR. ii3 == 0 ) lrecv_bdyint(ib_bdy,igrd,1,ir) = .true. 739 IF( iibi == jpi+1 .OR. ii1 == jpi+1 .OR. ii2 == jpi+1 .OR. ii3 == jpi+1 ) lrecv_bdyint(ib_bdy,igrd,2,ir) = .true. 740 IF( iibe == 0 ) lrecv_bdyext(ib_bdy,igrd,1,ir) = .true. 741 IF( iibe == jpi+1 ) lrecv_bdyext(ib_bdy,igrd,2,ir) = .true. 742 ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo 743 ! :¨¨¨¨¨|¨¨--> | | <--¨¨|¨¨¨¨¨: 744 ! : | x:o | neighbour limited by ... would need o | o:x | : 745 ! :.....|_._:_____| (1) W neighbour E neighbour (2) |_____:_._|.....: 746 IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. & 747 & ( iibi == 3 .OR. ii1 == 3 .OR. ii2 == 3 .OR. ii3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,1,ir)=.true. 748 IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. & 749 & ( iibi == jpi-2 .OR. ii1 == jpi-2 .OR. ii2 == jpi-2 .OR. ii3 == jpi-2) ) lsend_bdyint(ib_bdy,igrd,2,ir)=.true. 750 IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. iibe == 3 ) lsend_bdyext(ib_bdy,igrd,1,ir)=.true. 751 IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. iibe == jpi-2 ) lsend_bdyext(ib_bdy,igrd,2,ir)=.true. 752 ! 753 ! search neighbour in the north/south direction 754 ! Rim is on the halo and computed ocean is towards exterior of mpi domain 755 !(3) | | ^ ___o___ 756 ! | |___x___| OR | | x | 757 ! v o (4) | | 758 IF( ijbi == 0 .OR. ij1 == 0 .OR. ij2 == 0 .OR. ij3 == 0 ) lrecv_bdyint(ib_bdy,igrd,3,ir) = .true. 759 IF( ijbi == jpj+1 .OR. ij1 == jpj+1 .OR. ij2 == jpj+1 .OR. ij3 == jpj+1 ) lrecv_bdyint(ib_bdy,igrd,4,ir) = .true. 760 IF( ijbe == 0 ) lrecv_bdyext(ib_bdy,igrd,3,ir) = .true. 761 IF( ijbe == jpj+1 ) lrecv_bdyext(ib_bdy,igrd,4,ir) = .true. 762 ! Check if neighbour has its rim parallel to its mpi subdomain _________ border and next to its halo 763 ! ^ | o | : : 764 ! | |¨¨¨¨x¨¨¨¨| neighbour limited by ... would need o | |....x....| 765 ! :_________: (3) S neighbour N neighbour (4) v | o | 766 IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. & 767 & ( ijbi == 3 .OR. ij1 == 3 .OR. ij2 == 3 .OR. ij3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,3,ir)=.true. 768 IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. & 769 & ( ijbi == jpj-2 .OR. ij1 == jpj-2 .OR. ij2 == jpj-2 .OR. ij3 == jpj-2) ) lsend_bdyint(ib_bdy,igrd,4,ir)=.true. 770 IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. ijbe == 3 ) lsend_bdyext(ib_bdy,igrd,3,ir)=.true. 771 IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. ijbe == jpj-2 ) lsend_bdyext(ib_bdy,igrd,4,ir)=.true. 772 END DO 773 END DO 774 END DO 775 776 DO ib_bdy = 1,nb_bdy 777 IF( cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' .OR. & 778 & cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' .OR. & 779 & cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' ) THEN 780 DO igrd = 1, jpbgrd 781 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 782 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 783 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 784 IF( mig(ii) > 2 .AND. mig(ii) < jpiglo-2 .AND. mjg(ij) > 2 .AND. mjg(ij) < jpjglo-2 ) THEN 785 WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' 786 CALL ctl_stop( ctmp1 ) 787 END IF 788 END DO 789 END DO 790 END IF 791 END DO 792 ! 793 DEALLOCATE( nbidta, nbjdta, nbrdta ) 794 ! 795 END SUBROUTINE bdy_def 796 797 798 SUBROUTINE bdy_rim_treat( pumask, pvmask, pfmask, lrim0 ) 799 !!---------------------------------------------------------------------- 800 !! *** ROUTINE bdy_rim_treat *** 801 !! 802 !! ** Purpose : Initialize structures ( flagu, flagv, ntreat ) indicating how rim points 803 !! are to be handled in the boundary condition treatment 804 !! 805 !! ** Method : - to handle rim 0 zmasks must indicate ocean points (set at one on rim 0 and rim 1 and interior) 806 !! and bdymasks must be set at 0 on rim 0 (set at one on rim 1 and interior) 807 !! (as if rim 1 was free ocean) 808 !! - to handle rim 1 zmasks must be set at 0 on rim 0 (set at one on rim 1 and interior) 809 !! and bdymasks must indicate free ocean points (set at one on interior) 810 !! (as if rim 0 was land) 811 !! - we can then check in which direction the interior of the computational domain is with the difference 812 !! mask array values on both sides to compute flagu and flagv 813 !! - and look at the ocean neighbours to compute ntreat 814 !!---------------------------------------------------------------------- 815 REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) 816 REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary t/u/v mask array 817 LOGICAL , INTENT (in ) :: lrim0 ! .true. -> rim 0 .false. -> rim 1 818 INTEGER :: ib_bdy, ii, ij, igrd, ib, icount ! dummy loop indices 819 INTEGER :: i_offset, j_offset, inn ! local integer 820 INTEGER :: ibeg, iend ! local integer 821 LOGICAL :: llnon, llson, llean, llwen ! local logicals indicating the presence of a ocean neighbour 822 REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields 823 REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars 824 CHARACTER(LEN=1), DIMENSION(jpbgrd) :: cgrid 825 REAL(wp) , DIMENSION(jpi,jpj) :: ztmp 826 !!---------------------------------------------------------------------- 827 828 cgrid = (/'t','u','v'/) 829 1181 830 DO ib_bdy = 1, nb_bdy ! Indices and directions of rim velocity components 1182 1183 idx_bdy(ib_bdy)%flagu(:,:) = 0._wp1184 idx_bdy(ib_bdy)%flagv(:,:) = 0._wp1185 icount = 01186 831 1187 832 ! Calculate relationship of U direction to the local orientation of the boundary … … 1189 834 ! flagu = 0 : u is tangential 1190 835 ! flagu = 1 : u is normal to the boundary and is direction is inward 1191 1192 836 DO igrd = 1, jpbgrd 1193 837 SELECT CASE( igrd ) 1194 CASE( 1 ) ; pmask => umask (:,:,1); i_offset = 01195 CASE( 2 ) ; pmask => bdytmask(:,:); i_offset = 11196 CASE( 3 ) ; pmask => zfmask (:,:); i_offset = 0838 CASE( 1 ) ; zmask => pumask ; i_offset = 0 839 CASE( 2 ) ; zmask => bdytmask ; i_offset = 1 840 CASE( 3 ) ; zmask => pfmask ; i_offset = 0 1197 841 END SELECT 1198 842 icount = 0 1199 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1200 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1201 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1202 zefl = pmask(nbi+i_offset-1,nbj) 1203 zwfl = pmask(nbi+i_offset,nbj) 843 ztmp(:,:) = -999._wp 844 IF( lrim0 ) THEN ! extent of rim 0 845 ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 846 ELSE ! extent of rim 1 847 ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) 848 END IF 849 DO ib = ibeg, iend 850 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 851 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 852 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 853 zwfl = zmask(ii+i_offset-1,ij) 854 zefl = zmask(ii+i_offset ,ij) 1204 855 ! This error check only works if you are using the bdyXmask arrays 1205 IF( i_offset == 1 .and. zefl + zwfl == 2 ) THEN856 IF( i_offset == 1 .and. zefl + zwfl == 2. ) THEN 1206 857 icount = icount + 1 1207 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig( nbi),mjg(nbj)858 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) 1208 859 ELSE 1209 idx_bdy(ib_bdy)%flagu(ib,igrd) = -zefl + zwfl860 ztmp(ii,ij) = -zwfl + zefl 1210 861 ENDIF 1211 862 END DO 1212 863 IF( icount /= 0 ) THEN 1213 WRITE(ctmp1,*) ' E R R O R :Some ',cgrid(igrd),' grid points,', &864 WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & 1214 865 ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 1215 WRITE(ctmp2,*) ' ========== ' 1216 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 866 CALL ctl_stop( ctmp1 ) 1217 867 ENDIF 868 SELECT CASE( igrd ) 869 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) 870 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) 871 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) 872 END SELECT 873 DO ib = ibeg, iend 874 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 875 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 876 idx_bdy(ib_bdy)%flagu(ib,igrd) = ztmp(ii,ij) 877 END DO 1218 878 END DO 1219 879 … … 1222 882 ! flagv = 0 : v is tangential 1223 883 ! flagv = 1 : v is normal to the boundary and is direction is inward 1224 1225 884 DO igrd = 1, jpbgrd 1226 885 SELECT CASE( igrd ) 1227 CASE( 1 ) ; pmask => vmask (:,:,1); j_offset = 01228 CASE( 2 ) ; pmask => zfmask(:,:); j_offset = 01229 CASE( 3 ) ; pmask => bdytmask; j_offset = 1886 CASE( 1 ) ; zmask => pvmask ; j_offset = 0 887 CASE( 2 ) ; zmask => pfmask ; j_offset = 0 888 CASE( 3 ) ; zmask => bdytmask ; j_offset = 1 1230 889 END SELECT 1231 890 icount = 0 1232 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1233 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1234 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1235 znfl = pmask(nbi,nbj+j_offset-1) 1236 zsfl = pmask(nbi,nbj+j_offset ) 891 ztmp(:,:) = -999._wp 892 IF( lrim0 ) THEN ! extent of rim 0 893 ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 894 ELSE ! extent of rim 1 895 ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) 896 END IF 897 DO ib = ibeg, iend 898 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 899 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 900 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 901 zsfl = zmask(ii,ij+j_offset-1) 902 znfl = zmask(ii,ij+j_offset ) 1237 903 ! This error check only works if you are using the bdyXmask arrays 1238 IF( j_offset == 1 .and. znfl + zsfl == 2 ) THEN1239 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig( nbi),mjg(nbj)904 IF( j_offset == 1 .and. znfl + zsfl == 2. ) THEN 905 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) 1240 906 icount = icount + 1 1241 907 ELSE 1242 idx_bdy(ib_bdy)%flagv(ib,igrd) = -znfl + zsfl908 ztmp(ii,ij) = -zsfl + znfl 1243 909 END IF 1244 910 END DO 1245 911 IF( icount /= 0 ) THEN 1246 WRITE(ctmp1,*) ' E R R O R :Some ',cgrid(igrd),' grid points,', &912 WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & 1247 913 ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 1248 WRITE(ctmp2,*) ' ========== ' 1249 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1250 ENDIF 1251 END DO 1252 ! 1253 END DO 1254 ! 1255 ! Tidy up 1256 !-------- 1257 IF( nb_bdy>0 ) DEALLOCATE( nbidta, nbjdta, nbrdta ) 1258 ! 1259 END SUBROUTINE bdy_segs 1260 914 CALL ctl_stop( ctmp1 ) 915 ENDIF 916 SELECT CASE( igrd ) 917 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) 918 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) 919 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) 920 END SELECT 921 DO ib = ibeg, iend 922 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 923 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 924 idx_bdy(ib_bdy)%flagv(ib,igrd) = ztmp(ii,ij) 925 END DO 926 END DO 927 ! 928 END DO ! ib_bdy 929 930 DO ib_bdy = 1, nb_bdy 931 DO igrd = 1, jpbgrd 932 SELECT CASE( igrd ) 933 CASE( 1 ) ; zmask => bdytmask 934 CASE( 2 ) ; zmask => bdyumask 935 CASE( 3 ) ; zmask => bdyvmask 936 END SELECT 937 ztmp(:,:) = -999._wp 938 IF( lrim0 ) THEN ! extent of rim 0 939 ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 940 ELSE ! extent of rim 1 941 ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) 942 END IF 943 DO ib = ibeg, iend 944 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 945 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 946 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 947 llnon = zmask(ii ,ij+1) == 1. 948 llson = zmask(ii ,ij-1) == 1. 949 llean = zmask(ii+1,ij ) == 1. 950 llwen = zmask(ii-1,ij ) == 1. 951 inn = COUNT( (/ llnon, llson, llean, llwen /) ) 952 IF( inn == 0 ) THEN ! no neighbours -> interior of a corner or cluster of rim points 953 ! ! ! _____ ! _____ ! __ __ 954 ! 1 | o ! 2 o | ! 3 | x ! 4 x | ! | | -> error 955 ! |_x_ _ ! _ _x_| ! | o ! o | ! |x_x| 956 IF( zmask(ii+1,ij+1) == 1. ) THEN ; ztmp(ii,ij) = 1. 957 ELSEIF( zmask(ii-1,ij+1) == 1. ) THEN ; ztmp(ii,ij) = 2. 958 ELSEIF( zmask(ii+1,ij-1) == 1. ) THEN ; ztmp(ii,ij) = 3. 959 ELSEIF( zmask(ii-1,ij-1) == 1. ) THEN ; ztmp(ii,ij) = 4. 960 ELSE ; ztmp(ii,ij) = -1. 961 WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & 962 ' on boundary set ', ib_bdy, ' has no free ocean neighbour' 963 IF( lrim0 ) THEN 964 WRITE(ctmp2,*) ' There seems to be a cluster of rim 0 points.' 965 ELSE 966 WRITE(ctmp2,*) ' There seems to be a cluster of rim 1 points.' 967 END IF 968 CALL ctl_warn( ctmp1, ctmp2 ) 969 END IF 970 END IF 971 IF( inn == 1 ) THEN ! middle of linear bdy or incomplete corner ! ___ o 972 ! | ! | ! o ! ______ ! |x___ 973 ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x 974 ! | ! | ! ! o 975 IF( llean ) ztmp(ii,ij) = 5. 976 IF( llwen ) ztmp(ii,ij) = 6. 977 IF( llnon ) ztmp(ii,ij) = 7. 978 IF( llson ) ztmp(ii,ij) = 8. 979 END IF 980 IF( inn == 2 ) THEN ! exterior of a corner 981 ! o ! o ! _____| ! |_____ 982 ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x 983 ! | ! | ! o ! o 984 IF( llnon .AND. llean ) ztmp(ii,ij) = 9. 985 IF( llnon .AND. llwen ) ztmp(ii,ij) = 10. 986 IF( llson .AND. llean ) ztmp(ii,ij) = 11. 987 IF( llson .AND. llwen ) ztmp(ii,ij) = 12. 988 END IF 989 IF( inn == 3 ) THEN ! 3 neighbours __ __ 990 ! |_ o ! o _| ! |_| ! o 991 ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o 992 ! | o ! o | ! o ! __|¨|__ 993 IF( llnon .AND. llean .AND. llson ) ztmp(ii,ij) = 13. 994 IF( llnon .AND. llwen .AND. llson ) ztmp(ii,ij) = 14. 995 IF( llwen .AND. llson .AND. llean ) ztmp(ii,ij) = 15. 996 IF( llwen .AND. llnon .AND. llean ) ztmp(ii,ij) = 16. 997 END IF 998 IF( inn == 4 ) THEN 999 WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & 1000 ' on boundary set ', ib_bdy, ' have 4 neighbours' 1001 CALL ctl_stop( ctmp1 ) 1002 END IF 1003 END DO 1004 SELECT CASE( igrd ) 1005 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) 1006 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) 1007 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) 1008 END SELECT 1009 DO ib = ibeg, iend 1010 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1011 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1012 idx_bdy(ib_bdy)%ntreat(ib,igrd) = NINT(ztmp(ii,ij)) 1013 END DO 1014 END DO 1015 END DO 1016 1017 END SUBROUTINE bdy_rim_treat 1018 1019 1020 SUBROUTINE find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) 1021 !!---------------------------------------------------------------------- 1022 !! *** ROUTINE find_neib *** 1023 !! 1024 !! ** Purpose : get ii1, ij1, ii2, ij2, ii3, ij3, the indices of 1025 !! the free ocean neighbours of (ii,ij) for bdy treatment 1026 !! 1027 !! ** Method : use itreat input to select a case 1028 !! N.B. ntreat is defined for all bdy points in routine bdy_rim_treat 1029 !! 1030 !!---------------------------------------------------------------------- 1031 INTEGER, INTENT(in ) :: ii, ij, itreat 1032 INTEGER, INTENT( out) :: ii1, ij1, ii2, ij2, ii3, ij3 1033 !!---------------------------------------------------------------------- 1034 SELECT CASE( itreat ) ! points that will be used by bdy routines, -1 will be discarded 1035 ! ! ! _____ ! _____ 1036 ! 1 | o ! 2 o | ! 3 | x ! 4 x | 1037 ! |_x_ _ ! _ _x_| ! | o ! o | 1038 CASE( 1 ) ; ii1 = ii+1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1039 CASE( 2 ) ; ii1 = ii-1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1040 CASE( 3 ) ; ii1 = ii+1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1041 CASE( 4 ) ; ii1 = ii-1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1042 ! | ! | ! o ! ______ ! or incomplete corner 1043 ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x ! 7 ____ o 1044 ! | ! | ! ! o ! |x___ 1045 CASE( 5 ) ; ii1 = ii+1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1046 CASE( 6 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1047 CASE( 7 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1048 CASE( 8 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1049 ! o ! o ! _____| ! |_____ 1050 ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x 1051 ! | ! | ! o ! o 1052 CASE( 9 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 1053 CASE( 10 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 1054 CASE( 11 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 1055 CASE( 12 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 1056 ! |_ o ! o _| ! ¨¨|_|¨¨ ! o 1057 ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o 1058 ! | o ! o | ! o ! __|¨|__ 1059 CASE( 13 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 1060 CASE( 14 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 1061 CASE( 15 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij-1 ; ii3 = ii+1 ; ij3 = ij 1062 CASE( 16 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij+1 ; ii3 = ii+1 ; ij3 = ij 1063 END SELECT 1064 END SUBROUTINE find_neib 1065 1066 1067 SUBROUTINE bdy_read_seg( kb_bdy, knblendta ) 1068 !!---------------------------------------------------------------------- 1069 !! *** ROUTINE bdy_coords_seg *** 1070 !! 1071 !! ** Purpose : build bdy coordinates with segments defined in namelist 1072 !! 1073 !! ** Method : read namelist nambdy_index blocks 1074 !! 1075 !!---------------------------------------------------------------------- 1076 INTEGER , INTENT (in ) :: kb_bdy ! bdy number 1077 INTEGER, DIMENSION(jpbgrd), INTENT ( out) :: knblendta ! length of index arrays 1078 !! 1079 INTEGER :: ios ! Local integer output status for namelist read 1080 INTEGER :: nbdyind, nbdybeg, nbdyend 1081 CHARACTER(LEN=1) :: ctypebdy ! - - 1082 NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend 1083 !!---------------------------------------------------------------------- 1084 1085 ! No REWIND here because may need to read more than one nambdy_index namelist. 1086 ! Read only namelist_cfg to avoid unseccessfull overwrite 1087 ! keep full control of the configuration namelist 1088 READ ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 ) 1089 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in configuration namelist' ) 1090 IF(lwm) WRITE ( numond, nambdy_index ) 1091 1092 SELECT CASE ( TRIM(ctypebdy) ) 1093 CASE( 'N' ) 1094 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1095 nbdyind = jpjglo - 2 ! set boundary to whole side of model domain. 1096 nbdybeg = 2 1097 nbdyend = jpiglo - 1 1098 ENDIF 1099 nbdysegn = nbdysegn + 1 1100 npckgn(nbdysegn) = kb_bdy ! Save bdy package number 1101 jpjnob(nbdysegn) = nbdyind 1102 jpindt(nbdysegn) = nbdybeg 1103 jpinft(nbdysegn) = nbdyend 1104 ! 1105 CASE( 'S' ) 1106 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1107 nbdyind = 2 ! set boundary to whole side of model domain. 1108 nbdybeg = 2 1109 nbdyend = jpiglo - 1 1110 ENDIF 1111 nbdysegs = nbdysegs + 1 1112 npckgs(nbdysegs) = kb_bdy ! Save bdy package number 1113 jpjsob(nbdysegs) = nbdyind 1114 jpisdt(nbdysegs) = nbdybeg 1115 jpisft(nbdysegs) = nbdyend 1116 ! 1117 CASE( 'E' ) 1118 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1119 nbdyind = jpiglo - 2 ! set boundary to whole side of model domain. 1120 nbdybeg = 2 1121 nbdyend = jpjglo - 1 1122 ENDIF 1123 nbdysege = nbdysege + 1 1124 npckge(nbdysege) = kb_bdy ! Save bdy package number 1125 jpieob(nbdysege) = nbdyind 1126 jpjedt(nbdysege) = nbdybeg 1127 jpjeft(nbdysege) = nbdyend 1128 ! 1129 CASE( 'W' ) 1130 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1131 nbdyind = 2 ! set boundary to whole side of model domain. 1132 nbdybeg = 2 1133 nbdyend = jpjglo - 1 1134 ENDIF 1135 nbdysegw = nbdysegw + 1 1136 npckgw(nbdysegw) = kb_bdy ! Save bdy package number 1137 jpiwob(nbdysegw) = nbdyind 1138 jpjwdt(nbdysegw) = nbdybeg 1139 jpjwft(nbdysegw) = nbdyend 1140 ! 1141 CASE DEFAULT ; CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) 1142 END SELECT 1143 1144 ! For simplicity we assume that in case of straight bdy, arrays have the same length 1145 ! (even if it is true that last tangential velocity points 1146 ! are useless). This simplifies a little bit boundary data format (and agrees with format 1147 ! used so far in obc package) 1148 1149 knblendta(1:jpbgrd) = (nbdyend - nbdybeg + 1) * nn_rimwidth(kb_bdy) 1150 1151 END SUBROUTINE bdy_read_seg 1152 1153 1261 1154 SUBROUTINE bdy_ctl_seg 1262 1155 !!---------------------------------------------------------------------- … … 1288 1181 &(jpjnob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1289 1182 IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1290 IF (jpindt(ib).l e.1 ) CALL ctl_stop( 'Start index out of domain' )1291 IF (jpinft(ib).g e.jpiglo) CALL ctl_stop( 'End index out of domain' )1183 IF (jpindt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1184 IF (jpinft(ib).gt.jpiglo) CALL ctl_stop( 'End index out of domain' ) 1292 1185 END DO 1293 1186 ! … … 1297 1190 &(jpjsob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1298 1191 IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1299 IF (jpisdt(ib).l e.1 ) CALL ctl_stop( 'Start index out of domain' )1300 IF (jpisft(ib).g e.jpiglo) CALL ctl_stop( 'End index out of domain' )1192 IF (jpisdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1193 IF (jpisft(ib).gt.jpiglo) CALL ctl_stop( 'End index out of domain' ) 1301 1194 END DO 1302 1195 ! … … 1306 1199 &(jpieob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1307 1200 IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1308 IF (jpjedt(ib).l e.1 ) CALL ctl_stop( 'Start index out of domain' )1309 IF (jpjeft(ib).g e.jpjglo) CALL ctl_stop( 'End index out of domain' )1201 IF (jpjedt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1202 IF (jpjeft(ib).gt.jpjglo) CALL ctl_stop( 'End index out of domain' ) 1310 1203 END DO 1311 1204 ! … … 1315 1208 &(jpiwob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1316 1209 IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1317 IF (jpjwdt(ib).l e.1 ) CALL ctl_stop( 'Start index out of domain' )1318 IF (jpjwft(ib).g e.jpjglo) CALL ctl_stop( 'End index out of domain' )1210 IF (jpjwdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1211 IF (jpjwft(ib).gt.jpjglo) CALL ctl_stop( 'End index out of domain' ) 1319 1212 ENDDO 1320 1213 ! … … 1345 1238 icorns(ib2,1) = npckgw(ib1) 1346 1239 ELSEIF ((jpisft(ib2)==jpiwob(ib1)).AND.(jpjwft(ib1)==jpjsob(ib2))) THEN 1347 WRITE(ctmp1,*) ' E R R O R :Found an acute open boundary corner at point (i,j)= ', &1240 WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 1348 1241 & jpisft(ib2), jpjwft(ib1) 1349 WRITE(ctmp2,*) ' ==========Not allowed yet'1350 WRITE(ctmp3,*) ' 1351 & 1352 CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ')1242 WRITE(ctmp2,*) ' Not allowed yet' 1243 WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & 1244 & ' and South segment: ',npckgs(ib2) 1245 CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 1353 1246 ELSE 1354 WRITE(ctmp1,*) ' E R R O R :Check South and West Open boundary indices'1355 WRITE(ctmp2,*) ' ==========Crossing problem with West segment: ',npckgw(ib1) , &1356 & 1357 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ')1247 WRITE(ctmp1,*) ' Check South and West Open boundary indices' 1248 WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1) , & 1249 & ' and South segment: ',npckgs(ib2) 1250 CALL ctl_stop( ctmp1, ctmp2 ) 1358 1251 END IF 1359 1252 END IF … … 1377 1270 icorns(ib2,2) = npckge(ib1) 1378 1271 ELSEIF ((jpjeft(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpieob(ib1)+1)) THEN 1379 WRITE(ctmp1,*) ' E R R O R :Found an acute open boundary corner at point (i,j)= ', &1272 WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 1380 1273 & jpisdt(ib2), jpjeft(ib1) 1381 WRITE(ctmp2,*) ' ==========Not allowed yet'1382 WRITE(ctmp3,*) ' 1383 & 1384 CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ')1274 WRITE(ctmp2,*) ' Not allowed yet' 1275 WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & 1276 & ' and South segment: ',npckgs(ib2) 1277 CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 1385 1278 ELSE 1386 WRITE(ctmp1,*) ' E R R O R :Check South and East Open boundary indices'1387 WRITE(ctmp2,*) ' ==========Crossing problem with East segment: ',npckge(ib1), &1388 & 1389 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ')1279 WRITE(ctmp1,*) ' Check South and East Open boundary indices' 1280 WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & 1281 & ' and South segment: ',npckgs(ib2) 1282 CALL ctl_stop( ctmp1, ctmp2 ) 1390 1283 END IF 1391 1284 END IF … … 1409 1302 icornn(ib2,1) = npckgw(ib1) 1410 1303 ELSEIF ((jpjwdt(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpiwob(ib1))) THEN 1411 WRITE(ctmp1,*) ' E R R O R :Found an acute open boundary corner at point (i,j)= ', &1304 WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 1412 1305 & jpinft(ib2), jpjwdt(ib1) 1413 WRITE(ctmp2,*) ' ==========Not allowed yet'1414 WRITE(ctmp3,*) ' 1415 & 1416 CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ')1306 WRITE(ctmp2,*) ' Not allowed yet' 1307 WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & 1308 & ' and North segment: ',npckgn(ib2) 1309 CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 1417 1310 ELSE 1418 WRITE(ctmp1,*) ' E R R O R :Check North and West Open boundary indices'1419 WRITE(ctmp2,*) ' ==========Crossing problem with West segment: ',npckgw(ib1), &1420 & 1421 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ')1311 WRITE(ctmp1,*) ' Check North and West Open boundary indices' 1312 WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1), & 1313 & ' and North segment: ',npckgn(ib2) 1314 CALL ctl_stop( ctmp1, ctmp2 ) 1422 1315 END IF 1423 1316 END IF … … 1441 1334 icornn(ib2,2) = npckge(ib1) 1442 1335 ELSEIF ((jpjedt(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpieob(ib1)+1)) THEN 1443 WRITE(ctmp1,*) ' E R R O R :Found an acute open boundary corner at point (i,j)= ', &1336 WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 1444 1337 & jpindt(ib2), jpjedt(ib1) 1445 WRITE(ctmp2,*) ' ==========Not allowed yet'1446 WRITE(ctmp3,*) ' 1447 & 1448 CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ')1338 WRITE(ctmp2,*) ' Not allowed yet' 1339 WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & 1340 & ' and North segment: ',npckgn(ib2) 1341 CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 1449 1342 ELSE 1450 WRITE(ctmp1,*) ' E R R O R :Check North and East Open boundary indices'1451 WRITE(ctmp2,*) ' ==========Crossing problem with East segment: ',npckge(ib1), &1452 & 1453 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ')1343 WRITE(ctmp1,*) ' Check North and East Open boundary indices' 1344 WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & 1345 & ' and North segment: ',npckgn(ib2) 1346 CALL ctl_stop( ctmp1, ctmp2 ) 1454 1347 END IF 1455 1348 END IF … … 1477 1370 IF (ztestmask(1)==1) THEN 1478 1371 IF (icornw(ib,1)==0) THEN 1479 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgw(ib) 1480 WRITE(ctmp2,*) ' ========== does not start on land or on a corner' 1481 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1372 WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) 1373 CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 1482 1374 ELSE 1483 1375 ! This is a corner … … 1489 1381 IF (ztestmask(2)==1) THEN 1490 1382 IF (icornw(ib,2)==0) THEN 1491 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgw(ib) 1492 WRITE(ctmp2,*) ' ========== does not end on land or on a corner' 1493 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1383 WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) 1384 CALL ctl_stop( ' ', ctmp1, ' does not end on land or on a corner' ) 1494 1385 ELSE 1495 1386 ! This is a corner … … 1517 1408 IF (ztestmask(1)==1) THEN 1518 1409 IF (icorne(ib,1)==0) THEN 1519 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckge(ib) 1520 WRITE(ctmp2,*) ' ========== does not start on land or on a corner' 1521 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1410 WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) 1411 CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 1522 1412 ELSE 1523 1413 ! This is a corner … … 1529 1419 IF (ztestmask(2)==1) THEN 1530 1420 IF (icorne(ib,2)==0) THEN 1531 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckge(ib) 1532 WRITE(ctmp2,*) ' ========== does not end on land or on a corner' 1533 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1421 WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) 1422 CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) 1534 1423 ELSE 1535 1424 ! This is a corner … … 1556 1445 1557 1446 IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN 1558 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgs(ib) 1559 WRITE(ctmp2,*) ' ========== does not start on land or on a corner' 1560 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1447 WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) 1448 CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 1561 1449 ENDIF 1562 1450 IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN 1563 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgs(ib) 1564 WRITE(ctmp2,*) ' ========== does not end on land or on a corner' 1565 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1451 WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) 1452 CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) 1566 1453 ENDIF 1567 1454 END DO … … 1582 1469 1583 1470 IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN 1584 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgn(ib) 1585 WRITE(ctmp2,*) ' ========== does not start on land' 1586 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1471 WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) 1472 CALL ctl_stop( ctmp1, ' does not start on land' ) 1587 1473 ENDIF 1588 1474 IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN 1589 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgn(ib) 1590 WRITE(ctmp2,*) ' ========== does not end on land' 1591 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1475 WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) 1476 CALL ctl_stop( ctmp1, ' does not end on land' ) 1592 1477 ENDIF 1593 1478 END DO … … 1602 1487 END SUBROUTINE bdy_ctl_seg 1603 1488 1604 1489 1490 SUBROUTINE bdy_coords_seg( nbidta, nbjdta, nbrdta ) 1491 !!---------------------------------------------------------------------- 1492 !! *** ROUTINE bdy_coords_seg *** 1493 !! 1494 !! ** Purpose : build nbidta, nbidta, nbrdta for bdy built with segments 1495 !! 1496 !! ** Method : 1497 !! 1498 !!---------------------------------------------------------------------- 1499 INTEGER, DIMENSION(:,:,:), intent( out) :: nbidta, nbjdta, nbrdta ! Index arrays: i and j indices of bdy dta 1500 !! 1501 INTEGER :: ii, ij, ir, iseg 1502 INTEGER :: igrd ! grid type (t=1, u=2, v=3) 1503 INTEGER :: icount ! 1504 INTEGER :: ib_bdy ! bdy number 1505 !!---------------------------------------------------------------------- 1506 1507 ! East 1508 !----- 1509 DO iseg = 1, nbdysege 1510 ib_bdy = npckge(iseg) 1511 ! 1512 ! ------------ T points ------------- 1513 igrd=1 1514 icount=0 1515 DO ir = 1, nn_rimwidth(ib_bdy) 1516 DO ij = jpjedt(iseg), jpjeft(iseg) 1517 icount = icount + 1 1518 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 1519 nbjdta(icount, igrd, ib_bdy) = ij 1520 nbrdta(icount, igrd, ib_bdy) = ir 1521 ENDDO 1522 ENDDO 1523 ! 1524 ! ------------ U points ------------- 1525 igrd=2 1526 icount=0 1527 DO ir = 1, nn_rimwidth(ib_bdy) 1528 DO ij = jpjedt(iseg), jpjeft(iseg) 1529 icount = icount + 1 1530 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 1531 nbjdta(icount, igrd, ib_bdy) = ij 1532 nbrdta(icount, igrd, ib_bdy) = ir 1533 ENDDO 1534 ENDDO 1535 ! 1536 ! ------------ V points ------------- 1537 igrd=3 1538 icount=0 1539 DO ir = 1, nn_rimwidth(ib_bdy) 1540 ! DO ij = jpjedt(iseg), jpjeft(iseg) - 1 1541 DO ij = jpjedt(iseg), jpjeft(iseg) 1542 icount = icount + 1 1543 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 1544 nbjdta(icount, igrd, ib_bdy) = ij 1545 nbrdta(icount, igrd, ib_bdy) = ir 1546 ENDDO 1547 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1548 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1549 ENDDO 1550 ENDDO 1551 ! 1552 ! West 1553 !----- 1554 DO iseg = 1, nbdysegw 1555 ib_bdy = npckgw(iseg) 1556 ! 1557 ! ------------ T points ------------- 1558 igrd=1 1559 icount=0 1560 DO ir = 1, nn_rimwidth(ib_bdy) 1561 DO ij = jpjwdt(iseg), jpjwft(iseg) 1562 icount = icount + 1 1563 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1564 nbjdta(icount, igrd, ib_bdy) = ij 1565 nbrdta(icount, igrd, ib_bdy) = ir 1566 ENDDO 1567 ENDDO 1568 ! 1569 ! ------------ U points ------------- 1570 igrd=2 1571 icount=0 1572 DO ir = 1, nn_rimwidth(ib_bdy) 1573 DO ij = jpjwdt(iseg), jpjwft(iseg) 1574 icount = icount + 1 1575 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1576 nbjdta(icount, igrd, ib_bdy) = ij 1577 nbrdta(icount, igrd, ib_bdy) = ir 1578 ENDDO 1579 ENDDO 1580 ! 1581 ! ------------ V points ------------- 1582 igrd=3 1583 icount=0 1584 DO ir = 1, nn_rimwidth(ib_bdy) 1585 ! DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 1586 DO ij = jpjwdt(iseg), jpjwft(iseg) 1587 icount = icount + 1 1588 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1589 nbjdta(icount, igrd, ib_bdy) = ij 1590 nbrdta(icount, igrd, ib_bdy) = ir 1591 ENDDO 1592 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1593 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1594 ENDDO 1595 ENDDO 1596 ! 1597 ! North 1598 !----- 1599 DO iseg = 1, nbdysegn 1600 ib_bdy = npckgn(iseg) 1601 ! 1602 ! ------------ T points ------------- 1603 igrd=1 1604 icount=0 1605 DO ir = 1, nn_rimwidth(ib_bdy) 1606 DO ii = jpindt(iseg), jpinft(iseg) 1607 icount = icount + 1 1608 nbidta(icount, igrd, ib_bdy) = ii 1609 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 1610 nbrdta(icount, igrd, ib_bdy) = ir 1611 ENDDO 1612 ENDDO 1613 ! 1614 ! ------------ U points ------------- 1615 igrd=2 1616 icount=0 1617 DO ir = 1, nn_rimwidth(ib_bdy) 1618 ! DO ii = jpindt(iseg), jpinft(iseg) - 1 1619 DO ii = jpindt(iseg), jpinft(iseg) 1620 icount = icount + 1 1621 nbidta(icount, igrd, ib_bdy) = ii 1622 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 1623 nbrdta(icount, igrd, ib_bdy) = ir 1624 ENDDO 1625 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1626 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1627 ENDDO 1628 ! 1629 ! ------------ V points ------------- 1630 igrd=3 1631 icount=0 1632 DO ir = 1, nn_rimwidth(ib_bdy) 1633 DO ii = jpindt(iseg), jpinft(iseg) 1634 icount = icount + 1 1635 nbidta(icount, igrd, ib_bdy) = ii 1636 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 1637 nbrdta(icount, igrd, ib_bdy) = ir 1638 ENDDO 1639 ENDDO 1640 ENDDO 1641 ! 1642 ! South 1643 !----- 1644 DO iseg = 1, nbdysegs 1645 ib_bdy = npckgs(iseg) 1646 ! 1647 ! ------------ T points ------------- 1648 igrd=1 1649 icount=0 1650 DO ir = 1, nn_rimwidth(ib_bdy) 1651 DO ii = jpisdt(iseg), jpisft(iseg) 1652 icount = icount + 1 1653 nbidta(icount, igrd, ib_bdy) = ii 1654 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1655 nbrdta(icount, igrd, ib_bdy) = ir 1656 ENDDO 1657 ENDDO 1658 ! 1659 ! ------------ U points ------------- 1660 igrd=2 1661 icount=0 1662 DO ir = 1, nn_rimwidth(ib_bdy) 1663 ! DO ii = jpisdt(iseg), jpisft(iseg) - 1 1664 DO ii = jpisdt(iseg), jpisft(iseg) 1665 icount = icount + 1 1666 nbidta(icount, igrd, ib_bdy) = ii 1667 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1668 nbrdta(icount, igrd, ib_bdy) = ir 1669 ENDDO 1670 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1671 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1672 ENDDO 1673 ! 1674 ! ------------ V points ------------- 1675 igrd=3 1676 icount=0 1677 DO ir = 1, nn_rimwidth(ib_bdy) 1678 DO ii = jpisdt(iseg), jpisft(iseg) 1679 icount = icount + 1 1680 nbidta(icount, igrd, ib_bdy) = ii 1681 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1682 nbrdta(icount, igrd, ib_bdy) = ir 1683 ENDDO 1684 ENDDO 1685 ENDDO 1686 1687 1688 END SUBROUTINE bdy_coords_seg 1689 1690 1605 1691 SUBROUTINE bdy_ctl_corn( ib1, ib2 ) 1606 1692 !!---------------------------------------------------------------------- … … 1628 1714 ! 1629 1715 IF( itest>0 ) THEN 1630 WRITE(ctmp1,*) ' E R R O R : Segments ', ib1, 'and ', ib2 1631 WRITE(ctmp2,*) ' ========== have different open bdy schemes' 1632 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1716 WRITE(ctmp1,*) ' Segments ', ib1, 'and ', ib2 1717 CALL ctl_stop( ctmp1, ' have different open bdy schemes' ) 1633 1718 ENDIF 1634 1719 ! 1635 1720 END SUBROUTINE bdy_ctl_corn 1636 1721 1722 1723 SUBROUTINE bdy_meshwri() 1724 !!---------------------------------------------------------------------- 1725 !! *** ROUTINE bdy_meshwri *** 1726 !! 1727 !! ** Purpose : write netcdf file with nbr, flagu, flagv, ntreat for T, U 1728 !! and V points in 2D arrays for easier visualisation/control 1729 !! 1730 !! ** Method : use iom_rstput as in domwri.F 1731 !!---------------------------------------------------------------------- 1732 INTEGER :: ib_bdy, ii, ij, igrd, ib ! dummy loop indices 1733 INTEGER :: inum ! - - 1734 REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields 1735 REAL(wp) , DIMENSION(jpi,jpj) :: ztmp 1736 CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid 1737 !!---------------------------------------------------------------------- 1738 cgrid = (/'t','u','v'/) 1739 CALL iom_open( 'bdy_mesh', inum, ldwrt = .TRUE. ) 1740 DO igrd = 1, jpbgrd 1741 SELECT CASE( igrd ) 1742 CASE( 1 ) ; zmask => tmask(:,:,1) 1743 CASE( 2 ) ; zmask => umask(:,:,1) 1744 CASE( 3 ) ; zmask => vmask(:,:,1) 1745 END SELECT 1746 ztmp(:,:) = zmask(:,:) 1747 DO ib_bdy = 1, nb_bdy 1748 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) ! nbr deined for all rims 1749 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1750 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1751 ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%nbr(ib,igrd), wp) + 10. 1752 IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 1753 END DO 1754 END DO 1755 CALL iom_rstput( 0, 0, inum, 'bdy_nbr_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 1756 ztmp(:,:) = zmask(:,:) 1757 DO ib_bdy = 1, nb_bdy 1758 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagu defined only for rims 0 and 1 1759 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1760 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1761 ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagu(ib,igrd), wp) + 10. 1762 IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 1763 END DO 1764 END DO 1765 CALL iom_rstput( 0, 0, inum, 'flagu_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 1766 ztmp(:,:) = zmask(:,:) 1767 DO ib_bdy = 1, nb_bdy 1768 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagv defined only for rims 0 and 1 1769 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1770 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1771 ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagv(ib,igrd), wp) + 10. 1772 IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 1773 END DO 1774 END DO 1775 CALL iom_rstput( 0, 0, inum, 'flagv_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 1776 ztmp(:,:) = zmask(:,:) 1777 DO ib_bdy = 1, nb_bdy 1778 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! ntreat defined only for rims 0 and 1 1779 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1780 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1781 ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%ntreat(ib,igrd), wp) + 10. 1782 IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 1783 END DO 1784 END DO 1785 CALL iom_rstput( 0, 0, inum, 'ntreat_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 1786 END DO 1787 CALL iom_close( inum ) 1788 1789 END SUBROUTINE bdy_meshwri 1790 1637 1791 !!================================================================================= 1638 1792 END MODULE bdyini -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdylib.F90
r10529 r12065 15 15 USE bdy_oce ! ocean open boundary conditions 16 16 USE phycst ! physical constants 17 USE bdyini 17 18 ! 18 19 USE in_out_manager ! … … 75 76 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend 76 77 !! 77 REAL(wp) :: zwgt ! boundary weight78 78 INTEGER :: ib, ik, igrd ! dummy loop indices 79 79 INTEGER :: ii, ij ! 2D addresses … … 92 92 93 93 94 SUBROUTINE bdy_orl( idx, ptb, pta, dta, l l_npo )94 SUBROUTINE bdy_orl( idx, ptb, pta, dta, lrim0, ll_npo ) 95 95 !!---------------------------------------------------------------------- 96 96 !! *** SUBROUTINE bdy_orl *** … … 104 104 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptb ! before tracer field 105 105 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend 106 LOGICAL , OPTIONAL, INTENT(in) :: lrim0 ! indicate if rim 0 is treated 106 107 LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version 107 108 !! … … 111 112 igrd = 1 ! Everything is at T-points here 112 113 ! 113 CALL bdy_orlanski_3d( idx, igrd, ptb(:,:,:), pta(:,:,:), dta, l l_npo )114 CALL bdy_orlanski_3d( idx, igrd, ptb(:,:,:), pta(:,:,:), dta, lrim0, ll_npo ) 114 115 ! 115 116 END SUBROUTINE bdy_orl 116 117 117 118 118 SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, l l_npo )119 SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) 119 120 !!---------------------------------------------------------------------- 120 121 !! *** SUBROUTINE bdy_orlanski_2d *** … … 132 133 REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated) 133 134 REAL(wp), DIMENSION(:) , INTENT(in ) :: phi_ext ! external forcing data 135 LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 134 136 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 135 137 ! … … 140 142 INTEGER :: ii_offset, ij_offset ! offsets for mask indices 141 143 INTEGER :: flagu, flagv ! short cuts 144 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) 142 145 REAL(wp) :: zmask_x, zmask_y1, zmask_y2 143 146 REAL(wp) :: zex1, zex2, zey, zey1, zey2 … … 146 149 REAL(wp) :: zdy_1, zdy_2, zsign_ups 147 150 REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value 148 REAL(wp), POINTER, DIMENSION(:,:) :: pmask ! land/sea mask for field149 REAL(wp), POINTER, DIMENSION(:,:) :: pmask_xdif ! land/sea mask for x-derivatives150 REAL(wp), POINTER, DIMENSION(:,:) :: pmask_ydif ! land/sea mask for y-derivatives151 REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! land/sea mask for field 152 REAL(wp), POINTER, DIMENSION(:,:) :: zmask_xdif ! land/sea mask for x-derivatives 153 REAL(wp), POINTER, DIMENSION(:,:) :: zmask_ydif ! land/sea mask for y-derivatives 151 154 REAL(wp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives 152 155 REAL(wp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives … … 159 162 SELECT CASE(igrd) 160 163 CASE(1) 161 pmask => tmask(:,:,1)162 pmask_xdif => umask(:,:,1)163 pmask_ydif => vmask(:,:,1)164 zmask => tmask(:,:,1) 165 zmask_xdif => umask(:,:,1) 166 zmask_ydif => vmask(:,:,1) 164 167 pe_xdif => e1u(:,:) 165 168 pe_ydif => e2v(:,:) … … 167 170 ij_offset = 0 168 171 CASE(2) 169 pmask => umask(:,:,1)170 pmask_xdif => tmask(:,:,1)171 pmask_ydif => fmask(:,:,1)172 zmask => umask(:,:,1) 173 zmask_xdif => tmask(:,:,1) 174 zmask_ydif => fmask(:,:,1) 172 175 pe_xdif => e1t(:,:) 173 176 pe_ydif => e2f(:,:) … … 175 178 ij_offset = 0 176 179 CASE(3) 177 pmask => vmask(:,:,1)178 pmask_xdif => fmask(:,:,1)179 pmask_ydif => tmask(:,:,1)180 zmask => vmask(:,:,1) 181 zmask_xdif => fmask(:,:,1) 182 zmask_ydif => tmask(:,:,1) 180 183 pe_xdif => e1f(:,:) 181 184 pe_ydif => e2t(:,:) … … 185 188 END SELECT 186 189 ! 187 DO jb = 1, idx%nblenrim(igrd) 190 IF( PRESENT(lrim0) ) THEN 191 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 192 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 193 END IF 194 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 195 END IF 196 ! 197 DO jb = ibeg, iend 188 198 ii = idx%nbi(jb,igrd) 189 199 ij = idx%nbj(jb,igrd) 200 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 190 201 flagu = int( idx%flagu(jb,igrd) ) 191 202 flagv = int( idx%flagv(jb,igrd) ) … … 203 214 ! 204 215 ! Calculate scale factors for calculation of spatial derivatives. 205 zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 )&206 & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1+ij_offset) )207 zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 )&208 & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2+ij_offset) )209 zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) &216 zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & 217 & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1 +ij_offset) ) 218 zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 ) & 219 & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2 +ij_offset) ) 220 zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & 210 221 & + (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) 211 zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1)&212 & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1+ij_offset) )222 zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & 223 & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1 +ij_offset) ) 213 224 ! make sure scale factors are nonzero 214 225 if( zey1 .lt. rsmall ) zey1 = zey2 … … 217 228 zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); 218 229 ! 219 ! Calculate masks for calculation of spatial derivatives. 220 zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2 )&221 & + abs(ijbm1-ijbm2) * pmask_ydif(iibm2 ,ijbm2+ij_offset) )222 zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 )&223 & + (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) )224 zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1)&225 & + (ijbm1jp1-ijbm1) * pmask_ydif(iibm1 ,ijbm1+ij_offset) )230 ! Calculate masks for calculation of spatial derivatives. 231 zmask_x = ( abs(iibm1-iibm2) * zmask_xdif(iibm2 +ii_offset,ijbm2 ) & 232 & + abs(ijbm1-ijbm2) * zmask_ydif(iibm2 ,ijbm2 +ij_offset) ) 233 zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & 234 & + (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) 235 zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1 +ii_offset,ijbm1 ) & 236 & + (ijbm1jp1-ijbm1) * zmask_ydif(iibm1 ,ijbm1 +ij_offset) ) 226 237 227 238 ! Calculation of terms required for both versions of the scheme. … … 231 242 ! Note no rdt factor in expression for zdt because it cancels in the expressions for 232 243 ! zrx and zry. 233 zdt = phia(iibm1,ijbm1) - phib(iibm1,ijbm1)234 zdx = ( ( phia(iibm1,ijbm1) - phia(iibm2,ijbm2) ) / zex2 ) * zmask_x244 zdt = phia(iibm1 ,ijbm1 ) - phib(iibm1 ,ijbm1 ) 245 zdx = ( ( phia(iibm1 ,ijbm1 ) - phia(iibm2 ,ijbm2 ) ) / zex2 ) * zmask_x 235 246 zdy_1 = ( ( phib(iibm1 ,ijbm1 ) - phib(iibm1jm1,ijbm1jm1) ) / zey1 ) * zmask_y1 236 zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1 ,ijbm1 )) / zey2 ) * zmask_y2247 zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1 ,ijbm1 ) ) / zey2 ) * zmask_y2 237 248 zdy_centred = 0.5 * ( zdy_1 + zdy_2 ) 238 249 !!$ zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1) … … 265 276 & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 266 277 end if 267 phia(ii,ij) = phia(ii,ij) * pmask(ii,ij)278 phia(ii,ij) = phia(ii,ij) * zmask(ii,ij) 268 279 END DO 269 280 ! … … 271 282 272 283 273 SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, l l_npo )284 SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) 274 285 !!---------------------------------------------------------------------- 275 286 !! *** SUBROUTINE bdy_orlanski_3d *** … … 287 298 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) 288 299 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: phi_ext ! external forcing data 300 LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 289 301 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 290 302 ! … … 295 307 INTEGER :: ii_offset, ij_offset ! offsets for mask indices 296 308 INTEGER :: flagu, flagv ! short cuts 309 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) 297 310 REAL(wp) :: zmask_x, zmask_y1, zmask_y2 298 311 REAL(wp) :: zex1, zex2, zey, zey1, zey2 … … 301 314 REAL(wp) :: zdy_1, zdy_2, zsign_ups 302 315 REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value 303 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask ! land/sea mask for field304 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask_xdif ! land/sea mask for x-derivatives305 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask_ydif ! land/sea mask for y-derivatives316 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field 317 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_xdif ! land/sea mask for x-derivatives 318 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_ydif ! land/sea mask for y-derivatives 306 319 REAL(wp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives 307 320 REAL(wp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives … … 314 327 SELECT CASE(igrd) 315 328 CASE(1) 316 pmask => tmask(:,:,:)317 pmask_xdif => umask(:,:,:)318 pmask_ydif => vmask(:,:,:)329 zmask => tmask(:,:,:) 330 zmask_xdif => umask(:,:,:) 331 zmask_ydif => vmask(:,:,:) 319 332 pe_xdif => e1u(:,:) 320 333 pe_ydif => e2v(:,:) … … 322 335 ij_offset = 0 323 336 CASE(2) 324 pmask => umask(:,:,:)325 pmask_xdif => tmask(:,:,:)326 pmask_ydif => fmask(:,:,:)337 zmask => umask(:,:,:) 338 zmask_xdif => tmask(:,:,:) 339 zmask_ydif => fmask(:,:,:) 327 340 pe_xdif => e1t(:,:) 328 341 pe_ydif => e2f(:,:) … … 330 343 ij_offset = 0 331 344 CASE(3) 332 pmask => vmask(:,:,:)333 pmask_xdif => fmask(:,:,:)334 pmask_ydif => tmask(:,:,:)345 zmask => vmask(:,:,:) 346 zmask_xdif => fmask(:,:,:) 347 zmask_ydif => tmask(:,:,:) 335 348 pe_xdif => e1f(:,:) 336 349 pe_ydif => e2t(:,:) … … 339 352 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) 340 353 END SELECT 341 354 ! 355 IF( PRESENT(lrim0) ) THEN 356 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 357 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 358 END IF 359 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 360 END IF 361 ! 342 362 DO jk = 1, jpk 343 363 ! 344 DO jb = 1, idx%nblenrim(igrd)364 DO jb = ibeg, iend 345 365 ii = idx%nbi(jb,igrd) 346 366 ij = idx%nbj(jb,igrd) 367 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 347 368 flagu = int( idx%flagu(jb,igrd) ) 348 369 flagv = int( idx%flagv(jb,igrd) ) … … 360 381 ! 361 382 ! Calculate scale factors for calculation of spatial derivatives. 362 zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 )&363 & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1+ij_offset) )364 zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 )&365 & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2+ij_offset) )366 zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) &383 zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & 384 & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1+ij_offset ) ) 385 zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 ) & 386 & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2+ij_offset ) ) 387 zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & 367 388 & + (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) 368 zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1)&369 & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1+ij_offset) )389 zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & 390 & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1+ij_offset ) ) 370 391 ! make sure scale factors are nonzero 371 392 if( zey1 .lt. rsmall ) zey1 = zey2 … … 375 396 ! 376 397 ! Calculate masks for calculation of spatial derivatives. 377 zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2 ,jk)&378 & + abs(ijbm1-ijbm2) * pmask_ydif(iibm2 ,ijbm2+ij_offset,jk) )379 zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ,jk) &380 & + (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset,jk) )381 zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1 ,jk)&382 & + (ijbm1jp1-ijbm1) * pmask_ydif(iibm1 ,ijbm1+ij_offset,jk) )398 zmask_x = ( abs(iibm1-iibm2) * zmask_xdif(iibm2 +ii_offset,ijbm2 ,jk) & 399 & + abs(ijbm1-ijbm2) * zmask_ydif(iibm2 ,ijbm2 +ij_offset,jk) ) 400 zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ,jk) & 401 & + (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset,jk) ) 402 zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1 +ii_offset,ijbm1 ,jk) & 403 & + (ijbm1jp1-ijbm1) * zmask_ydif(iibm1 ,ijbm1 +ij_offset,jk) ) 383 404 ! 384 405 ! Calculate normal (zrx) and tangential (zry) components of radiation velocities. … … 386 407 ! Centred derivative is calculated as average of "left" and "right" derivatives for 387 408 ! this reason. 388 zdt = phia(iibm1,ijbm1,jk) - phib(iibm1,ijbm1,jk)389 zdx = ( ( phia(iibm1,ijbm1,jk) - phia(iibm2,ijbm2,jk) ) / zex2 ) * zmask_x409 zdt = phia(iibm1 ,ijbm1 ,jk) - phib(iibm1 ,ijbm1 ,jk) 410 zdx = ( ( phia(iibm1 ,ijbm1 ,jk) - phia(iibm2 ,ijbm2 ,jk) ) / zex2 ) * zmask_x 390 411 zdy_1 = ( ( phib(iibm1 ,ijbm1 ,jk) - phib(iibm1jm1,ijbm1jm1,jk) ) / zey1 ) * zmask_y1 391 412 zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1 ,ijbm1 ,jk) ) / zey2 ) * zmask_y2 … … 421 442 & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 422 443 end if 423 phia(ii,ij,jk) = phia(ii,ij,jk) * pmask(ii,ij,jk)444 phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk) 424 445 END DO 425 446 ! … … 428 449 END SUBROUTINE bdy_orlanski_3d 429 450 430 SUBROUTINE bdy_nmn( idx, igrd, phia )451 SUBROUTINE bdy_nmn( idx, igrd, phia, lrim0 ) 431 452 !!---------------------------------------------------------------------- 432 453 !! *** SUBROUTINE bdy_nmn *** … … 434 455 !! ** Purpose : Duplicate the value at open boundaries, zero gradient. 435 456 !! 436 !!---------------------------------------------------------------------- 437 INTEGER, INTENT(in) :: igrd ! grid index 438 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) 439 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 457 !! 458 !! ** Method : - take the average of free ocean neighbours 459 !! 460 !! ___ ! |_____| ! ___| ! __|x o ! |_ _| ! | 461 !! __|x ! x ! x o ! o ! |_| ! |x o 462 !! o ! o ! o ! ! o x o ! |x_x_ 463 !! ! o 464 !!---------------------------------------------------------------------- 465 INTEGER, INTENT(in ) :: igrd ! grid index 466 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked 467 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 468 LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 440 469 !! 441 REAL(wp) :: zcoef, zcoef1, zcoef2 442 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask ! land/sea mask for field 443 REAL(wp), POINTER, DIMENSION(:,:) :: bdypmask ! land/sea mask for field 470 REAL(wp) :: zweight 471 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field 444 472 INTEGER :: ib, ik ! dummy loop indices 445 INTEGER :: ii, ij, ip, jp ! 2D addresses 446 !!---------------------------------------------------------------------- 473 INTEGER :: ii, ij ! 2D addresses 474 INTEGER :: ipkm1 ! size of phia third dimension minus 1 475 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) 476 INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3, itreat 477 !!---------------------------------------------------------------------- 478 ! 479 ipkm1 = MAX( SIZE(phia,3) - 1, 1 ) 447 480 ! 448 481 SELECT CASE(igrd) 449 CASE(1) 450 pmask => tmask(:,:,:) 451 bdypmask => bdytmask(:,:) 452 CASE(2) 453 pmask => umask(:,:,:) 454 bdypmask => bdyumask(:,:) 455 CASE(3) 456 pmask => vmask(:,:,:) 457 bdypmask => bdyvmask(:,:) 482 CASE(1) ; zmask => tmask(:,:,:) 483 CASE(2) ; zmask => umask(:,:,:) 484 CASE(3) ; zmask => vmask(:,:,:) 458 485 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_nmn' ) 459 486 END SELECT 460 DO ib = 1, idx%nblenrim(igrd) 487 ! 488 IF( PRESENT(lrim0) ) THEN 489 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 490 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 491 END IF 492 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 493 END IF 494 ! 495 DO ib = ibeg, iend 461 496 ii = idx%nbi(ib,igrd) 462 497 ij = idx%nbj(ib,igrd) 463 DO ik = 1, jpkm1 464 ! search the sense of the gradient 465 zcoef1 = bdypmask(ii-1,ij )*pmask(ii-1,ij,ik) + bdypmask(ii+1,ij )*pmask(ii+1,ij,ik) 466 zcoef2 = bdypmask(ii ,ij-1)*pmask(ii,ij-1,ik) + bdypmask(ii ,ij+1)*pmask(ii,ij+1,ik) 467 IF ( nint(zcoef1+zcoef2) == 0) THEN 468 ! corner **** we probably only want to set the tangentail component for the dynamics here 469 zcoef = pmask(ii-1,ij,ik) + pmask(ii+1,ij,ik) + pmask(ii,ij-1,ik) + pmask(ii,ij+1,ik) 470 IF (zcoef > .5_wp) THEN ! Only set none isolated points. 471 phia(ii,ij,ik) = phia(ii-1,ij ,ik) * pmask(ii-1,ij ,ik) + & 472 & phia(ii+1,ij ,ik) * pmask(ii+1,ij ,ik) + & 473 & phia(ii ,ij-1,ik) * pmask(ii ,ij-1,ik) + & 474 & phia(ii ,ij+1,ik) * pmask(ii ,ij+1,ik) 475 phia(ii,ij,ik) = ( phia(ii,ij,ik) / zcoef ) * pmask(ii,ij,ik) 476 ELSE 477 phia(ii,ij,ik) = phia(ii,ij ,ik) * pmask(ii,ij ,ik) 478 ENDIF 479 ELSEIF ( nint(zcoef1+zcoef2) == 2) THEN 480 ! oblique corner **** we probably only want to set the normal component for the dynamics here 481 zcoef = pmask(ii-1,ij,ik)*bdypmask(ii-1,ij ) + pmask(ii+1,ij,ik)*bdypmask(ii+1,ij ) + & 482 & pmask(ii,ij-1,ik)*bdypmask(ii,ij -1 ) + pmask(ii,ij+1,ik)*bdypmask(ii,ij+1 ) 483 phia(ii,ij,ik) = phia(ii-1,ij ,ik) * pmask(ii-1,ij ,ik)*bdypmask(ii-1,ij ) + & 484 & phia(ii+1,ij ,ik) * pmask(ii+1,ij ,ik)*bdypmask(ii+1,ij ) + & 485 & phia(ii ,ij-1,ik) * pmask(ii ,ij-1,ik)*bdypmask(ii,ij -1 ) + & 486 & phia(ii ,ij+1,ik) * pmask(ii ,ij+1,ik)*bdypmask(ii,ij+1 ) 487 488 phia(ii,ij,ik) = ( phia(ii,ij,ik) / MAX(1._wp, zcoef) ) * pmask(ii,ij,ik) 489 ELSE 490 ip = nint(bdypmask(ii+1,ij )*pmask(ii+1,ij,ik) - bdypmask(ii-1,ij )*pmask(ii-1,ij,ik)) 491 jp = nint(bdypmask(ii ,ij+1)*pmask(ii,ij+1,ik) - bdypmask(ii ,ij-1)*pmask(ii,ij-1,ik)) 492 phia(ii,ij,ik) = phia(ii+ip,ij+jp,ik) * pmask(ii+ip,ij+jp,ik) 493 ENDIF 494 END DO 498 itreat = idx%ntreat(ib,igrd) 499 CALL find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) ! find free ocean neighbours 500 SELECT CASE( itreat ) 501 CASE( 1:8 ) 502 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE 503 DO ik = 1, ipkm1 504 IF( zmask(ii1,ij1,ik) /= 0. ) phia(ii,ij,ik) = phia(ii1,ij1,ik) 505 END DO 506 CASE( 9:12 ) 507 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE 508 IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE 509 DO ik = 1, ipkm1 510 zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) 511 IF( zweight /= 0. ) phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) ) / zweight 512 END DO 513 CASE( 13:16 ) 514 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE 515 IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE 516 IF( ii3 < 1 .OR. ii3 > jpi .OR. ij3 < 1 .OR. ij3 > jpj ) CYCLE 517 DO ik = 1, ipkm1 518 zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) + zmask(ii3,ij3,ik) 519 IF( zweight /= 0. ) phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) + phia(ii3,ij3,ik) ) / zweight 520 END DO 521 END SELECT 495 522 END DO 496 523 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdytides.F90
r12059 r12065 71 71 INTEGER :: inum, igrd 72 72 INTEGER, DIMENSION(3) :: ilen0 !: length of boundary data (from OBC arrays) 73 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts74 73 INTEGER :: ios ! Local integer output status for namelist read 75 74 CHARACTER(len=80) :: clfile !: full file name for tidal input file … … 78 77 !! 79 78 TYPE(TIDES_DATA), POINTER :: td !: local short cut 80 TYPE(MAP_POINTER), DIMENSION(jpbgrd) :: ibmap_ptr !: array of pointers to nbmap81 79 !! 82 80 NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta 83 81 !!---------------------------------------------------------------------- 84 82 ! 85 IF (nb_bdy>0) THEN 86 IF(lwp) WRITE(numout,*) 87 IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' 88 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 89 ENDIF 83 IF(lwp) WRITE(numout,*) 84 IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' 85 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 90 86 91 87 REWIND(numnam_cfg) … … 95 91 ! 96 92 td => tides(ib_bdy) 97 nblen => idx_bdy(ib_bdy)%nblen98 nblenrim => idx_bdy(ib_bdy)%nblenrim99 93 100 94 ! Namelist nambdy_tide : tidal harmonic forcing at open boundaries 101 95 filtide(:) = '' 102 96 97 REWIND( numnam_ref ) 98 READ ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901) 99 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_tide in reference namelist' ) 103 100 ! Don't REWIND here - may need to read more than one of these namelists. 104 READ ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901)105 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_tide in reference namelist', lwp )106 101 READ ( numnam_cfg, nambdy_tide, IOSTAT = ios, ERR = 902 ) 107 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist' , lwp)102 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist' ) 108 103 IF(lwm) WRITE ( numond, nambdy_tide ) 109 104 ! ! Parameter control and print … … 125 120 ! JC: If FRS scheme is used, we assume that tidal is needed over the whole 126 121 ! relaxation area 127 IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN ; ilen0(:) = nblen (:)128 ELSE ; ilen0(:) = nblenrim(:)122 IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN ; ilen0(:) = idx_bdy(ib_bdy)%nblen (:) 123 ELSE ; ilen0(:) = idx_bdy(ib_bdy)%nblenrim(:) 129 124 ENDIF 130 125 … … 161 156 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 162 157 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 158 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove? 163 159 td%ssh0(ib,itide,1) = ztr(ii,ij) 164 160 td%ssh0(ib,itide,2) = zti(ii,ij) … … 177 173 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 178 174 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 175 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove? 179 176 td%u0(ib,itide,1) = ztr(ii,ij) 180 177 td%u0(ib,itide,2) = zti(ii,ij) … … 193 190 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 194 191 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 192 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove? 195 193 td%v0(ib,itide,1) = ztr(ii,ij) 196 194 td%v0(ib,itide,2) = zti(ii,ij) … … 207 205 ALLOCATE( dta_read( MAXVAL(ilen0(1:3)), 1, 1 ) ) 208 206 ! 209 ! Set map structure210 ibmap_ptr(1)%ptr => idx_bdy(ib_bdy)%nbmap(:,1) ; ibmap_ptr(1)%ll_unstruc = ln_coords_file(ib_bdy)211 ibmap_ptr(2)%ptr => idx_bdy(ib_bdy)%nbmap(:,2) ; ibmap_ptr(2)%ll_unstruc = ln_coords_file(ib_bdy)212 ibmap_ptr(3)%ptr => idx_bdy(ib_bdy)%nbmap(:,3) ; ibmap_ptr(3)%ll_unstruc = ln_coords_file(ib_bdy)213 214 207 ! Open files and read in tidal forcing data 215 208 ! ----------------------------------------- … … 219 212 clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_T.nc' 220 213 CALL iom_open( clfile, inum ) 221 CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, ibmap_ptr(1) )214 CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 222 215 td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1) 223 CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, ibmap_ptr(1) )216 CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 224 217 td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1) 225 218 CALL iom_close( inum ) … … 227 220 clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_U.nc' 228 221 CALL iom_open( clfile, inum ) 229 CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, i bmap_ptr(2) )222 CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 230 223 td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1) 231 CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, i bmap_ptr(2) )224 CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 232 225 td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1) 233 226 CALL iom_close( inum ) … … 235 228 clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_V.nc' 236 229 CALL iom_open( clfile, inum ) 237 CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, i bmap_ptr(3) )230 CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 238 231 td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1) 239 CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, i bmap_ptr(3) )232 CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 240 233 td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1) 241 234 CALL iom_close( inum ) … … 263 256 264 257 265 SUBROUTINE bdytide_update( kt, idx, dta, td, jit, time_offset )258 SUBROUTINE bdytide_update( kt, idx, dta, td, kit, kt_offset ) 266 259 !!---------------------------------------------------------------------- 267 260 !! *** SUBROUTINE bdytide_update *** … … 274 267 TYPE(OBC_DATA) , INTENT(inout) :: dta ! OBC external data 275 268 TYPE(TIDES_DATA) , INTENT(inout) :: td ! tidal harmonics data 276 INTEGER, OPTIONAL, INTENT(in ) :: jit ! Barotropic timestep counter (for timesplitting option)277 INTEGER, OPTIONAL, INTENT(in ) :: time_offset ! time offset in units of timesteps. NB. if jit269 INTEGER, OPTIONAL, INTENT(in ) :: kit ! Barotropic timestep counter (for timesplitting option) 270 INTEGER, OPTIONAL, INTENT(in ) :: kt_offset ! time offset in units of timesteps. NB. if kit 278 271 ! ! is present then units = subcycle timesteps. 279 ! ! time_offset = 0 => get data at "now" time level280 ! ! time_offset = -1 => get data at "before" time level281 ! ! time_offset = +1 => get data at "after" time level272 ! ! kt_offset = 0 => get data at "now" time level 273 ! ! kt_offset = -1 => get data at "before" time level 274 ! ! kt_offset = +1 => get data at "after" time level 282 275 ! ! etc. 283 276 ! … … 294 287 295 288 zflag=1 296 IF ( PRESENT( jit) ) THEN297 IF ( jit /= 1 ) zflag=0289 IF ( PRESENT(kit) ) THEN 290 IF ( kit /= 1 ) zflag=0 298 291 ENDIF 299 292 … … 314 307 315 308 time_add = 0 316 IF( PRESENT( time_offset) ) THEN317 time_add = time_offset309 IF( PRESENT(kt_offset) ) THEN 310 time_add = kt_offset 318 311 ENDIF 319 312 320 IF( PRESENT( jit) ) THEN321 z_arg = ((kt-kt_tide) * rdt + ( jit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) )313 IF( PRESENT(kit) ) THEN 314 z_arg = ((kt-kt_tide) * rdt + (kit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) ) 322 315 ELSE 323 316 z_arg = ((kt-kt_tide)+time_add) * rdt … … 352 345 353 346 354 SUBROUTINE bdy_dta_tides( kt, kit, time_offset )347 SUBROUTINE bdy_dta_tides( kt, kit, kt_offset ) 355 348 !!---------------------------------------------------------------------- 356 349 !! *** SUBROUTINE bdy_dta_tides *** … … 361 354 INTEGER, INTENT(in) :: kt ! Main timestep counter 362 355 INTEGER, OPTIONAL, INTENT(in) :: kit ! Barotropic timestep counter (for timesplitting option) 363 INTEGER, OPTIONAL, INTENT(in) :: time_offset! time offset in units of timesteps. NB. if kit356 INTEGER, OPTIONAL, INTENT(in) :: kt_offset ! time offset in units of timesteps. NB. if kit 364 357 ! ! is present then units = subcycle timesteps. 365 ! ! time_offset = 0 => get data at "now" time level366 ! ! time_offset = -1 => get data at "before" time level367 ! ! time_offset = +1 => get data at "after" time level358 ! ! kt_offset = 0 => get data at "now" time level 359 ! ! kt_offset = -1 => get data at "before" time level 360 ! ! kt_offset = +1 => get data at "after" time level 368 361 ! ! etc. 369 362 ! … … 380 373 381 374 time_add = 0 382 IF( PRESENT( time_offset) ) THEN383 time_add = time_offset375 IF( PRESENT(kt_offset) ) THEN 376 time_add = kt_offset 384 377 ENDIF 385 378 … … 426 419 ! If time splitting, initialize arrays from slow varying open boundary data: 427 420 IF ( PRESENT(kit) ) THEN 428 IF ( dta_bdy(ib_bdy)%l l_ssh) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1))429 IF ( dta_bdy(ib_bdy)%l l_u2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2))430 IF ( dta_bdy(ib_bdy)%l l_v2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3))421 IF ( dta_bdy(ib_bdy)%lneed_ssh ) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) 422 IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) 423 IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) 431 424 ENDIF 432 425 ! … … 438 431 z_sist = zramp * SIN( z_sarg ) 439 432 ! 440 IF ( dta_bdy(ib_bdy)%l l_ssh ) THEN433 IF ( dta_bdy(ib_bdy)%lneed_ssh ) THEN 441 434 igrd=1 ! SSH on tracer grid 442 435 DO ib = 1, ilen0(igrd) … … 447 440 ENDIF 448 441 ! 449 IF ( dta_bdy(ib_bdy)%l l_u2d ) THEN442 IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) THEN 450 443 igrd=2 ! U grid 451 444 DO ib = 1, ilen0(igrd) … … 454 447 & tides(ib_bdy)%u(ib,itide,2)*z_sist ) 455 448 END DO 456 ENDIF457 !458 IF ( dta_bdy(ib_bdy)%ll_v2d ) THEN459 449 igrd=3 ! V grid 460 450 DO ib = 1, ilen0(igrd) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdytra.F90
r10529 r12065 49 49 INTEGER, INTENT(in) :: kt ! Main time step counter 50 50 ! 51 INTEGER :: ib_bdy, jn, igrd ! Loop indeces 52 TYPE(ztrabdy), DIMENSION(jpts) :: zdta ! Temporary data structure 51 INTEGER :: ib_bdy, jn, igrd, ir ! Loop indeces 52 TYPE(ztrabdy), DIMENSION(jpts) :: zdta ! Temporary data structure 53 LOGICAL :: llrim0 ! indicate if rim 0 is treated 54 LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out 53 55 !!---------------------------------------------------------------------- 54 56 igrd = 1 55 56 DO ib_bdy=1, nb_bdy 57 llsend1(:) = .false. ; llrecv1(:) = .false. 58 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 59 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 60 ELSE ; llrim0 = .FALSE. 61 END IF 62 DO ib_bdy=1, nb_bdy 63 ! 64 zdta(1)%tra => dta_bdy(ib_bdy)%tem 65 zdta(2)%tra => dta_bdy(ib_bdy)%sal 66 ! 67 DO jn = 1, jpts 68 ! 69 SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 70 CASE('none' ) ; CYCLE 71 CASE('frs' ) ! treat the whole boundary at once 72 IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 73 CASE('specified' ) ! treat the whole rim at once 74 IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 75 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , tsa(:,:,:,jn), llrim0 ) ! tsa masked 76 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & 77 & zdta(jn)%tra, llrim0, ll_npo=.false. ) 78 CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & 79 & zdta(jn)%tra, llrim0, ll_npo=.true. ) 80 CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), tsa(:,:,:,jn), jn, llrim0 ) 81 CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 82 END SELECT 83 ! 84 END DO 85 END DO 57 86 ! 58 zdta(1)%tra => dta_bdy(ib_bdy)%tem 59 zdta(2)%tra => dta_bdy(ib_bdy)%sal 87 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 88 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF 89 DO ib_bdy=1, nb_bdy 90 SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 91 CASE('neumann','runoff') 92 llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 93 llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 94 CASE('orlanski', 'orlanski_npo') 95 llsend1(:) = llsend1(:) .OR. lsend_bdy(ib_bdy,1,:,ir) ! possibly every direction, T points 96 llrecv1(:) = llrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:,ir) ! possibly every direction, T points 97 END SELECT 98 END DO 99 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 100 CALL lbc_lnk( 'bdytra', tsa, 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 101 END IF 60 102 ! 61 DO jn = 1, jpts 62 ! 63 SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 64 CASE('none' ) ; CYCLE 65 CASE('frs' ) ; CALL bdy_frs ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 66 CASE('specified' ) ; CALL bdy_spe ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 67 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , tsa(:,:,:,jn) ) 68 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), zdta(jn)%tra, ll_npo=.false. ) 69 CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), zdta(jn)%tra, ll_npo=.true. ) 70 CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), tsa(:,:,:,jn), jn ) 71 CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 72 END SELECT 73 ! Boundary points should be updated 74 CALL lbc_bdy_lnk( 'bdytra', tsa(:,:,:,jn), 'T', 1., ib_bdy ) 75 ! 76 END DO 77 END DO 103 END DO ! ir 78 104 ! 79 105 END SUBROUTINE bdy_tra 80 106 81 107 82 SUBROUTINE bdy_rnf( idx, pta, jpa )108 SUBROUTINE bdy_rnf( idx, pta, jpa, llrim0 ) 83 109 !!---------------------------------------------------------------------- 84 110 !! *** SUBROUTINE bdy_rnf *** … … 89 115 !! 90 116 !!---------------------------------------------------------------------- 91 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 92 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend 93 INTEGER, INTENT(in) :: jpa ! TRA index 117 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 118 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend 119 INTEGER, INTENT(in) :: jpa ! TRA index 120 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 94 121 ! 95 REAL(wp) :: zwgt ! boundary weight 96 INTEGER :: ib, ik, igrd ! dummy loop indices 97 INTEGER :: ii, ij, ip, jp ! 2D addresses 122 INTEGER :: ib, ii, ij, igrd ! dummy loop indices 123 INTEGER :: ik, ip, jp ! 2D addresses 98 124 !!---------------------------------------------------------------------- 99 125 ! 100 126 igrd = 1 ! Everything is at T-points here 101 DO ib = 1, idx%nblenrim(igrd)102 ii = idx%nbi(ib,igrd)103 ij = idx%nbj(ib,igrd)104 DO ik = 1, jpkm1105 ip = bdytmask(ii+1,ij ) - bdytmask(ii-1,ij )106 jp = bdytmask(ii ,ij+1) - bdytmask(ii ,ij-1)107 i f (jpa == jp_tem) pta(ii,ij,ik) = pta(ii+ip,ij+jp,ik) * tmask(ii,ij,ik)108 if (jpa == jp_sal) pta(ii,ij,ik) = 0.1 * tmask(ii,ij,ik)127 IF( jpa == jp_tem ) THEN 128 CALL bdy_nmn( idx, igrd, pta, llrim0 ) 129 ELSE IF( jpa == jp_sal ) THEN 130 IF( .NOT. llrim0 ) RETURN 131 DO ib = 1, idx%nblenrim(igrd) ! if llrim0 then treat the whole rim 132 ii = idx%nbi(ib,igrd) 133 ij = idx%nbj(ib,igrd) 134 pta(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) 109 135 END DO 110 END DO136 END IF 111 137 ! 112 138 END SUBROUTINE bdy_rnf -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/BDY/bdyvol.F90
r10481 r12065 99 99 ii = idx%nbi(jb,jgrd) 100 100 ij = idx%nbj(jb,jgrd) 101 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice 101 102 zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) 102 103 END DO … … 105 106 ii = idx%nbi(jb,jgrd) 106 107 ij = idx%nbj(jb,jgrd) 108 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice 107 109 zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) 108 110 END DO … … 126 128 ii = idx%nbi(jb,jgrd) 127 129 ij = idx%nbj(jb,jgrd) 130 !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ? 128 131 pua2d(ii,ij) = pua2d(ii,ij) - idx%flagu(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii+1,ij) 129 132 END DO … … 132 135 ii = idx%nbi(jb,jgrd) 133 136 ij = idx%nbj(jb,jgrd) 137 !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ? 134 138 pva2d(ii,ij) = pva2d(ii,ij) - idx%flagv(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii,ij+1) 135 139 END DO … … 139 143 ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected 140 144 ! ------------------------------------------------------ 141 IF( MOD( kt, n write ) == 0 .AND. ( kc == 1 ) ) THEN145 IF( MOD( kt, nn_write ) == 0 .AND. ( kc == 1 ) ) THEN 142 146 ! 143 147 ! compute residual transport across boundary … … 150 154 ii = idx%nbi(jb,jgrd) 151 155 ij = idx%nbj(jb,jgrd) 156 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 152 157 ztranst = ztranst + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) 153 158 END DO … … 156 161 ii = idx%nbi(jb,jgrd) 157 162 ij = idx%nbj(jb,jgrd) 163 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 158 164 ztranst = ztranst + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) 159 165 END DO … … 195 201 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 196 202 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 203 IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj ) CYCLE 197 204 zflagu => idx_bdy(ib_bdy)%flagu(ib,igrd) 198 205 bdy_segs_surf = bdy_segs_surf + phu(nbi, nbj) & … … 207 214 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 208 215 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 216 IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj ) CYCLE 209 217 zflagv => idx_bdy(ib_bdy)%flagv(ib,igrd) 210 218 bdy_segs_surf = bdy_segs_surf + phv(nbi, nbj) & -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/C1D/c1d.F90
r10068 r12065 52 52 REWIND( numnam_ref ) ! Namelist namc1d in reference namelist : Tracer advection scheme 53 53 READ ( numnam_ref, namc1d, IOSTAT = ios, ERR = 901) 54 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d in reference namelist' , lwp)54 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d in reference namelist' ) 55 55 ! 56 56 REWIND( numnam_cfg ) ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 57 57 READ ( numnam_cfg, namc1d, IOSTAT = ios, ERR = 902 ) 58 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d in configuration namelist' , lwp)58 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d in configuration namelist' ) 59 59 IF(lwm) WRITE ( numond, namc1d ) 60 60 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/C1D/dtauvd.F90
r10068 r12065 62 62 REWIND( numnam_ref ) ! Namelist namc1d_uvd in reference namelist : 63 63 READ ( numnam_ref, namc1d_uvd, IOSTAT = ios, ERR = 901) 64 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist' , lwp)64 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist' ) 65 65 ! 66 66 REWIND( numnam_cfg ) ! Namelist namc1d_uvd in configuration namelist : Parameters of the run 67 67 READ ( numnam_cfg, namc1d_uvd, IOSTAT = ios, ERR = 902 ) 68 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist' , lwp)68 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist' ) 69 69 IF(lwm) WRITE ( numond, namc1d_uvd ) 70 70 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/C1D/dyndmp.F90
r10425 r12065 81 81 REWIND( numnam_ref ) ! Namelist namc1d_dyndmp in reference namelist : 82 82 READ ( numnam_ref, namc1d_dyndmp, IOSTAT = ios, ERR = 901) 83 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist' , lwp)83 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist' ) 84 84 REWIND( numnam_cfg ) ! Namelist namc1d_dyndmp in configuration namelist : Parameters of the run 85 85 READ ( numnam_cfg, namc1d_dyndmp, IOSTAT = ios, ERR = 902 ) 86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist' , lwp)86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist' ) 87 87 IF(lwm) WRITE ( numond, namc1d_dyndmp ) 88 88 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/CRS/README.rst
r10279 r12065 2 2 On line biogeochemistry coarsening 3 3 ********************************** 4 5 .. todo:: 6 7 4 8 5 9 .. contents:: … … 63 67 ! 1, MAX of KZ 64 68 ! 2, MIN of KZ 65 ! 3, 10^(MEAN(LOG(KZ)) 66 ! 4, MEDIANE of KZ 69 ! 3, 10^(MEAN(LOG(KZ)) 70 ! 4, MEDIANE of KZ 67 71 ln_crs_wn = .false. ! wn coarsened (T) or computed using horizontal divergence ( F ) 68 72 ! ! … … 73 77 the north-fold lateral boundary condition (ORCA025, ORCA12, ORCA36, ...). 74 78 - ``nn_msh_crs = 1`` will activate the generation of the coarsened grid meshmask. 75 - ``nn_crs_kz`` is the operator to coarsen the vertical mixing coefficient. 79 - ``nn_crs_kz`` is the operator to coarsen the vertical mixing coefficient. 76 80 - ``ln_crs_wn`` 77 81 … … 80 84 - when ``key_vvl`` is not activated, 81 85 82 - coarsened vertical velocities are computed using horizontal divergence (``ln_crs_wn = .false.``) 86 - coarsened vertical velocities are computed using horizontal divergence (``ln_crs_wn = .false.``) 83 87 - or coarsened vertical velocities are computed with an average operator (``ln_crs_wn = .true.``) 84 88 - ``ln_crs_top = .true.``: should be activated to run BCG model in coarsened space; … … 97 101 98 102 In the [attachment:iodef.xml iodef.xml] file, a "nemo" context is defined and 99 some variable defined in [attachment:file_def.xml file_def.xml] are writted on the ocean-dynamic grid. 103 some variable defined in [attachment:file_def.xml file_def.xml] are writted on the ocean-dynamic grid. 100 104 To write variables on the coarsened grid, and in particular the passive tracers, 101 105 a "nemo_crs" context should be defined in [attachment:iodef.xml iodef.xml] and … … 111 115 interpolated `on-the-fly <http://forge.ipsl.jussieu.fr/nemo/wiki/Users/SetupNewConfiguration/Weight-creator>`_. 112 116 Example of namelist for PISCES : 113 117 114 118 .. code-block:: fortran 115 119 … … 134 138 rn_trfac(14) = 1.0e-06 ! - - - - 135 139 rn_trfac(23) = 7.6e-06 ! - - - - 136 140 137 141 cn_dir = './' ! root directory for the location of the data files 138 142 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/CRS/crsdom.F90
r10068 r12065 296 296 ENDDO 297 297 298 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, p val=1.0 )299 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, p val=1.0 )298 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pfillval=1.0 ) 299 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pfillval=1.0 ) 300 300 301 301 END SUBROUTINE crs_dom_hgr … … 579 579 ENDDO 580 580 CASE DEFAULT 581 STOP581 CALL ctl_stop( 'STOP', 'error from crs_dom_ope_3d, you should not be there...' ) 582 582 END SELECT 583 583 … … 1748 1748 ENDDO 1749 1749 1750 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, p val=1.0 )1751 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, p val=1.0 )1750 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pfillval=1.0 ) 1751 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pfillval=1.0 ) 1752 1752 ! 1753 1753 ! … … 1857 1857 ENDDO 1858 1858 1859 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, p val=1.0 )1860 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, p val=1.0 )1859 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, pfillval=1.0 ) 1860 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pfillval=1.0 ) 1861 1861 1862 1862 END SUBROUTINE crs_dom_sfc … … 1947 1947 1948 1948 CASE DEFAULT 1949 STOP1949 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) 1950 1950 END SELECT 1951 1951 IF( nlcjt_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1 … … 1996 1996 1997 1997 CASE DEFAULT 1998 STOP1998 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) 1999 1999 END SELECT 2000 2000 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/CRS/crsini.F90
r10068 r12065 82 82 REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run 83 83 READ ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) 84 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist' , lwp)84 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist' ) 85 85 REWIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run 86 86 READ ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) 87 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist' , lwp)87 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist' ) 88 88 IF(lwm) WRITE ( numond, namcrs ) 89 89 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/CRS/crslbclnk.F90
r10425 r12065 27 27 CONTAINS 28 28 29 SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, cd_mpp, pval)29 SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, kfillmode, pfillval ) 30 30 !!--------------------------------------------------------------------- 31 31 !! *** SUBROUTINE crs_lbc_lnk *** … … 40 40 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 41 41 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied 42 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! valeur sur les halo43 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! MPP only (here do nothing)42 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = cst) 43 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 44 44 ! 45 45 LOGICAL :: ll_grid_crs 46 REAL(wp) :: zval ! valeur sur les halo47 46 !!---------------------------------------------------------------------- 48 47 ! 49 48 ll_grid_crs = ( jpi == jpi_crs ) 50 49 ! 51 IF( PRESENT(pval) ) THEN ; zval = pval52 ELSE ; zval = 0._wp53 ENDIF54 !55 50 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 56 51 ! 57 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, cd_mpp, pval=zval ) 58 ELSE ; CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn , pval=zval ) 59 ENDIF 52 CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode, pfillval ) 60 53 ! 61 54 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain … … 64 57 65 58 66 SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval)59 SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, kfillmode, pfillval ) 67 60 !!--------------------------------------------------------------------- 68 61 !! *** SUBROUTINE crs_lbc_lnk *** … … 77 70 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 78 71 REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 79 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! valeur sur les halo80 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! MPP only (here do nothing)72 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 73 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 81 74 ! 82 75 LOGICAL :: ll_grid_crs 83 REAL(wp) :: zval ! valeur sur les halo84 76 !!---------------------------------------------------------------------- 85 77 ! 86 78 ll_grid_crs = ( jpi == jpi_crs ) 87 79 ! 88 IF( PRESENT(pval) ) THEN ; zval = pval89 ELSE ; zval = 0._wp90 ENDIF91 !92 80 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 93 81 ! 94 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, cd_mpp, pval=zval ) 95 ELSE ; CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn , pval=zval ) 96 ENDIF 82 CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode, pfillval ) 97 83 ! 98 84 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIA/dia25h.F90
r10641 r12065 55 55 REWIND ( numnam_ref ) ! Read Namelist nam_dia25h in reference namelist : 25hour mean diagnostics 56 56 READ ( numnam_ref, nam_dia25h, IOSTAT=ios, ERR= 901 ) 57 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' , lwp)57 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' ) 58 58 REWIND( numnam_cfg ) ! Namelist nam_dia25h in configuration namelist 25hour diagnostics 59 59 READ ( numnam_cfg, nam_dia25h, IOSTAT = ios, ERR = 902 ) 60 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist' , lwp)60 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist' ) 61 61 IF(lwm) WRITE ( numond, nam_dia25h ) 62 62 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIA/diacfl.F90
r10425 r12065 17 17 USE lbclnk ! ocean lateral boundary condition (or mpp link) 18 18 USE in_out_manager ! I/O manager 19 USE iom ! 19 20 USE timing ! Performance output 20 21 … … 27 28 INTEGER, DIMENSION(3) :: nCu_loc, nCv_loc, nCw_loc ! U, V, and W run max locations in the global domain 28 29 REAL(wp) :: rCu_max, rCv_max, rCw_max ! associated run max Courant number 29 30 !!gm CAUTION: need to declare these arrays here, otherwise the calculation fails in multi-proc !31 !!gm I don't understand why.32 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace33 !!gm end34 30 35 31 PUBLIC dia_cfl ! routine called by step.F90 … … 54 50 INTEGER, INTENT(in) :: kt ! ocean time-step index 55 51 ! 56 INTEGER :: ji, jj, jk! dummy loop indices57 REAL(wp) :: z2dt, zCu_max, zCv_max, zCw_max! local scalars58 INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc! workspace59 !!gm this does not work REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl! workspace52 INTEGER :: ji, jj, jk ! dummy loop indices 53 REAL(wp) :: z2dt, zCu_max, zCv_max, zCw_max ! local scalars 54 INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace 55 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace 60 56 !!---------------------------------------------------------------------- 61 57 ! … … 70 66 DO jk = 1, jpk ! calculate Courant numbers 71 67 DO jj = 1, jpj 72 DO ji = 1, fs_jpim1 ! vector opt.68 DO ji = 1, jpi 73 69 zCu_cfl(ji,jj,jk) = ABS( un(ji,jj,jk) ) * z2dt / e1u (ji,jj) ! for i-direction 74 70 zCv_cfl(ji,jj,jk) = ABS( vn(ji,jj,jk) ) * z2dt / e2v (ji,jj) ! for j-direction … … 78 74 END DO 79 75 ! 76 ! write outputs 77 IF( iom_use('cfl_cu') ) CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, dim=3 ) ) 78 IF( iom_use('cfl_cv') ) CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, dim=3 ) ) 79 IF( iom_use('cfl_cw') ) CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, dim=3 ) ) 80 80 81 ! ! calculate maximum values and locations 81 82 IF( lk_mpp ) THEN … … 105 106 ! ! write out to file 106 107 IF( lwp ) THEN 107 WRITE(numcfl,FMT='(2x,i 4,5x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3)108 WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 108 109 WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) 109 110 WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cw', zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) … … 166 167 rCw_max = 0._wp 167 168 ! 168 !!gm required to work169 ALLOCATE ( zCu_cfl(jpi,jpj,jpk), zCv_cfl(jpi,jpj,jpk), zCw_cfl(jpi,jpj,jpk) )170 !!gm end171 !172 169 END SUBROUTINE dia_cfl_init 173 170 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIA/diadct.F90
r10425 r12065 11 11 !! 3.4 ! 09/2011 (C Bricaud) 12 12 !!---------------------------------------------------------------------- 13 #if defined key_diadct 14 !!---------------------------------------------------------------------- 15 !! 'key_diadct' : 16 !!---------------------------------------------------------------------- 13 !! does not work with agrif 14 #if ! defined key_agrif 17 15 !!---------------------------------------------------------------------- 18 16 !! dia_dct : Compute the transport through a sec. … … 42 40 43 41 PUBLIC dia_dct ! routine called by step.F90 44 PUBLIC dia_dct_init ! routine called by opa.F90 45 PUBLIC diadct_alloc ! routine called by nemo_init in nemogcm.F90 46 PRIVATE readsec 47 PRIVATE removepoints 48 PRIVATE transport 49 PRIVATE dia_dct_wri 50 51 LOGICAL, PUBLIC, PARAMETER :: lk_diadct = .TRUE. !: model-data diagnostics flag 52 53 INTEGER :: nn_dct ! Frequency of computation 54 INTEGER :: nn_dctwri ! Frequency of output 55 INTEGER :: nn_secdebug ! Number of the section to debug 42 PUBLIC dia_dct_init ! routine called by nemogcm.F90 43 44 ! !!** namelist variables ** 45 LOGICAL, PUBLIC :: ln_diadct !: Calculate transport thru a section or not 46 INTEGER :: nn_dct ! Frequency of computation 47 INTEGER :: nn_dctwri ! Frequency of output 48 INTEGER :: nn_secdebug ! Number of the section to debug 56 49 57 50 INTEGER, PARAMETER :: nb_class_max = 10 … … 104 97 CONTAINS 105 98 106 INTEGER FUNCTION diadct_alloc() 107 !!---------------------------------------------------------------------- 108 !! *** FUNCTION diadct_alloc *** 109 !!---------------------------------------------------------------------- 110 INTEGER :: ierr(2) 111 !!---------------------------------------------------------------------- 112 113 ALLOCATE(transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), STAT=ierr(1) ) 114 ALLOCATE(transports_2d(nb_2d_vars,nb_sec_max,nb_point_max) , STAT=ierr(2) ) 115 116 diadct_alloc = MAXVAL( ierr ) 117 IF( diadct_alloc /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 118 119 END FUNCTION diadct_alloc 120 99 INTEGER FUNCTION diadct_alloc() 100 !!---------------------------------------------------------------------- 101 !! *** FUNCTION diadct_alloc *** 102 !!---------------------------------------------------------------------- 103 104 ALLOCATE( transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), & 105 & transports_2d(nb_2d_vars,nb_sec_max,nb_point_max) , STAT=diadct_alloc ) 106 107 CALL mpp_sum( 'diadct', diadct_alloc ) 108 IF( diadct_alloc /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 109 110 END FUNCTION diadct_alloc 121 111 122 112 SUBROUTINE dia_dct_init … … 130 120 INTEGER :: ios ! Local integer output status for namelist read 131 121 !! 132 NAMELIST/nam dct/nn_dct,nn_dctwri,nn_secdebug122 NAMELIST/nam_diadct/ln_diadct, nn_dct, nn_dctwri, nn_secdebug 133 123 !!--------------------------------------------------------------------- 134 124 135 REWIND( numnam_ref ) ! Namelist nam dct in reference namelist : Diagnostic: transport through sections136 READ ( numnam_ref, nam dct, IOSTAT = ios, ERR = 901)137 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam dct in reference namelist', lwp)138 139 REWIND( numnam_cfg ) ! Namelist nam dct in configuration namelist : Diagnostic: transport through sections140 READ ( numnam_cfg, nam dct, IOSTAT = ios, ERR = 902 )141 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam dct in configuration namelist', lwp)142 IF(lwm) WRITE ( numond, nam dct )125 REWIND( numnam_ref ) ! Namelist nam_diadct in reference namelist : Diagnostic: transport through sections 126 READ ( numnam_ref, nam_diadct, IOSTAT = ios, ERR = 901) 127 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diadct in reference namelist' ) 128 129 REWIND( numnam_cfg ) ! Namelist nam_diadct in configuration namelist : Diagnostic: transport through sections 130 READ ( numnam_cfg, nam_diadct, IOSTAT = ios, ERR = 902 ) 131 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diadct in configuration namelist' ) 132 IF(lwm) WRITE ( numond, nam_diadct ) 143 133 144 134 IF( lwp ) THEN … … 146 136 WRITE(numout,*) "diadct_init: compute transports through sections " 147 137 WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~" 148 WRITE(numout,*) " Frequency of computation: nn_dct = ",nn_dct 149 WRITE(numout,*) " Frequency of write: nn_dctwri = ",nn_dctwri 138 WRITE(numout,*) " Calculate transport thru sections: ln_diadct = ", ln_diadct 139 WRITE(numout,*) " Frequency of computation: nn_dct = ", nn_dct 140 WRITE(numout,*) " Frequency of write: nn_dctwri = ", nn_dctwri 150 141 151 142 IF ( nn_secdebug .GE. 1 .AND. nn_secdebug .LE. nb_sec_max )THEN … … 155 146 ELSE ; WRITE(numout,*)" Wrong value for nn_secdebug : ",nn_secdebug 156 147 ENDIF 157 148 ENDIF 149 150 IF( ln_diadct ) THEN 151 ! control 158 152 IF(nn_dct .GE. nn_dctwri .AND. MOD(nn_dct,nn_dctwri) .NE. 0) & 159 & CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) 160 153 & CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) 154 155 ! allocate dia_dct arrays 156 IF( diadct_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 157 158 !Read section_ijglobal.diadct 159 CALL readsec 160 161 !open output file 162 IF( lwm ) THEN 163 CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 164 CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 165 CALL ctl_opn( numdct_salt, 'salt_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 166 ENDIF 167 168 ! Initialise arrays to zero 169 transports_3d(:,:,:,:)=0.0 170 transports_2d(:,:,:) =0.0 171 ! 161 172 ENDIF 162 163 !Read section_ijglobal.diadct164 CALL readsec165 166 !open output file167 IF( lwm ) THEN168 CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )169 CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )170 CALL ctl_opn( numdct_salt, 'salt_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )171 ENDIF172 173 ! Initialise arrays to zero174 transports_3d(:,:,:,:)=0.0175 transports_2d(:,:,:) =0.0176 173 ! 177 174 END SUBROUTINE dia_dct_init … … 1241 1238 #else 1242 1239 !!---------------------------------------------------------------------- 1243 !! D efault option : Dummy module1240 !! Dummy module 1244 1241 !!---------------------------------------------------------------------- 1245 LOGICAL, PUBLIC, PARAMETER :: lk_diadct = .FALSE. !: diamht flag 1246 PUBLIC 1247 !! $Id$ 1242 LOGICAL, PUBLIC :: ln_diadct = .FALSE. 1248 1243 CONTAINS 1249 1250 SUBROUTINE dia_dct_init ! Dummy routine 1244 SUBROUTINE dia_dct_init 1251 1245 IMPLICIT NONE 1252 WRITE(*,*) 'dia_dct_init: You should not have seen this print! error?'1253 1246 END SUBROUTINE dia_dct_init 1254 1255 SUBROUTINE dia_dct( kt ) ! Dummy routine 1247 SUBROUTINE dia_dct( kt ) 1256 1248 IMPLICIT NONE 1257 INTEGER, INTENT( in ) :: kt ! ocean time-step index 1258 WRITE(*,*) 'dia_dct: You should not have seen this print! error?', kt 1249 INTEGER, INTENT(in) :: kt 1259 1250 END SUBROUTINE dia_dct 1251 ! 1260 1252 #endif 1261 1253 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIA/diaharm.F90
r10840 r12065 5 5 !!====================================================================== 6 6 !! History : 3.1 ! 2007 (O. Le Galloudec, J. Chanut) Original code 7 !!----------------------------------------------------------------------8 #if defined key_diaharm9 !!----------------------------------------------------------------------10 !! 'key_diaharm'11 7 !!---------------------------------------------------------------------- 12 8 USE oce ! ocean dynamics and tracers variables … … 26 22 IMPLICIT NONE 27 23 PRIVATE 28 29 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .TRUE.30 24 31 25 INTEGER, PARAMETER :: jpincomax = 2.*jpmax_harmo … … 33 27 34 28 ! !!** namelist variables ** 35 INTEGER :: nit000_han ! First time step used for harmonic analysis 36 INTEGER :: nitend_han ! Last time step used for harmonic analysis 37 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 38 INTEGER :: nb_ana ! Number of harmonics to analyse 29 LOGICAL, PUBLIC :: ln_diaharm ! Choose tidal harmonic output or not 30 INTEGER :: nit000_han ! First time step used for harmonic analysis 31 INTEGER :: nitend_han ! Last time step used for harmonic analysis 32 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 33 INTEGER :: nb_ana ! Number of harmonics to analyse 39 34 40 35 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ana_temp … … 51 46 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: tname ! Names of tidal constituents ('M2', 'K1',...) 52 47 53 PUBLIC dia_harm ! routine called by step.F90 48 PUBLIC dia_harm ! routine called by step.F90 49 PUBLIC dia_harm_init ! routine called by nemogcm.F90 54 50 55 51 !!---------------------------------------------------------------------- … … 69 65 !! 70 66 !!-------------------------------------------------------------------- 71 INTEGER :: jh, nhan, jk, ji67 INTEGER :: jh, nhan, ji 72 68 INTEGER :: ios ! Local integer output status for namelist read 73 69 TYPE(tide_harmonic), DIMENSION(:), POINTER :: tide_harmonics ! Oscillation parameters of selected tidal components 74 70 75 NAMELIST/nam_diaharm/ nit000_han, nitend_han, nstep_han, tname71 NAMELIST/nam_diaharm/ ln_diaharm, nit000_han, nitend_han, nstep_han, tname 76 72 !!---------------------------------------------------------------------- 77 73 … … 82 78 ENDIF 83 79 ! 84 IF( .NOT. ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis')85 !86 80 REWIND( numnam_ref ) ! Namelist nam_diaharm in reference namelist : Tidal harmonic analysis 87 81 READ ( numnam_ref, nam_diaharm, IOSTAT = ios, ERR = 901) 88 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in reference namelist' , lwp)82 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in reference namelist' ) 89 83 REWIND( numnam_cfg ) ! Namelist nam_diaharm in configuration namelist : Tidal harmonic analysis 90 84 READ ( numnam_cfg, nam_diaharm, IOSTAT = ios, ERR = 902 ) 91 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist' , lwp)85 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist' ) 92 86 IF(lwm) WRITE ( numond, nam_diaharm ) 93 87 ! 94 88 IF(lwp) THEN 95 WRITE(numout,*) 'First time step used for analysis: nit000_han= ', nit000_han 96 WRITE(numout,*) 'Last time step used for analysis: nitend_han= ', nitend_han 97 WRITE(numout,*) 'Time step frequency for harmonic analysis: nstep_han= ', nstep_han 89 WRITE(numout,*) 'Tidal diagnostics = ', ln_diaharm 90 WRITE(numout,*) ' First time step used for analysis: nit000_han= ', nit000_han 91 WRITE(numout,*) ' Last time step used for analysis: nitend_han= ', nitend_han 92 WRITE(numout,*) ' Time step frequency for harmonic analysis: nstep_han = ', nstep_han 98 93 ENDIF 99 94 100 ! Basic checks on harmonic analysis time window: 101 ! ---------------------------------------------- 102 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 103 & ' restart capability not implemented' ) 104 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 105 & 'restart capability not implemented' ) 106 107 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 108 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 109 110 ! Initialize oscillation parameters for tidal components that have been 111 ! selected for harmonic analysis 112 ! --------------------------------------------------------------------- 113 CALL tide_init_harmonics(tname, tide_harmonics) 114 ! Number of tidal components selected for harmonic analysis 115 nb_ana = size(tide_harmonics) 116 ! 117 IF(lwp) THEN 118 WRITE(numout,*) ' Namelist nam_diaharm' 119 WRITE(numout,*) ' nb_ana = ', nb_ana 120 CALL flush(numout) 95 IF( ln_diaharm .AND. .NOT.ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') 96 97 IF( ln_diaharm ) THEN 98 99 ! 100 ! Basic checks on harmonic analysis time window: 101 ! ---------------------------------------------- 102 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 103 & ' restart capability not implemented' ) 104 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 105 & 'restart capability not implemented' ) 106 107 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 108 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 109 ! 110 ! Initialize oscillation parameters for tidal components that have been 111 ! selected for harmonic analysis 112 ! --------------------------------------------------------------------- 113 CALL tide_init_harmonics(tname, tide_harmonics) 114 ! Number of tidal components selected for harmonic analysis 115 nb_ana = size(tide_harmonics) 116 ! 117 IF(lwp) THEN 118 WRITE(numout,*) ' Namelist nam_diaharm' 119 WRITE(numout,*) ' nb_ana = ', nb_ana 120 CALL flush(numout) 121 ENDIF 122 ! 123 IF (nb_ana > jpmax_harmo) THEN 124 WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo' 125 WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo 126 CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 ) 127 ENDIF 128 129 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' 130 131 DO jh = 1, nb_ana 132 IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',tide_harmonics(jh)%omega 133 END DO 134 135 ! Initialize temporary arrays: 136 ! ---------------------------- 137 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 138 ana_temp(:,:,:,:) = 0._wp 139 121 140 ENDIF 122 !123 IF (nb_ana > jpmax_harmo) THEN124 WRITE(ctmp1,*) ' E R R O R dia_harm_init : nb_ana must be lower than jpmax_harmo, stop'125 WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo126 CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 )127 ENDIF128 129 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency '130 131 DO jh = 1, nb_ana132 IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',tide_harmonics(jh)%omega133 END DO134 135 ! Initialize temporary arrays:136 ! ----------------------------137 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) )138 ana_temp(:,:,:,:) = 0._wp139 141 140 142 END SUBROUTINE dia_harm_init … … 156 158 !!-------------------------------------------------------------------- 157 159 IF( ln_timing ) CALL timing_start('dia_harm') 158 !159 IF( kt == nit000 ) CALL dia_harm_init160 160 ! 161 161 IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN … … 405 405 INTEGER, INTENT(in) :: init 406 406 ! 407 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, j k1_sd, jk2_sd407 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, jh1_sd, jh2_sd 408 408 REAL(wp) :: zval1, zval2, zx1 409 409 REAL(wp), DIMENSION(jpincomax) :: ztmpx, zcol1, zcol2 … … 417 417 ztmp3(:,:) = 0._wp 418 418 ! 419 DO j k1_sd = 1, nsparse420 DO j k2_sd = 1, nsparse421 nisparse(j k2_sd) = nisparse(jk2_sd)422 njsparse(j k2_sd) = njsparse(jk2_sd)423 IF( nisparse(j k2_sd) == nisparse(jk1_sd) ) THEN424 ztmp3(njsparse(j k1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) &425 & + valuesparse(j k1_sd)*valuesparse(jk2_sd)419 DO jh1_sd = 1, nsparse 420 DO jh2_sd = 1, nsparse 421 nisparse(jh2_sd) = nisparse(jh2_sd) 422 njsparse(jh2_sd) = njsparse(jh2_sd) 423 IF( nisparse(jh2_sd) == nisparse(jh1_sd) ) THEN 424 ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) = ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) & 425 & + valuesparse(jh1_sd)*valuesparse(jh2_sd) 426 426 ENDIF 427 427 END DO … … 498 498 END SUBROUTINE SUR_DETERMINE 499 499 500 #else501 !!----------------------------------------------------------------------502 !! Default case : Empty module503 !!----------------------------------------------------------------------504 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .FALSE.505 CONTAINS506 SUBROUTINE dia_harm ( kt ) ! Empty routine507 INTEGER, INTENT( IN ) :: kt508 WRITE(*,*) 'dia_harm: you should not have seen this print'509 END SUBROUTINE dia_harm510 #endif511 512 500 !!====================================================================== 513 501 END MODULE diaharm -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIA/diahsb.F90
r10425 r12065 362 362 REWIND( numnam_ref ) ! Namelist namhsb in reference namelist 363 363 READ ( numnam_ref, namhsb, IOSTAT = ios, ERR = 901) 364 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namhsb in reference namelist' , lwp)364 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namhsb in reference namelist' ) 365 365 REWIND( numnam_cfg ) ! Namelist namhsb in configuration namelist 366 366 READ ( numnam_cfg, namhsb, IOSTAT = ios, ERR = 902 ) 367 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namhsb in configuration namelist' , lwp)367 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namhsb in configuration namelist' ) 368 368 IF(lwm) WRITE( numond, namhsb ) 369 369 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIA/diaptr.F90
r10425 r12065 393 393 REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport 394 394 READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901) 395 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' , lwp)395 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' ) 396 396 397 397 REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport 398 398 READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 ) 399 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' , lwp)399 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' ) 400 400 IF(lwm) WRITE ( numond, namptr ) 401 401 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIA/diatmb.F90
r10499 r12065 43 43 REWIND( numnam_ref ) ! Read Namelist nam_diatmb in reference namelist : TMB diagnostics 44 44 READ ( numnam_ref, nam_diatmb, IOSTAT=ios, ERR= 901 ) 45 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diatmb in reference namelist' , lwp)45 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diatmb in reference namelist' ) 46 46 47 47 REWIND( numnam_cfg ) ! Namelist nam_diatmb in configuration namelist TMB diagnostics 48 48 READ ( numnam_cfg, nam_diatmb, IOSTAT = ios, ERR = 902 ) 49 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diatmb in configuration namelist' , lwp)49 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diatmb in configuration namelist' ) 50 50 IF(lwm) WRITE ( numond, nam_diatmb ) 51 51 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIA/diawri.F90
r10425 r12065 210 210 ENDIF 211 211 212 IF( ln_zad_Aimp ) wn = wn + wi ! Recombine explicit and implicit parts of vertical velocity for diagnostic output 213 ! 212 214 CALL iom_put( "woce", wn ) ! vertical velocity 213 215 IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value … … 220 222 IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 221 223 ENDIF 224 ! 225 IF( ln_zad_Aimp ) wn = wn - wi ! Remove implicit part of vertical velocity that was added for diagnostic output 222 226 223 227 CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. … … 426 430 !! define all the NETCDF files and fields 427 431 !! At each time step call histdef to compute the mean if ncessary 428 !! Each n write time step, output the instantaneous or mean fields432 !! Each nn_write time step, output the instantaneous or mean fields 429 433 !!---------------------------------------------------------------------- 430 434 INTEGER, INTENT( in ) :: kt ! ocean time-step index … … 442 446 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace 443 447 !!---------------------------------------------------------------------- 444 !445 IF( ln_timing ) CALL timing_start('dia_wri')446 448 ! 447 449 IF( ninist == 1 ) THEN !== Output the initial state and forcings ==! … … 450 452 ENDIF 451 453 ! 454 IF( nn_write == -1 ) RETURN ! we will never do any output 455 ! 456 IF( ln_timing ) CALL timing_start('dia_wri') 457 ! 452 458 ! 0. Initialisation 453 459 ! ----------------- … … 459 465 clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes) 460 466 #if defined key_diainstant 461 zsto = n write * rdt467 zsto = nn_write * rdt 462 468 clop = "inst("//TRIM(clop)//")" 463 469 #else … … 465 471 clop = "ave("//TRIM(clop)//")" 466 472 #endif 467 zout = n write * rdt473 zout = nn_write * rdt 468 474 zmax = ( nitend - nit000 + 1 ) * rdt 469 475 … … 496 502 ! WRITE root name in date.file for use by postpro 497 503 IF(lwp) THEN 498 CALL dia_nam( clhstnam, n write,' ' )504 CALL dia_nam( clhstnam, nn_write,' ' ) 499 505 CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 500 506 WRITE(inum,*) clhstnam … … 504 510 ! Define the T grid FILE ( nid_T ) 505 511 506 CALL dia_nam( clhstnam, n write, 'grid_T' )512 CALL dia_nam( clhstnam, nn_write, 'grid_T' ) 507 513 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename 508 514 CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit … … 540 546 ! Define the U grid FILE ( nid_U ) 541 547 542 CALL dia_nam( clhstnam, n write, 'grid_U' )548 CALL dia_nam( clhstnam, nn_write, 'grid_U' ) 543 549 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename 544 550 CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu, & ! Horizontal grid: glamu and gphiu … … 553 559 ! Define the V grid FILE ( nid_V ) 554 560 555 CALL dia_nam( clhstnam, n write, 'grid_V' ) ! filename561 CALL dia_nam( clhstnam, nn_write, 'grid_V' ) ! filename 556 562 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam 557 563 CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv, & ! Horizontal grid: glamv and gphiv … … 566 572 ! Define the W grid FILE ( nid_W ) 567 573 568 CALL dia_nam( clhstnam, n write, 'grid_W' ) ! filename574 CALL dia_nam( clhstnam, nn_write, 'grid_W' ) ! filename 569 575 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam 570 576 CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit … … 657 663 ENDIF 658 664 659 IF( .NOT. ln_cpl) THEN665 IF( ln_ssr ) THEN 660 666 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 661 667 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 665 671 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 666 672 ENDIF 667 668 IF( ln_cpl .AND. nn_ice <= 1 ) THEN 669 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 670 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 671 CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp 672 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 673 CALL histdef( nid_T, "sosafldp", "Surface salt flux: Damping" , "Kg/m2/s", & ! erp * sn 674 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 675 ENDIF 676 673 677 674 clmx ="l_max(only(x))" ! max index on a period 678 675 ! CALL histdef( nid_T, "sobowlin", "Bowl Index" , "W-point", & ! bowl INDEX … … 750 747 ! donne le nombre d'elements, et ndex la liste des indices a sortir 751 748 752 IF( lwp .AND. MOD( itmod, n write ) == 0 ) THEN749 IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN 753 750 WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step' 754 751 WRITE(numout,*) '~~~~~~ ' … … 814 811 ENDIF 815 812 816 IF( .NOT. ln_cpl) THEN813 IF( ln_ssr ) THEN 817 814 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 818 815 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 819 IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 820 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 821 ENDIF 822 IF( ln_cpl .AND. nn_ice <= 1 ) THEN 823 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 824 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 825 IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 816 zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 826 817 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 827 818 ENDIF … … 842 833 CALL histwrite( nid_V, "sometauy", it, vtau , ndim_hV, ndex_hV ) ! j-wind stress 843 834 844 CALL histwrite( nid_W, "vovecrtz", it, wn , ndim_T, ndex_T ) ! vert. current 835 IF( ln_zad_Aimp ) THEN 836 CALL histwrite( nid_W, "vovecrtz", it, wn + wi , ndim_T, ndex_T ) ! vert. current 837 ELSE 838 CALL histwrite( nid_W, "vovecrtz", it, wn , ndim_T, ndex_T ) ! vert. current 839 ENDIF 845 840 CALL histwrite( nid_W, "votkeavt", it, avt , ndim_T, ndex_T ) ! T vert. eddy diff. coef. 846 841 CALL histwrite( nid_W, "votkeavm", it, avm , ndim_T, ndex_T ) ! T vert. eddy visc. coef. … … 903 898 CALL iom_rstput( 0, 0, inum, 'vozocrtx', un ) ! now i-velocity 904 899 CALL iom_rstput( 0, 0, inum, 'vomecrty', vn ) ! now j-velocity 905 CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn ) ! now k-velocity 900 IF( ln_zad_Aimp ) THEN 901 CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn + wi ) ! now k-velocity 902 ELSE 903 CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn ) ! now k-velocity 904 ENDIF 906 905 IF( ALLOCATED(ahtu) ) THEN 907 906 CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) ! aht at u-point -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DIU/diurnal_bulk.F90
r10069 r12065 54 54 REWIND( numnam_ref ) 55 55 READ ( numnam_ref, namdiu, IOSTAT = ios, ERR = 901 ) 56 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdiu in reference namelist' , lwp)56 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdiu in reference namelist' ) 57 57 REWIND( numnam_cfg ) 58 58 READ ( numnam_cfg, namdiu, IOSTAT = ios, ERR = 902 ) 59 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdiu in configuration namelist' , lwp)59 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdiu in configuration namelist' ) 60 60 ! 61 61 IF( ln_diurnal_only .AND. ( .NOT. ln_diurnal ) ) THEN -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DOM/domain.F90
r10425 r12065 101 101 CASE( 0 ) ; WRITE(numout,*) ' (i.e. closed)' 102 102 CASE( 1 ) ; WRITE(numout,*) ' (i.e. cyclic east-west)' 103 CASE( 2 ) ; WRITE(numout,*) ' (i.e. equatorial symmetric)'103 CASE( 2 ) ; WRITE(numout,*) ' (i.e. cyclic north-south)' 104 104 CASE( 3 ) ; WRITE(numout,*) ' (i.e. north fold with T-point pivot)' 105 105 CASE( 4 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with T-point pivot)' … … 308 308 REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run 309 309 READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 310 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' , lwp)310 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' ) 311 311 REWIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run 312 312 READ ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) 313 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' , lwp)313 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' ) 314 314 IF(lwm) WRITE ( numond, namrun ) 315 315 ! … … 336 336 WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock 337 337 ENDIF 338 #if ! defined key_iomput 338 339 WRITE(numout,*) ' frequency of output file nn_write = ', nn_write 340 #endif 339 341 WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland 340 342 WRITE(numout,*) ' additional CF standard metadata ln_cfmeta = ', ln_cfmeta … … 358 360 nleapy = nn_leapy 359 361 ninist = nn_istate 360 nstock = nn_stock361 nstocklist = nn_stocklist362 nwrite = nn_write363 362 neuler = nn_euler 364 363 IF( neuler == 1 .AND. .NOT. ln_rstart ) THEN … … 369 368 ENDIF 370 369 ! ! control of output frequency 371 IF( nstock == 0 .OR. nstock > nitend ) THEN 372 WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend 370 IF( .NOT. ln_rst_list ) THEN ! we use nn_stock 371 IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) 372 IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN 373 WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend 374 CALL ctl_warn( ctmp1 ) 375 nn_stock = nitend 376 ENDIF 377 ENDIF 378 #if ! defined key_iomput 379 IF( nn_write == -1 ) CALL ctl_warn( 'nn_write = -1 --> no output files will be done' ) 380 IF ( nn_write == 0 ) THEN 381 WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend 373 382 CALL ctl_warn( ctmp1 ) 374 nstock = nitend 375 ENDIF 376 IF ( nwrite == 0 ) THEN 377 WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend 378 CALL ctl_warn( ctmp1 ) 379 nwrite = nitend 380 ENDIF 383 nn_write = nitend 384 ENDIF 385 #endif 381 386 382 387 #if defined key_agrif … … 401 406 REWIND( numnam_ref ) ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) 402 407 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 403 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' , lwp)408 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) 404 409 REWIND( numnam_cfg ) ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) 405 410 READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 406 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' , lwp)411 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 407 412 IF(lwm) WRITE( numond, namdom ) 408 413 ! … … 433 438 REWIND( numnam_ref ) ! Namelist namnc4 in reference namelist : NETCDF 434 439 READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 435 907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' , lwp)440 907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) 436 441 REWIND( numnam_cfg ) ! Namelist namnc4 in configuration namelist : NETCDF 437 442 READ ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) 438 908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' , lwp)443 908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' ) 439 444 IF(lwm) WRITE( numond, namnc4 ) 440 445 … … 511 516 512 517 513 SUBROUTINE domain_cfg( ldtxt,cd_cfg, kk_cfg, kpi, kpj, kpk, kperio )518 SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 514 519 !!---------------------------------------------------------------------- 515 520 !! *** ROUTINE dom_nam *** … … 519 524 !! ** Method : read the cn_domcfg NetCDF file 520 525 !!---------------------------------------------------------------------- 521 CHARACTER(len=*), DIMENSION(:), INTENT(out) :: ldtxt ! stored print information522 526 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 523 527 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution … … 525 529 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 526 530 ! 527 INTEGER :: inum , ii! local integer531 INTEGER :: inum ! local integer 528 532 REAL(wp) :: zorca_res ! local scalars 529 REAL(wp) :: ziglo, zjglo, zkglo, zperio ! - - 530 !!---------------------------------------------------------------------- 531 ! 532 ii = 1 533 WRITE(ldtxt(ii),*) ' ' ; ii = ii+1 534 WRITE(ldtxt(ii),*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' ; ii = ii+1 535 WRITE(ldtxt(ii),*) '~~~~~~~~~~ ' ; ii = ii+1 533 REAL(wp) :: zperio ! - - 534 INTEGER, DIMENSION(4) :: idvar, idimsz ! size of dimensions 535 !!---------------------------------------------------------------------- 536 ! 537 IF(lwp) THEN 538 WRITE(numout,*) ' ' 539 WRITE(numout,*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' 540 WRITE(numout,*) '~~~~~~~~~~ ' 541 ENDIF 536 542 ! 537 543 CALL iom_open( cn_domcfg, inum ) … … 544 550 CALL iom_get( inum, 'ORCA_index', zorca_res ) ; kk_cfg = NINT( zorca_res ) 545 551 ! 546 WRITE(ldtxt(ii),*) ' .' ; ii = ii+1 547 WRITE(ldtxt(ii),*) ' ==>>> ORCA configuration ' ; ii = ii+1 548 WRITE(ldtxt(ii),*) ' .' ; ii = ii+1 552 IF(lwp) THEN 553 WRITE(numout,*) ' .' 554 WRITE(numout,*) ' ==>>> ORCA configuration ' 555 WRITE(numout,*) ' .' 556 ENDIF 549 557 ! 550 558 ELSE !- cd_cfg & k_cfg are not used … … 559 567 ! 560 568 ENDIF 561 ! 562 CALL iom_get( inum, 'jpiglo', ziglo ) ; kpi = NINT( ziglo ) 563 CALL iom_get( inum, 'jpjglo', zjglo ) ; kpj = NINT( zjglo ) 564 CALL iom_get( inum, 'jpkglo', zkglo ) ; kpk = NINT( zkglo ) 569 ! 570 idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz ) ! use e3t_0, that must exist, to get jp(ijk)glo 571 kpi = idimsz(1) 572 kpj = idimsz(2) 573 kpk = idimsz(3) 565 574 CALL iom_get( inum, 'jperio', zperio ) ; kperio = NINT( zperio ) 566 575 CALL iom_close( inum ) 567 576 ! 568 WRITE(ldtxt(ii),*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg ; ii = ii+1 569 WRITE(ldtxt(ii),*) ' jpiglo = ', kpi ; ii = ii+1 570 WRITE(ldtxt(ii),*) ' jpjglo = ', kpj ; ii = ii+1 571 WRITE(ldtxt(ii),*) ' jpkglo = ', kpk ; ii = ii+1 572 WRITE(ldtxt(ii),*) ' type of global domain lateral boundary jperio = ', kperio ; ii = ii+1 577 IF(lwp) THEN 578 WRITE(numout,*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg 579 WRITE(numout,*) ' jpiglo = ', kpi 580 WRITE(numout,*) ' jpjglo = ', kpj 581 WRITE(numout,*) ' jpkglo = ', kpk 582 WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio 583 ENDIF 573 584 ! 574 585 END SUBROUTINE domain_cfg -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DOM/dommsk.F90
r10425 r12065 100 100 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 101 101 & cn_ice, nn_ice_dta, & 102 & rn_ice_tem, rn_ice_sal, rn_ice_age, & 103 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 102 & ln_vol, nn_volctl, nn_rimwidth 104 103 !!--------------------------------------------------------------------- 105 104 ! 106 105 REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition 107 106 READ ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 ) 108 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' , lwp)107 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' ) 109 108 REWIND( numnam_cfg ) ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition 110 109 READ ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 ) 111 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' , lwp)110 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' ) 112 111 IF(lwm) WRITE ( numond, namlbc ) 113 112 … … 142 141 ENDIF 143 142 END DO 144 END DO 145 !SF add here lbc_lnk: bug not still understood : cause now domain configuration is read ! 146 !!gm I don't understand why... 143 END DO 144 ! 145 ! the following call is mandatory 146 ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...) 147 147 CALL lbc_lnk( 'dommsk', tmask , 'T', 1._wp ) ! Lateral boundary conditions 148 148 … … 150 150 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries 151 151 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 152 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' , lwp)152 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) 153 153 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries 154 154 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 155 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' , lwp)155 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) 156 156 ! ------------------------ 157 157 IF ( ln_bdy .AND. ln_mask_file ) THEN -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DOM/domvvl.F90
r10425 r12065 327 327 END DO 328 328 ! 329 IF( ln_vvl_ztilde .OR. ln_vvl_layer.AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate !330 ! ! ------baroclinic part------ !329 IF( (ln_vvl_ztilde .OR. ln_vvl_layer) .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate ! 330 ! ! ------baroclinic part------ ! 331 331 ! I - initialization 332 332 ! ================== … … 993 993 REWIND( numnam_ref ) ! Namelist nam_vvl in reference namelist : 994 994 READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) 995 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' , lwp)995 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' ) 996 996 REWIND( numnam_cfg ) ! Namelist nam_vvl in configuration namelist : Parameters of the run 997 997 READ ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 ) 998 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' , lwp)998 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' ) 999 999 IF(lwm) WRITE ( numond, nam_vvl ) 1000 1000 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DOM/domwri.F90
r10425 r12065 162 162 CALL iom_rstput( 0, 0, inum, 'isfdraft', zprt, ktype = jp_r8 ) ! ! nb of ocean T-points 163 163 ! ! vertical mesh 164 CALL iom_rstput( 0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8 ) ! ! scale factors 165 CALL iom_rstput( 0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8 ) 166 CALL iom_rstput( 0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8 ) 167 CALL iom_rstput( 0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8 ) 164 CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8 ) ! ! scale factors 165 CALL iom_rstput( 0, 0, inum, 'e3w_1d', e3w_1d, ktype = jp_r8 ) 166 167 CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 ) 168 CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 ) 169 CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 ) 170 CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 ) 171 CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 ) 172 CALL iom_rstput( 0, 0, inum, 'e3uw_0', e3uw_0, ktype = jp_r8 ) 173 CALL iom_rstput( 0, 0, inum, 'e3vw_0', e3vw_0, ktype = jp_r8 ) 168 174 ! 169 175 CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 ) ! stretched system -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DOM/dtatsd.F90
r10213 r12065 67 67 REWIND( numnam_ref ) ! Namelist namtsd in reference namelist : 68 68 READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 69 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' , lwp)69 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' ) 70 70 REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run 71 71 READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 72 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtsd in configuration namelist' , lwp)72 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtsd in configuration namelist' ) 73 73 IF(lwm) WRITE ( numond, namtsd ) 74 74 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DOM/iscplhsb.F90
r10425 r12065 186 186 ! CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 187 187 ! CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 188 STOP ' iscpl_cons: please modify this module !'188 CALL ctl_stop( 'STOP', ' iscpl_cons: please modify this MODULE !' ) 189 189 !!gm end 190 190 ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DOM/iscplini.F90
r10425 r12065 64 64 REWIND( numnam_ref ) ! Namelist namsbc_iscpl in reference namelist : Ice sheet coupling 65 65 READ ( numnam_ref, namsbc_iscpl, IOSTAT = ios, ERR = 901) 66 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iscpl in reference namelist' , lwp)66 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iscpl in reference namelist' ) 67 67 REWIND( numnam_cfg ) ! Namelist namsbc_iscpl in configuration namelist : Ice Sheet coupling 68 68 READ ( numnam_cfg, namsbc_iscpl, IOSTAT = ios, ERR = 902 ) 69 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iscpl in configuration namelist' , lwp)69 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iscpl in configuration namelist' ) 70 70 IF(lwm) WRITE ( numond, namsbc_iscpl ) 71 71 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/dynadv.F90
r10068 r12065 106 106 REWIND( numnam_ref ) ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 107 107 READ ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) 108 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' , lwp)108 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) 109 109 REWIND( numnam_cfg ) ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme 110 110 READ ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) 111 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' , lwp)111 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) 112 112 IF(lwm) WRITE ( numond, namdyn_adv ) 113 113 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/dynhpg.F90
r10491 r12065 37 37 USE trd_oce ! trends: ocean variables 38 38 USE trddyn ! trend manager: dynamics 39 !jcUSE zpshde ! partial step: hor. derivative (zps_hde routine)39 USE zpshde ! partial step: hor. derivative (zps_hde routine) 40 40 ! 41 41 USE in_out_manager ! I/O manager … … 152 152 REWIND( numnam_ref ) ! Namelist namdyn_hpg in reference namelist : Hydrostatic pressure gradient 153 153 READ ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901) 154 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' , lwp)154 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' ) 155 155 ! 156 156 REWIND( numnam_cfg ) ! Namelist namdyn_hpg in configuration namelist : Hydrostatic pressure gradient 157 157 READ ( numnam_cfg, namdyn_hpg, IOSTAT = ios, ERR = 902 ) 158 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' , lwp)158 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' ) 159 159 IF(lwm) WRITE ( numond, namdyn_hpg ) 160 160 ! … … 338 338 REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars 339 339 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 340 REAL(wp), DIMENSION(jpi,jpj) :: zgtsu, zgtsv, zgru, zgrv 340 341 !!---------------------------------------------------------------------- 341 342 ! … … 346 347 ENDIF 347 348 348 ! Partial steps: bottom beforehorizontal gradient of t, s, rd at the last ocean level349 !jc CALL zps_hde ( kt, jpts, tsn, gtsu, gtsv, rhd, gru ,grv )349 ! Partial steps: Compute NOW horizontal gradient of t, s, rd at the last ocean level 350 CALL zps_hde( kt, jpts, tsn, zgtsu, zgtsv, rhd, zgru , zgrv ) 350 351 351 352 ! Local constant initialization … … 385 386 END DO 386 387 387 ! partial steps correction at the last level (use gru &grv computed in zpshde.F90)388 ! partial steps correction at the last level (use zgru & zgrv computed in zpshde.F90) 388 389 DO jj = 2, jpjm1 389 390 DO ji = 2, jpim1 … … 395 396 ua (ji,jj,iku) = ua(ji,jj,iku) - zhpi(ji,jj,iku) ! subtract old value 396 397 zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1) & ! compute the new one 397 & + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + gru(ji,jj) ) * r1_e1u(ji,jj)398 & + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + zgru(ji,jj) ) * r1_e1u(ji,jj) 398 399 ua (ji,jj,iku) = ua(ji,jj,iku) + zhpi(ji,jj,iku) ! add the new one to the general momentum trend 399 400 ENDIF … … 401 402 va (ji,jj,ikv) = va(ji,jj,ikv) - zhpj(ji,jj,ikv) ! subtract old value 402 403 zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1) & ! compute the new one 403 & + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + grv(ji,jj) ) * r1_e2v(ji,jj)404 & + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + zgrv(ji,jj) ) * r1_e2v(ji,jj) 404 405 va (ji,jj,ikv) = va(ji,jj,ikv) + zhpj(ji,jj,ikv) ! add the new one to the general momentum trend 405 406 ENDIF -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/dynkeg.F90
r10425 r12065 74 74 INTEGER, INTENT( in ) :: kscheme ! =0/1 type of KEG scheme 75 75 ! 76 INTEGER :: ji, jj, jk, jb ! dummy loop indices 77 INTEGER :: ii, ifu, ib_bdy ! local integers 78 INTEGER :: ij, ifv, igrd ! - - 79 REAL(wp) :: zu, zv ! local scalars 76 INTEGER :: ji, jj, jk ! dummy loop indices 77 REAL(wp) :: zu, zv ! local scalars 80 78 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhke 81 79 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv … … 97 95 98 96 zhke(:,:,jpk) = 0._wp 99 100 IF (ln_bdy) THEN101 ! Maria Luneva & Fred Wobus: July-2016102 ! compensate for lack of turbulent kinetic energy on liquid bdy points103 DO ib_bdy = 1, nb_bdy104 IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN105 igrd = 2 ! Copying normal velocity into points outside bdy106 DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd)107 DO jk = 1, jpkm1108 ii = idx_bdy(ib_bdy)%nbi(jb,igrd)109 ij = idx_bdy(ib_bdy)%nbj(jb,igrd)110 ifu = NINT( idx_bdy(ib_bdy)%flagu(jb,igrd) )111 un(ii-ifu,ij,jk) = un(ii,ij,jk) * umask(ii,ij,jk)112 END DO113 END DO114 !115 igrd = 3 ! Copying normal velocity into points outside bdy116 DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd)117 DO jk = 1, jpkm1118 ii = idx_bdy(ib_bdy)%nbi(jb,igrd)119 ij = idx_bdy(ib_bdy)%nbj(jb,igrd)120 ifv = NINT( idx_bdy(ib_bdy)%flagv(jb,igrd) )121 vn(ii,ij-ifv,jk) = vn(ii,ij,jk) * vmask(ii,ij,jk)122 END DO123 END DO124 ENDIF125 ENDDO126 ENDIF127 97 128 98 SELECT CASE ( kscheme ) !== Horizontal kinetic energy at T-point ==! … … 140 110 END DO 141 111 END DO 142 !143 112 CASE ( nkeg_HW ) !-- Hollingsworth scheme --! 144 113 DO jk = 1, jpkm1 … … 160 129 CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. ) 161 130 ! 162 END SELECT 163 164 IF (ln_bdy) THEN 165 ! restore velocity masks at points outside boundary 166 un(:,:,:) = un(:,:,:) * umask(:,:,:) 167 vn(:,:,:) = vn(:,:,:) * vmask(:,:,:) 168 ENDIF 169 131 END SELECT 170 132 ! 171 133 DO jk = 1, jpkm1 !== grad( KE ) added to the general momentum trends ==! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/dynnxt.F90
r10425 r12065 175 175 IF( neuler == 0 .AND. kt == nit000 ) THEN !* Euler at first time-step: only swap 176 176 DO jk = 1, jpkm1 177 ub(:,:,jk) = un(:,:,jk) ! ub <-- un 178 vb(:,:,jk) = vn(:,:,jk) 177 179 un(:,:,jk) = ua(:,:,jk) ! un <-- ua 178 180 vn(:,:,jk) = va(:,:,jk) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/dynspg.F90
r10860 r12065 205 205 REWIND( numnam_ref ) ! Namelist namdyn_spg in reference namelist : Free surface 206 206 READ ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901) 207 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' , lwp)207 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' ) 208 208 ! 209 209 REWIND( numnam_cfg ) ! Namelist namdyn_spg in configuration namelist : Free surface 210 210 READ ( numnam_cfg, namdyn_spg, IOSTAT = ios, ERR = 902 ) 211 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' , lwp)211 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' ) 212 212 IF(lwm) WRITE ( numond, namdyn_spg ) 213 213 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/dynspg_ts.F90
r10860 r12065 63 63 USE diatmb ! Top,middle,bottom output 64 64 65 USE iom ! to remove 66 65 67 IMPLICIT NONE 66 68 PRIVATE … … 103 105 ! 104 106 ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(jpi,jpj), STAT=ierr(1) ) 105 !106 107 IF( ln_dynvor_een .OR. ln_dynvor_eeT ) & 107 & ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , & 108 & ftsw(jpi,jpj) , ftse(jpi,jpj) , STAT=ierr(2) ) 108 & ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , ftsw(jpi,jpj) , ftse(jpi,jpj), STAT=ierr(2) ) 109 109 ! 110 110 ALLOCATE( un_adv(jpi,jpj), vn_adv(jpi,jpj) , STAT=ierr(3) ) … … 148 148 LOGICAL :: ll_fw_start ! =T : forward integration 149 149 LOGICAL :: ll_init ! =T : special startup of 2d equations 150 LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables used in W/D 151 INTEGER :: ikbu, iktu, noffset ! local integers 152 INTEGER :: ikbv, iktv ! - - 153 REAL(wp) :: r1_2dt_b, z2dt_bf ! local scalars 154 REAL(wp) :: zx1, zx2, zu_spg, zhura, z1_hu ! - - 155 REAL(wp) :: zy1, zy2, zv_spg, zhvra, z1_hv ! - - 150 INTEGER :: noffset ! local integers : time offset for bdy update 151 REAL(wp) :: r1_2dt_b, z1_hu, z1_hv ! local scalars 156 152 REAL(wp) :: za0, za1, za2, za3 ! - - 157 REAL(wp) :: zmdi, zztmp , z1_ht ! - - 158 REAL(wp), DIMENSION(jpi,jpj) :: zsshp2_e, zhf 159 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zu_trd, zu_frc, zssh_frc 160 REAL(wp), DIMENSION(jpi,jpj) :: zwy, zv_trd, zv_frc, zhdiv 161 REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhust_e, zhtp2_e 162 REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zhvst_e 153 REAL(wp) :: zmdi, zztmp, zldg ! - - 154 REAL(wp) :: zhu_bck, zhv_bck, zhdiv ! - - 155 REAL(wp) :: zun_save, zvn_save ! - - 156 REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg, zssh_frc 157 REAL(wp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg 158 REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e 159 REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e 163 160 REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points 161 REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV ! fluxes 164 162 ! 165 163 REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. … … 182 180 zwdramp = r_rn_wdmin1 ! simplest ramp 183 181 ! zwdramp = 1._wp / (rn_wdmin2 - rn_wdmin1) ! more general ramp 184 ! ! reciprocal of baroclinic time step 185 IF( kt == nit000 .AND. neuler == 0 ) THEN ; z2dt_bf = rdt 186 ELSE ; z2dt_bf = 2.0_wp * rdt 187 ENDIF 188 r1_2dt_b = 1.0_wp / z2dt_bf 182 ! ! inverse of baroclinic time step 183 IF( kt == nit000 .AND. neuler == 0 ) THEN ; r1_2dt_b = 1._wp / ( rdt ) 184 ELSE ; r1_2dt_b = 1._wp / ( 2._wp * rdt ) 185 ENDIF 189 186 ! 190 187 ll_init = ln_bt_av ! if no time averaging, then no specific restart … … 210 207 ll_fw_start =.FALSE. 211 208 ENDIF 212 ! 213 ! Set averaging weights and cycle length: 209 ! ! Set averaging weights and cycle length: 214 210 CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) 215 211 ! 216 ENDIF217 !218 IF( ln_isfcav ) THEN ! top+bottom friction (ocean cavities)219 DO jj = 2, jpjm1220 DO ji = fs_2, fs_jpim1 ! vector opt.221 zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) )222 zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) )223 END DO224 END DO225 ELSE ! bottom friction only226 DO jj = 2, jpjm1227 DO ji = fs_2, fs_jpim1 ! vector opt.228 zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) )229 zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) )230 END DO231 END DO232 ENDIF233 !234 ! Set arrays to remove/compute coriolis trend.235 ! Do it once at kt=nit000 if volume is fixed, else at each long time step.236 ! Note that these arrays are also used during barotropic loop. These are however frozen237 ! although they should be updated in the variable volume case. Not a big approximation.238 ! To remove this approximation, copy lines below inside barotropic loop239 ! and update depths at T-F points (ht and zhf resp.) at each barotropic time step240 !241 IF( kt == nit000 .OR. .NOT.ln_linssh ) THEN242 !243 SELECT CASE( nvor_scheme )244 CASE( np_EEN ) != EEN scheme using e3f (energy & enstrophy scheme)245 SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point246 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)247 DO jj = 1, jpjm1248 DO ji = 1, jpim1249 zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + &250 & ht_n(ji ,jj ) + ht_n(ji+1,jj ) ) * 0.25_wp251 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj)252 END DO253 END DO254 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)255 DO jj = 1, jpjm1256 DO ji = 1, jpim1257 zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) &258 & + ht_n (ji ,jj ) + ht_n (ji+1,jj ) ) &259 & / ( MAX( 1._wp, ssmask(ji ,jj+1) + ssmask(ji+1,jj+1) &260 & + ssmask(ji ,jj ) + ssmask(ji+1,jj ) ) )261 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj)262 END DO263 END DO264 END SELECT265 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp )266 !267 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp268 DO jj = 2, jpj269 DO ji = 2, jpi270 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1)271 ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj )272 ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1)273 ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj )274 END DO275 END DO276 !277 CASE( np_EET ) != EEN scheme using e3t (energy conserving scheme)278 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp279 DO jj = 2, jpj280 DO ji = 2, jpi281 z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) )282 ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht283 ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht284 ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht285 ftsw(ji,jj) = ( ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) ) * z1_ht286 END DO287 END DO288 !289 CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT !290 !291 zwz(:,:) = 0._wp292 zhf(:,:) = 0._wp293 294 !!gm assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed295 !!gm A priori a better value should be something like :296 !!gm zhf(i,j) = masked sum of ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)297 !!gm divided by the sum of the corresponding mask298 !!gm299 !!300 IF( .NOT.ln_sco ) THEN301 302 !!gm agree the JC comment : this should be done in a much clear way303 304 ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case305 ! Set it to zero for the time being306 ! IF( rn_hmin < 0._wp ) THEN ; jk = - INT( rn_hmin ) ! from a nb of level307 ! ELSE ; jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth308 ! ENDIF309 ! zhf(:,:) = gdepw_0(:,:,jk+1)310 !311 ELSE312 !313 !zhf(:,:) = hbatf(:,:)314 DO jj = 1, jpjm1315 DO ji = 1, jpim1316 zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) &317 & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) &318 & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) &319 & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp )320 END DO321 END DO322 ENDIF323 !324 DO jj = 1, jpjm1325 zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1))326 END DO327 !328 DO jk = 1, jpkm1329 DO jj = 1, jpjm1330 zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk)331 END DO332 END DO333 CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp )334 ! JC: TBC. hf should be greater than 0335 DO jj = 1, jpj336 DO ji = 1, jpi337 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj) ! zhf is actually hf here but it saves an array338 END DO339 END DO340 zwz(:,:) = ff_f(:,:) * zwz(:,:)341 END SELECT342 212 ENDIF 343 213 ! … … 348 218 CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) 349 219 ENDIF 220 ! 350 221 351 222 ! ----------------------------------------------------------------------------- … … 354 225 ! 355 226 ! 356 ! !* e3*d/dt(Ua) (Vertically integrated) 357 ! ! -------------------------------------------------- 358 zu_frc(:,:) = 0._wp 359 zv_frc(:,:) = 0._wp 360 ! 361 DO jk = 1, jpkm1 362 zu_frc(:,:) = zu_frc(:,:) + e3u_n(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 363 zv_frc(:,:) = zv_frc(:,:) + e3v_n(:,:,jk) * va(:,:,jk) * vmask(:,:,jk) 364 END DO 365 ! 366 zu_frc(:,:) = zu_frc(:,:) * r1_hu_n(:,:) 367 zv_frc(:,:) = zv_frc(:,:) * r1_hv_n(:,:) 368 ! 369 ! 370 ! !* baroclinic momentum trend (remove the vertical mean trend) 371 DO jk = 1, jpkm1 ! ----------------------------------------------------------- 372 DO jj = 2, jpjm1 373 DO ji = fs_2, fs_jpim1 ! vector opt. 374 ua(ji,jj,jk) = ua(ji,jj,jk) - zu_frc(ji,jj) * umask(ji,jj,jk) 375 va(ji,jj,jk) = va(ji,jj,jk) - zv_frc(ji,jj) * vmask(ji,jj,jk) 376 END DO 377 END DO 227 ! != zu_frc = 1/H e3*d/dt(Ua) =! (Vertical mean of Ua, the 3D trends) 228 ! ! --------------------------- ! 229 zu_frc(:,:) = SUM( e3u_n(:,:,:) * ua(:,:,:) * umask(:,:,:) , DIM=3 ) * r1_hu_n(:,:) 230 zv_frc(:,:) = SUM( e3v_n(:,:,:) * va(:,:,:) * vmask(:,:,:) , DIM=3 ) * r1_hv_n(:,:) 231 ! 232 ! 233 ! != Ua => baroclinic trend =! (remove its vertical mean) 234 DO jk = 1, jpkm1 ! ------------------------ ! 235 ua(:,:,jk) = ( ua(:,:,jk) - zu_frc(:,:) ) * umask(:,:,jk) 236 va(:,:,jk) = ( va(:,:,jk) - zv_frc(:,:) ) * vmask(:,:,jk) 378 237 END DO 379 238 … … 381 240 !!gm Is it correct to do so ? I think so... 382 241 383 384 ! !* barotropic Coriolis trends (vorticity scheme dependent) 385 ! ! -------------------------------------------------------- 386 ! 387 zwx(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:) ! now fluxes 388 zwy(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:) 389 ! 390 SELECT CASE( nvor_scheme ) 391 CASE( np_ENT ) ! enstrophy conserving scheme (f-point) 392 DO jj = 2, jpjm1 393 DO ji = 2, jpim1 ! vector opt. 394 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * r1_hu_n(ji,jj) & 395 & * ( e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) ) & 396 & + e1e2t(ji ,jj)*ht_n(ji ,jj)*ff_t(ji ,jj) * ( vn_b(ji ,jj) + vn_b(ji ,jj-1) ) ) 397 ! 398 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * r1_hv_n(ji,jj) & 399 & * ( e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) ) & 400 & + e1e2t(ji,jj )*ht_n(ji,jj )*ff_t(ji,jj ) * ( un_b(ji,jj ) + un_b(ji-1,jj ) ) ) 401 END DO 402 END DO 403 ! 404 CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX 405 DO jj = 2, jpjm1 406 DO ji = fs_2, fs_jpim1 ! vector opt. 407 zy1 = ( zwy(ji,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj) 408 zy2 = ( zwy(ji,jj ) + zwy(ji+1,jj ) ) * r1_e1u(ji,jj) 409 zx1 = ( zwx(ji-1,jj) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj) 410 zx2 = ( zwx(ji ,jj) + zwx(ji ,jj+1) ) * r1_e2v(ji,jj) 411 ! energy conserving formulation for planetary vorticity term 412 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 413 zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 414 END DO 415 END DO 416 ! 417 CASE( np_ENS ) ! enstrophy conserving scheme (f-point) 418 DO jj = 2, jpjm1 419 DO ji = fs_2, fs_jpim1 ! vector opt. 420 zy1 = r1_8 * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 421 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) * r1_e1u(ji,jj) 422 zx1 = - r1_8 * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 423 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) * r1_e2v(ji,jj) 424 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 425 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 426 END DO 427 END DO 428 ! 429 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 430 DO jj = 2, jpjm1 431 DO ji = fs_2, fs_jpim1 ! vector opt. 432 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zwy(ji ,jj ) & 433 & + ftnw(ji+1,jj) * zwy(ji+1,jj ) & 434 & + ftse(ji,jj ) * zwy(ji ,jj-1) & 435 & + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 436 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 437 & + ftse(ji,jj+1) * zwx(ji ,jj+1) & 438 & + ftnw(ji,jj ) * zwx(ji-1,jj ) & 439 & + ftne(ji,jj ) * zwx(ji ,jj ) ) 440 END DO 441 END DO 442 ! 443 END SELECT 444 ! 445 ! !* Right-Hand-Side of the barotropic momentum equation 446 ! ! ---------------------------------------------------- 447 IF( .NOT.ln_linssh ) THEN ! Variable volume : remove surface pressure gradient 448 IF( ln_wd_il ) THEN ! Calculating and applying W/D gravity filters 242 ! != remove 2D Coriolis and pressure gradient trends =! 243 ! ! ------------------------------------------------- ! 244 ! 245 IF( kt == nit000 .OR. .NOT. ln_linssh ) CALL dyn_cor_2D_init ! Set zwz, the barotropic Coriolis force coefficient 246 ! ! recompute zwz = f/depth at every time step for (.NOT.ln_linssh) as the water colomn height changes 247 ! 248 ! !* 2D Coriolis trends 249 zhU(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:) ! now fluxes 250 zhV(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:) ! NB: FULL domain : put a value in last row and column 251 ! 252 CALL dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV, & ! <<== in 253 & zu_trd, zv_trd ) ! ==>> out 254 ! 255 IF( .NOT.ln_linssh ) THEN !* surface pressure gradient (variable volume only) 256 ! 257 IF( ln_wd_il ) THEN ! W/D : limiter applied to spgspg 258 CALL wad_spg( sshn, zcpx, zcpy ) ! Calculating W/D gravity filters, zcpx and zcpy 449 259 DO jj = 2, jpjm1 450 DO ji = 2, jpim1 451 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 452 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & 453 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji+1,jj) + ht_0(ji+1,jj) ) & 454 & > rn_wdmin1 + rn_wdmin2 455 ll_tmp2 = ( ABS( sshn(ji+1,jj) - sshn(ji ,jj)) > 1.E-12 ).AND.( & 456 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 457 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 458 IF(ll_tmp1) THEN 459 zcpx(ji,jj) = 1.0_wp 460 ELSEIF(ll_tmp2) THEN 461 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 462 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 463 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 464 zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 465 ELSE 466 zcpx(ji,jj) = 0._wp 467 ENDIF 468 ! 469 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 470 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & 471 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji,jj+1) + ht_0(ji,jj+1) ) & 472 & > rn_wdmin1 + rn_wdmin2 473 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1)) > 1.E-12 ).AND.( & 474 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 475 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 476 477 IF(ll_tmp1) THEN 478 zcpy(ji,jj) = 1.0_wp 479 ELSE IF(ll_tmp2) THEN 480 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 481 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 482 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 483 zcpy(ji,jj) = MAX( 0._wp , MIN( zcpy(ji,jj) , 1.0_wp ) ) 484 ELSE 485 zcpy(ji,jj) = 0._wp 486 ENDIF 487 END DO 488 END DO 489 ! 490 DO jj = 2, jpjm1 491 DO ji = 2, jpim1 260 DO ji = 2, jpim1 ! SPG with the application of W/D gravity filters 492 261 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) & 493 262 & * r1_e1u(ji,jj) * zcpx(ji,jj) * wdrampu(ji,jj) !jth … … 496 265 END DO 497 266 END DO 498 ! 499 ELSE 500 ! 267 ELSE ! now suface pressure gradient 501 268 DO jj = 2, jpjm1 502 269 DO ji = fs_2, fs_jpim1 ! vector opt. … … 516 283 END DO 517 284 ! 518 ! ! Add bottom stress contribution from baroclinic velocities: 519 IF (ln_bt_fw) THEN 520 DO jj = 2, jpjm1 521 DO ji = fs_2, fs_jpim1 ! vector opt. 522 ikbu = mbku(ji,jj) 523 ikbv = mbkv(ji,jj) 524 zwx(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) ! NOW bottom baroclinic velocities 525 zwy(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 526 END DO 527 END DO 528 ELSE 529 DO jj = 2, jpjm1 530 DO ji = fs_2, fs_jpim1 ! vector opt. 531 ikbu = mbku(ji,jj) 532 ikbv = mbkv(ji,jj) 533 zwx(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) ! BEFORE bottom baroclinic velocities 534 zwy(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 535 END DO 536 END DO 537 ENDIF 538 ! 539 ! Note that the "unclipped" bottom friction parameter is used even with explicit drag 540 IF( ln_wd_il ) THEN 541 zztmp = -1._wp / rdtbt 542 DO jj = 2, jpjm1 543 DO ji = fs_2, fs_jpim1 ! vector opt. 544 zu_frc(ji,jj) = zu_frc(ji,jj) + & 545 & MAX(r1_hu_n(ji,jj) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ), zztmp ) * zwx(ji,jj) * wdrampu(ji,jj) 546 zv_frc(ji,jj) = zv_frc(ji,jj) + & 547 & MAX(r1_hv_n(ji,jj) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ), zztmp ) * zwy(ji,jj) * wdrampv(ji,jj) 548 END DO 549 END DO 550 ELSE 551 DO jj = 2, jpjm1 552 DO ji = fs_2, fs_jpim1 ! vector opt. 553 zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zwx(ji,jj) 554 zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zwy(ji,jj) 555 END DO 556 END DO 557 END IF 558 ! 559 IF( ln_isfcav ) THEN ! Add TOP stress contribution from baroclinic velocities: 560 IF( ln_bt_fw ) THEN 561 DO jj = 2, jpjm1 285 ! != Add bottom stress contribution from baroclinic velocities =! 286 ! ! ----------------------------------------------------------- ! 287 CALL dyn_drg_init( zu_frc, zv_frc, zCdU_u, zCdU_v ) ! also provide the barotropic drag coefficients 288 ! 289 ! != Add atmospheric pressure forcing =! 290 ! ! ---------------------------------- ! 291 IF( ln_apr_dyn ) THEN 292 IF( ln_bt_fw ) THEN ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) 293 DO jj = 2, jpjm1 562 294 DO ji = fs_2, fs_jpim1 ! vector opt. 563 iktu = miku(ji,jj) 564 iktv = mikv(ji,jj) 565 zwx(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) ! NOW top baroclinic velocities 566 zwy(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 567 END DO 568 END DO 569 ELSE 570 DO jj = 2, jpjm1 295 zu_frc(ji,jj) = zu_frc(ji,jj) + grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 296 zv_frc(ji,jj) = zv_frc(ji,jj) + grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 297 END DO 298 END DO 299 ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) 300 zztmp = grav * r1_2 301 DO jj = 2, jpjm1 571 302 DO ji = fs_2, fs_jpim1 ! vector opt. 572 iktu = miku(ji,jj) 573 iktv = mikv(ji,jj) 574 zwx(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) ! BEFORE top baroclinic velocities 575 zwy(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 576 END DO 577 END DO 578 ENDIF 579 ! 580 ! Note that the "unclipped" top friction parameter is used even with explicit drag 581 DO jj = 2, jpjm1 582 DO ji = fs_2, fs_jpim1 ! vector opt. 583 zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zwx(ji,jj) 584 zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zwy(ji,jj) 585 END DO 586 END DO 587 ENDIF 588 ! 303 zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & 304 & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) 305 zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & 306 & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) 307 END DO 308 END DO 309 ENDIF 310 ENDIF 311 ! 312 ! != Add atmospheric pressure forcing =! 313 ! ! ---------------------------------- ! 589 314 IF( ln_bt_fw ) THEN ! Add wind forcing 590 315 DO jj = 2, jpjm1 … … 604 329 ENDIF 605 330 ! 606 IF( ln_apr_dyn ) THEN ! Add atm pressure forcing 607 IF( ln_bt_fw ) THEN 608 DO jj = 2, jpjm1 609 DO ji = fs_2, fs_jpim1 ! vector opt. 610 zu_spg = grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 611 zv_spg = grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 612 zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 613 zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 614 END DO 615 END DO 616 ELSE 617 zztmp = grav * r1_2 618 DO jj = 2, jpjm1 619 DO ji = fs_2, fs_jpim1 ! vector opt. 620 zu_spg = zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & 621 & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) 622 zv_spg = zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & 623 & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) 624 zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 625 zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 626 END DO 627 END DO 628 ENDIF 629 ENDIF 630 ! !* Right-Hand-Side of the barotropic ssh equation 631 ! ! ----------------------------------------------- 632 ! ! Surface net water flux and rivers 633 IF (ln_bt_fw) THEN 634 zssh_frc(:,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 635 ELSE 331 ! !----------------! 332 ! !== sssh_frc ==! Right-Hand-Side of the barotropic ssh equation (over the FULL domain) 333 ! !----------------! 334 ! != Net water flux forcing applied to a water column =! 335 ! ! --------------------------------------------------- ! 336 IF (ln_bt_fw) THEN ! FORWARD integration: use kt+1/2 fluxes (NOW+1/2) 337 zssh_frc(:,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 338 ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) 636 339 zztmp = r1_rau0 * r1_2 637 zssh_frc(:,:) = zztmp * ( emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) & 638 & + fwfisf(:,:) + fwfisf_b(:,:) ) 639 ENDIF 640 ! 641 IF( ln_sdw ) THEN ! Stokes drift divergence added if necessary 340 zssh_frc(:,:) = zztmp * ( emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) + fwfisf(:,:) + fwfisf_b(:,:) ) 341 ENDIF 342 ! != Add Stokes drift divergence =! (if exist) 343 IF( ln_sdw ) THEN ! ----------------------------- ! 642 344 zssh_frc(:,:) = zssh_frc(:,:) + div_sd(:,:) 643 345 ENDIF 644 346 ! 645 347 #if defined key_asminc 646 ! ! Include the IAU weighted SSH increment 348 ! != Add the IAU weighted SSH increment =! 349 ! ! ------------------------------------ ! 647 350 IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 648 351 zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:) 649 352 ENDIF 650 353 #endif 651 ! ! *Fill boundary data arrays for AGRIF354 ! != Fill boundary data arrays for AGRIF 652 355 ! ! ------------------------------------ 653 356 #if defined key_agrif … … 671 374 vb_e (:,:) = 0._wp 672 375 ENDIF 673 376 ! 377 IF( ln_linssh ) THEN ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 378 zhup2_e(:,:) = hu_n(:,:) 379 zhvp2_e(:,:) = hv_n(:,:) 380 zhtp2_e(:,:) = ht_n(:,:) 381 ENDIF 674 382 ! 675 383 IF (ln_bt_fw) THEN ! FORWARD integration: start from NOW fields … … 693 401 ENDIF 694 402 ! 695 !696 !697 403 ! Initialize sums: 698 404 ua_b (:,:) = 0._wp ! After barotropic velocities (or transport if flux form) … … 714 420 ! 715 421 l_full_nf_update = jn == icycle ! false: disable full North fold update (performances) for jn = 1 to icycle-1 716 ! ! ------------------ 717 ! !* Update the forcing (BDY and tides) 718 ! ! ------------------ 719 ! Update only tidal forcing at open boundaries 720 IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, time_offset= noffset+1 ) 422 ! 423 ! !== Update the forcing ==! (BDY and tides) 424 ! 425 IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, kt_offset= noffset+1 ) 721 426 ! Update tide potential at the beginning of current time substep 722 427 IF( ln_tide_pot .AND. ln_tide ) THEN … … 725 430 END IF 726 431 ! 727 ! Set extrapolation coefficients for predictor step: 432 ! !== extrapolation at mid-step ==! (jn+1/2) 433 ! 434 ! !* Set extrapolation coefficients for predictor step: 728 435 IF ((jn<3).AND.ll_init) THEN ! Forward 729 436 za1 = 1._wp … … 735 442 za3 = 0.281105_wp ! za3 = bet 736 443 ENDIF 737 738 ! Extrapolate barotropic velocities at step jit+0.5: 444 ! 445 ! !* Extrapolate barotropic velocities at mid-step (jn+1/2) 446 !-- m+1/2 m m-1 m-2 --! 447 !-- u = (3/2+beta) u -(1/2+2beta) u + beta u --! 448 !-------------------------------------------------------------------------! 739 449 ua_e(:,:) = za1 * un_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:) 740 450 va_e(:,:) = za1 * vn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:) … … 743 453 ! ! ------------------ 744 454 ! Extrapolate Sea Level at step jit+0.5: 455 !-- m+1/2 m m-1 m-2 --! 456 !-- ssh = (3/2+beta) ssh -(1/2+2beta) ssh + beta ssh --! 457 !--------------------------------------------------------------------------------! 745 458 zsshp2_e(:,:) = za1 * sshn_e(:,:) + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 746 459 747 ! set wetting & drying mask at tracer points for this barotropic sub-step 748 IF ( ln_wd_dl ) THEN 749 ! 750 IF ( ln_wd_dl_rmp ) THEN 751 DO jj = 1, jpj 752 DO ji = 1, jpi ! vector opt. 753 IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN 754 ! IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN 755 ztwdmask(ji,jj) = 1._wp 756 ELSE IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN 757 ztwdmask(ji,jj) = (tanh(50._wp*( ( zsshp2_e(ji,jj) + ht_0(ji,jj) - rn_wdmin1 )*r_rn_wdmin1)) ) 758 ELSE 759 ztwdmask(ji,jj) = 0._wp 760 END IF 761 END DO 762 END DO 763 ELSE 764 DO jj = 1, jpj 765 DO ji = 1, jpi ! vector opt. 766 IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN 767 ztwdmask(ji,jj) = 1._wp 768 ELSE 769 ztwdmask(ji,jj) = 0._wp 770 ENDIF 771 END DO 772 END DO 773 ENDIF 774 ! 775 ENDIF 460 ! set wetting & drying mask at tracer points for this barotropic mid-step 461 IF( ln_wd_dl ) CALL wad_tmsk( zsshp2_e, ztwdmask ) 776 462 ! 777 DO jj = 2, jpjm1 ! Sea Surface Height at u- & v-points 778 DO ji = 2, fs_jpim1 ! Vector opt. 779 zwx(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 780 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 781 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) 782 zwy(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 783 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 784 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 785 END DO 786 END DO 787 CALL lbc_lnk_multi( 'dynspg_ts', zwx, 'U', 1._wp, zwy, 'V', 1._wp ) 463 ! ! ocean t-depth at mid-step 464 zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) 788 465 ! 789 zhup2_e(:,:) = hu_0(:,:) + zwx(:,:) ! Ocean depth at U- and V-points 790 zhvp2_e(:,:) = hv_0(:,:) + zwy(:,:) 791 zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) 792 ELSE 793 zhup2_e(:,:) = hu_n(:,:) 794 zhvp2_e(:,:) = hv_n(:,:) 795 zhtp2_e(:,:) = ht_n(:,:) 796 ENDIF 797 ! !* after ssh 798 ! ! ----------- 799 ! 800 ! Enforce volume conservation at open boundaries: 466 ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) 467 DO jj = 1, jpj 468 DO ji = 1, jpim1 ! not jpi-column 469 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 470 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 471 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 472 END DO 473 END DO 474 DO jj = 1, jpjm1 ! not jpj-row 475 DO ji = 1, jpi 476 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 477 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 478 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 479 END DO 480 END DO 481 ! 482 ENDIF 483 ! 484 ! !== after SSH ==! (jn+1) 485 ! 486 ! ! update (ua_e,va_e) to enforce volume conservation at open boundaries 487 ! ! values of zhup2_e and zhvp2_e on the halo are not needed in bdy_vol2d 801 488 IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jn, ua_e, va_e, zhup2_e, zhvp2_e ) 802 489 ! 803 zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:) ! fluxes at jn+0.5 804 zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 490 ! ! resulting flux at mid-step (not over the full domain) 491 zhU(1:jpim1,1:jpj ) = e2u(1:jpim1,1:jpj ) * ua_e(1:jpim1,1:jpj ) * zhup2_e(1:jpim1,1:jpj ) ! not jpi-column 492 zhV(1:jpi ,1:jpjm1) = e1v(1:jpi ,1:jpjm1) * va_e(1:jpi ,1:jpjm1) * zhvp2_e(1:jpi ,1:jpjm1) ! not jpj-row 805 493 ! 806 494 #if defined key_agrif … … 809 497 IF((nbondi == -1).OR.(nbondi == 2)) THEN 810 498 DO jj = 1, jpj 811 z wx(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj)812 z wy(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj)499 zhU(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj) 500 zhV(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj) 813 501 END DO 814 502 ENDIF 815 503 IF((nbondi == 1).OR.(nbondi == 2)) THEN 816 504 DO jj=1,jpj 817 z wx(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj)818 z wy(nlci-nbghostcells :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells :nlci-1,jj)505 zhU(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 506 zhV(nlci-nbghostcells :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells :nlci-1,jj) 819 507 END DO 820 508 ENDIF 821 509 IF((nbondj == -1).OR.(nbondj == 2)) THEN 822 510 DO ji=1,jpi 823 z wy(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1)824 z wx(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1)511 zhV(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1) 512 zhU(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1) 825 513 END DO 826 514 ENDIF 827 515 IF((nbondj == 1).OR.(nbondj == 2)) THEN 828 516 DO ji=1,jpi 829 z wy(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2)830 z wx(ji,nlcj-nbghostcells :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells :nlcj-1)517 zhV(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 518 zhU(ji,nlcj-nbghostcells :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells :nlcj-1) 831 519 END DO 832 520 ENDIF 833 521 ENDIF 834 522 #endif 835 IF( ln_wd_il ) CALL wad_lmt_bt(zwx, zwy, sshn_e, zssh_frc, rdtbt) 836 837 IF ( ln_wd_dl ) THEN 838 ! 839 ! un_e and vn_e are set to zero at faces where the direction of the flow is from dry cells 840 ! 841 DO jj = 1, jpjm1 842 DO ji = 1, jpim1 843 IF ( zwx(ji,jj) > 0.0 ) THEN 844 zuwdmask(ji, jj) = ztwdmask(ji ,jj) 845 ELSE 846 zuwdmask(ji, jj) = ztwdmask(ji+1,jj) 847 END IF 848 zwx(ji, jj) = zuwdmask(ji,jj)*zwx(ji, jj) 849 un_e(ji,jj) = zuwdmask(ji,jj)*un_e(ji,jj) 850 851 IF ( zwy(ji,jj) > 0.0 ) THEN 852 zvwdmask(ji, jj) = ztwdmask(ji, jj ) 853 ELSE 854 zvwdmask(ji, jj) = ztwdmask(ji, jj+1) 855 END IF 856 zwy(ji, jj) = zvwdmask(ji,jj)*zwy(ji,jj) 857 vn_e(ji,jj) = zvwdmask(ji,jj)*vn_e(ji,jj) 858 END DO 859 END DO 523 IF( ln_wd_il ) CALL wad_lmt_bt(zhU, zhV, sshn_e, zssh_frc, rdtbt) !!gm wad_lmt_bt use of lbc_lnk on zhU, zhV 524 525 IF( ln_wd_dl ) THEN ! un_e and vn_e are set to zero at faces where 526 ! ! the direction of the flow is from dry cells 527 CALL wad_Umsk( ztwdmask, zhU, zhV, un_e, vn_e, zuwdmask, zvwdmask ) ! not jpi colomn for U, not jpj row for V 860 528 ! 861 529 ENDIF 862 863 ! Sum over sub-time-steps to compute advective velocities 864 za2 = wgtbtp2(jn) 865 un_adv(:,:) = un_adv(:,:) + za2 * zwx(:,:) * r1_e2u(:,:) 866 vn_adv(:,:) = vn_adv(:,:) + za2 * zwy(:,:) * r1_e1v(:,:) 867 868 ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc = True) 530 ! 531 ! 532 ! Compute Sea Level at step jit+1 533 !-- m+1 m m+1/2 --! 534 !-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --! 535 !-------------------------------------------------------------------------! 536 DO jj = 2, jpjm1 ! INNER domain 537 DO ji = 2, jpim1 538 zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t(ji,jj) 539 ssha_e(ji,jj) = ( sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj) 540 END DO 541 END DO 542 ! 543 CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp ) 544 ! 545 ! ! Sum over sub-time-steps to compute advective velocities 546 za2 = wgtbtp2(jn) ! zhU, zhV hold fluxes extrapolated at jn+0.5 547 un_adv(:,:) = un_adv(:,:) + za2 * zhU(:,:) * r1_e2u(:,:) 548 vn_adv(:,:) = vn_adv(:,:) + za2 * zhV(:,:) * r1_e1v(:,:) 549 ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc=True) 869 550 IF ( ln_wd_dl_bc ) THEN 870 zuwdav2(:,:) = zuwdav2(:,:) + za2 * zuwdmask(:,:) 871 zvwdav2(:,:) = zvwdav2(:,:) + za2 * zvwdmask(:,:) 872 END IF 873 874 ! Set next sea level: 875 DO jj = 2, jpjm1 876 DO ji = fs_2, fs_jpim1 ! vector opt. 877 zhdiv(ji,jj) = ( zwx(ji,jj) - zwx(ji-1,jj) & 878 & + zwy(ji,jj) - zwy(ji,jj-1) ) * r1_e1e2t(ji,jj) 879 END DO 880 END DO 881 ssha_e(:,:) = ( sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) ) ) * ssmask(:,:) 882 883 CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T', 1._wp ) 884 551 zuwdav2(1:jpim1,1:jpj ) = zuwdav2(1:jpim1,1:jpj ) + za2 * zuwdmask(1:jpim1,1:jpj ) ! not jpi-column 552 zvwdav2(1:jpi ,1:jpjm1) = zvwdav2(1:jpi ,1:jpjm1) + za2 * zvwdmask(1:jpi ,1:jpjm1) ! not jpj-row 553 END IF 554 ! 885 555 ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) 886 556 IF( ln_bdy ) CALL bdy_ssh( ssha_e ) … … 891 561 ! Sea Surface Height at u-,v-points (vvl case only) 892 562 IF( .NOT.ln_linssh ) THEN 893 DO jj = 2, jpjm1 563 DO jj = 2, jpjm1 ! INNER domain, will be extended to whole domain later 894 564 DO ji = 2, jpim1 ! NO Vector Opt. 895 565 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & … … 901 571 END DO 902 572 END DO 903 CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp )904 573 ENDIF 905 ! 906 ! Half-step back interpolation of SSH for surface pressure computation: 907 !---------------------------------------------------------------------- 908 IF ((jn==1).AND.ll_init) THEN 909 za0=1._wp ! Forward-backward 910 za1=0._wp 911 za2=0._wp 912 za3=0._wp 913 ELSEIF ((jn==2).AND.ll_init) THEN ! AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 914 za0= 1.0833333333333_wp ! za0 = 1-gam-eps 915 za1=-0.1666666666666_wp ! za1 = gam 916 za2= 0.0833333333333_wp ! za2 = eps 917 za3= 0._wp 918 ELSE ! AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880 919 IF (rn_bt_alpha==0._wp) THEN 920 za0=0.614_wp ! za0 = 1/2 + gam + 2*eps 921 za1=0.285_wp ! za1 = 1/2 - 2*gam - 3*eps 922 za2=0.088_wp ! za2 = gam 923 za3=0.013_wp ! za3 = eps 924 ELSE 925 zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha 926 zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha 927 za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon 928 za1 = 1._wp - za0 - zgamma - zepsilon 929 za2 = zgamma 930 za3 = zepsilon 931 ENDIF 932 ENDIF 933 ! 574 ! 575 ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 576 !-- m+1/2 m+1 m m-1 m-2 --! 577 !-- ssh' = za0 * ssh + za1 * ssh + za2 * ssh + za3 * ssh --! 578 !------------------------------------------------------------------------------------------! 579 CALL ts_bck_interp( jn, ll_init, za0, za1, za2, za3 ) ! coeficients of the interpolation 934 580 zsshp2_e(:,:) = za0 * ssha_e(:,:) + za1 * sshn_e (:,:) & 935 581 & + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 936 937 IF( ln_wd_il ) THEN ! Calculating and applying W/D gravity filters 938 DO jj = 2, jpjm1 939 DO ji = 2, jpim1 940 ll_tmp1 = MIN( zsshp2_e(ji,jj) , zsshp2_e(ji+1,jj) ) > & 941 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & 942 & MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji+1,jj) + ht_0(ji+1,jj) ) & 943 & > rn_wdmin1 + rn_wdmin2 944 ll_tmp2 = (ABS(zsshp2_e(ji,jj) - zsshp2_e(ji+1,jj)) > 1.E-12 ).AND.( & 945 & MAX( zsshp2_e(ji,jj) , zsshp2_e(ji+1,jj) ) > & 946 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 947 948 IF(ll_tmp1) THEN 949 zcpx(ji,jj) = 1.0_wp 950 ELSE IF(ll_tmp2) THEN 951 ! no worries about zsshp2_e(ji+1,jj) - zsshp2_e(ji ,jj) = 0, it won't happen ! here 952 zcpx(ji,jj) = ABS( (zsshp2_e(ji+1,jj) + ht_0(ji+1,jj) - zsshp2_e(ji,jj) - ht_0(ji,jj)) & 953 & / (zsshp2_e(ji+1,jj) - zsshp2_e(ji ,jj)) ) 954 ELSE 955 zcpx(ji,jj) = 0._wp 956 ENDIF 957 ! 958 ll_tmp1 = MIN( zsshp2_e(ji,jj) , zsshp2_e(ji,jj+1) ) > & 959 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & 960 & MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji,jj+1) + ht_0(ji,jj+1) ) & 961 & > rn_wdmin1 + rn_wdmin2 962 ll_tmp2 = (ABS(zsshp2_e(ji,jj) - zsshp2_e(ji,jj+1)) > 1.E-12 ).AND.( & 963 & MAX( zsshp2_e(ji,jj) , zsshp2_e(ji,jj+1) ) > & 964 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 965 966 IF(ll_tmp1) THEN 967 zcpy(ji,jj) = 1.0_wp 968 ELSEIF(ll_tmp2) THEN 969 ! no worries about zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj ) = 0, it won't happen ! here 970 zcpy(ji,jj) = ABS( (zsshp2_e(ji,jj+1) + ht_0(ji,jj+1) - zsshp2_e(ji,jj) - ht_0(ji,jj)) & 971 & / (zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj )) ) 972 ELSE 973 zcpy(ji,jj) = 0._wp 974 ENDIF 975 END DO 976 END DO 977 ENDIF 978 ! 979 ! Compute associated depths at U and V points: 980 IF( .NOT.ln_linssh .AND. .NOT.ln_dynadv_vec ) THEN !* Vector form 981 ! 982 DO jj = 2, jpjm1 983 DO ji = 2, jpim1 984 zx1 = r1_2 * ssumask(ji ,jj) * r1_e1e2u(ji ,jj) & 985 & * ( e1e2t(ji ,jj ) * zsshp2_e(ji ,jj) & 986 & + e1e2t(ji+1,jj ) * zsshp2_e(ji+1,jj ) ) 987 zy1 = r1_2 * ssvmask(ji ,jj) * r1_e1e2v(ji ,jj ) & 988 & * ( e1e2t(ji ,jj ) * zsshp2_e(ji ,jj ) & 989 & + e1e2t(ji ,jj+1) * zsshp2_e(ji ,jj+1) ) 990 zhust_e(ji,jj) = hu_0(ji,jj) + zx1 991 zhvst_e(ji,jj) = hv_0(ji,jj) + zy1 992 END DO 993 END DO 994 ! 582 ! 583 ! ! Surface pressure gradient 584 zldg = ( 1._wp - rn_scal_load ) * grav ! local factor 585 DO jj = 2, jpjm1 586 DO ji = 2, jpim1 587 zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 588 zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 589 END DO 590 END DO 591 IF( ln_wd_il ) THEN ! W/D : gravity filters applied on pressure gradient 592 CALL wad_spg( zsshp2_e, zcpx, zcpy ) ! Calculating W/D gravity filters 593 zu_spg(2:jpim1,2:jpjm1) = zu_spg(2:jpim1,2:jpjm1) * zcpx(2:jpim1,2:jpjm1) 594 zv_spg(2:jpim1,2:jpjm1) = zv_spg(2:jpim1,2:jpjm1) * zcpy(2:jpim1,2:jpjm1) 995 595 ENDIF 996 596 ! … … 998 598 ! zwz array below or triads normally depend on sea level with ln_linssh=F and should be updated 999 599 ! at each time step. We however keep them constant here for optimization. 1000 ! Recall that zwx and zwy arrays hold fluxes at this stage: 1001 ! zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:) ! fluxes at jn+0.5 1002 ! zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 1003 ! 1004 SELECT CASE( nvor_scheme ) 1005 CASE( np_ENT ) ! energy conserving scheme (t-point) 1006 DO jj = 2, jpjm1 1007 DO ji = 2, jpim1 ! vector opt. 1008 1009 z1_hu = ssumask(ji,jj) / ( zhup2_e(ji,jj) + 1._wp - ssumask(ji,jj) ) 1010 z1_hv = ssvmask(ji,jj) / ( zhvp2_e(ji,jj) + 1._wp - ssvmask(ji,jj) ) 1011 1012 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & 1013 & * ( e1e2t(ji+1,jj)*zhtp2_e(ji+1,jj)*ff_t(ji+1,jj) * ( va_e(ji+1,jj) + va_e(ji+1,jj-1) ) & 1014 & + e1e2t(ji ,jj)*zhtp2_e(ji ,jj)*ff_t(ji ,jj) * ( va_e(ji ,jj) + va_e(ji ,jj-1) ) ) 1015 ! 1016 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & 1017 & * ( e1e2t(ji,jj+1)*zhtp2_e(ji,jj+1)*ff_t(ji,jj+1) * ( ua_e(ji,jj+1) + ua_e(ji-1,jj+1) ) & 1018 & + e1e2t(ji,jj )*zhtp2_e(ji,jj )*ff_t(ji,jj ) * ( ua_e(ji,jj ) + ua_e(ji-1,jj ) ) ) 1019 END DO 1020 END DO 1021 ! 1022 CASE( np_ENE, np_MIX ) ! energy conserving scheme (f-point) 1023 DO jj = 2, jpjm1 1024 DO ji = fs_2, fs_jpim1 ! vector opt. 1025 zy1 = ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj) 1026 zy2 = ( zwy(ji ,jj ) + zwy(ji+1,jj ) ) * r1_e1u(ji,jj) 1027 zx1 = ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj) 1028 zx2 = ( zwx(ji ,jj ) + zwx(ji ,jj+1) ) * r1_e2v(ji,jj) 1029 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 1030 zv_trd(ji,jj) =-r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 1031 END DO 1032 END DO 1033 ! 1034 CASE( np_ENS ) ! enstrophy conserving scheme (f-point) 1035 DO jj = 2, jpjm1 1036 DO ji = fs_2, fs_jpim1 ! vector opt. 1037 zy1 = r1_8 * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 1038 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) * r1_e1u(ji,jj) 1039 zx1 = - r1_8 * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 1040 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) * r1_e2v(ji,jj) 1041 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 1042 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 1043 END DO 1044 END DO 1045 ! 1046 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 1047 DO jj = 2, jpjm1 1048 DO ji = fs_2, fs_jpim1 ! vector opt. 1049 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zwy(ji ,jj ) & 1050 & + ftnw(ji+1,jj) * zwy(ji+1,jj ) & 1051 & + ftse(ji,jj ) * zwy(ji ,jj-1) & 1052 & + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 1053 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 1054 & + ftse(ji,jj+1) * zwx(ji ,jj+1) & 1055 & + ftnw(ji,jj ) * zwx(ji-1,jj ) & 1056 & + ftne(ji,jj ) * zwx(ji ,jj ) ) 1057 END DO 1058 END DO 1059 ! 1060 END SELECT 600 ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) 601 CALL dyn_cor_2d( zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd ) 1061 602 ! 1062 603 ! Add tidal astronomical forcing if defined … … 1064 605 DO jj = 2, jpjm1 1065 606 DO ji = fs_2, fs_jpim1 ! vector opt. 1066 zu_spg = grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 1067 zv_spg = grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 1068 zu_trd(ji,jj) = zu_trd(ji,jj) + zu_spg 1069 zv_trd(ji,jj) = zv_trd(ji,jj) + zv_spg 607 zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 608 zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 1070 609 END DO 1071 610 END DO … … 1081 620 END DO 1082 621 END DO 1083 ENDIF 1084 ! 1085 ! Surface pressure trend: 1086 IF( ln_wd_il ) THEN 1087 DO jj = 2, jpjm1 1088 DO ji = 2, jpim1 1089 ! Add surface pressure gradient 1090 zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 1091 zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 1092 zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg * zcpx(ji,jj) 1093 zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg * zcpy(ji,jj) 1094 END DO 1095 END DO 1096 ELSE 1097 DO jj = 2, jpjm1 1098 DO ji = fs_2, fs_jpim1 ! vector opt. 1099 ! Add surface pressure gradient 1100 zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 1101 zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 1102 zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg 1103 zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg 1104 END DO 1105 END DO 1106 END IF 1107 622 ENDIF 1108 623 ! 1109 624 ! Set next velocities: 625 ! Compute barotropic speeds at step jit+1 (h : total height of the water colomn) 626 !-- VECTOR FORM 627 !-- m+1 m / m+1/2 \ --! 628 !-- u = u + delta_t' * \ (1-r)*g * grad_x( ssh') - f * k vect u + frc / --! 629 !-- --! 630 !-- FLUX FORM --! 631 !-- m+1 __1__ / m m / m+1/2 m+1/2 m+1/2 n \ \ --! 632 !-- u = m+1 | h * u + delta_t' * \ h * (1-r)*g * grad_x( ssh') - h * f * k vect u + h * frc / | --! 633 !-- h \ / --! 634 !------------------------------------------------------------------------------------------------------------------------! 1110 635 IF( ln_dynadv_vec .OR. ln_linssh ) THEN !* Vector form 1111 636 DO jj = 2, jpjm1 1112 637 DO ji = fs_2, fs_jpim1 ! vector opt. 1113 638 ua_e(ji,jj) = ( un_e(ji,jj) & 1114 & + rdtbt * ( zwx(ji,jj) &639 & + rdtbt * ( zu_spg(ji,jj) & 1115 640 & + zu_trd(ji,jj) & 1116 641 & + zu_frc(ji,jj) ) & … … 1118 643 1119 644 va_e(ji,jj) = ( vn_e(ji,jj) & 1120 & + rdtbt * ( zwy(ji,jj) &645 & + rdtbt * ( zv_spg(ji,jj) & 1121 646 & + zv_trd(ji,jj) & 1122 647 & + zv_frc(ji,jj) ) & 1123 648 & ) * ssvmask(ji,jj) 1124 1125 649 END DO 1126 650 END DO … … 1128 652 ELSE !* Flux form 1129 653 DO jj = 2, jpjm1 1130 DO ji = fs_2, fs_jpim1 ! vector opt. 1131 1132 zhura = hu_0(ji,jj) + zsshu_a(ji,jj) 1133 zhvra = hv_0(ji,jj) + zsshv_a(ji,jj) 1134 1135 zhura = ssumask(ji,jj)/(zhura + 1._wp - ssumask(ji,jj)) 1136 zhvra = ssvmask(ji,jj)/(zhvra + 1._wp - ssvmask(ji,jj)) 1137 1138 ua_e(ji,jj) = ( hu_e(ji,jj) * un_e(ji,jj) & 1139 & + rdtbt * ( zhust_e(ji,jj) * zwx(ji,jj) & 1140 & + zhup2_e(ji,jj) * zu_trd(ji,jj) & 1141 & + hu_n(ji,jj) * zu_frc(ji,jj) ) & 1142 & ) * zhura 1143 1144 va_e(ji,jj) = ( hv_e(ji,jj) * vn_e(ji,jj) & 1145 & + rdtbt * ( zhvst_e(ji,jj) * zwy(ji,jj) & 1146 & + zhvp2_e(ji,jj) * zv_trd(ji,jj) & 1147 & + hv_n(ji,jj) * zv_frc(ji,jj) ) & 1148 & ) * zhvra 654 DO ji = 2, jpim1 655 ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 656 ! ! backward interpolated depth used in spg terms at jn+1/2 657 zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 658 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 659 zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 660 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 661 ! ! inverse depth at jn+1 662 z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 663 z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 664 ! 665 ua_e(ji,jj) = ( hu_e (ji,jj) * un_e (ji,jj) & 666 & + rdtbt * ( zhu_bck * zu_spg (ji,jj) & ! 667 & + zhup2_e(ji,jj) * zu_trd (ji,jj) & ! 668 & + hu_n (ji,jj) * zu_frc (ji,jj) ) ) * z1_hu 669 ! 670 va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj) & 671 & + rdtbt * ( zhv_bck * zv_spg (ji,jj) & ! 672 & + zhvp2_e(ji,jj) * zv_trd (ji,jj) & ! 673 & + hv_n (ji,jj) * zv_frc (ji,jj) ) ) * z1_hv 1149 674 END DO 1150 675 END DO … … 1159 684 END DO 1160 685 ENDIF 1161 1162 1163 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 1164 hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 1165 hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 1166 hur_e(:,:) = ssumask(:,:) / ( hu_e(:,:) + 1._wp - ssumask(:,:) ) 1167 hvr_e(:,:) = ssvmask(:,:) / ( hv_e(:,:) + 1._wp - ssvmask(:,:) ) 1168 ! 1169 ENDIF 1170 ! !* domain lateral boundary 1171 CALL lbc_lnk_multi( 'dynspg_ts', ua_e, 'U', -1._wp, va_e , 'V', -1._wp ) 686 687 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 688 hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 689 hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 690 hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 691 hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 692 CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & 693 & , hu_e , 'U', -1._wp, hv_e , 'V', -1._wp & 694 & , hur_e, 'U', -1._wp, hvr_e, 'V', -1._wp ) 695 ELSE 696 CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp ) 697 ENDIF 698 ! 1172 699 ! 1173 700 ! ! open boundaries … … 1217 744 ! Set advection velocity correction: 1218 745 IF (ln_bt_fw) THEN 1219 zwx(:,:) = un_adv(:,:)1220 zwy(:,:) = vn_adv(:,:)1221 746 IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN 1222 un_adv(:,:) = r1_2 * ( ub2_b(:,:) + zwx(:,:) - atfp * un_bf(:,:) ) 1223 vn_adv(:,:) = r1_2 * ( vb2_b(:,:) + zwy(:,:) - atfp * vn_bf(:,:) ) 1224 ! 1225 ! Update corrective fluxes for next time step: 1226 un_bf(:,:) = atfp * un_bf(:,:) + (zwx(:,:) - ub2_b(:,:)) 1227 vn_bf(:,:) = atfp * vn_bf(:,:) + (zwy(:,:) - vb2_b(:,:)) 747 DO jj = 1, jpj 748 DO ji = 1, jpi 749 zun_save = un_adv(ji,jj) 750 zvn_save = vn_adv(ji,jj) 751 ! ! apply the previously computed correction 752 un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 753 vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 754 ! ! Update corrective fluxes for next time step 755 un_bf(ji,jj) = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 756 vn_bf(ji,jj) = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 757 ! ! Save integrated transport for next computation 758 ub2_b(ji,jj) = zun_save 759 vb2_b(ji,jj) = zvn_save 760 END DO 761 END DO 1228 762 ELSE 1229 un_bf(:,:) = 0._wp 1230 vn_bf(:,:) = 0._wp 1231 END IF 1232 ! Save integrated transport for next computation 1233 ub2_b(:,:) = zwx(:,:) 1234 vb2_b(:,:) = zwy(:,:) 763 un_bf(:,:) = 0._wp ! corrective fluxes for next time step set to zero 764 vn_bf(:,:) = 0._wp 765 ub2_b(:,:) = un_adv(:,:) ! Save integrated transport for next computation 766 vb2_b(:,:) = vn_adv(:,:) 767 END IF 1235 768 ENDIF 1236 769 … … 1274 807 1275 808 IF ( ln_wd_dl .and. ln_wd_dl_bc) THEN 809 ! need to set lbc here because not done prior time averaging 810 CALL lbc_lnk_multi( 'dynspg_ts', zuwdav2, 'U', 1._wp, zvwdav2, 'V', 1._wp) 1276 811 DO jk = 1, jpkm1 1277 812 un(:,:,jk) = ( un_adv(:,:)*r1_hu_n(:,:) & … … 1477 1012 REAL(wp) :: zxr2, zyr2, zcmax ! local scalar 1478 1013 REAL(wp), DIMENSION(jpi,jpj) :: zcu 1014 INTEGER :: inum 1479 1015 !!---------------------------------------------------------------------- 1480 1016 ! … … 1583 1119 END SUBROUTINE dyn_spg_ts_init 1584 1120 1121 1122 SUBROUTINE dyn_cor_2d_init 1123 !!--------------------------------------------------------------------- 1124 !! *** ROUTINE dyn_cor_2d_init *** 1125 !! 1126 !! ** Purpose : Set time splitting options 1127 !! Set arrays to remove/compute coriolis trend. 1128 !! Do it once during initialization if volume is fixed, else at each long time step. 1129 !! Note that these arrays are also used during barotropic loop. These are however frozen 1130 !! although they should be updated in the variable volume case. Not a big approximation. 1131 !! To remove this approximation, copy lines below inside barotropic loop 1132 !! and update depths at T-F points (ht and zhf resp.) at each barotropic time step 1133 !! 1134 !! Compute zwz = f / ( height of the water colomn ) 1135 !!---------------------------------------------------------------------- 1136 INTEGER :: ji ,jj, jk ! dummy loop indices 1137 REAL(wp) :: z1_ht 1138 REAL(wp), DIMENSION(jpi,jpj) :: zhf 1139 !!---------------------------------------------------------------------- 1140 ! 1141 SELECT CASE( nvor_scheme ) 1142 CASE( np_EEN ) != EEN scheme using e3f (energy & enstrophy scheme) 1143 SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point 1144 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 1145 DO jj = 1, jpjm1 1146 DO ji = 1, jpim1 1147 zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + & 1148 & ht_n(ji ,jj ) + ht_n(ji+1,jj ) ) * 0.25_wp 1149 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1150 END DO 1151 END DO 1152 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 1153 DO jj = 1, jpjm1 1154 DO ji = 1, jpim1 1155 zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) & 1156 & + ht_n (ji ,jj ) + ht_n (ji+1,jj ) ) & 1157 & / ( MAX( 1._wp, ssmask(ji ,jj+1) + ssmask(ji+1,jj+1) & 1158 & + ssmask(ji ,jj ) + ssmask(ji+1,jj ) ) ) 1159 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1160 END DO 1161 END DO 1162 END SELECT 1163 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 1164 ! 1165 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1166 DO jj = 2, jpj 1167 DO ji = 2, jpi 1168 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) 1169 ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) 1170 ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1) 1171 ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj ) 1172 END DO 1173 END DO 1174 ! 1175 CASE( np_EET ) != EEN scheme using e3t (energy conserving scheme) 1176 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1177 DO jj = 2, jpj 1178 DO ji = 2, jpi 1179 z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 1180 ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht 1181 ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht 1182 ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 1183 ftsw(ji,jj) = ( ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) ) * z1_ht 1184 END DO 1185 END DO 1186 ! 1187 CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT ! 1188 ! 1189 zwz(:,:) = 0._wp 1190 zhf(:,:) = 0._wp 1191 1192 !!gm assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed 1193 !!gm A priori a better value should be something like : 1194 !!gm zhf(i,j) = masked sum of ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1) 1195 !!gm divided by the sum of the corresponding mask 1196 !!gm 1197 !! 1198 IF( .NOT.ln_sco ) THEN 1199 1200 !!gm agree the JC comment : this should be done in a much clear way 1201 1202 ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case 1203 ! Set it to zero for the time being 1204 ! IF( rn_hmin < 0._wp ) THEN ; jk = - INT( rn_hmin ) ! from a nb of level 1205 ! ELSE ; jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth 1206 ! ENDIF 1207 ! zhf(:,:) = gdepw_0(:,:,jk+1) 1208 ! 1209 ELSE 1210 ! 1211 !zhf(:,:) = hbatf(:,:) 1212 DO jj = 1, jpjm1 1213 DO ji = 1, jpim1 1214 zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) & 1215 & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) & 1216 & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) & 1217 & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp ) 1218 END DO 1219 END DO 1220 ENDIF 1221 ! 1222 DO jj = 1, jpjm1 1223 zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 1224 END DO 1225 ! 1226 DO jk = 1, jpkm1 1227 DO jj = 1, jpjm1 1228 zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 1229 END DO 1230 END DO 1231 CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 1232 ! JC: TBC. hf should be greater than 0 1233 DO jj = 1, jpj 1234 DO ji = 1, jpi 1235 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj) 1236 END DO 1237 END DO 1238 zwz(:,:) = ff_f(:,:) * zwz(:,:) 1239 END SELECT 1240 1241 END SUBROUTINE dyn_cor_2d_init 1242 1243 1244 1245 SUBROUTINE dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV, zu_trd, zv_trd ) 1246 !!--------------------------------------------------------------------- 1247 !! *** ROUTINE dyn_cor_2d *** 1248 !! 1249 !! ** Purpose : Compute u and v coriolis trends 1250 !!---------------------------------------------------------------------- 1251 INTEGER :: ji ,jj ! dummy loop indices 1252 REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - - 1253 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: hu_n, hv_n, un_b, vn_b, zhU, zhV 1254 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd 1255 !!---------------------------------------------------------------------- 1256 SELECT CASE( nvor_scheme ) 1257 CASE( np_ENT ) ! enstrophy conserving scheme (f-point) 1258 DO jj = 2, jpjm1 1259 DO ji = 2, jpim1 1260 z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) 1261 z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) 1262 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & 1263 & * ( e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) ) & 1264 & + e1e2t(ji ,jj)*ht_n(ji ,jj)*ff_t(ji ,jj) * ( vn_b(ji ,jj) + vn_b(ji ,jj-1) ) ) 1265 ! 1266 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & 1267 & * ( e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) ) & 1268 & + e1e2t(ji,jj )*ht_n(ji,jj )*ff_t(ji,jj ) * ( un_b(ji,jj ) + un_b(ji-1,jj ) ) ) 1269 END DO 1270 END DO 1271 ! 1272 CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX 1273 DO jj = 2, jpjm1 1274 DO ji = fs_2, fs_jpim1 ! vector opt. 1275 zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 1276 zy2 = ( zhV(ji,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) 1277 zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 1278 zx2 = ( zhU(ji ,jj) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) 1279 ! energy conserving formulation for planetary vorticity term 1280 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 1281 zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 1282 END DO 1283 END DO 1284 ! 1285 CASE( np_ENS ) ! enstrophy conserving scheme (f-point) 1286 DO jj = 2, jpjm1 1287 DO ji = fs_2, fs_jpim1 ! vector opt. 1288 zy1 = r1_8 * ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) & 1289 & + zhV(ji ,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) 1290 zx1 = - r1_8 * ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) & 1291 & + zhU(ji ,jj ) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) 1292 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 1293 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 1294 END DO 1295 END DO 1296 ! 1297 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 1298 DO jj = 2, jpjm1 1299 DO ji = fs_2, fs_jpim1 ! vector opt. 1300 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zhV(ji ,jj ) & 1301 & + ftnw(ji+1,jj) * zhV(ji+1,jj ) & 1302 & + ftse(ji,jj ) * zhV(ji ,jj-1) & 1303 & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 1304 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 1305 & + ftse(ji,jj+1) * zhU(ji ,jj+1) & 1306 & + ftnw(ji,jj ) * zhU(ji-1,jj ) & 1307 & + ftne(ji,jj ) * zhU(ji ,jj ) ) 1308 END DO 1309 END DO 1310 ! 1311 END SELECT 1312 ! 1313 END SUBROUTINE dyn_cor_2D 1314 1315 1316 SUBROUTINE wad_tmsk( pssh, ptmsk ) 1317 !!---------------------------------------------------------------------- 1318 !! *** ROUTINE wad_lmt *** 1319 !! 1320 !! ** Purpose : set wetting & drying mask at tracer points 1321 !! for the current barotropic sub-step 1322 !! 1323 !! ** Method : ??? 1324 !! 1325 !! ** Action : ptmsk : wetting & drying t-mask 1326 !!---------------------------------------------------------------------- 1327 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh ! 1328 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: ptmsk ! 1329 ! 1330 INTEGER :: ji, jj ! dummy loop indices 1331 !!---------------------------------------------------------------------- 1332 ! 1333 IF( ln_wd_dl_rmp ) THEN 1334 DO jj = 1, jpj 1335 DO ji = 1, jpi 1336 IF ( pssh(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN 1337 ! IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN 1338 ptmsk(ji,jj) = 1._wp 1339 ELSEIF( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN 1340 ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) - rn_wdmin1 )*r_rn_wdmin1) ) 1341 ELSE 1342 ptmsk(ji,jj) = 0._wp 1343 ENDIF 1344 END DO 1345 END DO 1346 ELSE 1347 DO jj = 1, jpj 1348 DO ji = 1, jpi 1349 IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN ; ptmsk(ji,jj) = 1._wp 1350 ELSE ; ptmsk(ji,jj) = 0._wp 1351 ENDIF 1352 END DO 1353 END DO 1354 ENDIF 1355 ! 1356 END SUBROUTINE wad_tmsk 1357 1358 1359 SUBROUTINE wad_Umsk( pTmsk, phU, phV, pu, pv, pUmsk, pVmsk ) 1360 !!---------------------------------------------------------------------- 1361 !! *** ROUTINE wad_lmt *** 1362 !! 1363 !! ** Purpose : set wetting & drying mask at tracer points 1364 !! for the current barotropic sub-step 1365 !! 1366 !! ** Method : ??? 1367 !! 1368 !! ** Action : ptmsk : wetting & drying t-mask 1369 !!---------------------------------------------------------------------- 1370 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pTmsk ! W & D t-mask 1371 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phU, phV, pu, pv ! ocean velocities and transports 1372 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pUmsk, pVmsk ! W & D u- and v-mask 1373 ! 1374 INTEGER :: ji, jj ! dummy loop indices 1375 !!---------------------------------------------------------------------- 1376 ! 1377 DO jj = 1, jpj 1378 DO ji = 1, jpim1 ! not jpi-column 1379 IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) 1380 ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) 1381 ENDIF 1382 phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 1383 pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 1384 END DO 1385 END DO 1386 ! 1387 DO jj = 1, jpjm1 ! not jpj-row 1388 DO ji = 1, jpi 1389 IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) 1390 ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) 1391 ENDIF 1392 phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj) 1393 pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 1394 END DO 1395 END DO 1396 ! 1397 END SUBROUTINE wad_Umsk 1398 1399 1400 SUBROUTINE wad_spg( sshn, zcpx, zcpy ) 1401 !!--------------------------------------------------------------------- 1402 !! *** ROUTINE wad_sp *** 1403 !! 1404 !! ** Purpose : 1405 !!---------------------------------------------------------------------- 1406 INTEGER :: ji ,jj ! dummy loop indices 1407 LOGICAL :: ll_tmp1, ll_tmp2 1408 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: sshn 1409 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy 1410 !!---------------------------------------------------------------------- 1411 DO jj = 2, jpjm1 1412 DO ji = 2, jpim1 1413 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1414 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & 1415 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji+1,jj) + ht_0(ji+1,jj) ) & 1416 & > rn_wdmin1 + rn_wdmin2 1417 ll_tmp2 = ( ABS( sshn(ji+1,jj) - sshn(ji ,jj)) > 1.E-12 ).AND.( & 1418 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1419 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 1420 IF(ll_tmp1) THEN 1421 zcpx(ji,jj) = 1.0_wp 1422 ELSEIF(ll_tmp2) THEN 1423 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 1424 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 1425 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 1426 zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 1427 ELSE 1428 zcpx(ji,jj) = 0._wp 1429 ENDIF 1430 ! 1431 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1432 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & 1433 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji,jj+1) + ht_0(ji,jj+1) ) & 1434 & > rn_wdmin1 + rn_wdmin2 1435 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1)) > 1.E-12 ).AND.( & 1436 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1437 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 1438 1439 IF(ll_tmp1) THEN 1440 zcpy(ji,jj) = 1.0_wp 1441 ELSE IF(ll_tmp2) THEN 1442 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 1443 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 1444 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 1445 zcpy(ji,jj) = MAX( 0._wp , MIN( zcpy(ji,jj) , 1.0_wp ) ) 1446 ELSE 1447 zcpy(ji,jj) = 0._wp 1448 ENDIF 1449 END DO 1450 END DO 1451 1452 END SUBROUTINE wad_spg 1453 1454 1455 1456 SUBROUTINE dyn_drg_init( pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) 1457 !!---------------------------------------------------------------------- 1458 !! *** ROUTINE dyn_drg_init *** 1459 !! 1460 !! ** Purpose : - add the baroclinic top/bottom drag contribution to 1461 !! the baroclinic part of the barotropic RHS 1462 !! - compute the barotropic drag coefficients 1463 !! 1464 !! ** Method : computation done over the INNER domain only 1465 !!---------------------------------------------------------------------- 1466 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pu_RHSi, pv_RHSi ! baroclinic part of the barotropic RHS 1467 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients 1468 ! 1469 INTEGER :: ji, jj ! dummy loop indices 1470 INTEGER :: ikbu, ikbv, iktu, iktv 1471 REAL(wp) :: zztmp 1472 REAL(wp), DIMENSION(jpi,jpj) :: zu_i, zv_i 1473 !!---------------------------------------------------------------------- 1474 ! 1475 ! !== Set the barotropic drag coef. ==! 1476 ! 1477 IF( ln_isfcav ) THEN ! top+bottom friction (ocean cavities) 1478 1479 DO jj = 2, jpjm1 1480 DO ji = 2, jpim1 ! INNER domain 1481 pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 1482 pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 1483 END DO 1484 END DO 1485 ELSE ! bottom friction only 1486 DO jj = 2, jpjm1 1487 DO ji = 2, jpim1 ! INNER domain 1488 pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 1489 pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 1490 END DO 1491 END DO 1492 ENDIF 1493 ! 1494 ! !== BOTTOM stress contribution from baroclinic velocities ==! 1495 ! 1496 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW bottom baroclinic velocities 1497 1498 DO jj = 2, jpjm1 1499 DO ji = 2, jpim1 ! INNER domain 1500 ikbu = mbku(ji,jj) 1501 ikbv = mbkv(ji,jj) 1502 zu_i(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) 1503 zv_i(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 1504 END DO 1505 END DO 1506 ELSE ! CENTRED integration: use BEFORE bottom baroclinic velocities 1507 1508 DO jj = 2, jpjm1 1509 DO ji = 2, jpim1 ! INNER domain 1510 ikbu = mbku(ji,jj) 1511 ikbv = mbkv(ji,jj) 1512 zu_i(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) 1513 zv_i(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 1514 END DO 1515 END DO 1516 ENDIF 1517 ! 1518 IF( ln_wd_il ) THEN ! W/D : use the "clipped" bottom friction !!gm explain WHY, please ! 1519 zztmp = -1._wp / rdtbt 1520 DO jj = 2, jpjm1 1521 DO ji = 2, jpim1 ! INNER domain 1522 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( & 1523 & r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp ) 1524 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) * wdrampv(ji,jj) * MAX( & 1525 & r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp ) 1526 END DO 1527 END DO 1528 ELSE ! use "unclipped" drag (even if explicit friction is used in 3D calculation) 1529 1530 DO jj = 2, jpjm1 1531 DO ji = 2, jpim1 ! INNER domain 1532 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 1533 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 1534 END DO 1535 END DO 1536 END IF 1537 ! 1538 ! !== TOP stress contribution from baroclinic velocities ==! (no W/D case) 1539 ! 1540 IF( ln_isfcav ) THEN 1541 ! 1542 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity 1543 1544 DO jj = 2, jpjm1 1545 DO ji = 2, jpim1 ! INNER domain 1546 iktu = miku(ji,jj) 1547 iktv = mikv(ji,jj) 1548 zu_i(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) 1549 zv_i(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 1550 END DO 1551 END DO 1552 ELSE ! CENTRED integration: use BEFORE top baroclinic velocity 1553 1554 DO jj = 2, jpjm1 1555 DO ji = 2, jpim1 ! INNER domain 1556 iktu = miku(ji,jj) 1557 iktv = mikv(ji,jj) 1558 zu_i(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) 1559 zv_i(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 1560 END DO 1561 END DO 1562 ENDIF 1563 ! 1564 ! ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) 1565 1566 DO jj = 2, jpjm1 1567 DO ji = 2, jpim1 ! INNER domain 1568 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 1569 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 1570 END DO 1571 END DO 1572 ! 1573 ENDIF 1574 ! 1575 END SUBROUTINE dyn_drg_init 1576 1577 SUBROUTINE ts_bck_interp( jn, ll_init, & ! <== in 1578 & za0, za1, za2, za3 ) ! ==> out 1579 !!---------------------------------------------------------------------- 1580 INTEGER ,INTENT(in ) :: jn ! index of sub time step 1581 LOGICAL ,INTENT(in ) :: ll_init ! 1582 REAL(wp),INTENT( out) :: za0, za1, za2, za3 ! Half-step back interpolation coefficient 1583 ! 1584 REAL(wp) :: zepsilon, zgamma ! - - 1585 !!---------------------------------------------------------------------- 1586 ! ! set Half-step back interpolation coefficient 1587 IF ( jn==1 .AND. ll_init ) THEN !* Forward-backward 1588 za0 = 1._wp 1589 za1 = 0._wp 1590 za2 = 0._wp 1591 za3 = 0._wp 1592 ELSEIF( jn==2 .AND. ll_init ) THEN !* AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 1593 za0 = 1.0833333333333_wp ! za0 = 1-gam-eps 1594 za1 =-0.1666666666666_wp ! za1 = gam 1595 za2 = 0.0833333333333_wp ! za2 = eps 1596 za3 = 0._wp 1597 ELSE !* AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880 1598 IF( rn_bt_alpha == 0._wp ) THEN ! Time diffusion 1599 za0 = 0.614_wp ! za0 = 1/2 + gam + 2*eps 1600 za1 = 0.285_wp ! za1 = 1/2 - 2*gam - 3*eps 1601 za2 = 0.088_wp ! za2 = gam 1602 za3 = 0.013_wp ! za3 = eps 1603 ELSE ! no time diffusion 1604 zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha 1605 zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha 1606 za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon 1607 za1 = 1._wp - za0 - zgamma - zepsilon 1608 za2 = zgamma 1609 za3 = zepsilon 1610 ENDIF 1611 ENDIF 1612 END SUBROUTINE ts_bck_interp 1613 1614 1585 1615 !!====================================================================== 1586 1616 END MODULE dynspg_ts -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/dynvor.F90
r10425 r12065 851 851 REWIND( numnam_ref ) ! Namelist namdyn_vor in reference namelist : Vorticity scheme options 852 852 READ ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901) 853 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' , lwp)853 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' ) 854 854 REWIND( numnam_cfg ) ! Namelist namdyn_vor in configuration namelist : Vorticity scheme options 855 855 READ ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 ) 856 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' , lwp)856 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' ) 857 857 IF(lwm) WRITE ( numond, namdyn_vor ) 858 858 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/dynzdf.F90
r10364 r12065 170 170 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & 171 171 & / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 172 zWui = 0.5_wp * ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) )173 zWus = 0.5_wp * ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) )172 zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua 173 zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 174 174 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 175 175 zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) … … 185 185 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 186 186 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 187 zWui = 0.5_wp * ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) )188 zWus = 0.5_wp * ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) )187 zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua 188 zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 189 189 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 190 190 zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) … … 199 199 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 200 200 zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) / ( ze3ua * e3uw_n(ji,jj,2) ) * wumask(ji,jj,2) 201 zWus = 0.5_wp * ( wi(ji ,jj,2) + wi(ji+1,jj,2) )201 zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / ze3ua 202 202 zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 203 203 zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) … … 336 336 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & 337 337 & / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 338 zWvi = 0.5_wp * ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) * wvmask(ji,jj,jk )339 zWvs = 0.5_wp * ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) * wvmask(ji,jj,jk+1)338 zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va 339 zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 340 340 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 341 341 zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) … … 351 351 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 352 352 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 353 zWvi = 0.5_wp * ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) * wvmask(ji,jj,jk )354 zWvs = 0.5_wp * ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) * wvmask(ji,jj,jk+1)353 zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va 354 zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 355 355 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 356 356 zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) … … 365 365 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 366 366 zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw_n(ji,jj,2) ) * wvmask(ji,jj,2) 367 zWvs = 0.5_wp * ( wi(ji,jj ,2) + wi(ji,jj+1,2) )367 zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / ze3va 368 368 zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 369 369 zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/sshwzv.F90
r10425 r12065 9 9 !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module 10 10 !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work 11 !! 4.0 ! 2018-12 (A. Coward) add mixed implicit/explicit advection 11 12 !!---------------------------------------------------------------------- 12 13 … … 279 280 !! : wi : now vertical velocity (for implicit treatment) 280 281 !! 281 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. 282 !! Reference : Shchepetkin, A. F. (2015): An adaptive, Courant-number-dependent 283 !! implicit scheme for vertical advection in oceanic modeling. 284 !! Ocean Modelling, 91, 38-69. 282 285 !!---------------------------------------------------------------------- 283 286 INTEGER, INTENT(in) :: kt ! time step 284 287 ! 285 288 INTEGER :: ji, jj, jk ! dummy loop indices 286 REAL(wp) :: zCu, zcff, z1_e3 w! local scalars289 REAL(wp) :: zCu, zcff, z1_e3t ! local scalars 287 290 REAL(wp) , PARAMETER :: Cu_min = 0.15_wp ! local parameters 288 REAL(wp) , PARAMETER :: Cu_max = 0. 27! local parameters291 REAL(wp) , PARAMETER :: Cu_max = 0.30_wp ! local parameters 289 292 REAL(wp) , PARAMETER :: Cu_cut = 2._wp*Cu_max - Cu_min ! local parameters 290 293 REAL(wp) , PARAMETER :: Fcu = 4._wp*Cu_max*(Cu_max-Cu_min) ! local parameters … … 297 300 IF(lwp) WRITE(numout,*) 'wAimp : Courant number-based partitioning of now vertical velocity ' 298 301 IF(lwp) WRITE(numout,*) '~~~~~ ' 299 ! 300 Cu_adv(:,:,jpk) = 0._wp ! bottom value : Cu_adv=0 (set once for all) 301 ENDIF 302 ! 303 DO jk = 1, jpkm1 ! calculate Courant numbers 304 DO jj = 2, jpjm1 305 DO ji = 2, fs_jpim1 ! vector opt. 306 z1_e3w = 1._wp / e3w_n(ji,jj,jk) 307 Cu_adv(ji,jj,jk) = r2dt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) ) & 308 & + ( MAX( e2u(ji ,jj)*e3uw_n(ji ,jj,jk)*un(ji ,jj,jk), 0._wp ) - & 309 & MIN( e2u(ji-1,jj)*e3uw_n(ji-1,jj,jk)*un(ji-1,jj,jk), 0._wp ) ) & 310 & * r1_e1e2t(ji,jj) & 311 & + ( MAX( e1v(ji,jj )*e3vw_n(ji,jj ,jk)*vn(ji,jj ,jk), 0._wp ) - & 312 & MIN( e1v(ji,jj-1)*e3vw_n(ji,jj-1,jk)*vn(ji,jj-1,jk), 0._wp ) ) & 313 & * r1_e1e2t(ji,jj) & 314 & ) * z1_e3w 302 wi(:,:,:) = 0._wp 303 ENDIF 304 ! 305 ! Calculate Courant numbers 306 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 307 DO jk = 1, jpkm1 308 DO jj = 2, jpjm1 309 DO ji = 2, fs_jpim1 ! vector opt. 310 z1_e3t = 1._wp / e3t_n(ji,jj,jk) 311 ! 2*rdt and not r2dt (for restartability) 312 Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) ) & 313 & + ( MAX( e2u(ji ,jj)*e3u_n(ji ,jj,jk)*un(ji ,jj,jk) + un_td(ji ,jj,jk), 0._wp ) - & 314 & MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk) + un_td(ji-1,jj,jk), 0._wp ) ) & 315 & * r1_e1e2t(ji,jj) & 316 & + ( MAX( e1v(ji,jj )*e3v_n(ji,jj ,jk)*vn(ji,jj ,jk) + vn_td(ji,jj ,jk), 0._wp ) - & 317 & MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk) + vn_td(ji,jj-1,jk), 0._wp ) ) & 318 & * r1_e1e2t(ji,jj) & 319 & ) * z1_e3t 320 END DO 315 321 END DO 316 322 END DO 317 END DO 323 ELSE 324 DO jk = 1, jpkm1 325 DO jj = 2, jpjm1 326 DO ji = 2, fs_jpim1 ! vector opt. 327 z1_e3t = 1._wp / e3t_n(ji,jj,jk) 328 ! 2*rdt and not r2dt (for restartability) 329 Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) ) & 330 & + ( MAX( e2u(ji ,jj)*e3u_n(ji ,jj,jk)*un(ji ,jj,jk), 0._wp ) - & 331 & MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk), 0._wp ) ) & 332 & * r1_e1e2t(ji,jj) & 333 & + ( MAX( e1v(ji,jj )*e3v_n(ji,jj ,jk)*vn(ji,jj ,jk), 0._wp ) - & 334 & MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk), 0._wp ) ) & 335 & * r1_e1e2t(ji,jj) & 336 & ) * z1_e3t 337 END DO 338 END DO 339 END DO 340 ENDIF 341 CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. ) 318 342 ! 319 343 CALL iom_put("Courant",Cu_adv) 320 344 ! 321 wi(:,:,:) = 0._wp ! Includes top and bottom values set to zero322 345 IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere 323 DO jk = 1, jpkm1! or scan Courant criterion and partition324 DO jj = 2, jpjm1! w where necessary325 DO ji = 2, fs_jpim1 ! vector opt.346 DO jk = jpkm1, 2, -1 ! or scan Courant criterion and partition 347 DO jj = 1, jpj ! w where necessary 348 DO ji = 1, jpi 326 349 ! 327 zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk+1) ) 350 zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) 351 ! alt: 352 ! IF ( wn(ji,jj,jk) > 0._wp ) THEN 353 ! zCu = Cu_adv(ji,jj,jk) 354 ! ELSE 355 ! zCu = Cu_adv(ji,jj,jk-1) 356 ! ENDIF 328 357 ! 329 IF( zCu < Cu_min ) THEN!<-- Fully explicit358 IF( zCu <= Cu_min ) THEN !<-- Fully explicit 330 359 zcff = 0._wp 331 360 ELSEIF( zCu < Cu_cut ) THEN !<-- Mixed explicit … … 340 369 wn(ji,jj,jk) = ( 1._wp - zcff ) * wn(ji,jj,jk) 341 370 ! 342 Cu_adv(ji,jj,jk) = zcff ! Reuse array to output coefficient 371 Cu_adv(ji,jj,jk) = zcff ! Reuse array to output coefficient below and in stp_ctl 343 372 END DO 344 373 END DO 345 374 END DO 375 Cu_adv(:,:,1) = 0._wp 346 376 ELSE 347 377 ! Fully explicit everywhere 348 Cu_adv = 0.0_wp ! Reuse array to output coefficient 378 Cu_adv(:,:,:) = 0._wp ! Reuse array to output coefficient below and in stp_ctl 379 wi (:,:,:) = 0._wp 349 380 ENDIF 350 381 CALL iom_put("wimp",wi) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/DYN/wet_dry.F90
r10499 r12065 81 81 REWIND( numnam_ref ) ! Namelist namwad in reference namelist : Parameters for Wetting/Drying 82 82 READ ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) 83 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist' , .TRUE.)83 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist' ) 84 84 REWIND( numnam_cfg ) ! Namelist namwad in configuration namelist : Parameters for Wetting/Drying 85 85 READ ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906) 86 906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namwad in configuration namelist' , .TRUE.)86 906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namwad in configuration namelist' ) 87 87 IF(lwm) WRITE ( numond, namwad ) 88 88 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/FLO/flo4rk.F90
r10068 r12065 4 4 !! Ocean floats : trajectory computation using a 4th order Runge-Kutta 5 5 !!====================================================================== 6 #if defined key_floats 7 !!---------------------------------------------------------------------- 8 !! 'key_floats' float trajectories 6 !! 9 7 !!---------------------------------------------------------------------- 10 8 !! flo_4rk : Compute the geographical position of floats … … 445 443 END SUBROUTINE flo_interp 446 444 447 # else448 !!----------------------------------------------------------------------449 !! No floats Dummy module450 !!----------------------------------------------------------------------451 #endif452 453 445 !!====================================================================== 454 446 END MODULE flo4rk -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/FLO/flo_oce.F90
r10425 r12065 6 6 !! History : OPA ! 1999-10 (CLIPPER projet) 7 7 !! NEMO 1.0 ! 2002-11 (G. Madec, A. Bozec) F90: Free form and module 8 !!----------------------------------------------------------------------9 #if defined key_floats10 !!----------------------------------------------------------------------11 !! 'key_floats' drifting floats12 8 !!---------------------------------------------------------------------- 13 9 USE par_oce ! ocean parameters … … 20 16 PUBLIC flo_oce_alloc ! Routine called in floats.F90 21 17 22 LOGICAL, PUBLIC, PARAMETER :: lk_floats = .TRUE. !: float flag23 24 18 !! float parameters 25 19 !! ---------------- 20 LOGICAL, PUBLIC :: ln_floats !: Activate floats or not 26 21 INTEGER, PUBLIC :: jpnfl !: total number of floats during the run 27 22 INTEGER, PUBLIC :: jpnnewflo !: number of floats added in a new run … … 68 63 END FUNCTION flo_oce_alloc 69 64 70 #else71 !!----------------------------------------------------------------------72 !! Default option : NO drifting floats73 !!----------------------------------------------------------------------74 LOGICAL, PUBLIC, PARAMETER :: lk_floats = .FALSE. !: float flag75 #endif76 77 65 !!====================================================================== 78 66 END MODULE flo_oce -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/FLO/floats.F90
r10068 r12065 7 7 !! NEMO 1.0 ! 2002-06 (A. Bozec) F90, Free form and module 8 8 !!---------------------------------------------------------------------- 9 #if defined key_floats 10 !!---------------------------------------------------------------------- 11 !! 'key_floats' float trajectories 9 !! 12 10 !!---------------------------------------------------------------------- 13 11 !! flo_stp : float trajectories computation … … 30 28 31 29 PUBLIC flo_stp ! routine called by step.F90 32 PUBLIC flo_init ! routine called by opa.F9030 PUBLIC flo_init ! routine called by nemogcm.F90 33 31 34 32 !!---------------------------------------------------------------------- … … 81 79 INTEGER :: ios ! Local integer output status for namelist read 82 80 ! 83 NAMELIST/namflo/ jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii81 NAMELIST/namflo/ ln_floats, jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii 84 82 !!--------------------------------------------------------------------- 85 83 ! … … 90 88 REWIND( numnam_ref ) ! Namelist namflo in reference namelist : Floats 91 89 READ ( numnam_ref, namflo, IOSTAT = ios, ERR = 901) 92 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namflo in reference namelist' , lwp)90 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namflo in reference namelist' ) 93 91 94 92 REWIND( numnam_cfg ) ! Namelist namflo in configuration namelist : Floats 95 93 READ ( numnam_cfg, namflo, IOSTAT = ios, ERR = 902 ) 96 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namflo in configuration namelist' , lwp)94 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namflo in configuration namelist' ) 97 95 IF(lwm) WRITE ( numond, namflo ) 98 96 ! … … 100 98 WRITE(numout,*) 101 99 WRITE(numout,*) ' Namelist floats :' 102 WRITE(numout,*) ' number of floats jpnfl = ', jpnfl 103 WRITE(numout,*) ' number of new floats jpnflnewflo = ', jpnnewflo 104 WRITE(numout,*) ' restart ln_rstflo = ', ln_rstflo 105 WRITE(numout,*) ' frequency of float output file nn_writefl = ', nn_writefl 106 WRITE(numout,*) ' frequency of float restart file nn_stockfl = ', nn_stockfl 107 WRITE(numout,*) ' Argo type floats ln_argo = ', ln_argo 108 WRITE(numout,*) ' Computation of T trajectories ln_flork4 = ', ln_flork4 109 WRITE(numout,*) ' Use of ariane convention ln_ariane = ', ln_ariane 110 WRITE(numout,*) ' ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii 100 WRITE(numout,*) ' Activate floats or not ln_floats = ', ln_floats 101 WRITE(numout,*) ' number of floats jpnfl = ', jpnfl 102 WRITE(numout,*) ' number of new floats jpnflnewflo = ', jpnnewflo 103 WRITE(numout,*) ' restart ln_rstflo = ', ln_rstflo 104 WRITE(numout,*) ' frequency of float output file nn_writefl = ', nn_writefl 105 WRITE(numout,*) ' frequency of float restart file nn_stockfl = ', nn_stockfl 106 WRITE(numout,*) ' Argo type floats ln_argo = ', ln_argo 107 WRITE(numout,*) ' Computation of T trajectories ln_flork4 = ', ln_flork4 108 WRITE(numout,*) ' Use of ariane convention ln_ariane = ', ln_ariane 109 WRITE(numout,*) ' ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii 111 110 112 111 ENDIF 113 112 ! 114 ! ! allocate floats arrays 115 IF( flo_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 116 ! 117 ! ! allocate flodom arrays 118 IF( flo_dom_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) 119 ! 120 ! ! allocate flowri arrays 121 IF( flo_wri_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 122 ! 123 ! ! allocate florst arrays 124 IF( flo_rst_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) 125 ! 126 jpnrstflo = jpnfl-jpnnewflo ! memory allocation 127 ! 128 DO jfl = 1, jpnfl ! vertical axe for netcdf IOM ouput 129 nfloat(jfl) = jfl 130 END DO 131 ! 132 CALL flo_dom ! compute/read initial position of floats 133 ! 134 wb(:,:,:) = wn(:,:,:) ! set wb for computation of floats trajectories at the first time step 113 IF( ln_floats ) THEN 114 ! ! allocate floats arrays 115 IF( flo_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 116 ! 117 ! ! allocate flodom arrays 118 IF( flo_dom_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) 119 ! 120 ! ! allocate flowri arrays 121 IF( flo_wri_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 122 ! 123 ! ! allocate florst arrays 124 IF( flo_rst_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) 125 ! 126 jpnrstflo = jpnfl-jpnnewflo ! memory allocation 127 ! 128 DO jfl = 1, jpnfl ! vertical axe for netcdf IOM ouput 129 nfloat(jfl) = jfl 130 END DO 131 ! 132 CALL flo_dom ! compute/read initial position of floats 133 ! 134 wb(:,:,:) = wn(:,:,:) ! set wb for computation of floats trajectories at the first time step 135 ! 136 ENDIF 135 137 ! 136 138 END SUBROUTINE flo_init 137 139 138 # else139 !!----------------------------------------------------------------------140 !! Default option : Empty module141 !!----------------------------------------------------------------------142 CONTAINS143 SUBROUTINE flo_stp( kt ) ! Empty routine144 IMPLICIT NONE145 INTEGER, INTENT( in ) :: kt146 WRITE(*,*) 'flo_stp: You should not have seen this print! error?', kt147 END SUBROUTINE flo_stp148 SUBROUTINE flo_init ! Empty routine149 IMPLICIT NONE150 END SUBROUTINE flo_init151 #endif152 153 140 !!====================================================================== 154 141 END MODULE floats -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/FLO/floblk.F90
r10425 r12065 4 4 !! Ocean floats : trajectory computation 5 5 !!====================================================================== 6 #if defined key_floats 7 !!---------------------------------------------------------------------- 8 !! 'key_floats' float trajectories 6 !! 9 7 !!---------------------------------------------------------------------- 10 8 !! flotblk : compute float trajectories with Blanke algorithme … … 369 367 END SUBROUTINE flo_blk 370 368 371 # else372 !!----------------------------------------------------------------------373 !! Default option Empty module374 !!----------------------------------------------------------------------375 CONTAINS376 SUBROUTINE flo_blk ! Empty routine377 END SUBROUTINE flo_blk378 #endif379 380 369 !!====================================================================== 381 370 END MODULE floblk -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/FLO/flodom.F90
r10425 r12065 6 6 !! History : OPA ! 1998-07 (Y.Drillet, CLIPPER) Original code 7 7 !! NEMO 3.3 ! 2011-09 (C.Bricaud,S.Law-Chune Mercator-Ocean): add ARIANE convention + comsecitc changes 8 !!----------------------------------------------------------------------9 #if defined key_floats10 !!----------------------------------------------------------------------11 !! 'key_floats' float trajectories12 8 !!---------------------------------------------------------------------- 13 9 !! flo_dom : initialization of floats … … 437 433 IF( ABS(dlx) > 1.0_wp ) dlx = 1.0_wp 438 434 ! 439 dld = ATAN( DSQRT( 1._wp * ( 1._wp-dlx )/( 1._wp+dlx ) )) * 222.24_wp / dls435 dld = ATAN(SQRT( 1._wp * ( 1._wp-dlx )/( 1._wp+dlx ) )) * 222.24_wp / dls 440 436 flo_dstnce = dld * 1000._wp 441 437 ! … … 455 451 END FUNCTION flo_dom_alloc 456 452 457 458 #else459 !!----------------------------------------------------------------------460 !! Default option Empty module461 !!----------------------------------------------------------------------462 CONTAINS463 SUBROUTINE flo_dom ! Empty routine464 WRITE(*,*) 'flo_dom: : You should not have seen this print! error?'465 END SUBROUTINE flo_dom466 #endif467 468 453 !!====================================================================== 469 454 END MODULE flodom -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/FLO/florst.F90
r10425 r12065 8 8 !! NEMO 1.0 ! 2002-10 (A. Bozec) F90 : Free form and module 9 9 !! 3.2 ! 2010-08 (slaw, cbricaud): netcdf outputs and others 10 !!----------------------------------------------------------------------11 #if defined key_floats12 !!----------------------------------------------------------------------13 !! 'key_floats' float trajectories14 10 !!---------------------------------------------------------------------- 15 11 USE flo_oce ! ocean drifting floats … … 125 121 END SUBROUTINE flo_rst 126 122 127 # else128 !!----------------------------------------------------------------------129 !! Default option Empty module130 !!----------------------------------------------------------------------131 CONTAINS132 SUBROUTINE flo_rst ! Empty routine133 END SUBROUTINE flo_rst134 #endif135 136 123 !!======================================================================= 137 124 END MODULE florst -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/FLO/flowri.F90
r10425 r12065 10 10 !! NEMO 1.0 ! 2002-10 (A. Bozec) F90 : Free form and module 11 11 !! 3.2 ! 2010-08 (slaw, cbricaud): netcdf outputs and others 12 !!----------------------------------------------------------------------13 #if defined key_floats14 !!----------------------------------------------------------------------15 !! 'key_floats' float trajectories16 12 !!---------------------------------------------------------------------- 17 13 USE flo_oce ! ocean drifting floats … … 179 175 CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 180 176 irecflo = NINT( (nitend-nn_it000) / FLOAT(nn_writefl) ) 181 WRITE(numflo,*) cexper,no,irecflo,jpnfl,nn_writefl177 WRITE(numflo,*) cexper, irecflo, jpnfl, nn_writefl 182 178 ENDIF 183 179 … … 225 221 clname=TRIM(clname)//".nc" 226 222 227 CALL fliocrfd( clname , (/ 'ntraj' , 't' /), (/ jpnfl , -1/) , numflo )223 CALL fliocrfd( clname , (/'ntraj' , ' t' /), (/ jpnfl , -1/) , numflo ) 228 224 229 225 CALL fliodefv( numflo, 'traj_lon' , (/1,2/), v_t=flio_r8, long_name="Longitude" , units="degrees_east" ) … … 255 251 256 252 istart = (/jfl,irec/) 257 icfl = INT( tpkfl(jfl) ) ! K-index of the nearest point before 258 259 CALL flioputv( numflo , 'traj_lon' , zlon(jfl) , start=istart ) 260 CALL flioputv( numflo , 'traj_lat' , zlat(jfl) , start=istart ) 261 CALL flioputv( numflo , 'traj_depth' , zdep(jfl) , start=istart ) 262 CALL flioputv( numflo , 'traj_temp' , ztemp(icfl,jfl) , start=istart ) 263 CALL flioputv( numflo , 'traj_salt' , zsal(icfl,jfl) , start=istart ) 264 CALL flioputv( numflo , 'traj_dens' , zrho(icfl,jfl) , start=istart ) 253 254 CALL flioputv( numflo , 'traj_lon' , zlon(jfl), start=istart ) 255 CALL flioputv( numflo , 'traj_lat' , zlat(jfl), start=istart ) 256 CALL flioputv( numflo , 'traj_depth' , zdep(jfl), start=istart ) 257 CALL flioputv( numflo , 'traj_temp' , ztem(jfl), start=istart ) 258 CALL flioputv( numflo , 'traj_salt' , zsal(jfl), start=istart ) 259 CALL flioputv( numflo , 'traj_dens' , zrho(jfl), start=istart ) 265 260 266 261 ENDDO … … 277 272 END SUBROUTINE flo_wri 278 273 279 280 # else281 !!----------------------------------------------------------------------282 !! Default option Empty module283 !!----------------------------------------------------------------------284 CONTAINS285 SUBROUTINE flo_wri ! Empty routine286 END SUBROUTINE flo_wri287 #endif288 289 274 !!======================================================================= 290 275 END MODULE flowri -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ICB/icbini.F90
r10702 r12065 406 406 REWIND( numnam_ref ) ! Namelist namberg in reference namelist : Iceberg parameters 407 407 READ ( numnam_ref, namberg, IOSTAT = ios, ERR = 901) 408 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist' , lwp)408 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist' ) 409 409 REWIND( numnam_cfg ) ! Namelist namberg in configuration namelist : Iceberg parameters 410 410 READ ( numnam_cfg, namberg, IOSTAT = ios, ERR = 902 ) 411 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist' , lwp)411 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist' ) 412 412 IF(lwm) WRITE ( numond, namberg ) 413 413 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ICB/icblbc.F90
r10570 r12065 278 278 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 279 279 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 280 IF( l_isend )CALL mpi_wait( iml_req1, iml_stat, iml_err )280 CALL mpi_wait( iml_req1, iml_stat, iml_err ) 281 281 ibergs_rcvd_from_e = INT( zewbergs(2) ) 282 282 CASE( 0 ) … … 287 287 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 288 288 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 289 IF( l_isend )CALL mpi_wait( iml_req2, iml_stat, iml_err )290 IF( l_isend )CALL mpi_wait( iml_req3, iml_stat, iml_err )289 CALL mpi_wait( iml_req2, iml_stat, iml_err ) 290 CALL mpi_wait( iml_req3, iml_stat, iml_err ) 291 291 ibergs_rcvd_from_e = INT( zewbergs(2) ) 292 292 ibergs_rcvd_from_w = INT( zwebergs(2) ) … … 295 295 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 296 296 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 297 IF( l_isend )CALL mpi_wait( iml_req4, iml_stat, iml_err )297 CALL mpi_wait( iml_req4, iml_stat, iml_err ) 298 298 ibergs_rcvd_from_w = INT( zwebergs(2) ) 299 299 END SELECT … … 310 310 CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 311 311 ENDIF 312 IF( ibergs_to_send_e > 0 .AND. l_isend) CALL mpi_wait( iml_req1, iml_stat, iml_err )312 IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 313 313 DO i = 1, ibergs_rcvd_from_e 314 314 IF( nn_verbose_level >= 4 ) THEN … … 329 329 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 330 330 ENDIF 331 IF( ibergs_to_send_w > 0 .AND. l_isend) CALL mpi_wait( iml_req2, iml_stat, iml_err )332 IF( ibergs_to_send_e > 0 .AND. l_isend) CALL mpi_wait( iml_req3, iml_stat, iml_err )331 IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 332 IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 333 333 DO i = 1, ibergs_rcvd_from_e 334 334 IF( nn_verbose_level >= 4 ) THEN … … 351 351 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 352 352 ENDIF 353 IF( ibergs_to_send_w > 0 .AND. l_isend) CALL mpi_wait( iml_req4, iml_stat, iml_err )353 IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 354 354 DO i = 1, ibergs_rcvd_from_w 355 355 IF( nn_verbose_level >= 4 ) THEN … … 409 409 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 410 410 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 411 IF( l_isend )CALL mpi_wait( iml_req1, iml_stat, iml_err )411 CALL mpi_wait( iml_req1, iml_stat, iml_err ) 412 412 ibergs_rcvd_from_n = INT( znsbergs(2) ) 413 413 CASE( 0 ) … … 418 418 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 419 419 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 420 IF( l_isend )CALL mpi_wait( iml_req2, iml_stat, iml_err )421 IF( l_isend )CALL mpi_wait( iml_req3, iml_stat, iml_err )420 CALL mpi_wait( iml_req2, iml_stat, iml_err ) 421 CALL mpi_wait( iml_req3, iml_stat, iml_err ) 422 422 ibergs_rcvd_from_n = INT( znsbergs(2) ) 423 423 ibergs_rcvd_from_s = INT( zsnbergs(2) ) … … 426 426 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 427 427 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 428 IF( l_isend )CALL mpi_wait( iml_req4, iml_stat, iml_err )428 CALL mpi_wait( iml_req4, iml_stat, iml_err ) 429 429 ibergs_rcvd_from_s = INT( zsnbergs(2) ) 430 430 END SELECT … … 441 441 CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 442 442 ENDIF 443 IF( ibergs_to_send_n > 0 .AND. l_isend) CALL mpi_wait( iml_req1, iml_stat, iml_err )443 IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 444 444 DO i = 1, ibergs_rcvd_from_n 445 445 IF( nn_verbose_level >= 4 ) THEN … … 460 460 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 461 461 ENDIF 462 IF( ibergs_to_send_s > 0 .AND. l_isend) CALL mpi_wait( iml_req2, iml_stat, iml_err )463 IF( ibergs_to_send_n > 0 .AND. l_isend) CALL mpi_wait( iml_req3, iml_stat, iml_err )462 IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 463 IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 464 464 DO i = 1, ibergs_rcvd_from_n 465 465 IF( nn_verbose_level >= 4 ) THEN … … 482 482 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 483 483 ENDIF 484 IF( ibergs_to_send_s > 0 .AND. l_isend) CALL mpi_wait( iml_req4, iml_stat, iml_err )484 IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 485 485 DO i = 1, ibergs_rcvd_from_s 486 486 IF( nn_verbose_level >= 4 ) THEN … … 669 669 ifldproc = nicbfldproc(jn) 670 670 IF( ifldproc == narea ) CYCLE 671 672 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 671 CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 673 672 ENDIF 674 673 ! … … 770 769 ifldproc = nicbfldproc(jn) 771 770 IF( ifldproc == narea ) CYCLE 772 773 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 771 CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 774 772 ENDIF 775 773 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ICB/icbrst.F90
r10425 r12065 131 131 CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) ) 132 132 num_bergs(:) = INT(zdata(:)) 133 ! Close file134 CALL iom_close( ncid )135 133 ! 136 134 … … 146 144 IF( lwp ) WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, icb_rst_read: there were',ibergs_in_file, & 147 145 & ' bergs in the restart file and', jn,' bergs have been read' 146 ! Close file 147 CALL iom_close( ncid ) 148 148 ! 149 149 ! Confirm that all areas have a suitable base for assigning new iceberg -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ICB/icbstp.F90
r10570 r12065 86 86 ! !* write out time 87 87 ll_verbose = .FALSE. 88 IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 ) ll_verbose = ( nn_verbose_level > =0 )88 IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 ) ll_verbose = ( nn_verbose_level > 0 ) 89 89 ! 90 90 IF( ll_verbose ) WRITE(numicb,9100) nktberg, ndastp, nsec_day -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/IOM/in_out_manager.F90
r10601 r12065 80 80 INTEGER :: nleapy !: Leap year calendar flag (0/1 or 30) 81 81 INTEGER :: ninist !: initial state output flag (0/1) 82 INTEGER :: nwrite !: model standard output frequency83 INTEGER :: nstock !: restart file frequency84 INTEGER, DIMENSION(10) :: nstocklist !: restart dump times85 82 86 83 !!---------------------------------------------------------------------- … … 119 116 INTEGER :: ptimincr = 1 !: timestep increment to output (time.step and run.stat) 120 117 END TYPE 121 TYPE(sn_ctl) :: sn_cfctl !: run control structure for selective output118 TYPE(sn_ctl), SAVE :: sn_cfctl !: run control structure for selective output, must have SAVE for default init. of sn_ctl 122 119 LOGICAL :: ln_timing !: run control for timing 123 120 LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics … … 167 164 CHARACTER(lc) :: ctmp7, ctmp8, ctmp9 !: temporary characters 7 to 9 168 165 CHARACTER(lc) :: ctmp10 !: temporary character 10 169 CHARACTER(lc) :: cform_err = "(/,' ===>>> : E R R O R', /,' ===========',/)" !:170 CHARACTER(lc) :: cform_war = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !:171 166 LOGICAL :: lwm = .FALSE. !: boolean : true on the 1st processor only (always) 172 167 LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. ln_ctl -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/IOM/iom.F90
r10523 r12065 58 58 PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get 59 59 PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 60 PUBLIC iom_use, iom_context_finalize 60 PUBLIC iom_use, iom_context_finalize, iom_miss_val 61 61 62 62 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d … … 212 212 CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 213 213 CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 214 !215 # if defined key_floats216 214 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 217 # endif218 215 # if defined key_si3 219 216 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) … … 222 219 # endif 223 220 #if defined key_top 224 CALL iom_set_axis_attr( "profsed", paxis = profsed )221 IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) 225 222 #endif 226 223 CALL iom_set_axis_attr( "icbcla", class_num ) 227 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) 228 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) 224 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) ! strange syntaxe and idea... 225 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 229 226 ENDIF 230 227 ! … … 697 694 clname = trim(cdname) 698 695 IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN 699 iln = INDEX(clname,'/') 696 !FUS iln = INDEX(clname,'/') 697 iln = INDEX(clname,'/',BACK=.true.) ! FUS: to insert the nest index at the right location within the string, the last / has to be found (search from the right to left) 700 698 cltmpn = clname(1:iln) 701 699 clname = clname(iln+1:LEN_TRIM(clname)) … … 835 833 836 834 837 FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, ld stop )835 FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, lduld, ldstop ) 838 836 !!----------------------------------------------------------------------- 839 837 !! *** FUNCTION iom_varid *** … … 844 842 CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable 845 843 INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of each dimension 846 INTEGER, INTENT( out), OPTIONAL :: kndims ! size of the dimensions 844 INTEGER , INTENT( out), OPTIONAL :: kndims ! number of dimensions 845 LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) 847 846 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if looking for non-existing variable (default = .TRUE.) 848 847 ! … … 874 873 iiv = iiv + 1 875 874 IF( iiv <= jpmax_vars ) THEN 876 iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims )875 iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims, lduld ) 877 876 ELSE 878 877 CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name, & … … 892 891 ENDIF 893 892 IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(iiv) 893 IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld( iiv) 894 894 ENDIF 895 895 ENDIF … … 1270 1270 !--- overlap areas and extra hallows (mpp) 1271 1271 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 1272 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999.,'no0')1272 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999., kfillmode = jpfillnothing ) 1273 1273 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 1274 1274 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 1275 1275 IF( icnt(3) == inlev ) THEN 1276 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.,'no0')1276 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing ) 1277 1277 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) 1278 1278 DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO … … 1299 1299 CALL xios_recv_field( trim(cdvar), pv_r3d) 1300 1300 IF(idom /= jpdom_unknown ) then 1301 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.,'no0')1301 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 1302 1302 ENDIF 1303 1303 ELSEIF( PRESENT(pv_r2d) ) THEN … … 1306 1306 CALL xios_recv_field( trim(cdvar), pv_r2d) 1307 1307 IF(idom /= jpdom_unknown ) THEN 1308 CALL lbc_lnk('iom', pv_r2d,'Z',-999., 'no0')1308 CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 1309 1309 ENDIF 1310 1310 ELSEIF( PRESENT(pv_r1d) ) THEN … … 1669 1669 CHARACTER(LEN=*), INTENT(in) :: cdname 1670 1670 REAL(wp) , INTENT(in) :: pfield0d 1671 REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson1671 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1672 1672 #if defined key_iomput 1673 zz(:,:)=pfield0d1674 CALL xios_send_field(cdname, zz)1675 !CALL xios_send_field(cdname, (/pfield0d/))1673 !!clem zz(:,:)=pfield0d 1674 !!clem CALL xios_send_field(cdname, zz) 1675 CALL xios_send_field(cdname, (/pfield0d/)) 1676 1676 #else 1677 1677 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings … … 1979 1979 ! Cell vertices on boundries 1980 1980 DO jn = 1, 4 1981 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., p val=999._wp )1982 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., p val=999._wp )1981 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pfillval=999._wp ) 1982 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pfillval=999._wp ) 1983 1983 END DO 1984 1984 ! … … 2239 2239 CHARACTER(LEN=20) :: clfreq 2240 2240 CHARACTER(LEN=20) :: cldate 2241 CHARACTER(LEN=256) :: cltmpn !FUS needed for correct path with AGRIF 2242 INTEGER :: iln !FUS needed for correct path with AGRIF 2241 2243 INTEGER :: idx 2242 2244 INTEGER :: jn … … 2321 2323 END DO 2322 2324 ! 2323 IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 2325 !FUS IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 2326 !FUS see comment line 700 2327 IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) THEN 2328 iln = INDEX(clname,'/',BACK=.true.) 2329 cltmpn = clname(1:iln) 2330 clname = clname(iln+1:LEN_TRIM(clname)) 2331 clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) 2332 ENDIF 2333 !FUS 2324 2334 IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) 2325 2335 IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) … … 2389 2399 !! NOT 'key_iomput' a few dummy routines 2390 2400 !!---------------------------------------------------------------------- 2391 2392 2401 SUBROUTINE iom_setkt( kt, cdname ) 2393 2402 INTEGER , INTENT(in):: kt … … 2404 2413 2405 2414 LOGICAL FUNCTION iom_use( cdname ) 2406 !!----------------------------------------------------------------------2407 !!----------------------------------------------------------------------2408 2415 CHARACTER(LEN=*), INTENT(in) :: cdname 2409 !!----------------------------------------------------------------------2410 2416 #if defined key_iomput 2411 2417 iom_use = xios_field_is_active( cdname ) … … 2414 2420 #endif 2415 2421 END FUNCTION iom_use 2416 2422 2423 SUBROUTINE iom_miss_val( cdname, pmiss_val ) 2424 CHARACTER(LEN=*), INTENT(in ) :: cdname 2425 REAL(wp) , INTENT(out) :: pmiss_val 2426 #if defined key_iomput 2427 ! get missing value 2428 CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 2429 #else 2430 IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings 2431 #endif 2432 END SUBROUTINE iom_miss_val 2433 2417 2434 !!====================================================================== 2418 2435 END MODULE iom -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/IOM/iom_nf90.F90
r10522 r12065 187 187 188 188 189 FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims )189 FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims, lduld ) 190 190 !!----------------------------------------------------------------------- 191 191 !! *** FUNCTION iom_varid *** … … 198 198 INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of the dimensions 199 199 INTEGER, INTENT( out), OPTIONAL :: kndims ! size of the dimensions 200 LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) 200 201 ! 201 202 INTEGER :: iom_nf90_varid ! iom variable Id … … 251 252 ENDIF 252 253 IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(kiv) 254 IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld(kiv) 253 255 ELSE 254 256 iom_nf90_varid = -1 ! variable not found, return error code: -1 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/IOM/restart.F90
r10425 r12065 70 70 IF( ln_rst_list ) THEN 71 71 nrst_lst = 1 72 nitrst = n stocklist( nrst_lst )72 nitrst = nn_stocklist( nrst_lst ) 73 73 ELSE 74 74 nitrst = nitend 75 75 ENDIF 76 76 ENDIF 77 78 IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart 77 79 78 80 ! frequency-based restart dumping (nn_stock) 79 IF( .NOT. ln_rst_list .AND. MOD( kt - 1, n stock ) == 0 ) THEN81 IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nn_stock ) == 0 ) THEN 80 82 ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment 81 nitrst = kt + n stock - 1 ! define the next value of nitrst for restart writing83 nitrst = kt + nn_stock - 1 ! define the next value of nitrst for restart writing 82 84 IF( nitrst > nitend ) nitrst = nitend ! make sure we write a restart at the end of the run 83 85 ENDIF … … 85 87 ! we open and define the ocean restart file one time step before writing the data (-> at nitrst - 1) 86 88 ! except if we write ocean restart files every time step or if an ocean restart file was writen at nitend - 1 87 IF( kt == nitrst - 1 .OR. n stock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN89 IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN 88 90 IF( nitrst <= nitend .AND. nitrst > 0 ) THEN 89 91 ! beware of the format used to write kt (default is i8.8, that should be large enough...) … … 184 186 lrst_oce = .FALSE. 185 187 IF( ln_rst_list ) THEN 186 nrst_lst = MIN(nrst_lst + 1, SIZE(n stocklist,1))187 nitrst = n stocklist( nrst_lst )188 nrst_lst = MIN(nrst_lst + 1, SIZE(nn_stocklist,1)) 189 nitrst = nn_stocklist( nrst_lst ) 188 190 ENDIF 189 191 ENDIF -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/lbc_lnk_multi_generic.h90
r10425 r12065 14 14 # define PTR_ptab pt4d 15 15 #endif 16 SUBROUTINE ROUTINE_MULTI( cdname & 17 & , pt1, cdna1, psgn1, pt2, cdna2, psgn2, pt3, cdna3, psgn3 & 18 & , pt4, cdna4, psgn4, pt5, cdna5, psgn5, pt6, cdna6, psgn6 & 19 & , pt7, cdna7, psgn7, pt8, cdna8, psgn8, pt9, cdna9, psgn9, cd_mpp, pval) 16 17 SUBROUTINE ROUTINE_MULTI( cdname & 18 & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 & 19 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 20 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 21 & , kfillmode, pfillval, lsend, lrecv, ihlcom ) 20 22 !!--------------------------------------------------------------------- 21 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 22 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 23 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 24 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 25 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9 26 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 27 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9 28 CHARACTER(len=3) , OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 29 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 23 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 24 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 25 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11 26 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 27 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 28 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 29 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 30 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 31 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 32 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 33 INTEGER , OPTIONAL , INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated 30 34 !! 31 INTEGER :: kfld ! number of elements that will be attributed32 PTR_TYPE , DIMENSION( 9) :: ptab_ptr ! pointer array33 CHARACTER(len=1) , DIMENSION( 9) :: cdna_ptr ! nature of ptab_ptr grid-points34 REAL(wp) , DIMENSION( 9) :: psgn_ptr ! sign used across the north fold boundary35 INTEGER :: kfld ! number of elements that will be attributed 36 PTR_TYPE , DIMENSION(11) :: ptab_ptr ! pointer array 37 CHARACTER(len=1) , DIMENSION(11) :: cdna_ptr ! nature of ptab_ptr grid-points 38 REAL(wp) , DIMENSION(11) :: psgn_ptr ! sign used across the north fold boundary 35 39 !!--------------------------------------------------------------------- 36 40 ! … … 41 45 ! 42 46 ! ! Look if more arrays are added 43 IF( PRESENT(psgn2) ) CALL ROUTINE_LOAD( pt2, cdna2, psgn2, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 44 IF( PRESENT(psgn3) ) CALL ROUTINE_LOAD( pt3, cdna3, psgn3, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 45 IF( PRESENT(psgn4) ) CALL ROUTINE_LOAD( pt4, cdna4, psgn4, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 46 IF( PRESENT(psgn5) ) CALL ROUTINE_LOAD( pt5, cdna5, psgn5, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 47 IF( PRESENT(psgn6) ) CALL ROUTINE_LOAD( pt6, cdna6, psgn6, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 48 IF( PRESENT(psgn7) ) CALL ROUTINE_LOAD( pt7, cdna7, psgn7, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 49 IF( PRESENT(psgn8) ) CALL ROUTINE_LOAD( pt8, cdna8, psgn8, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 50 IF( PRESENT(psgn9) ) CALL ROUTINE_LOAD( pt9, cdna9, psgn9, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 47 IF( PRESENT(psgn2 ) ) CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 48 IF( PRESENT(psgn3 ) ) CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 49 IF( PRESENT(psgn4 ) ) CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 50 IF( PRESENT(psgn5 ) ) CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 51 IF( PRESENT(psgn6 ) ) CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 52 IF( PRESENT(psgn7 ) ) CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 53 IF( PRESENT(psgn8 ) ) CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 54 IF( PRESENT(psgn9 ) ) CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 55 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 56 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 51 57 ! 52 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval)58 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 53 59 ! 54 60 END SUBROUTINE ROUTINE_MULTI … … 72 78 ! 73 79 END SUBROUTINE ROUTINE_LOAD 80 74 81 #undef ARRAY_TYPE 75 82 #undef PTR_TYPE -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r10425 r12065 74 74 ! 75 75 ! Security check for further developments 76 IF ( ipf > 1 ) THEN 77 write(6,*) 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation' 78 write(6,*) 'You should not be there...' 79 STOP 80 ENDIF 76 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 81 77 ! 82 78 ijpj = 1 ! index of first modified line -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/lbclnk.F90
r10425 r12065 14 14 !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 15 15 !!---------------------------------------------------------------------- 16 #if defined key_mpp_mpi17 !!----------------------------------------------------------------------18 !! 'key_mpp_mpi' MPI massively parallel processing library19 !!----------------------------------------------------------------------20 16 !! define the generic interfaces of lib_mpp routines 21 17 !!---------------------------------------------------------------------- … … 23 19 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 24 20 !!---------------------------------------------------------------------- 25 USE par_oce ! ocean dynamics and tracers21 USE dom_oce ! ocean space and time domain 26 22 USE lib_mpp ! distributed memory computing library 27 23 USE lbcnfd ! north fold 24 USE in_out_manager ! I/O manager 25 26 IMPLICIT NONE 27 PRIVATE 28 28 29 29 INTERFACE lbc_lnk … … 37 37 END INTERFACE 38 38 ! 39 INTERFACE lbc_bdy_lnk40 MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d41 END INTERFACE42 !43 39 INTERFACE lbc_lnk_icb 44 40 MODULE PROCEDURE mpp_lnk_2d_icb 45 41 END INTERFACE 46 42 43 INTERFACE mpp_nfd 44 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 45 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 46 END INTERFACE 47 47 48 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 48 49 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 49 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions50 50 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 51 52 #if defined key_mpp_mpi 53 !$AGRIF_DO_NOT_TREAT 54 INCLUDE 'mpif.h' 55 !$AGRIF_END_DO_NOT_TREAT 56 #endif 57 58 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 59 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 60 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 61 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 62 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 51 63 52 64 !!---------------------------------------------------------------------- … … 56 68 !!---------------------------------------------------------------------- 57 69 CONTAINS 58 59 #else60 !!----------------------------------------------------------------------61 !! Default option shared memory computing62 !!----------------------------------------------------------------------63 !! routines setting the appropriate values64 !! on first and last row and column of the global domain65 !!----------------------------------------------------------------------66 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh67 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh68 !! lbc_lnk : generic interface for lbc_lnk_3d and lbc_lnk_2d69 !! lbc_lnk_3d : set the lateral boundary condition on a 3D variable on ocean mesh70 !! lbc_lnk_2d : set the lateral boundary condition on a 2D variable on ocean mesh71 !! lbc_bdy_lnk : set the lateral BDY boundary condition72 !!----------------------------------------------------------------------73 USE oce ! ocean dynamics and tracers74 USE dom_oce ! ocean space and time domain75 USE in_out_manager ! I/O manager76 USE lbcnfd ! north fold77 78 IMPLICIT NONE79 PRIVATE80 81 INTERFACE lbc_lnk82 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d83 END INTERFACE84 INTERFACE lbc_lnk_ptr85 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr86 END INTERFACE87 INTERFACE lbc_lnk_multi88 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi89 END INTERFACE90 !91 INTERFACE lbc_bdy_lnk92 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d93 END INTERFACE94 !95 INTERFACE lbc_lnk_icb96 MODULE PROCEDURE lbc_lnk_2d_icb97 END INTERFACE98 99 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions100 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions101 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions102 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions103 104 !!----------------------------------------------------------------------105 !! NEMO/OCE 4.0 , NEMO Consortium (2018)106 !! $Id$107 !! Software governed by the CeCILL license (see ./LICENSE)108 !!----------------------------------------------------------------------109 CONTAINS110 111 !!======================================================================112 !! Default option 3D shared memory computing113 !!======================================================================114 !! routines setting land point, or east-west cyclic,115 !! or north-south cyclic, or north fold values116 !! on first and last row and column of the global domain117 !!----------------------------------------------------------------------118 119 !!----------------------------------------------------------------------120 !! *** routine lbc_lnk_(2,3,4)d ***121 !!122 !! * Argument : dummy argument use in lbc_lnk_... routines123 !! ptab : array or pointer of arrays on which the boundary condition is applied124 !! cd_nat : nature of array grid-points125 !! psgn : sign used across the north fold boundary126 !! kfld : optional, number of pt3d arrays127 !! cd_mpp : optional, fill the overlap area only128 !! pval : optional, background value (used at closed boundaries)129 !!----------------------------------------------------------------------130 !131 ! !== 2D array and array of 2D pointer ==!132 !133 # define DIM_2d134 # define ROUTINE_LNK lbc_lnk_2d135 # include "lbc_lnk_generic.h90"136 # undef ROUTINE_LNK137 # define MULTI138 # define ROUTINE_LNK lbc_lnk_2d_ptr139 # include "lbc_lnk_generic.h90"140 # undef ROUTINE_LNK141 # undef MULTI142 # undef DIM_2d143 !144 ! !== 3D array and array of 3D pointer ==!145 !146 # define DIM_3d147 # define ROUTINE_LNK lbc_lnk_3d148 # include "lbc_lnk_generic.h90"149 # undef ROUTINE_LNK150 # define MULTI151 # define ROUTINE_LNK lbc_lnk_3d_ptr152 # include "lbc_lnk_generic.h90"153 # undef ROUTINE_LNK154 # undef MULTI155 # undef DIM_3d156 !157 ! !== 4D array and array of 4D pointer ==!158 !159 # define DIM_4d160 # define ROUTINE_LNK lbc_lnk_4d161 # include "lbc_lnk_generic.h90"162 # undef ROUTINE_LNK163 # define MULTI164 # define ROUTINE_LNK lbc_lnk_4d_ptr165 # include "lbc_lnk_generic.h90"166 # undef ROUTINE_LNK167 # undef MULTI168 # undef DIM_4d169 170 !!======================================================================171 !! identical routines in both C1D and shared memory computing172 !!======================================================================173 174 !!----------------------------------------------------------------------175 !! *** routine lbc_bdy_lnk_(2,3,4)d ***176 !!177 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used178 !! to maintain the same interface with regards to the mpp case179 !!----------------------------------------------------------------------180 181 SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy )182 !!----------------------------------------------------------------------183 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine184 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt4d ! 3D array on which the lbc is applied185 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points186 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold187 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set188 !!----------------------------------------------------------------------189 CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn)190 END SUBROUTINE lbc_bdy_lnk_4d191 192 SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy )193 !!----------------------------------------------------------------------194 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine195 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied196 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points197 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold198 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set199 !!----------------------------------------------------------------------200 CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn)201 END SUBROUTINE lbc_bdy_lnk_3d202 203 204 SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy )205 !!----------------------------------------------------------------------206 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine207 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied208 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points209 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold210 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set211 !!----------------------------------------------------------------------212 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn)213 END SUBROUTINE lbc_bdy_lnk_2d214 215 216 !!gm This routine should be removed with an optional halos size added in argument of generic routines217 218 SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj )219 !!----------------------------------------------------------------------220 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine221 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied222 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points223 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold224 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp)225 !!----------------------------------------------------------------------226 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn )227 END SUBROUTINE lbc_lnk_2d_icb228 !!gm end229 230 #endif231 232 !!======================================================================233 !! identical routines in both distributed and shared memory computing234 !!======================================================================235 70 236 71 !!---------------------------------------------------------------------- … … 256 91 257 92 # define DIM_2d 93 # define ROUTINE_LOAD load_ptr_2d 258 94 # define ROUTINE_MULTI lbc_lnk_2d_multi 259 # define ROUTINE_LOAD load_ptr_2d260 95 # include "lbc_lnk_multi_generic.h90" 261 96 # undef ROUTINE_MULTI … … 263 98 # undef DIM_2d 264 99 265 266 100 # define DIM_3d 101 # define ROUTINE_LOAD load_ptr_3d 267 102 # define ROUTINE_MULTI lbc_lnk_3d_multi 268 # define ROUTINE_LOAD load_ptr_3d269 103 # include "lbc_lnk_multi_generic.h90" 270 104 # undef ROUTINE_MULTI … … 272 106 # undef DIM_3d 273 107 274 275 108 # define DIM_4d 109 # define ROUTINE_LOAD load_ptr_4d 276 110 # define ROUTINE_MULTI lbc_lnk_4d_multi 277 # define ROUTINE_LOAD load_ptr_4d278 111 # include "lbc_lnk_multi_generic.h90" 279 112 # undef ROUTINE_MULTI … … 281 114 # undef DIM_4d 282 115 116 !!---------------------------------------------------------------------- 117 !! *** routine mpp_lnk_(2,3,4)d *** 118 !! 119 !! * Argument : dummy argument use in mpp_lnk_... routines 120 !! ptab : array or pointer of arrays on which the boundary condition is applied 121 !! cd_nat : nature of array grid-points 122 !! psgn : sign used across the north fold boundary 123 !! kfld : optional, number of pt3d arrays 124 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 125 !! pfillval : optional, background value (used with jpfillcopy) 126 !!---------------------------------------------------------------------- 127 ! 128 ! !== 2D array and array of 2D pointer ==! 129 ! 130 # define DIM_2d 131 # define ROUTINE_LNK mpp_lnk_2d 132 # include "mpp_lnk_generic.h90" 133 # undef ROUTINE_LNK 134 # define MULTI 135 # define ROUTINE_LNK mpp_lnk_2d_ptr 136 # include "mpp_lnk_generic.h90" 137 # undef ROUTINE_LNK 138 # undef MULTI 139 # undef DIM_2d 140 ! 141 ! !== 3D array and array of 3D pointer ==! 142 ! 143 # define DIM_3d 144 # define ROUTINE_LNK mpp_lnk_3d 145 # include "mpp_lnk_generic.h90" 146 # undef ROUTINE_LNK 147 # define MULTI 148 # define ROUTINE_LNK mpp_lnk_3d_ptr 149 # include "mpp_lnk_generic.h90" 150 # undef ROUTINE_LNK 151 # undef MULTI 152 # undef DIM_3d 153 ! 154 ! !== 4D array and array of 4D pointer ==! 155 ! 156 # define DIM_4d 157 # define ROUTINE_LNK mpp_lnk_4d 158 # include "mpp_lnk_generic.h90" 159 # undef ROUTINE_LNK 160 # define MULTI 161 # define ROUTINE_LNK mpp_lnk_4d_ptr 162 # include "mpp_lnk_generic.h90" 163 # undef ROUTINE_LNK 164 # undef MULTI 165 # undef DIM_4d 166 167 !!---------------------------------------------------------------------- 168 !! *** routine mpp_nfd_(2,3,4)d *** 169 !! 170 !! * Argument : dummy argument use in mpp_nfd_... routines 171 !! ptab : array or pointer of arrays on which the boundary condition is applied 172 !! cd_nat : nature of array grid-points 173 !! psgn : sign used across the north fold boundary 174 !! kfld : optional, number of pt3d arrays 175 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 176 !! pfillval : optional, background value (used with jpfillcopy) 177 !!---------------------------------------------------------------------- 178 ! 179 ! !== 2D array and array of 2D pointer ==! 180 ! 181 # define DIM_2d 182 # define ROUTINE_NFD mpp_nfd_2d 183 # include "mpp_nfd_generic.h90" 184 # undef ROUTINE_NFD 185 # define MULTI 186 # define ROUTINE_NFD mpp_nfd_2d_ptr 187 # include "mpp_nfd_generic.h90" 188 # undef ROUTINE_NFD 189 # undef MULTI 190 # undef DIM_2d 191 ! 192 ! !== 3D array and array of 3D pointer ==! 193 ! 194 # define DIM_3d 195 # define ROUTINE_NFD mpp_nfd_3d 196 # include "mpp_nfd_generic.h90" 197 # undef ROUTINE_NFD 198 # define MULTI 199 # define ROUTINE_NFD mpp_nfd_3d_ptr 200 # include "mpp_nfd_generic.h90" 201 # undef ROUTINE_NFD 202 # undef MULTI 203 # undef DIM_3d 204 ! 205 ! !== 4D array and array of 4D pointer ==! 206 ! 207 # define DIM_4d 208 # define ROUTINE_NFD mpp_nfd_4d 209 # include "mpp_nfd_generic.h90" 210 # undef ROUTINE_NFD 211 # define MULTI 212 # define ROUTINE_NFD mpp_nfd_4d_ptr 213 # include "mpp_nfd_generic.h90" 214 # undef ROUTINE_NFD 215 # undef MULTI 216 # undef DIM_4d 217 218 283 219 !!====================================================================== 220 221 222 223 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 224 !!--------------------------------------------------------------------- 225 !! *** routine mpp_lbc_north_icb *** 226 !! 227 !! ** Purpose : Ensure proper north fold horizontal bondary condition 228 !! in mpp configuration in case of jpn1 > 1 and for 2d 229 !! array with outer extra halo 230 !! 231 !! ** Method : North fold condition and mpp with more than one proc 232 !! in i-direction require a specific treatment. We gather 233 !! the 4+kextj northern lines of the global domain on 1 234 !! processor and apply lbc north-fold on this sub array. 235 !! Then we scatter the north fold array back to the processors. 236 !! This routine accounts for an extra halo with icebergs 237 !! and assumes ghost rows and columns have been suppressed. 238 !! 239 !!---------------------------------------------------------------------- 240 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 241 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 242 ! ! = T , U , V , F or W -points 243 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 244 !! ! north fold, = 1. otherwise 245 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold 246 ! 247 INTEGER :: ji, jj, jr 248 INTEGER :: ierr, itaille, ildi, ilei, iilb 249 INTEGER :: ipj, ij, iproc 250 ! 251 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 252 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 253 !!---------------------------------------------------------------------- 254 #if defined key_mpp_mpi 255 ! 256 ipj=4 257 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & 258 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & 259 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) ) 260 ! 261 ztab_e(:,:) = 0._wp 262 znorthloc_e(:,:) = 0._wp 263 ! 264 ij = 1 - kextj 265 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e 266 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 267 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 268 ij = ij + 1 269 END DO 270 ! 271 itaille = jpimax * ( ipj + 2*kextj ) 272 ! 273 IF( ln_timing ) CALL tic_tac(.TRUE.) 274 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & 275 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & 276 & ncomm_north, ierr ) 277 ! 278 IF( ln_timing ) CALL tic_tac(.FALSE.) 279 ! 280 DO jr = 1, ndim_rank_north ! recover the global north array 281 iproc = nrank_north(jr) + 1 282 ildi = nldit (iproc) 283 ilei = nleit (iproc) 284 iilb = nimppt(iproc) 285 DO jj = 1-kextj, ipj+kextj 286 DO ji = ildi, ilei 287 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 288 END DO 289 END DO 290 END DO 291 292 ! 2. North-Fold boundary conditions 293 ! ---------------------------------- 294 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 295 296 ij = 1 - kextj 297 !! Scatter back to pt2d 298 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 299 DO ji= 1, jpi 300 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 301 END DO 302 ij = ij +1 303 END DO 304 ! 305 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 306 ! 307 #endif 308 END SUBROUTINE mpp_lbc_north_icb 309 310 311 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 312 !!---------------------------------------------------------------------- 313 !! *** routine mpp_lnk_2d_icb *** 314 !! 315 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) 316 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 317 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 318 !! 319 !! ** Method : Use mppsend and mpprecv function for passing mask 320 !! between processors following neighboring subdomains. 321 !! domain parameters 322 !! jpi : first dimension of the local subdomain 323 !! jpj : second dimension of the local subdomain 324 !! kexti : number of columns for extra outer halo 325 !! kextj : number of rows for extra outer halo 326 !! nbondi : mark for "east-west local boundary" 327 !! nbondj : mark for "north-south local boundary" 328 !! noea : number for local neighboring processors 329 !! nowe : number for local neighboring processors 330 !! noso : number for local neighboring processors 331 !! nono : number for local neighboring processors 332 !!---------------------------------------------------------------------- 333 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 334 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 335 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 336 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 337 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 338 INTEGER , INTENT(in ) :: kextj ! extra j-halo width 339 ! 340 INTEGER :: jl ! dummy loop indices 341 INTEGER :: imigr, iihom, ijhom ! local integers 342 INTEGER :: ipreci, iprecj ! - - 343 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 344 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 345 !! 346 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn 347 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew 348 !!---------------------------------------------------------------------- 349 350 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area 351 iprecj = nn_hls + kextj 352 353 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 354 355 ! 1. standard boundary treatment 356 ! ------------------------------ 357 ! Order matters Here !!!! 358 ! 359 ! ! East-West boundaries 360 ! !* Cyclic east-west 361 IF( l_Iperio ) THEN 362 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east 363 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west 364 ! 365 ELSE !* closed 366 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point 367 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west 368 ENDIF 369 ! ! North-South boundaries 370 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 371 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north 372 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south 373 ELSE !* closed 374 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point 375 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south 376 ENDIF 377 ! 378 379 ! north fold treatment 380 ! ----------------------- 381 IF( npolj /= 0 ) THEN 382 ! 383 SELECT CASE ( jpni ) 384 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 385 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 386 END SELECT 387 ! 388 ENDIF 389 390 ! 2. East and west directions exchange 391 ! ------------------------------------ 392 ! we play with the neigbours AND the row number because of the periodicity 393 ! 394 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 395 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 396 iihom = jpi-nreci-kexti 397 DO jl = 1, ipreci 398 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 399 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 400 END DO 401 END SELECT 402 ! 403 ! ! Migrations 404 imigr = ipreci * ( jpj + 2*kextj ) 405 ! 406 IF( ln_timing ) CALL tic_tac(.TRUE.) 407 ! 408 SELECT CASE ( nbondi ) 409 CASE ( -1 ) 410 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 411 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 412 CALL mpi_wait(ml_req1,ml_stat,ml_err) 413 CASE ( 0 ) 414 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 415 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 416 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 417 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 418 CALL mpi_wait(ml_req1,ml_stat,ml_err) 419 CALL mpi_wait(ml_req2,ml_stat,ml_err) 420 CASE ( 1 ) 421 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 422 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 423 CALL mpi_wait(ml_req1,ml_stat,ml_err) 424 END SELECT 425 ! 426 IF( ln_timing ) CALL tic_tac(.FALSE.) 427 ! 428 ! ! Write Dirichlet lateral conditions 429 iihom = jpi - nn_hls 430 ! 431 SELECT CASE ( nbondi ) 432 CASE ( -1 ) 433 DO jl = 1, ipreci 434 pt2d(iihom+jl,:) = r2dew(:,jl,2) 435 END DO 436 CASE ( 0 ) 437 DO jl = 1, ipreci 438 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 439 pt2d(iihom+jl,:) = r2dew(:,jl,2) 440 END DO 441 CASE ( 1 ) 442 DO jl = 1, ipreci 443 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 444 END DO 445 END SELECT 446 447 448 ! 3. North and south directions 449 ! ----------------------------- 450 ! always closed : we play only with the neigbours 451 ! 452 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 453 ijhom = jpj-nrecj-kextj 454 DO jl = 1, iprecj 455 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 456 r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 457 END DO 458 ENDIF 459 ! 460 ! ! Migrations 461 imigr = iprecj * ( jpi + 2*kexti ) 462 ! 463 IF( ln_timing ) CALL tic_tac(.TRUE.) 464 ! 465 SELECT CASE ( nbondj ) 466 CASE ( -1 ) 467 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 468 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 469 CALL mpi_wait(ml_req1,ml_stat,ml_err) 470 CASE ( 0 ) 471 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 472 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 473 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 474 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 475 CALL mpi_wait(ml_req1,ml_stat,ml_err) 476 CALL mpi_wait(ml_req2,ml_stat,ml_err) 477 CASE ( 1 ) 478 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 479 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 480 CALL mpi_wait(ml_req1,ml_stat,ml_err) 481 END SELECT 482 ! 483 IF( ln_timing ) CALL tic_tac(.FALSE.) 484 ! 485 ! ! Write Dirichlet lateral conditions 486 ijhom = jpj - nn_hls 487 ! 488 SELECT CASE ( nbondj ) 489 CASE ( -1 ) 490 DO jl = 1, iprecj 491 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 492 END DO 493 CASE ( 0 ) 494 DO jl = 1, iprecj 495 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 496 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 497 END DO 498 CASE ( 1 ) 499 DO jl = 1, iprecj 500 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 501 END DO 502 END SELECT 503 ! 504 END SUBROUTINE mpp_lnk_2d_icb 505 284 506 END MODULE lbclnk 285 507 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/lbcnfd.F90
r10425 r12065 20 20 USE dom_oce ! ocean space and time domain 21 21 USE in_out_manager ! I/O manager 22 USE lib_mpp ! MPP library 22 23 23 24 IMPLICIT NONE -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/lib_mpp.F90
r10538 r12065 32 32 !! ctl_opn : Open file and check if required file is available. 33 33 !! ctl_nam : Prints informations when an error occurs while reading a namelist 34 !! get_unit : give the index of an unused logical unit 35 !!---------------------------------------------------------------------- 36 #if defined key_mpp_mpi 37 !!---------------------------------------------------------------------- 38 !! 'key_mpp_mpi' MPI massively parallel processing library 39 !!---------------------------------------------------------------------- 40 !! lib_mpp_alloc : allocate mpp arrays 41 !! mynode : indentify the processor unit 34 !!---------------------------------------------------------------------- 35 !!---------------------------------------------------------------------- 36 !! mpp_start : get local communicator its size and rank 42 37 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 43 38 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) … … 57 52 !!---------------------------------------------------------------------- 58 53 USE dom_oce ! ocean space and time domain 59 USE lbcnfd ! north fold treatment60 54 USE in_out_manager ! I/O manager 61 55 62 56 IMPLICIT NONE 63 57 PRIVATE 64 65 INTERFACE mpp_nfd66 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d67 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr68 END INTERFACE69 70 ! Interface associated to the mpp_lnk_... routines is defined in lbclnk71 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d72 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr73 58 ! 74 !!gm this should be useless 75 PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 76 PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 77 !!gm end 78 ! 79 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 80 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 59 PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam 60 PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free 81 61 PUBLIC mpp_ini_north 82 PUBLIC mpp_lnk_2d_icb83 PUBLIC mpp_lbc_north_icb84 62 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 85 63 PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv … … 87 65 PUBLIC mpp_ini_znl 88 66 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 89 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 67 PUBLIC mpp_report 68 PUBLIC tic_tac 69 #if ! defined key_mpp_mpi 70 PUBLIC MPI_Wtime 71 #endif 90 72 91 73 !! * Interfaces … … 113 95 !! MPI variable definition !! 114 96 !! ========================= !! 97 #if defined key_mpp_mpi 115 98 !$AGRIF_DO_NOT_TREAT 116 99 INCLUDE 'mpif.h' 117 100 !$AGRIF_END_DO_NOT_TREAT 118 119 101 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 102 #else 103 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 104 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 105 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 106 #endif 120 107 121 108 INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2) … … 146 133 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 147 134 148 ! Type of send : standard, buffered, immediate149 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend)150 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I')151 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend152 153 135 ! Communications summary report 154 136 CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines … … 160 142 INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic 161 143 INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos) 162 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 3000 !: max number of communication record144 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 5000 !: max number of communication record 163 145 INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc 164 146 INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications … … 176 158 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 177 159 END TYPE DELAYARR 178 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC :: todelay179 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1!: mpi request id of the delayed operations160 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR 161 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations 180 162 181 163 ! timing summary report … … 187 169 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 188 170 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 189 171 190 172 !!---------------------------------------------------------------------- 191 173 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 195 177 CONTAINS 196 178 197 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 198 !!---------------------------------------------------------------------- 199 !! *** routine mynode *** 200 !! 201 !! ** Purpose : Find processor unit 202 !!---------------------------------------------------------------------- 203 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 204 CHARACTER(len=*) , INTENT(in ) :: ldname ! 205 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 206 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 207 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 208 INTEGER , INTENT(inout) :: kstop ! stop indicator 179 SUBROUTINE mpp_start( localComm ) 180 !!---------------------------------------------------------------------- 181 !! *** routine mpp_start *** 182 !! 183 !! ** Purpose : get mpi_comm_oce, mpprank and mppsize 184 !!---------------------------------------------------------------------- 209 185 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 210 186 ! 211 INTEGER :: mynode, ierr, code, ji, ii, ios 212 LOGICAL :: mpi_was_called 213 ! 214 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 215 !!---------------------------------------------------------------------- 216 ! 217 ii = 1 218 WRITE(ldtxt(ii),*) ; ii = ii + 1 219 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 220 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 221 ! 222 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 223 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 224 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 225 ! 226 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 227 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 228 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 229 ! 230 ! ! control print 231 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 232 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 233 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 234 ! 235 IF( jpni < 1 .OR. jpnj < 1 ) THEN 236 WRITE(ldtxt(ii),*) ' jpni and jpnj will be calculated automatically' ; ii = ii + 1 237 ELSE 238 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 239 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 240 ENDIF 241 242 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 243 244 CALL mpi_initialized ( mpi_was_called, code ) 245 IF( code /= MPI_SUCCESS ) THEN 246 DO ji = 1, SIZE(ldtxt) 247 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 248 END DO 249 WRITE(*, cform_err) 250 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 251 CALL mpi_abort( mpi_comm_world, code, ierr ) 252 ENDIF 253 254 IF( mpi_was_called ) THEN 255 ! 256 SELECT CASE ( cn_mpi_send ) 257 CASE ( 'S' ) ! Standard mpi send (blocking) 258 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 259 CASE ( 'B' ) ! Buffer mpi send (blocking) 260 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 261 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 262 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 263 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 264 l_isend = .TRUE. 265 CASE DEFAULT 266 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 267 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 268 kstop = kstop + 1 269 END SELECT 270 ! 271 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 272 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 273 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 274 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 275 kstop = kstop + 1 276 ELSE 277 SELECT CASE ( cn_mpi_send ) 278 CASE ( 'S' ) ! Standard mpi send (blocking) 279 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 280 CALL mpi_init( ierr ) 281 CASE ( 'B' ) ! Buffer mpi send (blocking) 282 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 283 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 284 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 285 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 286 l_isend = .TRUE. 287 CALL mpi_init( ierr ) 288 CASE DEFAULT 289 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 290 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 291 kstop = kstop + 1 292 END SELECT 293 ! 294 ENDIF 295 187 INTEGER :: ierr 188 LOGICAL :: llmpi_init 189 !!---------------------------------------------------------------------- 190 #if defined key_mpp_mpi 191 ! 192 CALL mpi_initialized ( llmpi_init, ierr ) 193 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 194 195 IF( .NOT. llmpi_init ) THEN 196 IF( PRESENT(localComm) ) THEN 197 WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 198 WRITE(ctmp2,*) ' without calling MPI_Init before ! ' 199 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 200 ENDIF 201 CALL mpi_init( ierr ) 202 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 203 ENDIF 204 296 205 IF( PRESENT(localComm) ) THEN 297 206 IF( Agrif_Root() ) THEN … … 299 208 ENDIF 300 209 ELSE 301 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 302 IF( code /= MPI_SUCCESS ) THEN 303 DO ji = 1, SIZE(ldtxt) 304 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 305 END DO 306 WRITE(*, cform_err) 307 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 308 CALL mpi_abort( mpi_comm_world, code, ierr ) 309 ENDIF 310 ENDIF 311 312 #if defined key_agrif 210 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 211 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 212 ENDIF 213 214 # if defined key_agrif 313 215 IF( Agrif_Root() ) THEN 314 216 CALL Agrif_MPI_Init(mpi_comm_oce) … … 316 218 CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 317 219 ENDIF 318 # endif220 # endif 319 221 320 222 CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 321 223 CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 322 mynode = mpprank323 324 IF( mynode == 0 ) THEN325 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )326 WRITE(kumond, nammpp)327 ENDIF328 224 ! 329 225 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 330 226 ! 331 END FUNCTION mynode 332 333 !!---------------------------------------------------------------------- 334 !! *** routine mpp_lnk_(2,3,4)d *** 335 !! 336 !! * Argument : dummy argument use in mpp_lnk_... routines 337 !! ptab : array or pointer of arrays on which the boundary condition is applied 338 !! cd_nat : nature of array grid-points 339 !! psgn : sign used across the north fold boundary 340 !! kfld : optional, number of pt3d arrays 341 !! cd_mpp : optional, fill the overlap area only 342 !! pval : optional, background value (used at closed boundaries) 343 !!---------------------------------------------------------------------- 344 ! 345 ! !== 2D array and array of 2D pointer ==! 346 ! 347 # define DIM_2d 348 # define ROUTINE_LNK mpp_lnk_2d 349 # include "mpp_lnk_generic.h90" 350 # undef ROUTINE_LNK 351 # define MULTI 352 # define ROUTINE_LNK mpp_lnk_2d_ptr 353 # include "mpp_lnk_generic.h90" 354 # undef ROUTINE_LNK 355 # undef MULTI 356 # undef DIM_2d 357 ! 358 ! !== 3D array and array of 3D pointer ==! 359 ! 360 # define DIM_3d 361 # define ROUTINE_LNK mpp_lnk_3d 362 # include "mpp_lnk_generic.h90" 363 # undef ROUTINE_LNK 364 # define MULTI 365 # define ROUTINE_LNK mpp_lnk_3d_ptr 366 # include "mpp_lnk_generic.h90" 367 # undef ROUTINE_LNK 368 # undef MULTI 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_LNK mpp_lnk_4d 375 # include "mpp_lnk_generic.h90" 376 # undef ROUTINE_LNK 377 # define MULTI 378 # define ROUTINE_LNK mpp_lnk_4d_ptr 379 # include "mpp_lnk_generic.h90" 380 # undef ROUTINE_LNK 381 # undef MULTI 382 # undef DIM_4d 383 384 !!---------------------------------------------------------------------- 385 !! *** routine mpp_nfd_(2,3,4)d *** 386 !! 387 !! * Argument : dummy argument use in mpp_nfd_... routines 388 !! ptab : array or pointer of arrays on which the boundary condition is applied 389 !! cd_nat : nature of array grid-points 390 !! psgn : sign used across the north fold boundary 391 !! kfld : optional, number of pt3d arrays 392 !! cd_mpp : optional, fill the overlap area only 393 !! pval : optional, background value (used at closed boundaries) 394 !!---------------------------------------------------------------------- 395 ! 396 ! !== 2D array and array of 2D pointer ==! 397 ! 398 # define DIM_2d 399 # define ROUTINE_NFD mpp_nfd_2d 400 # include "mpp_nfd_generic.h90" 401 # undef ROUTINE_NFD 402 # define MULTI 403 # define ROUTINE_NFD mpp_nfd_2d_ptr 404 # include "mpp_nfd_generic.h90" 405 # undef ROUTINE_NFD 406 # undef MULTI 407 # undef DIM_2d 408 ! 409 ! !== 3D array and array of 3D pointer ==! 410 ! 411 # define DIM_3d 412 # define ROUTINE_NFD mpp_nfd_3d 413 # include "mpp_nfd_generic.h90" 414 # undef ROUTINE_NFD 415 # define MULTI 416 # define ROUTINE_NFD mpp_nfd_3d_ptr 417 # include "mpp_nfd_generic.h90" 418 # undef ROUTINE_NFD 419 # undef MULTI 420 # undef DIM_3d 421 ! 422 ! !== 4D array and array of 4D pointer ==! 423 ! 424 # define DIM_4d 425 # define ROUTINE_NFD mpp_nfd_4d 426 # include "mpp_nfd_generic.h90" 427 # undef ROUTINE_NFD 428 # define MULTI 429 # define ROUTINE_NFD mpp_nfd_4d_ptr 430 # include "mpp_nfd_generic.h90" 431 # undef ROUTINE_NFD 432 # undef MULTI 433 # undef DIM_4d 434 435 436 !!---------------------------------------------------------------------- 437 !! *** routine mpp_lnk_bdy_(2,3,4)d *** 438 !! 439 !! * Argument : dummy argument use in mpp_lnk_... routines 440 !! ptab : array or pointer of arrays on which the boundary condition is applied 441 !! cd_nat : nature of array grid-points 442 !! psgn : sign used across the north fold boundary 443 !! kb_bdy : BDY boundary set 444 !! kfld : optional, number of pt3d arrays 445 !!---------------------------------------------------------------------- 446 ! 447 ! !== 2D array and array of 2D pointer ==! 448 ! 449 # define DIM_2d 450 # define ROUTINE_BDY mpp_lnk_bdy_2d 451 # include "mpp_bdy_generic.h90" 452 # undef ROUTINE_BDY 453 # undef DIM_2d 454 ! 455 ! !== 3D array and array of 3D pointer ==! 456 ! 457 # define DIM_3d 458 # define ROUTINE_BDY mpp_lnk_bdy_3d 459 # include "mpp_bdy_generic.h90" 460 # undef ROUTINE_BDY 461 # undef DIM_3d 462 ! 463 ! !== 4D array and array of 4D pointer ==! 464 ! 465 # define DIM_4d 466 # define ROUTINE_BDY mpp_lnk_bdy_4d 467 # include "mpp_bdy_generic.h90" 468 # undef ROUTINE_BDY 469 # undef DIM_4d 470 471 !!---------------------------------------------------------------------- 472 !! 473 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 474 475 476 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 477 478 479 !!---------------------------------------------------------------------- 480 227 #else 228 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 229 mppsize = 1 230 mpprank = 0 231 #endif 232 END SUBROUTINE mpp_start 481 233 482 234 … … 497 249 !!---------------------------------------------------------------------- 498 250 ! 499 SELECT CASE ( cn_mpi_send ) 500 CASE ( 'S' ) ! Standard mpi send (blocking) 501 CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 502 CASE ( 'B' ) ! Buffer mpi send (blocking) 503 CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 504 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 505 ! be carefull, one more argument here : the mpi request identifier.. 506 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 507 END SELECT 251 #if defined key_mpp_mpi 252 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 253 #endif 508 254 ! 509 255 END SUBROUTINE mppsend … … 527 273 !!---------------------------------------------------------------------- 528 274 ! 275 #if defined key_mpp_mpi 529 276 ! If a specific process number has been passed to the receive call, 530 277 ! use that one. Default is to use mpi_any_source … … 533 280 ! 534 281 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 282 #endif 535 283 ! 536 284 END SUBROUTINE mpprecv … … 553 301 ! 554 302 itaille = jpi * jpj 303 #if defined key_mpp_mpi 555 304 CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & 556 305 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 306 #else 307 pio(:,:,1) = ptab(:,:) 308 #endif 557 309 ! 558 310 END SUBROUTINE mppgather … … 576 328 itaille = jpi * jpj 577 329 ! 330 #if defined key_mpp_mpi 578 331 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & 579 332 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 333 #else 334 ptab(:,:) = pio(:,:,1) 335 #endif 580 336 ! 581 337 END SUBROUTINE mppscatter … … 601 357 COMPLEX(wp), ALLOCATABLE, DIMENSION(:) :: ytmp 602 358 !!---------------------------------------------------------------------- 359 #if defined key_mpp_mpi 603 360 ilocalcomm = mpi_comm_oce 604 361 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 639 396 640 397 ! send y_in into todelay(idvar)%y1d with a non-blocking communication 641 # if defined key_mpi2398 # if defined key_mpi2 642 399 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 643 400 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 644 401 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 402 # else 403 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 404 # endif 645 405 #else 646 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr)406 pout(:) = REAL(y_in(:), wp) 647 407 #endif 648 408 … … 668 428 INTEGER :: ierr, ilocalcomm 669 429 !!---------------------------------------------------------------------- 430 #if defined key_mpp_mpi 670 431 ilocalcomm = mpi_comm_oce 671 432 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 702 463 703 464 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 704 # if defined key_mpi2465 # if defined key_mpi2 705 466 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 706 467 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 707 468 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 469 # else 470 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 471 # endif 708 472 #else 709 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr)473 pout(:) = p_in(:) 710 474 #endif 711 475 … … 723 487 INTEGER :: ierr 724 488 !!---------------------------------------------------------------------- 489 #if defined key_mpp_mpi 725 490 IF( ndelayid(kid) /= -2 ) THEN 726 491 #if ! defined key_mpi2 … … 732 497 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 733 498 ENDIF 499 #endif 734 500 END SUBROUTINE mpp_delay_rcv 735 501 … … 890 656 !!----------------------------------------------------------------------- 891 657 ! 658 #if defined key_mpp_mpi 892 659 CALL mpi_barrier( mpi_comm_oce, ierror ) 660 #endif 893 661 ! 894 662 END SUBROUTINE mppsync 895 663 896 664 897 SUBROUTINE mppstop( ld final, ld_force_abort )665 SUBROUTINE mppstop( ld_abort ) 898 666 !!---------------------------------------------------------------------- 899 667 !! *** routine mppstop *** … … 902 670 !! 903 671 !!---------------------------------------------------------------------- 904 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 905 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 906 LOGICAL :: llfinal, ll_force_abort 672 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 673 LOGICAL :: ll_abort 907 674 INTEGER :: info 908 675 !!---------------------------------------------------------------------- 909 llfinal = .FALSE. 910 IF( PRESENT(ldfinal) ) llfinal = ldfinal 911 ll_force_abort = .FALSE. 912 IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 913 ! 914 IF(ll_force_abort) THEN 676 ll_abort = .FALSE. 677 IF( PRESENT(ld_abort) ) ll_abort = ld_abort 678 ! 679 #if defined key_mpp_mpi 680 IF(ll_abort) THEN 915 681 CALL mpi_abort( MPI_COMM_WORLD ) 916 682 ELSE … … 918 684 CALL mpi_finalize( info ) 919 685 ENDIF 920 IF( .NOT. llfinal ) STOP 123456 686 #endif 687 IF( ll_abort ) STOP 123 921 688 ! 922 689 END SUBROUTINE mppstop … … 930 697 !!---------------------------------------------------------------------- 931 698 ! 699 #if defined key_mpp_mpi 932 700 CALL MPI_COMM_FREE(kcom, ierr) 701 #endif 933 702 ! 934 703 END SUBROUTINE mpp_comm_free … … 960 729 INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork 961 730 !!---------------------------------------------------------------------- 731 #if defined key_mpp_mpi 962 732 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world 963 733 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world … … 965 735 ! 966 736 ALLOCATE( kwork(jpnij), STAT=ierr ) 967 IF( ierr /= 0 ) THEN 968 WRITE(kumout, cform_err) 969 WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 970 CALL mppstop 971 ENDIF 737 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 972 738 973 739 IF( jpnj == 1 ) THEN … … 1031 797 1032 798 DEALLOCATE(kwork) 799 #endif 1033 800 1034 801 END SUBROUTINE mpp_ini_znl … … 1062 829 !!---------------------------------------------------------------------- 1063 830 ! 831 #if defined key_mpp_mpi 1064 832 njmppmax = MAXVAL( njmppt ) 1065 833 ! … … 1093 861 CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 1094 862 ! 863 #endif 1095 864 END SUBROUTINE mpp_ini_north 1096 1097 1098 SUBROUTINE mpi_init_oce( ldtxt, ksft, code )1099 !!---------------------------------------------------------------------1100 !! *** routine mpp_init.opa ***1101 !!1102 !! ** Purpose :: export and attach a MPI buffer for bsend1103 !!1104 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment1105 !! but classical mpi_init1106 !!1107 !! History :: 01/11 :: IDRIS initial version for IBM only1108 !! 08/04 :: R. Benshila, generalisation1109 !!---------------------------------------------------------------------1110 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt1111 INTEGER , INTENT(inout) :: ksft1112 INTEGER , INTENT( out) :: code1113 INTEGER :: ierr, ji1114 LOGICAL :: mpi_was_called1115 !!---------------------------------------------------------------------1116 !1117 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization1118 IF ( code /= MPI_SUCCESS ) THEN1119 DO ji = 1, SIZE(ldtxt)1120 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1121 END DO1122 WRITE(*, cform_err)1123 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'1124 CALL mpi_abort( mpi_comm_world, code, ierr )1125 ENDIF1126 !1127 IF( .NOT. mpi_was_called ) THEN1128 CALL mpi_init( code )1129 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )1130 IF ( code /= MPI_SUCCESS ) THEN1131 DO ji = 1, SIZE(ldtxt)1132 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1133 END DO1134 WRITE(*, cform_err)1135 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'1136 CALL mpi_abort( mpi_comm_world, code, ierr )1137 ENDIF1138 ENDIF1139 !1140 IF( nn_buffer > 0 ) THEN1141 WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 11142 ! Buffer allocation and attachment1143 ALLOCATE( tampon(nn_buffer), stat = ierr )1144 IF( ierr /= 0 ) THEN1145 DO ji = 1, SIZE(ldtxt)1146 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1147 END DO1148 WRITE(*, cform_err)1149 WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr1150 CALL mpi_abort( mpi_comm_world, code, ierr )1151 END IF1152 CALL mpi_buffer_attach( tampon, nn_buffer, code )1153 ENDIF1154 !1155 END SUBROUTINE mpi_init_oce1156 865 1157 866 … … 1187 896 1188 897 1189 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)1190 !!---------------------------------------------------------------------1191 !! *** routine mpp_lbc_north_icb ***1192 !!1193 !! ** Purpose : Ensure proper north fold horizontal bondary condition1194 !! in mpp configuration in case of jpn1 > 1 and for 2d1195 !! array with outer extra halo1196 !!1197 !! ** Method : North fold condition and mpp with more than one proc1198 !! in i-direction require a specific treatment. We gather1199 !! the 4+kextj northern lines of the global domain on 11200 !! processor and apply lbc north-fold on this sub array.1201 !! Then we scatter the north fold array back to the processors.1202 !! This routine accounts for an extra halo with icebergs1203 !! and assumes ghost rows and columns have been suppressed.1204 !!1205 !!----------------------------------------------------------------------1206 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo1207 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points1208 ! ! = T , U , V , F or W -points1209 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the1210 !! ! north fold, = 1. otherwise1211 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold1212 !1213 INTEGER :: ji, jj, jr1214 INTEGER :: ierr, itaille, ildi, ilei, iilb1215 INTEGER :: ipj, ij, iproc1216 !1217 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1218 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1219 !!----------------------------------------------------------------------1220 !1221 ipj=41222 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &1223 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &1224 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )1225 !1226 ztab_e(:,:) = 0._wp1227 znorthloc_e(:,:) = 0._wp1228 !1229 ij = 1 - kextj1230 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e1231 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1232 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)1233 ij = ij + 11234 END DO1235 !1236 itaille = jpimax * ( ipj + 2*kextj )1237 !1238 IF( ln_timing ) CALL tic_tac(.TRUE.)1239 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &1240 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &1241 & ncomm_north, ierr )1242 !1243 IF( ln_timing ) CALL tic_tac(.FALSE.)1244 !1245 DO jr = 1, ndim_rank_north ! recover the global north array1246 iproc = nrank_north(jr) + 11247 ildi = nldit (iproc)1248 ilei = nleit (iproc)1249 iilb = nimppt(iproc)1250 DO jj = 1-kextj, ipj+kextj1251 DO ji = ildi, ilei1252 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)1253 END DO1254 END DO1255 END DO1256 1257 ! 2. North-Fold boundary conditions1258 ! ----------------------------------1259 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )1260 1261 ij = 1 - kextj1262 !! Scatter back to pt2d1263 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1264 DO ji= 1, jpi1265 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)1266 END DO1267 ij = ij +11268 END DO1269 !1270 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1271 !1272 END SUBROUTINE mpp_lbc_north_icb1273 1274 1275 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )1276 !!----------------------------------------------------------------------1277 !! *** routine mpp_lnk_2d_icb ***1278 !!1279 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)1280 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)1281 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.1282 !!1283 !! ** Method : Use mppsend and mpprecv function for passing mask1284 !! between processors following neighboring subdomains.1285 !! domain parameters1286 !! jpi : first dimension of the local subdomain1287 !! jpj : second dimension of the local subdomain1288 !! kexti : number of columns for extra outer halo1289 !! kextj : number of rows for extra outer halo1290 !! nbondi : mark for "east-west local boundary"1291 !! nbondj : mark for "north-south local boundary"1292 !! noea : number for local neighboring processors1293 !! nowe : number for local neighboring processors1294 !! noso : number for local neighboring processors1295 !! nono : number for local neighboring processors1296 !!----------------------------------------------------------------------1297 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine1298 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo1299 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1300 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1301 INTEGER , INTENT(in ) :: kexti ! extra i-halo width1302 INTEGER , INTENT(in ) :: kextj ! extra j-halo width1303 !1304 INTEGER :: jl ! dummy loop indices1305 INTEGER :: imigr, iihom, ijhom ! local integers1306 INTEGER :: ipreci, iprecj ! - -1307 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1308 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1309 !!1310 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn1311 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew1312 !!----------------------------------------------------------------------1313 1314 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area1315 iprecj = nn_hls + kextj1316 1317 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )1318 1319 ! 1. standard boundary treatment1320 ! ------------------------------1321 ! Order matters Here !!!!1322 !1323 ! ! East-West boundaries1324 ! !* Cyclic east-west1325 IF( l_Iperio ) THEN1326 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east1327 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west1328 !1329 ELSE !* closed1330 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point1331 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west1332 ENDIF1333 ! ! North-South boundaries1334 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)1335 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north1336 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south1337 ELSE !* closed1338 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point1339 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south1340 ENDIF1341 !1342 1343 ! north fold treatment1344 ! -----------------------1345 IF( npolj /= 0 ) THEN1346 !1347 SELECT CASE ( jpni )1348 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1349 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1350 END SELECT1351 !1352 ENDIF1353 1354 ! 2. East and west directions exchange1355 ! ------------------------------------1356 ! we play with the neigbours AND the row number because of the periodicity1357 !1358 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions1359 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1360 iihom = jpi-nreci-kexti1361 DO jl = 1, ipreci1362 r2dew(:,jl,1) = pt2d(nn_hls+jl,:)1363 r2dwe(:,jl,1) = pt2d(iihom +jl,:)1364 END DO1365 END SELECT1366 !1367 ! ! Migrations1368 imigr = ipreci * ( jpj + 2*kextj )1369 !1370 IF( ln_timing ) CALL tic_tac(.TRUE.)1371 !1372 SELECT CASE ( nbondi )1373 CASE ( -1 )1374 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )1375 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1376 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1377 CASE ( 0 )1378 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1379 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )1380 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1381 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1382 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1383 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1384 CASE ( 1 )1385 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1386 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1387 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1388 END SELECT1389 !1390 IF( ln_timing ) CALL tic_tac(.FALSE.)1391 !1392 ! ! Write Dirichlet lateral conditions1393 iihom = jpi - nn_hls1394 !1395 SELECT CASE ( nbondi )1396 CASE ( -1 )1397 DO jl = 1, ipreci1398 pt2d(iihom+jl,:) = r2dew(:,jl,2)1399 END DO1400 CASE ( 0 )1401 DO jl = 1, ipreci1402 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1403 pt2d(iihom+jl,:) = r2dew(:,jl,2)1404 END DO1405 CASE ( 1 )1406 DO jl = 1, ipreci1407 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1408 END DO1409 END SELECT1410 1411 1412 ! 3. North and south directions1413 ! -----------------------------1414 ! always closed : we play only with the neigbours1415 !1416 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1417 ijhom = jpj-nrecj-kextj1418 DO jl = 1, iprecj1419 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)1420 r2dns(:,jl,1) = pt2d(:,nn_hls+jl)1421 END DO1422 ENDIF1423 !1424 ! ! Migrations1425 imigr = iprecj * ( jpi + 2*kexti )1426 !1427 IF( ln_timing ) CALL tic_tac(.TRUE.)1428 !1429 SELECT CASE ( nbondj )1430 CASE ( -1 )1431 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )1432 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1433 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1434 CASE ( 0 )1435 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1436 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )1437 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1438 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1439 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1440 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1441 CASE ( 1 )1442 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1443 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1444 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1445 END SELECT1446 !1447 IF( ln_timing ) CALL tic_tac(.FALSE.)1448 !1449 ! ! Write Dirichlet lateral conditions1450 ijhom = jpj - nn_hls1451 !1452 SELECT CASE ( nbondj )1453 CASE ( -1 )1454 DO jl = 1, iprecj1455 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1456 END DO1457 CASE ( 0 )1458 DO jl = 1, iprecj1459 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1460 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1461 END DO1462 CASE ( 1 )1463 DO jl = 1, iprecj1464 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1465 END DO1466 END SELECT1467 !1468 END SUBROUTINE mpp_lnk_2d_icb1469 1470 1471 898 SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 1472 899 !!---------------------------------------------------------------------- … … 1480 907 LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg 1481 908 !! 909 CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications 1482 910 LOGICAL :: ll_lbc, ll_glb, ll_dlg 1483 INTEGER :: ji, jj, jk, jh, jf ! dummy loop indices 1484 !!---------------------------------------------------------------------- 911 INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices 912 !!---------------------------------------------------------------------- 913 #if defined key_mpp_mpi 1485 914 ! 1486 915 ll_lbc = .FALSE. … … 1538 967 WRITE(numcom,*) ' ' 1539 968 WRITE(numcom,*) ' lbc_lnk called' 1540 jj = 1 1541 DO ji = 2, n_sequence_lbc 1542 IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 1543 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 1544 jj = 0 969 DO ji = 1, n_sequence_lbc - 1 970 IF ( crname_lbc(ji) /= 'already counted' ) THEN 971 ccountname = crname_lbc(ji) 972 crname_lbc(ji) = 'already counted' 973 jcount = 1 974 DO jj = ji + 1, n_sequence_lbc 975 IF ( ccountname == crname_lbc(jj) ) THEN 976 jcount = jcount + 1 977 crname_lbc(jj) = 'already counted' 978 END IF 979 END DO 980 WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname) 1545 981 END IF 1546 jj = jj + 11547 982 END DO 1548 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 983 IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN 984 WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max)) 985 END IF 1549 986 WRITE(numcom,*) ' ' 1550 987 IF ( n_sequence_glb > 0 ) THEN … … 1585 1022 DEALLOCATE(crname_lbc) 1586 1023 ENDIF 1024 #endif 1587 1025 END SUBROUTINE mpp_report 1588 1026 … … 1595 1033 REAL(wp), SAVE :: tic_ct = 0._wp 1596 1034 INTEGER :: ii 1035 #if defined key_mpp_mpi 1597 1036 1598 1037 IF( ncom_stp <= nit000 ) RETURN … … 1610 1049 tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) 1611 1050 ENDIF 1051 #endif 1612 1052 1613 1053 END SUBROUTINE tic_tac 1614 1054 1055 #if ! defined key_mpp_mpi 1056 SUBROUTINE mpi_wait(request, status, ierror) 1057 INTEGER , INTENT(in ) :: request 1058 INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status 1059 INTEGER , INTENT( out) :: ierror 1060 END SUBROUTINE mpi_wait 1061 1615 1062 1616 #else 1617 !!---------------------------------------------------------------------- 1618 !! Default case: Dummy module share memory computing 1619 !!---------------------------------------------------------------------- 1620 USE in_out_manager 1621 1622 INTERFACE mpp_sum 1623 MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 1624 END INTERFACE 1625 INTERFACE mpp_max 1626 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 1627 END INTERFACE 1628 INTERFACE mpp_min 1629 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 1630 END INTERFACE 1631 INTERFACE mpp_minloc 1632 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 1633 END INTERFACE 1634 INTERFACE mpp_maxloc 1635 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 1636 END INTERFACE 1637 1638 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 1639 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 1640 INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator 1641 1642 INTEGER, PARAMETER, PUBLIC :: nbdelay = 0 ! make sure we don't enter loops: DO ji = 1, nbdelay 1643 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaylist = 'empty' 1644 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaycpnt = 'empty' 1645 LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. 1646 TYPE :: DELAYARR 1647 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 1648 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 1649 END TYPE DELAYARR 1650 TYPE( DELAYARR ), DIMENSION(1), PUBLIC :: todelay 1651 INTEGER, PUBLIC, DIMENSION(1) :: ndelayid = -1 1652 !!---------------------------------------------------------------------- 1653 CONTAINS 1654 1655 INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function 1656 INTEGER, INTENT(in) :: kumout 1657 lib_mpp_alloc = 0 1658 END FUNCTION lib_mpp_alloc 1659 1660 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 1661 INTEGER, OPTIONAL , INTENT(in ) :: localComm 1662 CHARACTER(len=*),DIMENSION(:) :: ldtxt 1663 CHARACTER(len=*) :: ldname 1664 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 1665 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 1666 function_value = 0 1667 IF( .FALSE. ) ldtxt(:) = 'never done' 1668 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 1669 END FUNCTION mynode 1670 1671 SUBROUTINE mppsync ! Dummy routine 1672 END SUBROUTINE mppsync 1673 1674 !!---------------------------------------------------------------------- 1675 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 1676 !! 1677 !!---------------------------------------------------------------------- 1678 !! 1679 # define OPERATION_MAX 1680 # define INTEGER_TYPE 1681 # define DIM_0d 1682 # define ROUTINE_ALLREDUCE mppmax_int 1683 # include "mpp_allreduce_generic.h90" 1684 # undef ROUTINE_ALLREDUCE 1685 # undef DIM_0d 1686 # define DIM_1d 1687 # define ROUTINE_ALLREDUCE mppmax_a_int 1688 # include "mpp_allreduce_generic.h90" 1689 # undef ROUTINE_ALLREDUCE 1690 # undef DIM_1d 1691 # undef INTEGER_TYPE 1692 ! 1693 # define REAL_TYPE 1694 # define DIM_0d 1695 # define ROUTINE_ALLREDUCE mppmax_real 1696 # include "mpp_allreduce_generic.h90" 1697 # undef ROUTINE_ALLREDUCE 1698 # undef DIM_0d 1699 # define DIM_1d 1700 # define ROUTINE_ALLREDUCE mppmax_a_real 1701 # include "mpp_allreduce_generic.h90" 1702 # undef ROUTINE_ALLREDUCE 1703 # undef DIM_1d 1704 # undef REAL_TYPE 1705 # undef OPERATION_MAX 1706 !!---------------------------------------------------------------------- 1707 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 1708 !! 1709 !!---------------------------------------------------------------------- 1710 !! 1711 # define OPERATION_MIN 1712 # define INTEGER_TYPE 1713 # define DIM_0d 1714 # define ROUTINE_ALLREDUCE mppmin_int 1715 # include "mpp_allreduce_generic.h90" 1716 # undef ROUTINE_ALLREDUCE 1717 # undef DIM_0d 1718 # define DIM_1d 1719 # define ROUTINE_ALLREDUCE mppmin_a_int 1720 # include "mpp_allreduce_generic.h90" 1721 # undef ROUTINE_ALLREDUCE 1722 # undef DIM_1d 1723 # undef INTEGER_TYPE 1724 ! 1725 # define REAL_TYPE 1726 # define DIM_0d 1727 # define ROUTINE_ALLREDUCE mppmin_real 1728 # include "mpp_allreduce_generic.h90" 1729 # undef ROUTINE_ALLREDUCE 1730 # undef DIM_0d 1731 # define DIM_1d 1732 # define ROUTINE_ALLREDUCE mppmin_a_real 1733 # include "mpp_allreduce_generic.h90" 1734 # undef ROUTINE_ALLREDUCE 1735 # undef DIM_1d 1736 # undef REAL_TYPE 1737 # undef OPERATION_MIN 1738 1739 !!---------------------------------------------------------------------- 1740 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 1741 !! 1742 !! Global sum of 1D array or a variable (integer, real or complex) 1743 !!---------------------------------------------------------------------- 1744 !! 1745 # define OPERATION_SUM 1746 # define INTEGER_TYPE 1747 # define DIM_0d 1748 # define ROUTINE_ALLREDUCE mppsum_int 1749 # include "mpp_allreduce_generic.h90" 1750 # undef ROUTINE_ALLREDUCE 1751 # undef DIM_0d 1752 # define DIM_1d 1753 # define ROUTINE_ALLREDUCE mppsum_a_int 1754 # include "mpp_allreduce_generic.h90" 1755 # undef ROUTINE_ALLREDUCE 1756 # undef DIM_1d 1757 # undef INTEGER_TYPE 1758 ! 1759 # define REAL_TYPE 1760 # define DIM_0d 1761 # define ROUTINE_ALLREDUCE mppsum_real 1762 # include "mpp_allreduce_generic.h90" 1763 # undef ROUTINE_ALLREDUCE 1764 # undef DIM_0d 1765 # define DIM_1d 1766 # define ROUTINE_ALLREDUCE mppsum_a_real 1767 # include "mpp_allreduce_generic.h90" 1768 # undef ROUTINE_ALLREDUCE 1769 # undef DIM_1d 1770 # undef REAL_TYPE 1771 # undef OPERATION_SUM 1772 1773 # define OPERATION_SUM_DD 1774 # define COMPLEX_TYPE 1775 # define DIM_0d 1776 # define ROUTINE_ALLREDUCE mppsum_realdd 1777 # include "mpp_allreduce_generic.h90" 1778 # undef ROUTINE_ALLREDUCE 1779 # undef DIM_0d 1780 # define DIM_1d 1781 # define ROUTINE_ALLREDUCE mppsum_a_realdd 1782 # include "mpp_allreduce_generic.h90" 1783 # undef ROUTINE_ALLREDUCE 1784 # undef DIM_1d 1785 # undef COMPLEX_TYPE 1786 # undef OPERATION_SUM_DD 1787 1788 !!---------------------------------------------------------------------- 1789 !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 1790 !! 1791 !!---------------------------------------------------------------------- 1792 !! 1793 # define OPERATION_MINLOC 1794 # define DIM_2d 1795 # define ROUTINE_LOC mpp_minloc2d 1796 # include "mpp_loc_generic.h90" 1797 # undef ROUTINE_LOC 1798 # undef DIM_2d 1799 # define DIM_3d 1800 # define ROUTINE_LOC mpp_minloc3d 1801 # include "mpp_loc_generic.h90" 1802 # undef ROUTINE_LOC 1803 # undef DIM_3d 1804 # undef OPERATION_MINLOC 1805 1806 # define OPERATION_MAXLOC 1807 # define DIM_2d 1808 # define ROUTINE_LOC mpp_maxloc2d 1809 # include "mpp_loc_generic.h90" 1810 # undef ROUTINE_LOC 1811 # undef DIM_2d 1812 # define DIM_3d 1813 # define ROUTINE_LOC mpp_maxloc3d 1814 # include "mpp_loc_generic.h90" 1815 # undef ROUTINE_LOC 1816 # undef DIM_3d 1817 # undef OPERATION_MAXLOC 1818 1819 SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 1820 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1821 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1822 COMPLEX(wp), INTENT(in ), DIMENSION(:) :: y_in 1823 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1824 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1825 INTEGER, INTENT(in ), OPTIONAL :: kcom 1826 ! 1827 pout(:) = REAL(y_in(:), wp) 1828 END SUBROUTINE mpp_delay_sum 1829 1830 SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 1831 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1832 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1833 REAL(wp), INTENT(in ), DIMENSION(:) :: p_in 1834 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1835 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1836 INTEGER, INTENT(in ), OPTIONAL :: kcom 1837 ! 1838 pout(:) = p_in(:) 1839 END SUBROUTINE mpp_delay_max 1840 1841 SUBROUTINE mpp_delay_rcv( kid ) 1842 INTEGER,INTENT(in ) :: kid 1843 WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 1844 END SUBROUTINE mpp_delay_rcv 1845 1846 SUBROUTINE mppstop( ldfinal, ld_force_abort ) 1847 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 1848 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 1849 STOP ! non MPP case, just stop the run 1850 END SUBROUTINE mppstop 1851 1852 SUBROUTINE mpp_ini_znl( knum ) 1853 INTEGER :: knum 1854 WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 1855 END SUBROUTINE mpp_ini_znl 1856 1857 SUBROUTINE mpp_comm_free( kcom ) 1858 INTEGER :: kcom 1859 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 1860 END SUBROUTINE mpp_comm_free 1861 1862 #endif 1863 1864 !!---------------------------------------------------------------------- 1865 !! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1063 FUNCTION MPI_Wtime() 1064 REAL(wp) :: MPI_Wtime 1065 MPI_Wtime = -1. 1066 END FUNCTION MPI_Wtime 1067 #endif 1068 1069 !!---------------------------------------------------------------------- 1070 !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1866 1071 !!---------------------------------------------------------------------- 1867 1072 … … 1874 1079 !! increment the error number (nstop) by one. 1875 1080 !!---------------------------------------------------------------------- 1876 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 1877 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1081 CHARACTER(len=*), INTENT(in ) :: cd1 1082 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 1083 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1878 1084 !!---------------------------------------------------------------------- 1879 1085 ! 1880 1086 nstop = nstop + 1 1881 1882 ! force to open ocean.output file 1087 ! 1088 ! force to open ocean.output file if not already opened 1883 1089 IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1884 1885 WRITE(numout,cform_err) 1886 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1090 ! 1091 WRITE(numout,*) 1092 WRITE(numout,*) ' ===>>> : E R R O R' 1093 WRITE(numout,*) 1094 WRITE(numout,*) ' ===========' 1095 WRITE(numout,*) 1096 WRITE(numout,*) TRIM(cd1) 1887 1097 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1888 1098 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) … … 1894 1104 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1895 1105 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1896 1106 WRITE(numout,*) 1107 ! 1897 1108 CALL FLUSH(numout ) 1898 1109 IF( numstp /= -1 ) CALL FLUSH(numstp ) … … 1901 1112 ! 1902 1113 IF( cd1 == 'STOP' ) THEN 1114 WRITE(numout,*) 1903 1115 WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' 1904 CALL mppstop(ld_force_abort = .true.) 1116 WRITE(numout,*) 1117 CALL mppstop( ld_abort = .true. ) 1905 1118 ENDIF 1906 1119 ! … … 1921 1134 ! 1922 1135 nwarn = nwarn + 1 1136 ! 1923 1137 IF(lwp) THEN 1924 WRITE(numout,cform_war) 1925 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1926 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1927 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1928 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1929 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1930 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1931 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1932 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1933 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1934 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1138 WRITE(numout,*) 1139 WRITE(numout,*) ' ===>>> : W A R N I N G' 1140 WRITE(numout,*) 1141 WRITE(numout,*) ' ===============' 1142 WRITE(numout,*) 1143 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1144 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1145 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1146 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1147 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1148 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1149 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1150 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1151 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1152 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1153 WRITE(numout,*) 1935 1154 ENDIF 1936 1155 CALL FLUSH(numout) … … 1975 1194 IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null 1976 1195 ! 1977 iost=0 1978 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1196 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1979 1197 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) 1980 1198 ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters … … 1997 1215 100 CONTINUE 1998 1216 IF( iost /= 0 ) THEN 1999 IF(ldwp) THEN 2000 WRITE(kout,*) 2001 WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2002 WRITE(kout,*) ' ======= === ' 2003 WRITE(kout,*) ' unit = ', knum 2004 WRITE(kout,*) ' status = ', cdstat 2005 WRITE(kout,*) ' form = ', cdform 2006 WRITE(kout,*) ' access = ', cdacce 2007 WRITE(kout,*) ' iostat = ', iost 2008 WRITE(kout,*) ' we stop. verify the file ' 2009 WRITE(kout,*) 2010 ELSE !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 2011 WRITE(*,*) 2012 WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2013 WRITE(*,*) ' ======= === ' 2014 WRITE(*,*) ' unit = ', knum 2015 WRITE(*,*) ' status = ', cdstat 2016 WRITE(*,*) ' form = ', cdform 2017 WRITE(*,*) ' access = ', cdacce 2018 WRITE(*,*) ' iostat = ', iost 2019 WRITE(*,*) ' we stop. verify the file ' 2020 WRITE(*,*) 2021 ENDIF 2022 CALL FLUSH( kout ) 2023 STOP 'ctl_opn bad opening' 1217 WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 1218 WRITE(ctmp2,*) ' ======= === ' 1219 WRITE(ctmp3,*) ' unit = ', knum 1220 WRITE(ctmp4,*) ' status = ', cdstat 1221 WRITE(ctmp5,*) ' form = ', cdform 1222 WRITE(ctmp6,*) ' access = ', cdacce 1223 WRITE(ctmp7,*) ' iostat = ', iost 1224 WRITE(ctmp8,*) ' we stop. verify the file ' 1225 CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 2024 1226 ENDIF 2025 1227 ! … … 2027 1229 2028 1230 2029 SUBROUTINE ctl_nam ( kios, cdnam , ldwp)1231 SUBROUTINE ctl_nam ( kios, cdnam ) 2030 1232 !!---------------------------------------------------------------------- 2031 1233 !! *** ROUTINE ctl_nam *** … … 2035 1237 !! ** Method : Fortan open 2036 1238 !!---------------------------------------------------------------------- 2037 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist2038 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs2039 CHARACTER(len=5) :: clios ! string to convert iostat in character for print2040 LOGICAL , INTENT(in ) :: ldwp ! boolean termfor print1239 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 1240 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 1241 ! 1242 CHARACTER(len=5) :: clios ! string to convert iostat in character for print 2041 1243 !!---------------------------------------------------------------------- 2042 1244 ! … … 2052 1254 ENDIF 2053 1255 kios = 0 2054 RETURN2055 1256 ! 2056 1257 END SUBROUTINE ctl_nam … … 2073 1274 END DO 2074 1275 IF( (get_unit == 999) .AND. llopn ) THEN 2075 CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 2076 get_unit = -1 1276 CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 2077 1277 ENDIF 2078 1278 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/mpp_lnk_generic.h90
r10542 r12065 46 46 47 47 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval)49 INTEGER 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 49 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 50 #else 51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , cd_mpp, pval)51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ihlcom ) 52 52 #endif 53 53 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 54 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 56 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 57 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 58 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 59 ! 60 INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices 54 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 56 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 57 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 58 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 59 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 60 INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated 61 ! 62 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 61 63 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 62 INTEGER :: i migr, iihom, ijhom! local integers63 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend64 INTEGER :: isize, ishift, ishift2 ! local integers 65 INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id 64 66 INTEGER :: ierr 67 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 68 INTEGER :: ihl ! number of ranks and rows to be communicated 65 69 REAL(wp) :: zland 66 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 67 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! north-south & south-north halos 68 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! east -west & west - east halos 70 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 71 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 72 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 73 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 74 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive 75 LOGICAL :: lldo_nfd ! do north pole folding 69 76 !!---------------------------------------------------------------------- 77 ! 78 ! ----------------------------------------- ! 79 ! 0. local variables initialization ! 80 ! ----------------------------------------- ! 70 81 ! 71 82 ipk = K_SIZE(ptab) ! 3rd dimension … … 73 84 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 74 85 ! 86 IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom 87 ELSE ; ihl = 1 88 END IF 89 ! 75 90 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 76 91 ! 77 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 78 ELSE ; zland = 0._wp ! zero by default 79 ENDIF 80 81 ! ------------------------------- ! 82 ! standard boundary treatment ! ! CAUTION: semi-column notation is often impossible 83 ! ------------------------------- ! 84 ! 85 IF( .NOT. PRESENT( cd_mpp ) ) THEN !== standard close or cyclic treatment ==! 86 ! 87 DO jf = 1, ipf ! number of arrays to be treated 88 ! 89 ! ! East-West boundaries 90 IF( l_Iperio ) THEN !* cyclic 91 ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) 92 ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf) 93 ELSE !* closed 94 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 :nn_hls,:,:,:,jf) = zland ! east except F-point 95 ARRAY_IN(nlci-nn_hls+1:jpi ,:,:,:,jf) = zland ! west 96 ENDIF 97 ! ! North-South boundaries 98 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 99 ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf) 100 ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf) 101 ELSE !* closed 102 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 :nn_hls,:,:,jf) = zland ! south except F-point 103 ARRAY_IN(:,nlcj-nn_hls+1:jpj ,:,:,jf) = zland ! north 92 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 93 llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4) 94 llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4) 95 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 96 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 97 WRITE(ctmp2,*) ' ========== ' 98 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 99 ELSE ! send and receive with every neighbour 100 llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 101 llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 102 llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 103 llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 104 llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no 105 END IF 106 107 108 lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini 109 110 zland = 0._wp ! land filling value: zero by default 111 IF( PRESENT( pfillval ) ) zland = pfillval ! set land value 112 113 ! define the method we will use to fill the halos in each direction 114 IF( llrecv_we ) THEN ; ifill_we = jpfillmpi 115 ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio 116 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode 117 ELSE ; ifill_we = jpfillcst 118 END IF 119 ! 120 IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi 121 ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio 122 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode 123 ELSE ; ifill_ea = jpfillcst 124 END IF 125 ! 126 IF( llrecv_so ) THEN ; ifill_so = jpfillmpi 127 ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio 128 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode 129 ELSE ; ifill_so = jpfillcst 130 END IF 131 ! 132 IF( llrecv_no ) THEN ; ifill_no = jpfillmpi 133 ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio 134 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode 135 ELSE ; ifill_no = jpfillcst 136 END IF 137 ! 138 #if defined PRINT_CAUTION 139 ! 140 ! ================================================================================== ! 141 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 142 ! ================================================================================== ! 143 ! 144 #endif 145 ! 146 ! -------------------------------------------------- ! 147 ! 1. Do east and west MPI exchange if needed ! 148 ! -------------------------------------------------- ! 149 ! 150 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 151 isize = ihl * jpj * ipk * ipl * ipf 152 ! 153 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 154 IF( llsend_we ) ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) ) 155 IF( llsend_ea ) ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) ) 156 IF( llrecv_we ) ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) ) 157 IF( llrecv_ea ) ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) ) 158 ! 159 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 160 ishift = ihl 161 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 162 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl 163 END DO ; END DO ; END DO ; END DO ; END DO 164 ENDIF 165 ! 166 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 167 ishift = jpi - 2 * ihl 168 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 169 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*ihl + 1 -> jpi - ihl 170 END DO ; END DO ; END DO ; END DO ; END DO 171 ENDIF 172 ! 173 IF( ln_timing ) CALL tic_tac(.TRUE.) 174 ! 175 ! non-blocking send of the western/eastern side using local temporary arrays 176 IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 177 IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 178 ! blocking receive of the western/eastern halo in local temporary arrays 179 IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 180 IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 181 ! 182 IF( ln_timing ) CALL tic_tac(.FALSE.) 183 ! 184 ! 185 ! ----------------------------------- ! 186 ! 2. Fill east and west halos ! 187 ! ----------------------------------- ! 188 ! 189 ! 2.1 fill weastern halo 190 ! ---------------------- 191 ! ishift = 0 ! fill halo from ji = 1 to ihl 192 SELECT CASE ( ifill_we ) 193 CASE ( jpfillnothing ) ! no filling 194 CASE ( jpfillmpi ) ! use data received by MPI 195 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 196 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl 197 END DO; END DO ; END DO ; END DO ; END DO 198 CASE ( jpfillperio ) ! use east-weast periodicity 199 ishift2 = jpi - 2 * ihl 200 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 201 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 202 END DO; END DO ; END DO ; END DO ; END DO 203 CASE ( jpfillcopy ) ! filling with inner domain values 204 DO jf = 1, ipf ! number of arrays to be treated 205 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 206 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 207 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 208 END DO ; END DO ; END DO ; END DO 104 209 ENDIF 105 210 END DO 106 ! 107 ENDIF 108 109 ! ------------------------------- ! 110 ! East and west exchange ! 111 ! ------------------------------- ! 112 ! we play with the neigbours AND the row number because of the periodicity 113 ! 114 IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) ) 115 IF( nbondi == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) ) 116 ! 117 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 118 CASE ( -1 ) 119 iihom = nlci-nreci 120 DO jf = 1, ipf 121 DO jl = 1, ipl 122 DO jk = 1, ipk 123 DO jh = 1, nn_hls 124 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 125 END DO 126 END DO 127 END DO 128 END DO 129 CASE ( 0 ) 130 iihom = nlci-nreci 131 DO jf = 1, ipf 132 DO jl = 1, ipl 133 DO jk = 1, ipk 134 DO jh = 1, nn_hls 135 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 136 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 137 END DO 138 END DO 139 END DO 140 END DO 141 CASE ( 1 ) 142 iihom = nlci-nreci 143 DO jf = 1, ipf 144 DO jl = 1, ipl 145 DO jk = 1, ipk 146 DO jh = 1, nn_hls 147 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 148 END DO 149 END DO 150 END DO 211 CASE ( jpfillcst ) ! filling with constant value 212 DO jf = 1, ipf ! number of arrays to be treated 213 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 214 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 215 ARRAY_IN(ji,jj,jk,jl,jf) = zland 216 END DO; END DO ; END DO ; END DO 217 ENDIF 151 218 END DO 152 219 END SELECT 153 ! ! Migrations 154 imigr = nn_hls * jpj * ipk * ipl * ipf 155 ! 156 IF( ln_timing ) CALL tic_tac(.TRUE.) 157 ! 158 SELECT CASE ( nbondi ) 159 CASE ( -1 ) 160 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 ) 161 CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea ) 162 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 163 CASE ( 0 ) 164 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 165 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 ) 166 CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 167 CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 168 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 169 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 170 CASE ( 1 ) 171 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 172 CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe ) 173 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 220 ! 221 ! 2.2 fill eastern halo 222 ! --------------------- 223 ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi 224 SELECT CASE ( ifill_ea ) 225 CASE ( jpfillnothing ) ! no filling 226 CASE ( jpfillmpi ) ! use data received by MPI 227 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 228 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl + 1 -> jpi 229 END DO ; END DO ; END DO ; END DO ; END DO 230 CASE ( jpfillperio ) ! use east-weast periodicity 231 ishift2 = ihl 232 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 233 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 234 END DO ; END DO ; END DO ; END DO ; END DO 235 CASE ( jpfillcopy ) ! filling with inner domain values 236 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 237 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 238 END DO ; END DO ; END DO ; END DO ; END DO 239 CASE ( jpfillcst ) ! filling with constant value 240 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 241 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 242 END DO; END DO ; END DO ; END DO ; END DO 174 243 END SELECT 175 !176 IF( ln_timing ) CALL tic_tac(.FALSE.)177 !178 ! ! Write Dirichlet lateral conditions179 iihom = nlci-nn_hls180 !181 SELECT CASE ( nbondi )182 CASE ( -1 )183 DO jf = 1, ipf184 DO jl = 1, ipl185 DO jk = 1, ipk186 DO jh = 1, nn_hls187 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1)188 END DO189 END DO190 END DO191 END DO192 CASE ( 0 )193 DO jf = 1, ipf194 DO jl = 1, ipl195 DO jk = 1, ipk196 DO jh = 1, nn_hls197 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)198 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)199 END DO200 END DO201 END DO202 END DO203 CASE ( 1 )204 DO jf = 1, ipf205 DO jl = 1, ipl206 DO jk = 1, ipk207 DO jh = 1, nn_hls208 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1)209 END DO210 END DO211 END DO212 END DO213 END SELECT214 !215 IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we )216 244 ! 217 245 ! ------------------------------- ! 218 246 ! 3. north fold treatment ! 219 247 ! ------------------------------- ! 248 ! 220 249 ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 221 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 250 ! 251 IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 222 252 ! 223 253 SELECT CASE ( jpni ) … … 226 256 END SELECT 227 257 ! 228 ENDIF 229 ! 230 ! ------------------------------- ! 231 ! 4. North and south directions ! 232 ! ------------------------------- ! 233 ! always closed : we play only with the neigbours 234 ! 235 IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) ) 236 IF( nbondj == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) ) 237 ! 238 SELECT CASE ( nbondj ) 239 CASE ( -1 ) 240 ijhom = nlcj-nrecj 241 DO jf = 1, ipf 242 DO jl = 1, ipl 243 DO jk = 1, ipk 244 DO jh = 1, nn_hls 245 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 246 END DO 247 END DO 248 END DO 258 ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding 259 ! 260 ENDIF 261 ! 262 ! ---------------------------------------------------- ! 263 ! 4. Do north and south MPI exchange if needed ! 264 ! ---------------------------------------------------- ! 265 ! 266 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) ) 267 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) ) 268 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) ) 269 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) ) 270 ! 271 isize = jpi * ihl * ipk * ipl * ipf 272 273 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 274 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 275 ishift = ihl 276 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 277 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl 278 END DO ; END DO ; END DO ; END DO ; END DO 279 ENDIF 280 ! 281 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 282 ishift = jpj - 2 * ihl 283 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 284 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*ihl+1 -> jpj-ihl 285 END DO ; END DO ; END DO ; END DO ; END DO 286 ENDIF 287 ! 288 IF( ln_timing ) CALL tic_tac(.TRUE.) 289 ! 290 ! non-blocking send of the southern/northern side 291 IF( llsend_so ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 292 IF( llsend_no ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 293 ! blocking receive of the southern/northern halo 294 IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 295 IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 296 ! 297 IF( ln_timing ) CALL tic_tac(.FALSE.) 298 ! 299 ! ------------------------------------- ! 300 ! 5. Fill south and north halos ! 301 ! ------------------------------------- ! 302 ! 303 ! 5.1 fill southern halo 304 ! ---------------------- 305 ! ishift = 0 ! fill halo from jj = 1 to ihl 306 SELECT CASE ( ifill_so ) 307 CASE ( jpfillnothing ) ! no filling 308 CASE ( jpfillmpi ) ! use data received by MPI 309 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 310 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl 311 END DO; END DO ; END DO ; END DO ; END DO 312 CASE ( jpfillperio ) ! use north-south periodicity 313 ishift2 = jpj - 2 * ihl 314 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 315 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 316 END DO; END DO ; END DO ; END DO ; END DO 317 CASE ( jpfillcopy ) ! filling with inner domain values 318 DO jf = 1, ipf ! number of arrays to be treated 319 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 320 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 321 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 322 END DO ; END DO ; END DO ; END DO 323 ENDIF 249 324 END DO 250 CASE ( 0 ) 251 ijhom = nlcj-nrecj 252 DO jf = 1, ipf 253 DO jl = 1, ipl 254 DO jk = 1, ipk 255 DO jh = 1, nn_hls 256 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 257 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 258 END DO 259 END DO 260 END DO 261 END DO 262 CASE ( 1 ) 263 ijhom = nlcj-nrecj 264 DO jf = 1, ipf 265 DO jl = 1, ipl 266 DO jk = 1, ipk 267 DO jh = 1, nn_hls 268 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 269 END DO 270 END DO 271 END DO 325 CASE ( jpfillcst ) ! filling with constant value 326 DO jf = 1, ipf ! number of arrays to be treated 327 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 328 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 329 ARRAY_IN(ji,jj,jk,jl,jf) = zland 330 END DO; END DO ; END DO ; END DO 331 ENDIF 272 332 END DO 273 333 END SELECT 274 334 ! 275 ! ! Migrations 276 imigr = nn_hls * jpi * ipk * ipl * ipf 277 ! 278 IF( ln_timing ) CALL tic_tac(.TRUE.) 279 ! 280 SELECT CASE ( nbondj ) 281 CASE ( -1 ) 282 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 ) 283 CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono ) 284 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 285 CASE ( 0 ) 286 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 287 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 ) 288 CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 289 CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 290 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 291 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 292 CASE ( 1 ) 293 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 294 CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso ) 295 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 335 ! 5.2 fill northern halo 336 ! ---------------------- 337 ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj 338 SELECT CASE ( ifill_no ) 339 CASE ( jpfillnothing ) ! no filling 340 CASE ( jpfillmpi ) ! use data received by MPI 341 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 342 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-ihl+1 -> jpj 343 END DO ; END DO ; END DO ; END DO ; END DO 344 CASE ( jpfillperio ) ! use north-south periodicity 345 ishift2 = ihl 346 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 347 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 348 END DO; END DO ; END DO ; END DO ; END DO 349 CASE ( jpfillcopy ) ! filling with inner domain values 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 351 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 352 END DO; END DO ; END DO ; END DO ; END DO 353 CASE ( jpfillcst ) ! filling with constant value 354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 356 END DO; END DO ; END DO ; END DO ; END DO 296 357 END SELECT 297 358 ! 298 IF( ln_timing ) CALL tic_tac(.FALSE.) 299 ! ! Write Dirichlet lateral conditions 300 ijhom = nlcj-nn_hls 301 ! 302 SELECT CASE ( nbondj ) 303 CASE ( -1 ) 304 DO jf = 1, ipf 305 DO jl = 1, ipl 306 DO jk = 1, ipk 307 DO jh = 1, nn_hls 308 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1) 309 END DO 310 END DO 311 END DO 312 END DO 313 CASE ( 0 ) 314 DO jf = 1, ipf 315 DO jl = 1, ipl 316 DO jk = 1, ipk 317 DO jh = 1, nn_hls 318 ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 319 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 320 END DO 321 END DO 322 END DO 323 END DO 324 CASE ( 1 ) 325 DO jf = 1, ipf 326 DO jl = 1, ipl 327 DO jk = 1, ipk 328 DO jh = 1, nn_hls 329 ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1) 330 END DO 331 END DO 332 END DO 333 END DO 334 END SELECT 335 ! 336 IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn ) 359 ! -------------------------------------------- ! 360 ! 6. deallocate local temporary arrays ! 361 ! -------------------------------------------- ! 362 ! 363 IF( llsend_we ) THEN 364 CALL mpi_wait(ireq_we, istat, ierr ) 365 DEALLOCATE( zsnd_we ) 366 ENDIF 367 IF( llsend_ea ) THEN 368 CALL mpi_wait(ireq_ea, istat, ierr ) 369 DEALLOCATE( zsnd_ea ) 370 ENDIF 371 IF( llsend_so ) THEN 372 CALL mpi_wait(ireq_so, istat, ierr ) 373 DEALLOCATE( zsnd_so ) 374 ENDIF 375 IF( llsend_no ) THEN 376 CALL mpi_wait(ireq_no, istat, ierr ) 377 DEALLOCATE( zsnd_no ) 378 ENDIF 379 ! 380 IF( llrecv_we ) DEALLOCATE( zrcv_we ) 381 IF( llrecv_ea ) DEALLOCATE( zrcv_ea ) 382 IF( llrecv_so ) DEALLOCATE( zrcv_so ) 383 IF( llrecv_no ) DEALLOCATE( zrcv_no ) 337 384 ! 338 385 END SUBROUTINE ROUTINE_LNK -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/mpp_nfd_generic.h90
r10440 r12065 76 76 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 77 77 ! 78 IF( l_north_nogather ) THEN !== ????==!78 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 79 79 80 80 ALLOCATE(ipj_s(ipf)) … … 200 200 ENDIF 201 201 END DO 202 IF( l_isend ) THEN 203 DO jr = 1,nsndto 204 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 205 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 206 ENDIF 207 END DO 208 ENDIF 202 DO jr = 1,nsndto 203 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 204 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 205 ENDIF 206 END DO 209 207 ! 210 208 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 213 211 ! 214 212 DO jf = 1, ipf 215 CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 216 END DO 217 ! 218 DEALLOCATE( zfoldwk ) 219 DEALLOCATE( ztabr ) 220 DEALLOCATE( jj_s ) 221 DEALLOCATE( ipj_s ) 222 ELSE !== ???? ==! 213 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 214 END DO 215 ! 216 DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 217 ! 218 ELSE !== allgather exchanges ==! 223 219 ! 224 220 ipj = 4 ! 2nd dimension of message transfers (last j-lines) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/mppini.F90
r10615 r12065 84 84 nbondj = 2 85 85 nidom = FLIO_DOM_NONE 86 npolj = jperio 86 npolj = 0 87 IF( jperio == 3 .OR. jperio == 4 ) npolj = 3 88 IF( jperio == 5 .OR. jperio == 6 ) npolj = 5 87 89 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 88 90 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) … … 152 154 LOGICAL :: llbest, llauto 153 155 LOGICAL :: llwrtlay 156 LOGICAL :: ln_listonly 154 157 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 155 158 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - … … 164 167 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 165 168 & cn_ice, nn_ice_dta, & 166 & rn_ice_tem, rn_ice_sal, rn_ice_age, &167 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy168 !!---------------------------------------------------------------------- 169 169 & ln_vol, nn_volctl, nn_rimwidth 170 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly 171 !!---------------------------------------------------------------------- 172 ! 170 173 llwrtlay = lwp .OR. ln_ctl .OR. sn_cfctl%l_layout 174 ! 175 ! 0. read namelists parameters 176 ! ----------------------------------- 177 ! 178 REWIND( numnam_ref ) ! Namelist nammpp in reference namelist 179 READ ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) 180 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist' ) 181 REWIND( numnam_cfg ) ! Namelist nammpp in confguration namelist 182 READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 183 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 184 ! 185 IF(lwp) THEN 186 WRITE(numout,*) ' Namelist nammpp' 187 IF( jpni < 1 .OR. jpnj < 1 ) THEN 188 WRITE(numout,*) ' jpni and jpnj will be calculated automatically' 189 ELSE 190 WRITE(numout,*) ' processor grid extent in i jpni = ', jpni 191 WRITE(numout,*) ' processor grid extent in j jpnj = ', jpnj 192 ENDIF 193 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 194 ENDIF 195 ! 196 IF(lwm) WRITE( numond, nammpp ) 197 171 198 ! do we need to take into account bdy_msk? 172 199 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist : BDY 173 200 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 174 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' , lwp)201 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) 175 202 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist : BDY 176 203 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 177 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' , lwp)204 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) 178 205 ! 179 206 IF( ln_read_cfg ) CALL iom_open( cn_domcfg, numbot ) 180 207 IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 208 ! 209 IF( ln_listonly ) CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 181 210 ! 182 211 ! 1. Dimension arrays for subdomains … … 241 270 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 242 271 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 243 CALL ctl_stop( 'STOP' )244 272 ENDIF 245 273 … … 266 294 ENDIF 267 295 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 268 CALL ctl_stop( 'STOP' )269 296 ENDIF 270 297 … … 511 538 9401 FORMAT(' ' ,20(' ',i3,' ') ) 512 539 9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ') ) 513 9404 FORMAT(' * ' ,20(' ',i3,' * ') )540 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 514 541 ENDIF 515 542 … … 669 696 ! 670 697 CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary) 671 ! 672 IF ( ln_nnogather) THEN698 ! 699 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 673 700 CALL mpp_init_nfdcom ! northfold neighbour lists 674 701 IF (llwrtlay) THEN … … 816 843 INTEGER :: isziref, iszjref 817 844 INTEGER :: inbij, iszij 818 INTEGER :: inbimax, inbjmax, inbijmax 845 INTEGER :: inbimax, inbjmax, inbijmax, inbijold 819 846 INTEGER :: isz0, isz1 820 847 INTEGER, DIMENSION( :), ALLOCATABLE :: indexok … … 941 968 DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) 942 969 943 IF( llist ) THEN ! we print about 21 best partitions970 IF( llist ) THEN 944 971 IF(lwp) THEN 945 972 WRITE(numout,*) 946 WRITE(numout, 947 WRITE(numout, '(a,i5,a)') ' list of the best partitions around ', knbij, ' mpi processes'948 WRITE(numout, *) ' --------------------------------------', '-----', '--------------'973 WRITE(numout,*) ' For your information:' 974 WRITE(numout,*) ' list of the best partitions including land supression' 975 WRITE(numout,*) ' -----------------------------------------------------' 949 976 WRITE(numout,*) 950 977 END IF 951 iitarget = MINLOC( inbi0(:)*inbj0(:), mask = inbi0(:)*inbj0(:) >= knbij, dim = 1 ) 952 DO ji = MAX(1,iitarget-10), MIN(isz0,iitarget+10) 978 ji = isz0 ! initialization with the largest value 979 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 980 CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 981 inbijold = COUNT(llisoce) 982 DEALLOCATE( llisoce ) 983 DO ji =isz0-1,1,-1 953 984 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 954 985 CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 955 986 inbij = COUNT(llisoce) 956 987 DEALLOCATE( llisoce ) 957 IF(lwp) WRITE(numout,'(a, i5, a, i5, a, i4, a, i4, a, i9, a, i5, a, i5, a)') & 958 & 'nb_cores ' , inbij,' oce + ', inbi0(ji)*inbj0(ji) - inbij & 959 & , ' land ( ', inbi0(ji),' x ', inbj0(ji), & 960 & ' ), nb_points ', iszi0(ji)*iszj0(ji),' ( ', iszi0(ji),' x ', iszj0(ji),' )' 988 IF(lwp .AND. inbij < inbijold) THEN 989 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & 990 & 'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij, & 991 & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100., & 992 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 993 inbijold = inbij 994 END IF 961 995 END DO 962 996 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 963 RETURN 997 IF(lwp) THEN 998 WRITE(numout,*) 999 WRITE(numout,*) ' -----------------------------------------------------------' 1000 ENDIF 1001 CALL mppsync 1002 CALL mppstop( ld_abort = .TRUE. ) 964 1003 ENDIF 965 1004 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LDF/ldfdyn.F90
r10425 r12065 62 62 63 63 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahmt, ahmf !: eddy viscosity coef. at T- and F-points [m2/s or m4/s] 64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ):: dtensq !: horizontal tension squared (Smagorinsky only)65 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ):: dshesq !: horizontal shearing strain squared (Smagorinsky only)64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dtensq !: horizontal tension squared (Smagorinsky only) 65 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dshesq !: horizontal shearing strain squared (Smagorinsky only) 66 66 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: esqt, esqf !: Square of the local gridscale (e1e2/(e1+e2))**2 67 67 … … 117 117 REWIND( numnam_ref ) ! Namelist namdyn_ldf in reference namelist : Lateral physics 118 118 READ ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901) 119 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' , lwp)119 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' ) 120 120 121 121 REWIND( numnam_cfg ) ! Namelist namdyn_ldf in configuration namelist : Lateral physics 122 122 READ ( numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902 ) 123 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' , lwp)123 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' ) 124 124 IF(lwm) WRITE ( numond, namdyn_ldf ) 125 125 … … 242 242 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate arrays') 243 243 ! 244 ahmt(:,:, jpk) = 0._wp ! last level always 0245 ahmf(:,:, jpk) = 0._wp244 ahmt(:,:,:) = 0._wp ! init to 0 needed 245 ahmf(:,:,:) = 0._wp 246 246 ! 247 247 ! ! value of lap/blp eddy mixing coef. … … 310 310 ! 311 311 ! ! allocate arrays used in ldf_dyn. 312 ALLOCATE( dtensq(jpi,jpj ) , dshesq(jpi,jpj) , esqt(jpi,jpj) ,esqf(jpi,jpj) , STAT=ierr )312 ALLOCATE( dtensq(jpi,jpj,jpk) , dshesq(jpi,jpj,jpk) , esqt(jpi,jpj) , esqf(jpi,jpj) , STAT=ierr ) 313 313 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') 314 314 ! 315 DO jj = 2, jpjm1! Set local gridscale values316 DO ji = fs_2, fs_jpim1317 esqt(ji,jj) = ( e1e2t(ji,jj) /( e1t(ji,jj) + e2t(ji,jj) ) )**2318 esqf(ji,jj) = ( e1e2f(ji,jj) /( e1f(ji,jj) + e2f(ji,jj) ) )**2315 DO jj = 1, jpj ! Set local gridscale values 316 DO ji = 1, jpi 317 esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2 318 esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2 319 319 END DO 320 320 END DO … … 359 359 ! 360 360 INTEGER :: ji, jj, jk ! dummy loop indices 361 REAL(wp) :: zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, ze tmax, zefmax ! local scalar362 REAL(wp) :: zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb ! local scalar361 REAL(wp) :: zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zemax ! local scalar (option 31) 362 REAL(wp) :: zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb ! local scalar (option 32) 363 363 !!---------------------------------------------------------------------- 364 364 ! … … 373 373 DO jj = 2, jpjm1 374 374 DO ji = fs_2, fs_jpim1 375 zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) 376 zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) 377 zemax = MAX( e1t(ji,jj) , e2t(ji,jj) ) 378 ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax * tmask(ji,jj,jk) ! 288= 12*12 * 2 379 END DO 380 END DO 381 DO jj = 1, jpjm1 382 DO ji = 1, fs_jpim1 375 383 zu2pv2_ij_p1 = ub(ji ,jj+1,jk) * ub(ji ,jj+1,jk) + vb(ji+1,jj ,jk) * vb(ji+1,jj ,jk) 376 384 zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) 377 zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) 378 zetmax = MAX( e1t(ji,jj) , e2t(ji,jj) ) 379 zefmax = MAX( e1f(ji,jj) , e2f(ji,jj) ) 380 ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zetmax * tmask(ji,jj,jk) ! 288= 12*12 * 2 381 ahmf(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zefmax * fmask(ji,jj,jk) 385 zemax = MAX( e1f(ji,jj) , e2f(ji,jj) ) 386 ahmf(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax * fmask(ji,jj,jk) ! 288= 12*12 * 2 382 387 END DO 383 388 END DO … … 387 392 DO jj = 2, jpjm1 388 393 DO ji = fs_2, fs_jpim1 394 zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) 395 zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) 396 zemax = MAX( e1t(ji,jj) , e2t(ji,jj) ) 397 ahmt(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax ) * zemax * tmask(ji,jj,jk) 398 END DO 399 END DO 400 DO jj = 1, jpjm1 401 DO ji = 1, fs_jpim1 389 402 zu2pv2_ij_p1 = ub(ji ,jj+1,jk) * ub(ji ,jj+1,jk) + vb(ji+1,jj ,jk) * vb(ji+1,jj ,jk) 390 403 zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) 391 zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) 392 zetmax = MAX( e1t(ji,jj) , e2t(ji,jj) ) 393 zefmax = MAX( e1f(ji,jj) , e2f(ji,jj) ) 394 ahmt(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zetmax ) * zetmax * tmask(ji,jj,jk) 395 ahmf(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zefmax ) * zefmax * fmask(ji,jj,jk) 404 zemax = MAX( e1f(ji,jj) , e2f(ji,jj) ) 405 ahmf(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax ) * zemax * fmask(ji,jj,jk) 396 406 END DO 397 407 END DO … … 406 416 IF( ln_dynldf_lap .OR. ln_dynldf_blp ) THEN ! laplacian operator : (C_smag/pi)^2 L^2 |D| 407 417 ! 408 zcmsmag = (rn_csmc/rpi)**2! (C_smag/pi)^2409 zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 4._wp * zcmsmag )! lower limit stability factor scaling410 zstabf_up = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rdt )! upper limit stability factor scaling418 zcmsmag = (rn_csmc/rpi)**2 ! (C_smag/pi)^2 419 zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 4._wp * zcmsmag ) ! lower limit stability factor scaling 420 zstabf_up = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rdt ) ! upper limit stability factor scaling 411 421 IF( ln_dynldf_blp ) zstabf_lo = ( 16._wp / 9._wp ) * zstabf_lo ! provide |U|L^3/12 lower limit instead 412 422 ! ! of |U|L^3/16 in blp case 413 423 DO jk = 1, jpkm1 414 424 ! 415 DO jj = 2, jpj 416 DO ji = 2, jpi 417 zdb = ( ( ub(ji,jj,jk) * r1_e2u(ji,jj) - ub(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) & 418 & * r1_e1t(ji,jj) * e2t(ji,jj) & 419 & - ( vb(ji,jj,jk) * r1_e1v(ji,jj) - vb(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) & 420 & * r1_e2t(ji,jj) * e1t(ji,jj) ) * tmask(ji,jj,jk) 421 dtensq(ji,jj) = zdb * zdb 425 DO jj = 2, jpjm1 426 DO ji = 2, jpim1 427 zdb = ( ub(ji,jj,jk) * r1_e2u(ji,jj) - ub(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) * r1_e1t(ji,jj) * e2t(ji,jj) & 428 & - ( vb(ji,jj,jk) * r1_e1v(ji,jj) - vb(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) * r1_e2t(ji,jj) * e1t(ji,jj) 429 dtensq(ji,jj,jk) = zdb * zdb * tmask(ji,jj,jk) 422 430 END DO 423 431 END DO … … 425 433 DO jj = 1, jpjm1 426 434 DO ji = 1, jpim1 427 zdb = ( ( ub(ji,jj+1,jk) * r1_e1u(ji,jj+1) - ub(ji,jj,jk) * r1_e1u(ji,jj) ) & 428 & * r1_e2f(ji,jj) * e1f(ji,jj) & 429 & + ( vb(ji+1,jj,jk) * r1_e2v(ji+1,jj) - vb(ji,jj,jk) * r1_e2v(ji,jj) ) & 430 & * r1_e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,jk) 431 dshesq(ji,jj) = zdb * zdb 435 zdb = ( ub(ji,jj+1,jk) * r1_e1u(ji,jj+1) - ub(ji,jj,jk) * r1_e1u(ji,jj) ) * r1_e2f(ji,jj) * e1f(ji,jj) & 436 & + ( vb(ji+1,jj,jk) * r1_e2v(ji+1,jj) - vb(ji,jj,jk) * r1_e2v(ji,jj) ) * r1_e1f(ji,jj) * e2f(ji,jj) 437 dshesq(ji,jj,jk) = zdb * zdb * fmask(ji,jj,jk) 432 438 END DO 433 439 END DO 434 440 ! 435 DO jj = 2, jpjm1 441 END DO 442 ! 443 CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1. ) ! lbc_lnk on dshesq not needed 444 ! 445 DO jk = 1, jpkm1 446 ! 447 DO jj = 2, jpjm1 ! T-point value 436 448 DO ji = fs_2, fs_jpim1 449 ! 450 zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) 451 zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) 452 ! 453 zdelta = zcmsmag * esqt(ji,jj) ! L^2 * (C_smag/pi)^2 454 ahmt(ji,jj,jk) = zdelta * SQRT( dtensq(ji ,jj,jk) + & 455 & r1_4 * ( dshesq(ji ,jj,jk) + dshesq(ji ,jj-1,jk) + & 456 & dshesq(ji-1,jj,jk) + dshesq(ji-1,jj-1,jk) ) ) 457 ahmt(ji,jj,jk) = MAX( ahmt(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2 458 ahmt(ji,jj,jk) = MIN( ahmt(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt) 459 ! 460 END DO 461 END DO 462 ! 463 DO jj = 1, jpjm1 ! F-point value 464 DO ji = 1, fs_jpim1 437 465 ! 438 466 zu2pv2_ij_p1 = ub(ji ,jj+1,jk) * ub(ji ,jj+1,jk) + vb(ji+1,jj ,jk) * vb(ji+1,jj ,jk) 439 467 zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) 440 zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) 441 ! T-point value 442 zdelta = zcmsmag * esqt(ji,jj) ! L^2 * (C_smag/pi)^2 443 ahmt(ji,jj,jk) = zdelta * sqrt( dtensq(ji,jj) + & 444 & r1_4 * ( dshesq(ji,jj) + dshesq(ji,jj-1) + & 445 & dshesq(ji-1,jj) + dshesq(ji-1,jj-1) ) ) 446 ahmt(ji,jj,jk) = MAX( ahmt(ji,jj,jk), & 447 & SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2 448 ahmt(ji,jj,jk) = MIN( ahmt(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt) 449 ! F-point value 468 ! 450 469 zdelta = zcmsmag * esqf(ji,jj) ! L^2 * (C_smag/pi)^2 451 ahmf(ji,jj,jk) = zdelta * sqrt( dshesq(ji,jj) + & 452 & r1_4 * ( dtensq(ji,jj) + dtensq(ji,jj+1) + & 453 & dtensq(ji+1,jj) + dtensq(ji+1,jj+1) ) ) 454 ahmf(ji,jj,jk) = MAX( ahmf(ji,jj,jk), & 455 & SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2 456 ahmf(ji,jj,jk) = MIN( ahmf(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt) 470 ahmf(ji,jj,jk) = zdelta * SQRT( dshesq(ji ,jj,jk) + & 471 & r1_4 * ( dtensq(ji ,jj,jk) + dtensq(ji ,jj+1,jk) + & 472 & dtensq(ji+1,jj,jk) + dtensq(ji+1,jj+1,jk) ) ) 473 ahmf(ji,jj,jk) = MAX( ahmf(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2 474 ahmf(ji,jj,jk) = MIN( ahmf(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt) 457 475 ! 458 476 END DO 459 477 END DO 478 ! 460 479 END DO 461 480 ! … … 470 489 DO ji = fs_2, fs_jpim1 471 490 ahmt(ji,jj,jk) = SQRT( r1_8 * esqt(ji,jj) * ahmt(ji,jj,jk) ) 491 END DO 492 END DO 493 DO jj = 1, jpjm1 494 DO ji = 1, fs_jpim1 472 495 ahmf(ji,jj,jk) = SQRT( r1_8 * esqf(ji,jj) * ahmf(ji,jj,jk) ) 473 496 END DO -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LDF/ldftra.F90
r10425 r12065 154 154 REWIND( numnam_ref ) ! Namelist namtra_ldf in reference namelist : Lateral physics on tracers 155 155 READ ( numnam_ref, namtra_ldf, IOSTAT = ios, ERR = 901) 156 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' , lwp)156 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' ) 157 157 REWIND( numnam_cfg ) ! Namelist namtra_ldf in configuration namelist : Lateral physics on tracers 158 158 READ ( numnam_cfg, namtra_ldf, IOSTAT = ios, ERR = 902 ) 159 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist' , lwp)159 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist' ) 160 160 IF(lwm) WRITE( numond, namtra_ldf ) 161 161 ! … … 512 512 REWIND( numnam_ref ) ! Namelist namtra_eiv in reference namelist : eddy induced velocity param. 513 513 READ ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901) 514 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' , lwp)514 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' ) 515 515 ! 516 516 REWIND( numnam_cfg ) ! Namelist namtra_eiv in configuration namelist : eddy induced velocity param. 517 517 READ ( numnam_cfg, namtra_eiv, IOSTAT = ios, ERR = 902 ) 518 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' , lwp)518 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' ) 519 519 IF(lwm) WRITE ( numond, namtra_eiv ) 520 520 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/OBS/diaobs.F90
r10068 r12065 203 203 REWIND( numnam_ref ) ! Namelist namobs in reference namelist 204 204 READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 205 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist' , lwp)205 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist' ) 206 206 REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist 207 207 READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 208 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist' , lwp)208 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist' ) 209 209 IF(lwm) WRITE ( numond, namobs ) 210 210 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/fldread.F90
r10425 r12065 48 48 TYPE, PUBLIC :: FLD_N !: Namelist field informations 49 49 CHARACTER(len = 256) :: clname ! generic name of the NetCDF flux file 50 REAL(wp) :: nfreqh! frequency of each flux file50 REAL(wp) :: freqh ! frequency of each flux file 51 51 CHARACTER(len = 34) :: clvar ! generic name of the variable in the NetCDF flux file 52 52 LOGICAL :: ln_tint ! time interpolation or not (T/F) … … 64 64 CHARACTER(len = 256) :: clrootname ! generic name of the NetCDF file 65 65 CHARACTER(len = 256) :: clname ! current name of the NetCDF file 66 REAL(wp) :: nfreqh! frequency of each flux file66 REAL(wp) :: freqh ! frequency of each flux file 67 67 CHARACTER(len = 34) :: clvar ! generic name of the variable in the NetCDF flux file 68 68 LOGICAL :: ln_tint ! time interpolation or not (T/F) … … 80 80 INTEGER :: nreclast ! last record to be read in the current file 81 81 CHARACTER(len = 256) :: lsmname ! current name of the NetCDF mask file acting as a key 82 INTEGER :: igrd ! grid type for bdy data 83 INTEGER :: ibdy ! bdy set id number 82 ! ! 83 ! ! Variables related to BDY 84 INTEGER :: igrd ! grid type for bdy data 85 INTEGER :: ibdy ! bdy set id number 86 INTEGER, POINTER, DIMENSION(:) :: imap ! Array of integer pointers to 1D arrays 87 LOGICAL :: ltotvel ! total velocity or not (T/F) 88 LOGICAL :: lzint ! T if it requires a vertical interpolation 84 89 END TYPE FLD 85 86 TYPE, PUBLIC :: MAP_POINTER !: Map from input data file to local domain87 INTEGER, POINTER, DIMENSION(:) :: ptr ! Array of integer pointers to 1D arrays88 LOGICAL :: ll_unstruc ! Unstructured (T) or structured (F) boundary data file89 END TYPE MAP_POINTER90 90 91 91 !$AGRIF_DO_NOT_TREAT … … 129 129 CONTAINS 130 130 131 SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy, fvl)131 SUBROUTINE fld_read( kt, kn_fsbc, sd, kit, kt_offset ) 132 132 !!--------------------------------------------------------------------- 133 133 !! *** ROUTINE fld_read *** … … 144 144 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 145 145 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 146 TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices147 146 INTEGER , INTENT(in ), OPTIONAL :: kit ! subcycle timestep for timesplitting option 148 147 INTEGER , INTENT(in ), OPTIONAL :: kt_offset ! provide fields at time other than "now" … … 150 149 ! ! kt_offset = +1 => fields at "after" time level 151 150 ! ! etc. 152 INTEGER , INTENT(in ), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data153 LOGICAL , INTENT(in ), OPTIONAL :: fvl ! number of vertical levels in the BDY data154 151 !! 155 152 INTEGER :: itmp ! local variable … … 166 163 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation 167 164 CHARACTER(LEN=1000) :: clfmt ! write format 168 TYPE(MAP_POINTER) :: imap ! global-to-local mapping indices169 165 !!--------------------------------------------------------------------- 170 166 ll_firstcall = kt == nit000 … … 175 171 ENDIF 176 172 IF( PRESENT(kt_offset) ) it_offset = kt_offset 177 178 imap%ptr => NULL()179 173 180 174 ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar … … 188 182 IF( ll_firstcall ) THEN ! initialization 189 183 DO jf = 1, imf 190 IF( PRESENT(map) ) imap = map(jf) 191 IF( PRESENT(jpk_bdy) ) THEN 192 CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy, fvl ) ! read each before field (put them in after as they will be swapped) 193 ELSE 194 CALL fld_init( kn_fsbc, sd(jf), imap ) ! read each before field (put them in after as they will be swapped) 195 ENDIF 184 IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE 185 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 196 186 END DO 197 187 IF( lwp ) CALL wgt_print() ! control print … … 202 192 ! 203 193 DO jf = 1, imf ! --- loop over field --- ! 204 194 195 IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE 196 205 197 IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN ! read/update the after data? 206 207 IF( PRESENT(map) ) imap = map(jf) ! temporary definition of map208 198 209 199 sd(jf)%nrec_b(:) = sd(jf)%nrec_a(:) ! swap before record informations … … 213 203 CALL fld_rec( kn_fsbc, sd(jf), kt_offset = it_offset, kit = kit ) ! update after record informations 214 204 215 ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd),205 ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), 216 206 ! it is possible that the before value is no more the good one... we have to re-read it 217 207 ! if before is not the last record of the file currently opened and after is the first record to be read … … 222 212 itmp = sd(jf)%nrec_a(1) ! temporary storage 223 213 sd(jf)%nrec_a(1) = sd(jf)%nreclast ! read the last record of the file currently opened 224 CALL fld_get( sd(jf) , imap )! read after data214 CALL fld_get( sd(jf) ) ! read after data 225 215 sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! re-swap before record field 226 216 sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1) ! update before record informations 227 sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)% nfreqh * 3600) ! assume freq to be in hours in this case217 sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. ) ! assume freq to be in hours in this case 228 218 sd(jf)%rotn(1) = sd(jf)%rotn(2) ! update before rotate informations 229 219 sd(jf)%nrec_a(1) = itmp ! move back to after record … … 234 224 IF( sd(jf)%ln_tint ) THEN 235 225 236 ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd),226 ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), 237 227 ! it is possible that the before value is no more the good one... we have to re-read it 238 228 ! if before record is not just just before the after record... … … 240 230 & .AND. sd(jf)%nrec_b(1) /= sd(jf)%nrec_a(1) - 1 ) THEN 241 231 sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - 1 ! move back to before record 242 CALL fld_get( sd(jf) , imap )! read after data232 CALL fld_get( sd(jf) ) ! read after data 243 233 sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! re-swap before record field 244 234 sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1) ! update before record informations 245 sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)% nfreqh * 3600) ! assume freq to be in hours in this case235 sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. ) ! assume freq to be in hours in this case 246 236 sd(jf)%rotn(1) = sd(jf)%rotn(2) ! update before rotate informations 247 237 sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) + 1 ! move back to after record … … 268 258 ! year/month/week/day, next year/month/week/day file must exist 269 259 isecend = nsec_year + nsec1jan000 + (nitend - kt) * NINT(rdt) ! second at the end of the run 270 llstop = isecend > sd(jf)%nrec_a(2) 260 llstop = isecend > sd(jf)%nrec_a(2) ! read more than 1 record of next year 271 261 ! we suppose that the date of next file is next day (should be ok even for weekly files...) 272 262 CALL fld_clopn( sd(jf), nyear + COUNT((/llnxtyr /)) , & … … 277 267 CALL ctl_warn('next year/month/week/day file: '//TRIM(sd(jf)%clname)// & 278 268 & ' not present -> back to current year/month/day') 279 CALL fld_clopn( sd(jf) ) ! back to the current year/month/day269 CALL fld_clopn( sd(jf) ) ! back to the current year/month/day 280 270 sd(jf)%nrec_a(1) = sd(jf)%nreclast ! force to read the last record in the current year file 281 271 ENDIF … … 285 275 286 276 ! read after data 287 IF( PRESENT(jpk_bdy) ) THEN 288 CALL fld_get( sd(jf), imap, jpk_bdy, fvl) 289 ELSE 290 CALL fld_get( sd(jf), imap ) 291 ENDIF 277 CALL fld_get( sd(jf) ) 278 292 279 ENDIF ! read new data? 293 280 END DO ! --- end loop over field --- ! … … 296 283 297 284 DO jf = 1, imf ! --- loop over field --- ! 285 ! 286 IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE 298 287 ! 299 288 IF( sd(jf)%ln_tint ) THEN ! temporal interpolation … … 327 316 328 317 329 SUBROUTINE fld_init( kn_fsbc, sdjf , map , jpk_bdy, fvl)318 SUBROUTINE fld_init( kn_fsbc, sdjf ) 330 319 !!--------------------------------------------------------------------- 331 320 !! *** ROUTINE fld_init *** … … 336 325 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 337 326 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 338 TYPE(MAP_POINTER),INTENT(in) :: map ! global-to-local mapping indices339 INTEGER , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data340 LOGICAL , INTENT(in), OPTIONAL :: fvl ! number of vertical levels in the BDY data341 327 !! 342 328 LOGICAL :: llprevyr ! are we reading previous year file? … … 351 337 CHARACTER(LEN=1000) :: clfmt ! write format 352 338 !!--------------------------------------------------------------------- 339 ! 353 340 llprevyr = .FALSE. 354 341 llprevmth = .FALSE. … … 365 352 ! 366 353 IF( sdjf%nrec_a(1) == 0 ) THEN ! we redefine record sdjf%nrec_a(1) with the last record of previous year file 367 IF ( sdjf%nfreqh== -12 ) THEN ! yearly mean354 IF ( NINT(sdjf%freqh) == -12 ) THEN ! yearly mean 368 355 IF( sdjf%cltype == 'yearly' ) THEN ! yearly file 369 356 sdjf%nrec_a(1) = 1 ! force to read the unique record … … 372 359 CALL ctl_stop( "fld_init: yearly mean file must be in a yearly type of file: "//TRIM(sdjf%clrootname) ) 373 360 ENDIF 374 ELSEIF( sdjf%nfreqh== -1 ) THEN ! monthly mean361 ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean 375 362 IF( sdjf%cltype == 'monthly' ) THEN ! monthly file 376 363 sdjf%nrec_a(1) = 1 ! force to read the unique record … … 381 368 llprevyr = .NOT. sdjf%ln_clim ! use previous year file? 382 369 ENDIF 383 ELSE ! higher frequency mean (in hours)370 ELSE ! higher frequency mean (in hours) 384 371 IF ( sdjf%cltype == 'monthly' ) THEN ! monthly file 385 sdjf%nrec_a(1) = NINT( 24 * nmonth_len(nmonth-1) / sdjf%nfreqh )! last record of previous month372 sdjf%nrec_a(1) = NINT( 24. * REAL(nmonth_len(nmonth-1),wp) / sdjf%freqh )! last record of previous month 386 373 llprevmth = .TRUE. ! use previous month file? 387 374 llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file? 388 375 ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ! weekly file 389 376 llprevweek = .TRUE. ! use previous week file? 390 sdjf%nrec_a(1) = NINT( 24 * 7 / sdjf%nfreqh )! last record of previous week377 sdjf%nrec_a(1) = NINT( 24. * 7. / sdjf%freqh ) ! last record of previous week 391 378 isec_week = NINT(rday) * 7 ! add a shift toward previous week 392 379 ELSEIF( sdjf%cltype == 'daily' ) THEN ! daily file 393 sdjf%nrec_a(1) = NINT( 24 / sdjf%nfreqh ) ! last record of previous day380 sdjf%nrec_a(1) = NINT( 24. / sdjf%freqh ) ! last record of previous day 394 381 llprevday = .TRUE. ! use previous day file? 395 382 llprevmth = llprevday .AND. nday == 1 ! use previous month file? 396 383 llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file? 397 384 ELSE ! yearly file 398 sdjf%nrec_a(1) = NINT( 24 * nyear_len(0) / sdjf%nfreqh )! last record of previous year385 sdjf%nrec_a(1) = NINT( 24. * REAL(nyear_len(0),wp) / sdjf%freqh ) ! last record of previous year 399 386 llprevyr = .NOT. sdjf%ln_clim ! use previous year file? 400 387 ENDIF … … 433 420 ! 434 421 ! read before data in after arrays(as we will swap it later) 435 IF( PRESENT(jpk_bdy) ) THEN 436 CALL fld_get( sdjf, map, jpk_bdy, fvl ) 437 ELSE 438 CALL fld_get( sdjf, map ) 439 ENDIF 422 CALL fld_get( sdjf ) 440 423 ! 441 424 clfmt = "(' fld_init : time-interpolation for ', a, ' read previous record = ', i6, ' at time = ', f7.2, ' days')" … … 456 439 !! if sdjf%ln_tint = .FALSE. 457 440 !! nrec_a(1): record number 458 !! nrec_b(2) and nrec_a(2): time of the beginning and end of the record (for print only)441 !! nrec_b(2) and nrec_a(2): time of the beginning and end of the record 459 442 !!---------------------------------------------------------------------- 460 443 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) … … 484 467 ELSE ; it_offset = 0 485 468 ENDIF 486 IF( PRESENT(kt_offset) ) it_offset = kt_offset469 IF( PRESENT(kt_offset) ) it_offset = kt_offset 487 470 IF( PRESENT(kit) ) THEN ; it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) ) 488 471 ELSE ; it_offset = it_offset * NINT( rdt ) 489 472 ENDIF 490 473 ! 491 ! ! =========== !492 IF ( sdjf%nfreqh== -12 ) THEN ! yearly mean493 ! ! =========== !494 ! 495 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record474 ! ! =========== ! 475 IF ( NINT(sdjf%freqh) == -12 ) THEN ! yearly mean 476 ! ! =========== ! 477 ! 478 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 496 479 ! 497 480 ! INT( ztmp ) … … 505 488 ! forcing record : 1 506 489 ! 507 ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 &508 &+ REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday )490 ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 & 491 & + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday ) 509 492 sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 510 493 ! swap at the middle of the year … … 514 497 & INT(ztmp) * INT(rday) * nyear_len(1) + INT(ztmp) * NINT( 0.5 * rday) * nyear_len(2) 515 498 ENDIF 516 ELSE ! no time interpolation499 ELSE ! no time interpolation 517 500 sdjf%nrec_a(1) = 1 518 501 sdjf%nrec_a(2) = NINT(rday) * nyear_len(1) + nsec1jan000 ! swap at the end of the year … … 520 503 ENDIF 521 504 ! 522 ! ! ============ !523 ELSEIF( sdjf%nfreqh== -1 ) THEN ! monthly mean !524 ! ! ============ !525 ! 526 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record505 ! ! ============ ! 506 ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean ! 507 ! ! ============ ! 508 ! 509 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 527 510 ! 528 511 ! INT( ztmp ) … … 536 519 ! forcing record : nmonth 537 520 ! 538 ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 &539 & + REAL(it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday )521 ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 & 522 & + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) 540 523 imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) 541 524 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) … … 551 534 ENDIF 552 535 ! 553 ! ! ================================ !554 ELSE ! higher frequency mean (in hours)555 ! ! ================================ !556 ! 557 ifreq_sec = NINT( sdjf% nfreqh * 3600) ! frequency mean (in seconds)536 ! ! ================================ ! 537 ELSE ! higher frequency mean (in hours) 538 ! ! ================================ ! 539 ! 540 ifreq_sec = NINT( sdjf%freqh * 3600. ) ! frequency mean (in seconds) 558 541 IF( sdjf%cltype(1:4) == 'week' ) isec_week = ksec_week( sdjf%cltype(6:8) ) ! since the first day of the current week 559 542 ! number of second since the beginning of the file … … 565 548 ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdt + REAL( it_offset, wp ) ! centrered in the middle of sbc time step 566 549 ztmp = ztmp + 0.01 * rdt ! avoid truncation error 567 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record550 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 568 551 ! 569 552 ! INT( ztmp/ifreq_sec + 0.5 ) … … 579 562 ! 580 563 ztmp= ztmp / REAL(ifreq_sec, wp) + 0.5 581 ELSE ! no time interpolation564 ELSE ! no time interpolation 582 565 ! 583 566 ! INT( ztmp/ifreq_sec ) … … 610 593 ENDIF 611 594 ! 595 IF( .NOT. sdjf%ln_tint ) sdjf%nrec_a(2) = sdjf%nrec_a(2) - 1 ! last second belongs to bext record : *----( 596 ! 612 597 END SUBROUTINE fld_rec 613 598 614 599 615 SUBROUTINE fld_get( sdjf , map, jpk_bdy, fvl)600 SUBROUTINE fld_get( sdjf ) 616 601 !!--------------------------------------------------------------------- 617 602 !! *** ROUTINE fld_get *** … … 620 605 !!---------------------------------------------------------------------- 621 606 TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables 622 TYPE(MAP_POINTER), INTENT(in ) :: map ! global-to-local mapping indices623 INTEGER , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the bdy data624 LOGICAL , INTENT(in), OPTIONAL :: fvl ! number of vertical levels in the bdy data625 607 ! 626 608 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) … … 634 616 ipk = SIZE( sdjf%fnow, 3 ) 635 617 ! 636 IF( ASSOCIATED(map%ptr) ) THEN 637 IF( PRESENT(jpk_bdy) ) THEN 638 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), & 639 sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 640 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), & 641 sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 642 ENDIF 643 ELSE 644 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 645 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map ) 646 ENDIF 647 ENDIF 618 IF( ASSOCIATED(sdjf%imap) ) THEN 619 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), & 620 & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) 621 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), & 622 & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) 623 ENDIF 648 624 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 649 625 CALL wgt_list( sdjf, iw ) … … 700 676 END SUBROUTINE fld_get 701 677 702 SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy, fvl ) 678 679 SUBROUTINE fld_map( knum, cdvar, pdta, krec, kmap, kgrd, kbdy, ldtotvel, ldzint ) 703 680 !!--------------------------------------------------------------------- 704 681 !! *** ROUTINE fld_map *** … … 707 684 !! using a general mapping (for open boundaries) 708 685 !!---------------------------------------------------------------------- 709 710 USE bdy_oce, ONLY: ln_bdy, idx_bdy, dta_global, dta_global_z, dta_global_dz, dta_global2, dta_global2_z, dta_global2_dz ! workspace to read in global data arrays 711 712 INTEGER , INTENT(in ) :: num ! stream number 713 CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name 714 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 715 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 716 TYPE(MAP_POINTER) , INTENT(in ) :: map ! global-to-local mapping indices 717 INTEGER , INTENT(in), OPTIONAL :: igrd, ibdy, jpk_bdy ! grid type, set number and number of vertical levels in the bdy data 718 LOGICAL , INTENT(in), OPTIONAL :: fvl ! grid type, set number and number of vertical levels in the bdy data 719 INTEGER :: jpkm1_bdy! number of vertical levels in the bdy data minus 1 720 !! 721 INTEGER :: ipi ! length of boundary data on local process 722 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 723 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 724 INTEGER :: ilendta ! length of data in file 725 INTEGER :: idvar ! variable ID 726 INTEGER :: ib, ik, ji, jj ! loop counters 727 INTEGER :: ierr 728 REAL(wp) :: fv ! fillvalue 729 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read ! work space for global data 730 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read_z ! work space for global data 731 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read_dz ! work space for global data 732 !!--------------------------------------------------------------------- 733 ! 734 ipi = SIZE( dta, 1 ) 735 ipj = 1 736 ipk = SIZE( dta, 3 ) 737 ! 738 idvar = iom_varid( num, clvar ) 739 ilendta = iom_file(num)%dimsz(1,idvar) 740 741 IF ( ln_bdy ) THEN 742 ipj = iom_file(num)%dimsz(2,idvar) 743 IF( map%ll_unstruc) THEN ! unstructured open boundary data file 744 dta_read => dta_global 745 IF( PRESENT(jpk_bdy) ) THEN 746 IF( jpk_bdy>0 ) THEN 747 dta_read_z => dta_global_z 748 dta_read_dz => dta_global_dz 749 jpkm1_bdy = jpk_bdy-1 750 ENDIF 751 ENDIF 752 ELSE ! structured open boundary file 753 dta_read => dta_global2 754 IF( PRESENT(jpk_bdy) ) THEN 755 IF( jpk_bdy>0 ) THEN 756 dta_read_z => dta_global2_z 757 dta_read_dz => dta_global2_dz 758 jpkm1_bdy = jpk_bdy-1 759 ENDIF 760 ENDIF 761 ENDIF 762 ENDIF 763 764 IF(lwp) WRITE(numout,*) 'Dim size for ', TRIM(clvar),' is ', ilendta 765 IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk 766 ! 767 SELECT CASE( ipk ) 768 CASE(1) ; 769 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1 ), nrec ) 770 IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 771 DO ib = 1, ipi 772 DO ik = 1, ipk 773 dta(ib,1,ik) = dta_read(map%ptr(ib),1,ik) 774 END DO 775 END DO 776 ELSE ! we assume that this is a structured open boundary file 777 DO ib = 1, ipi 778 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 779 ji=map%ptr(ib)-(jj-1)*ilendta 780 DO ik = 1, ipk 781 dta(ib,1,ik) = dta_read(ji,jj,ik) 782 END DO 783 END DO 784 ENDIF 686 INTEGER , INTENT(in ) :: knum ! stream number 687 CHARACTER(LEN=*) , INTENT(in ) :: cdvar ! variable name 688 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! bdy output field on model grid 689 INTEGER , INTENT(in ) :: krec ! record number to read (ie time slice) 690 INTEGER , DIMENSION(:) , INTENT(in ) :: kmap ! global-to-local bdy mapping indices 691 ! optional variables used for vertical interpolation: 692 INTEGER, OPTIONAL , INTENT(in ) :: kgrd ! grid type (t, u, v) 693 INTEGER, OPTIONAL , INTENT(in ) :: kbdy ! bdy number 694 LOGICAL, OPTIONAL , INTENT(in ) :: ldtotvel ! true if total ( = barotrop + barocline) velocity 695 LOGICAL, OPTIONAL , INTENT(in ) :: ldzint ! true if 3D variable requires a vertical interpolation 696 !! 697 INTEGER :: ipi ! length of boundary data on local process 698 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 699 INTEGER :: ipk ! number of vertical levels of pdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 700 INTEGER :: ipkb ! number of vertical levels in boundary data file 701 INTEGER :: idvar ! variable ID 702 INTEGER :: indims ! number of dimensions of the variable 703 INTEGER, DIMENSION(4) :: idimsz ! size of variable dimensions 704 REAL(wp) :: zfv ! fillvalue 705 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zz_read ! work space for global boundary data 706 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read ! work space local data requiring vertical interpolation 707 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_z ! work space local data requiring vertical interpolation 708 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_dz ! work space local data requiring vertical interpolation 709 CHARACTER(LEN=1),DIMENSION(3) :: clgrid 710 LOGICAL :: lluld ! is the variable using the unlimited dimension 711 LOGICAL :: llzint ! local value of ldzint 712 !!--------------------------------------------------------------------- 713 ! 714 clgrid = (/'t','u','v'/) 715 ! 716 ipi = SIZE( pdta, 1 ) 717 ipj = SIZE( pdta, 2 ) ! must be equal to 1 718 ipk = SIZE( pdta, 3 ) 719 ! 720 llzint = .FALSE. 721 IF( PRESENT(ldzint) ) llzint = ldzint 722 ! 723 idvar = iom_varid( knum, cdvar, kndims = indims, kdimsz = idimsz, lduld = lluld ) 724 IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN ; ipkb = idimsz(3) ! xy(zl)t or xy(zl) 725 ELSE ; ipkb = 1 ! xy or xyt 726 ENDIF 727 ! 728 ALLOCATE( zz_read( idimsz(1), idimsz(2), ipkb ) ) ! ++++++++ !!! this can be very big... 729 ! 730 IF( ipk == 1 ) THEN 731 732 IF( ipkb /= 1 ) CALL ctl_stop( 'fld_map : we must have ipkb = 1 to read surface data' ) 733 CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,1), krec ) ! call iom_get with a 2D file 734 CALL fld_map_core( zz_read, kmap, pdta ) 785 735 786 736 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 787 737 ! Do we include something here to adjust barotropic velocities ! 788 738 ! in case of a depth difference between bdy files and ! 789 ! bathymetry in the case ln_ full_vel = .false. and jpk_bdy>0?!739 ! bathymetry in the case ln_totvel = .false. and ipkb>0? ! 790 740 ! [as the enveloping and parital cells could change H] ! 791 741 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 792 742 793 CASE DEFAULT ; 794 795 IF( PRESENT(jpk_bdy) .AND. jpk_bdy>0 ) THEN ! boundary data not on model grid: vertical interpolation 796 CALL iom_getatt(num, '_FillValue', fv, cdvar=clvar ) 797 dta_read(:,:,:) = -ABS(fv) 798 dta_read_z(:,:,:) = 0._wp 799 dta_read_dz(:,:,:) = 0._wp 800 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:jpk_bdy), nrec ) 801 SELECT CASE( igrd ) 802 CASE(1) 803 CALL iom_get ( num, jpdom_unknown, 'gdept', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 804 CALL iom_get ( num, jpdom_unknown, 'e3t', dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 805 CASE(2) 806 CALL iom_get ( num, jpdom_unknown, 'gdepu', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 807 CALL iom_get ( num, jpdom_unknown, 'e3u', dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 808 CASE(3) 809 CALL iom_get ( num, jpdom_unknown, 'gdepv', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 810 CALL iom_get ( num, jpdom_unknown, 'e3v', dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 811 END SELECT 812 813 IF ( ln_bdy ) & 814 CALL fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta) 815 816 ELSE ! boundary data assumed to be on model grid 817 818 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec ) 819 IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 820 DO ib = 1, ipi 821 DO ik = 1, ipk 822 dta(ib,1,ik) = dta_read(map%ptr(ib),1,ik) 823 END DO 743 ELSE 744 ! 745 CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,:), krec ) ! call iom_get with a 3D file 746 ! 747 IF( ipkb /= ipk .OR. llzint ) THEN ! boundary data not on model vertical grid : vertical interpolation 748 ! 749 IF( ipk == jpk .AND. iom_varid(knum,'gdep'//clgrid(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//clgrid(kgrd)) /= -1 ) THEN 750 751 ALLOCATE( zdta_read(ipi,ipj,ipkb), zdta_read_z(ipi,ipj,ipkb), zdta_read_dz(ipi,ipj,ipkb) ) 752 753 CALL fld_map_core( zz_read, kmap, zdta_read ) 754 CALL iom_get ( knum, jpdom_unknown, 'gdep'//clgrid(kgrd), zz_read ) ! read only once? Potential temporal evolution? 755 CALL fld_map_core( zz_read, kmap, zdta_read_z ) 756 CALL iom_get ( knum, jpdom_unknown, 'e3'//clgrid(kgrd), zz_read ) ! read only once? Potential temporal evolution? 757 CALL fld_map_core( zz_read, kmap, zdta_read_dz ) 758 759 CALL iom_getatt(knum, '_FillValue', zfv, cdvar=cdvar ) 760 CALL fld_bdy_interp(zdta_read, zdta_read_z, zdta_read_dz, pdta, kgrd, kbdy, zfv, ldtotvel) 761 DEALLOCATE( zdta_read, zdta_read_z, zdta_read_dz ) 762 763 ELSE 764 IF( ipk /= jpk ) CALL ctl_stop( 'fld_map : this should be an impossible case...' ) 765 WRITE(ctmp1,*) 'fld_map : vertical interpolation for bdy variable '//TRIM(cdvar)//' requires ' 766 IF( iom_varid(knum, 'gdep'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//clgrid(kgrd)//' variable' ) 767 IF( iom_varid(knum, 'e3'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//clgrid(kgrd)//' variable' ) 768 769 ENDIF 770 ! 771 ELSE ! bdy data assumed to be the same levels as bdy variables 772 ! 773 CALL fld_map_core( zz_read, kmap, pdta ) 774 ! 775 ENDIF ! ipkb /= ipk 776 ENDIF ! ipk == 1 777 778 DEALLOCATE( zz_read ) 779 780 END SUBROUTINE fld_map 781 782 783 SUBROUTINE fld_map_core( pdta_read, kmap, pdta_bdy ) 784 !!--------------------------------------------------------------------- 785 !! *** ROUTINE fld_map_core *** 786 !! 787 !! ** Purpose : inner core of fld_map 788 !!---------------------------------------------------------------------- 789 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! global boundary data 790 INTEGER, DIMENSION(: ), INTENT(in ) :: kmap ! global-to-local bdy mapping indices 791 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta_bdy ! bdy output field on model grid 792 !! 793 INTEGER, DIMENSION(3) :: idim_read, idim_bdy ! arrays dimensions 794 INTEGER :: ji, jj, jk, jb ! loop counters 795 INTEGER :: im1 796 !!--------------------------------------------------------------------- 797 ! 798 idim_read = SHAPE( pdta_read ) 799 idim_bdy = SHAPE( pdta_bdy ) 800 ! 801 ! in all cases: idim_bdy(2) == 1 .AND. idim_read(1) * idim_read(2) == idim_bdy(1) 802 ! structured BDY with rimwidth > 1 : idim_read(2) == rimwidth /= 1 803 ! structured BDY with rimwidth == 1 or unstructured BDY: idim_read(2) == 1 804 ! 805 IF( idim_read(2) > 1 ) THEN ! structured BDY with rimwidth > 1 806 DO jk = 1, idim_bdy(3) 807 DO jb = 1, idim_bdy(1) 808 im1 = kmap(jb) - 1 809 jj = im1 / idim_read(1) + 1 810 ji = MOD( im1, idim_read(1) ) + 1 811 pdta_bdy(jb,1,jk) = pdta_read(ji,jj,jk) 824 812 END DO 825 ELSE ! we assume that this is a structured open boundary file 826 DO ib = 1, ipi 827 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 828 ji=map%ptr(ib)-(jj-1)*ilendta 829 DO ik = 1, ipk 830 dta(ib,1,ik) = dta_read(ji,jj,ik) 831 END DO 813 END DO 814 ELSE 815 DO jk = 1, idim_bdy(3) 816 DO jb = 1, idim_bdy(1) ! horizontal remap of bdy data on the local bdy 817 pdta_bdy(jb,1,jk) = pdta_read(kmap(jb),1,jk) 832 818 END DO 833 ENDIF 834 ENDIF ! PRESENT(jpk_bdy) 835 END SELECT 836 837 END SUBROUTINE fld_map 819 END DO 820 ENDIF 821 822 END SUBROUTINE fld_map_core 838 823 839 SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta)840 824 825 SUBROUTINE fld_bdy_interp(pdta_read, pdta_read_z, pdta_read_dz, pdta, kgrd, kbdy, pfv, ldtotvel) 841 826 !!--------------------------------------------------------------------- 842 827 !! *** ROUTINE fld_bdy_interp *** … … 847 832 USE bdy_oce, ONLY: idx_bdy ! indexing for map <-> ij transformation 848 833 849 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read ! work space for global data 850 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read_z ! work space for global data 851 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read_dz ! work space for global data 852 REAL(wp) , INTENT(in) :: fv ! fillvalue and alternative -ABS(fv) 853 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 854 TYPE(MAP_POINTER) , INTENT(in ) :: map ! global-to-local mapping indices 855 LOGICAL , INTENT(in), OPTIONAL :: fvl ! grid type, set number and number of vertical levels in the bdy data 856 INTEGER , INTENT(in) :: igrd, ibdy, jpk_bdy ! number of levels in bdy data 857 INTEGER , INTENT(in) :: ilendta ! length of data in file 858 !! 859 INTEGER :: ipi ! length of boundary data on local process 860 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 861 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 862 INTEGER :: jpkm1_bdy ! number of levels in bdy data minus 1 863 INTEGER :: ib, ik, ikk ! loop counters 864 INTEGER :: ji, jj, zij, zjj ! temporary indices 865 REAL(wp) :: zl, zi, zh ! tmp variable for current depth and interpolation factor 866 REAL(wp) :: fv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(fv) 867 CHARACTER (LEN=10) :: ibstr 834 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! data read in bdy file 835 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdta_read_z ! depth of the data read in bdy file 836 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdta_read_dz ! thickness of the levels in bdy file 837 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! output field on model grid (2 dimensional) 838 REAL(wp) , INTENT(in ) :: pfv ! fillvalue of the data read in bdy file 839 LOGICAL , INTENT(in ) :: ldtotvel ! true if toal ( = barotrop + barocline) velocity 840 INTEGER , INTENT(in ) :: kgrd ! grid type (t, u, v) 841 INTEGER , INTENT(in ) :: kbdy ! bdy number 842 !! 843 INTEGER :: ipi ! length of boundary data on local process 844 INTEGER :: ipkb ! number of vertical levels in boundary data file 845 INTEGER :: jb, ji, jj, jk, jkb ! loop counters 846 REAL(wp) :: zcoef 847 REAL(wp) :: zl, zi, zh ! tmp variable for current depth and interpolation factor 848 REAL(wp) :: zfv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(pfv) 849 REAL(wp), DIMENSION(jpk) :: zdepth, zdhalf ! level and half-level depth 868 850 !!--------------------------------------------------------------------- 869 851 870 871 ipi = SIZE( dta, 1 ) 872 ipj = SIZE( dta_read, 2 ) 873 ipk = SIZE( dta, 3 ) 874 jpkm1_bdy = jpk_bdy-1 852 ipi = SIZE( pdta, 1 ) 853 ipkb = SIZE( pdta_read, 3 ) 875 854 876 fv_alt = -ABS(fv) ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 877 DO ib = 1, ipi 878 zij = idx_bdy(ibdy)%nbi(ib,igrd) 879 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 880 IF(narea==2) WRITE(*,*) 'MAPI', ib, igrd, map%ptr(ib), narea-1, zij, zjj 881 ENDDO 882 ! 883 IF ( map%ll_unstruc ) THEN ! unstructured open boundary data file 884 885 DO ib = 1, ipi 886 DO ik = 1, jpk_bdy 887 IF( ( dta_read(map%ptr(ib),1,ik) == fv ) ) THEN 888 dta_read_z(map%ptr(ib),1,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 889 dta_read_dz(map%ptr(ib),1,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 855 zfv_alt = -ABS(pfv) ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 856 ! 857 WHERE( pdta_read == pfv ) 858 pdta_read_z = zfv_alt ! safety: put fillvalue into external depth field so consistent with data 859 pdta_read_dz = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 860 ENDWHERE 861 862 DO jb = 1, ipi 863 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 864 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 865 zh = SUM(pdta_read_dz(jb,1,:) ) 866 ! 867 ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 868 SELECT CASE( kgrd ) 869 CASE(1) 870 IF( ABS( (zh - ht_n(ji,jj)) / ht_n(ji,jj)) * tmask(ji,jj,1) > 0.01_wp ) THEN 871 WRITE(ctmp1,"(I10.10)") jb 872 CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 873 ! IF(lwp) WRITE(numout,*) 'DEPTHT', zh, sum(e3t_n(ji,jj,:), mask=tmask(ji,jj,:)==1), ht_n(ji,jj), jb, jb, ji, jj 874 ENDIF 875 CASE(2) 876 IF( ABS( (zh - hu_n(ji,jj)) * r1_hu_n(ji,jj)) * umask(ji,jj,1) > 0.01_wp ) THEN 877 WRITE(ctmp1,"(I10.10)") jb 878 CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 879 ! IF(lwp) WRITE(numout,*) 'DEPTHU', zh, SUM(e3u_n(ji,jj,:), mask=umask(ji,jj,:)==1), SUM(umask(ji,jj,:)), & 880 ! & hu_n(ji,jj), jb, jb, ji, jj, narea-1, pdta_read(jb,1,:) 881 ENDIF 882 CASE(3) 883 IF( ABS( (zh - hv_n(ji,jj)) * r1_hv_n(ji,jj)) * vmask(ji,jj,1) > 0.01_wp ) THEN 884 WRITE(ctmp1,"(I10.10)") jb 885 CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 886 ENDIF 887 END SELECT 888 ! 889 SELECT CASE( kgrd ) 890 CASE(1) 891 ! depth of T points: 892 zdepth(:) = gdept_n(ji,jj,:) 893 CASE(2) 894 ! depth of U points: we must not use gdept_n as we don't want to do a communication 895 ! --> copy what is done for gdept_n in domvvl... 896 zdhalf(1) = 0.0_wp 897 zdepth(1) = 0.5_wp * e3uw_n(ji,jj,1) 898 DO jk = 2, jpk ! vertical sum 899 ! zcoef = umask - wumask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 900 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 901 ! ! 0.5 where jk = mikt 902 !!gm ??????? BUG ? gdept_n as well as gde3w_n does not include the thickness of ISF ?? 903 zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) 904 zdhalf(jk) = zdhalf(jk-1) + e3u_n(ji,jj,jk-1) 905 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3uw_n(ji,jj,jk)) & 906 & + (1-zcoef) * ( zdepth(jk-1) + e3uw_n(ji,jj,jk)) 907 END DO 908 CASE(3) 909 ! depth of V points: we must not use gdept_n as we don't want to do a communication 910 ! --> copy what is done for gdept_n in domvvl... 911 zdhalf(1) = 0.0_wp 912 zdepth(1) = 0.5_wp * e3vw_n(ji,jj,1) 913 DO jk = 2, jpk ! vertical sum 914 ! zcoef = vmask - wvmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 915 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 916 ! ! 0.5 where jk = mikt 917 !!gm ??????? BUG ? gdept_n as well as gde3w_n does not include the thickness of ISF ?? 918 zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) 919 zdhalf(jk) = zdhalf(jk-1) + e3v_n(ji,jj,jk-1) 920 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3vw_n(ji,jj,jk)) & 921 & + (1-zcoef) * ( zdepth(jk-1) + e3vw_n(ji,jj,jk)) 922 END DO 923 END SELECT 924 ! 925 DO jk = 1, jpk 926 IF( zdepth(jk) < pdta_read_z(jb,1, 1) ) THEN ! above the first level of external data 927 pdta(jb,1,jk) = pdta_read(jb,1,1) 928 ELSEIF( zdepth(jk) > pdta_read_z(jb,1,ipkb) ) THEN ! below the last level of external data 929 pdta(jb,1,jk) = pdta_read(jb,1,MAXLOC(pdta_read_z(jb,1,:),1)) 930 ELSE ! inbetween: vertical interpolation between jkb & jkb+1 931 DO jkb = 1, ipkb-1 ! when gdept_n(jkb) < zdepth(jk) < gdept_n(jkb+1) 932 IF( ( ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) * ( zdepth(jk) - pdta_read_z(jb,1,jkb+1) ) <= 0._wp ) & 933 & .AND. ( pdta_read_z(jb,1,jkb+1) /= zfv_alt) ) THEN ! linear interpolation between 2 levels 934 zi = ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) / ( pdta_read_z(jb,1,jkb+1) - pdta_read_z(jb,1,jkb) ) 935 pdta(jb,1,jk) = pdta_read(jb,1,jkb) + ( pdta_read (jb,1,jkb+1) - pdta_read (jb,1,jkb) ) * zi 936 ENDIF 937 END DO 938 ENDIF 939 END DO ! jpk 940 ! 941 END DO ! ipi 942 943 IF(kgrd == 2) THEN ! do we need to adjust the transport term? 944 DO jb = 1, ipi 945 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 946 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 947 zh = SUM(pdta_read_dz(jb,1,:) ) 948 ztrans = 0._wp 949 ztrans_new = 0._wp 950 DO jkb = 1, ipkb ! calculate transport on input grid 951 ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb) 952 ENDDO 953 DO jk = 1, jpk ! calculate transport on model grid 954 ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3u_n(ji,jj,jk ) * umask(ji,jj,jk) 955 ENDDO 956 DO jk = 1, jpk ! make transport correction 957 IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 958 pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hu_n(ji,jj) ) * umask(ji,jj,jk) 959 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 960 pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hu_n(ji,jj) * umask(ji,jj,jk) 890 961 ENDIF 891 962 ENDDO 892 ENDDO 893 894 DO ib = 1, ipi 895 zij = idx_bdy(ibdy)%nbi(ib,igrd) 896 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 897 zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 898 ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 899 SELECT CASE( igrd ) 900 CASE(1) 901 IF( ABS( (zh - ht_n(zij,zjj)) / ht_n(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN 902 WRITE(ibstr,"(I10.10)") map%ptr(ib) 903 CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 904 ! IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t_n(zij,zjj,:), mask=tmask(zij,zjj,:)==1), ht_n(zij,zjj), map%ptr(ib), ib, zij, zjj 905 ENDIF 906 CASE(2) 907 IF( ABS( (zh - hu_n(zij,zjj)) * r1_hu_n(zij,zjj)) * umask(zij,zjj,1) > 0.01_wp ) THEN 908 WRITE(ibstr,"(I10.10)") map%ptr(ib) 909 CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 910 IF(lwp) WRITE(*,*) 'DEPTHU', zh, sum(e3u_n(zij,zjj,:), mask=umask(zij,zjj,:)==1), sum(umask(zij,zjj,:)), & 911 & hu_n(zij,zjj), map%ptr(ib), ib, zij, zjj, narea-1 , & 912 & dta_read(map%ptr(ib),1,:) 913 ENDIF 914 CASE(3) 915 IF( ABS( (zh - hv_n(zij,zjj)) * r1_hv_n(zij,zjj)) * vmask(zij,zjj,1) > 0.01_wp ) THEN 916 WRITE(ibstr,"(I10.10)") map%ptr(ib) 917 CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 918 ENDIF 919 END SELECT 920 DO ik = 1, ipk 921 SELECT CASE( igrd ) 922 CASE(1) 923 zl = gdept_n(zij,zjj,ik) ! if using in step could use fsdept instead of gdept_n? 924 CASE(2) 925 IF(ln_sco) THEN 926 zl = ( gdept_n(zij,zjj,ik) + gdept_n(zij+1,zjj,ik) ) * 0.5_wp ! if using in step could use fsdept instead of gdept_n? 927 ELSE 928 zl = MIN( gdept_n(zij,zjj,ik), gdept_n(zij+1,zjj,ik) ) 929 ENDIF 930 CASE(3) 931 IF(ln_sco) THEN 932 zl = ( gdept_n(zij,zjj,ik) + gdept_n(zij,zjj+1,ik) ) * 0.5_wp ! if using in step could use fsdept instead of gdept_n? 933 ELSE 934 zl = MIN( gdept_n(zij,zjj,ik), gdept_n(zij,zjj+1,ik) ) 935 ENDIF 936 END SELECT 937 IF( zl < dta_read_z(map%ptr(ib),1,1) ) THEN ! above the first level of external data 938 dta(ib,1,ik) = dta_read(map%ptr(ib),1,1) 939 ELSEIF( zl > MAXVAL(dta_read_z(map%ptr(ib),1,:),1) ) THEN ! below the last level of external data 940 dta(ib,1,ik) = dta_read(map%ptr(ib),1,MAXLOC(dta_read_z(map%ptr(ib),1,:),1)) 941 ELSE ! inbetween : vertical interpolation between ikk & ikk+1 942 DO ikk = 1, jpkm1_bdy ! when gdept_n(ikk) < zl < gdept_n(ikk+1) 943 IF( ( (zl-dta_read_z(map%ptr(ib),1,ikk)) * (zl-dta_read_z(map%ptr(ib),1,ikk+1)) <= 0._wp) & 944 & .AND. (dta_read_z(map%ptr(ib),1,ikk+1) /= fv_alt)) THEN 945 zi = ( zl - dta_read_z(map%ptr(ib),1,ikk) ) / & 946 & ( dta_read_z(map%ptr(ib),1,ikk+1) - dta_read_z(map%ptr(ib),1,ikk) ) 947 dta(ib,1,ik) = dta_read(map%ptr(ib),1,ikk) + & 948 & ( dta_read(map%ptr(ib),1,ikk+1) - dta_read(map%ptr(ib),1,ikk) ) * zi 949 ENDIF 950 END DO 951 ENDIF 952 END DO 953 END DO 954 955 IF(igrd == 2) THEN ! do we need to adjust the transport term? 956 DO ib = 1, ipi 957 zij = idx_bdy(ibdy)%nbi(ib,igrd) 958 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 959 zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 960 ztrans = 0._wp 961 ztrans_new = 0._wp 962 DO ik = 1, jpk_bdy ! calculate transport on input grid 963 ztrans = ztrans + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 964 ENDDO 965 DO ik = 1, ipk ! calculate transport on model grid 966 ztrans_new = ztrans_new + dta(ib,1,ik) * e3u_n(zij,zjj,ik) * umask(zij,zjj,ik) 967 ENDDO 968 DO ik = 1, ipk ! make transport correction 969 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 970 dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 971 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 972 IF( ABS(ztrans * r1_hu_n(zij,zjj)) > 0.01_wp ) & 973 & CALL ctl_warn('fld_bdy_interp: barotropic component of > 0.01 ms-1 found in baroclinic velocities at') 974 dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hu_n(zij,zjj) * umask(zij,zjj,ik) 975 ENDIF 976 ENDDO 963 ENDDO 964 ENDIF 965 966 IF(kgrd == 3) THEN ! do we need to adjust the transport term? 967 DO jb = 1, ipi 968 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 969 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 970 zh = SUM(pdta_read_dz(jb,1,:) ) 971 ztrans = 0._wp 972 ztrans_new = 0._wp 973 DO jkb = 1, ipkb ! calculate transport on input grid 974 ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb) 977 975 ENDDO 978 ENDIF 979 980 IF(igrd == 3) THEN ! do we need to adjust the transport term? 981 DO ib = 1, ipi 982 zij = idx_bdy(ibdy)%nbi(ib,igrd) 983 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 984 zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 985 ztrans = 0._wp 986 ztrans_new = 0._wp 987 DO ik = 1, jpk_bdy ! calculate transport on input grid 988 ztrans = ztrans + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 989 ENDDO 990 DO ik = 1, ipk ! calculate transport on model grid 991 ztrans_new = ztrans_new + dta(ib,1,ik) * e3v_n(zij,zjj,ik) * vmask(zij,zjj,ik) 992 ENDDO 993 DO ik = 1, ipk ! make transport correction 994 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 995 dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 996 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 997 dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hv_n(zij,zjj) * vmask(zij,zjj,ik) 998 ENDIF 999 ENDDO 976 DO jk = 1, jpk ! calculate transport on model grid 977 ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3v_n(ji,jj,jk ) * vmask(ji,jj,jk) 1000 978 ENDDO 1001 ENDIF 1002 1003 ELSE ! structured open boundary file 1004 1005 DO ib = 1, ipi 1006 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 1007 ji=map%ptr(ib)-(jj-1)*ilendta 1008 DO ik = 1, jpk_bdy 1009 IF( ( dta_read(ji,jj,ik) == fv ) ) THEN 1010 dta_read_z(ji,jj,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 1011 dta_read_dz(ji,jj,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 979 DO jk = 1, jpk ! make transport correction 980 IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 981 pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hv_n(ji,jj) ) * vmask(ji,jj,jk) 982 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 983 pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hv_n(ji,jj) * vmask(ji,jj,jk) 1012 984 ENDIF 1013 985 ENDDO 1014 ENDDO 1015 1016 1017 DO ib = 1, ipi 1018 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 1019 ji=map%ptr(ib)-(jj-1)*ilendta 1020 zij = idx_bdy(ibdy)%nbi(ib,igrd) 1021 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 1022 zh = SUM(dta_read_dz(ji,jj,:) ) 1023 ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 1024 SELECT CASE( igrd ) 1025 CASE(1) 1026 IF( ABS( (zh - ht_n(zij,zjj)) / ht_n(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN 1027 WRITE(ibstr,"(I10.10)") map%ptr(ib) 1028 CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 1029 ! IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t_n(zij,zjj,:), mask=tmask(zij,zjj,:)==1), ht_n(zij,zjj), map%ptr(ib), ib, zij, zjj 1030 ENDIF 1031 CASE(2) 1032 IF( ABS( (zh - hu_n(zij,zjj)) * r1_hu_n(zij,zjj)) * umask(zij,zjj,1) > 0.01_wp ) THEN 1033 WRITE(ibstr,"(I10.10)") map%ptr(ib) 1034 CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 1035 ENDIF 1036 CASE(3) 1037 IF( ABS( (zh - hv_n(zij,zjj)) * r1_hv_n(zij,zjj)) * vmask(zij,zjj,1) > 0.01_wp ) THEN 1038 WRITE(ibstr,"(I10.10)") map%ptr(ib) 1039 CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 1040 ENDIF 1041 END SELECT 1042 DO ik = 1, ipk 1043 SELECT CASE( igrd ) ! coded for sco - need zco and zps option using min 1044 CASE(1) 1045 zl = gdept_n(zij,zjj,ik) ! if using in step could use fsdept instead of gdept_n? 1046 CASE(2) 1047 IF(ln_sco) THEN 1048 zl = ( gdept_n(zij,zjj,ik) + gdept_n(zij+1,zjj,ik) ) * 0.5_wp ! if using in step could use fsdept instead of gdept_n? 1049 ELSE 1050 zl = MIN( gdept_n(zij,zjj,ik), gdept_n(zij+1,zjj,ik) ) 1051 ENDIF 1052 CASE(3) 1053 IF(ln_sco) THEN 1054 zl = ( gdept_n(zij,zjj,ik) + gdept_n(zij,zjj+1,ik) ) * 0.5_wp ! if using in step could use fsdept instead of gdept_n? 1055 ELSE 1056 zl = MIN( gdept_n(zij,zjj,ik), gdept_n(zij,zjj+1,ik) ) 1057 ENDIF 1058 END SELECT 1059 IF( zl < dta_read_z(ji,jj,1) ) THEN ! above the first level of external data 1060 dta(ib,1,ik) = dta_read(ji,jj,1) 1061 ELSEIF( zl > MAXVAL(dta_read_z(ji,jj,:),1) ) THEN ! below the last level of external data 1062 dta(ib,1,ik) = dta_read(ji,jj,MAXLOC(dta_read_z(ji,jj,:),1)) 1063 ELSE ! inbetween : vertical interpolation between ikk & ikk+1 1064 DO ikk = 1, jpkm1_bdy ! when gdept_n(ikk) < zl < gdept_n(ikk+1) 1065 IF( ( (zl-dta_read_z(ji,jj,ikk)) * (zl-dta_read_z(ji,jj,ikk+1)) <= 0._wp) & 1066 & .AND. (dta_read_z(ji,jj,ikk+1) /= fv_alt)) THEN 1067 zi = ( zl - dta_read_z(ji,jj,ikk) ) / & 1068 & ( dta_read_z(ji,jj,ikk+1) - dta_read_z(ji,jj,ikk) ) 1069 dta(ib,1,ik) = dta_read(ji,jj,ikk) + & 1070 & ( dta_read(ji,jj,ikk+1) - dta_read(ji,jj,ikk) ) * zi 1071 ENDIF 1072 END DO 1073 ENDIF 1074 END DO 1075 END DO 1076 1077 IF(igrd == 2) THEN ! do we need to adjust the transport term? 1078 DO ib = 1, ipi 1079 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 1080 ji=map%ptr(ib)-(jj-1)*ilendta 1081 zij = idx_bdy(ibdy)%nbi(ib,igrd) 1082 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 1083 zh = SUM(dta_read_dz(ji,jj,:) ) 1084 ztrans = 0._wp 1085 ztrans_new = 0._wp 1086 DO ik = 1, jpk_bdy ! calculate transport on input grid 1087 ztrans = ztrans + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik) 1088 ENDDO 1089 DO ik = 1, ipk ! calculate transport on model grid 1090 ztrans_new = ztrans_new + dta(ib,1,ik) * e3u_n(zij,zjj,ik) * umask(zij,zjj,ik) 1091 ENDDO 1092 DO ik = 1, ipk ! make transport correction 1093 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 1094 dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 1095 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 1096 dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 1097 ENDIF 1098 ENDDO 1099 ENDDO 1100 ENDIF 1101 1102 IF(igrd == 3) THEN ! do we need to adjust the transport term? 1103 DO ib = 1, ipi 1104 jj = 1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 1105 ji = map%ptr(ib)-(jj-1)*ilendta 1106 zij = idx_bdy(ibdy)%nbi(ib,igrd) 1107 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 1108 zh = SUM(dta_read_dz(ji,jj,:) ) 1109 ztrans = 0._wp 1110 ztrans_new = 0._wp 1111 DO ik = 1, jpk_bdy ! calculate transport on input grid 1112 ztrans = ztrans + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik) 1113 ENDDO 1114 DO ik = 1, ipk ! calculate transport on model grid 1115 ztrans_new = ztrans_new + dta(ib,1,ik) * e3v_n(zij,zjj,ik) * vmask(zij,zjj,ik) 1116 ENDDO 1117 DO ik = 1, ipk ! make transport correction 1118 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 1119 dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 1120 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 1121 dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 1122 ENDIF 1123 ENDDO 1124 ENDDO 1125 ENDIF 1126 1127 ENDIF ! endif unstructured or structured 1128 986 ENDDO 987 ENDIF 988 1129 989 END SUBROUTINE fld_bdy_interp 1130 990 … … 1151 1011 imf = SIZE( sd ) 1152 1012 DO ju = 1, imf 1013 IF( TRIM(sd(ju)%clrootname) == 'NOT USED' ) CYCLE 1153 1014 ill = LEN_TRIM( sd(ju)%vcomp ) 1154 1015 DO jn = 2-COUNT((/sd(ju)%ln_tint/)), 2 … … 1159 1020 iv = -1 1160 1021 DO jv = 1, imf 1022 IF( TRIM(sd(jv)%clrootname) == 'NOT USED' ) CYCLE 1161 1023 IF( TRIM(sd(jv)%vcomp) == TRIM(clcomp) ) iv = jv 1162 1024 END DO … … 1197 1059 LOGICAL, OPTIONAL, INTENT(in ) :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 1198 1060 ! 1199 LOGICAL :: llprevyr ! are we reading previous year file?1200 LOGICAL :: llprevmth ! are we reading previous month file?1201 INTEGER :: iyear, imonth, iday ! first day of the current file in yyyy mm dd1202 INTEGER :: isec_week ! number of seconds since start of the weekly file1203 INTEGER :: indexyr ! year undex (O/1/2: previous/current/next)1204 INTEGER :: iyear_len, imonth_len ! length (days) of iyear and imonth !1205 CHARACTER(len = 256) :: clname ! temporary file name1061 LOGICAL :: llprevyr ! are we reading previous year file? 1062 LOGICAL :: llprevmth ! are we reading previous month file? 1063 INTEGER :: iyear, imonth, iday ! first day of the current file in yyyy mm dd 1064 INTEGER :: isec_week ! number of seconds since start of the weekly file 1065 INTEGER :: indexyr ! year undex (O/1/2: previous/current/next) 1066 REAL(wp) :: zyear_len, zmonth_len ! length (days) of iyear and imonth ! 1067 CHARACTER(len = 256) :: clname ! temporary file name 1206 1068 !!---------------------------------------------------------------------- 1207 1069 IF( PRESENT(kyear) ) THEN ! use given values … … 1254 1116 ! find the last record to be read -> update sdjf%nreclast 1255 1117 indexyr = iyear - nyear + 1 1256 iyear_len = nyear_len( indexyr)1118 zyear_len = REAL(nyear_len( indexyr ), wp) 1257 1119 SELECT CASE ( indexyr ) 1258 CASE ( 0 ) ; imonth_len = 31! previous year -> imonth = 121259 CASE ( 1 ) ; imonth_len = nmonth_len(imonth)1260 CASE ( 2 ) ; imonth_len = 31! next year -> imonth = 11120 CASE ( 0 ) ; zmonth_len = 31. ! previous year -> imonth = 12 1121 CASE ( 1 ) ; zmonth_len = REAL(nmonth_len(imonth), wp) 1122 CASE ( 2 ) ; zmonth_len = 31. ! next year -> imonth = 1 1261 1123 END SELECT 1262 1124 ! 1263 1125 ! last record to be read in the current file 1264 IF ( sdjf% nfreqh == -12) THEN ; sdjf%nreclast = 1 ! yearly mean1265 ELSEIF( sdjf% nfreqh == -1) THEN ! monthly mean1126 IF ( sdjf%freqh == -12. ) THEN ; sdjf%nreclast = 1 ! yearly mean 1127 ELSEIF( sdjf%freqh == -1. ) THEN ! monthly mean 1266 1128 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = 1 1267 1129 ELSE ; sdjf%nreclast = 12 1268 1130 ENDIF 1269 1131 ELSE ! higher frequency mean (in hours) 1270 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = NINT( 24 * imonth_len / sdjf%nfreqh )1271 ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; sdjf%nreclast = NINT( 24 * 7 / sdjf%nfreqh )1272 ELSEIF( sdjf%cltype == 'daily' ) THEN ; sdjf%nreclast = NINT( 24 / sdjf%nfreqh )1273 ELSE ; sdjf%nreclast = NINT( 24 * iyear_len / sdjf%nfreqh )1132 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = NINT( 24. * zmonth_len / sdjf%freqh ) 1133 ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; sdjf%nreclast = NINT( 24. * 7. / sdjf%freqh ) 1134 ELSEIF( sdjf%cltype == 'daily' ) THEN ; sdjf%nreclast = NINT( 24. / sdjf%freqh ) 1135 ELSE ; sdjf%nreclast = NINT( 24. * zyear_len / sdjf%freqh ) 1274 1136 ENDIF 1275 1137 ENDIF … … 1299 1161 ! 1300 1162 DO jf = 1, SIZE(sdf) 1301 sdf(jf)%clrootname = TRIM( cdir )//TRIM( sdf_n(jf)%clname ) 1163 sdf(jf)%clrootname = sdf_n(jf)%clname 1164 IF( TRIM(sdf_n(jf)%clname) /= 'NOT USED' ) sdf(jf)%clrootname = TRIM( cdir )//sdf(jf)%clrootname 1302 1165 sdf(jf)%clname = "not yet defined" 1303 sdf(jf)% nfreqh = sdf_n(jf)%nfreqh1166 sdf(jf)%freqh = sdf_n(jf)%freqh 1304 1167 sdf(jf)%clvar = sdf_n(jf)%clvar 1305 1168 sdf(jf)%ln_tint = sdf_n(jf)%ln_tint … … 1308 1171 sdf(jf)%num = -1 1309 1172 sdf(jf)%wgtname = " " 1310 IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )// TRIM( sdf_n(jf)%wname )1173 IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//sdf_n(jf)%wname 1311 1174 sdf(jf)%lsmname = " " 1312 IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 ) sdf(jf)%lsmname = TRIM( cdir )// TRIM( sdf_n(jf)%lname )1175 IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 ) sdf(jf)%lsmname = TRIM( cdir )//sdf_n(jf)%lname 1313 1176 sdf(jf)%vcomp = sdf_n(jf)%vcomp 1314 1177 sdf(jf)%rotn(:) = .TRUE. ! pretend to be rotated -> won't try to rotate data before the first call to fld_get … … 1317 1180 IF( sdf(jf)%cltype(1:4) == 'week' .AND. sdf(jf)%ln_clim ) & 1318 1181 & CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.') 1319 sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 1182 sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 1183 sdf(jf)%igrd = 0 1184 sdf(jf)%ibdy = 0 1185 sdf(jf)%imap => NULL() 1186 sdf(jf)%ltotvel = .FALSE. 1187 sdf(jf)%lzint = .FALSE. 1320 1188 END DO 1321 1189 ! … … 1331 1199 DO jf = 1, SIZE(sdf) 1332 1200 WRITE(numout,*) ' root filename: ' , TRIM( sdf(jf)%clrootname ), ' variable name: ', TRIM( sdf(jf)%clvar ) 1333 WRITE(numout,*) ' frequency: ' , sdf(jf)% nfreqh, &1201 WRITE(numout,*) ' frequency: ' , sdf(jf)%freqh , & 1334 1202 & ' time interp: ' , sdf(jf)%ln_tint , & 1335 1203 & ' climatology: ' , sdf(jf)%ln_clim -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbc_oce.F90
r10425 r12065 119 119 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_tot !: total non solar heat flux (over sea and ice) [W/m2] 120 120 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp , emp_b !: freshwater budget: volume flux [Kg/m2/s] 121 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PS U/m2/s]121 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PSS.kg/m2/s] 122 122 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s] 123 123 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s] -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcapr.F90
r10425 r12065 26 26 PUBLIC sbc_apr_init ! routine called in sbcmod 27 27 28 ! !!* namsbc_apr namelist (Atmospheric PRessure) *29 LOGICAL, PUBLIC :: ln_apr_obc !: inverse barometer added to OBC ssh data30 LOGICAL, PUBLIC :: ln_ref_apr !: ref. pressure: global mean Patm (F) or a constant (F)31 REAL(wp) :: rn_pref ! reference atmospheric pressure [N/m2]28 ! !!* namsbc_apr namelist (Atmospheric PRessure) * 29 LOGICAL, PUBLIC :: ln_apr_obc = .false. !: inverse barometer added to OBC ssh data 30 LOGICAL, PUBLIC :: ln_ref_apr !: ref. pressure: global mean Patm (F) or a constant (F) 31 REAL(wp) :: rn_pref ! reference atmospheric pressure [N/m2] 32 32 33 33 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ib ! Inverse barometer now sea surface height [m] … … 71 71 REWIND( numnam_ref ) ! Namelist namsbc_apr in reference namelist : File for atmospheric pressure forcing 72 72 READ ( numnam_ref, namsbc_apr, IOSTAT = ios, ERR = 901) 73 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_apr in reference namelist' , lwp)73 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_apr in reference namelist' ) 74 74 75 75 REWIND( numnam_cfg ) ! Namelist namsbc_apr in configuration namelist : File for atmospheric pressure forcing 76 76 READ ( numnam_cfg, namsbc_apr, IOSTAT = ios, ERR = 902 ) 77 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist' , lwp)77 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist' ) 78 78 IF(lwm) WRITE ( numond, namsbc_apr ) 79 79 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcblk.F90
r10535 r12065 182 182 REWIND( numnam_ref ) !* Namelist namsbc_blk in reference namelist : bulk parameters 183 183 READ ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901) 184 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' , lwp)184 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' ) 185 185 ! 186 186 REWIND( numnam_cfg ) !* Namelist namsbc_blk in configuration namelist : bulk parameters 187 187 READ ( numnam_cfg, namsbc_blk, IOSTAT = ios, ERR = 902 ) 188 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist' , lwp)188 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist' ) 189 189 ! 190 190 IF(lwm) WRITE( numond, namsbc_blk ) … … 201 201 ! 202 202 IF( ln_dm2dc ) THEN !* check: diurnal cycle on Qsr 203 IF( sn_qsr% nfreqh /= 24) CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' )203 IF( sn_qsr%freqh /= 24. ) CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' ) 204 204 IF( sn_qsr%ln_tint ) THEN 205 205 CALL ctl_warn( 'sbc_blk_init: ln_dm2dc=T daily qsr time interpolation done by sbcdcy module', & … … 225 225 ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) ) 226 226 IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) 227 IF( slf_i(ifpr)% nfreqh > 0. .AND. MOD( 3600. * slf_i(ifpr)%nfreqh , REAL(nn_fsbc) * rdt) /= 0.) &227 IF( slf_i(ifpr)%freqh > 0. .AND. MOD( NINT(3600. * slf_i(ifpr)%freqh), nn_fsbc * NINT(rdt) ) /= 0 ) & 228 228 & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rdt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & 229 229 & ' This is not ideal. You should consider changing either rdt or nn_fsbc value...' ) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbccpl.F90
r10617 r12065 266 266 REWIND( numnam_ref ) ! Namelist namsbc_cpl in reference namelist : Variables for OASIS coupling 267 267 READ ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901) 268 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist' , lwp)268 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist' ) 269 269 ! 270 270 REWIND( numnam_cfg ) ! Namelist namsbc_cpl in configuration namelist : Variables for OASIS coupling 271 271 READ ( numnam_cfg, namsbc_cpl, IOSTAT = ios, ERR = 902 ) 272 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist' , lwp)272 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist' ) 273 273 IF(lwm) WRITE ( numond, namsbc_cpl ) 274 274 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcflx.F90
r10425 r12065 93 93 REWIND( numnam_ref ) ! Namelist namsbc_flx in reference namelist : Files for fluxes 94 94 READ ( numnam_ref, namsbc_flx, IOSTAT = ios, ERR = 901) 95 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx in reference namelist' , lwp)95 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx in reference namelist' ) 96 96 97 97 REWIND( numnam_cfg ) ! Namelist namsbc_flx in configuration namelist : Files for fluxes 98 98 READ ( numnam_cfg, namsbc_flx, IOSTAT = ios, ERR = 902 ) 99 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist' , lwp)99 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist' ) 100 100 IF(lwm) WRITE ( numond, namsbc_flx ) 101 101 ! 102 102 ! ! check: do we plan to use ln_dm2dc with non-daily forcing? 103 IF( ln_dm2dc .AND. sn_qsr% nfreqh /= 24) &103 IF( ln_dm2dc .AND. sn_qsr%freqh /= 24. ) & 104 104 & CALL ctl_stop( 'sbc_blk_core: ln_dm2dc can be activated only with daily short-wave forcing' ) 105 105 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcice_cice.F90
r10425 r12065 764 764 REWIND( numnam_ref ) ! Namelist namsbc_cice in reference namelist : 765 765 READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) 766 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' , lwp)766 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' ) 767 767 768 768 REWIND( numnam_cfg ) ! Namelist namsbc_cice in configuration namelist : Parameters of the run 769 769 READ ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 ) 770 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' , lwp)770 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' ) 771 771 IF(lwm) WRITE ( numond, namsbc_cice ) 772 772 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcice_if.F90
r10068 r12065 76 76 REWIND( numnam_ref ) ! Namelist namsbc_iif in reference namelist : Ice if file 77 77 READ ( numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901) 78 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' , lwp)78 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' ) 79 79 80 80 REWIND( numnam_cfg ) ! Namelist Namelist namsbc_iif in configuration namelist : Ice if file 81 81 READ ( numnam_cfg, namsbc_iif, IOSTAT = ios, ERR = 902 ) 82 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist' , lwp)82 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist' ) 83 83 IF(lwm) WRITE ( numond, namsbc_iif ) 84 84 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcisf.F90
r10536 r12065 278 278 REWIND( numnam_ref ) ! Namelist namsbc_rnf in reference namelist : Runoffs 279 279 READ ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901) 280 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_isf in reference namelist' , lwp)280 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_isf in reference namelist' ) 281 281 282 282 REWIND( numnam_cfg ) ! Namelist namsbc_rnf in configuration namelist : Runoffs 283 283 READ ( numnam_cfg, namsbc_isf, IOSTAT = ios, ERR = 902 ) 284 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist' , lwp)284 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist' ) 285 285 IF(lwm) WRITE ( numond, namsbc_isf ) 286 286 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcmod.F90
r10499 r12065 110 110 REWIND( numnam_ref ) !* Namelist namsbc in reference namelist : Surface boundary 111 111 READ ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901) 112 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist' , lwp)112 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist' ) 113 113 REWIND( numnam_cfg ) !* Namelist namsbc in configuration namelist : Parameters of the run 114 114 READ ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 ) 115 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist' , lwp)115 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist' ) 116 116 IF(lwm) WRITE( numond, namsbc ) 117 117 ! … … 307 307 ! 308 308 ! !* check consistency between model timeline and nn_fsbc 309 IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR. & 310 MOD( nstock , nn_fsbc) /= 0 ) THEN 311 WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') or nstock (', nstock, & 312 & ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 313 CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 309 IF( ln_rst_list .OR. nn_stock /= -1 ) THEN ! we will do restart files 310 IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 ) THEN 311 WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 312 CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 313 ENDIF 314 IF( .NOT. ln_rst_list .AND. MOD( nn_stock, nn_fsbc) /= 0 ) THEN ! we don't use nn_stock if ln_rst_list 315 WRITE(ctmp1,*) 'sbc_init : nn_stock (', nn_stock, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 316 CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 317 ENDIF 314 318 ENDIF 315 319 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcrnf.F90
r10523 r12065 267 267 REWIND( numnam_ref ) ! Namelist namsbc_rnf in reference namelist : Runoffs 268 268 READ ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) 269 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' , lwp)269 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) 270 270 271 271 REWIND( numnam_cfg ) ! Namelist namsbc_rnf in configuration namelist : Runoffs 272 272 READ ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 ) 273 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' , lwp)273 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' ) 274 274 IF(lwm) WRITE ( numond, namsbc_rnf ) 275 275 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcssr.F90
r10068 r12065 166 166 REWIND( numnam_ref ) ! Namelist namsbc_ssr in reference namelist : 167 167 READ ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901) 168 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' , lwp)168 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' ) 169 169 170 170 REWIND( numnam_cfg ) ! Namelist namsbc_ssr in configuration namelist : 171 171 READ ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 ) 172 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist' , lwp)172 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist' ) 173 173 IF(lwm) WRITE ( numond, namsbc_ssr ) 174 174 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/SBC/sbcwave.F90
r10425 r12065 397 397 REWIND( numnam_ref ) ! Namelist namsbc_wave in reference namelist : File for drag coeff. from wave model 398 398 READ ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) 399 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' , lwp)399 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' ) 400 400 401 401 REWIND( numnam_cfg ) ! Namelist namsbc_wave in configuration namelist : File for drag coeff. from wave model 402 402 READ ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) 403 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' , lwp)403 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' ) 404 404 IF(lwm) WRITE ( numond, namsbc_wave ) 405 405 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/STO/stopar.F90
r10425 r12065 263 263 REWIND( numnam_ref ) ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 264 264 READ ( numnam_ref, namsto, IOSTAT = ios, ERR = 901) 265 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist' , lwp)265 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist' ) 266 266 267 267 REWIND( numnam_cfg ) ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme 268 268 READ ( numnam_cfg, namsto, IOSTAT = ios, ERR = 902 ) 269 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist' , lwp)269 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist' ) 270 270 IF(lwm) WRITE ( numond, namsto ) 271 271 272 IF( .NOT.ln_ rststo) THEN ! no use of stochastic parameterization272 IF( .NOT.ln_sto_eos ) THEN ! no use of stochastic parameterization 273 273 IF(lwp) THEN 274 274 WRITE(numout,*) … … 750 750 CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name 751 751 CHARACTER(LEN=10) :: clseed='seed0_0000' ! seed variable name 752 752 !!---------------------------------------------------------------------- 753 754 IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart 755 753 756 IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN 754 757 … … 790 793 ! Open the restart file one timestep before writing restart 791 794 IF( kt < nitend) THEN 792 IF( kt == nitrst - 1 .OR. n stock == 1 .OR. kt == nitend-1 ) THEN795 IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. kt == nitend-1 ) THEN 793 796 ! create the filename 794 797 IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TDE/tide_mod.F90
r12057 r12065 134 134 REWIND( numnam_ref ) ! Namelist nam_tide in reference namelist : Tides 135 135 READ ( numnam_ref, nam_tide, IOSTAT = ios, ERR = 901) 136 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in reference namelist' , lwp)136 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in reference namelist' ) 137 137 ! 138 138 REWIND( numnam_cfg ) ! Namelist nam_tide in configuration namelist : Tides 139 139 READ ( numnam_cfg, nam_tide, IOSTAT = ios, ERR = 902 ) 140 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_tide in configuration namelist' , lwp)140 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_tide in configuration namelist' ) 141 141 IF(lwm) WRITE ( numond, nam_tide ) 142 142 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/eosbn2.F90
r10425 r12065 30 30 !! eos_insitu_2d : Compute the in situ density for 2d fields 31 31 !! bn2 : Compute the Brunt-Vaisala frequency 32 !! bn2 : compute the Brunt-Vaisala frequency 33 !! eos_pt_from_ct: compute the potential temperature from the Conservative Temperature 32 34 !! eos_rab : generic interface of in situ thermal/haline expansion ratio 33 35 !! eos_rab_3d : compute in situ thermal/haline expansion ratio … … 74 76 75 77 ! !!** Namelist nameos ** 76 LOGICAL , PUBLIC :: ln_TEOS10 ! determine if eos_pt_from_ct is used to compute sst_m77 LOGICAL , PUBLIC :: ln_EOS80 ! determine if eos_pt_from_ct is used to compute sst_m78 LOGICAL , PUBLIC :: ln_SEOS ! determine if eos_pt_from_ct is used to compute sst_m78 LOGICAL , PUBLIC :: ln_TEOS10 79 LOGICAL , PUBLIC :: ln_EOS80 80 LOGICAL , PUBLIC :: ln_SEOS 79 81 80 82 ! Parameters … … 1235 1237 REWIND( numnam_ref ) ! Namelist nameos in reference namelist : equation of state 1236 1238 READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 1237 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' , lwp)1239 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' ) 1238 1240 ! 1239 1241 REWIND( numnam_cfg ) ! Namelist nameos in configuration namelist : equation of state 1240 1242 READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 1241 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' , lwp)1243 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' ) 1242 1244 IF(lwm) WRITE( numond, nameos ) 1243 1245 ! … … 1647 1649 ! 1648 1650 CASE( np_seos ) !== Simplified EOS ==! 1651 1652 r1_S0 = 0.875_wp/35.16504_wp ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct) 1653 1649 1654 IF(lwp) THEN 1650 1655 WRITE(numout,*) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/traadv.F90
r10068 r12065 196 196 REWIND( numnam_ref ) ! Namelist namtra_adv in reference namelist : Tracer advection scheme 197 197 READ ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) 198 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist' , lwp)198 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist' ) 199 199 ! 200 200 REWIND( numnam_cfg ) ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 201 201 READ ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) 202 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' , lwp)202 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' ) 203 203 IF(lwm) WRITE( numond, namtra_adv ) 204 204 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/traadv_fct.F90
r10425 r12065 21 21 USE diaar5 ! AR5 diagnostics 22 22 USE phycst , ONLY : rau0_rcp 23 USE zdf_oce , ONLY : ln_zad_Aimp 23 24 ! 24 25 USE in_out_manager ! I/O manager … … 86 87 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 87 88 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry 89 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup 90 LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection 88 91 !!---------------------------------------------------------------------- 89 92 ! … … 97 100 l_hst = .FALSE. 98 101 l_ptr = .FALSE. 102 ll_zAimp = .FALSE. 99 103 IF( ( cdtype =='TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 100 104 IF( cdtype =='TRA' .AND. ln_diaptr ) l_ptr = .TRUE. … … 116 120 ! 117 121 zwi(:,:,:) = 0._wp 122 ! 123 ! If adaptive vertical advection, check if it is needed on this PE at this time 124 IF( ln_zad_Aimp ) THEN 125 IF( MAXVAL( ABS( wi(:,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE. 126 END IF 127 ! If active adaptive vertical advection, build tridiagonal matrix 128 IF( ll_zAimp ) THEN 129 ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) 130 DO jk = 1, jpkm1 131 DO jj = 2, jpjm1 132 DO ji = fs_2, fs_jpim1 ! vector opt. (ensure same order of calculation as below if wi=0.) 133 zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) / e3t_a(ji,jj,jk) 134 zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / e3t_a(ji,jj,jk) 135 zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t_a(ji,jj,jk) 136 END DO 137 END DO 138 END DO 139 END IF 118 140 ! 119 141 DO jn = 1, kjpt !== loop over the tracers ==! … … 169 191 END DO 170 192 END DO 193 194 IF ( ll_zAimp ) THEN 195 CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 ) 196 ! 197 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 198 DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) 199 DO jj = 2, jpjm1 200 DO ji = fs_2, fs_jpim1 ! vector opt. 201 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 202 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 203 ztw(ji,jj,jk) = 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 204 zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes 205 END DO 206 END DO 207 END DO 208 DO jk = 1, jpkm1 209 DO jj = 2, jpjm1 210 DO ji = fs_2, fs_jpim1 ! vector opt. 211 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & 212 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 213 END DO 214 END DO 215 END DO 216 ! 217 END IF 171 218 ! 172 219 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) … … 277 324 zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked 278 325 ENDIF 326 ! 327 IF ( ll_zAimp ) THEN 328 DO jk = 1, jpkm1 !* trend and after field with monotonic scheme 329 DO jj = 2, jpjm1 330 DO ji = fs_2, fs_jpim1 ! vector opt. 331 ! ! total intermediate advective trends 332 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 333 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 334 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 335 ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 336 END DO 337 END DO 338 END DO 339 ! 340 CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 341 ! 342 DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) 343 DO jj = 2, jpjm1 344 DO ji = fs_2, fs_jpim1 ! vector opt. 345 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 346 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 347 zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) 348 END DO 349 END DO 350 END DO 351 END IF 279 352 ! 280 353 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1., zwx, 'U', -1. , zwy, 'V', -1., zwz, 'W', 1. ) … … 289 362 DO jj = 2, jpjm1 290 363 DO ji = fs_2, fs_jpim1 ! vector opt. 291 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 292 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 293 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) & 294 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 295 END DO 296 END DO 297 END DO 364 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 365 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 366 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 367 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) 368 zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 369 END DO 370 END DO 371 END DO 372 ! 373 IF ( ll_zAimp ) THEN 374 ! 375 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 376 DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) 377 DO jj = 2, jpjm1 378 DO ji = fs_2, fs_jpim1 ! vector opt. 379 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 380 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 381 ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 382 zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic 383 END DO 384 END DO 385 END DO 386 DO jk = 1, jpkm1 387 DO jj = 2, jpjm1 388 DO ji = fs_2, fs_jpim1 ! vector opt. 389 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & 390 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 391 END DO 392 END DO 393 END DO 394 END IF 298 395 ! 299 396 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport … … 318 415 END DO ! end of tracer loop 319 416 ! 417 IF ( ll_zAimp ) THEN 418 DEALLOCATE( zwdia, zwinf, zwsup ) 419 ENDIF 320 420 IF( l_trd .OR. l_hst ) THEN 321 421 DEALLOCATE( ztrdx, ztrdy, ztrdz ) … … 559 659 DO ji = fs_2, fs_jpim1 560 660 ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point 561 ikb = mbkt(ji,jj)! - above the last wet point661 ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point 562 662 ! 563 663 zwd (ji,jj,ikt) = 1._wp ! top -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/trabbc.F90
r10425 r12065 135 135 REWIND( numnam_ref ) ! Namelist nambbc in reference namelist : Bottom momentum boundary condition 136 136 READ ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) 137 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist' , lwp)137 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist' ) 138 138 ! 139 139 REWIND( numnam_cfg ) ! Namelist nambbc in configuration namelist : Bottom momentum boundary condition 140 140 READ ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) 141 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist' , lwp)141 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist' ) 142 142 IF(lwm) WRITE ( numond, nambbc ) 143 143 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/trabbl.F90
r10425 r12065 485 485 REWIND( numnam_ref ) ! Namelist nambbl in reference namelist : Bottom boundary layer scheme 486 486 READ ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) 487 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist' , lwp)487 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist' ) 488 488 ! 489 489 REWIND( numnam_cfg ) ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme 490 490 READ ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) 491 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist' , lwp)491 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist' ) 492 492 IF(lwm) WRITE ( numond, nambbl ) 493 493 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/tradmp.F90
r10425 r12065 179 179 REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : T & S relaxation 180 180 READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 181 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' , lwp)181 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) 182 182 ! 183 183 REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : T & S relaxation 184 184 READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) 185 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' , lwp)185 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' ) 186 186 IF(lwm) WRITE ( numond, namtra_dmp ) 187 187 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/traldf_iso.F90
r10068 r12065 289 289 !!---------------------------------------------------------------------- 290 290 ! 291 ztfw( 1,:,:) = 0._wp ; ztfw(jpi,:,:) = 0._wp291 ztfw(fs_2:1,:,:) = 0._wp ; ztfw(jpi:fs_jpim1,:,:) = 0._wp ! avoid to potentially manipulate NaN values 292 292 ! 293 293 ! Vertical fluxes … … 323 323 IF( ln_traldf_lap ) THEN ! laplacian case: eddy coef = ah_wslp2 - akz 324 324 DO jk = 2, jpkm1 325 DO jj = 1, jpjm1325 DO jj = 2, jpjm1 326 326 DO ji = fs_2, fs_jpim1 327 327 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) & … … 336 336 CASE( 1 ) ! 1st pass : eddy coef = ah_wslp2 337 337 DO jk = 2, jpkm1 338 DO jj = 1, jpjm1338 DO jj = 2, jpjm1 339 339 DO ji = fs_2, fs_jpim1 340 340 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) & … … 346 346 CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb and ptbb gradients, resp. 347 347 DO jk = 2, jpkm1 348 DO jj = 1, jpjm1348 DO jj = 2, jpjm1 349 349 DO ji = fs_2, fs_jpim1 350 350 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) & -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/tramle.F90
r10425 r12065 268 268 REWIND( numnam_ref ) ! Namelist namtra_mle in reference namelist : Tracer advection scheme 269 269 READ ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901) 270 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_mle in reference namelist' , lwp)270 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_mle in reference namelist' ) 271 271 272 272 REWIND( numnam_cfg ) ! Namelist namtra_mle in configuration namelist : Tracer advection scheme 273 273 READ ( numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902 ) 274 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' , lwp)274 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' ) 275 275 IF(lwm) WRITE ( numond, namtra_mle ) 276 276 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRA/traqsr.F90
r10425 r12065 168 168 DO jj = 2, jpjm1 ! Separation in R-G-B depending of the surface Chl 169 169 DO ji = fs_2, fs_jpim1 170 zchl = sf_chl(1)%fnow(ji,jj,1)170 zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 171 171 zCtot = 40.6 * zchl**0.459 172 172 zze = 568.2 * zCtot**(-0.746) … … 338 338 REWIND( numnam_ref ) ! Namelist namtra_qsr in reference namelist 339 339 READ ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) 340 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' , lwp)340 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' ) 341 341 ! 342 342 REWIND( numnam_cfg ) ! Namelist namtra_qsr in configuration namelist 343 343 READ ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) 344 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' , lwp)344 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' ) 345 345 IF(lwm) WRITE ( numond, namtra_qsr ) 346 346 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRD/trdini.F90
r10068 r12065 48 48 REWIND( numnam_ref ) ! Namelist namtrd in reference namelist : trends diagnostic 49 49 READ ( numnam_ref, namtrd, IOSTAT = ios, ERR = 901 ) 50 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd in reference namelist' , lwp)50 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd in reference namelist' ) 51 51 ! 52 52 REWIND( numnam_cfg ) ! Namelist namtrd in configuration namelist : trends diagnostic 53 53 READ ( numnam_cfg, namtrd, IOSTAT = ios, ERR = 902 ) 54 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd in configuration namelist' , lwp)54 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd in configuration namelist' ) 55 55 IF(lwm) WRITE( numond, namtrd ) 56 56 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRD/trdmxl.F90
r10425 r12065 734 734 REWIND( numnam_ref ) ! Namelist namtrd_mxl in reference namelist : mixed layer trends diagnostic 735 735 READ ( numnam_ref, namtrd_mxl, IOSTAT = ios, ERR = 901 ) 736 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist' , lwp)736 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist' ) 737 737 738 738 REWIND( numnam_cfg ) ! Namelist namtrd_mxl in configuration namelist : mixed layer trends diagnostic 739 739 READ ( numnam_cfg, namtrd_mxl, IOSTAT = ios, ERR = 902 ) 740 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist' , lwp)740 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist' ) 741 741 IF(lwm) WRITE( numond, namtrd_mxl ) 742 742 ! … … 764 764 765 765 IF( MOD( nitend, nn_trd ) /= 0 ) THEN 766 WRITE(numout,cform_err) 767 WRITE(numout,*) ' Your nitend parameter, nitend = ', nitend 768 WRITE(numout,*) ' is no multiple of the trends diagnostics frequency ' 769 WRITE(numout,*) ' you defined, nn_trd = ', nn_trd 770 WRITE(numout,*) ' This will not allow you to restart from this simulation. ' 771 WRITE(numout,*) ' You should reconsider this choice. ' 772 WRITE(numout,*) 773 WRITE(numout,*) ' N.B. the nitend parameter is also constrained to be a ' 774 WRITE(numout,*) ' multiple of the nn_fsbc parameter ' 775 CALL ctl_stop( 'trd_mxl_init: see comment just above' ) 766 WRITE(ctmp1,*) ' Your nitend parameter, nitend = ', nitend 767 WRITE(ctmp2,*) ' is no multiple of the trends diagnostics frequency ' 768 WRITE(ctmp3,*) ' you defined, nn_trd = ', nn_trd 769 WRITE(ctmp4,*) ' This will not allow you to restart from this simulation. ' 770 WRITE(ctmp5,*) ' You should reconsider this choice. ' 771 WRITE(ctmp6,*) 772 WRITE(ctmp7,*) ' N.B. the nitend parameter is also constrained to be a ' 773 WRITE(ctmp8,*) ' multiple of the nn_fsbc parameter ' 774 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 776 775 END IF 777 776 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRD/trdmxl_rst.F90
r10425 r12065 47 47 !!-------------------------------------------------------------------------------- 48 48 49 IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart 50 49 51 ! to get better performances with NetCDF format: 50 52 ! we open and define the ocean restart_mxl file one time step before writing the data (-> at nitrst - 1) 51 53 ! except if we write ocean restart_mxl files every time step or if an ocean restart_mxl file was writen at nitend - 1 52 IF( kt == nitrst - 1 .OR. n stock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nstock ) == 0 ) ) THEN54 IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nn_stock ) == 0 ) ) THEN 53 55 ! beware of the format used to write kt (default is i8.8, that should be large enough...) 54 56 IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/TRD/trdvor.F90
r10425 r12065 46 46 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avr ! average 47 47 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrb ! before vorticity (kt-1) 48 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbb ! vorticity at begining of the n write-1 timestep averaging period48 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbb ! vorticity at begining of the nn_write-1 timestep averaging period 49 49 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbn ! after vorticity at time step after the 50 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: rotot ! begining of the N WRITE-1 timesteps50 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: rotot ! begining of the NN_WRITE-1 timesteps 51 51 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrtot ! 52 52 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrres ! … … 129 129 !! from ocean surface down to control surface (NetCDF output) 130 130 !! 131 !! ** Method/usage : integration done over n write-1 time steps131 !! ** Method/usage : integration done over nn_write-1 time steps 132 132 !! 133 133 !! ** Action : trends : … … 143 143 !! vortrd (,,10) = forcing term 144 144 !! vortrd (,,11) = bottom friction term 145 !! rotot(,) : total cumulative trends over n write-1 time steps145 !! rotot(,) : total cumulative trends over nn_write-1 time steps 146 146 !! vor_avrtot(,) : first membre of vrticity equation 147 147 !! vor_avrres(,) : residual = dh/dt entrainment … … 214 214 !! from ocean surface down to control surface (NetCDF output) 215 215 !! 216 !! ** Method/usage : integration done over n write-1 time steps216 !! ** Method/usage : integration done over nn_write-1 time steps 217 217 !! 218 218 !! ** Action : trends : … … 228 228 !! vortrd (,,10) = forcing term 229 229 !! vortrd (,,11) = bottom friction term 230 !! rotot(,) : total cumulative trends over n write-1 time steps230 !! rotot(,) : total cumulative trends over nn_write-1 time steps 231 231 !! vor_avrtot(,) : first membre of vrticity equation 232 232 !! vor_avrres(,) : residual = dh/dt entrainment … … 360 360 ENDIF 361 361 362 ! II.2 cumulated trends over analysis period (kt=2 to n write)362 ! II.2 cumulated trends over analysis period (kt=2 to nn_write) 363 363 ! ---------------------- 364 ! trends cumulated over n write-2 time steps364 ! trends cumulated over nn_write-2 time steps 365 365 366 366 IF( kt >= nit000+2 ) THEN … … 376 376 ! III. Output in netCDF + residual computation 377 377 ! ============================================= 378 378 379 379 ! define time axis 380 380 it = kt … … 504 504 ENDIF 505 505 #if defined key_diainstant 506 zsto = n write*rdt506 zsto = nn_write*rdt 507 507 clop = "inst("//TRIM(clop)//")" 508 508 #else -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/USR/usrdef_nam.F90
r10069 r12065 37 37 CONTAINS 38 38 39 SUBROUTINE usr_def_nam( ldtxt, ldnam,cd_cfg, kk_cfg, kpi, kpj, kpk, kperio )39 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 40 40 !!---------------------------------------------------------------------- 41 41 !! *** ROUTINE dom_nam *** … … 49 49 !! ** input : - namusr_def namelist found in namelist_cfg 50 50 !!---------------------------------------------------------------------- 51 CHARACTER(len=*), DIMENSION(:), INTENT(out) :: ldtxt, ldnam ! stored print information 52 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 53 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 54 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 55 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 51 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 56 55 ! 57 INTEGER :: ios , ii! Local integer56 INTEGER :: ios ! Local integer 58 57 !! 59 58 NAMELIST/namusr_def/ nn_GYRE, ln_bench, jpkglo 60 59 !!---------------------------------------------------------------------- 61 60 ! 62 ii = 163 !64 61 REWIND( numnam_cfg ) ! Namelist namusr_def (exist in namelist_cfg only) 65 62 READ ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 ) 66 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' , .TRUE.)63 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' ) 67 64 ! 68 WRITE( ldnam(:), namusr_def )65 IF(lwm) WRITE( numond, namusr_def ) 69 66 ! 70 67 cd_cfg = 'GYRE' ! name & resolution (not used) … … 83 80 #endif 84 81 kpk = jpkglo 85 !86 ! ! control print87 WRITE(ldtxt(ii),*) ' ' ; ii = ii + 188 WRITE(ldtxt(ii),*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg' ; ii = ii + 189 WRITE(ldtxt(ii),*) '~~~~~~~~~~~ ' ; ii = ii + 190 WRITE(ldtxt(ii),*) ' Namelist namusr_def : GYRE case' ; ii = ii + 191 WRITE(ldtxt(ii),*) ' GYRE used as Benchmark (=T) ln_bench = ', ln_bench ; ii = ii + 192 WRITE(ldtxt(ii),*) ' inverse resolution & implied domain size nn_GYRE = ', nn_GYRE ; ii = ii + 193 #if defined key_agrif94 IF( Agrif_Root() ) THEN95 #endif96 WRITE(ldtxt(ii),*) ' jpiglo = 30*nn_GYRE+2 jpiglo = ', kpi ; ii = ii + 197 WRITE(ldtxt(ii),*) ' jpjglo = 20*nn_GYRE+2 jpjglo = ', kpj ; ii = ii + 198 #if defined key_agrif99 ENDIF100 #endif101 WRITE(ldtxt(ii),*) ' number of model levels jpkglo = ', kpk ; ii = ii + 1102 !103 82 ! ! Set the lateral boundary condition of the global domain 104 83 kperio = 0 ! GYRE configuration : closed domain 105 84 ! 106 WRITE(ldtxt(ii),*) ' ' ; ii = ii + 1 107 WRITE(ldtxt(ii),*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio ; ii = ii + 1 85 ! ! control print 86 IF(lwp) THEN 87 WRITE(numout,*) ' ' 88 WRITE(numout,*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg' 89 WRITE(numout,*) '~~~~~~~~~~~ ' 90 WRITE(numout,*) ' Namelist namusr_def : GYRE case' 91 WRITE(numout,*) ' GYRE used as Benchmark (=T) ln_bench = ', ln_bench 92 WRITE(numout,*) ' inverse resolution & implied domain size nn_GYRE = ', nn_GYRE 93 #if defined key_agrif 94 IF( Agrif_Root() ) THEN 95 #endif 96 WRITE(numout,*) ' jpiglo = 30*nn_GYRE+2 jpiglo = ', kpi 97 WRITE(numout,*) ' jpjglo = 20*nn_GYRE+2 jpjglo = ', kpj 98 #if defined key_agrif 99 ENDIF 100 #endif 101 WRITE(numout,*) ' number of model levels jpkglo = ', kpk 102 WRITE(numout,*) ' ' 103 WRITE(numout,*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio 104 ENDIF 108 105 ! 109 106 END SUBROUTINE usr_def_nam -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ZDF/zdfdrg.F90
r10069 r12065 238 238 REWIND( numnam_ref ) ! Namelist namdrg in reference namelist 239 239 READ ( numnam_ref, namdrg, IOSTAT = ios, ERR = 901) 240 901 IF( ios /= 0 ) CALL ctl_nam( ios , 'namdrg in reference namelist' , lwp)240 901 IF( ios /= 0 ) CALL ctl_nam( ios , 'namdrg in reference namelist' ) 241 241 REWIND( numnam_cfg ) ! Namelist namdrg in configuration namelist 242 242 READ ( numnam_cfg, namdrg, IOSTAT = ios, ERR = 902 ) 243 902 IF( ios > 0 ) CALL ctl_nam( ios , 'namdrg in configuration namelist' , lwp)243 902 IF( ios > 0 ) CALL ctl_nam( ios , 'namdrg in configuration namelist' ) 244 244 IF(lwm) WRITE ( numond, namdrg ) 245 245 ! … … 338 338 IF(ll_top) READ ( numnam_ref, namdrg_top, IOSTAT = ios, ERR = 901) 339 339 IF(ll_bot) READ ( numnam_ref, namdrg_bot, IOSTAT = ios, ERR = 901) 340 901 IF( ios /= 0 ) CALL ctl_nam( ios , TRIM(cl_namref) , lwp)340 901 IF( ios /= 0 ) CALL ctl_nam( ios , TRIM(cl_namref) ) 341 341 REWIND( numnam_cfg ) ! Namelist cd_namdrg in configuration namelist 342 342 IF(ll_top) READ ( numnam_cfg, namdrg_top, IOSTAT = ios, ERR = 902 ) 343 343 IF(ll_bot) READ ( numnam_cfg, namdrg_bot, IOSTAT = ios, ERR = 902 ) 344 902 IF( ios > 0 ) CALL ctl_nam( ios , TRIM(cl_namcfg) , lwp)344 902 IF( ios > 0 ) CALL ctl_nam( ios , TRIM(cl_namcfg) ) 345 345 IF(lwm .AND. ll_top) WRITE ( numond, namdrg_top ) 346 346 IF(lwm .AND. ll_bot) WRITE ( numond, namdrg_bot ) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ZDF/zdfgls.F90
r10425 r12065 859 859 REWIND( numnam_ref ) ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme 860 860 READ ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901) 861 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' , lwp)861 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' ) 862 862 863 863 REWIND( numnam_cfg ) ! Namelist namzdf_gls in configuration namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme 864 864 READ ( numnam_cfg, namzdf_gls, IOSTAT = ios, ERR = 902 ) 865 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist' , lwp)865 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist' ) 866 866 IF(lwm) WRITE ( numond, namzdf_gls ) 867 867 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ZDF/zdfiwm.F90
r10425 r12065 424 424 REWIND( numnam_ref ) ! Namelist namzdf_iwm in reference namelist : Wave-driven mixing 425 425 READ ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901) 426 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' , lwp)426 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' ) 427 427 ! 428 428 REWIND( numnam_cfg ) ! Namelist namzdf_iwm in configuration namelist : Wave-driven mixing 429 429 READ ( numnam_cfg, namzdf_iwm, IOSTAT = ios, ERR = 902 ) 430 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' , lwp)430 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' ) 431 431 IF(lwm) WRITE ( numond, namzdf_iwm ) 432 432 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ZDF/zdfosm.F90
r10425 r12065 1386 1386 REWIND( numnam_ref ) ! Namelist namzdf_osm in reference namelist : Osmosis ML model 1387 1387 READ ( numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901) 1388 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' , lwp)1388 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' ) 1389 1389 1390 1390 REWIND( numnam_cfg ) ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy 1391 1391 READ ( numnam_cfg, namzdf_osm, IOSTAT = ios, ERR = 902 ) 1392 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist' , lwp)1392 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist' ) 1393 1393 IF(lwm) WRITE ( numond, namzdf_osm ) 1394 1394 -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ZDF/zdfphy.F90
r10425 r12065 93 93 REWIND( numnam_ref ) ! Namelist namzdf in reference namelist : Vertical mixing parameters 94 94 READ ( numnam_ref, namzdf, IOSTAT = ios, ERR = 901) 95 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf in reference namelist' , lwp)95 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf in reference namelist' ) 96 96 ! 97 97 REWIND( numnam_cfg ) ! Namelist namzdf in reference namelist : Vertical mixing parameters 98 98 READ ( numnam_cfg, namzdf, IOSTAT = ios, ERR = 902 ) 99 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf in configuration namelist' , lwp)99 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf in configuration namelist' ) 100 100 IF(lwm) WRITE ( numond, namzdf ) 101 101 ! … … 132 132 IF( ln_zad_Aimp ) THEN 133 133 IF( zdf_phy_alloc() /= 0 ) & 134 & CALL ctl_stop( 'STOP', 'zdf_phy_init : unable to allocate adaptive-implicit z-advection arrays' ) 135 wi(:,:,:) = 0._wp 134 & CALL ctl_stop( 'STOP', 'zdf_phy_init : unable to allocate adaptive-implicit z-advection arrays' ) 135 Cu_adv(:,:,:) = 0._wp 136 wi (:,:,:) = 0._wp 136 137 ENDIF 137 138 ! !== Background eddy viscosity and diffusivity ==! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ZDF/zdfric.F90
r10068 r12065 80 80 REWIND( numnam_ref ) ! Namelist namzdf_ric in reference namelist : Vertical diffusion Kz depends on Richardson number 81 81 READ ( numnam_ref, namzdf_ric, IOSTAT = ios, ERR = 901) 82 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist' , lwp)82 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist' ) 83 83 84 84 REWIND( numnam_cfg ) ! Namelist namzdf_ric in configuration namelist : Vertical diffusion Kz depends on Richardson number 85 85 READ ( numnam_cfg, namzdf_ric, IOSTAT = ios, ERR = 902 ) 86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist' , lwp)86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist' ) 87 87 IF(lwm) WRITE ( numond, namzdf_ric ) 88 88 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/ZDF/zdftke.F90
r10425 r12065 658 658 REWIND( numnam_ref ) ! Namelist namzdf_tke in reference namelist : Turbulent Kinetic Energy 659 659 READ ( numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901) 660 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist' , lwp)660 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist' ) 661 661 662 662 REWIND( numnam_cfg ) ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy 663 663 READ ( numnam_cfg, namzdf_tke, IOSTAT = ios, ERR = 902 ) 664 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist' , lwp)664 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist' ) 665 665 IF(lwm) WRITE ( numond, namzdf_tke ) 666 666 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/module_example
r10425 r12065 152 152 REWIND( numnam_ref ) ! Namelist namexa in reference namelist : Example 153 153 READ ( numnam_ref, namexa, IOSTAT = ios, ERR = 901) 154 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist' , lwp)154 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist' ) 155 155 ! 156 156 REWIND( numnam_cfg ) ! Namelist namexa in configuration namelist : Example 157 157 READ ( numnam_cfg, namexa, IOSTAT = ios, ERR = 902 ) 158 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist' , lwp)158 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist' ) 159 159 ! Output namelist for control 160 160 WRITE ( numond, namexa ) -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/nemogcm.F90
r10772 r12065 59 59 USE diaobs ! Observation diagnostics (dia_obs_init routine) 60 60 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 61 USE diaharm ! tidal harmonics diagnostics (dia_harm_init routine) 61 62 USE step ! NEMO time-stepping (stp routine) 62 63 USE icbini ! handle bergs, initialisation … … 103 104 104 105 #if defined key_mpp_mpi 106 ! need MPI_Wtime 105 107 INCLUDE 'mpif.h' 106 108 #endif … … 128 130 !!---------------------------------------------------------------------- 129 131 INTEGER :: istp ! time step index 132 REAL(wp):: zstptiming ! elapsed time for 1 time step 130 133 !!---------------------------------------------------------------------- 131 134 ! … … 188 191 ! 189 192 DO WHILE( istp <= nitend .AND. nstop == 0 ) 190 #if defined key_mpp_mpi 193 191 194 ncom_stp = istp 192 IF ( istp == ( nit000 + 1 ) ) elapsed_time = MPI_Wtime() 193 IF ( istp == nitend ) elapsed_time = MPI_Wtime() - elapsed_time 194 #endif 195 IF( ln_timing ) THEN 196 zstptiming = MPI_Wtime() 197 IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming 198 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 199 ENDIF 200 195 201 CALL stp ( istp ) 196 202 istp = istp + 1 203 204 IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 205 197 206 END DO 198 207 ! … … 220 229 ! 221 230 IF( nstop /= 0 .AND. lwp ) THEN ! error print 222 WRITE(numout,cform_err) 223 WRITE(numout,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found' 224 WRITE(numout,*) 231 WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found' 232 CALL ctl_stop( ctmp1 ) 225 233 ENDIF 226 234 ! … … 234 242 #else 235 243 IF ( lk_oasis ) THEN ; CALL cpl_finalize ! end coupling and mpp communications with OASIS 236 ELSEIF( lk_mpp ) THEN ; CALL mppstop ( ldfinal = .TRUE. )! end mpp communications244 ELSEIF( lk_mpp ) THEN ; CALL mppstop ! end mpp communications 237 245 ENDIF 238 246 #endif … … 240 248 IF(lwm) THEN 241 249 IF( nstop == 0 ) THEN ; STOP 0 242 ELSE ; STOP 999250 ELSE ; STOP 123 243 251 ENDIF 244 252 ENDIF … … 253 261 !! ** Purpose : initialization of the NEMO GCM 254 262 !!---------------------------------------------------------------------- 255 INTEGER :: ji ! dummy loop indices 256 INTEGER :: ios, ilocal_comm ! local integers 257 CHARACTER(len=120), DIMENSION(60) :: cltxt, cltxt2, clnam 263 INTEGER :: ios, ilocal_comm ! local integers 258 264 !! 259 265 NAMELIST/namctl/ ln_ctl , sn_cfctl, nn_print, nn_ictls, nn_ictle, & … … 263 269 !!---------------------------------------------------------------------- 264 270 ! 265 cltxt = ''266 cltxt2 = ''267 clnam = ''268 271 cxios_context = 'nemo' 269 272 ! 270 ! ! Open reference namelist and configuration namelist files 271 CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 272 CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 273 ! 274 REWIND( numnam_ref ) ! Namelist namctl in reference namelist 275 READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 276 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. ) 277 REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist 278 READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 279 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. ) 280 ! 281 REWIND( numnam_ref ) ! Namelist namcfg in reference namelist 282 READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 283 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. ) 284 REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist 285 READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 286 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. ) 287 288 ! !--------------------------! 289 ! ! Set global domain size ! (control print return in cltxt2) 290 ! !--------------------------! 291 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 292 CALL domain_cfg ( cltxt2, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 293 ! 294 ELSE ! user-defined namelist 295 CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 296 ENDIF 297 ! 298 ! 299 ! !--------------------------------------------! 300 ! ! set communicator & select the local node ! 301 ! ! NB: mynode also opens output.namelist.dyn ! 302 ! ! on unit number numond on first proc ! 303 ! !--------------------------------------------! 273 ! !-------------------------------------------------! 274 ! ! set communicator & select the local rank ! 275 ! ! must be done as soon as possible to get narea ! 276 ! !-------------------------------------------------! 277 ! 304 278 #if defined key_iomput 305 279 IF( Agrif_Root() ) THEN 306 280 IF( lk_oasis ) THEN 307 281 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 308 CALL xios_initialize( "not used" , local_comm= ilocal_comm )! send nemo communicator to xios282 CALL xios_initialize( "not used" , local_comm =ilocal_comm ) ! send nemo communicator to xios 309 283 ELSE 310 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm )! nemo local communicator given by xios284 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios 311 285 ENDIF 312 286 ENDIF 313 ! Nodes selection (control print return in cltxt) 314 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 287 CALL mpp_start( ilocal_comm ) 315 288 #else 316 289 IF( lk_oasis ) THEN … … 318 291 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 319 292 ENDIF 320 ! Nodes selection (control print return in cltxt) 321 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 293 CALL mpp_start( ilocal_comm ) 322 294 ELSE 323 ilocal_comm = 0 ! Nodes selection (control print return in cltxt)324 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )325 ENDIF 326 #endif 327 328 narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )329 330 IF( sn_cfctl%l_config ) THEN331 ! Activate finer control of report outputs332 ! optionally switch off output from selected areas (note this only333 ! applies to output which does not involve global communications)334 IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &335 & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &336 & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )337 ELSE338 ! Use ln_ctl to turn on or off all options.339 CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. )340 ENDIF341 342 lwm = (narea == 1) ! control of output namelists343 lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print344 345 IF(lwm) THEN ! write merged namelists from earlier to output namelist346 ! ! now that the file has been opened in call to mynode.347 ! ! NB: nammpp has already been written in mynode (if lk_mpp_mpi)348 WRITE( numond, namctl)349 WRITE( numond, namcfg)350 IF( .NOT.ln_read_cfg ) THEN351 DO ji = 1, SIZE(clnam)352 IF( TRIM(clnam(ji)) /= '' ) WRITE(numond, * ) clnam(ji) ! namusr_def print 353 END DO354 ENDIF355 ENDIF356 357 IF(lwp) THEN ! open listing units358 !359 CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )295 CALL mpp_start( ) 296 ENDIF 297 #endif 298 ! 299 narea = mpprank + 1 ! mpprank: the rank of proc (0 --> mppsize -1 ) 300 lwm = (narea == 1) ! control of output namelists 301 ! 302 ! !---------------------------------------------------------------! 303 ! ! Open output files, reference and configuration namelist files ! 304 ! !---------------------------------------------------------------! 305 ! 306 ! open ocean.output as soon as possible to get all output prints (including errors messages) 307 IF( lwm ) CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 308 ! open reference and configuration namelist files 309 CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 310 CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 311 IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 312 ! open /dev/null file to be able to supress output write easily 313 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 314 ! 315 ! !--------------------! 316 ! ! Open listing units ! -> need ln_ctl from namctl to define lwp 317 ! !--------------------! 318 ! 319 REWIND( numnam_ref ) ! Namelist namctl in reference namelist 320 READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 321 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist' ) 322 REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist 323 READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 324 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist' ) 325 ! 326 lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print 327 ! 328 IF(lwp) THEN ! open listing units 329 ! 330 IF( .NOT. lwm ) & ! alreay opened for narea == 1 331 & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 360 332 ! 361 333 WRITE(numout,*) 362 WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV -CMCC'334 WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' 363 335 WRITE(numout,*) ' NEMO team' 364 336 WRITE(numout,*) ' Ocean General Circulation Model' … … 379 351 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 380 352 WRITE(numout,*) 381 382 DO ji = 1, SIZE(cltxt)383 IF( TRIM(cltxt (ji)) /= '' ) WRITE(numout,*) TRIM(cltxt(ji)) ! control print of mynode384 END DO385 WRITE(numout,*)386 WRITE(numout,*)387 DO ji = 1, SIZE(cltxt2)388 IF( TRIM(cltxt2(ji)) /= '' ) WRITE(numout,*) TRIM(cltxt2(ji)) ! control print of domain size389 END DO390 353 ! 391 354 WRITE(numout,cform_aaa) ! Flag AAAAAAA 392 355 ! 393 356 ENDIF 394 ! open /dev/null file to be able to supress output write easily 395 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 396 ! 397 ! ! Domain decomposition 398 CALL mpp_init ! MPP 357 ! 358 ! finalize the definition of namctl variables 359 IF( sn_cfctl%l_config ) THEN 360 ! Activate finer control of report outputs 361 ! optionally switch off output from selected areas (note this only 362 ! applies to output which does not involve global communications) 363 IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. & 364 & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) & 365 & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 366 ELSE 367 ! Use ln_ctl to turn on or off all options. 368 CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. ) 369 ENDIF 370 ! 371 IF(lwm) WRITE( numond, namctl ) 372 ! 373 ! !------------------------------------! 374 ! ! Set global domain size parameters ! 375 ! !------------------------------------! 376 ! 377 REWIND( numnam_ref ) ! Namelist namcfg in reference namelist 378 READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 379 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' ) 380 REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist 381 READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 382 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) 383 ! 384 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 385 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 386 ELSE ! user-defined namelist 387 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 388 ENDIF 389 ! 390 IF(lwm) WRITE( numond, namcfg ) 391 ! 392 ! !-----------------------------------------! 393 ! ! mpp parameters and domain decomposition ! 394 ! !-----------------------------------------! 395 CALL mpp_init 399 396 400 397 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays … … 480 477 481 478 ! ! Diagnostics 482 IF( lk_floats )CALL flo_init ! drifting Floats479 CALL flo_init ! drifting Floats 483 480 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 484 481 CALL dia_ptr_init ! Poleward TRansports initialization 485 IF( lk_diadct )CALL dia_dct_init ! Sections tranports482 CALL dia_dct_init ! Sections tranports 486 483 CALL dia_hsb_init ! heat content, salt content and volume budgets 487 484 CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends … … 489 486 CALL dia_tmb_init ! TMB outputs 490 487 CALL dia_25h_init ! 25h mean outputs 491 IF( ln_diaobs ) CALL dia_obs( nit000-1 ) ! Observation operator for restart 488 CALL dia_harm_init ! tidal harmonics outputs 489 IF( ln_diaobs ) CALL dia_obs( nit000-1 ) ! Observation operator for restart 492 490 493 491 ! ! Assimilation increments … … 507 505 !! ** Purpose : control print setting 508 506 !! 509 !! ** Method : - print namctl information and check some consistencies507 !! ** Method : - print namctl and namcfg information and check some consistencies 510 508 !!---------------------------------------------------------------------- 511 509 ! … … 650 648 USE trc_oce , ONLY : trc_oce_alloc 651 649 USE bdy_oce , ONLY : bdy_oce_alloc 652 #if defined key_diadct653 USE diadct , ONLY : diadct_alloc654 #endif655 650 ! 656 651 INTEGER :: ierr … … 664 659 ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization) 665 660 ! 666 #if defined key_diadct667 ierr = ierr + diadct_alloc () !668 #endif669 !670 661 CALL mpp_sum( 'nemogcm', ierr ) 671 662 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' ) … … 673 664 END SUBROUTINE nemo_alloc 674 665 666 675 667 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all ) 676 668 !!---------------------------------------------------------------------- -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/step.F90
r10852 r12065 112 112 IF( ln_tide ) CALL tide_update( kstp ) ! update tide potential 113 113 IF( ln_apr_dyn ) CALL sbc_apr ( kstp ) ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib) 114 IF( ln_bdy ) CALL bdy_dta ( kstp, time_offset=+1 ) ! update dynamic & tracer data at open boundaries114 IF( ln_bdy ) CALL bdy_dta ( kstp, kt_offset = +1 ) ! update dynamic & tracer data at open boundaries 115 115 CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) 116 116 … … 165 165 CALL eos ( tsn, rhd, rhop, gdept_n(:,:,:) ) ! now in situ density for hpg computation 166 166 167 !!jc: fs simplification168 !!jc: lines below are useless if ln_linssh=F. Keep them here (which maintains a bug if ln_linssh=T and ln_zps=T, cf ticket #1636)169 !! but ensures reproductible results170 !! with previous versions using split-explicit free surface171 IF( ln_zps .AND. .NOT. ln_isfcav ) &172 & CALL zps_hde ( kstp, jpts, tsn, gtsu, gtsv, & ! Partial steps: before horizontal gradient173 & rhd, gru , grv ) ! of t, s, rd at the last ocean level174 IF( ln_zps .AND. ln_isfcav ) &175 & CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF)176 & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level177 !!jc: fs simplification178 167 179 168 ua(:,:,:) = 0._wp ! set dynamics trends to zero … … 198 187 CALL div_hor ( kstp ) ! Horizontal divergence (2nd call in time-split case) 199 188 IF(.NOT.ln_linssh) CALL dom_vvl_sf_nxt( kstp, kcall=2 ) ! after vertical scale factors (update depth average component) 189 ENDIF 190 CALL dyn_zdf ( kstp ) ! vertical diffusion 191 192 IF( ln_dynspg_ts ) THEN 200 193 CALL wzv ( kstp ) ! now cross-level velocity 201 194 IF( ln_zad_Aimp ) CALL wAimp ( kstp ) ! Adaptive-implicit vertical advection partitioning 202 195 ENDIF 203 204 CALL dyn_zdf ( kstp ) ! vertical diffusion205 196 206 197 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 212 203 ! diagnostics and outputs 213 204 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 214 IF( l k_floats ) CALL flo_stp ( kstp ) ! drifting Floats205 IF( ln_floats ) CALL flo_stp ( kstp ) ! drifting Floats 215 206 IF( ln_diacfl ) CALL dia_cfl ( kstp ) ! Courant number diagnostics 216 207 IF( lk_diahth ) CALL dia_hth ( kstp ) ! Thermocline depth (20 degres isotherm depth) 217 IF( l k_diadct ) CALL dia_dct ( kstp ) ! Transports208 IF( ln_diadct ) CALL dia_dct ( kstp ) ! Transports 218 209 CALL dia_ar5 ( kstp ) ! ar5 diag 219 IF( l k_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis210 IF( ln_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis 220 211 CALL dia_wri ( kstp ) ! ocean model: outputs 221 212 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/stpctl.F90
r10570 r12065 96 96 IF( ln_zad_Aimp ) THEN 97 97 istatus = NF90_DEF_VAR( idrun, 'abs_wi_max', NF90_DOUBLE, (/ idtime /), idw1 ) 98 istatus = NF90_DEF_VAR( idrun, 'C u_max', NF90_DOUBLE, (/ idtime /), idc1 )98 istatus = NF90_DEF_VAR( idrun, 'Cf_max', NF90_DOUBLE, (/ idtime /), idc1 ) 99 99 ENDIF 100 100 istatus = NF90_ENDDEF(idrun) … … 123 123 IF( ln_zad_Aimp ) THEN 124 124 zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = wmask(:,:,:) == 1._wp ) ! implicit vertical vel. max 125 zmax(9) = MAXVAL( Cu_adv(:,:,:) , mask = tmask(:,:,:) == 1._wp ) ! cell Courant no. max125 zmax(9) = MAXVAL( Cu_adv(:,:,:) , mask = tmask(:,:,:) == 1._wp ) ! partitioning coeff. max 126 126 ENDIF 127 127 ! -
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/timing.F90
r10510 r12065 347 347 348 348 ! write output file 349 IF( lwriter ) WRITE(numtime,*) 350 IF( lwriter ) WRITE(numtime,*) 349 351 IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :' 350 352 IF( lwriter ) WRITE(numtime,*) '--------------------' … … 657 659 ! Compute cpu/elapsed ratio 658 660 zall_ratio(:) = all_ctime(:) / all_etime(:) 659 ztot_ratio = SUM( zall_ratio(:))660 zavg_ratio = ztot_ratio/REAL(jpnij,wp)661 ztot_ratio = SUM(all_ctime(:))/SUM(all_etime(:)) 662 zavg_ratio = SUM(zall_ratio(:))/REAL(jpnij,wp) 661 663 zmax_ratio = MAXVAL(zall_ratio(:)) 662 664 zmin_ratio = MINVAL(zall_ratio(:)) … … 667 669 cllignes(2)='1x,"--------------------",//,' 668 670 cllignes(3)='1x,"Process Rank |"," Elapsed Time (s) |"," CPU Time (s) |"," Ratio CPU/Elapsed",/,' 669 cllignes(4)=' (1x,i4,9x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),'670 WRITE(cllignes(4)(1: 4),'(I4)') jpnij671 cllignes(4)=' (4x,i6,4x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),' 672 WRITE(cllignes(4)(1:6),'(I6)') jpnij 671 673 cllignes(5)='1x,"Total |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' 672 674 cllignes(6)='1x,"Minimum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,'
Note: See TracChangeset
for help on using the changeset viewer.