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.
trcdiasub.F90 in NEMO/branches/CNRS/dev_r6568_Subduction_Diagnostics/NEMOGCM/NEMO/TOP_SRC/TRP – NEMO

source: NEMO/branches/CNRS/dev_r6568_Subduction_Diagnostics/NEMOGCM/NEMO/TOP_SRC/TRP/trcdiasub.F90 @ 10278

Last change on this file since 10278 was 6570, checked in by cetlod, 8 years ago

1st implementation of subduction diag

File size: 12.6 KB
Line 
1MODULE trcdiasub
2   !!======================================================================
3   !!                     ***  MODULE  trcdiasub  ***
4   !! TOP :  computes passive tracer subduction
5   !!=====================================================================
6   !! History :   1.0  !  2006-06  (P. Karleskind)  original code
7   !!              -   !  2011-10  (P. Karleskind)  F90
8   !!----------------------------------------------------------------------
9#if  defined key_top  &&  defined key_diasub
10   !!----------------------------------------------------------------------
11   !!   'key_top'  and  'key_diasub'        TOP model + passive tracer sub
12   !!----------------------------------------------------------------------
13   !!   trc_sub      : computes passive tracer subdcution
14   !!----------------------------------------------------------------------
15   USE oce_trc
16   USE par_trc
17   USE trc
18   USE lib_print
19   USE iom
20   USE diasub
21
22   IMPLICIT NONE
23   PRIVATE
24
25   PUBLIC   trc_dia_sub_adv
26   PUBLIC   trc_dia_sub_adv_eiv
27   PUBLIC   trc_dia_sub_ldf
28   PUBLIC   trc_dia_sub_zdf
29   PUBLIC   trc_dia_sub_alloc
30
31   REAL(wp), PUBLIC, SAVE ,DIMENSION(:,:,:,:), ALLOCATABLE ::   trsub  !: tracer subduction array
32
33   !! * Substitutions
34#  include "top_substitute.h90"
35   !!----------------------------------------------------------------------
36   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
37   !! $Id: trcsub.F90 2715 2011-03-30 15:58:35Z rblod $
38   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
39   !!----------------------------------------------------------------------
40CONTAINS
41
42   INTEGER FUNCTION trc_dia_sub_alloc()
43      !!---------------------------------------------------------------------
44      !
45      ALLOCATE( trsub(jpi,jpj,jptra,jptrsub ), STAT=trc_dia_sub_alloc)
46      !
47      IF( lk_mpp           )   CALL mpp_sum ( trc_dia_sub_alloc )
48      IF( trc_dia_sub_alloc /= 0)   CALL ctl_warn('trc_dia_sub_alloc: failed to allocate arrays.')
49      !
50   END FUNCTION trc_dia_sub_alloc
51
52   SUBROUTINE trc_dia_sub_adv(kt, pun, pvn, pwn ) 
53      !!----------------------------------------------------------------------
54      !!                   ***  ROUTINE trc_sub  ***
55      !!
56      !! ** Purpose :   computes passive tracer subdcution for mld and adv (without eiv)
57      !!
58      !! ** Method  :   
59      !!----------------------------------------------------------------------
60      INTEGER, INTENT(in) ::   kt     ! ocean time-step
61      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) ::   pun, pvn, pwn   ! 3 ocean velocity components
62      !!
63      INTEGER  ::  ji, jj, jn, jk 
64      INTEGER  ::  ikn, ikni, iknj, ikw, iku, ikv, ikb 
65      REAL(wp) ::  zuints, zvints, zhint, ztrsu, ztrsv
66      !!----------------------------------------------------------------------
67
68!     trsub(:,:,:,:)=0.
69
70
71      DO jn = 1,jptra
72
73! Add tracers concentration
74         DO jj = fs_2, jpj
75            DO ji = fs_2, jpi
76               ikn   = nmln(ji,jj)  ;  ikni = nmln(ji-1,jj)  ;  iknj = nmln(ji,jj-1)
77               ikw   = nkind(ji,jj) 
78! W term
79               trsub(ji,jj,jn,jpsub_zad) = -pwn(ji,jj,ikn) * trn(ji,jj,ikw,jn) * tmask(ji,jj,ikw)
80! Adv term
81               DO jk = minku(ji,jj), maxku(ji,jj)
82                   iku  = nindui(ji,jj,jk) 
83                   ztrsu = umask(ji-1,jj,jk)      &
84                   &    * sign( 1, ikni - ikn )  &
85                   &    * pun(ji-1,jj,jk) * trn(iku,jj,jk,jn) * tmask(iku,jj,jk)                     
86                  trsub(ji,jj,jn,jpsub_xad) =  trsub(ji,jj,jn,jpsub_xad) + ztrsu 
87               ENDDO
88               !
89               DO jk = minkv(ji,jj), maxkv(ji,jj)
90                  ikv = nindvj(ji,jj,jk) 
91                  ztrsv = vmask(ji,jj-1,jk)      &
92                   &    * sign( 1, iknj - ikn )  &
93                   &    * pvn(ji,jj-1,jk) * trn(ji,ikv,jk,jn) * tmask(ji,ikv,jk)                     
94                  trsub(ji,jj,jn,jpsub_yad) =  trsub(ji,jj,jn,jpsub_yad) + ztrsv 
95               ENDDO
96               !
97              IF( kt > nit000 ) THEN
98                 ikn = nmln(ji,jj)   ;     ikb = nmlb(ji,jj) 
99                 zhint = 0._wp
100                 IF( ikn /= ikb ) THEN
101                   DO jk = minh(ji,jj), maxh(ji,jj)
102                      zhint = zhint +  gmlh(ji,jj,jk) * trb(ji,jj,jk,jn)
103                   END DO
104                   trsub(ji,jj,jn,jpsub_mld) = -zhint
105                 ENDIF
106             ENDIF
107
108            END DO
109         END DO
110      END DO
111
112      hmlpb(:,:) = hmlp(:,:)
113      nmlb (:,:) = nmln(:,:)
114      !
115   END SUBROUTINE trc_dia_sub_adv
116
117
118   SUBROUTINE trc_dia_sub_adv_eiv( kt, pun, pvn, pwn )
119      !!----------------------------------------------------------------------
120      !!                   ***  ROUTINE trc_dia_sub_adv_eiv  ***
121      !!
122      !! ** Purpose :   computes passive tracer subdcution for adv+eiv
123      !!
124      !! ** Method  :
125      !!----------------------------------------------------------------------
126      INTEGER, INTENT(in) ::   kt     ! ocean time-step
127      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components
128#if defined key_trcldf_eiv
129      !!
130      INTEGER ::   ji, jj, jn, jk
131      INTEGER ::   ikn, ikb, ikni, iknj
132      INTEGER ::   iieiu,iieiv, iieiw
133      REAL(wp) ::  ztrsu, ztrsv
134      INTEGER, POINTER, DIMENSION(:,:)  :: ikindeiu, ikindeiv, ikindeiw
135      !!----------------------------------------------------------------------
136      !
137      IF( kt == nit000 )  THEN
138         IF(lwp) WRITE(numout,*)
139         IF(lwp) WRITE(numout,*) 'trc_dia_sub_adv_eiv : passive tracer subduction for eiv '
140         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ '
141      ENDIF
142      !
143
144  !   trsub(:,:,:,:)=0.
145
146
147      CALL wrk_alloc(jpi,jpj, ikindeiu, ikindeiv, ikindeiw )
148
149      DO jj = fs_2, jpj
150         DO ji = fs_2, jpi
151            ikn  = nmln(ji,jj)  ;  ikni = nmln(ji-1,jj)  ;  iknj = nmln(ji,jj-1)
152            !
153            IF( pwn(ji,jj,ikn) < 0._wp ) THEN     ;  ikindeiw(ji,jj) = ikn - 1
154            ELSE                                  ;  ikindeiw(ji,jj) = ikn
155            ENDIF
156            !
157            DO jk = minku(ji,jj), maxku(ji,jj)
158              IF( pun(ji-1,jj,jk) < 0._wp ) THEN  ;  ikindeiu(ji,jj) = ji
159              ELSE                                ;  ikindeiu(ji,jj) = ji - 1
160              ENDIF
161            ENDDO
162            !
163            DO jk = minkv(ji,jj), maxkv(ji,jj)
164              IF( pvn(ji,jj-1,jk) < 0._wp ) THEN  ;  ikindeiv(ji,jj) = jj
165              ELSE                                ;  ikindeiv(ji,jj) = jj - 1
166             ENDIF
167            ENDDO
168     !
169            END DO
170         END DO
171
172
173      DO jn = 1,jptra
174
175! Add tracers concentration
176         DO jj = fs_2, jpj
177            DO ji = fs_2, jpi
178               ikn   = nmln(ji,jj)  ;  ikni = nmln(ji-1,jj)  ;  iknj = nmln(ji,jj-1)
179               iieiu = ikindeiu(ji,jj) 
180               iieiv = ikindeiv(ji,jj) 
181               iieiw = ikindeiw(ji,jj) 
182! W term
183               trsub(ji,jj,jn,jpsub_zei) = -pwn(ji,jj,ikn) * trn(ji,jj,iieiw,jn) * tmask(ji,jj,ikn)
184! Adv term
185               DO jk = minku(ji,jj), maxku(ji,jj)
186                  ztrsu = umask(ji-1,jj,jk)      &
187                   &    * sign( 1, ikni - ikn )  &
188                   &    * pun(ji-1,jj,jk) * trn(iieiu,jj,jk,jn) * tmask(iieiu,jj,jk)                     
189                  trsub(ji,jj,jn,jpsub_xei) =  trsub(ji,jj,jn,jpsub_xei) + ztrsu 
190               ENDDO
191               !
192               DO jk = minkv(ji,jj), maxkv(ji,jj)
193                  ztrsv = vmask(ji,jj-1,jk)      &
194                   &    * sign( 1, iknj - ikn )  &
195                   &    * pvn(ji,jj-1,jk) * trn(ji,iieiv,jk,jn) * tmask(ji,iieiv,jk)                     
196                  trsub(ji,jj,jn,jpsub_yei) =  trsub(ji,jj,jn,jpsub_yei) + ztrsv 
197               ENDDO
198               !
199            END DO
200         END DO
201      END DO
202      CALL wrk_dealloc(jpi,jpj, ikindeiu, ikindeiv, ikindeiw )
203#endif
204      !
205   END SUBROUTINE trc_dia_sub_adv_eiv
206
207
208   SUBROUTINE trc_dia_sub_ldf( kt, ptru, ptrv, ptrw )
209      !!----------------------------------------------------------------------
210      !!                   ***  ROUTINE trc_dia_sub_ldf  ***
211      !!
212      !! ** Purpose :   computes passive tracer subduction for ldf
213      !!
214      !! ** Method  :
215      !!----------------------------------------------------------------------
216      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index
217      REAL(wp), DIMENSION(jpi,jpj,jpk,jptra), INTENT(in   ) ::   ptru, ptrv, ptrw   ! 3 ocean lateral diffusion trends components
218      !!
219      INTEGER            :: ji, jj, jk, jn
220      INTEGER            :: ikn, ikni, iknj, iknp1
221      !!----------------------------------------------------------------------
222      !
223      IF( kt == nit000 )  THEN
224         IF(lwp) WRITE(numout,*)
225         IF(lwp) WRITE(numout,*) 'trc_dia_sub_ldf : passive tracer subduction for lateral diffusion '
226         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ '
227      ENDIF
228      !
229      DO jn = 1, jptra
230         DO ji = fs_2, jpi
231            DO jj = fs_2, jpj
232               ikn  = nmln(ji,jj)  ;  ikni = nmln(ji-1,jj)  ;  iknj = nmln(ji,jj-1)
233               !
234               DO jk = minku(ji,jj),  maxku(ji,jj)
235                  trsub(ji,jj,jn,jpsub_xlf)  = trsub(ji,jj,jn,jpsub_xlf) &
236                   &                         + umask(ji-1,jj,jk) * SIGN( 1, ikni - ikn ) * ptru(ji-1,jj,jk,jn)
237               END DO
238               !
239               DO jk = minkv(ji,jj), maxkv(ji,jj)
240                   trsub(ji,jj,jn,jpsub_ylf) =  trsub(ji,jj,jn,jpsub_ylf) &
241                    &                        + vmask(ji,jj-1,jk) * SIGN( 1, iknj - ikn ) * ptrv(ji,jj-1,jk,jn)
242               END DO
243            END DO
244         END DO
245         !
246         DO jj = 1, jpj
247            DO ji = 1, jpi
248               iknp1 = nmln(ji,jj) + 1
249               trsub(ji,jj,jn,jpsub_zlf) = ptrw(ji,jj,iknp1,jn)
250            END DO
251         END DO
252      END DO
253      !
254   END SUBROUTINE trc_dia_sub_ldf
255
256   SUBROUTINE trc_dia_sub_zdf( kt, ptrzdf )
257      !!----------------------------------------------------------------------
258      !!                   ***  ROUTINE trc_dia_sub_zdf  ***
259      !!
260      !! ** Purpose :   computes passive tracer subduction for zdf
261      !!
262      !! ** Method  :
263      !!----------------------------------------------------------------------
264      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index
265      REAL(wp), DIMENSION(jpi,jpj,jpk,jptra), INTENT(in) :: ptrzdf   !  ocean vertical diffusion trend
266      INTEGER            :: ji, jj, jk, jn
267      !!----------------------------------------------------------------------
268      !
269      IF( kt == nit000 )  THEN
270         IF(lwp) WRITE(numout,*)
271         IF(lwp) WRITE(numout,*) 'trc_dia_sub_zdf : passive tracer subduction for vertical diffusion '
272         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ '
273      ENDIF
274      !
275      DO jn = 1, jptra
276         DO ji = 2, jpi
277            DO jj = 2, jpj
278               DO jk = 1, nkind(ji,jj)
279                  trsub(ji,jj,jn,jpsub_zdf) = trsub(ji,jj,jn,jpsub_zdf)  &
280                      &                     - fse3t(ji,jj,jk) * e2t(ji,jj) * e1t(ji,jj) * ptrzdf(ji,jj,jk,jn)
281
282               END DO
283            END DO
284         END DO
285      END DO
286      !
287   END SUBROUTINE trc_dia_sub_zdf
288
289#else
290   !!----------------------------------------------------------------------
291   !!   Dummy module                              NO passive tracer Subduction
292   !!----------------------------------------------------------------------
293CONTAINS
294   SUBROUTINE trc_dia_sub_adv( kt, pun, pvn, pwn )              ! Empty routine
295      INTEGER  ::   kt
296      REAL, DIMENSION(:,:,:) ::   pun, pvn, pwn
297      WRITE(*,*) 'trc_dia_sub_adv: You should not have seen this print! error?', kt, pun(1,1,1), pvn(1,1,1), pwn(1,1,1)
298   END SUBROUTINE trc_dia_sub_adv
299
300   SUBROUTINE trc_dia_sub_adv_eiv( kt, pun, pvn, pwn )              ! Empty routine
301      INTEGER  ::   kt
302      REAL, DIMENSION(:,:,:) ::   pun, pvn, pwn
303      WRITE(*,*) 'trc_dia_sub_adv_eiv: You should not have seen this print! error?', kt, pun(1,1,1), pvn(1,1,1), pwn(1,1,1)
304   END SUBROUTINE trc_dia_sub_adv_eiv
305
306   SUBROUTINE trc_dia_sub_ldf( kt,  ptru, ptrv, ptrw )              ! Empty routine
307      REAL, DIMENSION(:,:,:,:) ::   ptru, ptrv, ptrw
308      WRITE(*,*) 'trc_dia_sub_ldf: You should not have seen this print! error?', ptru(1,1,1,1), ptrv(1,1,1,1), ptrw(1,1,1,1)
309   END SUBROUTINE trc_dia_sub_ldf
310
311   SUBROUTINE trc_dia_sub_zdf( kt,  ptrzdf )              ! Empty routine
312      REAL, DIMENSION(:,:,:,:) ::   ptrzdf
313      WRITE(*,*) 'trc_dia_sub_zdf: You should not have seen this print! error?', ptrzdf(1,1,1,1)
314   END SUBROUTINE trc_dia_sub_zdf
315
316#endif
317
318   !!======================================================================
319END MODULE trcdiasub
Note: See TracBrowser for help on using the repository browser.