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.
sbcflx_adj.F90 in branches/UKMO/dev_r5518_fa_am_dt_deltadelta_toa/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

source: branches/UKMO/dev_r5518_fa_am_dt_deltadelta_toa/NEMOGCM/NEMO/OPA_SRC/SBC/sbcflx_adj.F90 @ 7169

Last change on this file since 7169 was 7169, checked in by kuniko, 6 years ago

Corrected to only apply delta_toa & delta_delta_toa to heat flux adjusted ocean points

File size: 17.1 KB
Line 
1MODULE sbcflx_adj
2   !!======================================================================
3   !!                       ***  MODULE  sbcflx_adj  ***
4   !! Surface module :  flux adjustment of heat/freshwater. Add qrp/erp obtained from sbcssr
5   !!======================================================================
6   !! History :  0.0  !  2015-10-14  (K. Yamazaki)  Original code
7   !!----------------------------------------------------------------------
8
9   !!----------------------------------------------------------------------
10   !!   sbc_flx_adj       : add qrp/erp to sbc to perform flux adjustment
11   !!   sbc_flx_adj_init  : initialisation of flux adjustment
12   !!----------------------------------------------------------------------
13   USE oce            ! ocean dynamics and tracers
14   USE dom_oce        ! ocean space and time domain
15   USE sbc_oce        ! surface boundary condition
16   USE phycst         ! physical constants
17   USE sbcrnf         ! surface boundary condition : runoffs
18   USE sbc_arcmsk     ! surface boundary condition : runoffs & Arctic mask
19   !
20   USE fldread        ! read input fields
21   USE iom            ! I/O manager
22   USE in_out_manager ! I/O manager
23   USE lib_mpp        ! distribued memory computing library
24   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
25   USE timing         ! Timing
26   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
27
28   IMPLICIT NONE
29   PRIVATE
30
31   PUBLIC   sbc_flx_adj        ! routine called in sbcmod
32   PUBLIC   sbc_flx_adj_init   ! routine called in sbcmod
33
34   !ky 01/11/2016 uncommented below two lines for test
35   !ky 16/10/2016 commented out below two lines
36   !ky 06/09/2016 uncommented below two lines for FA test
37   !ky 11/12/2015 recommented below two lines
38   !!ky 3/12/2015 uncommented below two lines for FA test!
39   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp   !: evaporation damping   [kg/m2/s]
40   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp   !: heat flux damping        [w/m2]
41
42   !                                   !!* Namelist namsbc_flx_adj *
43   INTEGER, PUBLIC ::   nn_flxadjht     ! Heat/freshwater flux adjustment indicator
44   INTEGER, PUBLIC ::   nn_flxadjfw     ! Heat/freshwater flux adjustment indicator
45   LOGICAL         ::   ln_sssr_bnd     ! flag to bound erp term
46   REAL(wp)        ::   rn_sssr_bnd     ! ABS(Max./Min.) value of erp term [mm/day]
47   REAL(wp)        ::   delta_toa       ! global mean annual mean TOA for FA to perturbed ensemble [W/m2]
48   REAL(wp)        ::   delta_delta_toa ! perturbation to delta_toa [W/m2]
49
50   REAL(wp) , ALLOCATABLE, DIMENSION(:) ::   buffer   ! Temporary buffer for exchange
51   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_erp   ! structure of input erp (file informations, fields read)
52   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qrp   ! structure of input qrp (file informations, fields read)
53
54   !! * Substitutions
55#  include "domzgr_substitute.h90"
56   !!----------------------------------------------------------------------
57   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
58   !! $Id$
59   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
60   !!----------------------------------------------------------------------
61CONTAINS
62
63   SUBROUTINE sbc_flx_adj( kt )
64      !!---------------------------------------------------------------------
65      !!                     ***  ROUTINE sbc_flx_adj  ***
66      !!
67      !! ** Purpose :   Add to heat and/or freshwater fluxes a qrp and/or erp
68      !!                to flux adjust temperature/salinity
69      !!
70      !! ** Method  : - Read namelist namsbc_flx_adj
71      !!              - Read calculated qrp and/or erp
72      !!              - at each nscb time step
73      !!                   add qrp on qns    (nn_flxadjht = 1)
74      !!                   add erp on sfx        (nn_flxadjfw = 1)
75      !!                   add erp on emp        (nn_flxadjfw = 2)
76      !!---------------------------------------------------------------------
77      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
78      !!
79      INTEGER  ::   ji, jj   ! dummy loop indices
80      REAL(wp) ::   zerp     ! local scalar for evaporation damping
81      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
82      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
83      INTEGER  ::   ierror   ! return error code
84      !!
85      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
86      TYPE(FLD_N) ::   sn_qrp, sn_erp        ! informations about the fields to be read
87      !!----------------------------------------------------------------------
88      !
89      ! ky 17/10/2016 commented out below two lines
90      !write(numout,*) '*** In sbcflx_adj *** delta_toa, delta_delta_toa=', &
91      !   & delta_toa, delta_delta_toa
92
93      IF( nn_timing == 1 )  CALL timing_start('sbc_flx_adj')
94      !
95      IF( nn_flxadjht + nn_flxadjfw /= 0 ) THEN
96         !
97         IF( nn_flxadjht == 1)   CALL fld_read( kt, nn_fsbc, sf_qrp )   ! Read qrp data and provides it at kt
98         IF( nn_flxadjfw >= 1)   CALL fld_read( kt, nn_fsbc, sf_erp )   ! Read erp data and provides it at kt
99         !
100         !                                         ! ========================= !
101         IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !    Add restoring term     !
102            !                                      ! ========================= !
103            !
104            IF( nn_flxadjht == 1 ) THEN                                   !* Anomalous heat flux term (qrp)
105               DO jj = 1, jpj
106                  DO ji = 1, jpi
107                     ! K.Y. 16/03/2016 Apply Arctic mask to heat flux adjustment
108                     zqrp = ( 1. - 2.*only_arcmsk(ji,jj) )  &
109                        &        * (sf_qrp(1)%fnow(ji,jj,1)  &
110                        &        + delta_toa + delta_delta_toa)
111                     !   &        * sf_qrp(1)%fnow(ji,jj,1)  &
112                     !   &        + delta_toa + delta_delta_toa
113                     ! K.Y. 02/11/2016 recoded two lines above to only add delta_toas to FA regions
114                     ! K.Y. 16/10/2016 added "&" to 2 lines above and
115                     !   delta_toa, delta_delta_toa to above line
116                     !zqrp = sf_qrp(1)%fnow(ji,jj,1)
117                     !ky 07/09/2016 copied 1 line below for FA test
118                     !ky 11/12/2015 commented out 1 line below
119                     !!ky 3/12/2015 1 line below for FA test!
120                     !qrp(ji,jj) = sf_qrp(1)%fnow(ji,jj,1)
121                     !ky 07/09/2016 copied 1 line above and modified as below for FA test
122                     !ky 16/10/2016 commented out 1 line below
123                     !ky 01/11/2016 uncommented 1 line below for test
124                     qrp(ji,jj) = zqrp
125                     qns(ji,jj) = qns(ji,jj) + zqrp
126                  END DO
127               END DO
128               !ky 01/11/2016 uncommented 1 line below for test
129               !ky 16/10/2016 commented out below 1 line below
130               !ky 06/09/2016 uncommented below 1 line below for FA test!
131               !ky 11/12/2015 recommented out below 1 line below
132               !!ky 3/12/2015 uncommented below 1 line below for FA test!
133               CALL iom_put( "qrp", qrp )                             ! heat flux damping
134               !ky 01/11/2016 added 1 line below for test
135               CALL iom_put( "only_arcmsk", only_arcmsk )                             ! arctic mask
136            ENDIF
137            !
138            IF( nn_flxadjfw == 1 ) THEN                               !* Anomalous freshwater term !(salt flux only (sfx))
139!CDIR COLLAPSE
140               DO jj = 1, jpj
141                  !!write(numout,*) 'sf_qrp(1)%fnow(30,',jj,',1)=',sf_qrp(1)%fnow(30,jj,1), &
142                  !!  &            'sf_erp(1)%fnow(30,',jj,',1)=',sf_erp(1)%fnow(30,jj,1), &
143                  !!  &            'sst_m(30,',jj,')=',sst_m(30,jj),'sss_m(30,',jj,')=',sss_m(30,jj)
144                  DO ji = 1, jpi
145                     zerp = ( 1. - 2.*rnfmsk_arcmsk(ji,jj) )  &        ! No damping in vicinity of river mouths
146                        &        * sf_erp(1)%fnow(ji,jj,1)  &
147                        &        * MAX( sss_m(ji,jj), 1.e-20 )! reconverted into salinity flux
148                     !ky 22/07/2016 inserted 1 line above to reflect Dave Storkey's code review
149                     !ky 11/12/2015 recommented out 1 line below
150                     !!ky 3/12/2015 1 line below for FA test!
151                     !erp(ji,jj) = sf_erp(1)%fnow(ji,jj,1)
152                     !ky 01/11/2016 uncommented two lines below for test. erp is freshwater flux.
153                     !ky 16/10/2016 commented out below two lines
154                     !ky 06/09/2016 copied line above and changed to below two lines for FA test!
155                     erp(ji,jj) = ( 1. - 2.*rnfmsk_arcmsk(ji,jj) )  &        ! No damping in vicinity of river mouths
156                        &        * sf_erp(1)%fnow(ji,jj,1) 
157                     sfx(ji,jj) = sfx(ji,jj) + zerp                 ! salt flux
158                  END DO
159               END DO
160               !ky 01/11/2016 uncommented below one line for test
161               !ky 16/10/2016 commented out below one line
162               !ky 06/09/2016 uncommented below one line for FA test!
163               !ky 11/12/2015 recommented out below one line
164               !!ky 3/12/2015 uncommented below one line for FA test!
165               CALL iom_put( "erp", erp )                             ! freshwater flux damping
166               !ky 01/11/2016 added 1 line below for test
167               CALL iom_put( "rnfmsk_arcmsk", rnfmsk_arcmsk )                         ! river mough & arctic
168               !
169            ELSEIF( nn_flxadjfw == 2 ) THEN                               !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
170               zerp_bnd = rn_sssr_bnd / rday                          !       -              -   
171!CDIR COLLAPSE
172               DO jj = 1, jpj
173                  DO ji = 1, jpi                           
174                     zerp = ( 1. - 2.*rnfmsk_arcmsk(ji,jj) )  &        ! No damping in vicinity of river mouths
175                        &        * sf_erp(1)%fnow(ji,jj,1)
176                     IF( ln_sssr_bnd )   zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
177                     !ky 11/12/2015 recommented out 1 line below
178                     !!ky 3/12/2015 1 line below for FA test!
179                     !erp(ji,jj) = sf_erp(1)%fnow(ji,jj,1)
180                     !ky 06/09/2016 copied line above and changed to below line for FA test!
181                     !ky 01/11/2016 uncommented below line for test
182                     !ky 16/10/2016 commented out below line
183                     erp(ji,jj) = zerp
184                     emp(ji,jj) = emp (ji,jj) + zerp
185                     qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
186                  END DO
187               END DO
188               !ky 01/11/2016 uncommented below 1 line for test
189               !ky 16/10/2016 commented out below 1 line
190               !ky 06/09/2016 uncommented below 1 line for FA test!
191               !ky 11/12/2015 recommented out below 1 line
192               !!ky 3/12/2015 uncommented below 1 line for FA test!
193               CALL iom_put( "erp", erp )                             ! freshwater flux damping
194               !ky 01/11/2016 added 1 line below for test
195               CALL iom_put( "rnfmsk_arcmsk", rnfmsk_arcmsk )                         ! river mough & arctic
196            ENDIF
197            !
198         ENDIF
199         !
200      ENDIF
201      !
202      IF( nn_timing == 1 )  CALL timing_stop('sbc_flx_adj')
203      !
204   END SUBROUTINE sbc_flx_adj
205
206 
207   SUBROUTINE sbc_flx_adj_init
208      !!---------------------------------------------------------------------
209      !!                  ***  ROUTINE sbc_flx_adj_init  ***
210      !!
211      !! ** Purpose :   initialisation of surface damping term
212      !!
213      !! ** Method  : - Read namelist namsbc_flx_adj
214      !ky!!!              - Read observed SST and/or SSS if required
215      !!---------------------------------------------------------------------
216      INTEGER  ::   ji, jj   ! dummy loop indices
217      REAL(wp) ::   zerp     ! local scalar for evaporation damping
218      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
219      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
220      INTEGER  ::   ierror   ! return error code
221      !!
222      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
223      TYPE(FLD_N) ::   sn_qrp, sn_erp        ! informations about the fields to be read
224      NAMELIST/namsbc_flx_adj/ cn_dir, nn_flxadjht, nn_flxadjfw, sn_qrp, sn_erp,   &
225         &                     ln_sssr_bnd, rn_sssr_bnd, delta_toa, delta_delta_toa
226      INTEGER     ::  ios
227      !!----------------------------------------------------------------------
228      !
229 
230      !!write(numout,*) '*** in sbcflx_adj_init ***'
231
232      REWIND( numnam_ref )              ! Namelist namsbc_flx_adj in reference namelist :
233      READ  ( numnam_ref, namsbc_flx_adj, IOSTAT = ios, ERR = 901)
234901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx_adj in reference namelist', lwp )
235
236      REWIND( numnam_cfg )              ! Namelist namsbc_flx_adj in configuration namelist :
237      READ  ( numnam_cfg, namsbc_flx_adj, IOSTAT = ios, ERR = 902 )
238902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx_adj in configuration namelist', lwp )
239      IF(lwm) WRITE ( numond, namsbc_flx_adj )
240
241      IF(lwp) THEN                 !* control print
242         WRITE(numout,*)
243         WRITE(numout,*) 'sbc_flx_adj : Heat and/or freshwater flux adjustment term '
244         WRITE(numout,*) '~~~~~~~ '
245         WRITE(numout,*) '   Namelist namsbc_flx_adj :'
246         WRITE(numout,*) '      Anom. heat flux (qrp) term (Yes=1)             nn_flxadjht     = ', nn_flxadjht
247         WRITE(numout,*) '      Anom. fw flux (erp) term (Yes=1, salt flux)    nn_flxadjfw     = ', nn_flxadjfw
248         WRITE(numout,*) '                                           (Yes=2, volume flux) '
249         WRITE(numout,*) '      flag to bound erp term                 ln_sssr_bnd = ', ln_sssr_bnd
250         WRITE(numout,*) '      ABS(Max./Min.) erp threshold           rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day'
251         WRITE(numout,*) '      global mean, annual mean TOA to supplement FA delta_toa = ', delta_toa, ' W/m2'
252         WRITE(numout,*) '      perturbation to delta_toa = ', delta_delta_toa, ' W/m2'
253      ENDIF
254      !
255      !                            !* Allocate erp and qrp array
256      !ky 01/11/2016 uncommented out below two lines for test
257      !ky 16/10/2016 commented out below two lines
258      !ky 06/09/2016 uncommented below two lines for FA test!
259      !ky 11/12/2015 recommented out below two lines
260      !!ky 3/12/2015 uncommented below two lines for FA test!
261      ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )
262      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )
263      !
264      IF( nn_flxadjht == 1 ) THEN      !* set sf_qrp structure & allocate arrays
265         !
266         ALLOCATE( sf_qrp(1), STAT=ierror )
267         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_flx_adj: unable to allocate sf_qrp structure' )
268         ALLOCATE( sf_qrp(1)%fnow(jpi,jpj,1), STAT=ierror )
269         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_flx_adj: unable to allocate sf_qrp now array' )
270         !
271         ! fill sf_qrp with sn_qrp and control print
272         CALL fld_fill( sf_qrp, (/ sn_qrp /), cn_dir, 'sbc_qrp', 'Heat flux adjustment', 'namsbc_flx_adj' )
273         IF( sf_qrp(1)%ln_tint )   ALLOCATE( sf_qrp(1)%fdta(jpi,jpj,1,2), STAT=ierror )
274         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_flx_adj: unable to allocate sf_qrp data array' )
275         !
276      ENDIF
277      !
278      IF( nn_flxadjfw >= 1 ) THEN      !* set sf_erp structure & allocate arrays
279         !
280         ALLOCATE( sf_erp(1), STAT=ierror )
281         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_flx_adj: unable to allocate sf_erp structure' )
282         ALLOCATE( sf_erp(1)%fnow(jpi,jpj,1), STAT=ierror )
283         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_flx_adj: unable to allocate sf_erp now array' )
284         !
285         ! fill sf_erp with sn_erp and control print
286         CALL fld_fill( sf_erp, (/ sn_erp /), cn_dir, 'sbc_erp', 'Freshwater flux adjustment term', 'namsbc_flx_adj' )
287         IF( sf_erp(1)%ln_tint )   ALLOCATE( sf_erp(1)%fdta(jpi,jpj,1,2), STAT=ierror )
288         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_flx_adj: unable to allocate sf_erp data array' )
289         !
290      ENDIF
291      !
292      !ky!!                            !* Initialize qrp and erp if no restoring
293      !ky 01/11/2016 uncommented below two lines for test
294      !ky 16/10/2016 commented out below two lines
295      !ky 06/09/2016 below two lines for FA test!
296      !ky 11/12/2015 commented out below two lines
297      !!ky 3/12/2015 below two lines for FA test!
298      IF( nn_flxadjht /= 1                   )   qrp(:,:) = 0._wp
299      IF( nn_flxadjfw /= 1 .OR. nn_flxadjfw /= 2 )   erp(:,:) = 0._wp
300      !!ky!!IF( nn_sstr /= 1                   )   qrp(:,:) = 0._wp
301      !!ky!!IF( nn_sssr /= 1 .OR. nn_sssr /= 2 )   erp(:,:) = 0._wp
302      !
303   END SUBROUTINE sbc_flx_adj_init
304     
305   !!======================================================================
306END MODULE sbcflx_adj
Note: See TracBrowser for help on using the repository browser.