New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
isfcpl.F90 in NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/ISF – NEMO

source: NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/ISF/isfcpl.F90 @ 12546

Last change on this file since 12546 was 12546, checked in by orioltp, 4 years ago

Adding precision specification in hardcoded reals and other modifications to allow compilation without forcing reals without precision specification to a certain value through compiler flags

File size: 35.7 KB
Line 
1MODULE isfcpl
2   !!======================================================================
3   !!                       ***  MODULE  isfcpl  ***
4   !!
5   !! iceshelf coupling module : module managing the coupling between NEMO and an ice sheet model
6   !!
7   !!======================================================================
8   !! History :  4.1  !  2019-07  (P. Mathiot) Original code
9   !!----------------------------------------------------------------------
10
11   !!----------------------------------------------------------------------
12   !!   isfrst : read/write iceshelf variables in/from restart
13   !!----------------------------------------------------------------------
14   USE isf_oce                          ! ice shelf variable
15   USE isfutils, ONLY : debug
16   USE lib_mpp , ONLY: mpp_sum, mpp_max ! mpp routine
17   USE domvvl  , ONLY: dom_vvl_zgr      ! vertical scale factor interpolation
18   USE domngb  , ONLY: dom_ngb          ! find the closest grid point from a given lon/lat position
19   !
20   USE oce            ! ocean dynamics and tracers
21   USE in_out_manager ! I/O manager
22   USE iom            ! I/O library
23   !
24   IMPLICIT NONE
25
26   PRIVATE
27
28   PUBLIC isfcpl_rst_write, isfcpl_init                    ! iceshelf restart read and write
29   PUBLIC isfcpl_ssh, isfcpl_tra, isfcpl_vol, isfcpl_cons  ! iceshelf correction for ssh, tra, dyn and conservation
30
31   TYPE isfcons
32      INTEGER :: ii     ! i global
33      INTEGER :: jj     ! j global
34      INTEGER :: kk     ! k level
35      REAL(wp):: dvol   ! volume increment
36      REAL(wp):: dsal   ! salt increment
37      REAL(wp):: dtem   ! heat increment
38      REAL(wp):: lon    ! lon
39      REAL(wp):: lat    ! lat
40      INTEGER :: ngb    ! 0/1 (valid location or not (ie on halo or no neigbourg))
41   END TYPE
42   !
43   !! * Substitutions
44#  include "do_loop_substitute.h90"
45   !!----------------------------------------------------------------------
46   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
47   !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $
48   !! Software governed by the CeCILL license (see ./LICENSE)
49   !!----------------------------------------------------------------------
50CONTAINS
51   SUBROUTINE isfcpl_init(Kbb, Kmm, Kaa)
52      !!---------------------------------------------------------------------
53      !!                   ***  ROUTINE iscpl_init  ***
54      !!
55      !! ** Purpose : correct ocean state for new wet cell and horizontal divergence
56      !!              correction for the dynamical adjustement
57      !!
58      !! ** Action : - compute ssh on new wet cell
59      !!             - compute T/S on new wet cell
60      !!             - compute horizontal divergence correction as a volume flux
61      !!             - compute the T/S/vol correction increment to keep trend to 0
62      !!
63      !!---------------------------------------------------------------------
64      INTEGER, INTENT(in) :: Kbb, Kmm, Kaa      ! ocean time level indices
65      !!---------------------------------------------------------------------
66      INTEGER :: id
67      !!----------------------------------------------------------------------
68      !
69      ! start on an euler time step
70      l_1st_euler = .TRUE.
71      !
72      ! allocation and initialisation to 0
73      CALL isf_alloc_cpl()
74      !
75      ! check presence of variable needed for coupling
76      ! iom_varid return 0 if not found
77      id = 1
78      id = id * iom_varid(numror, 'ssmask', ldstop = .false.)
79      id = id * iom_varid(numror, 'tmask' , ldstop = .false.)
80      id = id * iom_varid(numror, 'e3t_n' , ldstop = .false.)
81      id = id * iom_varid(numror, 'e3u_n' , ldstop = .false.)
82      id = id * iom_varid(numror, 'e3v_n' , ldstop = .false.)
83      IF(lwp) WRITE(numout,*) ' isfcpl_init:', id
84      IF (id == 0) THEN
85         IF(lwp) WRITE(numout,*) ' isfcpl_init: restart variables for ice sheet coupling are missing, skip coupling for this leg ' 
86         IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~'
87         IF(lwp) WRITE(numout,*) ''
88      ELSE
89         ! extrapolation ssh
90         CALL isfcpl_ssh(Kbb, Kmm, Kaa)
91         !
92         ! extrapolation tracer properties
93         CALL isfcpl_tra(Kmm)
94         !
95         ! correction of the horizontal divergence and associated temp. and salt content flux
96         ! Need to : - include in the cpl cons the risfcpl_vol/tsc contribution
97         !           - decide how to manage thickness level change in conservation
98         CALL isfcpl_vol(Kmm)
99         !
100         ! apply the 'conservation' method
101         IF ( ln_isfcpl_cons ) CALL isfcpl_cons(Kmm)
102         !
103      END IF
104      !
105      ! mask velocity properly (mask used in restart not compatible with new mask)
106      uu(:,:,:,Kmm) = uu(:,:,:,Kmm) * umask(:,:,:)
107      vv(:,:,:,Kmm) = vv(:,:,:,Kmm) * vmask(:,:,:)
108      !
109      ! all before fields set to now values
110      ts  (:,:,:,:,Kbb) = ts  (:,:,:,:,Kmm)
111      uu   (:,:,:,Kbb)   = uu   (:,:,:,Kmm)
112      vv   (:,:,:,Kbb)   = vv   (:,:,:,Kmm)
113      ssh (:,:,Kbb)     = ssh (:,:,Kmm)
114      e3t(:,:,:,Kbb)   = e3t(:,:,:,Kmm)
115 
116      ! prepare writing restart
117      IF( lwxios ) THEN
118         CALL iom_set_rstw_var_active('ssmask')
119         CALL iom_set_rstw_var_active('tmask')
120         CALL iom_set_rstw_var_active('e3t_n')
121         CALL iom_set_rstw_var_active('e3u_n')
122         CALL iom_set_rstw_var_active('e3v_n')
123      END IF
124      !
125   END SUBROUTINE isfcpl_init
126   !
127   SUBROUTINE isfcpl_rst_write(kt, Kmm)
128      !!---------------------------------------------------------------------
129      !!                   ***  ROUTINE iscpl_rst_write  ***
130      !!
131      !! ** Purpose : write icesheet coupling variables in restart
132      !!
133      !!-------------------------- IN  --------------------------------------
134      INTEGER, INTENT(in) :: kt
135      INTEGER, INTENT(in) :: Kmm    ! ocean time level index
136      !!----------------------------------------------------------------------
137      !
138      IF( lwxios ) CALL iom_swap( cwxios_context )
139      CALL iom_rstput( kt, nitrst, numrow, 'tmask'  , tmask , ldxios = lwxios )
140      CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios )
141      CALL iom_rstput( kt, nitrst, numrow, 'e3t_n'  , e3t(:,:,:,Kmm) , ldxios = lwxios )
142      CALL iom_rstput( kt, nitrst, numrow, 'e3u_n'  , e3u(:,:,:,Kmm) , ldxios = lwxios )
143      CALL iom_rstput( kt, nitrst, numrow, 'e3v_n'  , e3v(:,:,:,Kmm) , ldxios = lwxios )
144      CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw(:,:,:,Kmm) , ldxios = lwxios )
145      IF( lwxios ) CALL iom_swap( cxios_context )
146      !
147   END SUBROUTINE isfcpl_rst_write
148
149   SUBROUTINE isfcpl_ssh(Kbb, Kmm, Kaa)
150      !!----------------------------------------------------------------------
151      !!                   ***  ROUTINE iscpl_ssh  ***
152      !!
153      !! ** Purpose :   basic guess of ssh in new wet cell
154      !!
155      !! ** Method  :   basic extrapolation from neigbourg cells
156      !!
157      !!----------------------------------------------------------------------
158      !!
159      INTEGER, INTENT(in) :: Kbb, Kmm, Kaa    ! ocean time level indices
160      !!----------------------------------------------------------------------
161      INTEGER :: ji, jj, jd, jk      !! loop index
162      INTEGER :: jip1, jim1, jjp1, jjm1
163      !!
164      REAL(wp):: zsummsk
165      REAL(wp), DIMENSION(jpi,jpj) :: zdssmask, zssmask0, zssmask_b, zssh
166      !!----------------------------------------------------------------------
167      !
168      CALL iom_get( numror, jpdom_autoglo, 'ssmask'  , zssmask_b, ldxios = lrxios   ) ! need to extrapolate T/S
169
170      ! compute new ssh if we open a full water column
171      ! rude average of the closest neigbourgs (e1e2t not taking into account)
172      !
173      zssh(:,:)     = ssh(:,:,Kmm)
174      zssmask0(:,:) = zssmask_b(:,:)
175      !
176      DO jd = 1, nn_drown
177         !
178         zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:)
179         DO_2D_00_00
180            jip1=ji+1; jim1=ji-1;
181            jjp1=jj+1; jjm1=jj-1;
182            !
183            zsummsk = zssmask0(jip1,jj) + zssmask0(jim1,jj) + zssmask0(ji,jjp1) + zssmask0(ji,jjm1)
184            !
185            IF (zdssmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp) THEN
186               ssh(ji,jj,Kmm)=( zssh(jip1,jj)*zssmask0(jip1,jj)     &
187               &           + zssh(jim1,jj)*zssmask0(jim1,jj)     &
188               &           + zssh(ji,jjp1)*zssmask0(ji,jjp1)     &
189               &           + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk
190               zssmask_b(ji,jj) = 1._wp
191            ENDIF
192         END_2D
193         !
194         zssh(:,:) = ssh(:,:,Kmm)
195         zssmask0(:,:) = zssmask_b(:,:)
196         !
197         CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp )
198         !
199      END DO
200      !
201      ! update ssh(:,:,Kmm)
202      ssh(:,:,Kmm) = zssh(:,:) * ssmask(:,:)
203      !
204      ssh(:,:,Kbb) = ssh(:,:,Kmm)
205      !
206      IF ( ln_isfdebug ) CALL debug('isfcpl_ssh: sshn',ssh(:,:,Kmm))
207      !
208      ! recompute the vertical scale factor, depth and water thickness
209      IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)'
210      IF(lwp) write(numout,*) '~~~~~~~~~~~'
211      DO jk = 1, jpk
212         e3t(:,:,jk,Kmm) =  e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &
213             &                          / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk)   &
214             &          + e3t_0(:,:,jk)                               * (1._wp -tmask(:,:,jk))
215      END DO
216      e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
217      CALL dom_vvl_zgr(Kbb, Kmm, Kaa)
218      !
219   END SUBROUTINE isfcpl_ssh
220
221   SUBROUTINE isfcpl_tra(Kmm)
222      !!----------------------------------------------------------------------
223      !!                   ***  ROUTINE iscpl_tra  ***
224      !!
225      !! ** Purpose :   compute new tn, sn in case of evolving geometry of ice shelves
226      !!
227      !! ** Method  :   tn, sn : basic extrapolation from neigbourg cells
228      !!
229      !!----------------------------------------------------------------------
230      INTEGER, INTENT(in) :: Kmm    ! ocean time level index
231      !!----------------------------------------------------------------------
232      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b
233      !REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: pdepw_b                         !! depth w before
234      !!
235      INTEGER :: ji, jj, jk, jd          !! loop index
236      INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1
237      !!
238      REAL(wp):: zsummsk
239      REAL(wp):: zdz, zdzm1, zdzp1
240      !!
241      REAL(wp), DIMENSION(jpi,jpj)          :: zdmask 
242      REAL(wp), DIMENSION(jpi,jpj,jpk)      :: ztmask0, zwmaskn
243      REAL(wp), DIMENSION(jpi,jpj,jpk)      :: ztmask1, zwmaskb, ztmp3d
244      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0
245      !!----------------------------------------------------------------------
246      !
247      CALL iom_get( numror, jpdom_autoglo, 'tmask'  , ztmask_b, ldxios = lrxios   ) ! need to extrapolate T/S
248      !CALL iom_get( numror, jpdom_autoglo, 'wmask'  , zwmask_b, ldxios = lrxios   ) ! need to extrapolate T/S
249      !CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl)
250      !
251      !
252      ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask
253      !PM: Is this IF needed since change to VVL by default
254      !bugged : to be corrected (PM)
255      ! back up original t/s/mask
256      !tsb (:,:,:,:) = ts(:,:,:,:,Kmm)
257      !
258     ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask
259
260!      IF (.NOT.ln_linssh) THEN
261!         DO jk = 2,jpk-1
262!            DO jj = 1,jpj
263!               DO ji = 1,jpi
264!                  IF (wmask(ji,jj,jk) * zwmaskb(ji,jj,jk) == 1._wp .AND. (tmask(ji,jj,1)==0._wp .OR. ztmask_b(ji,jj,1)==0._wp) ) THEN
265!
266!                     !compute weight
267!                     zdzp1 = MAX(0._wp,pdepw_b(ji,jj,jk+1) - gdepw(ji,jj,jk+1,Kmm))
268!                     zdzm1 = MAX(0._wp,gdepw(ji,jj,jk  ,Kmm) - pdepw_b(ji,jj,jk  ))
269!                     zdz   = e3t(ji,jj,jk,Kmm) - zdzp1 - zdzm1 ! if isf : e3t = gdepw(ji,jj,jk+1,Kmm)- gdepw(ji,jj,jk,Kmm)
270!
271!                     IF (zdz .LT. 0._wp) THEN
272!                        CALL ctl_stop( 'STOP', 'rst_iscpl : unable to compute the interpolation' )
273!                     END IF
274!
275!                     ts(ji,jj,jk,jp_tem,Kmm) = ( zdzp1*ts(ji,jj,jk+1,jp_tem,Kbb) &
276!                        &                   + zdz  *ts(ji,jj,jk  ,jp_tem,Kbb) &
277!                        &                   + zdzm1*ts(ji,jj,jk-1,jp_tem,Kbb) )/e3t(ji,jj,jk,Kmm)
278!
279!                     ts(ji,jj,jk,jp_sal,Kmm) = ( zdzp1*ts(ji,jj,jk+1,jp_sal,Kbb) &
280!                        &                   + zdz  *ts(ji,jj,jk  ,jp_sal,Kbb) &
281!                        &                   + zdzm1*ts(ji,jj,jk-1,jp_sal,Kbb) )/e3t(ji,jj,jk,Kmm)
282!
283!                  END IF
284!               END DO
285!            END DO
286!         END DO
287!      END IF
288
289      zts0(:,:,:,:)  = ts(:,:,:,:,Kmm)
290      ztmask0(:,:,:) = ztmask_b(:,:,:)
291      ztmask1(:,:,:) = ztmask_b(:,:,:)
292      !
293      ! iterate the extrapolation processes nn_drown times
294      DO jd = 1,nn_drown ! resolution dependent (OK for ISOMIP+ case)
295         DO jk = 1,jpk-1
296            !
297            ! define new wet cell
298            zdmask(:,:) = tmask(:,:,jk) - ztmask0(:,:,jk);
299            !
300            DO_2D_00_00
301               jip1=ji+1; jim1=ji-1;
302               jjp1=jj+1; jjm1=jj-1;
303               !
304               ! check if a wet neigbourg cell is present
305               zsummsk = ztmask0(jip1,jj  ,jk) + ztmask0(jim1,jj  ,jk) &
306                       + ztmask0(ji  ,jjp1,jk) + ztmask0(ji  ,jjm1,jk)
307               !
308               ! if neigbourg wet cell available at the same level
309               IF ( zdmask(ji,jj) == 1._wp  .AND. zsummsk /= 0._wp ) THEN
310                  !
311                  ! horizontal basic extrapolation
312                  ts(ji,jj,jk,1,Kmm)=( zts0(jip1,jj  ,jk,1) * ztmask0(jip1,jj  ,jk) &
313                  &               + zts0(jim1,jj  ,jk,1) * ztmask0(jim1,jj  ,jk) &
314                  &               + zts0(ji  ,jjp1,jk,1) * ztmask0(ji  ,jjp1,jk) &
315                  &               + zts0(ji  ,jjm1,jk,1) * ztmask0(ji  ,jjm1,jk) ) / zsummsk
316                  ts(ji,jj,jk,2,Kmm)=( zts0(jip1,jj  ,jk,2) * ztmask0(jip1,jj  ,jk) &
317                  &               + zts0(jim1,jj  ,jk,2) * ztmask0(jim1,jj  ,jk) &
318                  &               + zts0(ji  ,jjp1,jk,2) * ztmask0(ji  ,jjp1,jk) &
319                  &               + zts0(ji  ,jjm1,jk,2) * ztmask0(ji  ,jjm1,jk) ) / zsummsk
320                  !
321                  ! update mask for next pass
322                  ztmask1(ji,jj,jk)=1
323                  !
324               ! in case no neigbourg wet cell available at the same level
325               ! check if a wet cell is available below
326               ELSEIF (zdmask(ji,jj) == 1._wp .AND. zsummsk == 0._wp) THEN
327                  !
328                  ! vertical extrapolation if horizontal extrapolation failed
329                  jkm1=max(1,jk-1) ; jkp1=min(jpk,jk+1)
330                  !
331                  ! check if a wet neigbourg cell is present
332                  zsummsk = ztmask0(ji,jj,jkm1) + ztmask0(ji,jj,jkp1)
333                  IF (zdmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp ) THEN
334                     ts(ji,jj,jk,1,Kmm)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1)     &
335                     &               + zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1)) / zsummsk
336                     ts(ji,jj,jk,2,Kmm)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1)     &
337                     &               + zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1)) / zsummsk
338                     !
339                     ! update mask for next pass
340                     ztmask1(ji,jj,jk)=1._wp
341                  END IF
342               END IF
343            END_2D
344         END DO
345         !
346         ! update temperature and salinity and mask
347         zts0(:,:,:,:)  = ts(:,:,:,:,Kmm)
348         ztmask0(:,:,:) = ztmask1(:,:,:)
349         !
350         CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp)
351         !
352      END DO  ! nn_drown
353      !
354      ! mask new ts(:,:,:,:,Kmm) field
355      ts(:,:,:,jp_tem,Kmm) = zts0(:,:,:,jp_tem) * tmask(:,:,:)
356      ts(:,:,:,jp_sal,Kmm) = zts0(:,:,:,jp_sal) * tmask(:,:,:)
357      !
358      ! sanity check
359      ! -----------------------------------------------------------------------------------------
360      ! case we open a cell but no neigbour cells available to get an estimate of T and S
361      DO_3D_11_11( 1,jpk-1 )
362         IF (tmask(ji,jj,jk) == 1._wp .AND. ts(ji,jj,jk,2,Kmm) == 0._wp)              &
363            &   CALL ctl_stop('STOP', 'failing to fill all new weet cell,     &
364            &                          try increase nn_drown or activate XXXX &
365            &                         in your domain cfg computation'         )
366      END_3D
367      !
368   END SUBROUTINE isfcpl_tra
369
370   SUBROUTINE isfcpl_vol(Kmm)
371      !!----------------------------------------------------------------------
372      !!                   ***  ROUTINE iscpl_vol  ***
373      !!
374      !! ** Purpose : compute the correction of the local divergence to apply 
375      !!              during the first time step after the coupling.
376      !!
377      !! ** Method  : - compute horizontal vol div. before/after coupling
378      !!              - compute vertical input
379      !!              - compute correction
380      !!               
381      !!----------------------------------------------------------------------
382      !!
383      INTEGER, INTENT(in) :: Kmm    ! ocean time level index
384      !!----------------------------------------------------------------------
385      INTEGER :: ji, jj, jk 
386      INTEGER :: ikb, ikt
387      !!
388      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zqvolb, zqvoln  ! vol flux div.         before/after coupling
389      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3u_b, ze3v_b  ! vertical scale factor before/after coupling
390      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b        ! mask                  before       coupling
391      !!----------------------------------------------------------------------
392      !
393      CALL iom_get( numror, jpdom_autoglo, 'tmask'  , ztmask_b, ldxios = lrxios )
394      CALL iom_get( numror, jpdom_autoglo, 'e3u_n'  , ze3u_b  , ldxios = lrxios )
395      CALL iom_get( numror, jpdom_autoglo, 'e3v_n'  , ze3v_b  , ldxios = lrxios )
396      !
397      ! 1.0: compute horizontal volume flux divergence difference before-after coupling
398      !
399      DO jk = 1, jpk                                 ! Horizontal slab
400         ! 1.1: get volume flux before coupling (>0 out)
401         DO_2D_00_00
402            zqvolb(ji,jj,jk) =  (   e2u(ji,jj) * ze3u_b(ji,jj,jk) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj  ) * ze3u_b(ji-1,jj  ,jk) * uu(ji-1,jj  ,jk,Kmm)    &
403               &                  + e1v(ji,jj) * ze3v_b(ji,jj,jk) * vv(ji,jj,jk,Kmm) - e1v(ji  ,jj-1) * ze3v_b(ji  ,jj-1,jk) * vv(ji  ,jj-1,jk,Kmm)  ) &
404               &                * ztmask_b(ji,jj,jk)
405         END_2D
406         !
407         ! 1.2: get volume flux after coupling (>0 out)
408         ! properly mask velocity
409         ! (velocity are still mask with old mask at this stage)
410         uu(:,:,jk,Kmm) = uu(:,:,jk,Kmm) * umask(:,:,jk)
411         vv(:,:,jk,Kmm) = vv(:,:,jk,Kmm) * vmask(:,:,jk)
412         ! compute volume flux divergence after coupling
413         DO_2D_00_00
414            zqvoln(ji,jj,jk) = (   e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj  ) * e3u(ji-1,jj  ,jk,Kmm) * uu(ji-1,jj  ,jk,Kmm)    &
415               &                 + e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) - e1v(ji  ,jj-1) * e3v(ji  ,jj-1,jk,Kmm) * vv(ji  ,jj-1,jk,Kmm)  ) &
416               &               * tmask(ji,jj,jk)
417         END_2D
418         !
419         ! 1.3: get 3d volume flux difference (before - after cpl) (>0 out)
420         !      correction to add is _b - _n
421         risfcpl_vol(:,:,jk) = zqvolb(:,:,jk) - zqvoln(:,:,jk)
422      END DO
423      !
424      ! 2.0: include the contribution of the vertical velocity in the volume flux correction
425      !
426      DO_2D_00_00
427         !
428         ikt = mikt(ji,jj)
429         IF ( ikt > 1 .AND. ssmask(ji,jj) == 1 ) THEN
430            risfcpl_vol(ji,jj,ikt) = risfcpl_vol(ji,jj,ikt) + SUM(zqvolb(ji,jj,1:ikt-1))  ! test sign
431         ENDIF
432         !
433      END_2D
434      !
435      CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1.0_wp )
436      !
437      ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh)
438      !
439      ! 3.1: mask volume flux divergence correction
440      risfcpl_vol(:,:,:) = risfcpl_vol(:,:,:) * tmask(:,:,:)
441      !
442      ! 3.2: get 3d tr(:,:,:,:,Krhs) increment to apply at the first time step
443      ! temperature and salt content flux computed using local ts(:,:,:,:,Kmm)
444      ! (very simple advection scheme)
445      ! (>0 out)
446      risfcpl_tsc(:,:,:,jp_tem) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_tem,Kmm)
447      risfcpl_tsc(:,:,:,jp_sal) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_sal,Kmm)
448      !
449      ! 3.3: ssh correction (for dynspg_ts)
450      risfcpl_ssh(:,:) = 0.0
451      DO jk = 1,jpk
452         risfcpl_ssh(:,:) = risfcpl_ssh(:,:) + risfcpl_vol(:,:,jk) * r1_e1e2t(:,:)
453      END DO
454
455   END SUBROUTINE isfcpl_vol
456
457   SUBROUTINE isfcpl_cons(Kmm)
458      !!----------------------------------------------------------------------
459      !!                   ***  ROUTINE iscpl_cons  ***
460      !!
461      !! ** Purpose :   compute the corrective increment in volume/salt/heat to put back the vol/heat/salt
462      !!                removed or added during the coupling processes (wet or dry new cell)
463      !!
464      !! ** Method  :   - compare volume/heat/salt before and after
465      !!                - look for the closest wet cells (share amoung neigbourgs if there are)
466      !!                - build the correction increment to applied at each time step
467      !!               
468      !!----------------------------------------------------------------------
469      !
470      TYPE(isfcons), DIMENSION(:),ALLOCATABLE :: zisfpts ! list of point receiving a correction
471      !
472      !!----------------------------------------------------------------------
473      INTEGER, INTENT(in) :: Kmm    ! ocean time level index
474      !!----------------------------------------------------------------------
475      INTEGER  ::   ji   , jj  , jk  , jproc          ! loop index
476      INTEGER  ::   jip1 , jim1, jjp1, jjm1           ! dummy indices
477      INTEGER  ::   iig  , ijg, ik                    ! dummy indices
478      INTEGER  ::   jisf                              ! start, end and current position in the increment array
479      INTEGER  ::   ingb, ifind                       ! 0/1 target found or need to be found
480      INTEGER  ::   nisfl_area                        ! global number of cell concerned by the wet->dry case
481      INTEGER, DIMENSION(jpnij) :: nisfl              ! local  number of cell concerned by the wet->dry case
482      !
483      REAL(wp) ::   z1_sum, z1_rdtiscpl
484      REAL(wp) ::   zdtem, zdsal, zdvol, zratio       ! tem, sal, vol increment
485      REAL(wp) ::   zlon , zlat                       ! target location 
486      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b    ! mask before
487      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t_b      ! scale factor before
488      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zt_b      ! scale factor before
489      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zs_b      ! scale factor before
490      !!----------------------------------------------------------------------
491
492      !==============================================================================
493      ! 1.0: initialisation
494      !==============================================================================
495
496      ! get restart variable
497      CALL iom_get( numror, jpdom_autoglo, 'tmask'  , ztmask_b(:,:,:), ldxios = lrxios   ) ! need to extrapolate T/S
498      CALL iom_get( numror, jpdom_autoglo, 'e3t_n'  , ze3t_b(:,:,:)  , ldxios = lrxios )
499      CALL iom_get( numror, jpdom_autoglo, 'tn'     , zt_b(:,:,:)    , ldxios = lrxios )
500      CALL iom_get( numror, jpdom_autoglo, 'sn'     , zs_b(:,:,:)    , ldxios = lrxios )
501
502      ! compute run length
503      nstp_iscpl  = nitend - nit000 + 1
504      rdt_iscpl   = nstp_iscpl * rn_Dt
505      z1_rdtiscpl = 1._wp / rdt_iscpl 
506
507      IF (lwp) WRITE(numout,*) '            nb of stp for cons  = ', nstp_iscpl
508      IF (lwp) WRITE(numout,*) '            coupling time step  = ', rdt_iscpl
509
510      ! initialisation correction
511      risfcpl_cons_vol = 0.0
512      risfcpl_cons_ssh = 0.0
513      risfcpl_cons_tsc = 0.0
514
515      !==============================================================================
516      ! 2.0: diagnose the heat, salt and volume input and compute the correction variable
517      !      for case where we wet a cell or cell still wet (no change in cell status)
518      !==============================================================================
519
520      DO jk = 1,jpk-1
521         DO jj = nldj,nlej
522            DO ji = nldi,nlei
523
524               ! volume diff
525               zdvol = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) - ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk)
526
527               ! heat diff
528               zdtem = ts (ji,jj,jk,jp_tem,Kmm) *  e3t(ji,jj,jk,Kmm) *  tmask  (ji,jj,jk)   &
529                     - zt_b(ji,jj,jk)        * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk)
530
531               ! salt diff
532               zdsal = ts(ji,jj,jk,jp_sal,Kmm) *  e3t(ji,jj,jk,Kmm) *  tmask  (ji,jj,jk)   &
533                     - zs_b(ji,jj,jk)       * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk)
534           
535               ! volume, heat and salt differences in each cell (>0 means correction is an outward flux)
536               ! in addition to the geometry change unconservation, need to add the divergence correction as it is flux across the boundary
537               risfcpl_cons_vol(ji,jj,jk)        = (   zdvol * e1e2t(ji,jj) + risfcpl_vol(ji,jj,jk)        ) * z1_rdtiscpl
538               risfcpl_cons_tsc(ji,jj,jk,jp_sal) = ( - zdsal * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_sal) ) * z1_rdtiscpl
539               risfcpl_cons_tsc(ji,jj,jk,jp_tem) = ( - zdtem * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_tem) ) * z1_rdtiscpl
540
541            END DO
542         END DO
543      END DO
544      !
545      !==============================================================================
546      ! 3.0: diagnose the heat, salt and volume input and compute the correction variable
547      !      for case where we close a cell
548      !==============================================================================
549      !
550      ! compute the total number of point receiving a correction increment for each processor
551      ! local
552      nisfl(:)=0
553      DO jk = 1,jpk-1
554         DO jj = nldj,nlej
555            DO ji = nldi,nlei
556               jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ;
557               IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp)
558            ENDDO
559         ENDDO
560      ENDDO
561      !
562      ! global
563      CALL mpp_sum('isfcpl',nisfl  )
564      !
565      ! allocate list of point receiving correction
566      ALLOCATE(zisfpts(nisfl(narea)))
567      !
568      zisfpts(:) = isfcons(0,0,0,-HUGE(1.0), -HUGE(1.0), -HUGE(1.0), -HUGE(1.0), -HUGE(1.0), 0)
569      !
570      ! start computing the correction and fill zisfpts
571      ! local
572      jisf = 0
573      DO jk = 1,jpk-1
574         DO jj = nldj,nlej
575            DO ji = nldi,nlei
576               IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN
577
578                  jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ;
579
580                  zdvol = risfcpl_cons_vol(ji,jj,jk       )
581                  zdsal = risfcpl_cons_tsc(ji,jj,jk,jp_sal)
582                  zdtem = risfcpl_cons_tsc(ji,jj,jk,jp_tem)
583
584                  IF ( SUM( tmask(jim1:jip1,jjm1:jjp1,jk) ) > 0._wp ) THEN
585                     ! spread correction amoung neigbourg wet cells (horizontal direction first)
586                     ! as it is a rude correction corner and lateral cell have the same weight
587                     !
588                     z1_sum =  1._wp / SUM( tmask(jim1:jip1,jjm1:jjp1,jk) )
589                     !
590                     ! lateral cells
591                     IF (tmask(jip1,jj  ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jj  , jk, zdvol, zdsal, zdtem, z1_sum)
592                     IF (tmask(jim1,jj  ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jj  , jk, zdvol, zdsal, zdtem, z1_sum)
593                     IF (tmask(ji  ,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji  , jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
594                     IF (tmask(ji  ,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji  , jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
595                     !
596                     ! corner  cells
597                     IF (tmask(jip1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
598                     IF (tmask(jim1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
599                     IF (tmask(jim1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
600                     IF (tmask(jip1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
601                     !
602                  ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN
603                     ! spread correction amoung neigbourg wet cells (vertical direction)
604                     CALL update_isfpts(zisfpts, jisf, ji  , jj  , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0)
605                  ELSE
606                     ! need to find where to put correction in later on
607                     CALL update_isfpts(zisfpts, jisf, ji  , jj  , jk  , zdvol, zdsal, zdtem, 1.0_wp, 1)
608                  END IF
609               END IF
610            END DO
611         END DO
612      END DO
613      !
614      ! share data among all processes because for some point we need to find the closest wet point (could be on other process)
615      DO jproc=1,jpnij
616         !
617         ! share total number of isf point treated for proc jproc
618         IF (jproc==narea) THEN
619            nisfl_area=nisfl(jproc)
620         ELSE
621            nisfl_area=0
622         END IF
623         CALL mpp_max('isfcpl',nisfl_area)
624         !
625         DO jisf = 1,nisfl_area
626            !
627            IF (jproc==narea) THEN
628               ! indices (conversion to global indices and sharing)
629               iig = zisfpts(jisf)%ii       ; ijg = zisfpts(jisf)%jj       ; ik = zisfpts(jisf)%kk
630               !
631               ! data
632               zdvol = zisfpts(jisf)%dvol   ; zdsal = zisfpts(jisf)%dsal   ; zdtem = zisfpts(jisf)%dtem
633               !
634               ! location
635               zlat = zisfpts(jisf)%lat     ; zlon = zisfpts(jisf)%lon
636               !
637               ! find flag
638               ingb = zisfpts(jisf)%ngb
639            ELSE
640               iig  =0   ; ijg  =0   ; ik   =0 
641               zdvol=-HUGE(1.0) ; zdsal=-HUGE(1.0) ; zdtem=-HUGE(1.0)
642               zlat =-HUGE(1.0) ; zlon =-HUGE(1.0)   
643               ingb = 0
644            END IF
645            !
646            ! share data (need synchronisation of data as get_correction call a global com)
647            CALL mpp_max('isfcpl',iig)   ; CALL mpp_max('isfcpl',ijg)   ; CALL mpp_max('isfcpl',ik)
648            CALL mpp_max('isfcpl',zdvol) ; CALL mpp_max('isfcpl',zdsal) ; CALL mpp_max('isfcpl',zdtem)
649            CALL mpp_max('isfcpl',zlat)  ; CALL mpp_max('isfcpl',zlon)
650            CALL mpp_max('isfcpl',ingb)
651            !
652            ! fill the 3d correction array
653            CALL get_correction(iig, ijg, ik, zlon, zlat, zdvol, zdsal, zdtem, ingb)
654         END DO
655      END DO
656      !
657      !==============================================================================
658      ! 4.0: finalisation and compute ssh equivalent of the volume correction
659      !==============================================================================
660      !
661      ! mask (>0 out)
662      risfcpl_cons_vol(:,:,:       ) = risfcpl_cons_vol(:,:,:       ) * tmask(:,:,:)
663      risfcpl_cons_tsc(:,:,:,jp_sal) = risfcpl_cons_tsc(:,:,:,jp_sal) * tmask(:,:,:)
664      risfcpl_cons_tsc(:,:,:,jp_tem) = risfcpl_cons_tsc(:,:,:,jp_tem) * tmask(:,:,:)
665      !
666      ! add lbclnk
667      CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, &
668         &                            risfcpl_cons_vol(:,:,:)       , 'T', 1.0_wp)
669      !
670      ! ssh correction (for dynspg_ts)
671      DO jk = 1,jpk
672         risfcpl_cons_ssh(:,:) = risfcpl_cons_ssh(:,:) + risfcpl_cons_vol(:,:,jk)
673      END DO
674      risfcpl_cons_ssh(:,:) = risfcpl_cons_ssh(:,:) * r1_e1e2t(:,:)
675      !
676   END SUBROUTINE isfcpl_cons
677   !
678   SUBROUTINE update_isfpts(sisfpts, kpts, ki, kj, kk, pdvol, pdsal, pdtem, pratio, kfind)
679      !!---------------------------------------------------------------------
680      !!                  ***  ROUTINE update_isfpts  ***
681      !!
682      !! ** Purpose : if a cell become dry, we need to put the corrective increment elsewhere
683      !!
684      !! ** Action  : update the list of point
685      !!
686      !!----------------------------------------------------------------------
687      !!----------------------------------------------------------------------
688      TYPE(isfcons), DIMENSION(:), INTENT(inout) :: sisfpts
689      INTEGER,                     INTENT(inout) :: kpts
690      !!----------------------------------------------------------------------
691      INTEGER,      INTENT(in   )           :: ki, kj, kk                  !    target location (kfind=0)
692      !                                                                    ! or source location (kfind=1)
693      INTEGER,      INTENT(in   ), OPTIONAL :: kfind                       ! 0  target cell already found
694      !                                                                    ! 1  target to be determined
695      REAL(wp),     INTENT(in   )           :: pdvol, pdsal, pdtem, pratio ! vol/sal/tem increment
696      !                                                                    ! and ratio in case increment span over multiple cells.
697      !!----------------------------------------------------------------------
698      INTEGER :: ifind
699      !!----------------------------------------------------------------------
700      !
701      ! increment position
702      kpts = kpts + 1
703      !
704      ! define if we need to look for closest valid wet cell (no neighbours or neigbourg on halo)
705      IF ( PRESENT(kfind) ) THEN
706         ifind = kfind
707      ELSE
708         ifind = ( 1 - tmask_h(ki,kj) ) * tmask(ki,kj,kk)
709      END IF
710      !
711      ! update isfpts structure
712      sisfpts(kpts) = isfcons(mig(ki), mjg(kj), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, glamt(ki,kj), gphit(ki,kj), ifind )
713      !
714   END SUBROUTINE update_isfpts
715   !
716   SUBROUTINE get_correction( ki, kj, kk, plon, plat, pvolinc, psalinc, pteminc, kfind)
717      !!---------------------------------------------------------------------
718      !!                  ***  ROUTINE get_correction  ***
719      !!
720      !! ** Action : - Find the closest valid cell if needed (wet and not on the halo)
721      !!             - Scale the correction depending of pratio (case where multiple wet neigbourgs)
722      !!             - Fill the correction array
723      !!
724      !!----------------------------------------------------------------------
725      INTEGER , INTENT(in) :: ki, kj, kk, kfind        ! target point indices
726      REAL(wp), INTENT(in) :: plon, plat               ! target point lon/lat
727      REAL(wp), INTENT(in) :: pvolinc, pteminc,psalinc ! correction increment for vol/temp/salt
728      !!----------------------------------------------------------------------
729      INTEGER :: jj, ji, iig, ijg
730      !!----------------------------------------------------------------------
731      !
732      ! define global indice of correction location
733      iig = ki ; ijg = kj
734      IF ( kfind == 1 ) CALL dom_ngb( plon, plat, iig, ijg,'T', kk)
735      !
736      ! fill the correction array
737      DO jj = mj0(ijg),mj1(ijg)
738         DO ji = mi0(iig),mi1(iig)
739            ! correct the vol_flx and corresponding heat/salt flx in the closest cell
740            risfcpl_cons_vol(ji,jj,kk)        =  risfcpl_cons_vol(ji,jj,kk       ) + pvolinc
741            risfcpl_cons_tsc(ji,jj,kk,jp_sal) =  risfcpl_cons_tsc(ji,jj,kk,jp_sal) + psalinc
742            risfcpl_cons_tsc(ji,jj,kk,jp_tem) =  risfcpl_cons_tsc(ji,jj,kk,jp_tem) + pteminc
743         END DO
744      END DO
745
746   END SUBROUTINE get_correction
747
748END MODULE isfcpl
Note: See TracBrowser for help on using the repository browser.