[10727] | 1 | #if defined key_agrif |
---|
| 2 | subroutine agrif_update_all |
---|
| 3 | USE agrif_parameters |
---|
| 4 | USE agrif_profiles |
---|
| 5 | external update_bottom_level, update_e3t, update_e3u, update_e3v |
---|
| 6 | |
---|
| 7 | if (agrif_root()) return |
---|
| 8 | call agrif_update_variable(bottom_level_id,locupdate=(/npt_copy,0/),procname = update_bottom_level) |
---|
| 9 | |
---|
| 10 | Agrif_UseSpecialValueInUpdate = .TRUE. |
---|
| 11 | Agrif_SpecialValueFineGrid = 0._wp |
---|
| 12 | |
---|
| 13 | call agrif_update_variable(e3t_id,procname = update_e3t) |
---|
| 14 | Agrif_UseSpecialValueInUpdate = .FALSE. |
---|
| 15 | |
---|
| 16 | call agrif_update_variable(e3u_id,procname = update_e3u) |
---|
| 17 | call agrif_update_variable(e3v_id,procname = update_e3v) |
---|
| 18 | |
---|
| 19 | end subroutine agrif_update_all |
---|
| 20 | |
---|
| 21 | SUBROUTINE update_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir) |
---|
| 22 | USE dom_oce |
---|
| 23 | USE domzgr |
---|
| 24 | !!---------------------------------------------------------------------- |
---|
| 25 | !! *** ROUTINE interpsshn *** |
---|
| 26 | !!---------------------------------------------------------------------- |
---|
| 27 | INTEGER , INTENT(in ) :: i1, i2, j1, j2 |
---|
| 28 | REAL, DIMENSION(i1:i2,j1:j2) , INTENT(inout) :: ptab |
---|
| 29 | LOGICAL , INTENT(in ) :: before |
---|
| 30 | INTEGER , INTENT(in ) :: nb , ndir |
---|
| 31 | LOGICAL :: western_side, eastern_side,northern_side,southern_side |
---|
| 32 | ! |
---|
| 33 | !!---------------------------------------------------------------------- |
---|
| 34 | INTEGER :: ji,jj |
---|
| 35 | ! |
---|
| 36 | western_side = (nb == 1).AND.(ndir == 1) |
---|
| 37 | eastern_side = (nb == 1).AND.(ndir == 2) |
---|
| 38 | southern_side = (nb == 2).AND.(ndir == 1) |
---|
| 39 | northern_side = (nb == 2).AND.(ndir == 2) |
---|
| 40 | |
---|
| 41 | IF( before) THEN |
---|
| 42 | ptab(i1:i2,j1:j2) = mbkt(i1:i2,j1:j2)*ssmask(i1:i2,j1:j2) |
---|
| 43 | ELSE |
---|
| 44 | mbkt(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2)) |
---|
| 45 | |
---|
| 46 | WHERE (mbkt(i1:i2,j1:j2)==0) |
---|
| 47 | ssmask(i1:i2,j1:j2) = 0. |
---|
| 48 | END WHERE |
---|
| 49 | |
---|
| 50 | ENDIF |
---|
| 51 | ! |
---|
| 52 | END SUBROUTINE update_bottom_level |
---|
| 53 | |
---|
| 54 | SUBROUTINE update_e3t( tabres, i1, i2, j1, j2, k1, k2, before ) |
---|
| 55 | USE dom_oce |
---|
| 56 | implicit none |
---|
| 57 | !!--------------------------------------------- |
---|
| 58 | !! *** update_e3t updateT *** |
---|
| 59 | !!--------------------------------------------- |
---|
| 60 | INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 |
---|
| 61 | REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres |
---|
| 62 | LOGICAL, INTENT(in) :: before |
---|
| 63 | !! |
---|
| 64 | INTEGER :: ji,jj,jk |
---|
| 65 | !!--------------------------------------------- |
---|
| 66 | ! |
---|
| 67 | IF (before) THEN |
---|
| 68 | DO jk=k1,k2 |
---|
| 69 | DO jj=j1,j2 |
---|
| 70 | DO ji=i1,i2 |
---|
| 71 | if (mbkt(ji,jj) < jk) then |
---|
| 72 | tabres(ji,jj,jk) = e3t_0(ji,jj,jk) |
---|
| 73 | else |
---|
| 74 | tabres(ji,jj,jk) = 0. |
---|
| 75 | endif |
---|
| 76 | END DO |
---|
| 77 | END DO |
---|
| 78 | END DO |
---|
| 79 | ELSE |
---|
| 80 | DO jk=k1,k2 |
---|
| 81 | DO jj=j1,j2 |
---|
| 82 | DO ji=i1,i2 |
---|
| 83 | if (mbkt(ji,jj) < jk) then |
---|
| 84 | e3t_0(ji,jj,jk) = e3t_1d(jk) |
---|
| 85 | else |
---|
| 86 | e3t_0(ji,jj,jk) = MAX(tabres(ji,jj,jk),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) |
---|
| 87 | endif |
---|
| 88 | END DO |
---|
| 89 | END DO |
---|
| 90 | END DO |
---|
| 91 | ! |
---|
| 92 | ENDIF |
---|
| 93 | ! |
---|
| 94 | END SUBROUTINE update_e3t |
---|
| 95 | |
---|
| 96 | SUBROUTINE update_e3u( tabres, i1, i2, j1, j2, k1, k2, before ) |
---|
| 97 | USE dom_oce |
---|
| 98 | implicit none |
---|
| 99 | !!--------------------------------------------- |
---|
| 100 | !! *** ROUTINE update_e3u *** |
---|
| 101 | !!--------------------------------------------- |
---|
| 102 | INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 |
---|
| 103 | REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres |
---|
| 104 | LOGICAL , INTENT(in ) :: before |
---|
| 105 | ! |
---|
| 106 | INTEGER :: ji, jj, jk |
---|
| 107 | REAL :: zrhoy |
---|
| 108 | !!--------------------------------------------- |
---|
| 109 | ! |
---|
| 110 | IF( before ) THEN |
---|
| 111 | zrhoy = Agrif_Rhoy() |
---|
| 112 | DO jk = k1, k2 |
---|
| 113 | do jj=j1,j2 |
---|
| 114 | do ji=i1,i2 |
---|
| 115 | if (min(mbkt(ji,jj),mbkt(ji+1,jj))<jk) then |
---|
| 116 | tabres(ji,jj,jk) = zrhoy * e2u(ji,jj) * MIN(e3zps_min,e3t_1d(jk)*e3zps_rat) |
---|
| 117 | else |
---|
| 118 | tabres(ji,jj,jk) = zrhoy * e2u(ji,jj) * e3u_0(ji,jj,jk) |
---|
| 119 | endif |
---|
| 120 | enddo |
---|
| 121 | enddo |
---|
| 122 | END DO |
---|
| 123 | ELSE |
---|
| 124 | DO jk=k1,k2 |
---|
| 125 | DO jj=j1,j2 |
---|
| 126 | DO ji=i1,i2 |
---|
| 127 | if (min(mbkt(ji,jj),mbkt(ji+1,jj))<jk) then |
---|
| 128 | e3u_0(ji,jj,jk)=e3t_1d(jk) |
---|
| 129 | else |
---|
| 130 | e3u_0(ji,jj,jk) = MAX(tabres(ji,jj,jk) / e2u(ji,jj),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) |
---|
| 131 | endif |
---|
| 132 | END DO |
---|
| 133 | END DO |
---|
| 134 | END DO |
---|
| 135 | ! |
---|
| 136 | ENDIF |
---|
| 137 | ! |
---|
| 138 | END SUBROUTINE update_e3u |
---|
| 139 | |
---|
| 140 | SUBROUTINE update_e3v( tabres, i1, i2, j1, j2, k1, k2, before ) |
---|
| 141 | USE dom_oce |
---|
| 142 | implicit none |
---|
| 143 | !!--------------------------------------------- |
---|
| 144 | !! *** ROUTINE update_e3v *** |
---|
| 145 | !!--------------------------------------------- |
---|
| 146 | INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 |
---|
| 147 | REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres |
---|
| 148 | LOGICAL , INTENT(in ) :: before |
---|
| 149 | ! |
---|
| 150 | INTEGER :: ji, jj, jk |
---|
| 151 | REAL :: zrhox |
---|
| 152 | !!--------------------------------------------- |
---|
| 153 | ! |
---|
| 154 | IF( before ) THEN |
---|
| 155 | zrhox = Agrif_Rhox() |
---|
| 156 | DO jk = k1, k2 |
---|
| 157 | do jj=j1,j2 |
---|
| 158 | do ji=i1,i2 |
---|
| 159 | if (min(mbkt(ji,jj),mbkt(ji,jj+1))<jk) then |
---|
| 160 | tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * MIN(e3zps_min,e3t_1d(jk)*e3zps_rat) |
---|
| 161 | else |
---|
| 162 | tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * e3v_0(ji,jj,jk) |
---|
| 163 | endif |
---|
| 164 | enddo |
---|
| 165 | enddo |
---|
| 166 | END DO |
---|
| 167 | ELSE |
---|
| 168 | DO jk=k1,k2 |
---|
| 169 | DO jj=j1,j2 |
---|
| 170 | DO ji=i1,i2 |
---|
| 171 | if (min(mbkt(ji,jj),mbkt(ji,jj+1))<jk) then |
---|
| 172 | e3v_0(ji,jj,jk)=e3t_1d(jk) |
---|
| 173 | else |
---|
| 174 | e3v_0(ji,jj,jk) = MAX(tabres(ji,jj,jk) / e1v(ji,jj),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) |
---|
| 175 | endif |
---|
| 176 | END DO |
---|
| 177 | END DO |
---|
| 178 | END DO |
---|
| 179 | ! |
---|
| 180 | ENDIF |
---|
| 181 | ! |
---|
| 182 | END SUBROUTINE update_e3v |
---|
| 183 | |
---|
| 184 | #else |
---|
| 185 | subroutine agrif_update_all_empty |
---|
| 186 | end subroutine agrif_update_all_empty |
---|
| 187 | #endif |
---|