Changeset 13216 for NEMO/trunk/src/NST/agrif_oce_interp.F90
- Timestamp:
- 2020-07-02T11:25:49+02:00 (4 years ago)
- Location:
- NEMO/trunk
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk
- Property svn:externals
-
old new 2 2 ^/utils/build/makenemo@HEAD makenemo 3 3 ^/utils/build/mk@HEAD mk 4 ^/utils/tools @HEADtools5 ^/vendors/AGRIF/dev @HEADext/AGRIF4 ^/utils/tools/@HEAD tools 5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL
-
- Property svn:externals
-
NEMO/trunk/src/NST/agrif_oce_interp.F90
r12377 r13216 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 666 718 REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin 667 REAL(wp), DIMENSION(k1:k2) :: h_in 668 REAL(wp), DIMENSION(1:jpk) :: h_out 669 !!---------------------------------------------------------------------- 670 671 IF( before ) THEN 719 REAL(wp), DIMENSION(k1:k2) :: h_in, z_in 720 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 721 !!---------------------------------------------------------------------- 722 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 z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj) 793 DO jk=2,N_in 794 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 795 ENDDO 796 797 N_out = 0 798 DO jk=1,jpk ! jpk of child grid 799 IF (tmask(ji,jj,jk) == 0._wp) EXIT 800 N_out = N_out + 1 801 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 802 ENDDO 803 804 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj) 805 DO jk=2,N_out 806 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 807 ENDDO 808 809 IF (N_in*N_out > 0) THEN 810 IF( l_ini_child ) THEN 811 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 812 & z_out(1:N_out),N_in,N_out,jpts) 813 ELSE 814 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 815 & h_out(1:N_out),N_in,N_out,jpts) 816 ENDIF 726 817 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 818 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 819 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 820 Krhs_a = item 821 822 ELSE 823 824 DO jn=1, jpts 825 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) 826 END DO 827 ENDIF 747 828 748 829 ENDIF … … 780 861 REAL(wp) :: zrhoy, zhtot 781 862 ! vertical interpolation: 782 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 783 REAL(wp), DIMENSION(1:jpk) :: h_out 784 INTEGER :: N_in, N_out 863 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in 864 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 865 INTEGER :: N_in, N_out,item 785 866 REAL(wp) :: h_diff 786 867 !!--------------------------------------------- 787 868 ! 788 869 IF (before) THEN 870 871 item = Kmm_a 872 IF( l_ini_child ) Kmm_a = Kbb_a 873 789 874 DO jk=1,jpk 790 875 DO jj=j1,j2 791 876 DO ji=i1,i2 792 877 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 878 IF( l_vremap .OR. l_ini_child) THEN 879 ! Interpolate thicknesses (masked for subsequent extrapolation) 880 ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 881 ENDIF 882 END DO 883 END DO 884 END DO 885 886 IF( l_vremap .OR. l_ini_child) THEN 801 887 ! Extrapolate thicknesses in partial bottom cells: 802 888 ! 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 889 IF (ln_zps) THEN 890 DO jj=j1,j2 891 DO ji=i1,i2 892 jk = mbku(ji,jj) 893 ptab(ji,jj,jk,2) = 0._wp 894 END DO 895 END DO 896 END IF 897 898 ! Save ssh at last level: 899 ptab(i1:i2,j1:j2,k2,2) = 0._wp 900 IF (.NOT.ln_linssh) THEN 901 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 902 DO jk=1,jpk 903 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) 904 END DO 905 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2) 906 END IF 907 ENDIF 908 909 Kmm_a = item 821 910 ! 822 911 ELSE 823 912 zrhoy = Agrif_rhoy() 824 # if defined key_vertical 913 914 IF( l_vremap .OR. l_ini_child) THEN 825 915 ! VERTICAL REFINEMENT BEGIN 826 916 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 917 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 918 919 DO ji=i1,i2 920 DO jj=j1,j2 921 uu(ji,jj,:,Krhs_a) = 0._wp 922 N_in = mbku_parent(ji,jj) 923 zhtot = 0._wp 924 DO jk=1,N_in 925 IF (jk==N_in) THEN 926 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 927 ELSE 928 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 929 ENDIF 930 zhtot = zhtot + h_in(jk) 931 IF( h_in(jk) .GT. 0. ) THEN 932 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 933 ELSE 934 tabin(jk) = 0. 935 ENDIF 936 ENDDO 937 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 938 DO jk=2,N_in 939 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 940 ENDDO 941 942 N_out = 0 943 DO jk=1,jpk 944 IF (umask(ji,jj,jk) == 0) EXIT 945 N_out = N_out + 1 946 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 947 ENDDO 948 949 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj) 950 DO jk=2,N_out 951 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 952 ENDDO 953 954 IF (N_in*N_out > 0) THEN 955 IF( l_ini_child ) THEN 956 CALL remap_linear (tabin(1:N_in),z_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1) 957 ELSE 958 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) 959 ENDIF 960 ENDIF 961 ENDDO 853 962 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 963 ELSE 964 DO jk = 1, jpkm1 965 DO jj=j1,j2 966 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) ) 967 END DO 968 END DO 969 ENDIF 863 970 864 971 ENDIF … … 878 985 REAL(wp) :: zrhox 879 986 ! vertical interpolation: 880 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 881 REAL(wp), DIMENSION(1:jpk) :: h_out 882 INTEGER :: N_in, N_out 987 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in 988 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 989 INTEGER :: N_in, N_out, item 883 990 REAL(wp) :: h_diff, zhtot 884 991 !!--------------------------------------------- 885 992 ! 886 IF (before) THEN 993 IF (before) THEN 994 995 item = Kmm_a 996 IF( l_ini_child ) Kmm_a = Kbb_a 997 887 998 DO jk=k1,k2 888 999 DO jj=j1,j2 889 1000 DO ji=i1,i2 890 1001 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 1002 IF( l_vremap .OR. l_ini_child) THEN 1003 ! Interpolate thicknesses (masked for subsequent extrapolation) 1004 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 1005 ENDIF 1006 END DO 1007 END DO 1008 END DO 1009 1010 IF( l_vremap .OR. l_ini_child) THEN 899 1011 ! Extrapolate thicknesses in partial bottom cells: 900 1012 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 901 IF (ln_zps) THEN 1013 IF (ln_zps) THEN 1014 DO jj=j1,j2 1015 DO ji=i1,i2 1016 jk = mbkv(ji,jj) 1017 ptab(ji,jj,jk,2) = 0._wp 1018 END DO 1019 END DO 1020 END IF 1021 ! Save ssh at last level: 1022 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1023 IF (.NOT.ln_linssh) THEN 1024 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 1025 DO jk=1,jpk 1026 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) 1027 END DO 1028 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2) 1029 END IF 1030 ENDIF 1031 item = Kmm_a 1032 1033 ELSE 1034 zrhox = Agrif_rhox() 1035 1036 IF( l_vremap .OR. l_ini_child ) THEN 1037 1038 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1039 902 1040 DO jj=j1,j2 903 1041 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) 1042 vv(ji,jj,:,Krhs_a) = 0._wp 1043 N_in = mbkv_parent(ji,jj) 1044 zhtot = 0._wp 1045 DO jk=1,N_in 1046 IF (jk==N_in) THEN 1047 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1048 ELSE 1049 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1050 ENDIF 1051 zhtot = zhtot + h_in(jk) 1052 IF( h_in(jk) .GT. 0. ) THEN 1053 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 1054 ELSE 1055 tabin(jk) = 0. 1056 ENDIF 1057 ENDDO 1058 1059 z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj) 1060 DO jk=2,N_in 1061 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 1062 ENDDO 1063 1064 N_out = 0 1065 DO jk=1,jpk 1066 IF (vmask(ji,jj,jk) == 0) EXIT 1067 N_out = N_out + 1 1068 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 1069 ENDDO 1070 1071 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj) 1072 DO jk=2,N_out 1073 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 1074 ENDDO 1075 1076 IF (N_in*N_out > 0) THEN 1077 IF( l_ini_child ) THEN 1078 CALL remap_linear (tabin(1:N_in),z_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1) 1079 ELSE 1080 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) 1081 ENDIF 935 1082 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 1083 END DO 1084 END DO 1085 ELSE 1086 DO jk = 1, jpkm1 1087 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) ) 1088 END DO 1089 ENDIF 956 1090 ENDIF 957 1091 ! … … 1163 1297 END SUBROUTINE interpe3t 1164 1298 1165 1166 1299 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 1167 1300 !!---------------------------------------------------------------------- … … 1185 1318 END DO 1186 1319 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 1320 END DO 1321 1322 IF( l_vremap ) THEN 1323 ! Interpolate thicknesses 1324 ! Warning: these are masked, hence extrapolated prior interpolation. 1325 DO jk=k1,k2 1326 DO jj=j1,j2 1327 DO ji=i1,i2 1328 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 1329 END DO 1330 END DO 1331 END DO 1332 1333 ! Extrapolate thicknesses in partial bottom cells: 1334 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 1335 IF (ln_zps) THEN 1336 DO jj=j1,j2 1337 DO ji=i1,i2 1338 jk = mbkt(ji,jj) 1339 ptab(ji,jj,jk,2) = 0._wp 1340 END DO 1341 END DO 1342 END IF 1343 1344 ! Save ssh at last level: 1345 IF (.NOT.ln_linssh) THEN 1346 ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 1347 ELSE 1348 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1349 END IF 1350 ENDIF 1351 1218 1352 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) 1353 1354 IF( l_vremap ) THEN 1355 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1356 avm_k(i1:i2,j1:j2,k1:k2) = 0._wp 1357 1358 DO jj = j1, j2 1359 DO ji =i1, i2 1360 N_in = mbkt_parent(ji,jj) 1361 IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 1362 z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 1363 DO jk = N_in, 1, -1 ! Parent vertical grid 1364 z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 1365 tabin(jk) = ptab(ji,jj,jk,1) 1366 END DO 1367 N_out = mbkt(ji,jj) 1368 DO jk = 1, N_out ! Child vertical grid 1369 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1370 ENDDO 1371 IF (N_in*N_out > 0) THEN 1372 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) 1373 ENDIF 1235 1374 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 1375 ENDDO 1240 ENDDO 1241 #else 1242 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1243 #endif 1376 ELSE 1377 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1378 ENDIF 1244 1379 ENDIF 1245 1380 ! 1246 1381 END SUBROUTINE interpavm 1247 1382 1248 # if defined key_vertical1249 1383 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1250 1384 !!---------------------------------------------------------------------- … … 1282 1416 ! 1283 1417 END SUBROUTINE interpht0 1284 #endif 1285 1418 1419 SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before) 1420 INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2 1421 REAL(wp):: tabres(i1:i2,j1:j2,k1:k2,m1:m2) 1422 LOGICAL :: before 1423 1424 INTEGER :: jm 1425 1426 IF (before) THEN 1427 DO jm=1,jpts 1428 tabres(i1:i2,j1:j2,k1:k2,jm) = ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a) 1429 END DO 1430 ELSE 1431 DO jm=1,jpts 1432 ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)=tabres(i1:i2,j1:j2,k1:k2,jm) 1433 END DO 1434 ENDIF 1435 END SUBROUTINE agrif_initts 1436 1437 SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before ) 1438 !!---------------------------------------------------------------------- 1439 !! *** ROUTINE interpsshn *** 1440 !!---------------------------------------------------------------------- 1441 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1442 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1443 LOGICAL , INTENT(in ) :: before 1444 ! 1445 !!---------------------------------------------------------------------- 1446 ! 1447 IF( before) THEN 1448 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kbb_a) 1449 ELSE 1450 ssh(i1:i2,j1:j2,Kbb_a) = ptab(i1:i2,j1:j2)*tmask(i1:i2,j1:j2,1) 1451 ENDIF 1452 ! 1453 END SUBROUTINE agrif_initssh 1454 1286 1455 #else 1287 1456 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.