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 @ 11295

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

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