- Timestamp:
- 2018-06-30T12:51:02+02:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2018/dev_r9838_ENHANCE04_MLF/src/NST/agrif_oce_update.F90
r9780 r9863 12 12 !! 3.6 ! 2014-09 (R. Benshila) 13 13 !!---------------------------------------------------------------------- 14 15 !!---------------------------------------------------------------------- 16 !! Agrif_Update_Tra : T-S agrif update 17 !! Agrif_Update_Dyn : dynamics agrif update 18 !! Agrif_Update_ssh : sea surface height update 19 !! Agrif_Update_Tke : 20 !! Agrif_Update_vvl : 21 !! dom_vvl_update_UVF : 22 !! updateTS : 23 !! updateu : 24 !! correct_u_bdy : 25 !! updatev : 26 !! correct_v_bdy : 27 !! updateu2d : 28 !! updatev2d : 29 !! updateSSH : 30 !! updateub2b : 31 !! reflux_sshu : 32 !! updatevb2b : 33 !! reflux_sshv : 34 !! update_scales : 35 !! updateEN : 36 !! updateAVT : 37 !! updateAVM : 38 !! updatee3t : 39 !!---------------------------------------------------------------------- 40 14 41 #if defined key_agrif 15 42 !!---------------------------------------------------------------------- 16 43 !! 'key_agrif' AGRIF zoom 17 44 !!---------------------------------------------------------------------- 18 USE par_oce 19 USE oce 20 USE dom_oce 45 USE par_oce ! ocean parameter 46 USE oce ! ocean variables 47 USE dom_oce ! ocean domain 21 48 USE zdf_oce ! vertical physics: ocean variables 22 USE agrif_oce 49 USE agrif_oce ! 23 50 ! 24 51 USE in_out_manager ! I/O manager … … 67 94 ! 68 95 END SUBROUTINE Agrif_Update_Tra 96 69 97 70 98 SUBROUTINE Agrif_Update_Dyn( ) … … 125 153 END SUBROUTINE Agrif_Update_Dyn 126 154 155 127 156 SUBROUTINE Agrif_Update_ssh( ) 128 !!--------------------------------------------- 129 !! *** ROUTINE Agrif_Update_ssh ***130 !!--------------------------------------------- 157 !!---------------------------------------------------------------------- 158 !! *** ROUTINE Agrif_Update_ssh *** 159 !!---------------------------------------------------------------------- 131 160 ! 132 161 IF (Agrif_Root()) RETURN … … 163 192 164 193 SUBROUTINE Agrif_Update_Tke( ) 165 !!--------------------------------------------- 166 !! *** ROUTINE Agrif_Update_Tke *** 167 !!--------------------------------------------- 168 !! 194 !!---------------------------------------------------------------------- 195 !! *** ROUTINE Agrif_Update_Tke *** 196 !!---------------------------------------------------------------------- 169 197 ! 170 198 IF (Agrif_Root()) RETURN 171 199 ! 172 200 # if defined TWO_WAY 173 201 ! 174 202 Agrif_UseSpecialValueInUpdate = .TRUE. 175 203 Agrif_SpecialValueFineGrid = 0. 176 204 ! 177 205 CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN ) 178 206 CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 179 207 CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 180 208 ! 181 209 Agrif_UseSpecialValueInUpdate = .FALSE. 182 210 ! 183 211 # endif 184 212 ! 185 213 END SUBROUTINE Agrif_Update_Tke 186 214 187 215 188 216 SUBROUTINE Agrif_Update_vvl( ) 189 !!--------------------------------------------- 190 !! *** ROUTINE Agrif_Update_vvl ***191 !!--------------------------------------------- 192 ! 193 IF ( Agrif_Root())RETURN217 !!---------------------------------------------------------------------- 218 !! *** ROUTINE Agrif_Update_vvl *** 219 !!---------------------------------------------------------------------- 220 ! 221 IF ( Agrif_Root() ) RETURN 194 222 ! 195 223 #if defined TWO_WAY … … 214 242 END SUBROUTINE Agrif_Update_vvl 215 243 244 216 245 SUBROUTINE dom_vvl_update_UVF 217 !!--------------------------------------------- 218 !! *** ROUTINE dom_vvl_update_UVF *** 219 !!--------------------------------------------- 220 !! 221 INTEGER :: jk 222 REAL(wp):: zcoef 223 !!--------------------------------------------- 224 225 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', & 226 & Agrif_Fixed(), 'Step', Agrif_Nb_Step() 227 228 ! Save "old" scale factor (prior update) for subsequent asselin correction 229 ! of prognostic variables 246 !!---------------------------------------------------------------------- 247 !! *** ROUTINE dom_vvl_update_UVF *** 248 !!---------------------------------------------------------------------- 249 INTEGER :: jk ! dummy loop index 250 REAL(wp):: zcoef ! local scalar 251 !!---------------------------------------------------------------------- 252 ! 253 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', & 254 & Agrif_Fixed(), 'Step', Agrif_Nb_Step() 255 256 ! Save "old" scale factor (prior update) for subsequent asselin correction of prognostic variables 230 257 ! ----------------------- 231 !232 258 e3u_a(:,:,:) = e3u_n(:,:,:) 233 259 e3v_a(:,:,:) = e3v_n(:,:,:) … … 239 265 ! 1) NOW fields 240 266 !-------------- 241 242 ! Vertical scale factor interpolations 243 ! ------------------------------------ 244 CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:) , 'U' ) 245 CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:) , 'V' ) 246 CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:) , 'F' ) 247 267 ! ! Vertical scale factor interpolations 268 CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n (:,:,:) , 'U' ) 269 CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n (:,:,:) , 'V' ) 270 CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n (:,:,:) , 'F' ) 248 271 CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) 249 272 CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) 250 251 ! Update total depths: 252 ! -------------------- 273 ! 274 ! ! Update total depths 253 275 hu_n(:,:) = 0._wp ! Ocean depth at U-points 254 276 hv_n(:,:) = 0._wp ! Ocean depth at V-points … … 264 286 ! 2) BEFORE fields: 265 287 !------------------ 266 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN 267 ! 268 ! Vertical scale factor interpolations 269 ! ------------------------------------ 270 CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' ) 271 CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' ) 272 288 IF (.NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) THEN 289 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN 290 ! ! Vertical scale factor interpolations 291 CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b (:,:,:), 'U' ) 292 CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b (:,:,:), 'V' ) 273 293 CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' ) 274 294 CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' ) 275 276 ! Update total depths: 277 ! -------------------- 295 ! 296 ! ! Update total depths: 278 297 hu_b(:,:) = 0._wp ! Ocean depth at U-points 279 298 hv_b(:,:) = 0._wp ! Ocean depth at V-points … … 289 308 END SUBROUTINE dom_vvl_update_UVF 290 309 291 # if defined key_vertical310 # if defined key_vertical 292 311 293 312 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 294 313 !!---------------------------------------------------------------------- 295 !! *** ROUTINE updateT ***296 !!--------------------------------------------- 314 !! *** ROUTINE updateT *** 315 !!---------------------------------------------------------------------- 297 316 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 298 317 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres … … 306 325 REAL(wp) :: zrho_xy, h_diff 307 326 REAL(wp) :: tabin(k1:k2,n1:n2) 308 !!--------------------------------------------- 327 !!---------------------------------------------------------------------- 309 328 ! 310 329 IF (before) THEN 311 330 AGRIF_SpecialValue = -999._wp 312 331 zrho_xy = Agrif_rhox() * Agrif_rhoy() 313 DO jn = n1, n2-1314 DO jk =k1,k2315 DO jj =j1,j2316 DO ji =i1,i2332 DO jn = n1, n2-1 333 DO jk = k1, k2 334 DO jj = j1, j2 335 DO ji = i1, i2 317 336 tabres(ji,jj,jk,jn) = (tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) & 318 337 * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp … … 321 340 END DO 322 341 END DO 323 DO jk =k1,k2324 DO jj =j1,j2325 DO ji =i1,i2342 DO jk = k1, k2 343 DO jj = j1, j2 344 DO ji = i1, i2 326 345 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) & 327 346 + (tmask(ji,jj,jk)-1)*999._wp … … 332 351 tabres_child(:,:,:,:) = 0. 333 352 AGRIF_SpecialValue = 0._wp 334 DO jj =j1,j2335 DO ji =i1,i2353 DO jj = j1 , j2 354 DO ji = i1, i2 336 355 N_in = 0 337 DO jk =k1,k2 !k2 = jpk of child grid338 IF ( tabres(ji,jj,jk,n2) == 0 )EXIT356 DO jk = k1, k2 !k2 = jpk of child grid 357 IF ( tabres(ji,jj,jk,n2) == 0 ) EXIT 339 358 N_in = N_in + 1 340 359 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 341 h_in (N_in) = tabres(ji,jj,jk,n2)342 END DO360 h_in (N_in) = tabres(ji,jj,jk,n2) 361 END DO 343 362 N_out = 0 344 DO jk =1,jpk ! jpk of parent grid345 IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF363 DO jk = 1, jpk ! jpk of parent grid 364 IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF 346 365 N_out = N_out + 1 347 366 h_out(N_out) = e3t_n(ji,jj,jk) 348 END DO367 END DO 349 368 IF (N_in > 0) THEN !Remove this? 350 369 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) … … 355 374 STOP 356 375 ENDIF 357 DO jn =n1,n2-1376 DO jn = n1, n2-1 358 377 CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out) 359 END DO378 END DO 360 379 ENDIF 361 ENDDO 362 ENDDO 363 364 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 380 END DO 381 END DO 382 383 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) THEN 384 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 365 385 ! Add asselin part 366 DO jn = n1, n2-1367 DO jk =1,jpk368 DO jj =j1,j2369 DO ji =i1,i2370 IF( tabres_child(ji,jj,jk,jn) .NE.0. ) THEN386 DO jn = n1, n2-1 387 DO jk = 1, jpk 388 DO jj = j1, j2 389 DO ji = i1, i2 390 IF( tabres_child(ji,jj,jk,jn) /= 0. ) THEN 371 391 tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 372 392 & + atfp * ( tabres_child(ji,jj,jk,jn) & 373 393 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 374 394 ENDIF 375 END DO376 END DO377 END DO378 END DO379 ENDIF 380 DO jn = n1, n2-1381 DO jk =1,jpk382 DO jj =j1,j2383 DO ji =i1,i2384 IF( tabres_child(ji,jj,jk,jn) .NE.0. ) THEN395 END DO 396 END DO 397 END DO 398 END DO 399 ENDIF 400 DO jn = n1, n2-1 401 DO jk = 1, jpk 402 DO jj = j1, j2 403 DO ji = i1, i2 404 IF( tabres_child(ji,jj,jk,jn) /= 0. ) THEN 385 405 tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk) 386 406 END IF … … 396 416 397 417 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 398 !!--------------------------------------------- 399 !! ***ROUTINE updateT ***400 !!--------------------------------------------- 418 !!---------------------------------------------------------------------- 419 !! *** ROUTINE ROUTINE updateT *** 420 !!---------------------------------------------------------------------- 401 421 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 402 422 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 403 423 LOGICAL, INTENT(in) :: before 404 ! !424 ! 405 425 INTEGER :: ji,jj,jk,jn 406 426 REAL(wp) :: ztb, ztnu, ztno 407 !!--------------------------------------------- 427 !!---------------------------------------------------------------------- 408 428 ! 409 429 IF (before) THEN … … 425 445 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & 426 446 & * tmask(i1:i2,j1:j2,k1:k2) 427 END DO447 END DO 428 448 !< jc tmp 429 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 449 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) THEN 450 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 430 451 ! Add asselin part 431 452 DO jn = 1,jpts … … 457 478 END DO 458 479 ! 459 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 480 IF ( l_1st_euler .AND. Agrif_Nb_Step() == 0 ) THEN 481 !!gm IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 460 482 tsb(i1:i2,j1:j2,k1:k2,1:jpts) = tsn(i1:i2,j1:j2,k1:k2,1:jpts) 461 483 ENDIF … … 470 492 471 493 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 472 !!--------------------------------------------- 473 !! *** ROUTINE updateu ***474 !!--------------------------------------------- 494 !!---------------------------------------------------------------------- 495 !! *** ROUTINE updateu *** 496 !!---------------------------------------------------------------------- 475 497 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 476 498 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres … … 487 509 REAL(wp) :: tabin(k1:k2) 488 510 ! VERTICAL REFINEMENT END 489 !!--------------------------------------------- 511 !!---------------------------------------------------------------------- 490 512 ! 491 513 IF( before ) THEN … … 515 537 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 516 538 h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj) 517 END DO539 END DO 518 540 N_out = 0 519 541 DO jk=1,jpk … … 521 543 N_out = N_out + 1 522 544 h_out(N_out) = e3u_n(ji,jj,jk) 523 END DO545 END DO 524 546 IF (N_in * N_out > 0) THEN 525 547 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) … … 538 560 EXIT 539 561 ENDIF 540 END DO562 END DO 541 563 ENDIF 542 564 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 543 565 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out)) 544 566 ENDIF 545 END DO546 END DO567 END DO 568 END DO 547 569 548 570 DO jk=1,jpk 549 571 DO jj=j1,j2 550 572 DO ji=i1,i2 551 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 573 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler) ) THEN ! Add asselin part 574 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 552 575 ub(ji,jj,jk) = ub(ji,jj,jk) & 553 576 & + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) … … 565 588 566 589 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 567 !!--------------------------------------------- 568 !! *** ROUTINE updateu ***569 !!--------------------------------------------- 590 !!---------------------------------------------------------------------- 591 !! *** ROUTINE updateu *** 592 !!---------------------------------------------------------------------- 570 593 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 571 594 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres … … 574 597 INTEGER :: ji, jj, jk 575 598 REAL(wp) :: zrhoy, zub, zunu, zuno 576 !!--------------------------------------------- 599 !!---------------------------------------------------------------------- 577 600 ! 578 601 IF( before ) THEN … … 587 610 tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) 588 611 ! 589 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 612 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) THEN ! Add asselin part 613 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 590 614 zub = ub(ji,jj,jk) * e3u_b(ji,jj,jk) ! fse3t_b prior update should be used 591 615 zuno = un(ji,jj,jk) * e3u_a(ji,jj,jk) … … 600 624 END DO 601 625 ! 602 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 626 IF ( l_1st_euler .AND. Agrif_Nb_Step() == 0 ) THEN 627 !!gm IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 603 628 ub(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) 604 629 ENDIF … … 611 636 612 637 SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 613 !!--------------------------------------------- 614 !! *** ROUTINE correct_u_bdy ***615 !!--------------------------------------------- 638 !!---------------------------------------------------------------------- 639 !! *** ROUTINE correct_u_bdy *** 640 !!---------------------------------------------------------------------- 616 641 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 617 642 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 618 643 LOGICAL , INTENT(in ) :: before 619 INTEGER , INTENT(in ):: nb, ndir644 INTEGER , INTENT(in ) :: nb, ndir 620 645 !! 621 646 LOGICAL :: western_side, eastern_side 622 ! 623 INTEGER :: jj, jk 624 REAL(wp) :: zcor 625 !!--------------------------------------------- 647 INTEGER :: jj, jk 648 REAL(wp):: zcor 649 !!---------------------------------------------------------------------- 626 650 ! 627 651 IF( .NOT.before ) THEN … … 657 681 658 682 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 659 !!--------------------------------------------- 660 !! *** ROUTINE updatev ***661 !!--------------------------------------------- 683 !!---------------------------------------------------------------------- 684 !! *** ROUTINE updatev *** 685 !!---------------------------------------------------------------------- 662 686 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 663 687 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres … … 674 698 REAL(wp) :: tabin(k1:k2) 675 699 ! VERTICAL REFINEMENT END 676 !!--------------------------------------------- 700 !!---------------------------------------------------------------------- 677 701 ! 678 702 IF( before ) THEN … … 700 724 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 701 725 h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj) 702 END DO726 END DO 703 727 N_out = 0 704 728 DO jk=1,jpk … … 706 730 N_out = N_out + 1 707 731 h_out(N_out) = e3v_n(ji,jj,jk) 708 END DO732 END DO 709 733 IF (N_in * N_out > 0) THEN 710 734 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) … … 723 747 EXIT 724 748 ENDIF 725 END DO749 END DO 726 750 ENDIF 727 751 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 728 752 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out)) 729 753 ENDIF 730 END DO731 END DO754 END DO 755 END DO 732 756 733 757 DO jk=1,jpk … … 735 759 DO ji=i1,i2 736 760 ! 737 IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part 761 IF( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) THEN ! Add asselin part 762 !!gm IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part 738 763 vb(ji,jj,jk) = vb(ji,jj,jk) & 739 764 & + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) … … 751 776 752 777 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before) 753 !!--------------------------------------------- 754 !! *** ROUTINE updatev ***755 !!--------------------------------------------- 778 !!---------------------------------------------------------------------- 779 !! *** ROUTINE updatev *** 780 !!---------------------------------------------------------------------- 756 781 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 757 782 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres … … 760 785 INTEGER :: ji, jj, jk 761 786 REAL(wp) :: zrhox, zvb, zvnu, zvno 762 !!--------------------------------------------- 787 !!---------------------------------------------------------------------- 763 788 ! 764 789 IF (before) THEN … … 777 802 tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj) 778 803 ! 779 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 804 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) THEN ! Add asselin part 805 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 780 806 zvb = vb(ji,jj,jk) * e3v_b(ji,jj,jk) ! fse3t_b prior update should be used 781 807 zvno = vn(ji,jj,jk) * e3v_a(ji,jj,jk) … … 790 816 END DO 791 817 ! 792 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 818 IF ( l_1st_euler .AND. Agrif_Nb_Step() == 0 ) THEN 819 !!gm IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 793 820 vb(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) 794 821 ENDIF … … 801 828 802 829 SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 803 !!--------------------------------------------- 804 !! *** ROUTINE correct_u_bdy ***805 !!--------------------------------------------- 830 !!---------------------------------------------------------------------- 831 !! *** ROUTINE correct_v_bdy *** 832 !!---------------------------------------------------------------------- 806 833 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 807 834 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres … … 813 840 INTEGER :: ji, jk 814 841 REAL(wp) :: zcor 815 !!--------------------------------------------- 842 !!---------------------------------------------------------------------- 816 843 ! 817 844 IF( .NOT.before ) THEN … … 847 874 SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before ) 848 875 !!---------------------------------------------------------------------- 849 !! 876 !! *** ROUTINE updateu2d *** 850 877 !!---------------------------------------------------------------------- 851 878 INTEGER , INTENT(in ) :: i1, i2, j1, j2 852 879 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 853 880 LOGICAL , INTENT(in ) :: before 854 ! !881 ! 855 882 INTEGER :: ji, jj, jk 856 883 REAL(wp) :: zrhoy 857 884 REAL(wp) :: zcorr 858 !!--------------------------------------------- 885 !!---------------------------------------------------------------------- 859 886 ! 860 887 IF( before ) THEN … … 883 910 ! Update barotropic velocities: 884 911 IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 885 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 912 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) THEN ! Add asselin part 913 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 886 914 zcorr = (tabres(ji,jj) - un_b(ji,jj) * hu_a(ji,jj)) * r1_hu_b(ji,jj) 887 915 ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1) … … 904 932 END DO 905 933 ! 906 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 934 IF ( l_1st_euler .AND. Agrif_Nb_Step() == 0 ) THEN 935 !!gm IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 907 936 ub_b(i1:i2,j1:j2) = un_b(i1:i2,j1:j2) 908 937 ENDIF … … 948 977 ! 949 978 ! Update barotropic velocities: 950 IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 951 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 979 IF ( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. .NOT.ln_bt_fw ) ) THEN 980 IF ( .NOT.( lk_agrif_fstep. AND. l_1st_euler ) ) THEN ! Add asselin part 981 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 952 982 zcorr = (tabres(ji,jj) - vn_b(ji,jj) * hv_a(ji,jj)) * r1_hv_b(ji,jj) 953 983 vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1) … … 970 1000 END DO 971 1001 ! 972 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 1002 IF ( l_1st_euler .AND. Agrif_Nb_Step() == 0 ) THEN 1003 !!gm IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 973 1004 vb_b(i1:i2,j1:j2) = vn_b(i1:i2,j1:j2) 974 1005 ENDIF … … 986 1017 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 987 1018 LOGICAL , INTENT(in ) :: before 988 ! !1019 ! 989 1020 INTEGER :: ji, jj 990 1021 !!---------------------------------------------------------------------- … … 997 1028 END DO 998 1029 ELSE 999 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 1030 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) THEN 1031 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 1000 1032 DO jj=j1,j2 1001 1033 DO ji=i1,i2 … … 1012 1044 END DO 1013 1045 ! 1014 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 1046 IF ( l_1st_euler .AND. Agrif_Nb_Step() == 0 ) THEN 1047 !!gm IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 1015 1048 sshb(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 1016 1049 ENDIF 1017 1050 ! 1018 1019 1051 ENDIF 1020 1052 ! … … 1062 1094 END SUBROUTINE updateub2b 1063 1095 1096 1064 1097 SUBROUTINE reflux_sshu( tabres, i1, i2, j1, j2, before, nb, ndir ) 1065 !!--------------------------------------------- 1066 !! *** ROUTINE reflux_sshu ***1067 !!--------------------------------------------- 1068 INTEGER , INTENT(in) ::i1, i2, j1, j21069 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres1070 LOGICAL , INTENT(in) ::before1071 INTEGER , INTENT(in) ::nb, ndir1072 ! !1073 LOGICAL :: western_side, eastern_side1074 INTEGER :: ji, jj1075 REAL(wp) ::zrhoy, za1, zcor1076 !!--------------------------------------------- 1098 !!---------------------------------------------------------------------- 1099 !! *** ROUTINE reflux_sshu *** 1100 !!---------------------------------------------------------------------- 1101 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1102 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1103 LOGICAL , INTENT(in ) :: before 1104 INTEGER , INTENT(in ) :: nb, ndir 1105 ! 1106 LOGICAL :: western_side, eastern_side 1107 INTEGER :: ji, jj 1108 REAL(wp):: zrhoy, za1, zcor 1109 !!---------------------------------------------------------------------- 1077 1110 ! 1078 1111 IF (before) THEN … … 1091 1124 eastern_side = (nb == 1).AND.(ndir == 2) 1092 1125 ! 1093 IF ( western_side) THEN1126 IF ( western_side ) THEN 1094 1127 DO jj=j1,j2 1095 1128 zcor = rdt * r1_e1e2t(i1 ,jj) * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj)) 1096 1129 sshn(i1 ,jj) = sshn(i1 ,jj) + zcor 1097 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i1 ,jj) = sshb(i1 ,jj) + atfp * zcor 1098 END DO 1099 ENDIF 1100 IF (eastern_side) THEN 1130 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) sshb(i1 ,jj) = sshb(i1 ,jj) + atfp * zcor 1131 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i1 ,jj) = sshb(i1 ,jj) + atfp * zcor 1132 END DO 1133 ENDIF 1134 IF ( eastern_side ) THEN 1101 1135 DO jj=j1,j2 1102 1136 zcor = - rdt * r1_e1e2t(i2+1,jj) * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj)) 1103 1137 sshn(i2+1,jj) = sshn(i2+1,jj) + zcor 1104 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i2+1,jj) = sshb(i2+1,jj) + atfp * zcor 1138 IF (.NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) sshb(i2+1,jj) = sshb(i2+1,jj) + atfp * zcor 1139 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i2+1,jj) = sshb(i2+1,jj) + atfp * zcor 1105 1140 END DO 1106 1141 ENDIF … … 1110 1145 END SUBROUTINE reflux_sshu 1111 1146 1147 1112 1148 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 1113 1149 !!---------------------------------------------------------------------- 1114 !! 1150 !! *** ROUTINE updatevb2b *** 1115 1151 !!---------------------------------------------------------------------- 1116 1152 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1117 1153 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1118 1154 LOGICAL , INTENT(in ) :: before 1119 ! !1155 ! 1120 1156 INTEGER :: ji, jj 1121 1157 REAL(wp) :: zrhox, za1, zcor 1122 !!--------------------------------------------- 1158 !!--------------------------------------------------------------------- 1123 1159 ! 1124 1160 IF( before ) THEN … … 1150 1186 END SUBROUTINE updatevb2b 1151 1187 1188 1152 1189 SUBROUTINE reflux_sshv( tabres, i1, i2, j1, j2, before, nb, ndir ) 1153 !!--------------------------------------------- 1154 !! *** ROUTINE reflux_sshv ***1155 !!--------------------------------------------- 1156 INTEGER , INTENT(in) ::i1, i2, j1, j21157 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres1158 LOGICAL , INTENT(in) ::before1159 INTEGER , INTENT(in) ::nb, ndir1190 !!---------------------------------------------------------------------- 1191 !! *** ROUTINE reflux_sshv *** 1192 !!---------------------------------------------------------------------- 1193 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1194 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1195 LOGICAL , INTENT(in ) :: before 1196 INTEGER , INTENT(in ) :: nb, ndir 1160 1197 !! 1161 1198 LOGICAL :: southern_side, northern_side 1162 1199 INTEGER :: ji, jj 1163 1200 REAL(wp) :: zrhox, za1, zcor 1164 !!--------------------------------------------- 1201 !!---------------------------------------------------------------------- 1165 1202 ! 1166 1203 IF (before) THEN … … 1183 1220 zcor = rdt * r1_e1e2t(ji,j1 ) * e1v(ji,j1 ) * (vb2_b(ji,j1)-tabres(ji,j1)) 1184 1221 sshn(ji,j1 ) = sshn(ji,j1 ) + zcor 1185 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j1 ) = sshb(ji,j1) + atfp * zcor 1222 IF ( .NOT.( lk_agrif_fstep .AND. l_euler ) ) sshb(ji,j1 ) = sshb(ji,j1) + atfp * zcor 1223 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j1 ) = sshb(ji,j1) + atfp * zcor 1186 1224 END DO 1187 1225 ENDIF … … 1190 1228 zcor = - rdt * r1_e1e2t(ji,j2+1) * e1v(ji,j2 ) * (vb2_b(ji,j2)-tabres(ji,j2)) 1191 1229 sshn(ji,j2+1) = sshn(ji,j2+1) + zcor 1192 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j2+1) = sshb(ji,j2+1) + atfp * zcor 1230 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler ) ) sshb(ji,j2+1) = sshb(ji,j2+1) + atfp * zcor 1231 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j2+1) = sshb(ji,j2+1) + atfp * zcor 1193 1232 END DO 1194 1233 ENDIF … … 1198 1237 END SUBROUTINE reflux_sshv 1199 1238 1239 1200 1240 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 1241 !!---------------------------------------------------------------------- 1242 !! *** ROUTINE updateT *** 1201 1243 ! 1202 1244 ! ====>>>>>>>>>> currently not used 1203 1245 ! 1204 !!----------------------------------------------------------------------1205 !! *** ROUTINE updateT ***1206 1246 !!---------------------------------------------------------------------- 1207 1247 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 … … 1284 1324 1285 1325 SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 1286 !!--------------------------------------------- 1287 !! *** ROUTINE updateavm ***1326 !!---------------------------------------------------------------------- 1327 !! *** ROUTINE updateavm *** 1288 1328 !!---------------------------------------------------------------------- 1289 1329 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 … … 1298 1338 END SUBROUTINE updateAVM 1299 1339 1340 1300 1341 SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before ) 1301 !!--------------------------------------------- 1302 !! *** ROUTINE updatee3t ***1303 !!--------------------------------------------- 1342 !!---------------------------------------------------------------------- 1343 !! *** ROUTINE updatee3t *** 1344 !!---------------------------------------------------------------------- 1304 1345 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ptab_dum 1305 1346 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 … … 1313 1354 IF (.NOT.before) THEN 1314 1355 ! 1315 ALLOCATE( ptab(i1:i2,j1:j2,1:jpk))1356 ALLOCATE( ptab(i1:i2,j1:j2,1:jpk) ) 1316 1357 ! 1317 1358 ! Update e3t from ssh (z* case only) … … 1335 1376 ! hdivn(i1:i2,j1:j2,1:jpkm1) = e3t_b(i1:i2,j1:j2,1:jpkm1) 1336 1377 1337 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN 1378 IF ( .NOT.( lk_agrif_fstep .AND. l_1st_euler==0 ) ) THEN 1379 !!gm IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN 1338 1380 DO jk = 1, jpkm1 1339 1381 DO jj=j1,j2 … … 1398 1440 END DO 1399 1441 ! 1400 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 1442 IF ( l_1st_euler .AND. Agrif_Nb_Step()==0 ) THEN 1443 !!gm IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 1401 1444 e3t_b (i1:i2,j1:j2,1:jpk) = e3t_n (i1:i2,j1:j2,1:jpk) 1402 1445 e3w_b (i1:i2,j1:j2,1:jpk) = e3w_n (i1:i2,j1:j2,1:jpk)
Note: See TracChangeset
for help on using the changeset viewer.
