- Timestamp:
- 2020-11-09T16:48:35+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/test_12905_xios_restart
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/test_12905_xios_restart
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEADext/AGRIF5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 8 9 9 # SETTE 10 ^/utils/CI/ r12931_sette_ticket2462@HEADsette10 ^/utils/CI/sette@13559 sette
-
- Property svn:externals
-
NEMO/branches/2020/test_12905_xios_restart/src/NST/agrif_oce_interp.F90
r12377 r13751 34 34 USE lib_mpp 35 35 USE vremap 36 USE lbclnk 36 37 37 38 IMPLICIT NONE … … 43 44 PUBLIC interptsn, interpsshn, interpavm 44 45 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 45 PUBLIC interpe3t 46 #if defined key_vertical 46 PUBLIC interpe3t, interpglamt, interpgphit 47 47 PUBLIC interpht0, interpmbkt 48 # endif 48 PUBLIC agrif_initts, agrif_initssh 49 49 50 INTEGER :: bdy_tinterp = 0 50 51 … … 86 87 IF( Agrif_Root() ) RETURN 87 88 ! 88 Agrif_SpecialValue = 0. _wp89 Agrif_SpecialValue = 0.0_wp 89 90 Agrif_UseSpecialValue = ln_spc_dyn 90 91 ! 92 use_sign_north = .TRUE. 93 sign_north = -1.0_wp 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 = nn_hls + 2 ! halo + land + 1 103 ibdy2 = nn_hls + 1 + nbghostcells ! halo + land + 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 DO jk = 1, jpkm1 109 DO jj = 1, jpj 110 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) 111 END DO 112 END DO 113 DO jj = 1, jpj 114 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 115 END DO 116 END DO 117 ENDIF 118 ! 101 119 DO ji = mi0(ibdy1), mi1(ibdy2) 102 uu_b(ji,:,Krhs_a) = 0._wp 103 120 zub(ji,:) = 0._wp ! Correct transport 104 121 DO jk = 1, jpkm1 105 122 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 123 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 124 END DO 125 END DO 126 DO jj=1,jpj 127 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 128 END DO 138 129 DO jk = 1, jpkm1 139 130 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 131 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) 132 END DO 133 END DO 134 END DO 135 ! 136 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 137 DO ji = mi0(ibdy1), mi1(ibdy2) 138 zvb(ji,:) = 0._wp 139 DO jk = 1, jpkm1 140 DO jj = 1, jpj 141 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 142 END DO 143 END DO 144 DO jj = 1, jpj 145 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 146 END DO 147 DO jk = 1, jpkm1 148 DO jj = 1, jpj 149 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) 150 END DO 151 END DO 152 END DO 153 ENDIF 154 ! 155 ENDIF 156 157 ! --- East --- ! 158 IF( lk_east) THEN 159 ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 160 ibdy2 = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 161 ! 162 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 163 DO ji = mi0(ibdy1), mi1(ibdy2) 164 uu_b(ji,:,Krhs_a) = 0._wp 165 DO jk = 1, jpkm1 166 DO jj = 1, jpj 167 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) 168 END DO 169 END DO 170 DO jj = 1, jpj 171 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 172 END DO 173 END DO 174 ENDIF 175 ! 176 DO ji = mi0(ibdy1), mi1(ibdy2) 177 zub(ji,:) = 0._wp ! Correct transport 146 178 DO jk = 1, jpkm1 147 179 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 180 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 181 END DO 182 END DO 183 DO jj=1,jpj 184 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 185 END DO 161 186 DO jk = 1, jpkm1 162 187 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 188 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) 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 - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 195 ibdy2 = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 196 DO ji = mi0(ibdy1), mi1(ibdy2) 197 zvb(ji,:) = 0._wp 198 DO jk = 1, jpkm1 199 DO jj = 1, jpj 200 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 201 END DO 202 END DO 199 203 DO jj = 1, jpj 200 zvb(ji,jj) = zvb(ji,jj) & 201 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 202 END DO 203 END DO 204 DO jj = 1, jpj 204 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 205 END DO 206 DO jk = 1, jpkm1 207 DO jj = 1, jpj 208 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) 209 END DO 210 END DO 211 END DO 212 ENDIF 213 ! 214 ENDIF 215 216 ! --- South --- ! 217 IF( lk_south ) THEN 218 jbdy1 = nn_hls + 2 ! halo + land + 1 219 jbdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 220 ! 221 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 222 DO jj = mj0(jbdy1), mj1(jbdy2) 223 vv_b(:,jj,Krhs_a) = 0._wp 224 DO jk = 1, jpkm1 225 DO ji = 1, jpi 226 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + 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) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 240 END DO 241 END DO 242 DO ji = 1, jpi 205 243 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 206 244 END DO 207 DO jk = 1, jpkm1208 DO jj = 1, jpj209 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 DO212 END DO213 END DO214 ENDIF215 216 ! --- South --- !217 jbdy1 = 2218 jbdy2 = 1+nbghostcells219 !220 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport221 DO jj = mj0(jbdy1), mj1(jbdy2)222 vv_b(:,jj,Krhs_a) = 0._wp223 245 DO jk = 1, jpkm1 224 246 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 247 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) 248 END DO 249 END DO 250 END DO 251 ! 252 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 253 DO jj = mj0(jbdy1), mj1(jbdy2) 254 zub(:,jj) = 0._wp 255 DO jk = 1, jpkm1 256 DO ji = 1, jpi 257 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 258 END DO 259 END DO 260 DO ji = 1, jpi 261 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 262 END DO 263 DO jk = 1, jpkm1 264 DO ji = 1, jpi 265 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) 266 END DO 267 END DO 268 END DO 269 ENDIF 270 ! 271 ENDIF 272 273 ! --- North --- ! 274 IF( lk_north ) THEN 275 jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 276 jbdy2 = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 277 ! 278 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 279 DO jj = mj0(jbdy1), mj1(jbdy2) 280 vv_b(:,jj,Krhs_a) = 0._wp 281 DO jk = 1, jpkm1 282 DO ji = 1, jpi 283 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 284 END DO 285 END DO 286 DO ji=1,jpi 287 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 288 END DO 289 END DO 290 ENDIF 291 ! 292 DO jj = mj0(jbdy1), mj1(jbdy2) 293 zvb(:,jj) = 0._wp ! Correct transport 294 DO jk=1,jpkm1 295 DO ji=1,jpi 296 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 297 END DO 298 END DO 248 299 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 300 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 301 END DO 258 302 DO jk = 1, jpkm1 259 303 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 267 268 DO jk = 1, jpkm1 304 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) 305 END DO 306 END DO 307 END DO 308 ! 309 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 310 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 311 jbdy2 = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 312 DO jj = mj0(jbdy1), mj1(jbdy2) 313 zub(:,jj) = 0._wp 314 DO jk = 1, jpkm1 315 DO ji = 1, jpi 316 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 317 END DO 318 END DO 269 319 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 320 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 321 END DO 322 DO jk = 1, jpkm1 323 DO ji = 1, jpi 324 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) 325 END DO 326 END DO 327 END DO 328 ENDIF 329 ! 338 330 ENDIF 339 331 ! … … 354 346 ! 355 347 !--- 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 348 IF( lk_west ) THEN 349 istart = nn_hls + 2 ! halo + land + 1 350 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 351 DO ji = mi0(istart), mi1(iend) 352 DO jj=1,jpj 353 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 354 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 355 END DO 356 END DO 357 ENDIF 364 358 ! 365 359 !--- 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 360 IF( lk_east ) THEN 361 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 362 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 363 DO ji = mi0(istart), mi1(iend) 364 365 DO jj=1,jpj 366 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 367 END DO 368 END DO 369 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 370 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 371 DO ji = mi0(istart), mi1(iend) 372 DO jj=1,jpj 373 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 374 END DO 375 END DO 376 ENDIF 380 377 ! 381 378 !--- 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 379 IF( lk_south ) THEN 380 jstart = nn_hls + 2 ! halo + land + 1 381 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 382 DO jj = mj0(jstart), mj1(jend) 383 384 DO ji=1,jpi 385 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 386 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 387 END DO 388 END DO 389 ENDIF 390 390 ! 391 391 !--- 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 392 IF( lk_north ) THEN 393 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 394 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 395 DO jj = mj0(jstart), mj1(jend) 396 DO ji=1,jpi 397 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 398 END DO 399 END DO 400 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 401 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 402 DO jj = mj0(jstart), mj1(jend) 403 DO ji=1,jpi 404 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 405 END DO 406 END DO 407 ENDIF 406 408 ! 407 409 END SUBROUTINE Agrif_dyn_ts 408 410 411 409 412 SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv ) 410 413 !!---------------------------------------------------------------------- … … 421 424 ! 422 425 !--- 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 426 IF( lk_west ) THEN 427 istart = nn_hls + 2 ! halo + land + 1 428 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 429 DO ji = mi0(istart), mi1(iend) 430 DO jj=1,jpj 431 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 432 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 433 END DO 434 END DO 435 ENDIF 431 436 ! 432 437 !--- 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 438 IF( lk_east ) THEN 439 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 440 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 441 DO ji = mi0(istart), mi1(iend) 442 DO jj=1,jpj 443 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 444 END DO 445 END DO 446 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 447 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 448 DO ji = mi0(istart), mi1(iend) 449 DO jj=1,jpj 450 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 451 END DO 452 END DO 453 ENDIF 447 454 ! 448 455 !--- 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 456 IF( lk_south ) THEN 457 jstart = nn_hls + 2 ! halo + land + 1 458 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 459 DO jj = mj0(jstart), mj1(jend) 460 DO ji=1,jpi 461 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 462 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 463 END DO 464 END DO 465 ENDIF 457 466 ! 458 467 !--- 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 468 IF( lk_north ) THEN 469 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 470 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 471 DO jj = mj0(jstart), mj1(jend) 472 DO ji=1,jpi 473 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 474 END DO 475 END DO 476 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 477 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 478 DO jj = mj0(jstart), mj1(jend) 479 DO ji=1,jpi 480 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 481 END DO 482 END DO 483 ENDIF 473 484 ! 474 485 END SUBROUTINE Agrif_dyn_ts_flux 475 486 487 476 488 SUBROUTINE Agrif_dta_ts( kt ) 477 489 !!---------------------------------------------------------------------- … … 494 506 Agrif_SpecialValue = 0._wp 495 507 Agrif_UseSpecialValue = ln_spc_dyn 508 509 use_sign_north = .TRUE. 510 sign_north = -1. 511 496 512 ! 497 513 ! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners) … … 518 534 ENDIF 519 535 Agrif_UseSpecialValue = .FALSE. 536 use_sign_north = .FALSE. 520 537 ! 521 538 END SUBROUTINE Agrif_dta_ts … … 542 559 ! 543 560 ! --- 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) 549 ENDDO 550 ENDDO 561 IF(lk_west) THEN 562 istart = nn_hls + 2 ! halo + land + 1 563 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 564 DO ji = mi0(istart), mi1(iend) 565 DO jj = 1, jpj 566 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 567 END DO 568 END DO 569 ENDIF 551 570 ! 552 571 ! --- 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) 558 ENDDO 559 ENDDO 572 IF(lk_east) THEN 573 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 574 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 575 DO ji = mi0(istart), mi1(iend) 576 DO jj = 1, jpj 577 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 578 END DO 579 END DO 580 ENDIF 560 581 ! 561 582 ! --- 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) 567 ENDDO 568 ENDDO 583 IF(lk_south) THEN 584 jstart = nn_hls + 2 ! halo + land + 1 585 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 586 DO jj = mj0(jstart), mj1(jend) 587 DO ji = 1, jpi 588 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 589 END DO 590 END DO 591 ENDIF 569 592 ! 570 593 ! --- 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) 576 ENDDO 577 ENDDO 594 IF(lk_north) THEN 595 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 596 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 597 DO jj = mj0(jstart), mj1(jend) 598 DO ji = 1, jpi 599 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 600 END DO 601 END DO 602 ENDIF 578 603 ! 579 604 END SUBROUTINE Agrif_ssh … … 593 618 ! 594 619 ! --- 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) 600 ENDDO 601 ENDDO 620 IF(lk_west) THEN 621 istart = nn_hls + 2 ! halo + land + 1 622 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 623 DO ji = mi0(istart), mi1(iend) 624 DO jj = 1, jpj 625 ssha_e(ji,jj) = hbdy(ji,jj) 626 END DO 627 END DO 628 ENDIF 602 629 ! 603 630 ! --- 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) 609 ENDDO 610 ENDDO 631 IF(lk_east) THEN 632 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 633 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 634 DO ji = mi0(istart), mi1(iend) 635 DO jj = 1, jpj 636 ssha_e(ji,jj) = hbdy(ji,jj) 637 END DO 638 END DO 639 ENDIF 611 640 ! 612 641 ! --- 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) 618 ENDDO 619 ENDDO 642 IF(lk_south) THEN 643 jstart = nn_hls + 2 ! halo + land + 1 644 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 645 DO jj = mj0(jstart), mj1(jend) 646 DO ji = 1, jpi 647 ssha_e(ji,jj) = hbdy(ji,jj) 648 END DO 649 END DO 650 ENDIF 620 651 ! 621 652 ! --- 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) 627 ENDDO 628 ENDDO 653 IF(lk_north) THEN 654 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 655 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 656 DO jj = mj0(jstart), mj1(jend) 657 DO ji = 1, jpi 658 ssha_e(ji,jj) = hbdy(ji,jj) 659 END DO 660 END DO 661 ENDIF 629 662 ! 630 663 END SUBROUTINE Agrif_ssh_ts 631 664 665 632 666 SUBROUTINE Agrif_avm 633 667 !!---------------------------------------------------------------------- … … 650 684 ! 651 685 END SUBROUTINE Agrif_avm 652 686 653 687 654 688 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 662 696 INTEGER :: ji, jj, jk, jn ! dummy loop indices 663 697 INTEGER :: N_in, N_out 698 INTEGER :: item 664 699 ! vertical interpolation: 665 700 REAL(wp) :: zhtot 666 701 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 702 REAL(wp), DIMENSION(k1:k2) :: h_in, z_in 703 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 704 !!---------------------------------------------------------------------- 705 706 IF( before ) THEN 707 708 item = Kmm_a 709 IF( l_ini_child ) Kmm_a = Kbb_a 710 672 711 DO jn = 1,jpts 673 712 DO jk=k1,k2 … … 678 717 END DO 679 718 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 719 END DO 720 721 IF( l_vremap .OR. l_ini_child) THEN 722 ! Interpolate thicknesses 723 ! Warning: these are masked, hence extrapolated prior interpolation. 724 DO jk=k1,k2 725 DO jj=j1,j2 726 DO ji=i1,i2 727 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 728 729 END DO 730 END DO 731 END DO 732 733 ! Extrapolate thicknesses in partial bottom cells: 734 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 735 IF (ln_zps) THEN 736 DO jj=j1,j2 737 DO ji=i1,i2 738 jk = mbkt(ji,jj) 739 ptab(ji,jj,jk,jpts+1) = 0._wp 740 END DO 741 END DO 742 END IF 743 744 ! Save ssh at last level: 745 IF (.NOT.ln_linssh) THEN 746 ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 747 ELSE 748 ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp 749 END IF 750 ENDIF 751 Kmm_a = item 752 711 753 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) 754 item = Krhs_a 755 IF( l_ini_child ) Krhs_a = Kbb_a 756 757 IF( l_vremap .OR. l_ini_child ) THEN 758 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 759 760 DO jj=j1,j2 761 DO ji=i1,i2 762 ts(ji,jj,:,:,Krhs_a) = 0. 763 ! IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts) 764 N_in = mbkt_parent(ji,jj) 765 zhtot = 0._wp 766 DO jk=1,N_in !k2 = jpk of parent grid 767 IF (jk==N_in) THEN 768 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 769 ELSE 770 h_in(jk) = ptab(ji,jj,jk,n2) 771 ENDIF 772 zhtot = zhtot + h_in(jk) 773 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 774 END DO 775 z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj) 776 DO jk=2,N_in 777 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 778 END DO 779 780 N_out = 0 781 DO jk=1,jpk ! jpk of child grid 782 IF (tmask(ji,jj,jk) == 0._wp) EXIT 783 N_out = N_out + 1 784 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 785 END DO 786 787 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj) 788 DO jk=2,N_out 789 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 790 END DO 791 792 IF (N_in*N_out > 0) THEN 793 IF( l_ini_child ) THEN 794 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 795 & z_out(1:N_out),N_in,N_out,jpts) 796 ELSE 797 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 798 & h_out(1:N_out),N_in,N_out,jpts) 799 ENDIF 726 800 ENDIF 727 zhtot = zhtot + h_in(jk) 728 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 729 END DO 730 N_out = 0 731 DO jk=1,jpk ! jpk of child grid 732 IF (tmask(ji,jj,jk) == 0._wp) EXIT 733 N_out = N_out + 1 734 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 735 ENDDO 736 IF (N_in*N_out > 0) THEN 737 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 ENDIF 739 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 801 END DO 802 END DO 803 Krhs_a = item 804 805 ELSE 806 807 DO jn=1, jpts 808 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) 809 END DO 810 ENDIF 747 811 748 812 ENDIF … … 750 814 END SUBROUTINE interptsn 751 815 816 752 817 SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before ) 753 818 !!---------------------------------------------------------------------- … … 768 833 END SUBROUTINE interpsshn 769 834 835 770 836 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 771 837 !!---------------------------------------------------------------------- … … 780 846 REAL(wp) :: zrhoy, zhtot 781 847 ! 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 848 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in 849 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 850 INTEGER :: N_in, N_out,item 785 851 REAL(wp) :: h_diff 786 852 !!--------------------------------------------- 787 853 ! 788 854 IF (before) THEN 855 856 item = Kmm_a 857 IF( l_ini_child ) Kmm_a = Kbb_a 858 789 859 DO jk=1,jpk 790 860 DO jj=j1,j2 791 861 DO ji=i1,i2 792 862 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 863 IF( l_vremap .OR. l_ini_child) THEN 864 ! Interpolate thicknesses (masked for subsequent extrapolation) 865 ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 866 ENDIF 867 END DO 868 END DO 869 END DO 870 871 IF( l_vremap .OR. l_ini_child) THEN 801 872 ! Extrapolate thicknesses in partial bottom cells: 802 873 ! 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 874 IF (ln_zps) THEN 875 DO jj=j1,j2 876 DO ji=i1,i2 877 jk = mbku(ji,jj) 878 ptab(ji,jj,jk,2) = 0._wp 879 END DO 880 END DO 881 END IF 882 883 ! Save ssh at last level: 884 ptab(i1:i2,j1:j2,k2,2) = 0._wp 885 IF (.NOT.ln_linssh) THEN 886 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 887 DO jk=1,jpk 888 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) 889 END DO 890 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2) 891 END IF 892 ENDIF 893 894 Kmm_a = item 821 895 ! 822 896 ELSE 823 897 zrhoy = Agrif_rhoy() 824 # if defined key_vertical 898 899 IF( l_vremap .OR. l_ini_child) THEN 825 900 ! VERTICAL REFINEMENT BEGIN 826 901 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 853 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 902 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 903 904 DO ji=i1,i2 905 DO jj=j1,j2 906 uu(ji,jj,:,Krhs_a) = 0._wp 907 N_in = mbku_parent(ji,jj) 908 zhtot = 0._wp 909 DO jk=1,N_in 910 IF (jk==N_in) THEN 911 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 912 ELSE 913 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 914 ENDIF 915 zhtot = zhtot + h_in(jk) 916 IF( h_in(jk) .GT. 0. ) THEN 917 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 918 ELSE 919 tabin(jk) = 0. 920 ENDIF 921 END DO 922 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 923 DO jk=2,N_in 924 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 925 END DO 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 END DO 933 934 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj) 935 DO jk=2,N_out 936 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 937 END DO 938 939 IF (N_in*N_out > 0) THEN 940 IF( l_ini_child ) THEN 941 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) 942 ELSE 943 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) 944 ENDIF 945 ENDIF 946 END DO 947 END DO 948 ELSE 949 DO jk = 1, jpkm1 950 DO jj=j1,j2 951 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) ) 952 END DO 953 END DO 954 ENDIF 863 955 864 956 ENDIF … … 866 958 END SUBROUTINE interpun 867 959 960 868 961 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 869 962 !!---------------------------------------------------------------------- … … 878 971 REAL(wp) :: zrhox 879 972 ! 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 973 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in 974 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 975 INTEGER :: N_in, N_out, item 883 976 REAL(wp) :: h_diff, zhtot 884 977 !!--------------------------------------------- 885 978 ! 886 IF (before) THEN 979 IF (before) THEN 980 981 item = Kmm_a 982 IF( l_ini_child ) Kmm_a = Kbb_a 983 887 984 DO jk=k1,k2 888 985 DO jj=j1,j2 889 986 DO ji=i1,i2 890 987 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 988 IF( l_vremap .OR. l_ini_child) THEN 989 ! Interpolate thicknesses (masked for subsequent extrapolation) 990 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 991 ENDIF 992 END DO 993 END DO 994 END DO 995 996 IF( l_vremap .OR. l_ini_child) THEN 899 997 ! Extrapolate thicknesses in partial bottom cells: 900 998 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 901 IF (ln_zps) THEN 999 IF (ln_zps) THEN 1000 DO jj=j1,j2 1001 DO ji=i1,i2 1002 jk = mbkv(ji,jj) 1003 ptab(ji,jj,jk,2) = 0._wp 1004 END DO 1005 END DO 1006 END IF 1007 ! Save ssh at last level: 1008 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1009 IF (.NOT.ln_linssh) THEN 1010 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 1011 DO jk=1,jpk 1012 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) 1013 END DO 1014 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2) 1015 END IF 1016 ENDIF 1017 item = Kmm_a 1018 1019 ELSE 1020 zrhox = Agrif_rhox() 1021 1022 IF( l_vremap .OR. l_ini_child ) THEN 1023 1024 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1025 902 1026 DO jj=j1,j2 903 1027 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) 1028 vv(ji,jj,:,Krhs_a) = 0._wp 1029 N_in = mbkv_parent(ji,jj) 1030 zhtot = 0._wp 1031 DO jk=1,N_in 1032 IF (jk==N_in) THEN 1033 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1034 ELSE 1035 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1036 ENDIF 1037 zhtot = zhtot + h_in(jk) 1038 IF( h_in(jk) .GT. 0. ) THEN 1039 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 1040 ELSE 1041 tabin(jk) = 0. 1042 ENDIF 1043 END DO 1044 1045 z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj) 1046 DO jk=2,N_in 1047 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 1048 END DO 1049 1050 N_out = 0 1051 DO jk=1,jpk 1052 IF (vmask(ji,jj,jk) == 0) EXIT 1053 N_out = N_out + 1 1054 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 1055 END DO 1056 1057 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj) 1058 DO jk=2,N_out 1059 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 1060 END DO 1061 1062 IF (N_in*N_out > 0) THEN 1063 IF( l_ini_child ) THEN 1064 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) 1065 ELSE 1066 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) 1067 ENDIF 935 1068 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 1069 END DO 1070 END DO 1071 ELSE 1072 DO jk = 1, jpkm1 1073 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) ) 1074 END DO 1075 ENDIF 956 1076 ENDIF 957 1077 ! … … 1152 1272 WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', & 1153 1273 & ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), & 1154 & ji+nimpp-1, jj+njmpp-1, jk1155 kindic_agr = kindic_agr + 11274 & mig0(ji), mig0(jj), jk 1275 ! kindic_agr = kindic_agr + 1 1156 1276 ENDIF 1157 1277 END DO … … 1162 1282 ! 1163 1283 END SUBROUTINE interpe3t 1284 1285 SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before ) 1286 !!---------------------------------------------------------------------- 1287 !! *** ROUTINE interpglamt *** 1288 !!---------------------------------------------------------------------- 1289 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1290 REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1291 LOGICAL , INTENT(in ) :: before 1292 ! 1293 INTEGER :: ji, jj, jk 1294 REAL(wp):: ztst 1295 !!---------------------------------------------------------------------- 1296 ! 1297 IF( before ) THEN 1298 ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2) 1299 ELSE 1300 ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4 1301 DO jj = j1, j2 1302 DO ji = i1, i2 1303 IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN 1304 WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj) 1305 ! kindic_agr = kindic_agr + 1 1306 ENDIF 1307 END DO 1308 END DO 1309 ENDIF 1310 ! 1311 END SUBROUTINE interpglamt 1312 1313 1314 SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before ) 1315 !!---------------------------------------------------------------------- 1316 !! *** ROUTINE interpgphit *** 1317 !!---------------------------------------------------------------------- 1318 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1319 REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1320 LOGICAL , INTENT(in ) :: before 1321 ! 1322 INTEGER :: ji, jj, jk 1323 REAL(wp):: ztst 1324 !!---------------------------------------------------------------------- 1325 ! 1326 IF( before ) THEN 1327 ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2) 1328 ELSE 1329 ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4 1330 DO jj = j1, j2 1331 DO ji = i1, i2 1332 IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN 1333 WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj) 1334 ! kindic_agr = kindic_agr + 1 1335 ENDIF 1336 END DO 1337 END DO 1338 ENDIF 1339 ! 1340 END SUBROUTINE interpgphit 1164 1341 1165 1342 … … 1185 1362 END DO 1186 1363 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 1364 END DO 1365 1366 IF( l_vremap ) THEN 1367 ! Interpolate thicknesses 1368 ! Warning: these are masked, hence extrapolated prior interpolation. 1369 DO jk=k1,k2 1370 DO jj=j1,j2 1371 DO ji=i1,i2 1372 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 1373 END DO 1374 END DO 1375 END DO 1376 1377 ! Extrapolate thicknesses in partial bottom cells: 1378 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 1379 IF (ln_zps) THEN 1380 DO jj=j1,j2 1381 DO ji=i1,i2 1382 jk = mbkt(ji,jj) 1383 ptab(ji,jj,jk,2) = 0._wp 1384 END DO 1385 END DO 1386 END IF 1387 1388 ! Save ssh at last level: 1389 IF (.NOT.ln_linssh) THEN 1390 ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 1391 ELSE 1392 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1393 END IF 1394 ENDIF 1395 1218 1396 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) 1235 ENDDO 1236 IF (N_in*N_out > 0) THEN 1237 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 ENDIF 1239 ENDDO 1240 ENDDO 1241 #else 1242 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1243 #endif 1397 1398 IF( l_vremap ) THEN 1399 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1400 avm_k(i1:i2,j1:j2,k1:k2) = 0._wp 1401 1402 DO jj = j1, j2 1403 DO ji =i1, i2 1404 N_in = mbkt_parent(ji,jj) 1405 IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 1406 z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 1407 DO jk = N_in, 1, -1 ! Parent vertical grid 1408 z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 1409 tabin(jk) = ptab(ji,jj,jk,1) 1410 END DO 1411 N_out = mbkt(ji,jj) 1412 DO jk = 1, N_out ! Child vertical grid 1413 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1414 END DO 1415 IF (N_in*N_out > 0) THEN 1416 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) 1417 ENDIF 1418 END DO 1419 END DO 1420 ELSE 1421 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1422 ENDIF 1244 1423 ENDIF 1245 1424 ! 1246 1425 END SUBROUTINE interpavm 1247 1426 1248 # if defined key_vertical 1427 1249 1428 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1250 1429 !!---------------------------------------------------------------------- … … 1265 1444 END SUBROUTINE interpmbkt 1266 1445 1446 1267 1447 SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before ) 1268 1448 !!---------------------------------------------------------------------- … … 1282 1462 ! 1283 1463 END SUBROUTINE interpht0 1284 #endif 1285 1464 1465 1466 SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before) 1467 INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2 1468 REAL(wp):: tabres(i1:i2,j1:j2,k1:k2,m1:m2) 1469 LOGICAL :: before 1470 1471 INTEGER :: jm 1472 1473 IF (before) THEN 1474 DO jm=1,jpts 1475 tabres(i1:i2,j1:j2,k1:k2,jm) = ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a) 1476 END DO 1477 ELSE 1478 DO jm=1,jpts 1479 ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)=tabres(i1:i2,j1:j2,k1:k2,jm) 1480 END DO 1481 ENDIF 1482 END SUBROUTINE agrif_initts 1483 1484 1485 SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before ) 1486 !!---------------------------------------------------------------------- 1487 !! *** ROUTINE interpsshn *** 1488 !!---------------------------------------------------------------------- 1489 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1490 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1491 LOGICAL , INTENT(in ) :: before 1492 ! 1493 !!---------------------------------------------------------------------- 1494 ! 1495 IF( before) THEN 1496 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kbb_a) 1497 ELSE 1498 ssh(i1:i2,j1:j2,Kbb_a) = ptab(i1:i2,j1:j2)*tmask(i1:i2,j1:j2,1) 1499 ENDIF 1500 ! 1501 END SUBROUTINE agrif_initssh 1502 1286 1503 #else 1287 1504 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.