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.
sbcssr.F90 in branches/2015/dev_r5803_NOC_WAD/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

source: branches/2015/dev_r5803_NOC_WAD/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90 @ 5870

Last change on this file since 5870 was 5870, checked in by acc, 8 years ago

Branch 2015/dev_r5803_NOC_WAD. Merge in trunk changes from 5803 to 5869 in preparation for merge. Also tidied and reorganised some wetting and drying code. Renamed wadlmt.F90 to wetdry.F90. Wetting drying code changes restricted to domzgr.F90, domvvl.F90 nemogcm.F90 sshwzv.F90, dynspg_ts.F90, wetdry.F90 and dynhpg.F90. Code passes full SETTE tests with ln_wd=.false.. Still awaiting test case for checking with ln_wd=.false.
  • Property svn:keywords set to Id
File size: 12.2 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
34   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp   !: evaporation damping   [kg/m2/s]
35   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp   !: heat flux damping        [w/m2]
36
37   !                                   !!* Namelist namsbc_ssr *
38   INTEGER, PUBLIC ::   nn_sstr         ! SST/SSS restoring indicator
39   INTEGER, PUBLIC ::   nn_sssr         ! SST/SSS restoring indicator
40   REAL(wp)        ::   rn_dqdt         ! restoring factor on SST and SSS
41   REAL(wp)        ::   rn_deds         ! restoring factor on SST and SSS
42   LOGICAL         ::   ln_sssr_bnd     ! flag to bound erp term
43   REAL(wp)        ::   rn_sssr_bnd     ! ABS(Max./Min.) value of erp term [mm/day]
44
45   REAL(wp) , ALLOCATABLE, DIMENSION(:) ::   buffer   ! Temporary buffer for exchange
46   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sst   ! structure of input SST (file informations, fields read)
47   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sss   ! structure of input SSS (file informations, fields read)
48
49   !! * Substitutions
50#  include "domzgr_substitute.h90"
51   !!----------------------------------------------------------------------
52   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
53   !! $Id$
54   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
55   !!----------------------------------------------------------------------
56CONTAINS
57
58   SUBROUTINE sbc_ssr( kt )
59      !!---------------------------------------------------------------------
60      !!                     ***  ROUTINE sbc_ssr  ***
61      !!
62      !! ** Purpose :   Add to heat and/or freshwater fluxes a damping term
63      !!                toward observed SST and/or SSS.
64      !!
65      !! ** Method  : - Read namelist namsbc_ssr
66      !!              - Read observed SST and/or SSS
67      !!              - at each nscb time step
68      !!                   add a retroaction term on qns    (nn_sstr = 1)
69      !!                   add a damping term on sfx        (nn_sssr = 1)
70      !!                   add a damping term on emp        (nn_sssr = 2)
71      !!---------------------------------------------------------------------
72      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
73      !!
74      INTEGER  ::   ji, jj   ! dummy loop indices
75      REAL(wp) ::   zerp     ! local scalar for evaporation damping
76      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
77      REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
78      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
79      INTEGER  ::   ierror   ! return error code
80      !!
81      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
82      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
83      !!----------------------------------------------------------------------
84      !
85      IF( nn_timing == 1 )  CALL timing_start('sbc_ssr')
86      !
87      IF( nn_sstr + nn_sssr /= 0 ) THEN
88         !
89         IF( nn_sstr == 1)   CALL fld_read( kt, nn_fsbc, sf_sst )   ! Read SST data and provides it at kt
90         IF( nn_sssr >= 1)   CALL fld_read( kt, nn_fsbc, sf_sss )   ! Read SSS data and provides it at kt
91         !
92         !                                         ! ========================= !
93         IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !    Add restoring term     !
94            !                                      ! ========================= !
95            !
96            IF( nn_sstr == 1 ) THEN                                   !* Temperature restoring term
97               DO jj = 1, jpj
98                  DO ji = 1, jpi
99                     zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) )
100                     qns(ji,jj) = qns(ji,jj) + zqrp
101                     qrp(ji,jj) = zqrp
102                  END DO
103               END DO
104               CALL iom_put( "qrp", qrp )                             ! heat flux damping
105            ENDIF
106            !
107            IF( nn_sssr == 1 ) THEN                                   !* Salinity damping term (salt flux only (sfx))
108               zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
109               DO jj = 1, jpj
110                  DO ji = 1, jpi
111                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
112                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) 
113                     sfx(ji,jj) = sfx(ji,jj) + zerp                 ! salt flux
114                     erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only)
115                  END DO
116               END DO
117               CALL iom_put( "erp", erp )                             ! freshwater flux damping
118               !
119            ELSEIF( nn_sssr == 2 ) THEN                               !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
120               zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
121               zerp_bnd = rn_sssr_bnd / rday                          !       -              -   
122               DO jj = 1, jpj
123                  DO ji = 1, jpi                           
124                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
125                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )   &
126                        &        / MAX(  sss_m(ji,jj), 1.e-20   )
127                     IF( ln_sssr_bnd )   zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
128                     emp(ji,jj) = emp (ji,jj) + zerp
129                     qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
130                     erp(ji,jj) = zerp
131                  END DO
132               END DO
133               CALL iom_put( "erp", erp )                             ! freshwater flux damping
134            ENDIF
135            !
136         ENDIF
137         !
138      ENDIF
139      !
140      IF( nn_timing == 1 )  CALL timing_stop('sbc_ssr')
141      !
142   END SUBROUTINE sbc_ssr
143
144 
145   SUBROUTINE sbc_ssr_init
146      !!---------------------------------------------------------------------
147      !!                  ***  ROUTINE sbc_ssr_init  ***
148      !!
149      !! ** Purpose :   initialisation of surface damping term
150      !!
151      !! ** Method  : - Read namelist namsbc_ssr
152      !!              - Read observed SST and/or SSS if required
153      !!---------------------------------------------------------------------
154      INTEGER  ::   ji, jj   ! dummy loop indices
155      REAL(wp) ::   zerp     ! local scalar for evaporation damping
156      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
157      REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
158      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
159      INTEGER  ::   ierror   ! return error code
160      !!
161      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
162      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
163      NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd
164      INTEGER     ::  ios
165      !!----------------------------------------------------------------------
166      !
167 
168      REWIND( numnam_ref )              ! Namelist namsbc_ssr in reference namelist :
169      READ  ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901)
170901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist', lwp )
171
172      REWIND( numnam_cfg )              ! Namelist namsbc_ssr in configuration namelist :
173      READ  ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 )
174902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist', lwp )
175      IF(lwm) WRITE ( numond, namsbc_ssr )
176
177      IF(lwp) THEN                 !* control print
178         WRITE(numout,*)
179         WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term '
180         WRITE(numout,*) '~~~~~~~ '
181         WRITE(numout,*) '   Namelist namsbc_ssr :'
182         WRITE(numout,*) '      SST restoring term (Yes=1)             nn_sstr     = ', nn_sstr
183         WRITE(numout,*) '      SSS damping term (Yes=1, salt flux)    nn_sssr     = ', nn_sssr
184         WRITE(numout,*) '                       (Yes=2, volume flux) '
185         WRITE(numout,*) '      dQ/dT (restoring magnitude on SST)     rn_dqdt     = ', rn_dqdt, ' W/m2/K'
186         WRITE(numout,*) '      dE/dS (restoring magnitude on SST)     rn_deds     = ', rn_deds, ' mm/day'
187         WRITE(numout,*) '      flag to bound erp term                 ln_sssr_bnd = ', ln_sssr_bnd
188         WRITE(numout,*) '      ABS(Max./Min.) erp threshold           rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day'
189      ENDIF
190      !
191      !                            !* Allocate erp and qrp array
192      ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )
193      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )
194      !
195      IF( nn_sstr == 1 ) THEN      !* set sf_sst structure & allocate arrays
196         !
197         ALLOCATE( sf_sst(1), STAT=ierror )
198         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' )
199         ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror )
200         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' )
201         !
202         ! fill sf_sst with sn_sst and control print
203         CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr' )
204         IF( sf_sst(1)%ln_tint )   ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror )
205         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' )
206         !
207      ENDIF
208      !
209      IF( nn_sssr >= 1 ) THEN      !* set sf_sss structure & allocate arrays
210         !
211         ALLOCATE( sf_sss(1), STAT=ierror )
212         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' )
213         ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror )
214         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' )
215         !
216         ! fill sf_sss with sn_sss and control print
217         CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr' )
218         IF( sf_sss(1)%ln_tint )   ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror )
219         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' )
220         !
221      ENDIF
222      !
223      !                            !* Initialize qrp and erp if no restoring
224      IF( nn_sstr /= 1                   )   qrp(:,:) = 0._wp
225      IF( nn_sssr /= 1 .OR. nn_sssr /= 2 )   erp(:,:) = 0._wp
226      !
227   END SUBROUTINE sbc_ssr_init
228     
229   !!======================================================================
230END MODULE sbcssr
Note: See TracBrowser for help on using the repository browser.