Changeset 4789 for branches/2014/dev_r4765_CNRS_agrif
- Timestamp:
- 2014-09-25T18:26:34+02:00 (10 years ago)
- Location:
- branches/2014/dev_r4765_CNRS_agrif/NEMOGCM
- Files:
-
- 13 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/CONFIG/SHARED/1_namelist_ref
r4785 r4789 523 523 rn_sponge_tra = 2880. ! coefficient for tracer sponge layer [m2/s] 524 524 rn_sponge_dyn = 2880. ! coefficient for dynamics sponge layer [m2/s] 525 ln_chk_bathy = .FALSE. ! 526 ln_agrif_tle = .FALSE. 525 527 / 526 528 !----------------------------------------------------------------------- -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif2model.F90
r4785 r4789 1 1 #if defined key_agrif 2 3 !! NEMO/NST 3.3, NEMO Consortium (2010)4 5 6 7 8 9 10 11 2 !!---------------------------------------------------------------------- 3 !! NEMO/NST 3.6 , NEMO Consortium (2010) 4 !! $Id$ 5 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 6 !!---------------------------------------------------------------------- 7 SUBROUTINE Agrif2Model 8 !!--------------------------------------------- 9 !! *** ROUTINE Agrif2Model *** 10 !!--------------------------------------------- 11 END SUBROUTINE Agrif2model 12 12 13 14 15 16 17 18 13 SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 14 !!--------------------------------------------- 15 !! *** ROUTINE Agrif_Set_numberofcells *** 16 !!--------------------------------------------- 17 USE Agrif_Grids 18 IMPLICIT NONE 19 19 20 Type(Agrif_Grid), Pointer:: Agrif_Gr20 TYPE(Agrif_Grid), POINTER :: Agrif_Gr 21 21 22 IF ( associated(Agrif_Curgrid) )THEN22 IF ( ASSOCIATED(Agrif_Curgrid) )THEN 23 23 #include "SetNumberofcells.h" 24 24 ENDIF 25 25 26 26 END SUBROUTINE Agrif_Set_numberofcells 27 27 28 29 30 31 32 33 28 SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 29 !!--------------------------------------------- 30 !! *** ROUTINE Agrif_Get_numberofcells *** 31 !!--------------------------------------------- 32 USE Agrif_Grids 33 IMPLICIT NONE 34 34 35 Type(Agrif_Grid), Pointer:: Agrif_Gr35 TYPE(Agrif_Grid), POINTER :: Agrif_Gr 36 36 37 if ( associated(Agrif_Curgrid) ) then37 IF ( ASSOCIATED(Agrif_Curgrid) ) THEN 38 38 #include "GetNumberofcells.h" 39 endif39 ENDIF 40 40 41 41 END SUBROUTINE Agrif_Get_numberofcells 42 42 43 44 45 46 47 43 SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 44 !!--------------------------------------------- 45 !! *** ROUTINE Agrif_Allocationscalls *** 46 !!--------------------------------------------- 47 USE Agrif_Grids 48 48 #include "include_use_Alloc_agrif.h" 49 49 IMPLICIT NONE 50 50 51 Type(Agrif_Grid), Pointer:: Agrif_Gr51 TYPE(Agrif_Grid), POINTER :: Agrif_Gr 52 52 53 53 #include "allocations_calls_agrif.h" 54 54 55 55 END SUBROUTINE Agrif_Allocationcalls 56 56 57 58 59 60 61 62 57 SUBROUTINE Agrif_probdim_modtype_def() 58 !!--------------------------------------------- 59 !! *** ROUTINE Agrif_probdim_modtype_def *** 60 !!--------------------------------------------- 61 USE Agrif_Types 62 IMPLICIT NONE 63 63 64 64 #include "modtype_agrif.h" … … 66 66 #include "keys_agrif.h" 67 67 68 Return68 RETURN 69 69 70 70 END SUBROUTINE Agrif_probdim_modtype_def 71 71 72 73 74 75 76 72 SUBROUTINE Agrif_clustering_def() 73 !!--------------------------------------------- 74 !! *** ROUTINE Agrif_clustering_def *** 75 !!--------------------------------------------- 76 IMPLICIT NONE 77 77 78 Return78 RETURN 79 79 80 80 END SUBROUTINE Agrif_clustering_def 81 81 82 82 #else 83 84 85 86 87 88 83 SUBROUTINE Agrif2Model 84 !!--------------------------------------------- 85 !! *** ROUTINE Agrif2Model *** 86 !!--------------------------------------------- 87 WRITE(*,*) 'Impossible to bet here' 88 END SUBROUTINE Agrif2model 89 89 #endif -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r4785 r4789 12 12 USE par_oce ! ocean parameters 13 13 USE dom_oce ! domain parameters 14 14 15 15 IMPLICIT NONE 16 16 PRIVATE … … 23 23 REAL(wp), PUBLIC :: rn_sponge_tra = 2800. !: sponge coeff. for tracers 24 24 REAL(wp), PUBLIC :: rn_sponge_dyn = 2800. !: sponge coeff. for dynamics 25 LOGICAL , PUBLIC :: ln_chk_bathy = .FALSE. !: check of parent bathymetry 26 LOGICAL , PUBLIC :: ln_agrif_tke = .FALSE. !: interp/extrap for TKE 25 27 26 28 ! !!! OLD namelist names … … 34 36 LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 35 37 36 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone 38 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_tsn 39 # if defined key_top 40 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_trn 41 # endif 37 42 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 38 43 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 39 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spe1ur , spe2vr , spbtr2 !: ??? 40 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spe1ur2, spe2vr2, spbtr3 !: ??? 41 # if defined key_dynspg_ts42 46 ! Barotropic arrays used to store open boundary data during 43 47 ! time-splitting loop: … … 46 50 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 47 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 48 # endif 49 52 50 53 INTEGER :: tsn_id ! AGRIF profile for tracers interpolation and update 51 54 INTEGER :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations 52 55 INTEGER :: un_update_id, vn_update_id ! AGRIF profiles for udpates 53 56 INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 54 INTEGER :: trn_id 57 # if defined key_top 58 INTEGER :: trn_id, trn_sponge_id 59 # endif 55 60 INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 56 61 INTEGER :: ub2b_update_id, vb2b_update_id 57 62 INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id 58 63 INTEGER :: scales_t_id 64 INTEGER :: avt_id, avm_id, avmu_id, avmv_id 59 65 60 66 !!---------------------------------------------------------------------- … … 73 79 ierr(:) = 0 74 80 ! 75 ALLOCATE( spe1ur (jpi,jpj), spe2vr (jpi,jpj), & 76 & spbtr2 (jpi,jpj), spe1ur2 (jpi,jpj), & 77 & spe2vr2 (jpi,jpj), spbtr3 (jpi,jpj), & 78 & tabspongedone (jpi,jpj), tabspongedone_u(jpi,jpj), & 79 & tabspongedone_v(jpi,jpj), STAT = ierr(1) ) 81 ALLOCATE( spe1ur (jpi,jpj), spe2vr (jpi,jpj), & 82 & spbtr2 (jpi,jpj), spe1ur2(jpi,jpj), & 83 & spe2vr2(jpi,jpj), spbtr3(jpi,jpj), & 84 & tabspongedone_tsn(jpi,jpj), & 85 # if defined key_top 86 & tabspongedone_trn(jpi,jpj), & 87 # endif 88 & tabspongedone_u (jpi,jpj), & 89 & tabspongedone_v (jpi,jpj), STAT = ierr(1) ) 80 90 81 # if defined key_dynspg_ts82 91 ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj), & 83 92 & ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj), & 84 93 & ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi), & 85 94 & ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi), STAT = ierr(2) ) 86 # endif 95 87 96 agrif_oce_alloc = MAXVAL(ierr) 88 97 ! -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r4785 r4789 7 7 !! - ! 2005-11 (XXX) 8 8 !! 3.2 ! 2009-04 (R. Benshila) 9 !! 3.6 ! 2014-09 (R. Benshila) 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_agrif && ! defined key_offline … … 29 30 USE wrk_nemo 30 31 USE dynspg_oce 31 32 USE zdf_oce 33 32 34 IMPLICIT NONE 33 35 PRIVATE 34 36 35 37 INTEGER :: bdy_tinterp = 0 36 38 37 39 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 38 40 PUBLIC interpun, interpvn, interpun2d, interpvn2d 39 41 PUBLIC interptsn, interpsshn 40 42 PUBLIC interpunb, interpvnb, interpub2b, interpvb2b 43 PUBLIC interpe3t 44 # if defined key_zdftke 45 PUBLIC Agrif_tke, interpavt, interpavm, interpavmu, interpavmv 46 # endif 41 47 42 48 # include "domzgr_substitute.h90" 43 49 # include "vectopt_loop_substitute.h90" 44 50 !!---------------------------------------------------------------------- 45 !! NEMO/NST 3. 3, NEMO Consortium (2010)51 !! NEMO/NST 3.6 , NEMO Consortium (2010) 46 52 !! $Id$ 47 53 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 48 54 !!---------------------------------------------------------------------- 49 55 50 51 56 CONTAINS 57 52 58 SUBROUTINE Agrif_tra 53 59 !!---------------------------------------------------------------------- … … 199 205 END DO 200 206 spgu(nlci-2,:)=0. 201 dojk=1,jpkm1202 dojj=1,jpj207 DO jk=1,jpkm1 208 DO jj=1,jpj 203 209 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 204 enddo205 enddo210 ENDDO 211 ENDDO 206 212 DO jj=1,jpj 207 213 IF (umask(nlci-2,jj,1).NE.0.) THEN … … 429 435 DO jj=1,jpj 430 436 va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 431 ! Specified fluxes:437 ! Specified fluxes: 432 438 ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 433 ! Characteristics method:434 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &435 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )439 ! Characteristics method: 440 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 441 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 436 442 END DO 437 443 ENDIF … … 440 446 DO jj=1,jpj 441 447 va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 442 ! Specified fluxes:448 ! Specified fluxes: 443 449 ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 444 ! Characteristics method:445 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &446 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )450 ! Characteristics method: 451 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 452 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 447 453 END DO 448 454 ENDIF … … 451 457 DO ji=1,jpi 452 458 ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 453 ! Specified fluxes:459 ! Specified fluxes: 454 460 va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 455 ! Characteristics method:456 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &457 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )461 ! Characteristics method: 462 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 463 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 458 464 END DO 459 465 ENDIF … … 462 468 DO ji=1,jpi 463 469 ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 464 ! Specified fluxes:470 ! Specified fluxes: 465 471 va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 466 ! Characteristics method:467 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) &468 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )472 ! Characteristics method: 473 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) & 474 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 469 475 END DO 470 476 ENDIF … … 487 493 488 494 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 489 495 ! the forward case only 490 496 491 497 zrhot = Agrif_rhot() … … 598 604 END SUBROUTINE Agrif_ssh_ts 599 605 606 # if defined key_zdftke 607 SUBROUTINE Agrif_tke 608 !!---------------------------------------------------------------------- 609 !! *** ROUTINE Agrif_tke *** 610 !!---------------------------------------------------------------------- 611 ! 612 IF( Agrif_Root() ) RETURN 613 614 615 Agrif_SpecialValue = 0.e0 616 Agrif_UseSpecialValue = .TRUE. 617 618 CALL Agrif_Bc_variable(avt_id , procname=interpavt) 619 CALL Agrif_Bc_variable(avm_id , procname=interpavm) 620 CALL Agrif_Bc_variable(avmu_id, procname=interpavmu) 621 CALL Agrif_Bc_variable(avmv_id, procname=interpavmv) 622 623 Agrif_UseSpecialValue = .FALSE. 624 ! 625 END SUBROUTINE Agrif_tke 626 # endif 627 600 628 SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 601 629 !!--------------------------------------------- … … 612 640 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 613 641 LOGICAL :: western_side, eastern_side,northern_side,southern_side 614 642 615 643 IF (before) THEN 616 644 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) … … 656 684 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 657 685 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 658 686 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 659 687 ENDIF 660 688 ENDIF … … 675 703 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 676 704 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) & 677 705 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 678 706 ENDIF 679 707 ENDIF 680 708 END DO 681 709 END DO 682 ENDDO 710 ENDDO 683 711 ENDIF 684 712 ! … … 723 751 ! East south 724 752 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 725 tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)753 tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 726 754 ENDIF 727 755 ! East north 728 756 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 729 tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)730 ENDIF 757 tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 758 ENDIF 731 759 ! West south 732 760 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 733 tsa(2,2,:,:) = ptab(2,2,:,:)761 tsa(2,2,:,:) = ptab(2,2,:,:) 734 762 ENDIF 735 763 ! West north 736 764 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 737 tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)765 tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 738 766 ENDIF 739 767 ! … … 818 846 ! 819 847 ztref = 1. 820 848 821 849 IF (before) THEN 822 850 DO jj=j1,j2 823 DO ji=i1, min(i2,nlci-1)851 DO ji=i1,MIN(i2,nlci-1) 824 852 ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) 825 853 END DO … … 855 883 ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 856 884 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 857 END DO 885 END DO 858 886 END DO 859 887 END DO … … 866 894 END DO 867 895 END DO 868 869 896 ENDIF 897 ! 870 898 END SUBROUTINE interpvn 871 899 872 900 SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 873 901 !!--------------------------------------------- … … 887 915 IF (before) THEN 888 916 !interpv entre 1 et k2 et interpv2d en jpkp1 889 DO jj=j1, min(j2,nlcj-1)917 DO jj=j1,MIN(j2,nlcj-1) 890 918 DO ji=i1,i2 891 919 ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 892 920 END DO 893 921 END DO 894 895 896 897 898 899 900 922 ELSE 923 zrhox = Agrif_Rhox() 924 DO ji=i1,i2 925 laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 926 END DO 927 ENDIF 928 ! 901 929 END SUBROUTINE interpvn2d 902 930 … … 934 962 IF( bdy_tinterp == 1 ) THEN 935 963 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 936 964 & - zt0**2._wp * ( zt0 - 1._wp) ) 937 965 ELSEIF( bdy_tinterp == 2 ) THEN 938 966 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 939 940 967 & - zt0 * ( zt0 - 1._wp)**2._wp ) 968 941 969 ELSE 942 970 ztcoeff = 1 … … 945 973 IF(western_side) THEN 946 974 ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 947 ENDIF 975 ENDIF 948 976 IF(eastern_side) THEN 949 977 ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 950 ENDIF 978 ENDIF 951 979 IF(southern_side) THEN 952 980 ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 953 ENDIF 981 ENDIF 954 982 IF(northern_side) THEN 955 983 ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) … … 957 985 ! 958 986 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 959 IF(western_side) THEN960 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) &961 & * umask(i1,j1:j2,1)962 ENDIF963 IF(eastern_side) THEN964 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) &965 & * umask(i1,j1:j2,1)966 ENDIF967 IF(southern_side) THEN968 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) &969 & * umask(i1:i2,j1,1)970 ENDIF971 IF(northern_side) THEN972 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) &973 & * umask(i1:i2,j1,1)974 ENDIF975 ENDIF976 ENDIF 987 IF(western_side) THEN 988 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 989 & * umask(i1,j1:j2,1) 990 ENDIF 991 IF(eastern_side) THEN 992 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 993 & * umask(i1,j1:j2,1) 994 ENDIF 995 IF(southern_side) THEN 996 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 997 & * umask(i1:i2,j1,1) 998 ENDIF 999 IF(northern_side) THEN 1000 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 1001 & * umask(i1:i2,j1,1) 1002 ENDIF 1003 ENDIF 1004 ENDIF 977 1005 ! 978 1006 END SUBROUTINE interpunb … … 1010 1038 IF( bdy_tinterp == 1 ) THEN 1011 1039 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 1012 1040 & - zt0**2._wp * ( zt0 - 1._wp) ) 1013 1041 ELSEIF( bdy_tinterp == 2 ) THEN 1014 1042 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 1015 1016 1043 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1044 1017 1045 ELSE 1018 1046 ztcoeff = 1 … … 1021 1049 IF(western_side) THEN 1022 1050 vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 1023 ENDIF 1051 ENDIF 1024 1052 IF(eastern_side) THEN 1025 1053 vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 1026 ENDIF 1054 ENDIF 1027 1055 IF(southern_side) THEN 1028 1056 vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 1029 ENDIF 1057 ENDIF 1030 1058 IF(northern_side) THEN 1031 1059 vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) … … 1033 1061 ! 1034 1062 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 1035 IF(western_side) THEN1036 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) &1037 & * vmask(i1,j1:j2,1)1038 ENDIF1039 IF(eastern_side) THEN1040 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) &1041 & * vmask(i1,j1:j2,1)1042 ENDIF1043 IF(southern_side) THEN1044 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) &1045 & * vmask(i1:i2,j1,1)1046 ENDIF1047 IF(northern_side) THEN1048 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) &1049 & * vmask(i1:i2,j1,1)1050 ENDIF1051 ENDIF1052 ENDIF1053 !1063 IF(western_side) THEN 1064 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 1065 & * vmask(i1,j1:j2,1) 1066 ENDIF 1067 IF(eastern_side) THEN 1068 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 1069 & * vmask(i1,j1:j2,1) 1070 ENDIF 1071 IF(southern_side) THEN 1072 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 1073 & * vmask(i1:i2,j1,1) 1074 ENDIF 1075 IF(northern_side) THEN 1076 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 1077 & * vmask(i1:i2,j1,1) 1078 ENDIF 1079 ENDIF 1080 ENDIF 1081 ! 1054 1082 END SUBROUTINE interpvnb 1055 1083 … … 1084 1112 ! Polynomial interpolation coefficients: 1085 1113 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 1086 1114 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1087 1115 ! 1088 1116 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) … … 1090 1118 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1091 1119 IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1092 ENDIF 1120 ENDIF 1093 1121 ! 1094 1122 END SUBROUTINE interpub2b … … 1125 1153 ! Polynomial interpolation coefficients: 1126 1154 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 1127 1155 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1128 1156 ! 1129 1157 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) … … 1147 1175 INTEGER :: ji, jj, jk 1148 1176 INTEGER :: icnt 1149 logical:: western_side, eastern_side,northern_side,southern_side1177 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1150 1178 !!---------------------------------------------------------------------- 1151 1179 ! 1152 1180 IF (before) THEN 1153 DO jk=k1,k21154 DO jj=j1,j21155 DO ji=i1,i21156 ptab(ji,jj,jk) = tmask(ji,jj,jk) * fse3t(ji,jj,jk)1157 END DO1158 END DO1159 END DO1181 DO jk=k1,k2 1182 DO jj=j1,j2 1183 DO ji=i1,i2 1184 ptab(ji,jj,jk) = tmask(ji,jj,jk) * fse3t(ji,jj,jk) 1185 END DO 1186 END DO 1187 END DO 1160 1188 ELSE 1161 1189 western_side = (nb == 1).AND.(ndir == 1) … … 1163 1191 southern_side = (nb == 2).AND.(ndir == 1) 1164 1192 northern_side = (nb == 2).AND.(ndir == 2) 1165 1166 icnt = 0 1167 DO jk=k1,k2 1168 DO jj=j1,j2 1169 DO ji=i1,i2 1170 IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * fse3t(ji,jj,jk)) > 1.D-2) THEN 1171 IF (western_side) THEN 1172 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji,jj,jk 1173 ELSEIF (eastern_side) THEN 1174 WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji,jj,jk 1175 ELSEIF (southern_side) THEN 1176 WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji,jj,jk 1177 ELSEIF (northern_side) THEN 1178 WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji,jj,jk 1193 1194 icnt = 0 1195 DO jk=k1,k2 1196 DO jj=j1,j2 1197 DO ji=i1,i2 1198 IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * fse3t(ji,jj,jk)) > 1.D-2) THEN 1199 IF (western_side) THEN 1200 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji,jj,jk 1201 ELSEIF (eastern_side) THEN 1202 WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji,jj,jk 1203 ELSEIF (southern_side) THEN 1204 WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji,jj,jk 1205 ELSEIF (northern_side) THEN 1206 WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji,jj,jk 1207 ENDIF 1208 WRITE(numout,*) ' ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), fse3t(ji,jj,jk) 1209 icnt = icnt + 1 1179 1210 ENDIF 1180 WRITE(numout,*) ' ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), fse3t(ji,jj,jk) 1181 icnt = icnt + 1 1182 ENDIF 1183 END DO 1184 END DO 1185 END DO 1186 IF(icnt /= 0) THEN 1187 CALL ctl_stop('ERROR in bathymetry merge between parent and child grids...') 1188 ELSE 1189 IF(lwp) WRITE(numout,*) 'interp e3t ok...' 1190 END IF 1211 END DO 1212 END DO 1213 END DO 1214 IF(icnt /= 0) THEN 1215 CALL ctl_stop('ERROR in bathymetry merge between parent and child grids...') 1216 ELSE 1217 IF(lwp) WRITE(numout,*) 'interp e3t ok...' 1218 END IF 1191 1219 ENDIF 1192 1220 ! 1193 1221 END SUBROUTINE interpe3t 1222 1223 # if defined key_zdftke 1224 SUBROUTINE interpavt(ptab,i1,i2,j1,j2,k1,k2,before) 1225 !!---------------------------------------------------------------------- 1226 !! *** ROUTINE interavt *** 1227 !!---------------------------------------------------------------------- 1228 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1229 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1230 LOGICAL, INTENT(in) :: before 1231 !!---------------------------------------------------------------------- 1232 ! 1233 IF( before) THEN 1234 ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 1235 ELSE 1236 avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1237 ENDIF 1238 ! 1239 1240 END SUBROUTINE interpavt 1241 1242 1243 SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 1244 !!---------------------------------------------------------------------- 1245 !! *** ROUTINE interavm *** 1246 !!---------------------------------------------------------------------- 1247 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1248 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1249 LOGICAL, INTENT(in) :: before 1250 !!---------------------------------------------------------------------- 1251 ! 1252 IF( before) THEN 1253 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1254 ELSE 1255 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1256 ENDIF 1257 ! 1258 END SUBROUTINE interpavm 1259 1260 1261 SUBROUTINE interpavmu(ptab,i1,i2,j1,j2,k1,k2,before) 1262 !!---------------------------------------------------------------------- 1263 !! *** ROUTINE interavmu *** 1264 !!---------------------------------------------------------------------- 1265 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1266 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1267 LOGICAL, INTENT(in) :: before 1268 !!---------------------------------------------------------------------- 1269 ! 1270 IF( before) THEN 1271 ptab (i1:i2,j1:j2,k1:k2) = avmu_k(i1:i2,j1:j2,k1:k2) 1272 ELSE 1273 avmu_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1274 ENDIF 1275 ! 1276 END SUBROUTINE interpavmu 1277 1278 1279 SUBROUTINE interpavmv(ptab,i1,i2,j1,j2,k1,k2,before) 1280 !!---------------------------------------------------------------------- 1281 !! *** ROUTINE interavmv *** 1282 !!---------------------------------------------------------------------- 1283 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1284 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1285 LOGICAL, INTENT(in) :: before 1286 !!---------------------------------------------------------------------- 1287 ! 1288 IF( before) THEN 1289 ptab (i1:i2,j1:j2,k1:k2) = avmv_k(i1:i2,j1:j2,k1:k2) 1290 ELSE 1291 avmv_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1292 ENDIF 1293 ! 1294 END SUBROUTINE interpavmv 1295 # endif /* key_zdftke */ 1194 1296 1195 1297 #else -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
r4785 r4789 1 1 #define SPONGE && define SPONGE_TOP 2 2 3 M oduleagrif_opa_sponge3 MODULE agrif_opa_sponge 4 4 #if defined key_agrif && ! defined key_offline 5 5 USE par_oce … … 16 16 PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 17 17 18 !! * Substitutions18 !! * Substitutions 19 19 # include "domzgr_substitute.h90" 20 20 !!---------------------------------------------------------------------- … … 24 24 !!---------------------------------------------------------------------- 25 25 26 26 CONTAINS 27 27 28 28 SUBROUTINE Agrif_Sponge_Tra … … 31 31 !!--------------------------------------------- 32 32 !! 33 INTEGER :: ji,jj,jk,jn34 33 REAL(wp) :: timecoeff 35 REAL(wp) :: ztsa, zabe1, zabe2, zbtr36 REAL(wp), POINTER, DIMENSION(:,: ) :: ztu, ztv37 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab38 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: tsbdiff39 34 40 35 #if defined SPONGE 41 36 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 42 37 43 38 CALL Agrif_Sponge 44 39 Agrif_SpecialValue=0. 45 40 Agrif_UseSpecialValue = .TRUE. 46 tabspongedone = .FALSE.41 tabspongedone_tsn = .FALSE. 47 42 48 43 CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) … … 63 58 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 64 59 65 66 67 68 69 70 71 72 73 74 75 76 60 Agrif_SpecialValue=0. 61 Agrif_UseSpecialValue = ln_spc_dyn 62 63 tabspongedone_u = .FALSE. 64 tabspongedone_v = .FALSE. 65 CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 66 67 tabspongedone_u = .FALSE. 68 tabspongedone_v = .FALSE. 69 CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 70 71 Agrif_UseSpecialValue = .FALSE. 77 72 #endif 78 73 … … 109 104 ENDDO 110 105 spe1ur(2:ispongearea-1,: ) = 0.5 * ( zlocalviscsponge(2:ispongearea-1,: ) & 111 & + zlocalviscsponge(3:ispongearea ,: ) ) &112 & * e2u(2:ispongearea-1,: ) / e1u(2:ispongearea-1,: )106 & + zlocalviscsponge(3:ispongearea ,: ) ) & 107 & * e2u(2:ispongearea-1,: ) / e1u(2:ispongearea-1,: ) 113 108 spe2vr(2:ispongearea ,1:jpjm1) = 0.5 * ( zlocalviscsponge(2:ispongearea ,1:jpjm1) & 114 & + zlocalviscsponge(2:ispongearea,2 :jpj ) ) &115 & * e1v(2:ispongearea ,1:jpjm1) / e2v(2:ispongearea ,1:jpjm1)109 & + zlocalviscsponge(2:ispongearea,2 :jpj ) ) & 110 & * e1v(2:ispongearea ,1:jpjm1) / e2v(2:ispongearea ,1:jpjm1) 116 111 ENDIF 117 112 … … 120 115 zlocalviscsponge(ji,:) = visc_tra * (ji - (ilci+1) ) * z1spongearea 121 116 ENDDO 122 117 123 118 spe1ur(ilci+1:nlci-2,: ) = 0.5 * ( zlocalviscsponge(ilci+1:nlci-2,:) & 124 & + zlocalviscsponge(ilci+2:nlci-1,:) ) &125 & * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:)119 & + zlocalviscsponge(ilci+2:nlci-1,:) ) & 120 & * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 126 121 127 122 spe2vr(ilci+1:nlci-1,1:jpjm1) = 0.5 * ( zlocalviscsponge(ilci+1:nlci-1,1:jpjm1) & 128 & + zlocalviscsponge(ilci+1:nlci-1,2:jpj ) ) &129 & * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1)123 & + zlocalviscsponge(ilci+1:nlci-1,2:jpj ) ) & 124 & * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 130 125 ENDIF 131 126 … … 135 130 ENDDO 136 131 spe1ur(1:jpim1,2:ispongearea ) = 0.5 * ( zlocalviscsponge(1:jpim1,2:ispongearea ) & 137 & + zlocalviscsponge(2:jpi ,2:ispongearea) ) &138 & * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea)139 132 & + zlocalviscsponge(2:jpi ,2:ispongearea) ) & 133 & * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 134 140 135 spe2vr(: ,2:ispongearea-1) = 0.5 * ( zlocalviscsponge(:,2:ispongearea-1) & 141 & + zlocalviscsponge(:,3:ispongearea ) ) &142 & * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1)136 & + zlocalviscsponge(:,3:ispongearea ) ) & 137 & * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 143 138 ENDIF 144 139 … … 148 143 ENDDO 149 144 spe1ur(1:jpim1,ilcj+1:nlcj-1) = 0.5 * ( zlocalviscsponge(1:jpim1,ilcj+1:nlcj-1) & 150 & + zlocalviscsponge(2:jpi ,ilcj+1:nlcj-1) ) &151 & * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1)145 & + zlocalviscsponge(2:jpi ,ilcj+1:nlcj-1) ) & 146 & * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 152 147 spe2vr(: ,ilcj+1:nlcj-2) = 0.5 * ( zlocalviscsponge(:,ilcj+1:nlcj-2 ) & 153 & + zlocalviscsponge(:,ilcj+2:nlcj-1) ) &154 & * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2)148 & + zlocalviscsponge(:,ilcj+2:nlcj-1) ) & 149 & * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 155 150 ENDIF 156 151 spongedoneT = .TRUE. … … 168 163 ENDDO 169 164 spe1ur2(2:ispongearea-1,: ) = 0.5 * ( zlocalviscsponge(2:ispongearea-1,: ) & 170 165 & + zlocalviscsponge(3:ispongearea,: ) ) 171 166 spe2vr2(2:ispongearea ,1:jpjm1) = 0.5 * ( zlocalviscsponge(2:ispongearea ,1:jpjm1) & 172 167 & + zlocalviscsponge(2:ispongearea,2:jpj) ) 173 168 ENDIF 174 169 … … 178 173 ENDDO 179 174 spe1ur2(ilci+1:nlci-2,: ) = 0.5 * ( zlocalviscsponge(ilci+1:nlci-2,:) & 180 175 & + zlocalviscsponge(ilci+2:nlci-1,:) ) 181 176 spe2vr2(ilci+1:nlci-1,1:jpjm1) = 0.5 * ( zlocalviscsponge(ilci+1:nlci-1,1:jpjm1) & 182 177 & + zlocalviscsponge(ilci+1:nlci-1,2:jpj ) ) 183 178 ENDIF 184 179 … … 188 183 ENDDO 189 184 spe1ur2(1:jpim1,2:ispongearea ) = 0.5 * ( zlocalviscsponge(1:jpim1,2:ispongearea) & 190 185 & + zlocalviscsponge(2:jpi,2:ispongearea) ) 191 186 spe2vr2(: ,2:ispongearea-1) = 0.5 * ( zlocalviscsponge(:,2:ispongearea-1) & 192 187 & + zlocalviscsponge(:,3:ispongearea) ) 193 188 ENDIF 194 189 … … 198 193 ENDDO 199 194 spe1ur2(1:jpim1,ilcj+1:nlcj-1) = 0.5 * ( zlocalviscsponge(1:jpim1,ilcj+1:nlcj-1) & 200 195 & + zlocalviscsponge(2:jpi,ilcj+1:nlcj-1) ) 201 196 spe2vr2(: ,ilcj+1:nlcj-2) = 0.5 * ( zlocalviscsponge(:,ilcj+1:nlcj-2 ) & 202 197 & + zlocalviscsponge(:,ilcj+2:nlcj-1) ) 203 198 ENDIF 204 199 spongedoneU = .TRUE. … … 219 214 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 220 215 LOGICAL, INTENT(in) :: before 221 222 216 217 223 218 INTEGER :: ji, jj, jk, jn ! dummy loop indices 224 219 … … 227 222 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 228 223 ! 229 230 231 IF (before) THEN 232 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 233 ELSE 234 235 tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:) 236 DO jn = 1, jpts 237 DO jk = 1, jpkm1 238 239 DO jj = j1,j2-1 240 DO ji = i1,i2-1 241 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 242 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 243 ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 244 ztv(ji,jj) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 245 ENDDO 224 225 226 IF (before) THEN 227 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 228 ELSE 229 230 tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:) 231 DO jn = 1, jpts 232 DO jk = 1, jpkm1 233 234 DO jj = j1,j2-1 235 DO ji = i1,i2-1 236 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 237 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 238 ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 239 ztv(ji,jj) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 246 240 ENDDO 247 248 DO jj = j1+1,j2-1 249 DO ji = i1+1,i2-1 250 251 if (.not. tabspongedone(ji,jj)) then 252 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 253 ! horizontal diffusive trends 254 ztsa = zbtr * ( ztu(ji,jj) - ztu(ji-1,jj ) + ztv(ji,jj) - ztv(ji ,jj-1) ) 255 ! add it to the general tracer trends 256 tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 257 endif 258 259 ENDDO 260 ENDDO 261 262 ENDDO 263 ENDDO 264 265 tabspongedone(i1+1:i2-1,j1+1:j2-1) = .TRUE. 266 267 ENDIF 268 241 ENDDO 242 243 DO jj = j1+1,j2-1 244 DO ji = i1+1,i2-1 245 246 IF (.NOT. tabspongedone_tsn(ji,jj)) THEN 247 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 248 ! horizontal diffusive trends 249 ztsa = zbtr * ( ztu(ji,jj) - ztu(ji-1,jj ) + ztv(ji,jj) - ztv(ji ,jj-1) ) 250 ! add it to the general tracer trends 251 tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 252 ENDIF 253 254 ENDDO 255 ENDDO 256 257 ENDDO 258 ENDDO 259 260 tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 261 262 ENDIF 263 269 264 END SUBROUTINE interptsn_sponge 270 265 … … 279 274 INTEGER :: ji,jj,jk 280 275 281 276 ! sponge parameters 282 277 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 283 278 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 284 279 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 285 280 INTEGER :: jmax 286 287 281 ! 282 288 283 289 284 IF (before) THEN 290 291 285 286 tabres = un(i1:i2,j1:j2,:) 292 287 293 288 ELSE 294 289 295 290 ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:) 296 291 297 292 DO jk=1,jpkm1 298 293 ubdiff(i1:i2,j1:j2,jk) = ubdiff(i1:i2,j1:j2,jk) * spe1ur2(i1:i2,j1:j2) … … 300 295 301 296 DO jk = 1, jpkm1 ! Horizontal slab 302 ! ! ===============303 304 ! ! --------305 ! Horizontal divergence ! div306 ! ! --------297 ! ! =============== 298 299 ! ! -------- 300 ! Horizontal divergence ! div 301 ! ! -------- 307 302 DO jj = j1,j2 308 303 DO ji = i1+1,i2 ! vector opt. 309 304 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 310 305 hdivdiff(ji,jj,jk) = (e2u(ji,jj)*fse3u(ji,jj,jk) * ubdiff(ji,jj,jk) - e2u(ji-1,jj)* fse3u(ji-1,jj ,jk) & 311 306 * ubdiff(ji-1,jj ,jk) ) * zbtr 312 307 END DO 313 308 END DO … … 317 312 zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 318 313 rotdiff(ji,jj,jk) = (- e1u(ji ,jj+1) * ubdiff(ji ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk) ) & 319 314 * fmask(ji,jj,jk) * zbtr 320 315 END DO 321 316 END DO 322 317 ENDDO 323 318 324 !325 326 327 328 329 330 331 if (.not. tabspongedone_u(ji,jj)) then332 333 334 335 ! horizontal diffusive trends336 337 + ( hdivdiff(ji+1,jj,jk) - ze1v ) / e1u(ji,jj)338 339 ! add it to the general momentum trends340 341 342 END DO343 endif344 345 END DO346 347 348 tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .true.349 319 ! 320 321 322 323 DO jj = j1+1, j2-1 324 DO ji = i1+1, i2-1 ! vector opt. 325 326 IF (.NOT. tabspongedone_u(ji,jj)) THEN 327 DO jk = 1, jpkm1 ! Horizontal slab 328 ze2u = rotdiff (ji,jj,jk) 329 ze1v = hdivdiff(ji,jj,jk) 330 ! horizontal diffusive trends 331 zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) & 332 + ( hdivdiff(ji+1,jj,jk) - ze1v ) / e1u(ji,jj) 333 334 ! add it to the general momentum trends 335 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 336 337 END DO 338 ENDIF 339 340 END DO 341 END DO 342 343 tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE. 344 350 345 jmax = j2-1 351 I f ((nbondj == 1).OR.(nbondj == 2)) jmax = min(jmax,nlcj-3)352 353 354 355 356 if (.not. tabspongedone_v(ji,jj)) then357 358 359 360 361 ! horizontal diffusive trends362 363 + ( hdivdiff(ji,jj+1,jk) - ze1v ) / e2v(ji,jj)364 365 ! add it to the general momentum trends366 367 END DO368 endif369 370 END DO371 372 373 374 tabspongedone_v(i1+1:i2,j1+1:jmax) = .true.375 346 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-3) 347 348 DO jj = j1+1, jmax 349 DO ji = i1+1, i2 ! vector opt. 350 351 IF (.NOT. tabspongedone_v(ji,jj)) THEN 352 DO jk = 1, jpkm1 ! Horizontal slab 353 ze2u = rotdiff (ji,jj,jk) 354 ze1v = hdivdiff(ji,jj,jk) 355 356 ! horizontal diffusive trends 357 zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) & 358 + ( hdivdiff(ji,jj+1,jk) - ze1v ) / e2v(ji,jj) 359 360 ! add it to the general momentum trends 361 va(ji,jj,jk) = va(ji,jj,jk) + zva 362 END DO 363 ENDIF 364 365 END DO 366 END DO 367 368 369 tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE. 370 376 371 ENDIF 377 378 372 373 379 374 END SUBROUTINE interpun_sponge 380 381 375 376 382 377 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 383 !!---------------------------------------------378 !!--------------------------------------------- 384 379 !! *** ROUTINE interpvn_sponge *** 385 380 !!--------------------------------------------- … … 392 387 393 388 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 394 389 395 390 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 396 391 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 397 392 INTEGER :: imax 398 399 393 ! 394 400 395 IF (before) THEN 401 396 tabres = vn(i1:i2,j1:j2,:) 402 397 ELSE 403 398 404 399 vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:) 405 400 406 401 DO jk=1,jpkm1 407 402 vbdiff(i1:i2,j1:j2,jk) = vbdiff(i1:i2,j1:j2,jk) * spe2vr2(i1:i2,j1:j2) … … 409 404 410 405 DO jk = 1, jpkm1 ! Horizontal slab 411 ! ! ===============412 413 ! ! --------414 ! Horizontal divergence ! div415 ! ! --------406 ! ! =============== 407 408 ! ! -------- 409 ! Horizontal divergence ! div 410 ! ! -------- 416 411 DO jj = j1+1,j2 417 412 DO ji = i1,i2 ! vector opt. 418 413 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 419 414 hdivdiff(ji,jj,jk) = (e1v(ji,jj) * fse3v(ji,jj,jk) * vbdiff(ji,jj,jk) - e1v(ji ,jj-1) & 420 415 * fse3v(ji ,jj-1,jk) * vbdiff(ji ,jj-1,jk) ) * zbtr 421 416 END DO 422 417 END DO 423 424 418 DO jj = j1,j2 425 419 DO ji = i1,i2-1 ! vector opt. 426 420 zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 427 421 rotdiff(ji,jj,jk) = (e2v(ji+1,jj ) * vbdiff(ji+1,jj ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk)) & 428 422 * fmask(ji,jj,jk) * zbtr 429 423 END DO 430 424 END DO 431 432 425 ENDDO 433 426 434 ! ! ===============435 !436 427 ! ! =============== 428 ! 429 437 430 imax = i2-1 438 If ((nbondi == 1).OR.(nbondi == 2)) imax = min(imax,nlci-3) 439 440 DO jj = j1+1, j2 441 DO ji = i1+1, imax ! vector opt. 442 if (.not. tabspongedone_u(ji,jj)) then 443 DO jk = 1, jpkm1 ! Horizontal slab 444 ze2u = rotdiff (ji,jj,jk) 445 ze1v = hdivdiff(ji,jj,jk) 446 ! horizontal diffusive trends 447 zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 448 / e1u(ji,jj) 449 450 451 ! add it to the general momentum trends 452 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 453 END DO 454 455 endif 456 END DO 457 END DO 458 459 tabspongedone_u(i1+1:imax,j1+1:j2) = .true. 460 461 DO jj = j1+1, j2-1 462 DO ji = i1+1, i2-1 ! vector opt. 463 if (.not. tabspongedone_v(ji,jj)) then 464 DO jk = 1, jpkm1 ! Horizontal slab 465 ze2u = rotdiff (ji,jj,jk) 466 ze1v = hdivdiff(ji,jj,jk) 467 ! horizontal diffusive trends 468 469 zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 470 / e2v(ji,jj) 471 472 ! add it to the general momentum trends 473 va(ji,jj,jk) = va(ji,jj,jk) + zva 474 END DO 475 476 endif 477 END DO 478 END DO 479 480 tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .true. 481 431 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-3) 432 433 DO jj = j1+1, j2 434 DO ji = i1+1, imax ! vector opt. 435 IF (.NOT. tabspongedone_u(ji,jj)) THEN 436 DO jk = 1, jpkm1 ! Horizontal slab 437 ze2u = rotdiff (ji,jj,jk) 438 ze1v = hdivdiff(ji,jj,jk) 439 ! horizontal diffusive trends 440 zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 441 / e1u(ji,jj) 442 443 444 ! add it to the general momentum trends 445 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 446 END DO 447 448 ENDIF 449 END DO 450 END DO 451 452 tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE. 453 454 DO jj = j1+1, j2-1 455 DO ji = i1+1, i2-1 ! vector opt. 456 IF (.NOT. tabspongedone_v(ji,jj)) THEN 457 DO jk = 1, jpkm1 ! Horizontal slab 458 ze2u = rotdiff (ji,jj,jk) 459 ze1v = hdivdiff(ji,jj,jk) 460 ! horizontal diffusive trends 461 462 zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 463 / e2v(ji,jj) 464 465 ! add it to the general momentum trends 466 va(ji,jj,jk) = va(ji,jj,jk) + zva 467 END DO 468 ENDIF 469 END DO 470 END DO 471 tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE. 482 472 ENDIF 483 473 484 474 END SUBROUTINE interpvn_sponge 485 475 -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r4785 r4789 12 12 USE wrk_nemo 13 13 USE dynspg_oce 14 USE zdf_oce ! vertical physics: ocean variables 14 15 15 16 IMPLICIT NONE … … 17 18 18 19 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 19 20 # if defined key_zdftke 21 PUBLIC Agrif_Update_Tke 22 # endif 20 23 !!---------------------------------------------------------------------- 21 !! NEMO/NST 3. 3, NEMO Consortium (2010)24 !! NEMO/NST 3.6 , NEMO Consortium (2010) 22 25 !! $Id$ 23 26 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 115 118 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 116 119 # endif 117 END IF 120 END IF 118 121 # endif 119 122 ! … … 132 135 END SUBROUTINE Agrif_Update_Dyn 133 136 137 # if defined key_zdftke 138 SUBROUTINE Agrif_Update_Tke( kt ) 139 !!--------------------------------------------- 140 !! *** ROUTINE Agrif_Update_Tke *** 141 !!--------------------------------------------- 142 !! 143 INTEGER, INTENT(in) :: kt 144 ! 145 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 146 # if defined TWO_WAY 147 148 Agrif_UseSpecialValueInUpdate = .TRUE. 149 Agrif_SpecialValueFineGrid = 0. 150 151 CALL Agrif_Update_Variable(avt_id ,locupdate=(/0,0/), procname=updateAVT ) 152 CALL Agrif_Update_Variable(avm_id ,locupdate=(/0,0/), procname=updateAVM ) 153 CALL Agrif_Update_Variable(avmu_id,locupdate=(/0,0/), procname=updateAVMu) 154 CALL Agrif_Update_Variable(avmv_id,locupdate=(/0,0/), procname=updateAVMv) 155 156 Agrif_UseSpecialValueInUpdate = .FALSE. 157 158 # endif 159 160 END SUBROUTINE Agrif_Update_Tke 161 # endif /* key_zdftke */ 134 162 135 163 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 164 192 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 165 193 tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 166 & + atfp * ( tabres(ji,jj,jk,jn) &167 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)194 & + atfp * ( tabres(ji,jj,jk,jn) & 195 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 168 196 ENDIF 169 197 ENDDO … … 220 248 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 221 249 ub(ji,jj,jk) = ub(ji,jj,jk) & 222 & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)250 & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 223 251 ENDIF 224 252 ! … … 264 292 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 265 293 vb(ji,jj,jk) = vb(ji,jj,jk) & 266 & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)294 & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 267 295 ENDIF 268 296 ! … … 406 434 ! 407 435 END SUBROUTINE updatev2d 408 436 409 437 410 438 SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) … … 430 458 DO jj=j1,j2 431 459 DO ji=i1,i2 432 sshb(ji,jj) = sshb(ji,jj) &433 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)460 sshb(ji,jj) = sshb(ji,jj) & 461 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 434 462 END DO 435 463 END DO … … 507 535 508 536 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 509 ! currently not used537 ! currently not used 510 538 !!--------------------------------------------- 511 539 !! *** ROUTINE updateT *** … … 521 549 522 550 IF (before) THEN 523 524 525 526 527 528 529 530 531 532 533 534 535 ELSE 536 537 538 539 551 DO jk=k1,k2 552 DO jj=j1,j2 553 DO ji=i1,i2 554 tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 555 tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 556 tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 557 END DO 558 END DO 559 END DO 560 tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 561 tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 562 tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 563 ELSE 564 DO jk=k1,k2 565 DO jj=j1,j2 566 DO ji=i1,i2 567 IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN 540 568 print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 541 569 print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) … … 544 572 print *,'CORR = ',ztemp-1. 545 573 print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 546 tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp574 tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 547 575 e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 548 576 e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 549 550 551 552 553 ENDIF 554 577 END IF 578 END DO 579 END DO 580 END DO 581 ENDIF 582 ! 555 583 END SUBROUTINE update_scales 584 585 # if defined key_zdftke 586 SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 587 !!--------------------------------------------- 588 !! *** ROUTINE updateavt *** 589 !!--------------------------------------------- 590 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 591 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 592 LOGICAL, INTENT(in) :: before 593 !!--------------------------------------------- 594 ! 595 IF (before) THEN 596 ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 597 ELSE 598 avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 599 ENDIF 600 ! 601 END SUBROUTINE updateAVT 602 603 604 SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 605 !!--------------------------------------------- 606 !! *** ROUTINE updateavm *** 607 !!--------------------------------------------- 608 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 609 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 610 LOGICAL, INTENT(in) :: before 611 !!--------------------------------------------- 612 ! 613 IF (before) THEN 614 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 615 ELSE 616 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 617 ENDIF 618 ! 619 END SUBROUTINE updateAVM 620 621 622 SUBROUTINE updateAVMu( ptab, i1, i2, j1, j2, k1, k2, before ) 623 !!--------------------------------------------- 624 !! *** ROUTINE updateavmu *** 625 !!--------------------------------------------- 626 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 627 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 628 LOGICAL, INTENT(in) :: before 629 !!--------------------------------------------- 630 ! 631 IF (before) THEN 632 ptab (i1:i2,j1:j2,k1:k2) = avmu_k(i1:i2,j1:j2,k1:k2) 633 ELSE 634 avmu_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 635 ENDIF 636 ! 637 END SUBROUTINE updateAVMu 638 639 640 SUBROUTINE updateAVMv( ptab, i1, i2, j1, j2, k1, k2, before ) 641 !!--------------------------------------------- 642 !! *** ROUTINE updateavmv *** 643 !!--------------------------------------------- 644 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 645 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 646 LOGICAL, INTENT(in) :: before 647 !!--------------------------------------------- 648 ! 649 IF (before) THEN 650 ptab (i1:i2,j1:j2,k1:k2) = avmv_k(i1:i2,j1:j2,k1:k2) 651 ELSE 652 avmv_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 653 ENDIF 654 ! 655 END SUBROUTINE updateAVMv 656 657 # endif /* key_zdftke */ 556 658 557 659 #else -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
r3680 r4789 19 19 # include "vectopt_loop_substitute.h90" 20 20 !!---------------------------------------------------------------------- 21 !! NEMO/NST 3. 3, NEMO Consortium (2010)21 !! NEMO/NST 3.6 , NEMO Consortium (2010) 22 22 !! $Id$ 23 23 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 28 28 SUBROUTINE Agrif_trc 29 29 !!---------------------------------------------------------------------- 30 !! *** ROUTINE Agrif_Tra *** 31 !!---------------------------------------------------------------------- 32 !! 33 INTEGER :: ji, jj, jk, jn ! dummy loop indices 34 REAL(wp) :: zrhox , alpha1, alpha2, alpha3 35 REAL(wp) :: alpha4, alpha5, alpha6, alpha7 36 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 30 !! *** ROUTINE Agrif_trc *** 37 31 !!---------------------------------------------------------------------- 38 32 ! 39 33 IF( Agrif_Root() ) RETURN 40 34 41 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra )42 43 35 Agrif_SpecialValue = 0.e0 44 36 Agrif_UseSpecialValue = .TRUE. 45 ztra(:,:,:,:) = 0.e046 37 47 CALL Agrif_Bc_variable( ztra,trn_id, procname=interptrn )38 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 48 39 Agrif_UseSpecialValue = .FALSE. 40 ! 41 END SUBROUTINE Agrif_trc 49 42 50 zrhox = Agrif_Rhox() 43 SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 44 !!--------------------------------------------- 45 !! *** ROUTINE interptsn *** 46 !!--------------------------------------------- 47 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 48 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 49 LOGICAL, INTENT(in) :: before 50 INTEGER, INTENT(in) :: nb , ndir 51 ! 52 INTEGER :: ji, jj, jk, jn ! dummy loop indices 53 INTEGER :: imin, imax, jmin, jmax 54 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 55 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 56 LOGICAL :: western_side, eastern_side,northern_side,southern_side 51 57 52 alpha1 = ( zrhox - 1. ) * 0.5 53 alpha2 = 1. - alpha1 54 55 alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 56 alpha4 = 1. - alpha3 57 58 alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 59 alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 60 alpha5 = 1. - alpha6 - alpha7 61 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 62 63 DO jn = 1, jptra 64 tra(nlci,:,:,jn) = alpha1 * ztra(nlci,:,:,jn) + alpha2 * ztra(nlci-1,:,:,jn) 65 DO jk = 1, jpkm1 66 DO jj = 1, jpj 67 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 68 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 69 ELSE 70 tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 71 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 72 tra(nlci-1,jj,jk,jn)=( alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn) & 73 & + alpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 58 IF (before) THEN 59 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 60 ELSE 61 ! 62 western_side = (nb == 1).AND.(ndir == 1) 63 eastern_side = (nb == 1).AND.(ndir == 2) 64 southern_side = (nb == 2).AND.(ndir == 1) 65 northern_side = (nb == 2).AND.(ndir == 2) 66 ! 67 zrhox = Agrif_Rhox() 68 ! 69 zalpha1 = ( zrhox - 1. ) * 0.5 70 zalpha2 = 1. - zalpha1 71 ! 72 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 73 zalpha4 = 1. - zalpha3 74 ! 75 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 76 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 77 zalpha5 = 1. - zalpha6 - zalpha7 78 ! 79 imin = i1 80 imax = i2 81 jmin = j1 82 jmax = j2 83 ! 84 ! Remove CORNERS 85 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 86 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 87 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 88 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 89 ! 90 IF( eastern_side) THEN 91 DO jn = 1, jptra 92 tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 93 DO jk = 1, jpkm1 94 DO jj = jmin,jmax 95 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 96 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 97 ELSE 98 tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 99 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 100 tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) & 101 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 102 ENDIF 74 103 ENDIF 75 ENDIF 104 END DO 105 END DO 106 ENDDO 107 ENDIF 108 ! 109 IF( northern_side ) THEN 110 DO jn = 1, jptra 111 tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 112 DO jk = 1, jpkm1 113 DO ji = imin,imax 114 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 115 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 116 ELSE 117 tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 118 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 119 tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn) & 120 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 121 ENDIF 122 ENDIF 123 END DO 124 END DO 125 ENDDO 126 ENDIF 127 ! 128 IF( western_side) THEN 129 DO jn = 1, jptra 130 tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 131 DO jk = 1, jpkm1 132 DO jj = jmin,jmax 133 IF( umask(2,jj,jk) == 0.e0 ) THEN 134 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 135 ELSE 136 tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 137 IF( un(2,jj,jk) < 0.e0 ) THEN 138 tra(2,jj,jk,jn)=(zalpha6*tra(3,jj,jk,jn)+zalpha5*tra(1,jj,jk,jn)+zalpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 139 ENDIF 140 ENDIF 141 END DO 76 142 END DO 77 143 END DO 78 ENDDO 79 ENDIF 80 81 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 82 83 DO jn = 1, jptra 84 tra(:,nlcj,:,jn) = alpha1 * ztra(:,nlcj,:,jn) + alpha2 * ztra(:,nlcj-1,:,jn) 85 DO jk = 1, jpkm1 86 DO ji = 1, jpi 87 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 88 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 89 ELSE 90 tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 91 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 92 tra(ji,nlcj-1,jk,jn)=( alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn) & 93 & + alpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 144 ENDIF 145 ! 146 IF( southern_side ) THEN 147 DO jn = 1, jptra 148 tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 149 DO jk=1,jpk 150 DO ji=imin,imax 151 IF( vmask(ji,2,jk) == 0.e0 ) THEN 152 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 153 ELSE 154 tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 155 IF( vn(ji,2,jk) < 0.e0 ) THEN 156 tra(ji,2,jk,jn)=(zalpha6*tra(ji,3,jk,jn)+zalpha5*tra(ji,1,jk,jn)+zalpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 157 ENDIF 94 158 ENDIF 95 END IF159 END DO 96 160 END DO 97 END DO 98 ENDDO 99 ENDIF 100 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 101 DO jn = 1, jptra 102 tra(1,:,:,jn) = alpha1 * ztra(1,:,:,jn) + alpha2 * ztra(2,:,:,jn) 103 DO jk = 1, jpkm1 104 DO jj = 1, jpj 105 IF( umask(2,jj,jk) == 0.e0 ) THEN 106 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 107 ELSE 108 tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 109 IF( un(2,jj,jk) < 0.e0 ) THEN 110 tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn)+alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 111 ENDIF 112 ENDIF 113 END DO 114 END DO 115 END DO 116 ENDIF 117 118 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 119 DO jn = 1, jptra 120 tra(:,1,:,jn) = alpha1 * ztra(:,1,:,jn) + alpha2 * ztra(:,2,:,jn) 121 DO jk=1,jpk 122 DO ji=1,jpi 123 IF( vmask(ji,2,jk) == 0.e0 ) THEN 124 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 125 ELSE 126 tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 127 IF( vn(ji,2,jk) < 0.e0 ) THEN 128 tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)+alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 129 ENDIF 130 ENDIF 131 END DO 132 END DO 133 ENDDO 161 ENDDO 162 ENDIF 163 ! 164 ! Treatment of corners 165 ! 166 ! East south 167 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 168 tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 169 ENDIF 170 ! East north 171 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 172 tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 173 ENDIF 174 ! West south 175 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 176 tra(2,2,:,:) = ptab(2,2,:,:) 177 ENDIF 178 ! West north 179 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 180 tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 181 ENDIF 182 ! 134 183 ENDIF 135 184 ! 136 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 137 ! 138 139 END SUBROUTINE Agrif_trc 185 END SUBROUTINE interptrn 140 186 141 187 #else -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90
r3680 r4789 1 1 #define SPONGE_TOP 2 2 3 M oduleagrif_top_sponge3 MODULE agrif_top_sponge 4 4 #if defined key_agrif && defined key_top 5 5 USE par_oce … … 16 16 PRIVATE 17 17 18 PUBLIC Agrif_Sponge_ Trc, interptrn18 PUBLIC Agrif_Sponge_trc, interptrn 19 19 20 !! * Substitutions20 !! * Substitutions 21 21 # include "domzgr_substitute.h90" 22 22 !!---------------------------------------------------------------------- 23 !! NEMO/NST 3. 3, NEMO Consortium (2010)23 !! NEMO/NST 3.6 , NEMO Consortium (2010) 24 24 !! $Id$ 25 25 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 26 26 !!---------------------------------------------------------------------- 27 27 28 28 CONTAINS 29 29 30 SUBROUTINE Agrif_Sponge_ Trc30 SUBROUTINE Agrif_Sponge_trc 31 31 !!--------------------------------------------- 32 32 !! *** ROUTINE Agrif_Sponge_Trc *** 33 33 !!--------------------------------------------- 34 34 !! 35 INTEGER :: ji,jj,jk,jn36 35 REAL(wp) :: timecoeff 37 REAL(wp) :: ztra, zabe1, zabe2, zbtr38 REAL(wp), POINTER, DIMENSION(:,:) :: ztru, ztrv39 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztabr40 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: trbdiff41 36 42 37 #if defined SPONGE_TOP 43 CALL wrk_alloc( jpi, jpj, ztru, ztrv )44 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztabr, trbdiff )45 46 38 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 47 39 CALL Agrif_sponge 48 40 Agrif_SpecialValue=0. 49 41 Agrif_UseSpecialValue = .TRUE. 50 ztabr = 0.e051 CALL Agrif_Bc_Variable( ztabr, tra_id,calledweight=timecoeff,procname=interptrn)42 tabspongetrn = .FALSE. 43 CALL Agrif_Bc_Variable(trn_sponge_id,calledweight=timecoeff,procname=interptrn_sponge) 52 44 Agrif_UseSpecialValue = .FALSE. 53 54 trbdiff(:,:,:,:) = trb(:,:,:,:) - ztabr(:,:,:,:)55 56 CALL Agrif_sponge57 58 DO jn = 1, jptra59 DO jk = 1, jpkm160 !61 DO jj = 1, jpjm162 DO ji = 1, jpim163 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk)64 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk)65 ztru(ji,jj) = zabe1 * ( trbdiff(ji+1,jj ,jk,jn) - trbdiff(ji,jj,jk,jn) )66 ztrv(ji,jj) = zabe2 * ( trbdiff(ji ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) )67 ENDDO68 ENDDO69 70 DO jj = 2,jpjm171 DO ji = 2,jpim172 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk)73 ! horizontal diffusive trends74 ztra = zbtr * ( ztru(ji,jj) - ztru(ji-1,jj) + ztrv(ji,jj) - ztrv(ji,jj-1) )75 ! add it to the general tracer trends76 tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra77 END DO78 END DO79 !80 ENDDO81 ENDDO82 83 CALL wrk_dealloc( jpi, jpj, ztru, ztrv )84 CALL wrk_dealloc( jpi, jpj, jpk, jptra, trbdiff, ztabr )85 45 86 46 #endif … … 88 48 END SUBROUTINE Agrif_Sponge_Trc 89 49 90 SUBROUTINE interptrn (tabres,i1,i2,j1,j2,k1,k2,n1,n2)50 SUBROUTINE interptrn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 91 51 !!--------------------------------------------- 92 !! *** ROUTINE interpt n***52 !! *** ROUTINE interptrn_sponge *** 93 53 !!--------------------------------------------- 94 54 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 95 55 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 56 LOGICAL, INTENT(in) :: before 57 58 59 INTEGER :: ji, jj, jk, jn ! dummy loop indices 60 61 REAL(wp) :: ztra, zabe1, zabe2, zbtr 62 REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 63 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::trbdiff 96 64 ! 97 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 65 IF (before) THEN 66 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 67 ELSE 98 68 99 END SUBROUTINE interptrn 69 trbdiff(:,:,:,:) = trb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:) 70 DO jn = 1, jptra 71 DO jk = 1, jpkm1 72 73 DO jj = j1,j2-1 74 DO ji = i1,i2-1 75 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 76 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 77 ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 78 ztv(ji,jj) = zabe2 * ( trbdiff(ji ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 79 ENDDO 80 ENDDO 81 82 DO jj = j1+1,j2-1 83 DO ji = i1+1,i2-1 84 85 IF (.NOT. tabspongedone_trn(ji,jj)) THEN 86 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 87 ! horizontal diffusive trends 88 ztra = zbtr * ( ztu(ji,jj) - ztu(ji-1,jj ) + ztv(ji,jj) - ztv(ji ,jj-1) ) 89 ! add it to the general tracer trends 90 tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 91 ENDIF 92 93 ENDDO 94 ENDDO 95 96 ENDDO 97 ENDDO 98 99 tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 100 ENDIF 101 ! 102 END SUBROUTINE interptrn_sponge 100 103 101 104 #else -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90
r4491 r4789 24 24 !!---------------------------------------------------------------------- 25 25 26 26 CONTAINS 27 27 28 28 SUBROUTINE Agrif_Update_Trc( kt ) … … 30 30 !! *** ROUTINE Agrif_Update_Trc *** 31 31 !!--------------------------------------------- 32 !!33 32 INTEGER, INTENT(in) :: kt 34 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 35 36 37 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 38 39 #if defined TWO_WAY 40 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 41 33 !!--------------------------------------------- 34 ! 35 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 36 #if defined TWO_WAY 42 37 Agrif_UseSpecialValueInUpdate = .TRUE. 43 38 Agrif_SpecialValueFineGrid = 0. 44 45 IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 46 CALL Agrif_Update_Variable(ztra,trn_id, procname=updateTRC) 39 ! 40 IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 41 # if ! defined DECAL_FEEDBACK 42 CALL Agrif_Update_Variable(trn_id, procname=updateTRC) 43 # else 44 CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC) 45 # endif 47 46 ELSE 48 CALL Agrif_Update_Variable(ztra,trn_id,locupdate=(/0,2/), procname=updateTRC) 47 # if ! defined DECAL_FEEDBACK 48 CALL Agrif_Update_Variable(trn_id,locupdate=(/0,2/), procname=updateTRC) 49 # else 50 CALL Agrif_Update_Variable(trn_id,locupdate=(/1,2/), procname=updateTRC) 51 # endif 49 52 ENDIF 50 53 ! 51 54 Agrif_UseSpecialValueInUpdate = .FALSE. 52 55 nbcline_trc = nbcline_trc + 1 53 54 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra )55 56 #endif 56 57 ! 57 58 END SUBROUTINE Agrif_Update_Trc 58 59 59 SUBROUTINE updateTRC( tabres,i1,i2,j1,j2,k1,k2,n1,n2,before)60 SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 60 61 !!--------------------------------------------- 61 !! *** ROUTINE UpdateTrc***62 !! *** ROUTINE updateT *** 62 63 !!--------------------------------------------- 64 # include "domzgr_substitute.h90" 63 65 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 64 REAL , DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres66 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 65 67 LOGICAL, INTENT(in) :: before 66 68 !! 67 69 INTEGER :: ji,jj,jk,jn 68 69 IF( before ) THEN 70 DO jn = n1, n2 71 DO jk = k1, k2 72 DO jj = j1, j2 73 DO ji = i1, i2 74 tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 75 ENDDO 76 ENDDO 77 ENDDO 78 ENDDO 79 ELSE 80 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 70 !!--------------------------------------------- 71 ! 72 IF (before) THEN 73 DO jn = n1,n2 74 DO jk=k1,k2 75 DO jj=j1,j2 76 DO ji=i1,i2 77 ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 78 END DO 79 END DO 80 END DO 81 END DO 82 ELSE 83 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 81 84 ! Add asselin part 82 DO jn = n1, n2 83 DO jk = k1, k2 84 DO jj = j1, j2 85 DO ji = i1, i2 86 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 87 trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) & 88 & + atfp * ( tabres(ji,jj,jk,jn) & 89 - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 90 ENDIF 91 ENDDO 92 ENDDO 93 ENDDO 94 ENDDO 95 ENDIF 96 97 DO jn = n1, n2 98 DO jk = k1, k2 99 DO jj = j1, j2 100 DO ji = i1, i2 101 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 102 trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 85 DO jn = n1,n2 86 DO jk=k1,k2 87 DO jj=j1,j2 88 DO ji=i1,i2 89 IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 90 trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) & 91 & + atfp * ( ptab(ji,jj,jk,jn) & 92 & - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 103 93 ENDIF 104 94 ENDDO … … 107 97 ENDDO 108 98 ENDIF 109 99 DO jn = n1,n2 100 DO jk=k1,k2 101 DO jj=j1,j2 102 DO ji=i1,i2 103 IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 104 trn(ji,jj,jk,jn) = ptab(ji,jj,jk,jn) * tmask(ji,jj,jk) 105 END IF 106 END DO 107 END DO 108 END DO 109 END DO 110 ENDIF 111 ! 110 112 END SUBROUTINE updateTRC 111 113 … … 119 121 END SUBROUTINE agrif_top_update_empty 120 122 #endif 121 END M oduleagrif_top_update123 END MODULE agrif_top_update -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r4785 r4789 64 64 ! 0. Initializations 65 65 !------------------- 66 IF( cp_cfg == 'orca' ) then66 IF( cp_cfg == 'orca' ) THEN 67 67 IF ( jp_cfg == 2 .OR. jp_cfg == 025 .OR. jp_cfg == 05 & 68 & .OR. jp_cfg == 4 ) THEN68 & .OR. jp_cfg == 4 ) THEN 69 69 jp_cfg = -1 ! set special value for jp_cfg on fine grids 70 70 cp_cfg = "default" … … 120 120 SUBROUTINE agrif_declare_var_dom 121 121 !!---------------------------------------------------------------------- 122 !! *** ROUTINE agrif_declar E_var ***122 !! *** ROUTINE agrif_declare_var *** 123 123 !! 124 124 !! ** Purpose :: Declaration of variables to be interpolated … … 137 137 ! 2. Type of interpolation 138 138 !------------------------- 139 C allAgrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm)140 C allAgrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear)139 CALL Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 140 CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 141 141 142 142 ! 3. Location of interpolation 143 143 !----------------------------- 144 C allAgrif_Set_bc(e1u_id,(/0,0/))145 C allAgrif_Set_bc(e2v_id,(/0,0/))144 CALL Agrif_Set_bc(e1u_id,(/0,0/)) 145 CALL Agrif_Set_bc(e2v_id,(/0,0/)) 146 146 147 147 ! 5. Update type 148 148 !--------------- 149 C allAgrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average)150 C allAgrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy)149 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 150 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 151 151 152 152 END SUBROUTINE agrif_declare_var_dom … … 188 188 CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 189 189 CALL Agrif_Sponge 190 tabspongedone = .FALSE.190 tabspongedone_tsn = .FALSE. 191 191 CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 192 192 ! reset tsa to zero … … 222 222 ! 3. Some controls 223 223 !----------------- 224 check_namelist = . true.224 check_namelist = .TRUE. 225 225 226 226 IF( check_namelist ) THEN 227 227 228 228 ! Check time steps 229 IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN230 write(cl_check1,*) nint(Agrif_Parent(rdt))231 write(cl_check2,*) nint(rdt)232 write(cl_check3,*) nint(Agrif_Parent(rdt)/Agrif_Rhot())229 IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 230 WRITE(cl_check1,*) NINT(Agrif_Parent(rdt)) 231 WRITE(cl_check2,*) NINT(rdt) 232 WRITE(cl_check3,*) NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 233 233 CALL ctl_warn( 'incompatible time step between grids', & 234 & 'parent grid value : '//cl_check1 , &235 & 'child grid value : '//cl_check2 , &236 & 'value on child grid will be changed to : '//cl_check3 )234 & 'parent grid value : '//cl_check1 , & 235 & 'child grid value : '//cl_check2 , & 236 & 'value on child grid will be changed to : '//cl_check3 ) 237 237 rdt=Agrif_Parent(rdt)/Agrif_Rhot() 238 238 ENDIF … … 240 240 ! Check run length 241 241 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 242 Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN243 write(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1244 write(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot()242 Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 243 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 244 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() 245 245 CALL ctl_warn( 'incompatible run length between grids' , & 246 & ' nit000 on fine grid will be change to : '//cl_check1, &247 & ' nitend on fine grid will be change to : '//cl_check2 )246 & ' nit000 on fine grid will be change to : '//cl_check1, & 247 & ' nitend on fine grid will be change to : '//cl_check2 ) 248 248 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 249 249 nitend = Agrif_Parent(nitend) *Agrif_IRhot() … … 253 253 IF( ln_zps ) THEN 254 254 ! check parameters for partial steps 255 IF( Agrif_Parent(e3zps_min) . ne. e3zps_min ) THEN255 IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 256 256 WRITE(*,*) 'incompatible e3zps_min between grids' 257 257 WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) … … 268 268 ENDIF 269 269 ENDIF 270 ! check if the bathy metry match 271 IF(ln_chk_bathy) CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 272 ! 270 273 ENDIF 271 274 ! 272 275 CALL Agrif_Update_tra(0) 273 276 CALL Agrif_Update_dyn(0) 277 # if defined key_zdftke 278 IF( ln_agrif_tke ) THEN 279 CALL Agrif_Update_tke(0) 280 ENDIF 281 # endif 274 282 ! 275 283 Agrif_UseSpecialValueInUpdate = .FALSE. … … 304 312 305 313 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 306 314 307 315 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 308 316 … … 316 324 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 317 325 326 # if defined key_zdftke 327 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 328 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 329 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avmu_id) 330 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avmv_id) 331 # endif 318 332 319 333 ! 2. Type of interpolation 320 334 !------------------------- 321 335 CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 322 336 323 337 CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 324 338 CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 325 339 326 340 CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 327 341 … … 335 349 CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 336 350 CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 337 351 338 352 CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 339 353 354 # if defined key_zdftke 355 CALL Agrif_Set_bcinterp(avt_id ,interp=AGRIF_linear) 356 CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 357 CALL Agrif_Set_bcinterp(avmu_id,interp=AGRIF_linear) 358 CALL Agrif_Set_bcinterp(avmv_id,interp=AGRIF_linear) 359 # endif 360 340 361 341 362 ! 3. Location of interpolation … … 352 373 CALL Agrif_Set_bc(unb_id ,(/0,0/)) 353 374 CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 354 C allAgrif_Set_bc(ub2b_interp_id,(/0,0/))355 C allAgrif_Set_bc(vb2b_interp_id,(/0,0/))375 CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 376 CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 356 377 357 378 CALL Agrif_Set_bc(e3t_id,(/-3*Agrif_irhox(),0/)) ! if west and rhox=3: column 2 to 11 379 380 # if defined key_zdftke 381 CALL Agrif_Set_bc(avt_id ,(/0,1/)) 382 CALL Agrif_Set_bc(avm_id ,(/0,1/)) 383 CALL Agrif_Set_bc(avmu_id,(/0,1/)) 384 CALL Agrif_Set_bc(avmv_id,(/0,1/)) 385 # endif 358 386 359 387 ! 5. Update type … … 367 395 CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 368 396 369 Call Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 370 Call Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 371 397 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 398 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 399 400 # if defined key_zdftke 401 CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 402 CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 403 CALL Agrif_Set_Updatetype(avmu_id, update = AGRIF_Update_Average) 404 CALL Agrif_Set_Updatetype(avmv_id, update = AGRIF_Update_Average) 405 # endif 372 406 ! 373 407 END SUBROUTINE agrif_declare_var … … 457 491 !------------------------- 458 492 CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 459 C allAgrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm)460 C allAgrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear)493 CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 494 CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 461 495 462 496 ! 3. Location of interpolation 463 497 !----------------------------- 464 C allAgrif_Set_bc(adv_ice_id ,(/0,1/))465 C allAgrif_Set_bc(u_ice_id,(/0,1/))466 C allAgrif_Set_bc(v_ice_id,(/0,1/))498 CALL Agrif_Set_bc(adv_ice_id ,(/0,1/)) 499 CALL Agrif_Set_bc(u_ice_id,(/0,1/)) 500 CALL Agrif_Set_bc(v_ice_id,(/0,1/)) 467 501 468 502 ! 5. Update type 469 503 !--------------- 470 C allAgrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average)471 C allAgrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)472 C allAgrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy)504 CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 505 CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 506 CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 473 507 474 508 END SUBROUTINE agrif_declare_var_lim2 … … 497 531 IMPLICIT NONE 498 532 ! 499 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp500 533 CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 501 534 LOGICAL :: check_namelist 502 535 !!---------------------------------------------------------------------- 503 504 ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) )505 536 506 537 … … 513 544 Agrif_SpecialValue=0. 514 545 Agrif_UseSpecialValue = .TRUE. 515 Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 516 Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 546 CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 517 547 Agrif_UseSpecialValue = .FALSE. 548 CALL Agrif_Sponge 549 tabspongedone_trn = .FALSE. 550 CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 551 ! reset tsa to zero 552 tra(:,:,:,:) = 0. 553 518 554 519 555 ! 3. Some controls 520 556 !----------------- 521 check_namelist = . true.557 check_namelist = .TRUE. 522 558 523 559 IF( check_namelist ) THEN 524 560 # if defined key_offline 525 561 ! Check time steps 526 IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN527 write(cl_check1,*) Agrif_Parent(rdt)528 write(cl_check2,*) rdt529 write(cl_check3,*) rdt*Agrif_Rhot()562 IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 563 WRITE(cl_check1,*) Agrif_Parent(rdt) 564 WRITE(cl_check2,*) rdt 565 WRITE(cl_check3,*) rdt*Agrif_Rhot() 530 566 CALL ctl_warn( 'incompatible time step between grids', & 531 & 'parent grid value : '//cl_check1 , &532 & 'child grid value : '//cl_check2 , &533 & 'value on child grid will be changed to &534 & :'//cl_check3 )567 & 'parent grid value : '//cl_check1 , & 568 & 'child grid value : '//cl_check2 , & 569 & 'value on child grid will be changed to & 570 & :'//cl_check3 ) 535 571 rdt=rdt*Agrif_Rhot() 536 572 ENDIF … … 538 574 ! Check run length 539 575 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 540 Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 541 WRITE(*,*) 'incompatible run length between grids' 542 WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 543 Agrif_Parent(nit000)+1),' time step' 544 WRITE(*,*) 'child grid value : ', & 545 (nitend-nit000+1),' time step' 546 WRITE(*,*) 'value on child grid should be : ', & 547 Agrif_IRhot() * (Agrif_Parent(nitend)- & 548 Agrif_Parent(nit000)+1) 549 CALL ctl_warn( 'incompatible run length between grids', & 550 & 'value on child grid will be change to ' & 551 & ) 552 553 576 Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 577 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 578 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() 579 CALL ctl_warn( 'incompatible run length between grids' , & 580 & ' nit000 on fine grid will be change to : '//cl_check1, & 581 & ' nitend on fine grid will be change to : '//cl_check2 ) 582 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 583 nitend = Agrif_Parent(nitend) *Agrif_IRhot() 554 584 ENDIF 555 585 … … 557 587 IF( ln_zps ) THEN 558 588 ! check parameters for partial steps 559 IF( Agrif_Parent(e3zps_min) . ne. e3zps_min ) THEN589 IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 560 590 WRITE(*,*) 'incompatible e3zps_min between grids' 561 591 WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) … … 564 594 STOP 565 595 ENDIF 566 IF( Agrif_Parent(e3zps_rat) . ne. e3zps_rat ) THEN596 IF( Agrif_Parent(e3zps_rat) .NE. e3zps_rat ) THEN 567 597 WRITE(*,*) 'incompatible e3zps_rat between grids' 568 598 WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) … … 574 604 # endif 575 605 ! Check passive tracer cell 576 IF( nn_dttrc . ne. 1 ) THEN606 IF( nn_dttrc .NE. 1 ) THEN 577 607 WRITE(*,*) 'nn_dttrc should be equal to 1' 578 608 ENDIF 579 609 ENDIF 580 610 581 !ch CALL Agrif_Update_trc(0) 611 CALL Agrif_Update_trc(0) 612 ! 613 Agrif_UseSpecialValueInUpdate = .FALSE. 582 614 nbcline_trc = 0 583 615 ! … … 601 633 ! 1. Declaration of the type of variable which have to be interpolated 602 634 !--------------------------------------------------------------------- 603 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 604 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 605 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 635 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 636 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 606 637 607 638 ! 2. Type of interpolation 608 639 !------------------------- 609 640 CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 610 CALL Agrif_Set_bcinterp(tr a_id,interp=AGRIF_linear)641 CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 611 642 612 643 ! 3. Location of interpolation 613 644 !----------------------------- 614 C allAgrif_Set_bc(trn_id,(/0,1/))615 C all Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/))645 CALL Agrif_Set_bc(trn_id,(/0,1/)) 646 CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 616 647 617 648 ! 5. Update type 618 649 !--------------- 619 Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 620 Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 621 622 650 CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 651 ! 623 652 END SUBROUTINE agrif_declare_var_top 624 653 # endif … … 650 679 ! 651 680 INTEGER :: ios ! Local integer output status for namelist read 652 NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 653 !!---------------------------------------------------------------------- 654 ! 655 REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : AGRIF zoom 656 READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 657 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 658 659 REWIND( numnam_cfg ) ! Namelist namagrif in configuration namelist : AGRIF zoom 660 READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 661 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 662 IF(lwm) WRITE ( numond, namagrif ) 681 NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy, & 682 & ln_agrif_tke 683 !!-------------------------------------------------------------------------------------- 684 ! 685 REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : AGRIF zoom 686 READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 687 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 688 689 REWIND( numnam_cfg ) ! Namelist namagrif in configuration namelist : AGRIF zoom 690 READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 691 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 692 IF(lwm) WRITE ( numond, namagrif ) 663 693 ! 664 694 IF(lwp) THEN ! control print … … 671 701 WRITE(numout,*) ' sponge coefficient for dynamics rn_sponge_tra = ', rn_sponge_dyn, ' s' 672 702 WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn 703 WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy 704 WRITE(numout,*) ' use TKE interpolation/update ln_agrif_tke = ', ln_agrif_tke 673 705 WRITE(numout,*) 674 706 ENDIF … … 702 734 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 703 735 CASE DEFAULT 704 736 indglob = indloc 705 737 END SELECT 706 738 ! … … 742 774 END SUBROUTINE Agrif_estimate_parallel_cost 743 775 744 745 776 # endif 746 777 -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90
r4147 r4789 42 42 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avmu , avmv !: vertical viscosity coef at uw- & vw-pts [m2/s] 43 43 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm , avt !: vertical viscosity & diffusivity coef at w-pt [m2/s] 44 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k , avm_k ! not enhanced Kz 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k, avmv_k ! not enhanced Kz 46 45 47 !!---------------------------------------------------------------------- 46 48 !! NEMO/OPA 4.0 , NEMO Consortium (2011) … … 57 59 ALLOCATE(avmb(jpk) , bfrua(jpi,jpj) , & 58 60 & avtb(jpk) , bfrva(jpi,jpj) , avtb_2d(jpi,jpj) , & 59 & avmu(jpi,jpj,jpk), avm(jpi,jpj,jpk) , & 60 & avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk) , STAT = zdf_oce_alloc ) 61 & avmu (jpi,jpj,jpk), avm (jpi,jpj,jpk), & 62 & avmv (jpi,jpj,jpk), avt (jpi,jpj,jpk), & 63 & avt_k (jpi,jpj,jpk), avm_k (jpi,jpj,jpk), & 64 & avmu_k(jpi,jpj,jpk), avmv_k(jpi,jpj,jpk), STAT = zdf_oce_alloc ) 61 65 ! 62 66 IF( zdf_oce_alloc /= 0 ) CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays') -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90
r4624 r4789 44 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: mxln !: now mixing length 45 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zwall !: wall function 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k ! not enhanced Kz47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avm_k ! not enhanced Kz48 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k ! not enhanced Kz49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmv_k ! not enhanced Kz50 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustars2 !: Squared surface velocity scale at T-points 51 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustarb2 !: Squared bottom velocity scale at T-points … … 123 119 !!---------------------------------------------------------------------- 124 120 ALLOCATE( en(jpi,jpj,jpk), mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) , & 125 & avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk), &126 & avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), &127 121 & ustars2(jpi,jpj), ustarb2(jpi,jpj) , STAT= zdf_gls_alloc ) 128 122 ! -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r4785 r4789 52 52 USE timing ! Timing 53 53 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 54 #if defined key_agrif 55 USE agrif_opa_interp 56 USE agrif_opa_update 57 #endif 54 58 55 59 IMPLICIT NONE … … 87 91 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: htau ! depth of tke penetration (nn_htau) 88 92 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dissl ! now mixing lenght of dissipation 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k , avm_k ! not enhanced Kz90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k, avmv_k ! not enhanced Kz91 93 #if defined key_c1d 92 94 ! !!** 1D cfg only ** ('key_c1d') … … 94 96 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e_pdl, e_ric !: prandl and local Richardson numbers 95 97 #endif 98 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wei3d ! 99 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,: ) :: wmix ! 96 100 97 101 !! * Substitutions … … 114 118 & e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) , & 115 119 #endif 116 & en (jpi,jpj,jpk) , htau (jpi,jpj) , dissl(jpi,jpj,jpk) , & 117 & avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk), & 118 & avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc ) 120 & en (jpi,jpj,jpk) , htau (jpi,jpj) , dissl(jpi,jpj,jpk) , & 121 & STAT= zdf_tke_alloc ) 119 122 ! 120 123 IF( lk_mpp ) CALL mpp_sum ( zdf_tke_alloc ) 121 124 IF( zdf_tke_alloc /= 0 ) CALL ctl_warn('zdf_tke_alloc: failed to allocate arrays') 125 ! 126 IF(.NOT. Agrif_Root()) THEN 127 ALLOCATE( wei3d(jpi,jpj,jpk), wmix(jpi,jpj), STAT= zdf_tke_alloc ) 128 IF( lk_mpp ) CALL mpp_sum ( zdf_tke_alloc ) 129 IF( zdf_tke_alloc /= 0 ) CALL ctl_warn('zdf_tke_alloc2: failed to allocate arrays') 130 ENDIF 122 131 ! 123 132 END FUNCTION zdf_tke_alloc … … 173 182 ! 174 183 IF( kt /= nit000 ) THEN ! restore before value to compute tke 184 #if defined key_agrif 185 ! interpolation parent grid => child grid for avt_k, avm_k, avmu_k, avmv_k 186 !( ex : at west border: update column 1 and 2) 187 IF(ln_agrif_tke) CALL Agrif_Tke 188 #endif 175 189 avt (:,:,:) = avt_k (:,:,:) 176 190 avm (:,:,:) = avm_k (:,:,:) … … 188 202 avmv_k(:,:,:) = avmv(:,:,:) 189 203 ! 190 END SUBROUTINE zdf_tke 204 #if defined key_agrif 205 ! Update child grid f => parent grid 206 IF( .NOT.Agrif_Root() .AND. ln_agrif_tke) CALL Agrif_Update_Tke( kt ) ! children only 207 #endif 208 ! 209 END SUBROUTINE zdf_tke 191 210 192 211 … … 341 360 END DO 342 361 END DO 343 !344 IF( .NOT. AGRIF_Root() ) THEN345 DO jk = 1, jpkm1346 IF ((nbondi == 1).OR.(nbondi == 2)) avmu(nlci-1 , : ,jk) = avmu(nlci-2 , : ,jk) ! east347 IF ((nbondi == -1).OR.(nbondi == 2)) avmu(1 , : ,jk) = avmu(2 , : ,jk) ! west348 IF ((nbondj == 1).OR.(nbondj == 2)) avmv(: ,nlcj-1 ,jk) = avmv(: ,nlcj-2 ,jk) ! north349 IF ((nbondj == -1).OR.(nbondj == 2)) avmv(: ,1 ,jk) = avmv(: ,2 ,jk) ! south350 END DO351 ENDIF352 362 ! 353 363 DO jk = 2, jpkm1 !* Matrix and right hand side in en … … 501 511 REAL(wp) :: zdku, zpdlr, zri, zsqen ! - - 502 512 REAL(wp) :: zdkv, zemxl, zemlm, zemlp ! - - 513 REAL(wp), POINTER, DIMENSION(:,: ) :: ztmp2d 503 514 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmpdl, zmxlm, zmxld 504 515 !!-------------------------------------------------------------------- … … 506 517 IF( nn_timing == 1 ) CALL timing_start('tke_avn') 507 518 519 CALL wrk_alloc( jpi,jpj, ztmp2d ) 508 520 CALL wrk_alloc( jpi,jpj,jpk, zmpdl, zmxlm, zmxld ) 509 521 … … 636 648 END DO 637 649 CALL lbc_lnk( avm, 'W', 1. ) ! Lateral boundary conditions (sign unchanged) 650 ! 651 # if defined key_agrif 652 IF( .NOT. AGRIF_Root() ) THEN 653 IF( ln_agrif_tke ) THEN 654 DO jk = 1, jpkm1 655 DO jj = 2, jpjm1 656 DO ji = 2, jpim1 657 ztmp2d(ji,jj) = 1. * avm(ji-1,jj-1,jk) * tmask(ji-1,jj-1,jk) & 658 & + 2. * avm(ji ,jj-1,jk) * tmask(ji ,jj-1,jk) & 659 & + 1. * avm(ji+1,jj-1,jk) * tmask(ji+1,jj-1,jk) & 660 & + 2. * avm(ji-1,jj ,jk) * tmask(ji-1,jj ,jk) & 661 & + 4. * avm(ji ,jj ,jk) * tmask(ji ,jj ,jk) & 662 & + 2. * avm(ji+1,jj ,jk) * tmask(ji+1,jj ,jk) & 663 & + 1. * avm(ji-1,jj+1,jk) * tmask(ji-1,jj+1,jk) & 664 & + 2. * avm(ji ,jj+1,jk) * tmask(ji ,jj+1,jk) & 665 & + 1. * avm(ji+1,jj+1,jk) * tmask(ji+1,jj+1,jk) 666 END DO 667 END DO 668 DO jj = 2, jpjm1 669 DO ji = 2, jpim1 670 avm(ji,jj,jk) = ztmp2d(ji,jj) * wei3d(ji,jj,jk) * wmix(ji,jj) + avm(ji,jj,jk) * ( 1. - wmix(ji,jj) ) 671 END DO 672 END DO 673 END DO 674 CALL lbc_lnk( avm, 'W', 1. ) ! Lateral boundary conditions (sign unchanged) 675 DO jk = 1, jpkm1 676 DO jj = 2, jpjm1 677 DO ji = 2, jpim1 678 ztmp2d(ji,jj) = 1. * avt(ji-1,jj-1,jk) * tmask(ji-1,jj-1,jk) & 679 & + 2. * avt(ji ,jj-1,jk) * tmask(ji ,jj-1,jk) & 680 & + 1. * avt(ji+1,jj-1,jk) * tmask(ji+1,jj-1,jk) & 681 & + 2. * avt(ji-1,jj ,jk) * tmask(ji-1,jj ,jk) & 682 & + 4. * avt(ji ,jj ,jk) * tmask(ji ,jj ,jk) & 683 & + 2. * avt(ji+1,jj ,jk) * tmask(ji+1,jj ,jk) & 684 & + 1. * avt(ji-1,jj+1,jk) * tmask(ji-1,jj+1,jk) & 685 & + 2. * avt(ji ,jj+1,jk) * tmask(ji ,jj+1,jk) & 686 & + 1. * avt(ji+1,jj+1,jk) * tmask(ji+1,jj+1,jk) 687 END DO 688 END DO 689 DO jj = 2, jpjm1 690 DO ji = 2, jpim1 691 avt(ji,jj,jk) = ztmp2d(ji,jj) * wei3d(ji,jj,jk) * wmix(ji,jj) + avt(ji,jj,jk) * ( 1. - wmix(ji,jj) ) 692 END DO 693 END DO 694 END DO 695 CALL lbc_lnk( avt, 'W', 1. ) ! Lateral boundary conditions (sign unchanged) 696 ELSE 697 DO jk = 1, jpkm1 698 IF ((nbondi == 1).OR.(nbondi == 2)) avmu(nlci-1 , : ,jk) = avmu(nlci-2 , : ,jk) ! east 699 IF ((nbondi == -1).OR.(nbondi == 2)) avmu(1 , : ,jk) = avmu(2 , : ,jk) ! west 700 IF ((nbondj == 1).OR.(nbondj == 2)) avmv(: ,nlcj-1 ,jk) = avmv(: ,nlcj-2 ,jk) ! north 701 IF ((nbondj == -1).OR.(nbondj == 2)) avmv(: ,1 ,jk) = avmv(: ,2 ,jk) ! south 702 END DO 703 ENDIF 704 ENDIF 705 # endif /* key_Agrif */ 638 706 ! 639 707 DO jk = 2, jpkm1 !* vertical eddy viscosity at u- and v-points … … 679 747 ENDIF 680 748 ! 749 CALL wrk_dealloc( jpi,jpj, ztmp2d ) 681 750 CALL wrk_dealloc( jpi,jpj,jpk, zmpdl, zmxlm, zmxld ) 682 751 !
Note: See TracChangeset
for help on using the changeset viewer.