source: CONFIG/UNIFORM/v6/IPSLCM6/SOURCES/NEMO/sbcssr.F90 @ 5080

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

CM6.0.11 : revert changes for NEMO and add only the changes in sea surface restoring parametrisation
File size: 14.4 KB
Line 
1MODULE sbcssr
2   !!======================================================================
3   !!                       ***  MODULE  sbcssr  ***
4   !! Surface module :  heat and fresh water fluxes a restoring term toward observed SST/SSS
5   !!======================================================================
6   !! History :  3.0  !  2006-06  (G. Madec)  Original code
7   !!            3.2  !  2009-04  (B. Lemaire)  Introduce iom_put
8   !!----------------------------------------------------------------------
9
10   !!----------------------------------------------------------------------
11   !!   sbc_ssr       : add to sbc a restoring term toward SST/SSS climatology
12   !!   sbc_ssr_init  : initialisation of surface restoring
13   !!----------------------------------------------------------------------
14   USE oce            ! ocean dynamics and tracers
15   USE dom_oce        ! ocean space and time domain
16   USE sbc_oce        ! surface boundary condition
17   USE phycst         ! physical constants
18   USE sbcrnf         ! surface boundary condition : runoffs
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_ssr        ! routine called in sbcmod
32   PUBLIC   sbc_ssr_init   ! routine called in sbcmod
33   PUBLIC   sbc_ssr_alloc  ! routine called in sbcmod
34
35   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp       !: evaporation damping   [kg/m2/s]
36   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp       !: heat flux damping        [w/m2]
37   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   coefice   !: under ice relaxation coefficient
38
39   !                                   !!* Namelist namsbc_ssr *
40   INTEGER, PUBLIC ::   nn_sstr         ! SST/SSS restoring indicator
41   INTEGER, PUBLIC ::   nn_sssr         ! SST/SSS restoring indicator
42   REAL(wp)        ::   rn_dqdt         ! restoring factor on SST and SSS
43   REAL(wp)        ::   rn_deds         ! restoring factor on SST and SSS
44   LOGICAL         ::   ln_sssr_bnd     ! flag to bound erp term
45   REAL(wp)        ::   rn_sssr_bnd     ! ABS(Max./Min.) value of erp term [mm/day]
46   LOGICAL         ::   ln_sssd_bnd     ! flag to bound S-S* term
47   REAL(wp)        ::   rn_sssd_bnd     ! ABS(Max./Min.) value of S-S* term [psu]
48   INTEGER         ::   nn_icedmp       ! Control of restoring under ice
49
50   REAL(wp) , ALLOCATABLE, DIMENSION(:) ::   buffer   ! Temporary buffer for exchange
51   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sst   ! structure of input SST (file informations, fields read)
52   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sss   ! structure of input SSS (file informations, fields read)
53
54   !! * Substitutions
55#  include "domzgr_substitute.h90"
56   !!----------------------------------------------------------------------
57   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
58   !! $Id: sbcssr.F90 4990 2014-12-15 16:42:49Z timgraham $
59   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
60   !!----------------------------------------------------------------------
61CONTAINS
62
63   SUBROUTINE sbc_ssr( kt )
64      !!---------------------------------------------------------------------
65      !!                     ***  ROUTINE sbc_ssr  ***
66      !!
67      !! ** Purpose :   Add to heat and/or freshwater fluxes a damping term
68      !!                toward observed SST and/or SSS.
69      !!
70      !! ** Method  : - Read namelist namsbc_ssr
71      !!              - Read observed SST and/or SSS
72      !!              - at each nscb time step
73      !!                   add a retroaction term on qns    (nn_sstr = 1)
74      !!                   add a damping term on sfx        (nn_sssr = 1)
75      !!                   add a damping term on emp        (nn_sssr = 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) ::   zsdif    ! local scalar for salinity difference from climatology
82      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
83      REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
84      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
85      INTEGER  ::   ierror   ! return error code
86      !!
87      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
88      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
89      !!----------------------------------------------------------------------
90      !
91      IF( nn_timing == 1 )  CALL timing_start('sbc_ssr')
92      !
93      IF( nn_sstr + nn_sssr /= 0 ) THEN
94         !
95         IF( nn_sstr == 1)   CALL fld_read( kt, nn_fsbc, sf_sst )   ! Read SST data and provides it at kt
96         IF( nn_sssr >= 1)   CALL fld_read( kt, nn_fsbc, sf_sss )   ! Read SSS data and provides it at kt
97         !
98         !                                         ! ========================= !
99         IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !    Add restoring term     !
100            !                                      ! ========================= !
101            !
102            IF( nn_sstr == 1 ) THEN                                   !* Temperature restoring term
103               DO jj = 1, jpj
104                  DO ji = 1, jpi
105                     zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) )
106                     qns(ji,jj) = qns(ji,jj) + zqrp
107                     qrp(ji,jj) = zqrp
108                  END DO
109               END DO
110            ENDIF
111            !
112            IF( nn_sssr /= 0 .AND. nn_icedmp /= 1 ) THEN
113              ! use fraction of ice ( fr_i ) to adjust relaxation under ice if nn_icedmp .ne. 1
114              ! n.b. coefice is initialised and fixed to 1._wp if nn_icedmp = 1
115               DO jj = 1, jpj
116                  DO ji = 1, jpi
117                     SELECT CASE ( nn_icedmp )
118                       CASE ( 0 )    ;  coefice(ji,jj) = 1._wp - fr_i(ji,jj)              ! no/reduced damping under ice
119                       CASE  DEFAULT ;  coefice(ji,jj) = 1._wp +(nn_icedmp-1)*fr_i(ji,jj) ! reinforced damping (x nn_icedmp) under ice )
120                     END SELECT
121                  END DO
122               END DO
123            ENDIF
124
125            IF( nn_sssr == 1 ) THEN                                   !* Salinity damping term (salt flux only (sfx))
126               zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
127!CDIR COLLAPSE
128               DO jj = 1, jpj
129                  DO ji = 1, jpi
130                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
131                        &        *   coefice(ji,jj)            &      ! Optional control of damping under sea-ice
132                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) 
133                     sfx(ji,jj) = sfx(ji,jj) + zerp                   ! salt flux
134                     erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 )  ! converted into an equivalent volume flux (diagnostic only)
135                  END DO
136               END DO
137               !
138            ELSEIF( nn_sssr == 2 ) THEN                               !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
139               zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
140               zerp_bnd = rn_sssr_bnd / rday                          !       -              -   
141!CDIR COLLAPSE
142               DO jj = 1, jpj
143                  DO ji = 1, jpi                           
144                     zsdif = sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1)   ! Difference between actual and relaxation SSS
145                     IF( ln_sssd_bnd ) zsdif = SIGN( MIN( ABS( zsdif ) , rn_sssd_bnd ) , zsdif )  ! Optional bound on salinity difference
146                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
147                        &        * coefice(ji,jj)              &      ! Optional control of damping under sea-ice
148                        &        * zsdif / MAX( sss_m(ji,jj), 1.e-20 )
149                     IF( ln_sssr_bnd )   zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
150                     emp(ji,jj) = emp (ji,jj) + zerp
151                     qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
152                     erp(ji,jj) = zerp
153                  END DO
154               END DO
155            ENDIF
156            !
157         ENDIF
158         !
159      ENDIF
160      !
161      IF( nn_timing == 1 )  CALL timing_stop('sbc_ssr')
162      !
163   END SUBROUTINE sbc_ssr
164
165 
166   SUBROUTINE sbc_ssr_init
167      !!---------------------------------------------------------------------
168      !!                  ***  ROUTINE sbc_ssr_init  ***
169      !!
170      !! ** Purpose :   initialisation of surface damping term
171      !!
172      !! ** Method  : - Read namelist namsbc_ssr
173      !!              - Read observed SST and/or SSS if required
174      !!---------------------------------------------------------------------
175      INTEGER  ::   ji, jj   ! dummy loop indices
176      INTEGER  ::   ierror   ! return error code
177      !!
178      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
179      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
180      NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd,  &
181                         & ln_sssd_bnd, rn_sssd_bnd, nn_icedmp
182      INTEGER     ::  ios
183      !!----------------------------------------------------------------------
184      !
185 
186      REWIND( numnam_ref )              ! Namelist namsbc_ssr in reference namelist :
187      READ  ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901)
188901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist', lwp )
189
190      REWIND( numnam_cfg )              ! Namelist namsbc_ssr in configuration namelist :
191      READ  ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 )
192902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist', lwp )
193      IF(lwm) WRITE ( numond, namsbc_ssr )
194
195      IF(lwp) THEN                 !* control print
196         WRITE(numout,*)
197         WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term '
198         WRITE(numout,*) '~~~~~~~ '
199         WRITE(numout,*) '   Namelist namsbc_ssr :'
200         WRITE(numout,*) '      SST restoring term (Yes=1)             nn_sstr     = ', nn_sstr
201         WRITE(numout,*) '      SSS damping term (Yes=1, salt flux)    nn_sssr     = ', nn_sssr
202         WRITE(numout,*) '                       (Yes=2, volume flux) '
203         WRITE(numout,*) '      dQ/dT (restoring magnitude on SST)     rn_dqdt     = ', rn_dqdt, ' W/m2/K'
204         WRITE(numout,*) '      dE/dS (restoring magnitude on SST)     rn_deds     = ', rn_deds, ' mm/day'
205         WRITE(numout,*) '      flag to bound erp term                 ln_sssr_bnd = ', ln_sssr_bnd
206         WRITE(numout,*) '      ABS(Max./Min.) erp threshold           rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day'
207         WRITE(numout,*) '      flag to bound  S-S*                    ln_sssd_bnd = ', ln_sssd_bnd
208         WRITE(numout,*) '      ABS(Max./Min.) S-S* threshold          rn_sssd_bnd = ', rn_sssd_bnd, ' psu'
209         WRITE(numout,*) '      Cntrl of surface restoration under ice nn_icedmp   = ', nn_icedmp
210         WRITE(numout,*) '          ( 0 = no restoration under ice)'
211         WRITE(numout,*) '          ( 1 = restoration everywhere  )'
212         WRITE(numout,*) '          (>1 = enhanced restoration under ice  )'
213      ENDIF
214      !
215      IF( nn_sstr == 1 ) THEN      !* set sf_sst structure & allocate arrays
216         !
217         ALLOCATE( sf_sst(1), STAT=ierror )
218         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' )
219         ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror )
220         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' )
221         !
222         ! fill sf_sst with sn_sst and control print
223         CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr' )
224         IF( sf_sst(1)%ln_tint )   ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror )
225         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' )
226         !
227      ENDIF
228      !
229      IF( nn_sssr >= 1 ) THEN      !* set sf_sss structure & allocate arrays
230         !
231         ALLOCATE( sf_sss(1), STAT=ierror )
232         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' )
233         ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror )
234         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' )
235         !
236         ! fill sf_sss with sn_sss and control print
237         CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr' )
238         IF( sf_sss(1)%ln_tint )   ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror )
239         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' )
240         !
241      ENDIF
242      !
243      coefice(:,:) = 1._wp         !  Initialise coefice to 1._wp ; will not need to be changed if nn_icedmp=1
244      !                            !* Initialize qrp and erp if no restoring
245      IF( nn_sstr /= 1                   )   qrp(:,:) = 0._wp
246      IF( nn_sssr /= 1 .OR. nn_sssr /= 2 )   erp(:,:) = 0._wp
247      !
248   END SUBROUTINE sbc_ssr_init
249     
250   INTEGER FUNCTION sbc_ssr_alloc()
251      !!----------------------------------------------------------------------
252      !!               ***  FUNCTION sbc_ssr_alloc  ***
253      !!----------------------------------------------------------------------
254      sbc_ssr_alloc = 0       ! set to zero if no array to be allocated
255      IF( .NOT. ALLOCATED( erp ) ) THEN
256         ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), coefice(jpi,jpj), STAT= sbc_ssr_alloc )
257         !
258         IF( lk_mpp                  )   CALL mpp_sum ( sbc_ssr_alloc )
259         IF( sbc_ssr_alloc /= 0 )   CALL ctl_warn('sbc_ssr_alloc: failed to allocate arrays.')
260         !
261      ENDIF
262   END FUNCTION
263
264   !!======================================================================
265END MODULE sbcssr
Note: See TracBrowser for help on using the repository browser.