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.
iscplrst.F90 in branches/2017/dev_r8600_xios_read/NEMOGCM/NEMO/OPA_SRC/DOM – NEMO

source: branches/2017/dev_r8600_xios_read/NEMOGCM/NEMO/OPA_SRC/DOM/iscplrst.F90 @ 8612

Last change on this file since 8612 was 8612, checked in by andmirek, 6 years ago

#1953 read single file restart with XIOS

File size: 21.1 KB
Line 
1MODULE iscplrst
2   !!======================================================================
3   !!                       ***  MODULE  iscplrst  ***
4   !! Ocean forcing: update the restart file in case of ice sheet/ocean coupling
5   !!=====================================================================
6   !! History :  NEMO  ! 2015-01 P. Mathiot: original
7   !!----------------------------------------------------------------------
8
9   !!----------------------------------------------------------------------
10   !!   iscpl_stp          : step management
11   !!   iscpl_rst_interpol : restart interpolation in case of coupling with ice sheet
12   !!----------------------------------------------------------------------
13   USE dom_oce         ! ocean space and time domain
14   USE domwri          ! ocean space and time domain
15   USE domvvl, ONLY : dom_vvl_interpol
16   USE phycst          ! physical constants
17   USE sbc_oce         ! surface boundary condition variables
18   USE oce             ! global tra/dyn variable
19   USE in_out_manager  ! I/O manager
20   USE iom             ! I/O module
21   USE lib_mpp         ! MPP library
22   USE lib_fortran     ! MPP library
23   USE wrk_nemo        ! Memory allocation
24   USE lbclnk          ! communication
25   USE iscplini        ! ice sheet coupling: initialisation
26   USE iscplhsb        ! ice sheet coupling: conservation
27   USE iom_def, ONLY : lxios_read
28
29   IMPLICIT NONE
30   PRIVATE
31   
32   PUBLIC   iscpl_stp          ! step management
33   !!
34   !! * Substitutions 
35#  include "vectopt_loop_substitute.h90"
36   !!----------------------------------------------------------------------
37   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
38   !! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $
39   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
40   !!----------------------------------------------------------------------
41CONTAINS
42
43   SUBROUTINE iscpl_stp
44      !!----------------------------------------------------------------------
45      !!                   ***  ROUTINE iscpl_stp  ***
46      !!
47      !! ** Purpose : compute initialisation
48      !!              compute extrapolation of restart variable un, vn, tsn, sshn (wetting/drying)   
49      !!              compute correction term if needed
50      !!
51      !!----------------------------------------------------------------------
52      INTEGER  ::   inum0
53      REAL(wp), DIMENSION(:,:  ), POINTER ::   zsmask_b
54      REAL(wp), DIMENSION(:,:,:), POINTER ::   ztmask_b, zumask_b, zvmask_b
55      REAL(wp), DIMENSION(:,:,:), POINTER ::   ze3t_b  , ze3u_b  , ze3v_b 
56      REAL(wp), DIMENSION(:,:,:), POINTER ::   zdepw_b
57      CHARACTER(20) :: cfile
58      !!----------------------------------------------------------------------
59
60      CALL wrk_alloc(jpi,jpj,jpk,   ztmask_b, zumask_b, zvmask_b) ! mask before
61      CALL wrk_alloc(jpi,jpj,jpk,   ze3t_b  , ze3u_b  , ze3v_b  ) ! e3   before
62      CALL wrk_alloc(jpi,jpj,jpk,   zdepw_b )
63      CALL wrk_alloc(jpi,jpj,       zsmask_b                    )
64
65
66      !! get restart variable
67      CALL iom_get( numror, jpdom_autoglo, 'tmask'  , ztmask_b, lrxios = lxios_read   ) ! need to extrapolate T/S
68      CALL iom_get( numror, jpdom_autoglo, 'umask'  , zumask_b, lrxios = lxios_read   ) ! need to correct barotropic velocity
69      CALL iom_get( numror, jpdom_autoglo, 'vmask'  , zvmask_b, lrxios = lxios_read   ) ! need to correct barotropic velocity
70      CALL iom_get( numror, jpdom_autoglo, 'smask'  , zsmask_b, lrxios = lxios_read   ) ! need to correct barotropic velocity
71      CALL iom_get( numror, jpdom_autoglo, 'e3t_n'  , ze3t_b(:,:,:), lrxios = lxios_read )  ! need to compute temperature correction
72      CALL iom_get( numror, jpdom_autoglo, 'e3u_n'  , ze3u_b(:,:,:), lrxios = lxios_read )  ! need to correct barotropic velocity
73      CALL iom_get( numror, jpdom_autoglo, 'e3v_n'  , ze3v_b(:,:,:), lrxios = lxios_read )  ! need to correct barotropic velocity
74      CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:), lrxios = lxios_read ) ! need to interpol vertical profile (vvl)
75
76      !! read namelist
77      CALL iscpl_init()
78
79      !!  ! Extrapolation/interpolation of modify cell and new cells ... (maybe do it later after domvvl)
80      CALL iscpl_rst_interpol( ztmask_b, zumask_b, zvmask_b, zsmask_b, ze3t_b, ze3u_b, ze3v_b, zdepw_b )
81
82      !! compute correction if conservation needed
83      IF ( ln_hsb ) THEN
84         IF( iscpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'rst_iscpl : unable to allocate rst_iscpl arrays' )
85         CALL iscpl_cons(ztmask_b, zsmask_b, ze3t_b, htsc_iscpl, hdiv_iscpl, rdt_iscpl)
86      END IF
87         
88      !! print mesh/mask
89      IF( nn_msh /= 0 .AND. ln_iscpl )   CALL dom_wri      ! Create a domain file
90
91      IF ( ln_hsb ) THEN
92         cfile='correction'
93         cfile = TRIM( cfile )
94         CALL iom_open  ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib )
95         CALL iom_rstput( 0, 0, inum0, 'vol_cor', hdiv_iscpl(:,:,:) )
96         CALL iom_rstput( 0, 0, inum0, 'tem_cor', htsc_iscpl(:,:,:,jp_tem) )
97         CALL iom_rstput( 0, 0, inum0, 'sal_cor', htsc_iscpl(:,:,:,jp_sal) )
98         CALL iom_close ( inum0 )
99      END IF
100
101      CALL wrk_dealloc(jpi,jpj,jpk,   ztmask_b,zumask_b,zvmask_b ) 
102      CALL wrk_dealloc(jpi,jpj,jpk,   ze3t_b  ,ze3u_b  ,ze3v_b   ) 
103      CALL wrk_dealloc(jpi,jpj,jpk,   zdepw_b                    )
104      CALL wrk_dealloc(jpi,jpj,       zsmask_b                   )
105
106      !! next step is an euler time step
107      neuler = 0
108
109      !! set _b and _n variables equal
110      tsb (:,:,:,:) = tsn (:,:,:,:)
111      ub  (:,:,:)   = un  (:,:,:)
112      vb  (:,:,:)   = vn  (:,:,:)
113      sshb(:,:)     = sshn(:,:)
114
115      !! set _b and _n vertical scale factor equal
116      e3t_b (:,:,:) = e3t_n (:,:,:)
117      e3u_b (:,:,:) = e3u_n (:,:,:)
118      e3v_b (:,:,:) = e3v_n (:,:,:)
119
120      e3uw_b (:,:,:) = e3uw_n (:,:,:)
121      e3vw_b (:,:,:) = e3vw_n (:,:,:)
122      gdept_b(:,:,:) = gdept_n(:,:,:)
123      gdepw_b(:,:,:) = gdepw_n(:,:,:)
124      hu_b   (:,:)   = hu_n   (:,:)
125      hv_b   (:,:)   = hv_n   (:,:)
126      r1_hu_b(:,:)   = r1_hu_n(:,:)
127      r1_hv_b(:,:)   = r1_hv_n(:,:)
128      !
129   END SUBROUTINE iscpl_stp
130
131
132   SUBROUTINE iscpl_rst_interpol (ptmask_b, pumask_b, pvmask_b, psmask_b, pe3t_b, pe3u_b, pe3v_b, pdepw_b)
133      !!----------------------------------------------------------------------
134      !!                   ***  ROUTINE iscpl_rst_interpol  ***
135      !!
136      !! ** Purpose :   compute new tn, sn, un, vn and sshn in case of evolving geometry of ice shelves
137      !!                compute 2d fields of heat, salt and volume correction
138      !!
139      !! ** Method  :   tn, sn : extrapolation from neigbourg cells
140      !!                un, vn : fill with 0 velocity and keep barotropic transport by modifing surface velocity or adjacent velocity
141      !!----------------------------------------------------------------------
142      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: ptmask_b, pumask_b, pvmask_b    !! mask before
143      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: pe3t_b  , pe3u_b  , pe3v_b      !! scale factor before
144      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: pdepw_b                         !! depth w before
145      REAL(wp), DIMENSION(:,:    ), INTENT(in ) :: psmask_b                        !! mask before
146      !!
147      INTEGER :: ji, jj, jk, iz          !! loop index
148      INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1
149      !!
150      REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb
151      REAL(wp):: zdz, zdzm1, zdzp1
152      !!
153      REAL(wp), DIMENSION(:,:    ), POINTER :: zdmask , zdsmask, zvcorr, zucorr, zde3t
154      REAL(wp), DIMENSION(:,:    ), POINTER :: zbub   , zbvb   , zbun  , zbvn
155      REAL(wp), DIMENSION(:,:    ), POINTER :: zssh0  , zssh1, zhu1, zhv1
156      REAL(wp), DIMENSION(:,:    ), POINTER :: zsmask0, zsmask1
157      REAL(wp), DIMENSION(:,:,:  ), POINTER :: ztmask0, ztmask1, ztrp
158      REAL(wp), DIMENSION(:,:,:  ), POINTER :: zwmaskn, zwmaskb, ztmp3d
159      REAL(wp), DIMENSION(:,:,:,:), POINTER :: zts0
160      !!----------------------------------------------------------------------
161
162      !! allocate variables
163      CALL wrk_alloc(jpi,jpj,jpk,2, zts0                                   )
164      CALL wrk_alloc(jpi,jpj,jpk,   ztmask0, ztmask1 , ztrp, ztmp3d        ) 
165      CALL wrk_alloc(jpi,jpj,jpk,   zwmaskn, zwmaskb                       ) 
166      CALL wrk_alloc(jpi,jpj,       zsmask0, zsmask1                       ) 
167      CALL wrk_alloc(jpi,jpj,       zdmask , zdsmask, zvcorr, zucorr, zde3t) 
168      CALL wrk_alloc(jpi,jpj,       zbub   , zbvb    , zbun , zbvn         ) 
169      CALL wrk_alloc(jpi,jpj,       zssh0  , zssh1, zhu1, zhv1             ) 
170
171      !! mask value to be sure
172      tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * ptmask_b(:,:,:)
173      tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * ptmask_b(:,:,:)
174     
175      ! compute wmask
176      zwmaskn(:,:,1) = tmask   (:,:,1)
177      zwmaskb(:,:,1) = ptmask_b(:,:,1)
178      DO jk = 2,jpk
179         zwmaskn(:,:,jk) =  tmask  (:,:,jk) *  tmask  (:,:,jk-1)
180         zwmaskb(:,:,jk) = ptmask_b(:,:,jk) * ptmask_b(:,:,jk-1)
181      END DO
182           
183      ! compute new ssh if we open a full water column (average of the closest neigbourgs) 
184      sshb (:,:)=sshn(:,:)
185      zssh0(:,:)=sshn(:,:)
186      zsmask0(:,:) = psmask_b(:,:)
187      zsmask1(:,:) = psmask_b(:,:)
188      DO iz = 1,10    ! need to be tuned (configuration dependent) (OK for ISOMIP+)
189         zdsmask(:,:) = ssmask(:,:)-zsmask0(:,:)
190         DO jj = 2,jpj-1
191            DO ji = fs_2, fs_jpim1   ! vector opt.
192               jip1=ji+1; jim1=ji-1;
193               jjp1=jj+1; jjm1=jj-1;
194               summsk=(zsmask0(jip1,jj)+zsmask0(jim1,jj)+zsmask0(ji,jjp1)+zsmask0(ji,jjm1))
195               IF (zdsmask(ji,jj) == 1._wp .AND. summsk /= 0._wp) THEN
196                  sshn(ji,jj)=( zssh0(jip1,jj)*zsmask0(jip1,jj)     &
197                  &           + zssh0(jim1,jj)*zsmask0(jim1,jj)     &
198                  &           + zssh0(ji,jjp1)*zsmask0(ji,jjp1)     &
199                  &           + zssh0(ji,jjm1)*zsmask0(ji,jjm1))/summsk
200                  zsmask1(ji,jj)=1._wp
201               END IF
202            END DO
203         END DO
204         CALL lbc_lnk(sshn,'T',1._wp)
205         CALL lbc_lnk(zsmask1,'T',1._wp)
206         zssh0   = sshn
207         zsmask0 = zsmask1
208      END DO
209      sshn(:,:) = sshn(:,:) * ssmask(:,:)
210
211!=============================================================================
212!PM: Is this needed since introduction of VVL by default?
213      IF (.NOT.ln_linssh) THEN
214      ! Reconstruction of all vertical scale factors at now time steps
215      ! =============================================================================
216      ! Horizontal scale factor interpolations
217      ! --------------------------------------
218         DO jk = 1,jpk
219            DO jj=1,jpj
220               DO ji=1,jpi
221                  IF (tmask(ji,jj,1) == 0._wp .OR. ptmask_b(ji,jj,1) == 0._wp) THEN
222                     e3t_n(ji,jj,jk) = e3t_0(ji,jj,jk) * ( 1._wp + sshn(ji,jj) /   &
223                     &   ( ht_0(ji,jj) + 1._wp - ssmask(ji,jj) ) * tmask(ji,jj,jk) )
224                  ENDIF
225               END DO
226            END DO
227         END DO
228
229         CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' )
230         CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' )
231         CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' )
232
233      ! Vertical scale factor interpolations
234      ! ------------------------------------
235         CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W'  )
236         CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
237         CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
238
239      ! t- and w- points depth
240      ! ----------------------
241         gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1)
242         gdepw_n(:,:,1) = 0.0_wp
243         gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:)
244         DO jj = 1,jpj
245            DO ji = 1,jpi
246               DO jk = 2,mikt(ji,jj)-1
247                  gdept_n(ji,jj,jk) = gdept_0(ji,jj,jk)
248                  gdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk)
249                  gde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj)
250               END DO
251               IF (mikt(ji,jj) > 1) THEN
252                  jk = mikt(ji,jj)
253                  gdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * e3w_n(ji,jj,jk)
254                  gdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk)
255                  gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk  ) - sshn   (ji,jj)
256               END IF
257               DO jk = mikt(ji,jj)+1, jpk
258                  gdept_n(ji,jj,jk) = gdept_n(ji,jj,jk-1) + e3w_n(ji,jj,jk)
259                  gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1)
260                  gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk  ) - sshn (ji,jj)
261               END DO
262            END DO
263         END DO
264
265      ! t-, u- and v- water column thickness
266      ! ------------------------------------
267         ht_n(:,:) = 0._wp ; hu_n(:,:) = 0._wp ; hv_n(:,:) = 0._wp
268         DO jk = 1, jpkm1
269            hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
270            hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
271            ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk)
272         END DO
273         !                                        ! Inverse of the local depth
274         r1_hu_n(:,:) = 1._wp / ( hu_n(:,:) + 1._wp - ssumask(:,:) ) * ssumask(:,:)
275         r1_hv_n(:,:) = 1._wp / ( hv_n(:,:) + 1._wp - ssvmask(:,:) ) * ssvmask(:,:)
276
277      END IF
278
279!=============================================================================
280! compute velocity
281! compute velocity in order to conserve barotropic velocity (modification by poderation of the scale factor).
282      ub(:,:,:)=un(:,:,:)
283      vb(:,:,:)=vn(:,:,:)
284      DO jk = 1,jpk
285         DO jj = 1,jpj
286            DO ji = 1,jpi
287               un(ji,jj,jk) = ub(ji,jj,jk)*pe3u_b(ji,jj,jk)*pumask_b(ji,jj,jk)/e3u_n(ji,jj,jk)*umask(ji,jj,jk);
288               vn(ji,jj,jk) = vb(ji,jj,jk)*pe3v_b(ji,jj,jk)*pvmask_b(ji,jj,jk)/e3v_n(ji,jj,jk)*vmask(ji,jj,jk);
289            END DO
290         END DO
291      END DO
292
293! compute new velocity if we close a cell (check barotropic velocity and change velocity over the water column)
294! compute barotropic velocity now and after
295      ztrp(:,:,:) = ub(:,:,:)*pe3u_b(:,:,:); 
296      zbub(:,:)   = SUM(ztrp,DIM=3)
297      ztrp(:,:,:) = vb(:,:,:)*pe3v_b(:,:,:); 
298      zbvb(:,:)   = SUM(ztrp,DIM=3)
299      ztrp(:,:,:) = un(:,:,:)*e3u_n(:,:,:); 
300      zbun(:,:)   = SUM(ztrp,DIM=3)
301      ztrp(:,:,:) = vn(:,:,:)*e3v_n(:,:,:); 
302      zbvn(:,:)   = SUM(ztrp,DIM=3)
303
304      ! new water column
305      zhu1=0.0_wp ;
306      zhv1=0.0_wp ;
307      DO jk  = 1,jpk
308        zhu1(:,:) = zhu1(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
309        zhv1(:,:) = zhv1(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
310      END DO
311     
312      ! compute correction     
313      zucorr = 0._wp
314      zvcorr = 0._wp
315      DO jj = 1,jpj
316         DO ji = 1,jpi
317            IF (zbun(ji,jj) /= zbub(ji,jj) .AND. zhu1(ji,jj) /= 0._wp ) THEN
318               zucorr(ji,jj) = (zbun(ji,jj) - zbub(ji,jj))/zhu1(ji,jj)
319            END IF
320            IF (zbvn(ji,jj) /= zbvb(ji,jj) .AND. zhv1(ji,jj) /= 0._wp ) THEN
321               zvcorr(ji,jj) = (zbvn(ji,jj) - zbvb(ji,jj))/zhv1(ji,jj)
322            END IF
323         END DO
324      END DO 
325     
326      ! update velocity
327      DO jk  = 1,jpk
328         un(:,:,jk)=(un(:,:,jk) - zucorr(:,:))*umask(:,:,jk)
329         vn(:,:,jk)=(vn(:,:,jk) - zvcorr(:,:))*vmask(:,:,jk)
330      END DO
331
332!=============================================================================
333      ! compute temp and salt
334      ! compute new tn and sn if we open a new cell
335      tsb (:,:,:,:) = tsn(:,:,:,:)
336      zts0(:,:,:,:) = tsn(:,:,:,:)
337      ztmask1(:,:,:) = ptmask_b(:,:,:)
338      ztmask0(:,:,:) = ptmask_b(:,:,:)
339      DO iz = 1,nn_drown ! resolution dependent (OK for ISOMIP+ case)
340          DO jk = 1,jpk-1
341              zdmask=tmask(:,:,jk)-ztmask0(:,:,jk);
342              DO jj = 2,jpj-1
343                 DO ji = fs_2,fs_jpim1
344                      jip1=ji+1; jim1=ji-1;
345                      jjp1=jj+1; jjm1=jj-1;
346                      summsk= (ztmask0(jip1,jj  ,jk)+ztmask0(jim1,jj  ,jk)+ztmask0(ji  ,jjp1,jk)+ztmask0(ji  ,jjm1,jk))
347                      IF (zdmask(ji,jj) == 1._wp .AND. summsk /= 0._wp) THEN
348                      !! horizontal basic extrapolation
349                         tsn(ji,jj,jk,1)=( zts0(jip1,jj  ,jk,1)*ztmask0(jip1,jj  ,jk) &
350                         &                +zts0(jim1,jj  ,jk,1)*ztmask0(jim1,jj  ,jk) &
351                         &                +zts0(ji  ,jjp1,jk,1)*ztmask0(ji  ,jjp1,jk) &
352                         &                +zts0(ji  ,jjm1,jk,1)*ztmask0(ji  ,jjm1,jk) ) / summsk
353                         tsn(ji,jj,jk,2)=( zts0(jip1,jj  ,jk,2)*ztmask0(jip1,jj  ,jk) &
354                         &                +zts0(jim1,jj  ,jk,2)*ztmask0(jim1,jj  ,jk) &
355                         &                +zts0(ji  ,jjp1,jk,2)*ztmask0(ji  ,jjp1,jk) &
356                         &                +zts0(ji  ,jjm1,jk,2)*ztmask0(ji  ,jjm1,jk) ) / summsk
357                         ztmask1(ji,jj,jk)=1
358                      ELSEIF (zdmask(ji,jj) == 1._wp .AND. summsk == 0._wp) THEN
359                      !! vertical extrapolation if horizontal extrapolation failed
360                         jkm1=max(1,jk-1) ; jkp1=min(jpk,jk+1)
361                         summsk=(ztmask0(ji,jj,jkm1)+ztmask0(ji,jj,jkp1))
362                         IF (zdmask(ji,jj) == 1._wp .AND. summsk /= 0._wp ) THEN
363                            tsn(ji,jj,jk,1)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1)     &
364                            &                +zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1))/summsk
365                            tsn(ji,jj,jk,2)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1)     &
366                            &                +zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1))/summsk
367                            ztmask1(ji,jj,jk)=1._wp
368                         END IF
369                      END IF
370                  END DO
371              END DO
372          END DO
373         
374          CALL lbc_lnk(tsn(:,:,:,1),'T',1._wp)
375          CALL lbc_lnk(tsn(:,:,:,2),'T',1._wp)
376          CALL lbc_lnk(ztmask1,     'T',1._wp)
377
378          ! update
379          zts0(:,:,:,:) = tsn(:,:,:,:)
380          ztmask0 = ztmask1
381
382      END DO
383
384      ! mask new tsn field
385      tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask(:,:,:)
386      tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask(:,:,:)
387
388      ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask
389      !PM: Is this IF needed since change to VVL by default
390      IF (.NOT.ln_linssh) THEN
391         DO jk = 2,jpk-1
392            DO jj = 1,jpj
393               DO ji = 1,jpi
394                  IF (zwmaskn(ji,jj,jk) * zwmaskb(ji,jj,jk) == 1._wp .AND.   &
395                  &      (tmask(ji,jj,1)==0._wp .OR. ptmask_b(ji,jj,1)==0._wp) ) THEN
396                     !compute weight
397                     zdzp1 = MAX(0._wp,gdepw_n(ji,jj,jk+1) - pdepw_b(ji,jj,jk+1))
398                     zdz   =           gdepw_n(ji,jj,jk+1) - pdepw_b(ji,jj,jk  ) 
399                     zdzm1 = MAX(0._wp,pdepw_b(ji,jj,jk  ) - gdepw_n(ji,jj,jk  ))
400                     IF (zdz .LT. 0._wp) THEN
401                        CALL ctl_stop( 'STOP', 'rst_iscpl : unable to compute the interpolation' )
402                     END IF
403                     tsn(ji,jj,jk,jp_tem) = ( zdzp1*tsb(ji,jj,jk+1,jp_tem)      &
404                        &                   + zdz  *tsb(ji,jj,jk  ,jp_tem)      &
405                        &                   + zdzm1*tsb(ji,jj,jk-1,jp_tem)      )/e3t_n(ji,jj,jk)
406                     tsn(ji,jj,jk,jp_sal) = ( zdzp1*tsb(ji,jj,jk+1,jp_sal)      &
407                        &                   + zdz  *tsb(ji,jj,jk  ,jp_sal)      &
408                        &                   + zdzm1*tsb(ji,jj,jk-1,jp_sal)      )/e3t_n(ji,jj,jk)
409                  END IF
410               END DO
411            END DO
412         END DO               
413      END IF
414
415      ! closed pool
416      ! -----------------------------------------------------------------------------------------
417      ! case we open a cell but no neigbour cells available to get an estimate of T and S
418      WHERE (tmask(:,:,:) == 1._wp .AND. tsn(:,:,:,2) == 0._wp) 
419         tsn(:,:,:,2) = -99._wp  ! Special value for closed pool (checking purpose in output.init)
420         tmask(:,:,:) = 0._wp    ! set mask to 0 to run
421         umask(:,:,:) = 0._wp
422         vmask(:,:,:) = 0._wp
423      END WHERE
424     
425      ! set mbkt and mikt to 1 in thiese location
426      WHERE (SUM(tmask,dim=3) == 0)
427         mbkt(:,:)=1 ; mbku(:,:)=1 ; mbkv(:,:)=1
428         mikt(:,:)=1 ; miku(:,:)=1 ; mikv(:,:)=1
429      END WHERE
430      ! -------------------------------------------------------------------------------------------
431      ! compute new tn and sn if we close cell
432      ! nothing to do
433      !
434      ! deallocation tmp arrays
435      CALL wrk_dealloc(jpi,jpj,jpk,2, zts0                                   )
436      CALL wrk_dealloc(jpi,jpj,jpk,   ztmask0, ztmask1 , ztrp                ) 
437      CALL wrk_dealloc(jpi,jpj,jpk,   zwmaskn, zwmaskb , ztmp3d              ) 
438      CALL wrk_dealloc(jpi,jpj,       zsmask0, zsmask1                       ) 
439      CALL wrk_dealloc(jpi,jpj,       zdmask , zdsmask, zvcorr, zucorr, zde3t) 
440      CALL wrk_dealloc(jpi,jpj,       zbub   , zbvb    , zbun  , zbvn        ) 
441      CALL wrk_dealloc(jpi,jpj,       zssh0  , zssh1  , zhu1 , zhv1          ) 
442      !
443   END SUBROUTINE iscpl_rst_interpol
444
445   !!======================================================================
446END MODULE iscplrst
Note: See TracBrowser for help on using the repository browser.