Changeset 7953 for branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC
- Timestamp:
- 2017-04-23T09:30:41+02:00 (7 years ago)
- Location:
- branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC
- Files:
-
- 11 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_ice.F90
r7646 r7953 18 18 PUBLIC agrif_ice_alloc ! routine called by nemo_init in nemogcm.F90 19 19 20 INTEGER , PUBLIC ::u_ice_id, v_ice_id, adv_ice_id21 REAL(wp), PUBLIC :: lim_nbstep = 0. ! child time position in sea-ice model20 INTEGER , PUBLIC :: u_ice_id, v_ice_id, adv_ice_id 21 REAL(wp), PUBLIC :: lim_nbstep = 0. ! child time position in sea-ice model 22 22 #if defined key_lim2_vp 23 23 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: u_ice_nst, v_ice_nst 24 24 #else 25 25 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: u_ice_oe, u_ice_sn !: boundaries arrays 26 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: v_ice_oe, v_ice_sn !: " "26 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: v_ice_oe, v_ice_sn !: - - 27 27 #endif 28 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: adv_ice_oe, adv_ice_sn !: " "28 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: adv_ice_oe, adv_ice_sn !: - - 29 29 30 30 !!---------------------------------------------------------------------- 31 !! NEMO/NST 3.3.4 , NEMO Consortium (2012)31 !! NEMO/NST 4.0 , NEMO Consortium (2017) 32 32 !! $Id$ 33 33 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 34 34 !!---------------------------------------------------------------------- 35 36 35 CONTAINS 37 36 … … 50 49 51 50 #if ! defined key_lim2_vp 52 u_ice_oe(:,:,:) = 0. e053 v_ice_oe(:,:,:) = 0. e054 u_ice_sn(:,:,:) = 0. e055 v_ice_sn(:,:,:) = 0. e051 u_ice_oe(:,:,:) = 0._wp 52 v_ice_oe(:,:,:) = 0._wp 53 u_ice_sn(:,:,:) = 0._wp 54 v_ice_sn(:,:,:) = 0._wp 56 55 #endif 57 adv_ice_oe (:,:,:,:) = 0. e058 adv_ice_sn (:,:,:,:) = 0. e056 adv_ice_oe (:,:,:,:) = 0._wp 57 adv_ice_sn (:,:,:,:) = 0._wp 59 58 ! 60 59 END FUNCTION agrif_ice_alloc … … 71 70 72 71 !!---------------------------------------------------------------------- 73 !! NEMO/NST 3.6 , NEMO Consortium (2016)72 !! NEMO/NST 4.0 , NEMO Consortium (2017) 74 73 !! $Id$ 75 74 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_lim3_interp.F90
r7761 r7953 28 28 PRIVATE 29 29 30 PUBLIC agrif_interp_lim330 PUBLIC agrif_interp_lim3 ! called by ??? 31 31 32 32 !!---------------------------------------------------------------------- … … 46 46 !! computing factor for time interpolation 47 47 !!----------------------------------------------------------------------- 48 CHARACTER(len=1), INTENT( in ) ::cd_type49 INTEGER , INTENT( in ), OPTIONAL ::kiter, kitermax50 !! 51 REAL(wp) :: zbeta48 CHARACTER(len=1), INTENT(in ) :: cd_type 49 INTEGER , INTENT(in ), OPTIONAL :: kiter, kitermax 50 !! 51 REAL(wp) :: zbeta ! local scalar 52 52 !!----------------------------------------------------------------------- 53 53 ! 54 54 IF( Agrif_Root() ) RETURN 55 55 ! 56 SELECT CASE( cd_type)56 SELECT CASE( cd_type ) 57 57 CASE('U','V') 58 58 IF( PRESENT( kiter ) ) THEN ! interpolation at the child sub-time step (only for ice rheology) … … 66 66 END SELECT 67 67 ! 68 Agrif_SpecialValue =-9999.68 Agrif_SpecialValue = -9999. 69 69 Agrif_UseSpecialValue = .TRUE. 70 SELECT CASE(cd_type) 71 CASE('U') 72 CALL Agrif_Bc_variable( u_ice_id , procname=interp_u_ice , calledweight=zbeta ) 73 CASE('V') 74 CALL Agrif_Bc_variable( v_ice_id , procname=interp_v_ice , calledweight=zbeta ) 75 CASE('T') 76 CALL Agrif_Bc_variable( tra_ice_id, procname=interp_tra_ice, calledweight=zbeta ) 70 SELECT CASE( cd_type ) 71 CASE('U') ; CALL Agrif_Bc_variable( u_ice_id , procname=interp_u_ice , calledweight=zbeta ) 72 CASE('V') ; CALL Agrif_Bc_variable( v_ice_id , procname=interp_v_ice , calledweight=zbeta ) 73 CASE('T') ; CALL Agrif_Bc_variable( tra_ice_id, procname=interp_tra_ice, calledweight=zbeta ) 77 74 END SELECT 78 Agrif_SpecialValue =0.75 Agrif_SpecialValue = 0._wp 79 76 Agrif_UseSpecialValue = .FALSE. 80 77 ! 81 78 END SUBROUTINE agrif_interp_lim3 82 79 83 !!------------------ 84 !! Local subroutines 85 !!------------------ 80 86 81 SUBROUTINE interp_u_ice( ptab, i1, i2, j1, j2, before ) 87 82 !!----------------------------------------------------------------------- … … 92 87 !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 93 88 !!----------------------------------------------------------------------- 94 INTEGER , INTENT(in) ::i1, i2, j1, j295 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab96 LOGICAL , INTENT(in) ::before97 !! 98 REAL(wp) :: zrhoy89 INTEGER , INTENT(in ) :: i1, i2, j1, j2 90 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 91 LOGICAL , INTENT(in ) :: before 92 !! 93 REAL(wp) :: zrhoy ! local scalar 99 94 !!----------------------------------------------------------------------- 100 95 ! … … 118 113 !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 119 114 !!----------------------------------------------------------------------- 120 INTEGER , INTENT(in) ::i1, i2, j1, j2121 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab122 LOGICAL , INTENT(in) ::before123 !! 124 REAL(wp) :: zrhox115 INTEGER , INTENT(in ) :: i1, i2, j1, j2 116 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 117 LOGICAL , INTENT(in ) :: before 118 !! 119 REAL(wp) :: zrhox ! local scalar 125 120 !!----------------------------------------------------------------------- 126 121 ! … … 144 139 !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 145 140 !!----------------------------------------------------------------------- 146 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 147 INTEGER , INTENT(in) :: i1, i2, j1, j2, k1, k2 148 LOGICAL , INTENT(in) :: before 149 INTEGER , INTENT(in) :: nb, ndir 150 !! 151 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztab 141 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 142 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 143 LOGICAL , INTENT(in ) :: before 144 INTEGER , INTENT(in ) :: nb, ndir 145 !! 152 146 INTEGER :: ji, jj, jk, jl, jm 153 147 INTEGER :: imin, imax, jmin, jmax 148 LOGICAL :: western_side, eastern_side, northern_side, southern_side 154 149 REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7 155 LOGICAL :: western_side, eastern_side, northern_side, southern_side 156 157 !!----------------------------------------------------------------------- 158 ! tracers are not multiplied by grid cell here => before: * e12t ; after: * r1_e12t / rhox / rhoy 150 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztab 151 !!----------------------------------------------------------------------- 152 ! tracers are not multiplied by grid cell here => before: * e1e2t ; after: * r1_e1e2t / rhox / rhoy 159 153 ! and it is ok since we conserve tracers (same as in the ocean). 160 154 ALLOCATE( ztab(SIZE(a_i_b,1),SIZE(a_i_b,2),SIZE(ptab,3)) ) … … 163 157 jm = 1 164 158 DO jl = 1, jpl 165 ptab(i1:i2,j1:j2,jm) = a_i_b (i1:i2,j1:j2,jl) ;jm = jm + 1166 ptab(i1:i2,j1:j2,jm) = v_i_b (i1:i2,j1:j2,jl) ;jm = jm + 1167 ptab(i1:i2,j1:j2,jm) = v_s_b (i1:i2,j1:j2,jl) ;jm = jm + 1168 ptab(i1:i2,j1:j2,jm) = smv_i_b(i1:i2,j1:j2,jl) ;jm = jm + 1169 ptab(i1:i2,j1:j2,jm) = oa_i_b (i1:i2,j1:j2,jl) ;jm = jm + 1159 ptab(i1:i2,j1:j2,jm) = a_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 160 ptab(i1:i2,j1:j2,jm) = v_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 161 ptab(i1:i2,j1:j2,jm) = v_s_b (i1:i2,j1:j2,jl) ; jm = jm + 1 162 ptab(i1:i2,j1:j2,jm) = smv_i_b(i1:i2,j1:j2,jl) ; jm = jm + 1 163 ptab(i1:i2,j1:j2,jm) = oa_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 170 164 DO jk = 1, nlay_s 171 ptab(i1:i2,j1:j2,jm) = e_s_b(i1:i2,j1:j2,jk,jl) ;jm = jm + 1172 END DO165 ptab(i1:i2,j1:j2,jm) = e_s_b(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 166 END DO 173 167 DO jk = 1, nlay_i 174 ptab(i1:i2,j1:j2,jm) = e_i_b(i1:i2,j1:j2,jk,jl) ;jm = jm + 1175 END DO176 END DO168 ptab(i1:i2,j1:j2,jm) = e_i_b(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 169 END DO 170 END DO 177 171 178 172 DO jk = k1, k2 179 WHERE( tmask(i1:i2,j1:j2,1) == 0. )ptab(i1:i2,j1:j2,jk) = -9999.180 END DO173 WHERE( tmask(i1:i2,j1:j2,1) == 0._wp ) ptab(i1:i2,j1:j2,jk) = -9999. 174 END DO 181 175 182 176 ELSE ! child grid … … 184 178 jm = 1 185 179 DO jl = 1, jpl 186 a_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1187 v_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1188 v_s (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1189 smv_i(i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1190 oa_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1180 a_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 181 v_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 182 v_s (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 183 smv_i(i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 184 oa_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 191 185 DO jk = 1, nlay_s 192 e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1193 END DO186 e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 187 END DO 194 188 DO jk = 1, nlay_i 195 e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1196 END DO197 END DO189 e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 190 END DO 191 END DO 198 192 199 193 !! ==> this is a more complex interpolation since we mix solutions over a couple of grid points … … 319 313 et_s(i1:i2,j1:j2) = SUM( SUM( e_s(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 320 314 et_i(i1:i2,j1:j2) = SUM( SUM( e_i(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 321 315 ! 322 316 ENDIF 323 317 … … 327 321 328 322 #else 323 !!---------------------------------------------------------------------- 324 !! Empty module no sea-ice 325 !!---------------------------------------------------------------------- 329 326 CONTAINS 330 327 SUBROUTINE agrif_lim3_interp_empty 331 !!---------------------------------------------332 !! *** ROUTINE agrif_lim3_interp_empty ***333 !!---------------------------------------------334 328 WRITE(*,*) 'agrif_lim3_interp : You should not have seen this print! error?' 335 329 END SUBROUTINE agrif_lim3_interp_empty 336 330 #endif 331 332 !!====================================================================== 337 333 END MODULE agrif_lim3_interp -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_lim3_update.F90
r7761 r7953 31 31 PRIVATE 32 32 33 PUBLIC agrif_update_lim333 PUBLIC agrif_update_lim3 ! called by ???? 34 34 35 35 !!---------------------------------------------------------------------- 36 !! NEMO/NST 3.6 , LOCEAN-IPSL (2016)36 !! NEMO/NST 4.0 , LOCEAN-IPSL (2017) 37 37 !! $Id: agrif_lim3_update.F90 6204 2016-01-04 13:47:06Z cetlod $ 38 38 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 39 39 !!---------------------------------------------------------------------- 40 41 40 CONTAINS 42 41 … … 49 48 !!---------------------------------------------------------------------- 50 49 INTEGER, INTENT(in) :: kt 51 !!52 50 !!---------------------------------------------------------------------- 53 51 ! … … 57 55 ! i.e. update only at the parent time step 58 56 Agrif_UseSpecialValueInUpdate = .TRUE. 59 Agrif_SpecialValueFineGrid = -9999.57 Agrif_SpecialValueFineGrid = -9999. 60 58 # if defined TWO_WAY 61 59 IF( MOD(nbcline,nbclineupdate) == 0) THEN ! update the whole basin at each nbclineupdate (=nn_cln_update) baroclinic parent time steps … … 75 73 76 74 77 !!------------------78 !! Local subroutines79 !!------------------80 75 SUBROUTINE update_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before ) 81 76 !!----------------------------------------------------------------------- … … 84 79 !! the properties per mass on the coarse grid 85 80 !!----------------------------------------------------------------------- 86 INTEGER , INTENT(in) ::i1, i2, j1, j2, k1, k287 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab88 LOGICAL , INTENT(in) ::before81 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 82 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 83 LOGICAL , INTENT(in ) :: before 89 84 !! 90 85 INTEGER :: jk, jl, jm … … 94 89 jm = 1 95 90 DO jl = 1, jpl 96 ptab(:,:,jm) = a_i (i1:i2,j1:j2,jl) ;jm = jm + 197 ptab(:,:,jm) = v_i (i1:i2,j1:j2,jl) ;jm = jm + 198 ptab(:,:,jm) = v_s (i1:i2,j1:j2,jl) ;jm = jm + 199 ptab(:,:,jm) = smv_i(i1:i2,j1:j2,jl) ;jm = jm + 1100 ptab(:,:,jm) = oa_i (i1:i2,j1:j2,jl) ;jm = jm + 191 ptab(:,:,jm) = a_i (i1:i2,j1:j2,jl) ; jm = jm + 1 92 ptab(:,:,jm) = v_i (i1:i2,j1:j2,jl) ; jm = jm + 1 93 ptab(:,:,jm) = v_s (i1:i2,j1:j2,jl) ; jm = jm + 1 94 ptab(:,:,jm) = smv_i(i1:i2,j1:j2,jl) ; jm = jm + 1 95 ptab(:,:,jm) = oa_i (i1:i2,j1:j2,jl) ; jm = jm + 1 101 96 DO jk = 1, nlay_s 102 ptab(:,:,jm) = e_s(i1:i2,j1:j2,jk,jl) ;jm = jm + 1103 END DO97 ptab(:,:,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 98 END DO 104 99 DO jk = 1, nlay_i 105 ptab(:,:,jm) = e_i(i1:i2,j1:j2,jk,jl) ;jm = jm + 1106 END DO107 END DO100 ptab(:,:,jm) = e_i(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 101 END DO 102 END DO 108 103 109 104 DO jk = k1, k2 110 105 WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab(:,:,jk) = -9999. 111 END DO112 106 END DO 107 ! 113 108 ELSE 114 109 jm = 1 115 110 DO jl = 1, jpl 116 a_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1117 v_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1118 v_s (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1119 smv_i(i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1120 oa_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1111 a_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 112 v_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 113 v_s (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 114 smv_i(i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 115 oa_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 121 116 DO jk = 1, nlay_s 122 e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1117 e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 123 118 ENDDO 124 119 DO jk = 1, nlay_i 125 e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ;jm = jm + 1126 END DO127 END DO120 e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 121 END DO 122 END DO 128 123 129 124 ! integrated values … … 144 139 !! ** Method : Update the fluxes and recover the properties (C-grid) 145 140 !!----------------------------------------------------------------------- 146 INTEGER , INTENT(in) ::i1, i2, j1, j2147 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab148 LOGICAL , INTENT(in) ::before141 INTEGER , INTENT(in ) :: i1, i2, j1, j2 142 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 143 LOGICAL , INTENT(in ) :: before 149 144 !! 150 REAL(wp) :: zrhoy145 REAL(wp) :: zrhoy ! local scalar 151 146 !!----------------------------------------------------------------------- 152 147 ! … … 154 149 zrhoy = Agrif_Rhoy() 155 150 ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2) * zrhoy 156 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.151 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999. 157 152 ELSE 158 153 u_ice(i1:i2,j1:j2) = ptab(:,:) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1) … … 167 162 !! ** Method : Update the fluxes and recover the properties (C-grid) 168 163 !!----------------------------------------------------------------------- 169 INTEGER , INTENT(in) :: i1,i2,j1,j2170 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::ptab171 LOGICAL , INTENT(in) ::before164 INTEGER , INTENT(in ) :: i1, i2, j1, j2 165 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 166 LOGICAL , INTENT(in ) :: before 172 167 !! 173 REAL(wp) :: zrhox168 REAL(wp) :: zrhox ! local scalar 174 169 !!----------------------------------------------------------------------- 175 170 ! … … 177 172 zrhox = Agrif_Rhox() 178 173 ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2) * zrhox 179 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.174 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999. 180 175 ELSE 181 176 v_ice(i1:i2,j1:j2) = ptab(:,:) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1) … … 185 180 186 181 #else 182 !!---------------------------------------------------------------------- 183 !! Empty module no sea-ice 184 !!---------------------------------------------------------------------- 187 185 CONTAINS 188 186 SUBROUTINE agrif_lim3_update_empty 189 !!---------------------------------------------190 !! *** ROUTINE agrif_lim3_update_empty ***191 !!---------------------------------------------192 187 WRITE(*,*) 'agrif_lim3_update : You should not have seen this print! error?' 193 188 END SUBROUTINE agrif_lim3_update_empty 194 189 #endif 190 191 !!====================================================================== 195 192 END MODULE agrif_lim3_update -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r5656 r7953 47 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsahm_spt, fsahm_spf !: sponge viscosities 48 48 49 ! Barotropic arrays used to store open boundary data during 50 ! time-splitting loop: 49 ! Barotropic arrays used to store open boundary data during time-splitting loop: 51 50 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 52 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e … … 54 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 55 54 56 INTEGER :: tsn_id ! AGRIF profile for tracers interpolation and update 57 INTEGER :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations 58 INTEGER :: un_update_id, vn_update_id ! AGRIF profiles for udpates 59 INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 55 !!gm add PUBLIC in all variable below: 56 57 INTEGER, PUBLIC :: tsn_id ! AGRIF profile for tracers interpolation and update 58 INTEGER, PUBLIC :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations 59 INTEGER, PUBLIC :: un_update_id, vn_update_id ! AGRIF profiles for udpates 60 INTEGER, PUBLIC :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 60 61 # if defined key_top 61 INTEGER :: trn_id, trn_sponge_id62 INTEGER, PUBLIC :: trn_id, trn_sponge_id 62 63 # endif 63 INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id64 INTEGER :: ub2b_update_id, vb2b_update_id65 INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id66 INTEGER :: scales_t_id67 # if defined key_zdftke 68 INTEGER :: avt_id, avm_id, en_id69 # endif 70 INTEGER :: umsk_id, vmsk_id71 INTEGER :: kindic_agr 64 INTEGER, PUBLIC :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 65 INTEGER, PUBLIC :: ub2b_update_id, vb2b_update_id 66 INTEGER, PUBLIC :: e3t_id, e1u_id, e2v_id, sshn_id 67 INTEGER, PUBLIC :: scales_t_id 68 INTEGER, PUBLIC :: avt_id, avm_id, en_id ! TKE related identificators 69 INTEGER, PUBLIC :: umsk_id, vmsk_id 70 INTEGER, PUBLIC :: kindic_agr 71 72 !!gm end public addition 72 73 73 74 !!---------------------------------------------------------------------- -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r7646 r7953 21 21 USE oce 22 22 USE dom_oce 23 USE zdf_oce 23 USE zdf_oce ! vertical physics 24 24 USE agrif_oce 25 25 USE phycst … … 34 34 35 35 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 36 PUBLIC interpun , interpvn37 PUBLIC interptsn, 38 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b36 PUBLIC interpun , interpvn 37 PUBLIC interptsn, interpsshn 38 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 39 39 PUBLIC interpe3t, interpumsk, interpvmsk 40 # if defined key_zdftke41 40 PUBLIC Agrif_tke, interpavm 42 # endif43 41 44 42 INTEGER :: bdy_tinterp = 0 … … 46 44 # include "vectopt_loop_substitute.h90" 47 45 !!---------------------------------------------------------------------- 48 !! NEMO/NST 3.7 , NEMO Consortium (2015)46 !! NEMO/NST 4.0 , NEMO Consortium (2017) 49 47 !! $Id$ 50 48 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 385 383 !! *** ROUTINE Agrif_dyn_ts *** 386 384 !!---------------------------------------------------------------------- 387 !!388 385 INTEGER, INTENT(in) :: jn 389 386 !! … … 444 441 !! *** ROUTINE Agrif_dta_ts *** 445 442 !!---------------------------------------------------------------------- 446 !!447 443 INTEGER, INTENT(in) :: kt 448 444 !! … … 504 500 !!---------------------------------------------------------------------- 505 501 INTEGER, INTENT(in) :: kt 506 !!507 502 !!---------------------------------------------------------------------- 508 503 ! … … 541 536 !!---------------------------------------------------------------------- 542 537 ! 543 IF( (nbondi == -1).OR.(nbondi == 2)) THEN538 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 544 539 DO jj = 1, jpj 545 540 ssha_e(2,jj) = hbdy_w(jj) … … 547 542 ENDIF 548 543 ! 549 IF( (nbondi == 1).OR.(nbondi == 2)) THEN544 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 550 545 DO jj = 1, jpj 551 546 ssha_e(nlci-1,jj) = hbdy_e(jj) … … 553 548 ENDIF 554 549 ! 555 IF( (nbondj == -1).OR.(nbondj == 2)) THEN550 IF( nbondj == -1 .OR.(nbondj == 2 ) THEN 556 551 DO ji = 1, jpi 557 552 ssha_e(ji,2) = hbdy_s(ji) … … 559 554 ENDIF 560 555 ! 561 IF( (nbondj == 1).OR.(nbondj == 2)) THEN556 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 562 557 DO ji = 1, jpi 563 558 ssha_e(ji,nlcj-1) = hbdy_n(ji) … … 567 562 END SUBROUTINE Agrif_ssh_ts 568 563 569 # if defined key_zdftke570 564 571 565 SUBROUTINE Agrif_tke … … 579 573 IF( zalpha > 1. ) zalpha = 1. 580 574 ! 581 Agrif_SpecialValue = 0. e0575 Agrif_SpecialValue = 0._wp 582 576 Agrif_UseSpecialValue = .TRUE. 583 577 ! 584 CALL Agrif_Bc_variable( avm_id ,calledweight=zalpha, procname=interpavm)578 CALL Agrif_Bc_variable( avm_id , calledweight=zalpha, procname=interpavm ) 585 579 ! 586 580 Agrif_UseSpecialValue = .FALSE. 587 581 ! 588 582 END SUBROUTINE Agrif_tke 589 590 # endif 583 591 584 592 585 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 593 586 !!---------------------------------------------------------------------- 594 !! *** ROUTINE interptsn ***587 !! *** ROUTINE interptsn *** 595 588 !!---------------------------------------------------------------------- 596 589 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab … … 599 592 INTEGER , INTENT(in ) :: nb , ndir 600 593 ! 601 INTEGER 602 INTEGER 603 REAL(wp) 604 REAL(wp) 605 LOGICAL 594 INTEGER :: ji, jj, jk, jn ! dummy loop indices 595 INTEGER :: imin, imax, jmin, jmax 596 REAL(wp):: zrhox , zalpha1, zalpha2, zalpha3 597 REAL(wp):: zalpha4, zalpha5, zalpha6, zalpha7 598 LOGICAL :: western_side, eastern_side,northern_side,southern_side 606 599 !!---------------------------------------------------------------------- 607 600 ! … … 770 763 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before ) 771 764 !!---------------------------------------------------------------------- 772 !! *** ROUTINE interpun ***765 !! *** ROUTINE interpun *** 773 766 !!---------------------------------------------------------------------- 774 767 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 … … 776 769 LOGICAL , INTENT(in ) :: before 777 770 ! 778 INTEGER 779 REAL(wp) 771 INTEGER :: ji, jj, jk 772 REAL(wp):: zrhoy 780 773 !!---------------------------------------------------------------------- 781 774 ! … … 798 791 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before ) 799 792 !!---------------------------------------------------------------------- 800 !! *** ROUTINE interpvn ***793 !! *** ROUTINE interpvn *** 801 794 !!---------------------------------------------------------------------- 802 795 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 … … 804 797 LOGICAL , INTENT(in ) :: before 805 798 ! 806 INTEGER 807 REAL(wp) 799 INTEGER :: ji, jj, jk 800 REAL(wp):: zrhox 808 801 !!---------------------------------------------------------------------- 809 802 ! … … 831 824 INTEGER , INTENT(in ) :: nb , ndir 832 825 ! 833 INTEGER 834 REAL(wp) 835 LOGICAL 826 INTEGER :: ji, jj 827 REAL(wp):: zrhoy, zrhot, zt0, zt1, ztcoeff 828 LOGICAL :: western_side, eastern_side,northern_side,southern_side 836 829 !!---------------------------------------------------------------------- 837 830 ! … … 901 894 INTEGER , INTENT(in ) :: nb , ndir 902 895 ! 903 INTEGER 904 REAL(wp) 905 LOGICAL 896 INTEGER :: ji,jj 897 REAL(wp):: zrhox, zrhot, zt0, zt1, ztcoeff 898 LOGICAL :: western_side, eastern_side,northern_side,southern_side 906 899 !!---------------------------------------------------------------------- 907 900 ! … … 919 912 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 920 913 IF( bdy_tinterp == 1 ) THEN 921 ztcoeff = zrhot * ( zt1**2._wp * ( 922 & - zt0**2._wp * ( 914 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 915 & - zt0**2._wp * ( zt0 - 1._wp) ) 923 916 ELSEIF( bdy_tinterp == 2 ) THEN 924 ztcoeff = zrhot * ( zt1 * ( 925 & - zt0 * ( 917 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 918 & - zt0 * ( zt0 - 1._wp)**2._wp ) 926 919 ELSE 927 920 ztcoeff = 1 … … 942 935 ! 943 936 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 944 IF(western_side) THEN 945 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 946 & * vmask(i1,j1:j2,1) 947 ENDIF 948 IF(eastern_side) THEN 949 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 950 & * vmask(i1,j1:j2,1) 951 ENDIF 952 IF(southern_side) THEN 953 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 954 & * vmask(i1:i2,j1,1) 955 ENDIF 956 IF(northern_side) THEN 957 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 958 & * vmask(i1:i2,j1,1) 937 IF( western_side ) vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) * vmask(i1,j1:j2,1) 938 IF( eastern_side ) vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) * vmask(i1,j1:j2,1) 939 IF( southern_side ) vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) * vmask(i1:i2,j1,1) 940 IF( northern_side ) vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) * vmask(i1:i2,j1,1) 959 941 ENDIF 960 942 ENDIF … … 973 955 INTEGER , INTENT(in ) :: nb , ndir 974 956 ! 975 INTEGER 976 REAL(wp) 977 LOGICAL 957 INTEGER :: ji,jj 958 REAL(wp):: zrhot, zt0, zt1,zat 959 LOGICAL :: western_side, eastern_side,northern_side,southern_side 978 960 !!---------------------------------------------------------------------- 979 961 IF( before ) THEN … … 1030 1012 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1031 1013 ! 1032 IF( western_side) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)1033 IF( eastern_side) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)1034 IF( southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)1035 IF( northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)1014 IF( western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1015 IF( eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1016 IF( southern_side ) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1017 IF( northern_side ) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1036 1018 ENDIF 1037 1019 ! … … 1048 1030 INTEGER , INTENT(in ) :: nb , ndir 1049 1031 ! 1050 INTEGER :: ji, jj, jk1051 LOGICAL :: western_side, eastern_side, northern_side, southern_side1052 REAL(wp) ::ztmpmsk1032 INTEGER :: ji, jj, jk 1033 LOGICAL :: western_side, eastern_side, northern_side, southern_side 1034 REAL(wp):: ztmpmsk 1053 1035 !!---------------------------------------------------------------------- 1054 1036 ! … … 1065 1047 DO ji = i1, i2 1066 1048 ! Get velocity mask at boundary edge points: 1067 IF( western_side ) ztmpmsk = umask(ji ,jj ,1)1068 IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1)1069 IF( northern_side ) ztmpmsk = vmask(ji ,nlcj-2,1)1070 IF( southern_side ) ztmpmsk = vmask(ji ,2 ,1)1049 IF( western_side ) ztmpmsk = umask(ji ,jj ,1) 1050 IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1) 1051 IF( northern_side ) ztmpmsk = vmask(ji ,nlcj-2,1) 1052 IF( southern_side ) ztmpmsk = vmask(ji ,2 ,1) 1071 1053 ! 1072 1054 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN … … 1141 1123 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1142 1124 LOGICAL , INTENT(in ) :: before 1143 INTEGER , INTENT(in ) :: nb , ndir1125 INTEGER , INTENT(in ) :: nb , ndir 1144 1126 ! 1145 1127 INTEGER :: ji, jj, jk … … 1175 1157 END SUBROUTINE interpvmsk 1176 1158 1177 # if defined key_zdftke1178 1159 1179 1160 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before ) … … 1186 1167 !!---------------------------------------------------------------------- 1187 1168 ! 1188 IF( before ) THEN 1189 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1190 ELSE 1191 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1169 IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1170 ELSE ; avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1192 1171 ENDIF 1193 1172 ! 1194 1173 END SUBROUTINE interpavm 1195 1196 # endif /* key_zdftke */1197 1174 1198 1175 #else -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
r7646 r7953 3 3 MODULE agrif_opa_sponge 4 4 !!====================================================================== 5 !! *** MODULE agrif_opa_update***6 !! AGRIF :5 !! *** MODULE agrif_opa_interp *** 6 !! AGRIF: interpolation package 7 7 !!====================================================================== 8 !! History : 8 !! History : 2.0 ! 2002-06 (XXX) Original cade 9 !! - ! 2005-11 (XXX) 10 !! 3.2 ! 2009-04 (R. Benshila) 11 !! 3.6 ! 2014-09 (R. Benshila) 9 12 !!---------------------------------------------------------------------- 10 13 #if defined key_agrif 14 !!---------------------------------------------------------------------- 15 !! 'key_agrif' AGRIF zoom 16 !!---------------------------------------------------------------------- 11 17 USE par_oce 12 18 USE oce 13 19 USE dom_oce 20 ! 14 21 USE in_out_manager 15 22 USE agrif_oce … … 24 31 25 32 !!---------------------------------------------------------------------- 26 !! NEMO/NST 3.7 , NEMO Consortium (2015)33 !! NEMO/NST 4.0 , NEMO Consortium (2017) 27 34 !! $Id$ 28 35 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 31 38 32 39 SUBROUTINE Agrif_Sponge_Tra 33 !!--------------------------------------------- 34 !! *** ROUTINE Agrif_Sponge_Tra ***35 !!--------------------------------------------- 36 REAL(wp) :: timecoeff37 !!--------------------------------------------- 40 !!---------------------------------------------------------------------- 41 !! *** ROUTINE Agrif_Sponge_Tra *** 42 !!---------------------------------------------------------------------- 43 REAL(wp) :: timecoeff ! local scalar 44 !!---------------------------------------------------------------------- 38 45 ! 39 46 #if defined SPONGE 40 47 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 41 48 ! 42 49 CALL Agrif_Sponge 43 Agrif_SpecialValue =0.50 Agrif_SpecialValue = 0._wp 44 51 Agrif_UseSpecialValue = .TRUE. 45 tabspongedone_tsn = .FALSE.46 52 tabspongedone_tsn = .FALSE. 53 ! 47 54 CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) 48 55 ! 49 56 Agrif_UseSpecialValue = .FALSE. 50 57 #endif … … 54 61 55 62 SUBROUTINE Agrif_Sponge_dyn 56 !!--------------------------------------------- 57 !! *** ROUTINE Agrif_Sponge_dyn ***58 !!--------------------------------------------- 59 REAL(wp) :: timecoeff60 !!--------------------------------------------- 61 63 !!---------------------------------------------------------------------- 64 !! *** ROUTINE Agrif_Sponge_dyn *** 65 !!---------------------------------------------------------------------- 66 REAL(wp) :: timecoeff ! local scalar 67 !!---------------------------------------------------------------------- 68 ! 62 69 #if defined SPONGE 63 70 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 64 65 Agrif_SpecialValue =0.71 ! 72 Agrif_SpecialValue = 0._wp 66 73 Agrif_UseSpecialValue = ln_spc_dyn 67 74 ! 68 75 tabspongedone_u = .FALSE. 69 76 tabspongedone_v = .FALSE. 70 77 CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 71 78 ! 72 79 tabspongedone_u = .FALSE. 73 80 tabspongedone_v = .FALSE. 74 81 CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 75 82 ! 76 83 Agrif_UseSpecialValue = .FALSE. 77 84 #endif … … 81 88 82 89 SUBROUTINE Agrif_Sponge 83 !!--------------------------------------------- 84 !! *** ROUTINE Agrif_Sponge ***85 !!--------------------------------------------- 90 !!---------------------------------------------------------------------- 91 !! *** ROUTINE Agrif_Sponge *** 92 !!---------------------------------------------------------------------- 86 93 INTEGER :: ji,jj,jk 87 94 INTEGER :: ispongearea, ilci, ilcj … … 89 96 REAL(wp) :: z1spongearea, zramp 90 97 REAL(wp), POINTER, DIMENSION(:,:) :: ztabramp 91 98 !!---------------------------------------------------------------------- 99 ! 92 100 #if defined SPONGE || defined SPONGE_TOP 93 101 ll_spdone=.TRUE. … … 176 184 fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj) 177 185 fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) & 178 &+ztabramp(ji,jj) + ztabramp(ji+1,jj ) )179 END DO 180 END DO 181 186 & +ztabramp(ji,jj) + ztabramp(ji+1,jj ) ) 187 END DO 188 END DO 189 ! 182 190 CALL lbc_lnk( fsahm_spt, 'T', 1. ) ! Lateral boundary conditions 183 191 CALL lbc_lnk( fsahm_spf, 'F', 1. ) … … 192 200 193 201 194 SUBROUTINE interptsn_sponge( tabres,i1,i2,j1,j2,k1,k2,n1,n2,before)195 !!--------------------------------------------- 196 !! *** ROUTINE interptsn_sponge ***197 !!--------------------------------------------- 198 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2199 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres200 LOGICAL , INTENT(in) ::before202 SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 203 !!---------------------------------------------------------------------- 204 !! *** ROUTINE interptsn_sponge *** 205 !!---------------------------------------------------------------------- 206 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 207 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 208 LOGICAL , INTENT(in ) :: before 201 209 ! 202 210 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 205 213 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 206 214 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 215 !!---------------------------------------------------------------------- 207 216 ! 208 217 IF( before ) THEN … … 258 267 259 268 260 SUBROUTINE interpun_sponge( tabres,i1,i2,j1,j2,k1,k2, before)261 !!--------------------------------------------- 262 !! *** ROUTINE interpun_sponge ***263 !!--------------------------------------------- 264 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2265 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres266 LOGICAL , INTENT(in) ::before267 269 SUBROUTINE interpun_sponge( tabres, i1, i2, j1, j2, k1, k2, before ) 270 !!---------------------------------------------------------------------- 271 !! *** ROUTINE interpun_sponge *** 272 !!---------------------------------------------------------------------- 273 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 274 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 275 LOGICAL , INTENT(in ) :: before 276 !! 268 277 INTEGER :: ji,jj,jk 269 270 ! sponge parameters 278 INTEGER :: jmax 271 279 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 272 280 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 273 281 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 274 INTEGER :: jmax 275 !!--------------------------------------------- 282 !!---------------------------------------------------------------------- 276 283 ! 277 284 IF( before ) THEN … … 356 363 357 364 358 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 359 !!--------------------------------------------- 360 !! *** ROUTINE interpvn_sponge *** 361 !!--------------------------------------------- 362 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 363 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 364 LOGICAL, INTENT(in) :: before 365 INTEGER, INTENT(in) :: nb , ndir 366 ! 367 INTEGER :: ji, jj, jk 368 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 369 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 370 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 371 INTEGER :: imax 372 !!--------------------------------------------- 365 SUBROUTINE interpvn_sponge( tabres, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 366 !!---------------------------------------------------------------------- 367 !! *** ROUTINE interpvn_sponge *** 368 !!---------------------------------------------------------------------- 369 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 370 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 371 LOGICAL , INTENT(in ) :: before 372 INTEGER , INTENT(in ) :: nb , ndir 373 ! 374 INTEGER :: ji, jj, jk 375 INTEGER :: imax 376 REAL(wp):: ze2u, ze1v, zua, zva, zbtr 377 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff, rotdiff, hdivdiff 378 !!---------------------------------------------------------------------- 373 379 374 380 IF( before ) THEN … … 403 409 ! 404 410 405 imax = i2 -1411 imax = i2 - 1 406 412 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-3) 407 413 … … 437 443 438 444 #else 445 !!---------------------------------------------------------------------- 446 !! Empty module no AGRIF zoom 447 !!---------------------------------------------------------------------- 439 448 CONTAINS 440 449 SUBROUTINE agrif_opa_sponge_empty 441 !!--------------------------------------------- 442 !! *** ROUTINE agrif_OPA_sponge_empty ***443 !!--------------------------------------------- 450 !!---------------------------------------------------------------------- 451 !! *** ROUTINE agrif_OPA_sponge_empty *** 452 !!---------------------------------------------------------------------- 444 453 WRITE(*,*) 'agrif_opa_sponge : You should not have seen this print! error?' 445 454 END SUBROUTINE agrif_opa_sponge_empty -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r7646 r7953 3 3 4 4 MODULE agrif_opa_update 5 !!====================================================================== 6 !! *** MODULE agrif_opa_interp *** 7 !! AGRIF: interpolation package 8 !!====================================================================== 9 !! History : 2.0 ! 2002-06 (XXX) Original cade 10 !! - ! 2005-11 (XXX) 11 !! 3.2 ! 2009-04 (R. Benshila) 12 !! 3.6 ! 2014-09 (R. Benshila) 13 !!---------------------------------------------------------------------- 5 14 #if defined key_agrif 15 !!---------------------------------------------------------------------- 16 !! 'key_agrif' AGRIF zoom 17 !!---------------------------------------------------------------------- 6 18 USE par_oce 7 19 USE oce 8 20 USE dom_oce 21 USE zdf_oce ! vertical physics: ocean variables 9 22 USE agrif_oce 10 USE in_out_manager ! I/O manager 23 ! 24 USE in_out_manager ! I/O manager 11 25 USE lib_mpp 12 26 USE wrk_nemo 13 USE zdf_oce ! vertical physics: ocean variables14 27 15 28 IMPLICIT NONE 16 29 PRIVATE 17 30 18 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 19 # if defined key_zdftke 20 PUBLIC Agrif_Update_Tke 21 # endif 31 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn, Update_Scales 32 PUBLIC Agrif_Update_Tke 33 22 34 !!---------------------------------------------------------------------- 23 !! NEMO/NST 3.6 , NEMO Consortium (2010)35 !! NEMO/NST 4.0 , NEMO Consortium (2017) 24 36 !! $Id$ 25 37 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 28 40 29 41 RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 30 !!--------------------------------------------- 31 !! *** ROUTINE Agrif_Update_Tra ***32 !!--------------------------------------------- 42 !!---------------------------------------------------------------------- 43 !! *** ROUTINE Agrif_Update_Tra *** 44 !!---------------------------------------------------------------------- 33 45 ! 34 46 IF (Agrif_Root()) RETURN … … 38 50 39 51 Agrif_UseSpecialValueInUpdate = .TRUE. 40 Agrif_SpecialValueFineGrid = 0.52 Agrif_SpecialValueFineGrid = 0._wp 41 53 ! 42 54 IF (MOD(nbcline,nbclineupdate) == 0) THEN … … 68 80 69 81 RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 70 !!--------------------------------------------- 71 !! *** ROUTINE Agrif_Update_Dyn ***72 !!--------------------------------------------- 82 !!---------------------------------------------------------------------- 83 !! *** ROUTINE Agrif_Update_Dyn *** 84 !!---------------------------------------------------------------------- 73 85 ! 74 86 IF (Agrif_Root()) RETURN … … 106 118 # endif 107 119 108 IF ( ln_dynspg_ts .AND.ln_bt_fw ) THEN120 IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN 109 121 ! Update time integrated transports 110 122 IF (mod(nbcline,nbclineupdate) == 0) THEN … … 149 161 END SUBROUTINE Agrif_Update_Dyn 150 162 151 # if defined key_zdftke 163 !!gm Missing GLS case !!!!! 152 164 153 165 SUBROUTINE Agrif_Update_Tke( kt ) 154 !!--------------------------------------------- 155 !! *** ROUTINE Agrif_Update_Tke *** 156 !!--------------------------------------------- 157 !! 166 !!---------------------------------------------------------------------- 167 !! *** ROUTINE Agrif_Update_Tke *** 168 !!---------------------------------------------------------------------- 158 169 INTEGER, INTENT(in) :: kt 159 ! 160 IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 170 !!---------------------------------------------------------------------- 171 ! 172 !!gm test on kt/=0 ???? why not nit000-1 ? doesn't seem logic 173 IF( ( Agrif_NbStepint() /= 0 ) .AND. kt /= 0 ) RETURN 161 174 # if defined TWO_WAY 162 175 ! 163 176 Agrif_UseSpecialValueInUpdate = .TRUE. 164 Agrif_SpecialValueFineGrid = 0.165 166 CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN )167 CALL Agrif_Update_Variable( avt_id, locupdate=(/0,0/), procname=updateAVT )168 CALL Agrif_Update_Variable( avm_id, locupdate=(/0,0/), procname=updateAVM )169 177 Agrif_SpecialValueFineGrid = 0._wp 178 ! 179 CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN ) 180 CALL Agrif_Update_Variable( avt_id, locupdate=(/0,0/), procname=updateAVT ) 181 CALL Agrif_Update_Variable( avm_id, locupdate=(/0,0/), procname=updateAVM ) 182 ! 170 183 Agrif_UseSpecialValueInUpdate = .FALSE. 171 184 ! 172 185 # endif 173 186 ! 174 187 END SUBROUTINE Agrif_Update_Tke 175 188 176 # endif /* key_zdftke */177 189 178 190 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 179 !!--------------------------------------------- 191 !!---------------------------------------------------------------------- 180 192 !! *** ROUTINE updateT *** 181 !!--------------------------------------------- 182 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2183 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres184 LOGICAL , INTENT(in) ::before185 ! !186 INTEGER :: ji, jj,jk,jn187 !!--------------------------------------------- 188 ! 189 IF (before) THEN190 DO jn = n1, n2191 DO jk =k1,k2192 DO jj =j1,j2193 DO ji =i1,i2193 !!---------------------------------------------------------------------- 194 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 195 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 196 LOGICAL , INTENT(in ) :: before 197 ! 198 INTEGER :: ji, jj, jk, jn 199 !!---------------------------------------------------------------------- 200 ! 201 IF( before ) THEN 202 DO jn = n1, n2 203 DO jk = k1, k2 204 DO jj = j1, j2 205 DO ji = i1, i2 194 206 tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) 195 207 END DO … … 209 221 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 210 222 ENDIF 211 END DO212 END DO213 END DO214 END DO223 END DO 224 END DO 225 END DO 226 END DO 215 227 ENDIF 216 228 DO jn = n1,n2 … … 238 250 LOGICAL , INTENT(in ) :: before 239 251 ! 240 INTEGER 241 REAL(wp) 252 INTEGER :: ji, jj, jk 253 REAL(wp):: zrhoy 242 254 !!--------------------------------------------- 243 255 ! … … 268 280 269 281 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before ) 270 !!--------------------------------------------- 271 !! *** ROUTINE updatev *** 272 !!--------------------------------------------- 273 INTEGER :: i1,i2,j1,j2,k1,k2 274 INTEGER :: ji,jj,jk 275 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 276 LOGICAL :: before 282 !!---------------------------------------------------------------------- 283 !! *** ROUTINE updatev *** 284 !!---------------------------------------------------------------------- 285 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 286 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 287 LOGICAL , INTENT(in ) :: before 277 288 !! 278 REAL(wp) :: zrhox 279 !!--------------------------------------------- 280 ! 281 IF (before) THEN 289 INTEGER :: ji, jj, jk 290 REAL(wp) :: zrhox 291 !!---------------------------------------------------------------------- 292 ! 293 IF( before ) THEN 282 294 zrhox = Agrif_Rhox() 283 295 DO jk=k1,k2 … … 309 321 310 322 SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before ) 323 !!---------------------------------------------------------------------- 324 !! *** ROUTINE updateu2d *** 325 !!---------------------------------------------------------------------- 326 INTEGER , INTENT(in ) :: i1, i2, j1, j2 327 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 328 LOGICAL , INTENT(in ) :: before 329 !! 330 INTEGER :: ji, jj, jk 331 REAL(wp):: zrhoy, zcorr 311 332 !!--------------------------------------------- 312 !! *** ROUTINE updateu2d *** 313 !!--------------------------------------------- 314 INTEGER, INTENT(in) :: i1, i2, j1, j2 315 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 316 LOGICAL, INTENT(in) :: before 317 !! 318 INTEGER :: ji, jj, jk 319 REAL(wp) :: zrhoy 320 REAL(wp) :: zcorr 321 !!--------------------------------------------- 322 ! 323 IF (before) THEN 333 ! 334 IF( before ) THEN 324 335 zrhoy = Agrif_Rhoy() 325 336 DO jj=j1,j2 … … 374 385 375 386 SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before ) 376 !!--------------------------------------------- 377 !! *** ROUTINE updatev2d ***378 !!--------------------------------------------- 379 INTEGER , INTENT(in) ::i1, i2, j1, j2380 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres381 LOGICAL , INTENT(in) ::before382 ! !387 !!---------------------------------------------------------------------- 388 !! *** ROUTINE updatev2d *** 389 !!---------------------------------------------------------------------- 390 INTEGER , INTENT(in ) :: i1, i2, j1, j2 391 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 392 LOGICAL , INTENT(in ) :: before 393 ! 383 394 INTEGER :: ji, jj, jk 384 REAL(wp) :: zrhox 385 REAL(wp) :: zcorr 386 !!--------------------------------------------- 387 ! 388 IF (before) THEN 395 REAL(wp) :: zrhox, zcorr 396 !!---------------------------------------------------------------------- 397 ! 398 IF( before ) THEN 389 399 zrhox = Agrif_Rhox() 390 400 DO jj=j1,j2 … … 439 449 440 450 SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 441 !!--------------------------------------------- 442 !! *** ROUTINE updateSSH ***443 !!--------------------------------------------- 444 INTEGER , INTENT(in) ::i1, i2, j1, j2445 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres446 LOGICAL , INTENT(in) ::before451 !!---------------------------------------------------------------------- 452 !! *** ROUTINE updateSSH *** 453 !!---------------------------------------------------------------------- 454 INTEGER , INTENT(in ) :: i1, i2, j1, j2 455 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 456 LOGICAL , INTENT(in ) :: before 447 457 !! 448 458 INTEGER :: ji, jj 449 !!--------------------------------------------- 450 ! 451 IF (before) THEN459 !!---------------------------------------------------------------------- 460 ! 461 IF( before ) THEN 452 462 DO jj=j1,j2 453 463 DO ji=i1,i2 … … 478 488 479 489 SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 480 !!--------------------------------------------- 481 !! *** ROUTINE updateub2b ***482 !!--------------------------------------------- 483 INTEGER , INTENT(in) ::i1, i2, j1, j2484 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres485 LOGICAL , INTENT(in) ::before490 !!---------------------------------------------------------------------- 491 !! *** ROUTINE updateub2b *** 492 !!---------------------------------------------------------------------- 493 INTEGER , INTENT(in) :: i1, i2, j1, j2 494 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 495 LOGICAL , INTENT(in) :: before 486 496 !! 487 INTEGER :: ji, jj488 REAL(wp) ::zrhoy489 !!--------------------------------------------- 497 INTEGER :: ji, jj 498 REAL(wp):: zrhoy 499 !!---------------------------------------------------------------------- 490 500 ! 491 501 IF (before) THEN … … 509 519 510 520 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 511 !!--------------------------------------------- 512 !! *** ROUTINE updatevb2b ***513 !!--------------------------------------------- 514 INTEGER , INTENT(in) ::i1, i2, j1, j2515 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres516 LOGICAL , INTENT(in) ::before521 !!---------------------------------------------------------------------- 522 !! *** ROUTINE updatevb2b *** 523 !!---------------------------------------------------------------------- 524 INTEGER , INTENT(in ) :: i1, i2, j1, j2 525 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 526 LOGICAL , INTENT(in ) :: before 517 527 !! 518 INTEGER :: ji, jj519 REAL(wp) ::zrhox520 !!--------------------------------------------- 521 ! 522 IF (before) THEN528 INTEGER :: ji, jj 529 REAL(wp):: zrhox 530 !!---------------------------------------------------------------------- 531 ! 532 IF( before ) THEN 523 533 zrhox = Agrif_Rhox() 524 534 DO jj=j1,j2 … … 540 550 541 551 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 542 ! currently not used 543 !!--------------------------------------------- 544 !! *** ROUTINE updateT *** 545 !!--------------------------------------------- 546 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 547 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 548 LOGICAL, iNTENT(in) :: before 549 ! 552 ! 553 ! ====>>>>>>>>>> currently not used 554 ! 555 !!---------------------------------------------------------------------- 556 !! *** ROUTINE updateT *** 557 !!---------------------------------------------------------------------- 558 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 559 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 560 LOGICAL , INTENT(in ) :: before 561 !! 550 562 INTEGER :: ji,jj,jk 551 563 REAL(wp) :: ztemp 552 !!--------------------------------------------- 564 !!---------------------------------------------------------------------- 553 565 554 566 IF (before) THEN … … 587 599 END SUBROUTINE update_scales 588 600 589 # if defined key_zdftke590 601 591 602 SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 592 !!--------------------------------------------- 593 !! *** ROUTINE updateen ***594 !!--------------------------------------------- 595 INTEGER , INTENT(in) ::i1, i2, j1, j2, k1, k2596 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab597 LOGICAL , INTENT(in) ::before598 !!--------------------------------------------- 599 ! 600 IF (before) THEN603 !!---------------------------------------------------------------------- 604 !! *** ROUTINE updateen *** 605 !!---------------------------------------------------------------------- 606 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 607 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 608 LOGICAL , INTENT(in ) :: before 609 !!---------------------------------------------------------------------- 610 ! 611 IF( before ) THEN 601 612 ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 602 613 ELSE … … 608 619 609 620 SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 610 !!--------------------------------------------- 611 !! *** ROUTINE updateavt *** 612 !!--------------------------------------------- 613 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 614 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 615 LOGICAL, INTENT(in) :: before 616 !!--------------------------------------------- 617 ! 618 IF (before) THEN 619 ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 620 ELSE 621 avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 621 !!---------------------------------------------------------------------- 622 !! *** ROUTINE updateavt *** 623 !!---------------------------------------------------------------------- 624 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 625 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 626 LOGICAL , INTENT(in ) :: before 627 !!---------------------------------------------------------------------- 628 ! 629 IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 630 ELSE ; avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 622 631 ENDIF 623 632 ! … … 628 637 !!--------------------------------------------- 629 638 !! *** ROUTINE updateavm *** 630 !!--------------------------------------------- 631 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 632 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 633 LOGICAL, INTENT(in) :: before 634 !!--------------------------------------------- 635 ! 636 IF (before) THEN 637 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 638 ELSE 639 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 639 !!---------------------------------------------------------------------- 640 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 641 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 642 LOGICAL , INTENT(in ) :: before 643 !!---------------------------------------------------------------------- 644 ! 645 IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 646 ELSE ; avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 640 647 ENDIF 641 648 ! 642 649 END SUBROUTINE updateAVM 643 650 644 # endif /* key_zdftke */645 646 651 #else 652 !!---------------------------------------------------------------------- 653 !! Empty module no AGRIF zoom 654 !!---------------------------------------------------------------------- 647 655 CONTAINS 648 656 SUBROUTINE agrif_opa_update_empty 649 !!---------------------------------------------650 !! *** ROUTINE agrif_opa_update_empty ***651 !!---------------------------------------------652 657 WRITE(*,*) 'agrif_opa_update : You should not have seen this print! error?' 653 658 END SUBROUTINE agrif_opa_update_empty 654 659 #endif 660 661 !!====================================================================== 655 662 END MODULE agrif_opa_update 656 663 -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
r6140 r7953 1 1 MODULE agrif_top_interp 2 !!====================================================================== 3 !! *** MODULE agrif_top_interp *** 4 !! AGRIF: interpolation package 5 !!====================================================================== 6 !! History : 2.0 ! ??? 7 !!---------------------------------------------------------------------- 2 8 #if defined key_agrif && defined key_top 9 !!---------------------------------------------------------------------- 10 !! 'key_agrif' AGRIF zoom 11 !! 'key_top' on-line tracers 12 !!---------------------------------------------------------------------- 3 13 USE par_oce 4 14 USE oce … … 8 18 USE par_trc 9 19 USE trc 20 ! 10 21 USE lib_mpp 11 22 USE wrk_nemo … … 16 27 PUBLIC Agrif_trc, interptrn 17 28 18 # include "vectopt_loop_substitute.h90"19 29 !!---------------------------------------------------------------------- 20 !! NEMO/NST 3.6 , NEMO Consortium (2010)30 !! NEMO/NST 4.0 , NEMO Consortium (2017) 21 31 !! $Id$ 22 32 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 26 36 SUBROUTINE Agrif_trc 27 37 !!---------------------------------------------------------------------- 28 !! *** ROUTINE Agrif_trc ***38 !! *** ROUTINE Agrif_trc *** 29 39 !!---------------------------------------------------------------------- 30 40 ! 31 41 IF( Agrif_Root() ) RETURN 32 33 Agrif_SpecialValue = 0. e042 ! 43 Agrif_SpecialValue = 0._wp 34 44 Agrif_UseSpecialValue = .TRUE. 35 45 ! 36 46 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 37 47 Agrif_UseSpecialValue = .FALSE. … … 40 50 41 51 42 SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 43 !!--------------------------------------------- 44 !! *** ROUTINE interptrn *** 45 !!--------------------------------------------- 46 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 47 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 48 LOGICAL, INTENT(in) :: before 49 INTEGER, INTENT(in) :: nb , ndir 50 ! 51 INTEGER :: ji, jj, jk, jn ! dummy loop indices 52 INTEGER :: imin, imax, jmin, jmax 53 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 54 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 55 LOGICAL :: western_side, eastern_side,northern_side,southern_side 56 57 IF (before) THEN 52 SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 53 !!---------------------------------------------------------------------- 54 !! *** ROUTINE interptrn *** 55 !!---------------------------------------------------------------------- 56 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 57 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 58 LOGICAL , INTENT(in ) :: before 59 INTEGER , INTENT(in ) :: nb , ndir 60 !! 61 INTEGER :: ji, jj, jk, jn ! dummy loop indices 62 INTEGER :: imin, imax, jmin, jmax 63 LOGICAL :: western_side, eastern_side,northern_side,southern_side 64 REAL(wp):: zrhox , zalpha1, zalpha2, zalpha3 65 REAL(wp):: zalpha4, zalpha5, zalpha6, zalpha7 66 !!---------------------------------------------------------------------- 67 ! 68 IF( before ) THEN 58 69 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 59 70 ELSE … … 185 196 186 197 #else 198 !!---------------------------------------------------------------------- 199 !! Empty module no TOP AGRIF 200 !!---------------------------------------------------------------------- 187 201 CONTAINS 188 202 SUBROUTINE Agrif_TOP_Interp_empty … … 193 207 END SUBROUTINE Agrif_TOP_Interp_empty 194 208 #endif 209 210 !!====================================================================== 195 211 END MODULE agrif_top_interp -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90
r6140 r7953 4 4 !!====================================================================== 5 5 !! *** MODULE agrif_top_sponge *** 6 !! AGRIF : define in memory AGRIF variables for sea-ice6 !! AGRIF : TOP sponge layer 7 7 !!====================================================================== 8 8 !! History : 2.0 ! 2006-08 (R. Benshila, L. Debreu) Original code 9 9 !!---------------------------------------------------------------------- 10 10 #if defined key_agrif && defined key_top 11 11 !!---------------------------------------------------------------------- 12 12 !! Agrif_Sponge_trc : 13 13 !! interptrn_sponge : 14 14 !!---------------------------------------------------------------------- 15 #if defined key_agrif && defined key_top16 15 USE par_oce 17 16 USE par_trc … … 32 31 33 32 !!---------------------------------------------------------------------- 34 !! NEMO/NST 3.7 , NEMO Consortium (2015)33 !! NEMO/NST 4.0 , NEMO Consortium (2017) 35 34 !! $Id$ 36 35 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 42 41 !! *** ROUTINE Agrif_Sponge_Trc *** 43 42 !!---------------------------------------------------------------------- 44 REAL(wp) :: timecoeff 43 REAL(wp) :: timecoeff ! local scalar 45 44 !!---------------------------------------------------------------------- 46 45 ! … … 107 106 108 107 #else 109 108 !!---------------------------------------------------------------------- 109 !! Empty module no TOP AGRIF 110 !!---------------------------------------------------------------------- 110 111 CONTAINS 111 112 SUBROUTINE agrif_top_sponge_empty -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90
r6140 r7953 6 6 !! *** MODULE agrif_top_update *** 7 7 !! AGRIF : 8 !! ----------------------------------------------------------------------8 !!====================================================================== 9 9 !! History : 10 10 !!---------------------------------------------------------------------- 11 12 11 #if defined key_agrif && defined key_top 12 !!---------------------------------------------------------------------- 13 !! 'key_agrif' AGRIF zoom 14 !! 'key_TOP' on-line tracers 15 !!---------------------------------------------------------------------- 13 16 USE par_oce 14 17 USE oce 18 USE dom_oce 19 USE agrif_oce 15 20 USE par_trc 16 21 USE trc 17 USE dom_oce 18 USE agrif_oce 22 ! 19 23 USE wrk_nemo 20 24 … … 27 31 28 32 !!---------------------------------------------------------------------- 29 !! NEMO/NST 3.7 , NEMO Consortium (2015)33 !! NEMO/NST 4.0 , NEMO Consortium (2017) 30 34 !! $Id$ 31 35 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 112 116 113 117 #else 118 !!---------------------------------------------------------------------- 119 !! Empty module no TOP AGRIF 120 !!---------------------------------------------------------------------- 114 121 CONTAINS 115 122 SUBROUTINE agrif_top_update_empty 116 !!---------------------------------------------117 !! *** ROUTINE agrif_Top_update_empty ***118 !!---------------------------------------------119 123 WRITE(*,*) 'agrif_top_update : You should not have seen this print! error?' 120 124 END SUBROUTINE agrif_top_update_empty -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r7761 r7953 1 1 #if defined key_agrif 2 2 !!---------------------------------------------------------------------- 3 !! NEMO/NST 3.7 , NEMO Consortium (2016)3 !! NEMO/NST 4.0 , NEMO Consortium (2017) 4 4 !! $Id$ 5 5 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 107 107 !! 108 108 IMPLICIT NONE 109 ! 109 110 !!---------------------------------------------------------------------- 110 111 ! … … 125 126 USE par_oce 126 127 USE oce 127 ! !128 ! 128 129 IMPLICIT NONE 129 130 !!---------------------------------------------------------------------- … … 136 137 ! 2. Type of interpolation 137 138 !------------------------- 138 CALL Agrif_Set_bcinterp( e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm)139 CALL Agrif_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 ) 140 141 141 142 ! 3. Location of interpolation 142 143 !----------------------------- 143 CALL Agrif_Set_bc( e1u_id,(/0,0/))144 CALL Agrif_Set_bc( e2v_id,(/0,0/))144 CALL Agrif_Set_bc( e1u_id, (/0,0/) ) 145 CALL Agrif_Set_bc( e2v_id, (/0,0/) ) 145 146 146 147 ! 5. Update type 147 148 !--------------- 148 CALL Agrif_Set_Updatetype( e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average)149 CALL Agrif_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 ) 150 151 151 152 ! High order updates 152 ! CALL Agrif_Set_Updatetype( e1u_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Full_Weighting)153 ! CALL Agrif_Set_Updatetype( e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average)153 ! CALL Agrif_Set_Updatetype( e1u_id, update1=Agrif_Update_Average , update2=Agrif_Update_Full_Weighting ) 154 ! CALL Agrif_Set_Updatetype( e2v_id, update1=Agrif_Update_Full_Weighting, update2=Agrif_Update_Average ) 154 155 ! 155 156 END SUBROUTINE agrif_declare_var_dom … … 165 166 USE oce 166 167 USE dom_oce 168 USE zdf_oce 167 169 USE nemogcm 170 ! 168 171 USE lib_mpp 169 172 USE in_out_manager … … 171 174 USE agrif_opa_interp 172 175 USE agrif_opa_sponge 173 ! !176 ! 174 177 IMPLICIT NONE 175 178 ! … … 184 187 ! 2. First interpolations of potentially non zero fields 185 188 !------------------------------------------------------- 186 Agrif_SpecialValue =0.189 Agrif_SpecialValue = 0._wp 187 190 Agrif_UseSpecialValue = .TRUE. 188 191 CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) … … 319 322 ENDIF 320 323 ! 321 # if defined key_zdftke 322 CALL Agrif_Update_tke(0) 323 # endif 324 IF( ln_zdftke ) CALL Agrif_Update_tke( 0 ) 324 325 ! 325 326 Agrif_UseSpecialValueInUpdate = .FALSE. … … 337 338 !!---------------------------------------------------------------------- 338 339 USE agrif_util 339 USE par_oce ! ONLY : jpts 340 USE agrif_oce 341 USE par_oce ! ocean parameters 342 USE zdf_oce ! vertical physics 340 343 USE oce 341 USE agrif_oce342 344 !! 343 345 IMPLICIT NONE … … 371 373 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 372 374 373 # if defined key_zdftke 374 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id)375 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id)376 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id)377 # endif 375 IF( ln_zdftke ) THEN 376 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 377 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 378 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 379 ENDIF 378 380 379 381 ! 2. Type of interpolation … … 400 402 CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 401 403 402 # if defined key_zdftke 403 CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 404 # endif 405 404 IF( ln_zdftke ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) 406 405 407 406 ! 3. Location of interpolation … … 418 417 CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 419 418 420 CALL Agrif_Set_bc( sshn_id,(/0,0/))421 CALL Agrif_Set_bc( unb_id ,(/0,0/))422 CALL Agrif_Set_bc( vnb_id ,(/0,0/))423 CALL Agrif_Set_bc( ub2b_interp_id,(/0,0/))424 CALL Agrif_Set_bc( vb2b_interp_id,(/0,0/))419 CALL Agrif_Set_bc( sshn_id , (/0,0/) ) 420 CALL Agrif_Set_bc( unb_id , (/0,0/) ) 421 CALL Agrif_Set_bc( vnb_id , (/0,0/) ) 422 CALL Agrif_Set_bc( ub2b_interp_id, (/0,0/) ) 423 CALL Agrif_Set_bc( vb2b_interp_id, (/0,0/) ) 425 424 426 425 CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/)) ! if west and rhox=3: column 2 to 9 … … 428 427 CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 429 428 430 # if defined key_zdftke 431 CALL Agrif_Set_bc(avm_id ,(/0,1/)) 432 # endif 429 IF( ln_zdftke ) CALL Agrif_Set_bc( avm_id, (/0,1/) ) 433 430 434 431 ! 5. Update type … … 446 443 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 447 444 448 # if defined key_zdftke 449 CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average)450 CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average)451 CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average)452 # endif 445 IF( ln_zdftke) THEN 446 CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 447 CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 448 CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 449 ENDIF 453 450 454 451 ! High order updates
Note: See TracChangeset
for help on using the changeset viewer.