Changeset 9817 for branches/UKMO/dev_r5518_nemo2cice_prints/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90
- Timestamp:
- 2018-06-21T11:58:42+02:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_nemo2cice_prints/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90
r9816 r9817 9 9 !! 3.4 ! 09-2012 (R. Benshila, C. Herbaut) update and EVP 10 10 !!---------------------------------------------------------------------- 11 #if defined key_agrif && defined key_lim2 11 #if defined key_agrif && defined key_lim2 12 12 !!---------------------------------------------------------------------- 13 13 !! 'key_lim2' : LIM 2.0 sea-ice model … … 41 41 PUBLIC interp_adv_ice 42 42 43 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PRIVATE :: uice_agr, vice_agr 44 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: tabice_agr 45 46 43 47 !!---------------------------------------------------------------------- 44 48 !! NEMO/NST 3.4 , NEMO Consortium (2012) … … 65 69 u_ice_nst(:,:) = 0. 66 70 v_ice_nst(:,:) = 0. 67 CALL Agrif_Bc_variable( u_ice_ nst, u_ice_id ,procname=interp_u_ice, calledweight=1. )68 CALL Agrif_Bc_variable( v_ice_ nst, v_ice_id ,procname=interp_v_ice, calledweight=1. )71 CALL Agrif_Bc_variable( u_ice_id ,procname=interp_u_ice, calledweight=1. ) 72 CALL Agrif_Bc_variable( v_ice_id ,procname=interp_v_ice, calledweight=1. ) 69 73 Agrif_SpecialValue=0. 70 74 Agrif_UseSpecialValue = .FALSE. … … 138 142 !! we are in inside a new parent ice time step 139 143 !!----------------------------------------------------------------------- 140 REAL(wp), DIMENSION(jpi,jpj) :: zuice, zvice141 144 INTEGER :: ji,jj 142 145 REAL(wp) :: zrhox, zrhoy … … 155 158 Agrif_SpecialValue=-9999. 156 159 Agrif_UseSpecialValue = .TRUE. 157 zuice = 0. 158 zvice = 0. 159 CALL Agrif_Bc_variable(zuice,u_ice_id,procname=interp_u_ice, calledweight=1.) 160 CALL Agrif_Bc_variable(zvice,v_ice_id,procname=interp_v_ice, calledweight=1.) 160 IF( .NOT. ALLOCATED(uice_agr) )THEN 161 ALLOCATE(uice_agr(jpi,jpj), vice_agr(jpi,jpj)) 162 ENDIF 163 uice_agr = 0. 164 vice_agr = 0. 165 CALL Agrif_Bc_variable(u_ice_id,procname=interp_u_ice, calledweight=1.) 166 CALL Agrif_Bc_variable(v_ice_id,procname=interp_v_ice, calledweight=1.) 161 167 Agrif_SpecialValue=0. 162 168 Agrif_UseSpecialValue = .FALSE. 163 169 ! 164 170 zrhox = agrif_rhox() ; zrhoy = agrif_rhoy() 165 zuice(:,:) = zuice(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1)166 zvice(:,:) = zvice(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1)171 uice_agr(:,:) = uice_agr(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 172 vice_agr(:,:) = vice_agr(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 167 173 ! fill boundaries 168 174 DO jj = 1, jpj 169 175 DO ji = 1, 2 170 u_ice_oe(ji, jj,2) = zuice(ji ,jj)171 u_ice_oe(ji+2,jj,2) = zuice(nlci+ji-3,jj)176 u_ice_oe(ji, jj,2) = uice_agr(ji ,jj) 177 u_ice_oe(ji+2,jj,2) = uice_agr(nlci+ji-3,jj) 172 178 END DO 173 179 END DO 174 180 DO jj = 1, jpj 175 v_ice_oe(2,jj,2) = zvice(2 ,jj)176 v_ice_oe(4,jj,2) = zvice(nlci-1,jj)181 v_ice_oe(2,jj,2) = vice_agr(2 ,jj) 182 v_ice_oe(4,jj,2) = vice_agr(nlci-1,jj) 177 183 END DO 178 184 DO ji = 1, jpi 179 u_ice_sn(ji,2,2) = zuice(ji,2 )180 u_ice_sn(ji,4,2) = zuice(ji,nlcj-1)185 u_ice_sn(ji,2,2) = uice_agr(ji,2 ) 186 u_ice_sn(ji,4,2) = uice_agr(ji,nlcj-1) 181 187 END DO 182 188 DO jj = 1, 2 183 189 DO ji = 1, jpi 184 v_ice_sn(ji,jj ,2) = zvice(ji,jj )185 v_ice_sn(ji,jj+2,2) = zvice(ji,nlcj+jj-3)190 v_ice_sn(ji,jj ,2) = vice_agr(ji,jj ) 191 v_ice_sn(ji,jj+2,2) = vice_agr(ji,nlcj+jj-3) 186 192 END DO 187 193 END DO … … 334 340 !! we are in inside a new parent ice time step 335 341 !!----------------------------------------------------------------------- 336 REAL(wp), DIMENSION(jpi,jpj,7) :: ztab337 342 INTEGER :: ji,jj,jn 338 343 !!----------------------------------------------------------------------- … … 345 350 adv_ice_sn(:,:,:,1) = adv_ice_sn(:,:,:,2) 346 351 ! interpolation of boundaries 347 ztab(:,:,:) = 0. 352 IF(.NOT.ALLOCATED(tabice_agr))THEN 353 ALLOCATE(tabice_agr(jpi,jpj,7)) 354 ENDIF 355 tabice_agr(:,:,:) = 0. 348 356 Agrif_SpecialValue=-9999. 349 357 Agrif_UseSpecialValue = .TRUE. 350 CALL Agrif_Bc_variable( ztab,adv_ice_id ,procname=interp_adv_ice,calledweight=1. )358 CALL Agrif_Bc_variable( adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 351 359 Agrif_SpecialValue=0. 352 360 Agrif_UseSpecialValue = .FALSE. … … 356 364 DO jj = 1, jpj 357 365 DO ji=1,2 358 adv_ice_oe(ji ,jj,jn,2) = ztab(ji ,jj,jn)359 adv_ice_oe(ji+2,jj,jn,2) = ztab(nlci-2+ji,jj,jn)366 adv_ice_oe(ji ,jj,jn,2) = tabice_agr(ji ,jj,jn) 367 adv_ice_oe(ji+2,jj,jn,2) = tabice_agr(nlci-2+ji,jj,jn) 360 368 END DO 361 369 END DO … … 365 373 Do jj =1,2 366 374 DO ji = 1, jpi 367 adv_ice_sn(ji,jj ,jn,2) = ztab(ji,jj ,jn)368 adv_ice_sn(ji,jj+2,jn,2) = ztab(ji,nlcj-2+jj,jn)375 adv_ice_sn(ji,jj ,jn,2) = tabice_agr(ji,jj ,jn) 376 adv_ice_sn(ji,jj+2,jn,2) = tabice_agr(ji,nlcj-2+jj,jn) 369 377 END DO 370 378 END DO … … 384 392 INTEGER :: ji,jj,jn 385 393 REAL(wp) :: zalpha 386 REAL(wp), DIMENSION(jpi,jpj,7) :: ztab387 394 !!----------------------------------------------------------------------- 388 395 ! … … 391 398 zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) 392 399 ! 393 ztab(:,:,:) = 0.e0400 tabice_agr(:,:,:) = 0.e0 394 401 DO jn =1,7 395 402 DO jj =1,2 396 403 DO ji = 1, jpi 397 ztab(ji,jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj ,jn,1) + zalpha*adv_ice_sn(ji,jj ,jn,2)398 ztab(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)404 tabice_agr(ji,jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj ,jn,1) + zalpha*adv_ice_sn(ji,jj ,jn,2) 405 tabice_agr(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2) 399 406 END DO 400 407 END DO … … 404 411 DO jj = 1, jpj 405 412 DO ji=1,2 406 ztab(ji ,jj,jn) = (1-zalpha)*adv_ice_oe(ji ,jj,jn,1) + zalpha*adv_ice_oe(ji ,jj,jn,2)407 ztab(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)413 tabice_agr(ji ,jj,jn) = (1-zalpha)*adv_ice_oe(ji ,jj,jn,1) + zalpha*adv_ice_oe(ji ,jj,jn,2) 414 tabice_agr(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2) 408 415 END DO 409 416 END DO 410 417 END DO 411 418 ! 412 CALL parcoursT( ztab(:,:, 1), frld )413 CALL parcoursT( ztab(:,:, 2), hicif )414 CALL parcoursT( ztab(:,:, 3), hsnif )415 CALL parcoursT( ztab(:,:, 4), tbif(:,:,1) )416 CALL parcoursT( ztab(:,:, 5), tbif(:,:,2) )417 CALL parcoursT( ztab(:,:, 6), tbif(:,:,3) )418 CALL parcoursT( ztab(:,:, 7), qstoif )419 CALL parcoursT( tabice_agr(:,:, 1), frld ) 420 CALL parcoursT( tabice_agr(:,:, 2), hicif ) 421 CALL parcoursT( tabice_agr(:,:, 3), hsnif ) 422 CALL parcoursT( tabice_agr(:,:, 4), tbif(:,:,1) ) 423 CALL parcoursT( tabice_agr(:,:, 5), tbif(:,:,2) ) 424 CALL parcoursT( tabice_agr(:,:, 6), tbif(:,:,3) ) 425 CALL parcoursT( tabice_agr(:,:, 7), qstoif ) 419 426 ! 420 427 END SUBROUTINE agrif_trp_lim2 … … 499 506 500 507 501 SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2 )508 SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2, before ) 502 509 !!----------------------------------------------------------------------- 503 510 !! *** ROUTINE interp_u_ice *** … … 505 512 INTEGER, INTENT(in) :: i1, i2, j1, j2 506 513 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 514 LOGICAL, INTENT(in) :: before 507 515 !! 508 516 INTEGER :: ji,jj … … 510 518 ! 511 519 #if defined key_lim2_vp 512 DO jj=MAX(j1,2),j2 513 DO ji=MAX(i1,2),i2 514 IF( tmu(ji,jj) == 0. ) THEN 515 tabres(ji,jj) = -9999. 516 ELSE 517 tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 518 ENDIF 519 END DO 520 END DO 520 IF( before ) THEN 521 DO jj=MAX(j1,2),j2 522 DO ji=MAX(i1,2),i2 523 IF( tmu(ji,jj) == 0. ) THEN 524 tabres(ji,jj) = -9999. 525 ELSE 526 tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 527 ENDIF 528 END DO 529 END DO 530 ELSE 531 DO jj=MAX(j1,2),j2 532 DO ji=MAX(i1,2),i2 533 uice_agr(ji,jj) = tabres(ji,jj) 534 END DO 535 END DO 536 ENDIF 521 537 #else 522 DO jj= j1, j2 523 DO ji= i1, i2 524 IF( umask(ji,jj,1) == 0. ) THEN 525 tabres(ji,jj) = -9999. 526 ELSE 527 tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 528 ENDIF 529 END DO 530 END DO 538 IF( before ) THEN 539 DO jj= j1, j2 540 DO ji= i1, i2 541 IF( umask(ji,jj,1) == 0. ) THEN 542 tabres(ji,jj) = -9999. 543 ELSE 544 tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 545 ENDIF 546 END DO 547 END DO 548 ELSE 549 DO jj= j1, j2 550 DO ji= i1, i2 551 uice_agr(ji,jj) = tabres(ji,jj) 552 END DO 553 END DO 554 ENDIF 531 555 #endif 532 556 END SUBROUTINE interp_u_ice 533 557 534 558 535 SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2 )559 SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2, before ) 536 560 !!----------------------------------------------------------------------- 537 561 !! *** ROUTINE interp_v_ice *** … … 539 563 INTEGER, INTENT(in) :: i1, i2, j1, j2 540 564 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 565 LOGICAL, INTENT(in) :: before 541 566 !! 542 567 INTEGER :: ji, jj … … 544 569 ! 545 570 #if defined key_lim2_vp 546 DO jj=MAX(j1,2),j2 547 DO ji=MAX(i1,2),i2 548 IF( tmu(ji,jj) == 0. ) THEN 549 tabres(ji,jj) = -9999. 550 ELSE 551 tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 552 ENDIF 553 END DO 554 END DO 571 IF( before ) THEN 572 DO jj=MAX(j1,2),j2 573 DO ji=MAX(i1,2),i2 574 IF( tmu(ji,jj) == 0. ) THEN 575 tabres(ji,jj) = -9999. 576 ELSE 577 tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 578 ENDIF 579 END DO 580 END DO 581 ELSE 582 DO jj=MAX(j1,2),j2 583 DO ji=MAX(i1,2),i2 584 vice_agr(ji,jj) = tabres(ji,jj) 585 END DO 586 END DO 587 ENDIF 555 588 #else 556 DO jj= j1 ,j2 557 DO ji = i1, i2 558 IF( vmask(ji,jj,1) == 0. ) THEN 559 tabres(ji,jj) = -9999. 560 ELSE 561 tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 562 ENDIF 563 END DO 564 END DO 589 IF( before ) THEN 590 DO jj= j1 ,j2 591 DO ji = i1, i2 592 IF( vmask(ji,jj,1) == 0. ) THEN 593 tabres(ji,jj) = -9999. 594 ELSE 595 tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 596 ENDIF 597 END DO 598 END DO 599 ELSE 600 DO jj= j1 ,j2 601 DO ji = i1, i2 602 vice_agr(ji,jj) = tabres(ji,jj) 603 END DO 604 END DO 605 ENDIF 565 606 #endif 566 607 END SUBROUTINE interp_v_ice 567 608 568 609 569 SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2 )610 SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, k1, k2, before ) 570 611 !!----------------------------------------------------------------------- 571 612 !! *** ROUTINE interp_adv_ice *** … … 575 616 !! put -9999 where no ice for correct extrapolation 576 617 !!----------------------------------------------------------------------- 577 INTEGER, INTENT(in) :: i1, i2, j1, j2 578 REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres 618 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 619 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 620 LOGICAL, INTENT(in) :: before 579 621 !! 580 622 INTEGER :: ji, jj, jk 581 623 !!----------------------------------------------------------------------- 582 624 ! 583 DO jj=j1,j2 584 DO ji=i1,i2 585 IF( tms(ji,jj) == 0. ) THEN 586 tabres(ji,jj,:) = -9999. 587 ELSE 588 tabres(ji,jj, 1) = frld (ji,jj) 589 tabres(ji,jj, 2) = hicif (ji,jj) 590 tabres(ji,jj, 3) = hsnif (ji,jj) 591 tabres(ji,jj, 4) = tbif (ji,jj,1) 592 tabres(ji,jj, 5) = tbif (ji,jj,2) 593 tabres(ji,jj, 6) = tbif (ji,jj,3) 594 tabres(ji,jj, 7) = qstoif(ji,jj) 595 ENDIF 596 END DO 597 END DO 625 IF( before ) THEN 626 DO jj=j1,j2 627 DO ji=i1,i2 628 IF( tms(ji,jj) == 0. ) THEN 629 tabres(ji,jj,:) = -9999 630 ELSE 631 tabres(ji,jj, 1) = frld (ji,jj) 632 tabres(ji,jj, 2) = hicif (ji,jj) 633 tabres(ji,jj, 3) = hsnif (ji,jj) 634 tabres(ji,jj, 4) = tbif (ji,jj,1) 635 tabres(ji,jj, 5) = tbif (ji,jj,2) 636 tabres(ji,jj, 6) = tbif (ji,jj,3) 637 tabres(ji,jj, 7) = qstoif(ji,jj) 638 ENDIF 639 END DO 640 END DO 641 ELSE 642 DO jj=j1,j2 643 DO ji=i1,i2 644 DO jk=k1, k2 645 tabice_agr(ji,jj,jk) = tabres(ji,jj,jk) 646 END DO 647 END DO 648 END DO 649 ENDIF 598 650 ! 599 651 END SUBROUTINE interp_adv_ice
Note: See TracChangeset
for help on using the changeset viewer.
