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.
sbcclo.F90 in NEMO/branches/2019/ENHANCE-03_closea/src/OCE/SBC – NEMO

source: NEMO/branches/2019/ENHANCE-03_closea/src/OCE/SBC/sbcclo.F90 @ 11629

Last change on this file since 11629 was 11629, checked in by mathiot, 5 years ago

ENHANCE-03_closea: cosmetic changes (ticket #2143)

File size: 15.8 KB
Line 
1MODULE sbcclo
2   !!======================================================================
3   !!                       ***  MODULE  sbcclo  ***
4   !! Ocean forcing: redistribution of emp unbalance over closed sea into river mouth or open ocean
5   !!=====================================================================
6   !! History :  4.0 and earlier ! see closea.F90 history   
7   !!   NEMO     4.1  ! 2019-09  (P. Mathiot) rewrite sbc_clo module to match new closed sea mask definition (original sbcclo.F90)
8   !!
9   !!----------------------------------------------------------------------
10   !
11   !!----------------------------------------------------------------------
12   !!   Public subroutines:
13   !!   sbc_clo       : update emp and qns over target area and source area
14   !!   sbc_clo_init  : initialise all variable needed for closed sea correction
15   !!
16   !!   Private subroutines:
17   !!   alloc_csarr   : allocate closed sea array
18   !!   get_cssrcsurf : compute source surface area
19   !!   get_cstrgsurf : compute target surface area
20   !!   prt_csctl     : closed sea control print
21   !!   sbc_csupdate  : compute net fw from closed sea
22   !!----------------------------------------------------------------------
23   !
24   USE oce             ! dynamics and tracers
25   USE dom_oce         ! ocean space and time domain
26   USE closea          ! closed sea
27   USE phycst          ! physical constants
28   USE sbc_oce         ! ocean surface boundary conditions
29   USE iom             ! I/O routines
30   !
31   USE in_out_manager  ! I/O manager
32   USE lib_fortran,    ONLY: glob_sum
33   USE lib_mpp         ! MPP library
34   !
35   IMPLICIT NONE
36   !
37   PRIVATE
38   !
39   PUBLIC sbc_clo
40   PUBLIC sbc_clo_init
41   !
42   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcg, rsurftrgg      !: closed sea source/target glo surface areas
43   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcr, rsurftrgr      !: closed sea source/target rnf surface areas
44   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrce, rsurftrge      !: closed sea source/target emp surface areas
45   !
46   INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:)  :: mcsgrpg, mcsgrpr, mcsgrpe !: closed sea group for glo, rnf and emp
47   !
48   CONTAINS
49   !
50   !!----------------------------------------------------------------------
51   !!  Public subroutines
52   !!----------------------------------------------------------------------
53   !
54   SUBROUTINE sbc_clo_init
55      !!---------------------------------------------------------------------
56      !!                  ***  ROUTINE sbc_clo_init  ***
57      !!                   
58      !! ** Purpose :  Initialisation of the variable needed for the net fw closed sea correction
59      !!
60      !! ** Method  :  - compute source surface area for each closed sea
61      !!               - defined the group of each closed sea
62      !!                 (needed to manage multiple closed sea and one target area like great lakes / St Laurent outlet)
63      !!               - compute target surface area
64      !!----------------------------------------------------------------------
65      !
66      ! 0. Allocate cs variables (surf)
67      CALL alloc_csarr( ncsg, rsurfsrcg, rsurftrgg, mcsgrpg ) 
68      CALL alloc_csarr( ncsr, rsurfsrcr, rsurftrgr, mcsgrpr )
69      CALL alloc_csarr( ncse, rsurfsrce, rsurftrge, mcsgrpe )
70      !
71      ! 1. compute source surface area
72      CALL get_cssrcsurf( ncsg, mask_csglo, rsurfsrcg )
73      CALL get_cssrcsurf( ncsr, mask_csrnf, rsurfsrcr )
74      CALL get_cssrcsurf( ncse, mask_csemp, rsurfsrce )
75      !
76      ! 2. compute target surface area and group number (mcsgrp) for all cs and cases
77      ! glo could be simpler but for lisibility, all treated the same way
78      ! It is only done once, so not a big deal
79      CALL get_cstrgsurf( ncsg, mask_csglo, mask_csgrpglo, rsurftrgg, mcsgrpg )
80      CALL get_cstrgsurf( ncsr, mask_csrnf, mask_csgrprnf, rsurftrgr, mcsgrpr )
81      CALL get_cstrgsurf( ncse, mask_csemp, mask_csgrpemp, rsurftrge, mcsgrpe )
82      !
83      ! 3. print out in ocean.ouput
84      IF ( lwp ) WRITE(numout,*) 'sbc_clo_init : compute surface area for source (closed sea) and target (river mouth)'
85      IF ( lwp ) WRITE(numout,*) '~~~~~~~~~~~~~~'
86      CALL prt_csctl( ncsg, rsurfsrcg, rsurftrgg, mcsgrpg, 'glo' )
87      CALL prt_csctl( ncsr, rsurfsrcr, rsurftrgr, mcsgrpr, 'rnf' )
88      CALL prt_csctl( ncse, rsurfsrce, rsurftrge, mcsgrpe, 'emp' )
89
90   END SUBROUTINE sbc_clo_init
91
92   SUBROUTINE sbc_clo( kt )
93      !!---------------------------------------------------------------------
94      !!                  ***  ROUTINE sbc_clo  ***
95      !!                   
96      !! ** Purpose :   Special handling of closed seas
97      !!
98      !! ** Method  :   Water flux is forced to zero over closed sea
99      !!      Excess is shared between remaining ocean, or
100      !!      put as run-off in open ocean.
101      !!
102      !! ** Action  : - compute surface freshwater fluxes and associated heat content flux at kt
103      !!              - output closed sea contribution to fw and heat budget
104      !!              - update emp and qns
105      !!----------------------------------------------------------------------
106      INTEGER         , INTENT(in   ) ::   kt       ! ocean model time step
107      !
108      REAL(wp), DIMENSION(jpi,jpj) :: zwcs, zqcs    ! water flux and heat flux correction due to closed seas
109      !!----------------------------------------------------------------------
110      !
111      ! 0. initialisation
112      zwcs(:,:) = 0._wp ; zqcs(:,:) = 0._wp
113      !
114      ! 1. update emp and qns
115      CALL sbc_csupdate( ncsg, mcsgrpg, mask_csglo, mask_csgrpglo, rsurfsrcg, rsurftrgg, 'glo', mask_opnsea, rsurftrgg, zwcs, zqcs )
116      CALL sbc_csupdate( ncsr, mcsgrpr, mask_csrnf, mask_csgrprnf, rsurfsrcr, rsurftrgr, 'rnf', mask_opnsea, rsurftrgg, zwcs, zqcs )
117      CALL sbc_csupdate( ncse, mcsgrpe, mask_csemp, mask_csgrpemp, rsurfsrce, rsurftrge, 'emp', mask_opnsea, rsurftrgg, zwcs, zqcs )
118      !
119      ! 2. ouput closed sea contributions
120      CALL iom_put('wclosea',zwcs)
121      CALL iom_put('qclosea',zqcs)
122      !
123      ! 3. update emp and qns
124      emp(:,:) = emp(:,:) + zwcs(:,:)
125      qns(:,:) = qns(:,:) + zqcs(:,:)
126      !
127   END SUBROUTINE sbc_clo
128   !
129   !!----------------------------------------------------------------------
130   !!  Private subroutines
131   !!----------------------------------------------------------------------
132   !
133   SUBROUTINE get_cssrcsurf(kncs, kmaskcs, psurfsrc)
134      !!-----------------------------------------------------------------------
135      !!                  ***  routine get_cssrcsurf  ***
136      !!
137      !! ** Purpose : compute closed sea (source) surface area
138      !!----------------------------------------------------------------------
139      ! subroutine parameters
140      INTEGER ,                 INTENT(in   ) :: kncs          ! closed sea number
141      INTEGER , DIMENSION(:,:), INTENT(in   ) :: kmaskcs       ! closed sea mask
142      REAL(wp), DIMENSION(:)  , INTENT(  out) :: psurfsrc      ! source surface area
143
144      ! local variables
145      INTEGER :: jcs                                           ! loop index
146      INTEGER, DIMENSION(jpi,jpj) :: imsksrc                   ! source mask
147      !!----------------------------------------------------------------------
148      !
149      DO jcs = 1,kncs  ! loop over closed seas
150         !
151         ! 0. build river mouth mask for this lake
152         WHERE ( kmaskcs == jcs )
153            imsksrc = 1
154         ELSE WHERE
155            imsksrc = 0
156         END WHERE
157         !
158         ! 1. compute target area
159         psurfsrc(jcs) = glob_sum('closea', e1e2t(:,:) * imsksrc(:,:) )
160         !
161      END DO  ! jcs
162
163   END SUBROUTINE
164
165   SUBROUTINE get_cstrgsurf(kncs, kmaskcs, kmaskcsgrp, psurftrg, kcsgrp )
166      !!-----------------------------------------------------------------------
167      !!                  ***  routine get_cstrgsurf  ***
168      !!
169      !! ** Purpose : compute closed sea (target) surface area
170      !!----------------------------------------------------------------------
171      ! subroutine parameters
172      ! input
173      INTEGER,                 INTENT(in   ) :: kncs                 ! closed sea number
174      INTEGER, DIMENSION(:,:), INTENT(in   ) :: kmaskcs, kmaskcsgrp  ! closed sea and group mask
175
176      ! output
177      INTEGER , DIMENSION(:)  , INTENT(  out) :: kcsgrp              ! closed sea group number
178      REAL(wp), DIMENSION(:)  , INTENT(  out) :: psurftrg            ! target surface area
179
180      ! local variables
181      INTEGER :: jcs, jtmp                                           ! tmp
182      INTEGER, DIMENSION(jpi,jpj) :: imskgrp, imsksrc, imsktrg, imsk ! tmp group, source, target and tmp mask
183      !!----------------------------------------------------------------------
184      !
185      DO jcs = 1,kncs  ! loop over closed seas
186         !
187         !! 0. find group number for cs number jcs
188         imskgrp = kmaskcsgrp
189         imsksrc = kmaskcs
190         !
191         ! set cs value where cs is defined
192         ! imsk = HUGE outside the cs id jcs
193         imsk = HUGE(1)
194         WHERE ( imsksrc == jcs ) imsk = jcs
195         !
196         ! jtmp = jcs - group id for this lake
197         imsk = imsk - imskgrp
198         jtmp = MINVAL(imsk) ; CALL mpp_min('closea',jtmp)
199         ! kcsgrp = group id corresponding to the cs id jcs
200         ! kcsgrp(jcs)=(jcs - (jcs - group id))=group id
201         kcsgrp(jcs) = jcs - jtmp
202         !
203         !! 1. build the target river mouth mask for this lake
204         WHERE ( imskgrp * mask_opnsea == kcsgrp(jcs) )
205            imsktrg = 1
206         ELSE WHERE
207            imsktrg = 0
208         END WHERE
209         !
210         !! 2. compute target area
211         psurftrg(jcs) = glob_sum('closea', e1e2t(:,:) * imsktrg(:,:) )
212         !
213      END DO ! jcs
214
215   END SUBROUTINE
216
217   SUBROUTINE prt_csctl(kncs, psurfsrc, psurftrg, kcsgrp, cdcstype)
218      !!-----------------------------------------------------------------------
219      !!                  ***  routine prt_csctl  ***
220      !!
221      !! ** Purpose : output information about each closed sea (src id, trg id, src area and trg area)
222      !!----------------------------------------------------------------------
223      ! subroutine parameters
224      INTEGER,               INTENT(in   ) :: kncs                 ! closed sea number               
225      INTEGER, DIMENSION(:), INTENT(in   ) :: kcsgrp               ! closed sea group number
226      !
227      REAL(wp), DIMENSION(:), INTENT(in   ) :: psurfsrc, psurftrg  ! source and target surface area
228      !
229      CHARACTER(256), INTENT(in   ) :: cdcstype  ! closed sea scheme used for redistribution
230      !
231      ! local variable
232      INTEGER :: jcs
233      !!----------------------------------------------------------------------
234      !
235      IF ( lwp .AND. kncs > 0 ) THEN
236         WRITE(numout,*)''
237         !
238         WRITE(numout,*)'Closed sea target ',TRIM(cdcstype),' : '
239         !
240         DO jcs = 1,kncs
241            WRITE(numout,FMT='(3a,i3,a,i3)') ' ',TRIM(cdcstype),' closed sea id is ',jcs,' and trg group id is : ', kcsgrp(jcs)
242            WRITE(numout,FMT='(a,f12.2)'   ) ' src surface areas (km2) : ', psurfsrc(jcs) * 1.0e-6
243            WRITE(numout,FMT='(a,f12.2)'   ) ' trg surface areas (km2) : ', psurftrg(jcs) * 1.0e-6
244         END DO
245         !
246         WRITE(numout,*)''
247      END IF
248
249   END SUBROUTINE
250
251   SUBROUTINE sbc_csupdate(kncs, kcsgrp, kmsk_src, kmsk_grp, psurfsrc, psurftrg, cdcstype, kmsk_opnsea, psurf_opnsea, pwcs, pqcs)
252      !!-----------------------------------------------------------------------
253      !!                  ***  routine sbc_csupdate  ***
254      !!
255      !! ** Purpose : - compute the net freshwater fluxes over each closed seas
256      !!              - apply correction to closed sea source/target net fwf accordingly
257      !!----------------------------------------------------------------------
258      ! subroutine parameters
259      INTEGER,                 INTENT(in) :: kncs                                 ! closed sea id
260      INTEGER, DIMENSION(:  ), INTENT(in) :: kcsgrp                               ! closed sea group id
261      INTEGER, DIMENSION(:,:), INTENT(in) :: kmsk_src, kmsk_grp, kmsk_opnsea      ! source, target, open ocean mask
262     
263      REAL(wp), DIMENSION(:)  , INTENT(in   ) :: psurfsrc, psurftrg, psurf_opnsea ! source, target and open ocean surface area
264      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pwcs, pqcs                       ! water and heat flux correction due to closed seas
265
266      CHARACTER(256), INTENT(in   ) :: cdcstype  ! closed sea scheme used for redistribution
267
268      ! local variables
269      INTEGER :: jcs                                     ! loop index over closed sea
270      INTEGER, DIMENSION(jpi,jpj) :: imsk_src, imsk_trg  ! tmp array source and target closed sea masks
271     
272      REAL(wp) :: zcoef, zcoef1, ztmp ! tmp
273      REAL(wp) :: zcsfwf              ! tmp net fwf over one closed sea
274      REAL(wp) :: zsurftrg            ! tmp target surface area
275      !!----------------------------------------------------------------------
276      !
277      DO jcs = 1, kncs  ! loop over closed seas
278         !
279         !! 0. get mask of the closed sea
280         imsk_src(:,:) = 0
281         WHERE ( kmsk_src(:,:) == jcs ) imsk_src(:,:) = 1
282         !
283         !! 1. Work out net freshwater fluxes over the closed sea from EMP - RNF.
284         !!    (PM: should we consider used delayed glob sum ?)
285         zcsfwf = glob_sum( 'closea', e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * imsk_src(:,:) )
286         !
287         !! 2. Deal with runoff special case (net evaporation spread globally)
288         !!    and compute trg mask
289         IF (cdcstype == 'rnf' .AND. zcsfwf > 0) THEN
290            zsurftrg = psurf_opnsea(1)           ! change the target area surface
291            imsk_trg = kcsgrp(jcs) * kmsk_opnsea ! trg mask is now the open sea mask
292         ELSE
293            zsurftrg = psurftrg(jcs)
294            imsk_trg = kmsk_grp * kmsk_opnsea
295         END IF
296         !
297         !! 3. Add residuals to target points
298         zcoef  = zcsfwf / zsurftrg
299         zcoef1 = rcp * zcoef
300         WHERE( imsk_trg(:,:) == kcsgrp(jcs) )
301            pwcs(:,:) = pwcs(:,:) + zcoef
302            pqcs(:,:) = pqcs(:,:) - zcoef1 * sst_m(:,:)
303         ENDWHERE
304         !
305         !! 4. Subtract residuals from source points
306         zcoef    = zcsfwf / psurfsrc(jcs)
307         zcoef1   = rcp * zcoef
308         WHERE( kmsk_src(:,:) == jcs )
309            pwcs(:,:) = pwcs(:,:) - zcoef
310            pqcs(:,:) = pqcs(:,:) + zcoef1 * sst_m(:,:)
311         ENDWHERE
312         ! WARNING (PM): the correction is done as it was done in the previous version
313         !               this do no conserve heat as there is no reason that
314         !               sum(zcoef1*sst_m) over the source (closed sea) (4) = sum(zcoef1*sst_m) over the target (river mouth) (3)
315         !
316      END DO ! jcs
317
318   END SUBROUTINE
319
320   SUBROUTINE alloc_csarr( klen, pvarsrc, pvartrg, kvargrp )
321      !!-----------------------------------------------------------------------
322      !!                  ***  routine alloc_cssurf  ***
323      !!
324      !! ** Purpose : allocate closed sea surface array
325      !!----------------------------------------------------------------------
326      ! subroutine parameters
327      INTEGER,  INTENT(in) :: klen
328      INTEGER,  ALLOCATABLE, DIMENSION(:), INTENT(  out) :: kvargrp
329      REAL(wp), ALLOCATABLE, DIMENSION(:), INTENT(  out) :: pvarsrc, pvartrg 
330      !
331      ! local variables
332      INTEGER :: ierr
333      !!----------------------------------------------------------------------
334      !
335      ! klen (number of lake) can be zero so use MAX(klen,1) to avoid 0 length array
336      ALLOCATE( pvarsrc(MAX(klen,1)) , pvartrg(MAX(klen,1)) , STAT=ierr )
337      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surf array')
338      !
339      ALLOCATE( kvargrp(MAX(klen,1)) , STAT=ierr )
340      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate group array')
341      !
342      ! initialise to 0
343      pvarsrc(:) = 0.e0_wp
344      pvartrg(:) = 0.e0_wp
345      kvargrp(:) = 0
346   END SUBROUTINE
347
348END MODULE
Note: See TracBrowser for help on using the repository browser.