source: branches/UKMO/dev_1d_bugfixes_tocommit/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90 @ 13191

Last change on this file since 13191 was 13191, checked in by jwhile, 11 months ago

Updates for 1d runnig

File size: 13.7 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   USE stopack
28   USE wrk_nemo       ! Memory Allocation
29
30   IMPLICIT NONE
31   PRIVATE
32
33   PUBLIC   sbc_ssr        ! routine called in sbcmod
34   PUBLIC   sbc_ssr_init   ! routine called in sbcmod
35
36   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp   !: evaporation damping   [kg/m2/s]
37   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp   !: heat flux damping        [w/m2]
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
47   REAL(wp) , ALLOCATABLE, DIMENSION(:) ::   buffer   ! Temporary buffer for exchange
48   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sst   ! structure of input SST (file informations, fields read)
49   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sss   ! structure of input SSS (file informations, fields read)
50
51   !! * Substitutions
52#  include "domzgr_substitute.h90"
53   !!----------------------------------------------------------------------
54   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
55   !! $Id$
56   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
57   !!----------------------------------------------------------------------
58CONTAINS
59
60   SUBROUTINE sbc_ssr( kt )
61      !!---------------------------------------------------------------------
62      !!                     ***  ROUTINE sbc_ssr  ***
63      !!
64      !! ** Purpose :   Add to heat and/or freshwater fluxes a damping term
65      !!                toward observed SST and/or SSS.
66      !!
67      !! ** Method  : - Read namelist namsbc_ssr
68      !!              - Read observed SST and/or SSS
69      !!              - at each nscb time step
70      !!                   add a retroaction term on qns    (nn_sstr = 1)
71      !!                   add a damping term on sfx        (nn_sssr = 1)
72      !!                   add a damping term on emp        (nn_sssr = 2)
73      !!---------------------------------------------------------------------
74      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
75      !!
76      INTEGER  ::   ji, jj   ! dummy loop indices
77      REAL(wp) ::   zerp     ! local scalar for evaporation damping
78      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
79      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
80      REAL(wp), POINTER, DIMENSION(:,:) :: rn_dqdt_s, zsrp
81      INTEGER  ::   ierror   ! return error code
82      !!
83      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
84      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
85      !!----------------------------------------------------------------------
86      !
87      IF( nn_timing == 1 )  CALL timing_start('sbc_ssr')
88      !
89      IF( nn_sstr + nn_sssr /= 0 ) THEN
90         !
91         IF( nn_sstr == 1)   CALL fld_read( kt, nn_fsbc, sf_sst )   ! Read SST data and provides it at kt
92         IF( nn_sssr >= 1)   CALL fld_read( kt, nn_fsbc, sf_sss )   ! Read SSS data and provides it at kt
93         !
94         !                                         ! ========================= !
95         IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !    Add restoring term     !
96            !                                      ! ========================= !
97            !
98            IF( nn_sstr == 1 ) THEN                                   !* Temperature restoring term
99
100               CALL wrk_alloc( jpi, jpj, rn_dqdt_s )
101               rn_dqdt_s(:,:) = rn_dqdt
102
103#if defined key_traldf_c2d || key_traldf_c3d
104            IF( ln_stopack .AND. nn_spp_dqdt > 0 ) &
105               & CALL spp_gen( kt, rn_dqdt_s, nn_spp_dqdt, rn_dqdt_sd, jk_spp_dqdt )
106#else
107            IF ( ln_stopack .AND. nn_spp_dqdt > 0 ) &
108               & CALL ctl_stop( 'sbc_ssr: parameter perturbation will only work with '// &
109                                'key_traldf_c2d or key_traldf_c3d')
110#endif
111
112               DO jj = 1, jpj
113                  DO ji = 1, jpi
114                     zqrp = rn_dqdt_s(ji,jj) * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) )
115                     qns(ji,jj) = qns(ji,jj) + zqrp
116                     qrp(ji,jj) = zqrp
117                  END DO
118               END DO
119               CALL iom_put( "qrp", qrp )                             ! heat flux damping
120               CALL wrk_dealloc( jpi, jpj, rn_dqdt_s )
121            ENDIF
122            !
123            IF( nn_sssr == 1 ) THEN                                   !* Salinity damping term (salt flux only (sfx))
124               CALL wrk_alloc( jpi, jpj, zsrp)
125               zsrp(:,:) = rn_deds
126#if defined key_traldf_c2d || key_traldf_c3d
127               IF( ln_stopack .AND. nn_spp_dedt > 0 ) &
128                  & CALL spp_gen(kt, zsrp, nn_spp_dedt, rn_dedt_sd, jk_spp_deds )
129#else
130            IF ( ln_stopack .AND. nn_spp_icealb > 0 ) &
131               & CALL ctl_stop( 'sbc_ssr: parameter perturbation will only work with '// &
132                                'key_traldf_c2d or key_traldf_c3d')
133#endif
134
135
136!CDIR COLLAPSE
137               DO jj = 1, jpj
138                  DO ji = 1, jpi
139                     zerp = (zsrp(ji,jj)/rday) * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
140                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )
141                     sfx(ji,jj) = sfx(ji,jj) + zerp                 ! salt flux
142                     erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only)
143                  END DO
144               END DO
145               CALL iom_put( "erp", erp )                             ! freshwater flux damping
146               CALL wrk_dealloc( jpi,jpj, zsrp )
147               !
148            ELSEIF( nn_sssr == 2 ) THEN                               !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
149               CALL wrk_alloc( jpi, jpj, zsrp)
150               zsrp(:,:) = rn_deds
151#if defined key_traldf_c2d || key_traldf_c3d
152               IF( ln_stopack .AND. nn_spp_dedt > 0 ) &
153                  & CALL spp_gen( kt, zsrp, nn_spp_dedt, rn_dedt_sd, jk_spp_deds )
154#else
155               IF ( ln_stopack .AND. nn_spp_dedt > 0 ) &
156                  & CALL ctl_stop( 'sbc_ssr: parameter perturbation will only work with '// &
157                                   'key_traldf_c2d or key_traldf_c3d')
158#endif
159               zerp_bnd = rn_sssr_bnd / rday                          !       -              -
160!CDIR COLLAPSE
161               DO jj = 1, jpj
162                  DO ji = 1, jpi
163                     zerp = (zsrp(ji,jj)/rday) * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
164                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )   &
165                        &        / MAX(  sss_m(ji,jj), 1.e-20   )
166                     IF( ln_sssr_bnd )   zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
167                     emp(ji,jj) = emp (ji,jj) + zerp
168                     qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
169                     erp(ji,jj) = zerp
170                  END DO
171               END DO
172               CALL iom_put( "erp", erp )                             ! freshwater flux damping
173               CALL wrk_dealloc( jpi,jpj,zsrp )
174            ENDIF
175            !
176         ENDIF
177         !
178      ENDIF
179      !
180      IF( nn_timing == 1 )  CALL timing_stop('sbc_ssr')
181      !
182   END SUBROUTINE sbc_ssr
183
184
185   SUBROUTINE sbc_ssr_init
186      !!---------------------------------------------------------------------
187      !!                  ***  ROUTINE sbc_ssr_init  ***
188      !!
189      !! ** Purpose :   initialisation of surface damping term
190      !!
191      !! ** Method  : - Read namelist namsbc_ssr
192      !!              - Read observed SST and/or SSS if required
193      !!---------------------------------------------------------------------
194      INTEGER  ::   ji, jj   ! dummy loop indices
195      REAL(wp) ::   zerp     ! local scalar for evaporation damping
196      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
197      REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
198      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
199      INTEGER  ::   ierror   ! return error code
200      !!
201      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
202      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
203      NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd
204      INTEGER     ::  ios
205      !!----------------------------------------------------------------------
206      !
207
208      REWIND( numnam_ref )              ! Namelist namsbc_ssr in reference namelist :
209      READ  ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901)
210901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist', lwp )
211
212      REWIND( numnam_cfg )              ! Namelist namsbc_ssr in configuration namelist :
213      READ  ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 )
214902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist', lwp )
215      IF(lwm) WRITE ( numond, namsbc_ssr )
216
217      IF(lwp) THEN                 !* control print
218         WRITE(numout,*)
219         WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term '
220         WRITE(numout,*) '~~~~~~~ '
221         WRITE(numout,*) '   Namelist namsbc_ssr :'
222         WRITE(numout,*) '      SST restoring term (Yes=1)             nn_sstr     = ', nn_sstr
223         WRITE(numout,*) '      SSS damping term (Yes=1, salt flux)    nn_sssr     = ', nn_sssr
224         WRITE(numout,*) '                       (Yes=2, volume flux) '
225         WRITE(numout,*) '      dQ/dT (restoring magnitude on SST)     rn_dqdt     = ', rn_dqdt, ' W/m2/K'
226         WRITE(numout,*) '      dE/dS (restoring magnitude on SST)     rn_deds     = ', rn_deds, ' mm/day'
227         WRITE(numout,*) '      flag to bound erp term                 ln_sssr_bnd = ', ln_sssr_bnd
228         WRITE(numout,*) '      ABS(Max./Min.) erp threshold           rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day'
229      ENDIF
230      !
231      !                            !* Allocate erp and qrp array
232      ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )
233      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )
234      !
235      IF( nn_sstr == 1 ) THEN      !* set sf_sst structure & allocate arrays
236         !
237         ALLOCATE( sf_sst(1), STAT=ierror )
238         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' )
239         ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror )
240         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' )
241         !
242         ! fill sf_sst with sn_sst and control print
243         CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr' )
244         IF( sf_sst(1)%ln_tint )   ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror )
245         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' )
246         !
247      ENDIF
248      !
249      IF( nn_sssr >= 1 ) THEN      !* set sf_sss structure & allocate arrays
250         !
251         ALLOCATE( sf_sss(1), STAT=ierror )
252         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' )
253         ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror )
254         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' )
255         !
256         ! fill sf_sss with sn_sss and control print
257         CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr' )
258         IF( sf_sss(1)%ln_tint )   ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror )
259         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' )
260         !
261      ENDIF
262      !
263      !                            !* Initialize qrp and erp if no restoring
264      IF( nn_sstr /= 1                   )   qrp(:,:) = 0._wp
265      IF( nn_sssr /= 1 .OR. nn_sssr /= 2 )   erp(:,:) = 0._wp
266      !
267   END SUBROUTINE sbc_ssr_init
268
269   !!======================================================================
270END MODULE sbcssr
Note: See TracBrowser for help on using the repository browser.