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

source: branches/2017/dev_r7881_no_wrk_alloc/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90 @ 7910

Last change on this file since 7910 was 7910, checked in by timgraham, 7 years ago

All wrk_alloc removed

File size: 15.4 KB
RevLine 
[5790]1MODULE iscplhsb
2   !!======================================================================
[7646]3   !!                       ***  MODULE  iscplhsb  ***
[5790]4   !! Ocean forcing: ice sheet/ocean coupling (conservation)
5   !!=====================================================================
6   !! History :  NEMO  ! 2015-01 P. Mathiot: original
7   !!----------------------------------------------------------------------
8
9   !!----------------------------------------------------------------------
10   !!   iscpl_alloc    : variable allocation
11   !!   iscpl_hsb      : compute and store the input of heat/salt/volume
12   !!                    into the system due to the coupling process
13   !!   iscpl_div      : correction of divergence to keep volume conservation
14   !!----------------------------------------------------------------------
15   USE dom_oce         ! ocean space and time domain
16   USE domwri          ! ocean space and time domain
17   USE phycst          ! physical constants
18   USE sbc_oce         ! surface boundary condition variables
19   USE oce             ! global tra/dyn variable
20   USE in_out_manager  ! I/O manager
21   USE lib_mpp         ! MPP library
22   USE lib_fortran     ! MPP library
23   USE lbclnk          !
24   USE domngb          !
25   USE iscplini
26
27   IMPLICIT NONE
28   PRIVATE
29   
30   PUBLIC   iscpl_div   
31   PUBLIC   iscpl_cons       
32   !! * Substitutions 
[5920]33#  include "vectopt_loop_substitute.h90"
[5790]34   !!----------------------------------------------------------------------
35   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
36   !! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $
37   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
38   !!----------------------------------------------------------------------
39CONTAINS
40
41   SUBROUTINE iscpl_cons(ptmask_b, psmask_b, pe3t_b, pts_flx, pvol_flx, prdt_iscpl)
42      !!----------------------------------------------------------------------
43      !!                   ***  ROUTINE iscpl_cons  ***
44      !!
45      !! ** Purpose :   compute input into the system during the coupling step
46      !!                compute the correction term
47      !!                compute where the correction have to be applied
48      !!
49      !! ** Method  :   compute tsn*e3t-tsb*e3tb and e3t-e3t_b
50      !!----------------------------------------------------------------------
51      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: ptmask_b    !! mask before
52      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: pe3t_b      !! scale factor before
53      REAL(wp), DIMENSION(:,:    ), INTENT(in ) :: psmask_b    !! mask before
54      REAL(wp), DIMENSION(:,:,:,:), INTENT(out) :: pts_flx     !! corrective flux to have tracer conservation
55      REAL(wp), DIMENSION(:,:,:  ), INTENT(out) :: pvol_flx    !! corrective flux to have volume conservation
56      REAL(wp),                     INTENT(in ) :: prdt_iscpl  !! coupling period
57      !!
[5920]58      INTEGER :: ji, jj, jk                                    !! loop index
[5790]59      INTEGER :: jip1, jim1, jjp1, jjm1
60      !!
61      REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb
[5920]62      REAL(wp):: r1_rdtiscpl
[5820]63      REAL(wp):: zjip1_ratio  , zjim1_ratio  , zjjp1_ratio  , zjjm1_ratio
[5790]64      !!
[5920]65      REAL(wp):: zde3t, zdtem, zdsal
[7910]66      REAL(wp), DIMENSION(jpi,jpj) :: zdssh
[5920]67      !!
68      REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon, zlat
69      REAL(wp), DIMENSION(:), ALLOCATABLE :: zcorr_vol, zcorr_tem, zcorr_sal
[5945]70      INTEGER , DIMENSION(:), ALLOCATABLE :: ixpts, iypts, izpts, inpts
[5790]71      INTEGER :: jpts, npts
72
73
[5920]74      ! get imbalance (volume heat and salt)
75      ! initialisation difference
76      zde3t = 0.0_wp; zdsal = 0.0_wp ; zdtem = 0.0_wp
77
78      ! initialisation correction term
[5802]79      pvol_flx(:,:,:  ) = 0.0_wp
80      pts_flx (:,:,:,:) = 0.0_wp
[5920]81     
82      r1_rdtiscpl = 1._wp / prdt_iscpl 
[5790]83
[5820]84      ! mask tsn and tsb
[5802]85      tsb(:,:,:,jp_tem)=tsb(:,:,:,jp_tem)*ptmask_b(:,:,:); tsn(:,:,:,jp_tem)=tsn(:,:,:,jp_tem)*tmask(:,:,:);
86      tsb(:,:,:,jp_sal)=tsb(:,:,:,jp_sal)*ptmask_b(:,:,:); tsn(:,:,:,jp_sal)=tsn(:,:,:,jp_sal)*tmask(:,:,:);
[5790]87
[5835]88      !==============================================================================
89      ! diagnose the heat, salt and volume input and compute the correction variable
90      !==============================================================================
[5790]91
[5835]92      !
[5920]93      zdssh(:,:) = sshn(:,:) * ssmask(:,:) - sshb(:,:) * psmask_b(:,:)
[6075]94      IF (.NOT. ln_linssh ) zdssh = 0.0_wp ! already included in the levels by definition
[5835]95     
[5802]96      DO jk = 1,jpk-1
[5920]97         DO jj = 2,jpj-1
98            DO ji = fs_2,fs_jpim1
[5802]99               IF (tmask_h(ji,jj) == 1._wp) THEN
[5790]100
[5820]101                  ! volume differences
[6074]102                  zde3t = e3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk)
[5790]103
[5820]104                  ! heat diff
[6074]105                  zdtem = tsn(ji,jj,jk,jp_tem) * e3t_n(ji,jj,jk) *  tmask  (ji,jj,jk)   &
[5920]106                        - tsb(ji,jj,jk,jp_tem) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)
[5820]107                  ! salt diff
[6074]108                  zdsal = tsn(ji,jj,jk,jp_sal) * e3t_n(ji,jj,jk) *  tmask  (ji,jj,jk)   &
[5920]109                        - tsb(ji,jj,jk,jp_sal) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)
[5802]110               
[5820]111                  ! shh changes
112                  IF ( ptmask_b(ji,jj,jk) == 1._wp .OR. tmask(ji,jj,jk) == 1._wp ) THEN
[5920]113                     zde3t = zde3t + zdssh(ji,jj) ! zdssh = 0 if vvl
114                     zdssh(ji,jj) = 0._wp
[5820]115                  END IF
[5790]116
[5820]117                  ! volume, heat and salt differences in each cell
[5920]118                  pvol_flx(ji,jj,jk)       =   pvol_flx(ji,jj,jk)        + zde3t * r1_rdtiscpl
119                  pts_flx (ji,jj,jk,jp_sal)=   pts_flx (ji,jj,jk,jp_sal) + zdsal * r1_rdtiscpl 
120                  pts_flx (ji,jj,jk,jp_tem)=   pts_flx (ji,jj,jk,jp_tem) + zdtem * r1_rdtiscpl
[5790]121
[5835]122                  ! case where we close a cell: check if the neighbour cells are wet
[5820]123                  IF ( tmask(ji,jj,jk) == 0._wp .AND. ptmask_b(ji,jj,jk) == 1._wp ) THEN
[5790]124
[5820]125                     jip1=ji+1 ; jim1=ji-1 ; jjp1=jj+1 ; jjm1=jj-1 ;
[5790]126
[5964]127                     zsum =   e1e2t(ji  ,jjp1) * tmask(ji  ,jjp1,jk) + e1e2t(ji  ,jjm1) * tmask(ji  ,jjm1,jk) &
128                       &    + e1e2t(jim1,jj  ) * tmask(jim1,jj  ,jk) + e1e2t(jip1,jj  ) * tmask(jip1,jj  ,jk)
[5790]129
[5945]130                     IF ( zsum /= 0._wp ) THEN
[5964]131                        zjip1_ratio   = e1e2t(jip1,jj  ) * tmask(jip1,jj  ,jk) / zsum
132                        zjim1_ratio   = e1e2t(jim1,jj  ) * tmask(jim1,jj  ,jk) / zsum
133                        zjjp1_ratio   = e1e2t(ji  ,jjp1) * tmask(ji  ,jjp1,jk) / zsum
134                        zjjm1_ratio   = e1e2t(ji  ,jjm1) * tmask(ji  ,jjm1,jk) / zsum
[5790]135
[5820]136                        pvol_flx(ji  ,jjp1,jk       ) = pvol_flx(ji  ,jjp1,jk       ) + pvol_flx(ji,jj,jk       ) * zjjp1_ratio
137                        pvol_flx(ji  ,jjm1,jk       ) = pvol_flx(ji  ,jjm1,jk       ) + pvol_flx(ji,jj,jk       ) * zjjm1_ratio
138                        pvol_flx(jip1,jj  ,jk       ) = pvol_flx(jip1,jj  ,jk       ) + pvol_flx(ji,jj,jk       ) * zjip1_ratio
139                        pvol_flx(jim1,jj  ,jk       ) = pvol_flx(jim1,jj  ,jk       ) + pvol_flx(ji,jj,jk       ) * zjim1_ratio
140                        pts_flx (ji  ,jjp1,jk,jp_sal) = pts_flx (ji  ,jjp1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjp1_ratio
141                        pts_flx (ji  ,jjm1,jk,jp_sal) = pts_flx (ji  ,jjm1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjm1_ratio
142                        pts_flx (jip1,jj  ,jk,jp_sal) = pts_flx (jip1,jj  ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjip1_ratio
143                        pts_flx (jim1,jj  ,jk,jp_sal) = pts_flx (jim1,jj  ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjim1_ratio
144                        pts_flx (ji  ,jjp1,jk,jp_tem) = pts_flx (ji  ,jjp1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjp1_ratio
145                        pts_flx (ji  ,jjm1,jk,jp_tem) = pts_flx (ji  ,jjm1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjm1_ratio
146                        pts_flx (jip1,jj  ,jk,jp_tem) = pts_flx (jip1,jj  ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjip1_ratio
147                        pts_flx (jim1,jj  ,jk,jp_tem) = pts_flx (jim1,jj  ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjim1_ratio
[5790]148
[5802]149                        ! set to 0 the cell we distributed over neigbourg cells
150                        pvol_flx(ji,jj,jk       ) = 0._wp
151                        pts_flx (ji,jj,jk,jp_sal) = 0._wp
152                        pts_flx (ji,jj,jk,jp_tem) = 0._wp
[5820]153
[5945]154                     ELSE IF (zsum == 0._wp ) THEN
[5820]155                        ! case where we close a cell and no adjacent cell open
156                        ! check if the cell beneath is wet
[5945]157                        IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN
[5820]158                           pvol_flx(ji,jj,jk+1)       =  pvol_flx(ji,jj,jk+1)        + pvol_flx(ji,jj,jk)
159                           pts_flx (ji,jj,jk+1,jp_sal)=  pts_flx (ji,jj,jk+1,jp_sal) + pts_flx (ji,jj,jk,jp_sal)
160                           pts_flx (ji,jj,jk+1,jp_tem)=  pts_flx (ji,jj,jk+1,jp_tem) + pts_flx (ji,jj,jk,jp_tem)
161
162                           ! set to 0 the cell we distributed over neigbourg cells
163                           pvol_flx(ji,jj,jk       ) = 0._wp
164                           pts_flx (ji,jj,jk,jp_sal) = 0._wp
165                           pts_flx (ji,jj,jk,jp_tem) = 0._wp
166                        ELSE
167                        ! case no adjacent cell on the horizontal and on the vertical
[5945]168                           IF ( lwp ) THEN   ! JMM : cAution this warning may occur on any mpp subdomain but numout is only
169                                             ! open for narea== 1 (lwp=T)
[5820]170                           WRITE(numout,*) 'W A R N I N G iscpl: no adjacent cell on the vertical and horizontal'
171                           WRITE(numout,*) '                     ',mig(ji),' ',mjg(jj),' ',jk
172                           WRITE(numout,*) '                     ',ji,' ',jj,' ',jk,' ',narea
173                           WRITE(numout,*) ' we are now looking for the closest wet cell on the horizontal '
[5945]174                           ENDIF
[5820]175                        ! We deal with these points later.
176                        END IF
[5802]177                     END IF
178                  END IF
179               END IF
180            END DO
181         END DO
182      END DO
[5790]183
[5802]184      CALL lbc_sum(pvol_flx(:,:,:       ),'T',1.)
185      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.)
186      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.)
[5790]187
[5802]188      ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point
189      ! allocation and initialisation of the list of problematic point
[5945]190      ALLOCATE(inpts(jpnij))
191      inpts(:)=0
[5790]192
[5802]193      ! fill narea location with the number of problematic point
194      DO jk = 1,jpk-1
[5920]195         DO jj = 2,jpj-1
196            DO ji = fs_2,fs_jpim1
[5820]197               IF (     ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1)  == 0._wp .AND. tmask_h(ji,jj) == 1._wp  &
198                  .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN
[5945]199                  inpts(narea) = inpts(narea) + 1 
[5802]200               END IF
201            END DO
202         END DO
203      END DO
[5790]204
[5802]205      ! build array of total problematic point on each cpu (share to each cpu)
[5945]206      CALL mpp_max(inpts,jpnij) 
[5790]207
[5802]208      ! size of the new variable
[5945]209      npts  = SUM(inpts)   
[5802]210     
211      ! allocation of the coordinates, correction, index vector for the problematic points
212      ALLOCATE(ixpts(npts), iypts(npts), izpts(npts), zcorr_vol(npts), zcorr_sal(npts), zcorr_tem(npts), zlon(npts), zlat(npts))
[5945]213      ixpts(:) = -9999 ; iypts(:) = -9999 ; izpts(:) = -9999 ; zlon(:) = -1.0e20_wp ; zlat(:) = -1.0e20_wp
214      zcorr_vol(:) = -1.0e20_wp
215      zcorr_sal(:) = -1.0e20_wp
216      zcorr_tem(:) = -1.0e20_wp
[5790]217
[5802]218      ! fill new variable
[5945]219      jpts = SUM(inpts(1:narea-1))
[5802]220      DO jk = 1,jpk-1
[5920]221         DO jj = 2,jpj-1
222            DO ji = fs_2,fs_jpim1
[5820]223               IF (     ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1)  == 0._wp .AND. tmask_h(ji,jj) == 1._wp  &
224                  .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN
[5945]225                  jpts = jpts + 1  ! positioning in the inpts vector for the area narea
[5802]226                  ixpts(jpts) = ji           ; iypts(jpts) = jj ; izpts(jpts) = jk
227                  zlon (jpts) = glamt(ji,jj) ; zlat (jpts) = gphit(ji,jj)
228                  zcorr_vol(jpts) = pvol_flx(ji,jj,jk)
229                  zcorr_sal(jpts) = pts_flx (ji,jj,jk,jp_sal)
230                  zcorr_tem(jpts) = pts_flx (ji,jj,jk,jp_tem)
[5820]231
[5802]232                  ! set flx to 0 (safer)
233                  pvol_flx(ji,jj,jk       ) = 0.0_wp
234                  pts_flx (ji,jj,jk,jp_sal) = 0.0_wp
235                  pts_flx (ji,jj,jk,jp_tem) = 0.0_wp
236               END IF
237            END DO
238         END DO
239      END DO
[5790]240
[5802]241      ! build array of total problematic point on each cpu (share to each cpu)
[5820]242      ! point coordinates
[5802]243      CALL mpp_max(zlat ,npts)
244      CALL mpp_max(zlon ,npts)
245      CALL mpp_max(izpts,npts)
246
[5820]247      ! correction values
248      CALL mpp_max(zcorr_vol,npts)
249      CALL mpp_max(zcorr_sal,npts)
250      CALL mpp_max(zcorr_tem,npts)
251
[5802]252      ! put correction term in the closest cell         
253      DO jpts = 1,npts
254         CALL dom_ngb(zlon(jpts), zlat(jpts), ixpts(jpts), iypts(jpts),'T', izpts(jpts))
255         DO jj = mj0(iypts(jpts)),mj1(iypts(jpts))
256            DO ji = mi0(ixpts(jpts)),mi1(ixpts(jpts))
257               jk = izpts(jpts)
[5820]258
259               IF (tmask_h(ji,jj) == 1._wp) THEN
260                  ! correct the vol_flx in the closest cell
261                  pvol_flx(ji,jj,jk)        =  pvol_flx(ji,jj,jk       ) + zcorr_vol(jpts)
262                  pts_flx (ji,jj,jk,jp_sal) =  pts_flx (ji,jj,jk,jp_sal) + zcorr_sal(jpts)
263                  pts_flx (ji,jj,jk,jp_tem) =  pts_flx (ji,jj,jk,jp_tem) + zcorr_tem(jpts)
264
265                  ! set correction to 0
266                  zcorr_vol(jpts) = 0.0_wp
267                  zcorr_sal(jpts) = 0.0_wp
268                  zcorr_tem(jpts) = 0.0_wp
269               END IF
[5802]270            END DO
271         END DO
272      END DO
[5820]273
[5802]274      ! deallocate variables
[5945]275      DEALLOCATE(inpts)
[5802]276      DEALLOCATE(ixpts, iypts, izpts, zcorr_vol, zcorr_sal, zcorr_tem, zlon, zlat)
277   
278      ! add contribution store on the hallo (lbclnk remove one of the contribution)
279      pvol_flx(:,:,:       ) = pvol_flx(:,:,:       ) * tmask(:,:,:)
280      pts_flx (:,:,:,jp_sal) = pts_flx (:,:,:,jp_sal) * tmask(:,:,:)
281      pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:)
282
[5820]283      ! compute sum over the halo and set it to 0.
284      CALL lbc_sum(pvol_flx(:,:,:       ),'T',1._wp)
285      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp)
286      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp)
[5802]287
[5820]288      ! deallocate variables
[5920]289
[5790]290   END SUBROUTINE iscpl_cons
291
292   SUBROUTINE iscpl_div( phdivn )
293      !!----------------------------------------------------------------------
294      !!                  ***  ROUTINE iscpl_div  ***
295      !!
296      !! ** Purpose :   update the horizontal divergenc
297      !!
298      !! ** Method  :
299      !!                CAUTION : iscpl is positive (inflow) and expressed in m/s
300      !!
301      !! ** Action  :   phdivn   increase by the iscpl correction term
302      !!----------------------------------------------------------------------
303      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phdivn   ! horizontal divergence
304      !!
305      INTEGER  ::   ji, jj, jk   ! dummy loop indices
306      !!----------------------------------------------------------------------
307      !
308      DO jk = 1, jpk
309         DO jj = 1, jpj
310            DO ji = 1, jpi
[6074]311               phdivn(ji,jj,jk) = phdivn(ji,jj,jk) + hdiv_iscpl(ji,jj,jk) / e3t_n(ji,jj,jk)
[5790]312            END DO
313         END DO
314      END DO
315      !
316   END SUBROUTINE iscpl_div
317
318END MODULE iscplhsb
Note: See TracBrowser for help on using the repository browser.