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.
gitdiff_sbcssr.F90 on Ticket #2071 – Attachment – NEMO

Ticket #2071: gitdiff_sbcssr.F90

File gitdiff_sbcssr.F90, 12.2 KB (added by yruprich, 6 years ago)

git diff between the current and modified sbcssr.F90 routine

Line 
1diff --git a/sources/nemo-3.6/NEMO/OPA_SRC/SBC/sbcssr.F90 b/sources/nemo-3.6/NEMO/OPA_SRC/SBC/sbcssr.F90
2index 90698f891..aabfc16b9 100644
3--- a/sources/nemo-3.6/NEMO/OPA_SRC/SBC/sbcssr.F90
4+++ b/sources/nemo-3.6/NEMO/OPA_SRC/SBC/sbcssr.F90
5@@ -1,14 +1,16 @@
6 MODULE sbcssr
7    !!======================================================================
8    !!                       ***  MODULE  sbcssr  ***
9-   !! Surface module :  heat and fresh water fluxes a restoring term toward observed SST/SSS
10+   !! Surface module :  heat and fresh water flux restoring term toward targeted SST/SSS
11    !!======================================================================
12    !! History :  3.0  !  2006-06  (G. Madec)  Original code
13    !!            3.2  !  2009-04  (B. Lemaire)  Introduce iom_put
14+   !!            3.6  !  2018-02  (Y. Ruprich-Robert) restoring ponderated by sea-ice fraction
15+   !!            3.6  !  2018-02  (Y. Ruprich-Robert) Subregion restoring mask
16    !!----------------------------------------------------------------------
17 
18    !!----------------------------------------------------------------------
19-   !!   sbc_ssr       : add to sbc a restoring term toward SST/SSS climatology
20+   !!   sbc_ssr       : add to sbc a restoring term toward SST/SSS target
21    !!   sbc_ssr_init  : initialisation of surface restoring
22    !!----------------------------------------------------------------------
23    USE oce            ! ocean dynamics and tracers
24@@ -33,10 +35,18 @@ MODULE sbcssr
25 
26    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp   !: evaporation damping   [kg/m2/s]
27    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp   !: heat flux damping        [w/m2]
28+! 02/2018 - Yohan Ruprich-Robert change: subregion restoring mask
29+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sf_msk_f        !: restoring mask
30+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sf_msk_f_init   !: initial restoring mask
31+
32 
33    !                                   !!* Namelist namsbc_ssr *
34-   INTEGER, PUBLIC ::   nn_sstr         ! SST/SSS restoring indicator
35-   INTEGER, PUBLIC ::   nn_sssr         ! SST/SSS restoring indicator
36+   INTEGER, PUBLIC ::   nn_sstr         ! SST restoring indicator
37+   INTEGER, PUBLIC ::   nn_sssr         ! SSS restoring indicator
38+! 02/2018 - Yohan Ruprich-Robert change: surface restoring ponderated by sea-ice fraction
39+   INTEGER, PUBLIC ::   nn_icer         ! SST/SSS restoring indicator where sea-ice
40+! 02/2018 - Yohan Ruprich-Robert change: subregion restoring mask
41+   INTEGER, PUBLIC ::   nn_msk          ! SST/SSS restoring mask 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@@ -45,6 +55,7 @@ MODULE sbcssr
46    REAL(wp) , ALLOCATABLE, DIMENSION(:) ::   buffer   ! Temporary buffer for exchange
47    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sst   ! structure of input SST (file informations, fields read)
48    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sss   ! structure of input SSS (file informations, fields read)
49+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_msk   ! structure of input MASK (file informations, fields read)
50 
51    !! * Substitutions
52 #  include "domzgr_substitute.h90"
53@@ -60,10 +71,10 @@ CONTAINS
54       !!                     ***  ROUTINE sbc_ssr  ***
55       !!
56       !! ** Purpose :   Add to heat and/or freshwater fluxes a damping term
57-      !!                toward observed SST and/or SSS.
58+      !!                toward targeted SST and/or SSS.
59       !!
60       !! ** Method  : - Read namelist namsbc_ssr
61-      !!              - Read observed SST and/or SSS
62+      !!              - Read targeted SST and/or SSS
63       !!              - at each nscb time step
64       !!                   add a retroaction term on qns    (nn_sstr = 1)
65       !!                   add a damping term on sfx        (nn_sssr = 1)
66@@ -79,43 +90,50 @@ CONTAINS
67       INTEGER  ::   ierror   ! return error code
68       !!
69       CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
70-      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
71+      TYPE(FLD_N) ::   sn_sst, sn_sss, sn_msk    ! informations about the fields to be read
72       !!----------------------------------------------------------------------
73-      !
74+      !     
75       IF( nn_timing == 1 )  CALL timing_start('sbc_ssr')
76       !
77       IF( nn_sstr + nn_sssr /= 0 ) THEN
78          !
79+! 02/2018 - Yohan Ruprich-Robert change: modify mask based on surface restoring option where sea-ice
80+         sf_msk_f = sf_msk_f_init      ! initialize mask at time step kt
81+         IF( nn_icer == 0 ) THEN       ! case surface restoring ponderated by sea-ice fraction
82+            sf_msk_f = sf_msk_f(:,:) * ( 1.e0 - fr_i(:,:) )
83+         ENDIF
84+         !
85          IF( nn_sstr == 1)   CALL fld_read( kt, nn_fsbc, sf_sst )   ! Read SST data and provides it at kt
86          IF( nn_sssr >= 1)   CALL fld_read( kt, nn_fsbc, sf_sss )   ! Read SSS data and provides it at kt
87          !
88          !                                         ! ========================= !
89          IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !    Add restoring term     !
90             !                                      ! ========================= !
91-            !
92-            IF( nn_sstr == 1 ) THEN                                   !* Temperature restoring term
93-               DO jj = 1, jpj
94+           IF( nn_sstr == 1 ) THEN                                   !* Temperature restoring term
95+             DO jj = 1, jpj
96                   DO ji = 1, jpi
97-                     zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) )
98+! 02/2018 - Yohan Ruprich-Robert change: subregion restoring mask
99+                     zqrp = sf_msk_f(ji,jj) * 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+            CALL iom_put( "qrp", qrp )
107+
108             !
109             IF( nn_sssr == 1 ) THEN                                   !* Salinity damping term (salt flux only (sfx))
110                zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
111 !CDIR COLLAPSE
112                DO jj = 1, jpj
113                   DO ji = 1, jpi
114-                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
115-                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) 
116-                     sfx(ji,jj) = sfx(ji,jj) + zerp                 ! salt flux
117+! 02/2018 - Yohan Ruprich-Robert change: subregion restoring mask
118+                     zerp = sf_msk_f(ji,jj) * zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
119+                          &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) 
120+                     sfx(ji,jj) = sfx(ji,jj) + zerp                  ! salt flux
121                      erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only)
122                   END DO
123                END DO
124-               CALL iom_put( "erp", erp )                             ! freshwater flux damping
125                !
126             ELSEIF( nn_sssr == 2 ) THEN                               !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
127                zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
128@@ -123,22 +141,23 @@ CONTAINS
129 !CDIR COLLAPSE
130                DO jj = 1, jpj
131                   DO ji = 1, jpi                           
132-                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
133-                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )   &
134-                        &        / MAX(  sss_m(ji,jj), 1.e-20   )
135+! 02/2018 - Yohan Ruprich-Robert change: subregion restoring mask
136+                     zerp = sf_msk_f(ji,jj) * zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
137+                          &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )   &
138+                          &        / MAX(  sss_m(ji,jj), 1.e-20   )
139                      IF( ln_sssr_bnd )   zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
140                      emp(ji,jj) = emp (ji,jj) + zerp
141                      qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
142                      erp(ji,jj) = zerp
143                   END DO
144                END DO
145-               CALL iom_put( "erp", erp )                             ! freshwater flux damping
146             ENDIF
147-            !
148+            CALL iom_put( "erp", erp )                             ! freshwater flux damping
149+
150          ENDIF
151-         !
152+            !
153       ENDIF
154-      !
155+         !
156       IF( nn_timing == 1 )  CALL timing_stop('sbc_ssr')
157       !
158    END SUBROUTINE sbc_ssr
159@@ -159,10 +178,11 @@ CONTAINS
160       REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
161       REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
162       INTEGER  ::   ierror   ! return error code
163+      LOGICAL  ::   llok
164       !!
165       CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
166-      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
167-      NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd
168+      TYPE(FLD_N) ::   sn_sst, sn_sss, sn_msk   ! informations about the fields to be read
169+      NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, nn_icer, nn_msk, rn_dqdt, rn_deds, sn_sst, sn_sss, sn_msk, ln_sssr_bnd, rn_sssr_bnd
170       INTEGER     ::  ios
171       !!----------------------------------------------------------------------
172       !
173@@ -184,6 +204,8 @@ CONTAINS
174          WRITE(numout,*) '      SST restoring term (Yes=1)             nn_sstr     = ', nn_sstr
175          WRITE(numout,*) '      SSS damping term (Yes=1, salt flux)    nn_sssr     = ', nn_sssr
176          WRITE(numout,*) '                       (Yes=2, volume flux) '
177+         WRITE(numout,*) '      restoring where sea-ice (Yes=1)        nn_icer     = ', nn_icer
178+         WRITE(numout,*) '      subregion restoring mask (Yes=1)       nn_msk      = ', nn_msk
179          WRITE(numout,*) '      dQ/dT (restoring magnitude on SST)     rn_dqdt     = ', rn_dqdt, ' W/m2/K'
180          WRITE(numout,*) '      dE/dS (restoring magnitude on SST)     rn_deds     = ', rn_deds, ' mm/day'
181          WRITE(numout,*) '      flag to bound erp term                 ln_sssr_bnd = ', ln_sssr_bnd
182@@ -191,9 +213,29 @@ CONTAINS
183       ENDIF
184       !
185       !                            !* Allocate erp and qrp array
186-      ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )
187+      ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), sf_msk_f_init(jpi,jpj), sf_msk_f(jpi,jpj), STAT=ierror )
188       IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )
189       !
190+! 02/2018 - Yohan Ruprich-Robert change: subregion restoring mask
191+      IF( nn_sstr + nn_sssr /= 0 ) THEN
192+         !
193+         sf_msk_f_init = tmask(:,:,1)
194+         IF (nn_msk == 1) THEN             !* set sf_msk structure & allocate arrays
195+
196+            ALLOCATE( sf_msk(1), STAT=ierror )
197+            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_msk structure' )
198+            ALLOCATE( sf_msk(1)%fnow(jpi,jpj,1), STAT=ierror )
199+            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_msk now array' )
200+            !
201+            ! fill sf_msk with sn_msk and control print
202+            CALL fld_fill( sf_msk, (/ sn_msk /), cn_dir, 'sbc_ssr', 'mask for sea surface restoring', 'namsbc_ssr' )
203+            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_msk data array' )
204+            !
205+            CALL fld_read( 0, nn_fsbc, sf_msk )   ! Read mask
206+            sf_msk_f_init = sf_msk(1)%fnow(:,:,1)
207+         ENDIF
208+      ENDIF
209+
210       IF( nn_sstr == 1 ) THEN      !* set sf_sst structure & allocate arrays
211          !
212          ALLOCATE( sf_sst(1), STAT=ierror )