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 NEMO/branches/2019/dev_r11470_HPC_12_mpi3/src/OCE/SBC – NEMO

source: NEMO/branches/2019/dev_r11470_HPC_12_mpi3/src/OCE/SBC/sbcssr.F90 @ 11799

Last change on this file since 11799 was 11799, checked in by mocavero, 4 years ago

Update the branch to v4.0.1 of the trunk

  • Property svn:keywords set to Id
File size: 12.1 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 in_out_manager ! I/O manager
22   USE iom            ! I/O manager
23   USE lib_mpp        ! distribued memory computing library
24   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
25   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
26
27   IMPLICIT NONE
28   PRIVATE
29
30   PUBLIC   sbc_ssr        ! routine called in sbcmod
31   PUBLIC   sbc_ssr_init   ! routine called in sbcmod
32
33   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp   !: evaporation damping   [kg/m2/s]
34   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp   !: heat flux damping        [w/m2]
35
36   !                                   !!* Namelist namsbc_ssr *
37   INTEGER, PUBLIC ::   nn_sstr         ! SST/SSS restoring indicator
38   INTEGER, PUBLIC ::   nn_sssr         ! SST/SSS restoring indicator
39   REAL(wp)        ::   rn_dqdt         ! restoring factor on SST and SSS
40   REAL(wp)        ::   rn_deds         ! restoring factor on SST and SSS
41   LOGICAL         ::   ln_sssr_bnd     ! flag to bound erp term
42   REAL(wp)        ::   rn_sssr_bnd     ! ABS(Max./Min.) value of erp term [mm/day]
43
44   REAL(wp) , ALLOCATABLE, DIMENSION(:) ::   buffer   ! Temporary buffer for exchange
45   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sst   ! structure of input SST (file informations, fields read)
46   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sss   ! structure of input SSS (file informations, fields read)
47
48   !!----------------------------------------------------------------------
49   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
50   !! $Id$
51   !! Software governed by the CeCILL license (see ./LICENSE)
52   !!----------------------------------------------------------------------
53CONTAINS
54
55   SUBROUTINE sbc_ssr( kt )
56      !!---------------------------------------------------------------------
57      !!                     ***  ROUTINE sbc_ssr  ***
58      !!
59      !! ** Purpose :   Add to heat and/or freshwater fluxes a damping term
60      !!                toward observed SST and/or SSS.
61      !!
62      !! ** Method  : - Read namelist namsbc_ssr
63      !!              - Read observed SST and/or SSS
64      !!              - at each nscb time step
65      !!                   add a retroaction term on qns    (nn_sstr = 1)
66      !!                   add a damping term on sfx        (nn_sssr = 1)
67      !!                   add a damping term on emp        (nn_sssr = 2)
68      !!---------------------------------------------------------------------
69      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
70      !!
71      INTEGER  ::   ji, jj   ! dummy loop indices
72      REAL(wp) ::   zerp     ! local scalar for evaporation damping
73      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
74      REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
75      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
76      INTEGER  ::   ierror   ! return error code
77      !!
78      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
79      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
80      !!----------------------------------------------------------------------
81      !
82      IF( nn_sstr + nn_sssr /= 0 ) THEN
83         !
84         IF( nn_sstr == 1)   CALL fld_read( kt, nn_fsbc, sf_sst )   ! Read SST data and provides it at kt
85         IF( nn_sssr >= 1)   CALL fld_read( kt, nn_fsbc, sf_sss )   ! Read SSS data and provides it at kt
86         !
87         !                                         ! ========================= !
88         IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !    Add restoring term     !
89            !                                      ! ========================= !
90            !
91            IF( nn_sstr == 1 ) THEN                                   !* Temperature restoring term
92               DO jj = 1, jpj
93                  DO ji = 1, jpi
94                     zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1)
95                     qns(ji,jj) = qns(ji,jj) + zqrp
96                     qrp(ji,jj) = zqrp
97                  END DO
98               END DO
99               CALL iom_put( "qrp", qrp )                             ! heat flux damping
100            ENDIF
101            !
102            IF( nn_sssr == 1 ) THEN                                   !* Salinity damping term (salt flux only (sfx))
103               zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
104               DO jj = 1, jpj
105                  DO ji = 1, jpi
106                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
107                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1)
108                     sfx(ji,jj) = sfx(ji,jj) + zerp                 ! salt flux
109                     erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only)
110                  END DO
111               END DO
112               CALL iom_put( "erp", erp )                             ! freshwater flux damping
113               !
114            ELSEIF( nn_sssr == 2 ) THEN                               !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
115               zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
116               zerp_bnd = rn_sssr_bnd / rday                          !       -              -   
117               DO jj = 1, jpj
118                  DO ji = 1, jpi                           
119                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
120                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )   &
121                        &        / MAX(  sss_m(ji,jj), 1.e-20   ) * tmask(ji,jj,1)
122                     IF( ln_sssr_bnd )   zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
123                     emp(ji,jj) = emp (ji,jj) + zerp
124                     qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
125                     erp(ji,jj) = zerp
126                  END DO
127               END DO
128               CALL iom_put( "erp", erp )                             ! freshwater flux damping
129            ENDIF
130            !
131         ENDIF
132         !
133      ENDIF
134      !
135   END SUBROUTINE sbc_ssr
136
137 
138   SUBROUTINE sbc_ssr_init
139      !!---------------------------------------------------------------------
140      !!                  ***  ROUTINE sbc_ssr_init  ***
141      !!
142      !! ** Purpose :   initialisation of surface damping term
143      !!
144      !! ** Method  : - Read namelist namsbc_ssr
145      !!              - Read observed SST and/or SSS if required
146      !!---------------------------------------------------------------------
147      INTEGER  ::   ji, jj   ! dummy loop indices
148      REAL(wp) ::   zerp     ! local scalar for evaporation damping
149      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
150      REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
151      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
152      INTEGER  ::   ierror   ! return error code
153      !!
154      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
155      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
156      NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd
157      INTEGER     ::  ios
158      !!----------------------------------------------------------------------
159      !
160      IF(lwp) THEN
161         WRITE(numout,*)
162         WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term '
163         WRITE(numout,*) '~~~~~~~ '
164      ENDIF
165      !
166      REWIND( numnam_ref )              ! Namelist namsbc_ssr in reference namelist :
167      READ  ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901)
168901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' )
169
170      REWIND( numnam_cfg )              ! Namelist namsbc_ssr in configuration namelist :
171      READ  ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 )
172902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist' )
173      IF(lwm) WRITE ( numond, namsbc_ssr )
174
175      IF(lwp) THEN                 !* control print
176         WRITE(numout,*) '   Namelist namsbc_ssr :'
177         WRITE(numout,*) '      SST restoring term (Yes=1)             nn_sstr        = ', nn_sstr
178         WRITE(numout,*) '         dQ/dT (restoring magnitude on SST)     rn_dqdt     = ', rn_dqdt, ' W/m2/K'
179         WRITE(numout,*) '      SSS damping term (Yes=1, salt   flux)  nn_sssr        = ', nn_sssr
180         WRITE(numout,*) '                       (Yes=2, volume flux) '
181         WRITE(numout,*) '         dE/dS (restoring magnitude on SST)     rn_deds     = ', rn_deds, ' mm/day'
182         WRITE(numout,*) '         flag to bound erp term                 ln_sssr_bnd = ', ln_sssr_bnd
183         WRITE(numout,*) '         ABS(Max./Min.) erp threshold           rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day'
184      ENDIF
185      !
186      !                            !* Allocate erp and qrp array
187      ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )
188      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )
189      !
190      IF( nn_sstr == 1 ) THEN      !* set sf_sst structure & allocate arrays
191         !
192         ALLOCATE( sf_sst(1), STAT=ierror )
193         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' )
194         ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror )
195         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' )
196         !
197         ! fill sf_sst with sn_sst and control print
198         CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr', no_print )
199         IF( sf_sst(1)%ln_tint )   ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror )
200         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' )
201         !
202      ENDIF
203      !
204      IF( nn_sssr >= 1 ) THEN      !* set sf_sss structure & allocate arrays
205         !
206         ALLOCATE( sf_sss(1), STAT=ierror )
207         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' )
208         ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror )
209         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' )
210         !
211         ! fill sf_sss with sn_sss and control print
212         CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr', no_print )
213         IF( sf_sss(1)%ln_tint )   ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror )
214         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' )
215         !
216      ENDIF
217      !
218      !                            !* Initialize qrp and erp if no restoring
219      IF( nn_sstr /= 1                   )   qrp(:,:) = 0._wp
220      IF( nn_sssr /= 1 .OR. nn_sssr /= 2 )   erp(:,:) = 0._wp
221      !
222   END SUBROUTINE sbc_ssr_init
223     
224   !!======================================================================
225END MODULE sbcssr
Note: See TracBrowser for help on using the repository browser.