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/dev_r12072_MERGE_OPTION2_2019/src/OCE/SBC – NEMO

source: NEMO/branches/2019/dev_r12072_MERGE_OPTION2_2019/src/OCE/SBC/sbcclo.F90 @ 12173

Last change on this file since 12173 was 12173, checked in by cetlod, 4 years ago

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