- Timestamp:
- 2020-06-03T16:30:02+02:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r12973_AGRIF_CMEMS/src/NST/agrif_oce_interp.F90
r12377 r13026 34 34 USE lib_mpp 35 35 USE vremap 36 USE lbclnk 36 37 37 38 IMPLICIT NONE … … 44 45 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 45 46 PUBLIC interpe3t 46 #if defined key_vertical47 47 PUBLIC interpht0, interpmbkt 48 # endif 48 PUBLIC agrif_initts, agrif_initssh 49 49 50 INTEGER :: bdy_tinterp = 0 50 51 … … 89 90 Agrif_UseSpecialValue = ln_spc_dyn 90 91 ! 92 use_sign_north = .TRUE. 93 sign_north = -1. 91 94 CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) 92 95 CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) 96 use_sign_north = .FALSE. 93 97 ! 94 98 Agrif_UseSpecialValue = .FALSE. 95 99 ! 96 100 ! --- West --- ! 97 ibdy1 = 2 98 ibdy2 = 1+nbghostcells 99 ! 100 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 101 IF( lk_west ) THEN 102 ibdy1 = 2 103 ibdy2 = 1+nbghostcells 104 ! 105 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 106 DO ji = mi0(ibdy1), mi1(ibdy2) 107 uu_b(ji,:,Krhs_a) = 0._wp 108 109 DO jk = 1, jpkm1 110 DO jj = 1, jpj 111 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 112 END DO 113 END DO 114 115 DO jj = 1, jpj 116 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 117 END DO 118 END DO 119 ENDIF 120 ! 101 121 DO ji = mi0(ibdy1), mi1(ibdy2) 102 uu_b(ji,:,Krhs_a) = 0._wp 103 122 zub(ji,:) = 0._wp ! Correct transport 104 123 DO jk = 1, jpkm1 105 124 DO jj = 1, jpj 106 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 107 END DO 108 END DO 109 110 DO jj = 1, jpj 111 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 112 END DO 113 END DO 114 ENDIF 115 ! 116 DO ji = mi0(ibdy1), mi1(ibdy2) 117 zub(ji,:) = 0._wp ! Correct transport 118 DO jk = 1, jpkm1 119 DO jj = 1, jpj 120 zub(ji,jj) = zub(ji,jj) & 121 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a)*umask(ji,jj,jk) 122 END DO 123 END DO 124 DO jj=1,jpj 125 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 126 END DO 127 128 DO jk = 1, jpkm1 129 DO jj = 1, jpj 130 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a)-zub(ji,jj)) * umask(ji,jj,jk) 131 END DO 132 END DO 133 END DO 134 135 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 136 DO ji = mi0(ibdy1), mi1(ibdy2) 137 zvb(ji,:) = 0._wp 125 zub(ji,jj) = zub(ji,jj) & 126 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a)*umask(ji,jj,jk) 127 END DO 128 END DO 129 DO jj=1,jpj 130 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 131 END DO 132 138 133 DO jk = 1, jpkm1 139 134 DO jj = 1, jpj 140 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 141 END DO 142 END DO 143 DO jj = 1, jpj 144 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 145 END DO 135 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a)-zub(ji,jj)) * umask(ji,jj,jk) 136 END DO 137 END DO 138 END DO 139 140 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 141 DO ji = mi0(ibdy1), mi1(ibdy2) 142 zvb(ji,:) = 0._wp 143 DO jk = 1, jpkm1 144 DO jj = 1, jpj 145 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 146 END DO 147 END DO 148 DO jj = 1, jpj 149 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 150 END DO 151 DO jk = 1, jpkm1 152 DO jj = 1, jpj 153 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a)-zvb(ji,jj))*vmask(ji,jj,jk) 154 END DO 155 END DO 156 END DO 157 ENDIF 158 ENDIF 159 160 ! --- East --- ! 161 IF( lk_east) THEN 162 ibdy1 = jpiglo-1-nbghostcells 163 ibdy2 = jpiglo-2 164 ! 165 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 166 DO ji = mi0(ibdy1), mi1(ibdy2) 167 uu_b(ji,:,Krhs_a) = 0._wp 168 DO jk = 1, jpkm1 169 DO jj = 1, jpj 170 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) & 171 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 172 END DO 173 END DO 174 DO jj = 1, jpj 175 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 176 END DO 177 END DO 178 ENDIF 179 ! 180 DO ji = mi0(ibdy1), mi1(ibdy2) 181 zub(ji,:) = 0._wp ! Correct transport 146 182 DO jk = 1, jpkm1 147 183 DO jj = 1, jpj 148 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a)-zvb(ji,jj))*vmask(ji,jj,jk) 149 END DO 150 END DO 151 END DO 152 ENDIF 153 154 ! --- East --- ! 155 ibdy1 = jpiglo-1-nbghostcells 156 ibdy2 = jpiglo-2 157 ! 158 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 159 DO ji = mi0(ibdy1), mi1(ibdy2) 160 uu_b(ji,:,Krhs_a) = 0._wp 184 zub(ji,jj) = zub(ji,jj) & 185 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 186 END DO 187 END DO 188 DO jj=1,jpj 189 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 190 END DO 191 161 192 DO jk = 1, jpkm1 162 193 DO jj = 1, jpj 163 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) & 164 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 165 END DO 166 END DO 167 DO jj = 1, jpj 168 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 169 END DO 170 END DO 171 ENDIF 172 ! 173 DO ji = mi0(ibdy1), mi1(ibdy2) 174 zub(ji,:) = 0._wp ! Correct transport 175 DO jk = 1, jpkm1 176 DO jj = 1, jpj 177 zub(ji,jj) = zub(ji,jj) & 178 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 179 END DO 180 END DO 181 DO jj=1,jpj 182 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 183 END DO 184 185 DO jk = 1, jpkm1 186 DO jj = 1, jpj 187 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 188 & + uu_b(ji,jj,Krhs_a)-zub(ji,jj))*umask(ji,jj,jk) 189 END DO 190 END DO 191 END DO 192 193 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 194 ibdy1 = jpiglo-nbghostcells 195 ibdy2 = jpiglo-1 196 DO ji = mi0(ibdy1), mi1(ibdy2) 197 zvb(ji,:) = 0._wp 198 DO jk = 1, jpkm1 194 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 195 & + uu_b(ji,jj,Krhs_a)-zub(ji,jj))*umask(ji,jj,jk) 196 END DO 197 END DO 198 END DO 199 200 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 201 ibdy1 = jpiglo-nbghostcells 202 ibdy2 = jpiglo-1 203 DO ji = mi0(ibdy1), mi1(ibdy2) 204 zvb(ji,:) = 0._wp 205 DO jk = 1, jpkm1 206 DO jj = 1, jpj 207 zvb(ji,jj) = zvb(ji,jj) & 208 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 209 END DO 210 END DO 199 211 DO jj = 1, jpj 200 zvb(ji,jj) = zvb(ji,jj) & 212 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 213 END DO 214 DO jk = 1, jpkm1 215 DO jj = 1, jpj 216 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 217 & + vv_b(ji,jj,Krhs_a)-zvb(ji,jj)) * vmask(ji,jj,jk) 218 END DO 219 END DO 220 END DO 221 ENDIF 222 ENDIF 223 224 ! --- South --- ! 225 IF( lk_south ) THEN 226 jbdy1 = 2 227 jbdy2 = 1+nbghostcells 228 ! 229 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 230 DO jj = mj0(jbdy1), mj1(jbdy2) 231 vv_b(:,jj,Krhs_a) = 0._wp 232 DO jk = 1, jpkm1 233 DO ji = 1, jpi 234 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 235 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 236 END DO 237 END DO 238 DO ji=1,jpi 239 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 240 END DO 241 END DO 242 ENDIF 243 ! 244 DO jj = mj0(jbdy1), mj1(jbdy2) 245 zvb(:,jj) = 0._wp ! Correct transport 246 DO jk=1,jpkm1 247 DO ji=1,jpi 248 zvb(ji,jj) = zvb(ji,jj) & 201 249 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 202 250 END DO 203 251 END DO 204 DO j j = 1, jpj252 DO ji = 1, jpi 205 253 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 206 254 END DO 207 DO jk = 1, jpkm1 208 DO jj = 1, jpj 209 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 210 & + vv_b(ji,jj,Krhs_a)-zvb(ji,jj)) * vmask(ji,jj,jk) 211 END DO 212 END DO 213 END DO 214 ENDIF 215 216 ! --- South --- ! 217 jbdy1 = 2 218 jbdy2 = 1+nbghostcells 219 ! 220 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 221 DO jj = mj0(jbdy1), mj1(jbdy2) 222 vv_b(:,jj,Krhs_a) = 0._wp 255 223 256 DO jk = 1, jpkm1 224 257 DO ji = 1, jpi 225 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 226 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 227 END DO 228 END DO 229 DO ji=1,jpi 230 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 231 END DO 232 END DO 233 ENDIF 234 ! 235 DO jj = mj0(jbdy1), mj1(jbdy2) 236 zvb(:,jj) = 0._wp ! Correct transport 237 DO jk=1,jpkm1 238 DO ji=1,jpi 239 zvb(ji,jj) = zvb(ji,jj) & 240 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 241 END DO 242 END DO 243 DO ji = 1, jpi 244 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 245 END DO 246 247 DO jk = 1, jpkm1 258 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 259 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 260 END DO 261 END DO 262 END DO 263 264 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 265 DO jj = mj0(jbdy1), mj1(jbdy2) 266 zub(:,jj) = 0._wp 267 DO jk = 1, jpkm1 268 DO ji = 1, jpi 269 zub(ji,jj) = zub(ji,jj) & 270 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 271 END DO 272 END DO 273 DO ji = 1, jpi 274 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 275 END DO 276 277 DO jk = 1, jpkm1 278 DO ji = 1, jpi 279 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 280 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 281 END DO 282 END DO 283 END DO 284 ENDIF 285 ENDIF 286 287 ! --- North --- ! 288 IF( lk_north ) THEN 289 jbdy1 = jpjglo-1-nbghostcells 290 jbdy2 = jpjglo-2 291 ! 292 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 293 DO jj = mj0(jbdy1), mj1(jbdy2) 294 vv_b(:,jj,Krhs_a) = 0._wp 295 DO jk = 1, jpkm1 296 DO ji = 1, jpi 297 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 298 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 299 END DO 300 END DO 301 DO ji=1,jpi 302 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 303 END DO 304 END DO 305 ENDIF 306 ! 307 DO jj = mj0(jbdy1), mj1(jbdy2) 308 zvb(:,jj) = 0._wp ! Correct transport 309 DO jk=1,jpkm1 310 DO ji=1,jpi 311 zvb(ji,jj) = zvb(ji,jj) & 312 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 313 END DO 314 END DO 248 315 DO ji = 1, jpi 249 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 250 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 251 END DO 252 END DO 253 END DO 254 255 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 256 DO jj = mj0(jbdy1), mj1(jbdy2) 257 zub(:,jj) = 0._wp 316 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 317 END DO 318 258 319 DO jk = 1, jpkm1 259 320 DO ji = 1, jpi 260 zub(ji,jj) = zub(ji,jj) & 261 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 262 END DO 263 END DO 264 DO ji = 1, jpi 265 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 266 END DO 321 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 322 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 323 END DO 324 END DO 325 END DO 267 326 268 DO jk = 1, jpkm1 327 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 328 jbdy1 = jpjglo-nbghostcells 329 jbdy2 = jpjglo-1 330 DO jj = mj0(jbdy1), mj1(jbdy2) 331 zub(:,jj) = 0._wp 332 DO jk = 1, jpkm1 333 DO ji = 1, jpi 334 zub(ji,jj) = zub(ji,jj) & 335 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 336 END DO 337 END DO 269 338 DO ji = 1, jpi 270 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 271 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 272 END DO 273 END DO 274 END DO 275 ENDIF 276 277 ! --- North --- ! 278 jbdy1 = jpjglo-1-nbghostcells 279 jbdy2 = jpjglo-2 280 ! 281 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 282 DO jj = mj0(jbdy1), mj1(jbdy2) 283 vv_b(:,jj,Krhs_a) = 0._wp 284 DO jk = 1, jpkm1 285 DO ji = 1, jpi 286 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 287 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 288 END DO 289 END DO 290 DO ji=1,jpi 291 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 292 END DO 293 END DO 294 ENDIF 295 ! 296 DO jj = mj0(jbdy1), mj1(jbdy2) 297 zvb(:,jj) = 0._wp ! Correct transport 298 DO jk=1,jpkm1 299 DO ji=1,jpi 300 zvb(ji,jj) = zvb(ji,jj) & 301 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 302 END DO 303 END DO 304 DO ji = 1, jpi 305 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 306 END DO 307 308 DO jk = 1, jpkm1 309 DO ji = 1, jpi 310 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 311 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 312 END DO 313 END DO 314 END DO 315 316 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 317 jbdy1 = jpjglo-nbghostcells 318 jbdy2 = jpjglo-1 319 DO jj = mj0(jbdy1), mj1(jbdy2) 320 zub(:,jj) = 0._wp 321 DO jk = 1, jpkm1 322 DO ji = 1, jpi 323 zub(ji,jj) = zub(ji,jj) & 324 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 325 END DO 326 END DO 327 DO ji = 1, jpi 328 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 329 END DO 330 331 DO jk = 1, jpkm1 332 DO ji = 1, jpi 333 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 334 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 335 END DO 336 END DO 337 END DO 339 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 340 END DO 341 342 DO jk = 1, jpkm1 343 DO ji = 1, jpi 344 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 345 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 346 END DO 347 END DO 348 END DO 349 ENDIF 338 350 ENDIF 339 351 ! … … 354 366 ! 355 367 !--- West ---! 356 istart = 2 357 iend = nbghostcells+1 358 DO ji = mi0(istart), mi1(iend) 359 DO jj=1,jpj 360 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 361 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 362 END DO 363 END DO 368 IF( lk_west ) THEN 369 istart = 2 370 iend = nbghostcells+1 371 DO ji = mi0(istart), mi1(iend) 372 DO jj=1,jpj 373 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 374 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 375 END DO 376 END DO 377 ENDIF 364 378 ! 365 379 !--- East ---! 366 istart = jpiglo-nbghostcells 367 iend = jpiglo-1 368 DO ji = mi0(istart), mi1(iend) 369 DO jj=1,jpj 370 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 371 END DO 372 END DO 373 istart = jpiglo-nbghostcells-1 374 iend = jpiglo-2 375 DO ji = mi0(istart), mi1(iend) 376 DO jj=1,jpj 377 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 378 END DO 379 END DO 380 IF( lk_east ) THEN 381 istart = jpiglo-nbghostcells 382 iend = jpiglo-1 383 DO ji = mi0(istart), mi1(iend) 384 385 DO jj=1,jpj 386 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 387 END DO 388 END DO 389 istart = jpiglo-nbghostcells-1 390 iend = jpiglo-2 391 DO ji = mi0(istart), mi1(iend) 392 DO jj=1,jpj 393 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 394 END DO 395 END DO 396 ENDIF 380 397 ! 381 398 !--- South ---! 382 jstart = 2 383 jend = nbghostcells+1 384 DO jj = mj0(jstart), mj1(jend) 385 DO ji=1,jpi 386 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 387 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 388 END DO 389 END DO 399 IF( lk_south ) THEN 400 jstart = 2 401 jend = nbghostcells+1 402 DO jj = mj0(jstart), mj1(jend) 403 404 DO ji=1,jpi 405 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 406 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 407 END DO 408 END DO 409 ENDIF 390 410 ! 391 411 !--- North ---! 392 jstart = jpjglo-nbghostcells 393 jend = jpjglo-1 394 DO jj = mj0(jstart), mj1(jend) 395 DO ji=1,jpi 396 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 397 END DO 398 END DO 399 jstart = jpjglo-nbghostcells-1 400 jend = jpjglo-2 401 DO jj = mj0(jstart), mj1(jend) 402 DO ji=1,jpi 403 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 404 END DO 405 END DO 412 IF( lk_north ) THEN 413 jstart = jpjglo-nbghostcells 414 jend = jpjglo-1 415 DO jj = mj0(jstart), mj1(jend) 416 DO ji=1,jpi 417 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 418 END DO 419 END DO 420 jstart = jpjglo-nbghostcells-1 421 jend = jpjglo-2 422 DO jj = mj0(jstart), mj1(jend) 423 DO ji=1,jpi 424 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 425 END DO 426 END DO 427 ENDIF 406 428 ! 407 429 END SUBROUTINE Agrif_dyn_ts … … 421 443 ! 422 444 !--- West ---! 423 istart = 2 424 iend = nbghostcells+1 425 DO ji = mi0(istart), mi1(iend) 426 DO jj=1,jpj 427 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 428 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 429 END DO 430 END DO 445 IF( lk_west ) THEN 446 istart = 2 447 iend = nbghostcells+1 448 DO ji = mi0(istart), mi1(iend) 449 DO jj=1,jpj 450 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 451 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 452 END DO 453 END DO 454 ENDIF 431 455 ! 432 456 !--- East ---! 433 istart = jpiglo-nbghostcells 434 iend = jpiglo-1 435 DO ji = mi0(istart), mi1(iend) 436 DO jj=1,jpj 437 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 438 END DO 439 END DO 440 istart = jpiglo-nbghostcells-1 441 iend = jpiglo-2 442 DO ji = mi0(istart), mi1(iend) 443 DO jj=1,jpj 444 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 445 END DO 446 END DO 457 IF( lk_east ) THEN 458 istart = jpiglo-nbghostcells 459 iend = jpiglo-1 460 DO ji = mi0(istart), mi1(iend) 461 DO jj=1,jpj 462 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 463 END DO 464 END DO 465 istart = jpiglo-nbghostcells-1 466 iend = jpiglo-2 467 DO ji = mi0(istart), mi1(iend) 468 DO jj=1,jpj 469 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 470 END DO 471 END DO 472 ENDIF 447 473 ! 448 474 !--- South ---! 449 jstart = 2 450 jend = nbghostcells+1 451 DO jj = mj0(jstart), mj1(jend) 452 DO ji=1,jpi 453 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 454 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 455 END DO 456 END DO 475 IF( lk_south ) THEN 476 jstart = 2 477 jend = nbghostcells+1 478 DO jj = mj0(jstart), mj1(jend) 479 DO ji=1,jpi 480 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 481 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 482 END DO 483 END DO 484 ENDIF 457 485 ! 458 486 !--- North ---! 459 jstart = jpjglo-nbghostcells 460 jend = jpjglo-1 461 DO jj = mj0(jstart), mj1(jend) 462 DO ji=1,jpi 463 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 464 END DO 465 END DO 466 jstart = jpjglo-nbghostcells-1 467 jend = jpjglo-2 468 DO jj = mj0(jstart), mj1(jend) 469 DO ji=1,jpi 470 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 471 END DO 472 END DO 487 IF( lk_north ) THEN 488 jstart = jpjglo-nbghostcells 489 jend = jpjglo-1 490 DO jj = mj0(jstart), mj1(jend) 491 DO ji=1,jpi 492 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 493 END DO 494 END DO 495 jstart = jpjglo-nbghostcells-1 496 jend = jpjglo-2 497 DO jj = mj0(jstart), mj1(jend) 498 DO ji=1,jpi 499 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 500 END DO 501 END DO 502 ENDIF 473 503 ! 474 504 END SUBROUTINE Agrif_dyn_ts_flux … … 494 524 Agrif_SpecialValue = 0._wp 495 525 Agrif_UseSpecialValue = ln_spc_dyn 526 527 use_sign_north = .TRUE. 528 sign_north = -1. 529 496 530 ! 497 531 ! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners) … … 518 552 ENDIF 519 553 Agrif_UseSpecialValue = .FALSE. 554 use_sign_north = .FALSE. 520 555 ! 521 556 END SUBROUTINE Agrif_dta_ts … … 542 577 ! 543 578 ! --- West --- ! 544 istart = 2 545 iend = 1 + nbghostcells 546 DO ji = mi0(istart), mi1(iend) 547 DO jj = 1, jpj 548 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 579 IF(lk_west) THEN 580 istart = 2 581 iend = 1 + nbghostcells 582 DO ji = mi0(istart), mi1(iend) 583 DO jj = 1, jpj 584 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 585 ENDDO 549 586 ENDDO 550 END DO587 ENDIF 551 588 ! 552 589 ! --- East --- ! 553 istart = jpiglo - nbghostcells 554 iend = jpiglo - 1 555 DO ji = mi0(istart), mi1(iend) 556 DO jj = 1, jpj 557 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 590 IF(lk_east) THEN 591 istart = jpiglo - nbghostcells 592 iend = jpiglo - 1 593 DO ji = mi0(istart), mi1(iend) 594 DO jj = 1, jpj 595 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 596 ENDDO 558 597 ENDDO 559 END DO598 ENDIF 560 599 ! 561 600 ! --- South --- ! 562 jstart = 2 563 jend = 1 + nbghostcells 564 DO jj = mj0(jstart), mj1(jend) 565 DO ji = 1, jpi 566 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 601 IF(lk_south) THEN 602 jstart = 2 603 jend = 1 + nbghostcells 604 DO jj = mj0(jstart), mj1(jend) 605 DO ji = 1, jpi 606 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 607 ENDDO 567 608 ENDDO 568 END DO609 ENDIF 569 610 ! 570 611 ! --- North --- ! 571 jstart = jpjglo - nbghostcells 572 jend = jpjglo - 1 573 DO jj = mj0(jstart), mj1(jend) 574 DO ji = 1, jpi 575 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 612 IF(lk_north) THEN 613 jstart = jpjglo - nbghostcells 614 jend = jpjglo - 1 615 DO jj = mj0(jstart), mj1(jend) 616 DO ji = 1, jpi 617 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 618 ENDDO 576 619 ENDDO 577 END DO620 ENDIF 578 621 ! 579 622 END SUBROUTINE Agrif_ssh … … 593 636 ! 594 637 ! --- West --- ! 595 istart = 2 596 iend = 1+nbghostcells 597 DO ji = mi0(istart), mi1(iend) 598 DO jj = 1, jpj 599 ssha_e(ji,jj) = hbdy(ji,jj) 638 IF(lk_west) THEN 639 istart = 2 640 iend = 1+nbghostcells 641 DO ji = mi0(istart), mi1(iend) 642 DO jj = 1, jpj 643 ssha_e(ji,jj) = hbdy(ji,jj) 644 ENDDO 600 645 ENDDO 601 END DO646 ENDIF 602 647 ! 603 648 ! --- East --- ! 604 istart = jpiglo - nbghostcells 605 iend = jpiglo - 1 606 DO ji = mi0(istart), mi1(iend) 607 DO jj = 1, jpj 608 ssha_e(ji,jj) = hbdy(ji,jj) 649 IF(lk_east) THEN 650 istart = jpiglo - nbghostcells 651 iend = jpiglo - 1 652 DO ji = mi0(istart), mi1(iend) 653 DO jj = 1, jpj 654 ssha_e(ji,jj) = hbdy(ji,jj) 655 ENDDO 609 656 ENDDO 610 END DO657 ENDIF 611 658 ! 612 659 ! --- South --- ! 613 jstart = 2 614 jend = 1+nbghostcells 615 DO jj = mj0(jstart), mj1(jend) 616 DO ji = 1, jpi 617 ssha_e(ji,jj) = hbdy(ji,jj) 660 IF(lk_south) THEN 661 jstart = 2 662 jend = 1+nbghostcells 663 DO jj = mj0(jstart), mj1(jend) 664 DO ji = 1, jpi 665 ssha_e(ji,jj) = hbdy(ji,jj) 666 ENDDO 618 667 ENDDO 619 END DO668 ENDIF 620 669 ! 621 670 ! --- North --- ! 622 jstart = jpjglo - nbghostcells 623 jend = jpjglo - 1 624 DO jj = mj0(jstart), mj1(jend) 625 DO ji = 1, jpi 626 ssha_e(ji,jj) = hbdy(ji,jj) 671 IF(lk_north) THEN 672 jstart = jpjglo - nbghostcells 673 jend = jpjglo - 1 674 DO jj = mj0(jstart), mj1(jend) 675 DO ji = 1, jpi 676 ssha_e(ji,jj) = hbdy(ji,jj) 677 ENDDO 627 678 ENDDO 628 END DO679 ENDIF 629 680 ! 630 681 END SUBROUTINE Agrif_ssh_ts … … 662 713 INTEGER :: ji, jj, jk, jn ! dummy loop indices 663 714 INTEGER :: N_in, N_out 715 INTEGER :: item 664 716 ! vertical interpolation: 665 717 REAL(wp) :: zhtot … … 669 721 !!---------------------------------------------------------------------- 670 722 671 IF( before ) THEN 723 IF( before ) THEN 724 725 item = Kmm_a 726 IF( l_ini_child ) Kmm_a = Kbb_a 727 672 728 DO jn = 1,jpts 673 729 DO jk=k1,k2 … … 678 734 END DO 679 735 END DO 680 END DO 681 682 # if defined key_vertical 683 ! Interpolate thicknesses 684 ! Warning: these are masked, hence extrapolated prior interpolation. 685 DO jk=k1,k2 686 DO jj=j1,j2 687 DO ji=i1,i2 688 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 689 END DO 690 END DO 691 END DO 692 693 ! Extrapolate thicknesses in partial bottom cells: 694 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 695 IF (ln_zps) THEN 696 DO jj=j1,j2 697 DO ji=i1,i2 698 jk = mbkt(ji,jj) 699 ptab(ji,jj,jk,jpts+1) = 0._wp 700 END DO 701 END DO 702 END IF 703 704 ! Save ssh at last level: 705 IF (.NOT.ln_linssh) THEN 706 ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 707 ELSE 708 ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp 709 END IF 710 # endif 736 END DO 737 738 IF( l_vremap .OR. l_ini_child) THEN 739 ! Interpolate thicknesses 740 ! Warning: these are masked, hence extrapolated prior interpolation. 741 DO jk=k1,k2 742 DO jj=j1,j2 743 DO ji=i1,i2 744 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 745 746 END DO 747 END DO 748 END DO 749 750 ! Extrapolate thicknesses in partial bottom cells: 751 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 752 IF (ln_zps) THEN 753 DO jj=j1,j2 754 DO ji=i1,i2 755 jk = mbkt(ji,jj) 756 ptab(ji,jj,jk,jpts+1) = 0._wp 757 END DO 758 END DO 759 END IF 760 761 ! Save ssh at last level: 762 IF (.NOT.ln_linssh) THEN 763 ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 764 ELSE 765 ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp 766 END IF 767 ENDIF 768 Kmm_a = item 769 711 770 ELSE 712 713 # if defined key_vertical 714 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 715 716 DO jj=j1,j2 717 DO ji=i1,i2 718 ts(ji,jj,:,:,Krhs_a) = 0._wp 719 N_in = mbkt_parent(ji,jj) 720 zhtot = 0._wp 721 DO jk=1,N_in !k2 = jpk of parent grid 722 IF (jk==N_in) THEN 723 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 724 ELSE 725 h_in(jk) = ptab(ji,jj,jk,n2) 771 item = Krhs_a 772 IF( l_ini_child ) Krhs_a = Kbb_a 773 774 IF( l_vremap .OR. l_ini_child ) THEN 775 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 776 777 DO jj=j1,j2 778 DO ji=i1,i2 779 ts(ji,jj,:,:,Krhs_a) = 0. 780 ! IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts) 781 N_in = mbkt_parent(ji,jj) 782 zhtot = 0._wp 783 DO jk=1,N_in !k2 = jpk of parent grid 784 IF (jk==N_in) THEN 785 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 786 ELSE 787 h_in(jk) = ptab(ji,jj,jk,n2) 788 ENDIF 789 zhtot = zhtot + h_in(jk) 790 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 791 END DO 792 N_out = 0 793 DO jk=1,jpk ! jpk of child grid 794 IF (tmask(ji,jj,jk) == 0._wp) EXIT 795 N_out = N_out + 1 796 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 797 ENDDO 798 IF (N_in*N_out > 0) THEN 799 IF( l_ini_child ) THEN 800 CALL remap_linear(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 801 & h_out(1:N_out),N_in,N_out,jpts) 802 ELSE 803 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 804 & h_out(1:N_out),N_in,N_out,jpts) 805 ENDIF 726 806 ENDIF 727 zhtot = zhtot + h_in(jk)728 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)729 END DO730 N_out = 0731 DO jk=1,jpk ! jpk of child grid732 IF (tmask(ji,jj,jk) == 0._wp) EXIT733 N_out = N_out + 1734 h_out(jk) = e3t(ji,jj,jk,Krhs_a)735 807 ENDDO 736 IF (N_in*N_out > 0) THEN737 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),h_out(1:N_out),N_in,N_out,jpts)738 ENDIF739 808 ENDDO 740 ENDDO 741 # else 742 ! 743 DO jn=1, jpts 744 ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 745 END DO 746 # endif 809 Krhs_a = item 810 811 ELSE 812 813 DO jn=1, jpts 814 ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 815 END DO 816 ENDIF 747 817 748 818 ENDIF … … 782 852 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 783 853 REAL(wp), DIMENSION(1:jpk) :: h_out 784 INTEGER :: N_in, N_out 854 INTEGER :: N_in, N_out,item 785 855 REAL(wp) :: h_diff 786 856 !!--------------------------------------------- 787 857 ! 788 858 IF (before) THEN 859 860 item = Kmm_a 861 IF( l_ini_child ) Kmm_a = Kbb_a 862 789 863 DO jk=1,jpk 790 864 DO jj=j1,j2 791 865 DO ji=i1,i2 792 866 ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk)) 793 # if defined key_vertical 794 ! Interpolate thicknesses (masked for subsequent extrapolation) 795 ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 796 # endif 797 END DO 798 END DO 799 END DO 800 # if defined key_vertical 867 IF( l_vremap .OR. l_ini_child) THEN 868 ! Interpolate thicknesses (masked for subsequent extrapolation) 869 ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 870 ENDIF 871 END DO 872 END DO 873 END DO 874 875 IF( l_vremap .OR. l_ini_child) THEN 801 876 ! Extrapolate thicknesses in partial bottom cells: 802 877 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 803 IF (ln_zps) THEN 804 DO jj=j1,j2 805 DO ji=i1,i2 806 jk = mbku(ji,jj) 807 ptab(ji,jj,jk,2) = 0._wp 808 END DO 809 END DO 810 END IF 811 ! Save ssh at last level: 812 ptab(i1:i2,j1:j2,k2,2) = 0._wp 813 IF (.NOT.ln_linssh) THEN 814 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 815 DO jk=1,jpk 816 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk) 817 END DO 818 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2) 819 END IF 820 # endif 878 IF (ln_zps) THEN 879 DO jj=j1,j2 880 DO ji=i1,i2 881 jk = mbku(ji,jj) 882 ptab(ji,jj,jk,2) = 0._wp 883 END DO 884 END DO 885 END IF 886 887 ! Save ssh at last level: 888 ptab(i1:i2,j1:j2,k2,2) = 0._wp 889 IF (.NOT.ln_linssh) THEN 890 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 891 DO jk=1,jpk 892 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk) 893 END DO 894 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2) 895 END IF 896 ENDIF 897 898 Kmm_a = item 821 899 ! 822 900 ELSE 823 901 zrhoy = Agrif_rhoy() 824 # if defined key_vertical 902 903 IF( l_vremap .OR. l_ini_child) THEN 825 904 ! VERTICAL REFINEMENT BEGIN 826 905 827 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 828 829 DO ji=i1,i2 830 DO jj=j1,j2 831 uu(ji,jj,:,Krhs_a) = 0._wp 832 N_in = mbku_parent(ji,jj) 833 zhtot = 0._wp 834 DO jk=1,N_in 835 IF (jk==N_in) THEN 836 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 837 ELSE 838 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 839 ENDIF 840 zhtot = zhtot + h_in(jk) 841 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 842 ENDDO 843 844 N_out = 0 845 DO jk=1,jpk 846 if (umask(ji,jj,jk) == 0) EXIT 847 N_out = N_out + 1 848 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 849 ENDDO 850 IF (N_in*N_out > 0) THEN 851 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 852 ENDIF 906 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 907 908 DO ji=i1,i2 909 DO jj=j1,j2 910 uu(ji,jj,:,Krhs_a) = 0._wp 911 N_in = mbku_parent(ji,jj) 912 zhtot = 0._wp 913 DO jk=1,N_in 914 IF (jk==N_in) THEN 915 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 916 ELSE 917 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 918 ENDIF 919 zhtot = zhtot + h_in(jk) 920 IF( h_in(jk) .GT. 0. ) THEN 921 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 922 ELSE 923 tabin(jk) = 0. 924 ENDIF 925 ENDDO 926 927 N_out = 0 928 DO jk=1,jpk 929 IF (umask(ji,jj,jk) == 0) EXIT 930 N_out = N_out + 1 931 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 932 ENDDO 933 IF (N_in*N_out > 0) THEN 934 IF( l_ini_child ) THEN 935 CALL remap_linear (tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 936 ELSE 937 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 938 ENDIF 939 ENDIF 940 ENDDO 853 941 ENDDO 854 ENDDO 855 856 # else 857 DO jk = 1, jpkm1 858 DO jj=j1,j2 859 uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) ) 860 END DO 861 END DO 862 # endif 942 ELSE 943 DO jk = 1, jpkm1 944 DO jj=j1,j2 945 uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) ) 946 END DO 947 END DO 948 ENDIF 863 949 864 950 ENDIF … … 880 966 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 881 967 REAL(wp), DIMENSION(1:jpk) :: h_out 882 INTEGER :: N_in, N_out 968 INTEGER :: N_in, N_out, item 883 969 REAL(wp) :: h_diff, zhtot 884 970 !!--------------------------------------------- 885 971 ! 886 IF (before) THEN 972 IF (before) THEN 973 974 item = Kmm_a 975 IF( l_ini_child ) Kmm_a = Kbb_a 976 887 977 DO jk=k1,k2 888 978 DO jj=j1,j2 889 979 DO ji=i1,i2 890 980 ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk)) 891 # if defined key_vertical 892 ! Interpolate thicknesses (masked for subsequent extrapolation) 893 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 894 # endif 895 END DO 896 END DO 897 END DO 898 # if defined key_vertical 981 IF( l_vremap .OR. l_ini_child) THEN 982 ! Interpolate thicknesses (masked for subsequent extrapolation) 983 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 984 ENDIF 985 END DO 986 END DO 987 END DO 988 989 IF( l_vremap .OR. l_ini_child) THEN 899 990 ! Extrapolate thicknesses in partial bottom cells: 900 991 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 901 IF (ln_zps) THEN 992 IF (ln_zps) THEN 993 DO jj=j1,j2 994 DO ji=i1,i2 995 jk = mbkv(ji,jj) 996 ptab(ji,jj,jk,2) = 0._wp 997 END DO 998 END DO 999 END IF 1000 ! Save ssh at last level: 1001 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1002 IF (.NOT.ln_linssh) THEN 1003 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 1004 DO jk=1,jpk 1005 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk) 1006 END DO 1007 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2) 1008 END IF 1009 ENDIF 1010 item = Kmm_a 1011 1012 ELSE 1013 zrhox = Agrif_rhox() 1014 1015 IF( l_vremap .OR. l_ini_child ) THEN 1016 1017 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1018 902 1019 DO jj=j1,j2 903 1020 DO ji=i1,i2 904 jk = mbkv(ji,jj) 905 ptab(ji,jj,jk,2) = 0._wp 906 END DO 907 END DO 908 END IF 909 ! Save ssh at last level: 910 ptab(i1:i2,j1:j2,k2,2) = 0._wp 911 IF (.NOT.ln_linssh) THEN 912 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 913 DO jk=1,jpk 914 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk) 915 END DO 916 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2) 917 END IF 918 # endif 919 ELSE 920 zrhox = Agrif_rhox() 921 # if defined key_vertical 922 923 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 924 925 DO jj=j1,j2 926 DO ji=i1,i2 927 vv(ji,jj,:,Krhs_a) = 0._wp 928 N_in = mbkv_parent(ji,jj) 929 zhtot = 0._wp 930 DO jk=1,N_in 931 IF (jk==N_in) THEN 932 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 933 ELSE 934 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1021 vv(ji,jj,:,Krhs_a) = 0._wp 1022 N_in = mbkv_parent(ji,jj) 1023 zhtot = 0._wp 1024 DO jk=1,N_in 1025 IF (jk==N_in) THEN 1026 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1027 ELSE 1028 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1029 ENDIF 1030 zhtot = zhtot + h_in(jk) 1031 IF( h_in(jk) .GT. 0. ) THEN 1032 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 1033 ELSE 1034 tabin(jk) = 0. 1035 ENDIF 1036 ENDDO 1037 1038 N_out = 0 1039 DO jk=1,jpk 1040 if (vmask(ji,jj,jk) == 0) EXIT 1041 N_out = N_out + 1 1042 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 1043 END DO 1044 IF (N_in*N_out > 0) THEN 1045 IF( l_ini_child ) THEN 1046 CALL remap_linear (tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 1047 ELSE 1048 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 1049 ENDIF 935 1050 ENDIF 936 zhtot = zhtot + h_in(jk) 937 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 938 ENDDO 939 940 N_out = 0 941 DO jk=1,jpk 942 if (vmask(ji,jj,jk) == 0) EXIT 943 N_out = N_out + 1 944 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 945 END DO 946 IF (N_in*N_out > 0) THEN 947 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 948 ENDIF 949 END DO 950 END DO 951 # else 952 DO jk = 1, jpkm1 953 vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) ) 954 END DO 955 # endif 1051 END DO 1052 END DO 1053 ELSE 1054 DO jk = 1, jpkm1 1055 vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) ) 1056 END DO 1057 ENDIF 956 1058 ENDIF 957 1059 ! … … 1163 1265 END SUBROUTINE interpe3t 1164 1266 1165 1166 1267 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 1167 1268 !!---------------------------------------------------------------------- … … 1185 1286 END DO 1186 1287 END DO 1187 END DO 1188 1189 # if defined key_vertical 1190 ! Interpolate thicknesses 1191 ! Warning: these are masked, hence extrapolated prior interpolation. 1192 DO jk=k1,k2 1193 DO jj=j1,j2 1194 DO ji=i1,i2 1195 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 1196 END DO 1197 END DO 1198 END DO 1199 1200 ! Extrapolate thicknesses in partial bottom cells: 1201 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 1202 IF (ln_zps) THEN 1203 DO jj=j1,j2 1204 DO ji=i1,i2 1205 jk = mbkt(ji,jj) 1206 ptab(ji,jj,jk,2) = 0._wp 1207 END DO 1208 END DO 1209 END IF 1210 1211 ! Save ssh at last level: 1212 IF (.NOT.ln_linssh) THEN 1213 ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 1214 ELSE 1215 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1216 END IF 1217 # endif 1288 END DO 1289 1290 IF( l_vremap ) THEN 1291 ! Interpolate thicknesses 1292 ! Warning: these are masked, hence extrapolated prior interpolation. 1293 DO jk=k1,k2 1294 DO jj=j1,j2 1295 DO ji=i1,i2 1296 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 1297 END DO 1298 END DO 1299 END DO 1300 1301 ! Extrapolate thicknesses in partial bottom cells: 1302 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 1303 IF (ln_zps) THEN 1304 DO jj=j1,j2 1305 DO ji=i1,i2 1306 jk = mbkt(ji,jj) 1307 ptab(ji,jj,jk,2) = 0._wp 1308 END DO 1309 END DO 1310 END IF 1311 1312 ! Save ssh at last level: 1313 IF (.NOT.ln_linssh) THEN 1314 ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 1315 ELSE 1316 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1317 END IF 1318 ENDIF 1319 1218 1320 ELSE 1219 #ifdef key_vertical 1220 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1221 avm_k(i1:i2,j1:j2,k1:k2) = 0._wp 1222 1223 DO jj = j1, j2 1224 DO ji =i1, i2 1225 N_in = mbkt_parent(ji,jj) 1226 IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 1227 z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 1228 DO jk = N_in, 1, -1 ! Parent vertical grid 1229 z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 1230 tabin(jk) = ptab(ji,jj,jk,1) 1231 END DO 1232 N_out = mbkt(ji,jj) 1233 DO jk = 1, N_out ! Child vertical grid 1234 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1321 1322 IF( l_vremap ) THEN 1323 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1324 avm_k(i1:i2,j1:j2,k1:k2) = 0._wp 1325 1326 DO jj = j1, j2 1327 DO ji =i1, i2 1328 N_in = mbkt_parent(ji,jj) 1329 IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 1330 z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 1331 DO jk = N_in, 1, -1 ! Parent vertical grid 1332 z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 1333 tabin(jk) = ptab(ji,jj,jk,1) 1334 END DO 1335 N_out = mbkt(ji,jj) 1336 DO jk = 1, N_out ! Child vertical grid 1337 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1338 ENDDO 1339 IF (N_in*N_out > 0) THEN 1340 CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1) 1341 ENDIF 1235 1342 ENDDO 1236 IF (N_in*N_out > 0) THEN1237 CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1)1238 ENDIF1239 1343 ENDDO 1240 ENDDO 1241 #else 1242 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1243 #endif 1344 ELSE 1345 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1346 ENDIF 1244 1347 ENDIF 1245 1348 ! 1246 1349 END SUBROUTINE interpavm 1247 1350 1248 # if defined key_vertical1249 1351 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1250 1352 !!---------------------------------------------------------------------- … … 1282 1384 ! 1283 1385 END SUBROUTINE interpht0 1284 #endif 1285 1386 1387 SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before) 1388 INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2 1389 REAL(wp):: tabres(i1:i2,j1:j2,k1:k2,m1:m2) 1390 LOGICAL :: before 1391 1392 INTEGER :: jm 1393 1394 IF (before) THEN 1395 DO jm=1,jpts 1396 tabres(i1:i2,j1:j2,k1:k2,jm) = ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a) 1397 END DO 1398 ELSE 1399 DO jm=1,jpts 1400 ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)=tabres(i1:i2,j1:j2,k1:k2,jm) 1401 END DO 1402 ENDIF 1403 END SUBROUTINE agrif_initts 1404 1405 SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before ) 1406 !!---------------------------------------------------------------------- 1407 !! *** ROUTINE interpsshn *** 1408 !!---------------------------------------------------------------------- 1409 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1410 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1411 LOGICAL , INTENT(in ) :: before 1412 ! 1413 !!---------------------------------------------------------------------- 1414 ! 1415 IF( before) THEN 1416 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kbb_a) 1417 ELSE 1418 ssh(i1:i2,j1:j2,Kbb_a) = ptab(i1:i2,j1:j2)*tmask(i1:i2,j1:j2,1) 1419 ENDIF 1420 ! 1421 END SUBROUTINE agrif_initssh 1422 1286 1423 #else 1287 1424 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.