- Timestamp:
- 2019-12-11T16:56:06+01:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r12072_MERGE_OPTION2_2019/src/NST/agrif_oce_update.F90
r10068 r12191 1 # define TWO_WAY /* TWO WAY NESTING*/2 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/3 #undef VOL_REFLUX /* VOLUME REFLUXING*/1 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES */ 2 #undef DECAL_FEEDBACK_2D /* SEPARATION of INTERFACES (Barotropic mode) */ 3 #undef VOL_REFLUX /* VOLUME REFLUXING*/ 4 4 5 5 MODULE agrif_oce_update … … 25 25 USE lib_mpp ! MPP library 26 26 USE domvvl ! Need interpolation routines 27 USE vremap ! Vertical remapping 27 28 28 29 IMPLICIT NONE … … 46 47 IF (Agrif_Root()) RETURN 47 48 ! 48 #if defined TWO_WAY49 49 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers from grid Number',Agrif_Fixed() 50 50 51 #if defined key_vertical 52 ! Effect of this has to be carrefully checked 53 ! depending on what the nesting tools ensure for 54 ! volume conservation: 55 Agrif_UseSpecialValueInUpdate = .FALSE. 56 #else 51 57 Agrif_UseSpecialValueInUpdate = .TRUE. 58 #endif 52 59 Agrif_SpecialValueFineGrid = 0._wp 53 60 ! … … 64 71 Agrif_UseSpecialValueInUpdate = .FALSE. 65 72 ! 66 #endif67 73 ! 68 74 END SUBROUTINE Agrif_Update_Tra … … 75 81 IF (Agrif_Root()) RETURN 76 82 ! 77 #if defined TWO_WAY78 83 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed() 79 84 … … 95 100 # endif 96 101 97 # if ! defined DECAL_FEEDBACK 102 # if ! defined DECAL_FEEDBACK_2D 98 103 CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 99 104 CALL Agrif_Update_Variable(e2v_id,procname = updateV2d) … … 103 108 # endif 104 109 ! 105 # if ! defined DECAL_FEEDBACK 110 # if ! defined DECAL_FEEDBACK_2D 106 111 ! Account for updated thicknesses at boundary edges 107 112 IF (.NOT.ln_linssh) THEN … … 113 118 IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN 114 119 ! Update time integrated transports 115 # if ! defined DECAL_FEEDBACK 120 # if ! defined DECAL_FEEDBACK_2D 116 121 CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 117 122 CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) … … 121 126 # endif 122 127 END IF 123 #endif124 128 ! 125 129 END SUBROUTINE Agrif_Update_Dyn … … 131 135 ! 132 136 IF (Agrif_Root()) RETURN 133 !134 #if defined TWO_WAY135 137 ! 136 138 Agrif_UseSpecialValueInUpdate = .TRUE. 137 139 Agrif_SpecialValueFineGrid = 0. 138 # if ! defined DECAL_FEEDBACK 140 # if ! defined DECAL_FEEDBACK_2D 139 141 CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 140 142 # else … … 147 149 IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 148 150 ! Refluxing on ssh: 149 # if defined DECAL_FEEDBACK 151 # if defined DECAL_FEEDBACK_2D 150 152 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0, 0/),locupdate2=(/1, 1/),procname = reflux_sshu) 151 153 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1, 1/),locupdate2=(/0, 0/),procname = reflux_sshv) … … 157 159 # endif 158 160 ! 159 #endif160 !161 161 END SUBROUTINE Agrif_Update_ssh 162 162 … … 170 170 IF (Agrif_Root()) RETURN 171 171 ! 172 # if defined TWO_WAY173 174 172 Agrif_UseSpecialValueInUpdate = .TRUE. 175 173 Agrif_SpecialValueFineGrid = 0. … … 180 178 181 179 Agrif_UseSpecialValueInUpdate = .FALSE. 182 183 # endif184 180 185 181 END SUBROUTINE Agrif_Update_Tke … … 192 188 ! 193 189 IF (Agrif_Root()) RETURN 194 !195 #if defined TWO_WAY196 190 ! 197 191 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step() … … 209 203 CALL dom_vvl_update_UVF 210 204 CALL Agrif_ParentGrid_To_ChildGrid() 211 !212 #endif213 205 ! 214 206 END SUBROUTINE Agrif_Update_vvl … … 300 292 !! 301 293 INTEGER :: ji,jj,jk,jn 302 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child 294 INTEGER :: N_in, N_out 295 REAL(wp) :: ztb, ztnu, ztno 303 296 REAL(wp) :: h_in(k1:k2) 304 297 REAL(wp) :: h_out(1:jpk) 305 INTEGER :: N_in, N_out 306 REAL(wp) :: zrho_xy, h_diff 307 REAL(wp) :: tabin(k1:k2,n1:n2) 298 REAL(wp) :: tabin(k1:k2,1:jpts) 299 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jpts) :: tabres_child 308 300 !!--------------------------------------------- 309 301 ! 310 302 IF (before) THEN 311 AGRIF_SpecialValue = -999._wp 312 zrho_xy = Agrif_rhox() * Agrif_rhoy() 303 !jc_alt 304 ! AGRIF_SpecialValue = -999._wp 313 305 DO jn = n1,n2-1 314 306 DO jk=k1,k2 315 307 DO jj=j1,j2 316 308 DO ji=i1,i2 317 tabres(ji,jj,jk,jn) = (tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) & 318 * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp 309 !jc_alt 310 ! tabres(ji,jj,jk,jn) = (tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) & 311 ! & * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1._wp) * 999._wp 312 tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) 319 313 END DO 320 314 END DO … … 324 318 DO jj=j1,j2 325 319 DO ji=i1,i2 326 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) & 327 + (tmask(ji,jj,jk)-1)*999._wp 320 !jc_alt 321 ! tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) & 322 ! & + (tmask(ji,jj,jk) - 1._wp) * 999._wp 323 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 328 324 END DO 329 325 END DO 330 326 END DO 331 327 ELSE 332 tabres_child(:,:,:,:) = 0. 328 tabres_child(:,:,:,:) = 0._wp 333 329 AGRIF_SpecialValue = 0._wp 334 330 DO jj=j1,j2 … … 336 332 N_in = 0 337 333 DO jk=k1,k2 !k2 = jpk of child grid 338 IF (tabres(ji,jj,jk,n2) == 0 ) EXIT 334 ! jc_alt 335 ! IF (tabres(ji,jj,jk,n2) < -900._wp ) EXIT 336 IF (tabres(ji,jj,jk,n2) == 0._wp ) EXIT 339 337 N_in = N_in + 1 340 338 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) … … 343 341 N_out = 0 344 342 DO jk=1,jpk ! jpk of parent grid 345 IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF343 IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF 346 344 N_out = N_out + 1 347 345 h_out(N_out) = e3t_n(ji,jj,jk) 348 346 ENDDO 349 IF (N_in > 0) THEN !Remove this? 350 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 351 IF (h_diff < -1.e-4) THEN 352 print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out)) 353 print *,h_in(1:N_in) 354 print *,h_out(1:N_out) 355 STOP 356 ENDIF 357 DO jn=n1,n2-1 358 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 ENDDO 347 IF (N_in*N_out > 0) THEN !Remove this? 348 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 360 349 ENDIF 361 350 ENDDO … … 364 353 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 365 354 ! Add asselin part 366 DO jn = n1,n2-1 367 DO jk=1,jpk 368 DO jj=j1,j2 369 DO ji=i1,i2 370 IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 371 tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 372 & + atfp * ( tabres_child(ji,jj,jk,jn) & 373 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 355 DO jn = 1,jpts 356 DO jk = 1, jpkm1 357 DO jj = j1, j2 358 DO ji = i1, i2 359 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 360 ztb = tsb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used 361 ztnu = tabres_child(ji,jj,jk,jn) * e3t_n(ji,jj,jk) 362 ztno = tsn(ji,jj,jk,jn) * e3t_a(ji,jj,jk) 363 tsb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) ) & 364 & * tmask(ji,jj,jk) / e3t_b(ji,jj,jk) 374 365 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.) THEN385 tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk)366 END DO 367 END DO 368 END DO 369 END DO 370 ENDIF 371 DO jn = 1,jpts 372 DO jk = 1, jpkm1 373 DO jj = j1, j2 374 DO ji = i1, i2 375 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 376 tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) 386 377 END IF 387 378 END DO … … 389 380 END DO 390 381 END DO 382 ! 383 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 384 tsb(i1:i2,j1:j2,1:jpkm1,1:jpts) = tsn(i1:i2,j1:j2,1:jpkm1,1:jpts) 385 ENDIF 391 386 ENDIF 392 387 ! … … 478 473 ! 479 474 INTEGER :: ji, jj, jk 480 REAL(wp):: zrhoy 475 REAL(wp):: zrhoy, zub, zunu, zuno 481 476 ! VERTICAL REFINEMENT BEGIN 482 477 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child … … 491 486 IF( before ) THEN 492 487 zrhoy = Agrif_Rhoy() 493 AGRIF_SpecialValue = -999._wp 488 !jc_alt 489 ! AGRIF_SpecialValue = -999._wp 494 490 DO jk=k1,k2 495 491 DO jj=j1,j2 496 492 DO ji=i1,i2 497 tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk) & 498 + (umask(ji,jj,jk)-1)*999._wp 499 tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk) & 500 + (umask(ji,jj,jk)-1)*999._wp 493 !jc_alt 494 ! tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk) & 495 ! & + (umask(ji,jj,jk)-1._wp)*999._wp 496 tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk) 497 !jc_alt 498 ! tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk) & 499 ! & + (umask(ji,jj,jk)-1._wp)*999._wp 500 tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk) 501 501 END DO 502 502 END DO … … 511 511 tabin(:) = 0._wp 512 512 DO jk=k1,k2 !k2=jpk of child grid 513 IF( tabres(ji,jj,jk,2) < -900) EXIT 513 !jc_alt 514 ! IF( tabres(ji,jj,jk,2) < -900._wp) EXIT 515 IF( tabres(ji,jj,jk,2) == 0.) EXIT 514 516 N_in = N_in + 1 515 517 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) … … 524 526 IF (N_in * N_out > 0) THEN 525 527 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 528 excess = 0._wp 526 529 IF (h_diff < -1.e-4) THEN 527 530 !Even if bathy at T points match it's possible for the U points to be deeper in the child grid. 528 531 !In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. 529 excess = 0._wp530 532 DO jk=N_in,1,-1 531 533 thick = MIN(-1*h_diff, h_in(jk)) … … 540 542 ENDDO 541 543 ENDIF 542 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 )544 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,1) 543 545 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out)) 544 546 ENDIF 545 547 ENDDO 546 548 ENDDO 547 549 ! 548 550 DO jk=1,jpk 549 551 DO jj=j1,j2 550 552 DO ji=i1,i2 551 553 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 552 ub(ji,jj,jk) = ub(ji,jj,jk) & 553 & + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 554 zub = ub(ji,jj,jk) * e3u_b(ji,jj,jk) ! fse3t_b prior update should be used 555 zuno = un(ji,jj,jk) * e3u_a(ji,jj,jk) 556 zunu = tabres_child(ji,jj,jk) * e3u_n(ji,jj,jk) 557 ub(ji,jj,jk) = ( zub + atfp * ( zunu - zuno) ) & 558 & * umask(ji,jj,jk) / e3u_b(ji,jj,jk) 554 559 ENDIF 555 560 ! … … 558 563 END DO 559 564 END DO 565 ! 566 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 567 ub(i1:i2,j1:j2,1:jpkm1) = un(i1:i2,j1:j2,1:jpkm1) 568 ENDIF 569 ! 560 570 ENDIF 561 571 ! … … 665 675 ! 666 676 INTEGER :: ji, jj, jk 667 REAL(wp) :: zrhox 677 REAL(wp) :: zrhox, zvb, zvnu, zvno 668 678 ! VERTICAL REFINEMENT BEGIN 669 679 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child … … 678 688 IF( before ) THEN 679 689 zrhox = Agrif_Rhox() 680 AGRIF_SpecialValue = -999._wp 690 !jc_alt 691 ! AGRIF_SpecialValue = -999._wp 681 692 DO jk=k1,k2 682 693 DO jj=j1,j2 683 694 DO ji=i1,i2 684 tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk) & 685 + (vmask(ji,jj,jk)-1)*999._wp 686 tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) & 687 + (vmask(ji,jj,jk)-1)*999._wp 695 !jc_alt 696 ! tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk) & 697 ! & + (vmask(ji,jj,jk)-1._wp) * 999._wp 698 tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk) 699 !jc_alt 700 ! tabres(ji,jj,jk,2) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) & 701 ! & + (vmask(ji,jj,jk)-1._wp) * 999._wp 702 tabres(ji,jj,jk,2) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) 688 703 END DO 689 704 END DO … … 696 711 N_in = 0 697 712 DO jk=k1,k2 698 IF (tabres(ji,jj,jk,2) < -900) EXIT 713 !jc_alt 714 ! IF (tabres(ji,jj,jk,2) < -900._wp) EXIT 715 IF (tabres(ji,jj,jk,2) == 0) EXIT 699 716 N_in = N_in + 1 700 717 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) … … 709 726 IF (N_in * N_out > 0) THEN 710 727 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 728 excess = 0._wp 711 729 IF (h_diff < -1.e-4) then 712 !Even if bathy at T points match it's possible for the Upoints to be deeper in the child grid.730 !Even if bathy at T points match it's possible for the V points to be deeper in the child grid. 713 731 !In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. 714 excess = 0._wp715 732 DO jk=N_in,1,-1 716 733 thick = MIN(-1*h_diff, h_in(jk)) … … 725 742 ENDDO 726 743 ENDIF 727 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 )744 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,1) 728 745 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out)) 729 746 ENDIF 730 747 ENDDO 731 748 ENDDO 732 733 DO jk=1,jpk 749 ! 750 DO jk=1,jpkm1 734 751 DO jj=j1,j2 735 752 DO ji=i1,i2 736 ! 737 IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part 738 vb(ji,jj,jk) = vb(ji,jj,jk) & 739 & + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 753 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 754 zvb = vb(ji,jj,jk) * e3v_b(ji,jj,jk) ! fse3t_b prior update should be used 755 zvno = vn(ji,jj,jk) * e3v_a(ji,jj,jk) 756 zvnu = tabres_child(ji,jj,jk) * e3v_n(ji,jj,jk) 757 vb(ji,jj,jk) = ( zvb + atfp * ( zvnu - zvno) ) & 758 & * vmask(ji,jj,jk) / e3v_b(ji,jj,jk) 740 759 ENDIF 741 760 ! … … 744 763 END DO 745 764 END DO 765 ! 766 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 767 vb(i1:i2,j1:j2,1:jpkm1) = vn(i1:i2,j1:j2,1:jpkm1) 768 ENDIF 769 ! 746 770 ENDIF 747 771 !
Note: See TracChangeset
for help on using the changeset viewer.
