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.
diaptr.F90 in NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA – NEMO

source: NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diaptr.F90 @ 13571

Last change on this file since 13571 was 13571, checked in by mocavero, 3 years ago

Align branch with trunk

  • Property svn:keywords set to Id
File size: 27.5 KB
Line 
1MODULE diaptr
2   !!======================================================================
3   !!                       ***  MODULE  diaptr  ***
4   !! Ocean physics:  Computes meridonal transports and zonal means
5   !!=====================================================================
6   !! History :  1.0  ! 2003-09  (C. Talandier, G. Madec)  Original code
7   !!            2.0  ! 2006-01  (A. Biastoch)  Allow sub-basins computation
8   !!            3.2  ! 2010-03  (O. Marti, S. Flavoni) Add fields
9   !!            3.3  ! 2010-10  (G. Madec)  dynamical allocation
10   !!            3.6  ! 2014-12  (C. Ethe) use of IOM
11   !!            3.6  ! 2016-06  (T. Graham) Addition of diagnostics for CMIP6
12   !!            4.0  ! 2010-08  ( C. Ethe, J. Deshayes ) Improvment
13   !!----------------------------------------------------------------------
14
15   !!----------------------------------------------------------------------
16   !!   dia_ptr      : Poleward Transport Diagnostics module
17   !!   dia_ptr_init : Initialization, namelist read
18   !!   ptr_sjk      : "zonal" mean computation of a field - tracer or flux array
19   !!   ptr_sj       : "zonal" and vertical sum computation of a "meridional" flux array
20   !!                   (Generic interface to ptr_sj_3d, ptr_sj_2d)
21   !!----------------------------------------------------------------------
22   USE oce              ! ocean dynamics and active tracers
23   USE dom_oce          ! ocean space and time domain
24   USE phycst           ! physical constants
25   !
26   USE iom              ! IOM library
27   USE in_out_manager   ! I/O manager
28   USE lib_mpp          ! MPP library
29   USE timing           ! preformance summary
30
31   IMPLICIT NONE
32   PRIVATE
33
34   INTERFACE ptr_sj
35      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d
36   END INTERFACE
37
38   PUBLIC   dia_ptr        ! call in step module
39   PUBLIC   dia_ptr_hst    ! called from tra_ldf/tra_adv routines
40
41   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hstr_adv, hstr_ldf, hstr_eiv   !: Heat/Salt TRansports(adv, diff, Bolus.)
42   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hstr_ove, hstr_btr, hstr_vtr   !: heat Salt TRansports(overturn, baro, merional)
43
44   LOGICAL, PUBLIC ::   l_diaptr       !: tracers  trend flag
45
46   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup
47   REAL(wp) ::   rc_pwatt = 1.e-15_wp  ! conversion from W    to PW (further x rho0 x Cp)
48   REAL(wp) ::   rc_ggram = 1.e-9_wp   ! conversion from g    to Gg  (further x rho0)
49
50   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk   ! T-point basin interior masks
51   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S)
52
53   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)   :: p_fval1d
54   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d
55
56   LOGICAL ::   ll_init = .TRUE.        !: tracers  trend flag
57   
58   !! * Substitutions
59#  include "do_loop_substitute.h90"
60#  include "domzgr_substitute.h90"
61   !!----------------------------------------------------------------------
62   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
63   !! $Id$
64   !! Software governed by the CeCILL license (see ./LICENSE)
65   !!----------------------------------------------------------------------
66CONTAINS
67
68   SUBROUTINE dia_ptr( kt, Kmm, pvtr )
69      !!----------------------------------------------------------------------
70      !!                  ***  ROUTINE dia_ptr  ***
71      !!----------------------------------------------------------------------
72      INTEGER                         , INTENT(in)           ::   kt     ! ocean time-step index     
73      INTEGER                         , INTENT(in)           ::   Kmm    ! time level index
74      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport
75      !
76      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
77      REAL(wp) ::   zsfc,zvfc               ! local scalar
78      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace
79      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace
80      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d    ! 3D workspace
81      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace
82      REAL(wp), DIMENSION(jpj)      ::  zvsum, ztsum, zssum   ! 1D workspace
83      !
84      !overturning calculation
85      REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE ::   sjk, r1_sjk, v_msf  ! i-mean i-k-surface and its inverse
86      REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE ::   zt_jk, zs_jk        ! i-mean T and S, j-Stream-Function
87
88      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   z4d1, z4d2
89      REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE ::   z3dtr
90      !!----------------------------------------------------------------------
91      !
92      IF( ln_timing )   CALL timing_start('dia_ptr')
93
94      IF( kt == nit000 .AND. ll_init )   CALL dia_ptr_init   ! -> will define l_diaptr and nbasin
95      !
96      IF( .NOT. l_diaptr ) THEN
97         IF( ln_timing ) CALL timing_stop('dia_ptr')
98         RETURN
99      ENDIF
100      !
101      ALLOCATE( z3dtr(jpi,jpj,nbasin) )
102      !
103      IF( PRESENT( pvtr ) ) THEN
104         IF( iom_use( 'zomsf' ) ) THEN    ! effective MSF
105            ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) )
106            DO jn = 1, nbasin                                    ! by sub-basins
107               z4d1(1,:,:,jn) =  ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )  ! zonal cumulative effective transport excluding closed seas
108               DO jk = jpkm1, 1, -1 
109                  z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn)    ! effective j-Stream-Function (MSF)
110               END DO
111               DO ji = 1, jpi
112                  z4d1(ji,:,:,jn) = z4d1(1,:,:,jn)
113               ENDDO
114            END DO
115            CALL iom_put( 'zomsf', z4d1 * rc_sv )
116            DEALLOCATE( z4d1 )
117         ENDIF
118         IF(  iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.   &
119            & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN
120            ! define fields multiplied by scalar
121            zmask(:,:,:) = 0._wp
122            zts(:,:,:,:) = 0._wp
123            DO_3D( 1, 0, 1, 1, 1, jpkm1 )
124               zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)
125               zmask(ji,jj,jk)      = vmask(ji,jj,jk)      * zvfc
126               zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc  !Tracers averaged onto V grid
127               zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc
128            END_3D
129         ENDIF
130         IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN
131            DO jn = 1, nbasin
132               ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin),   &
133                  &                          zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) )
134               sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
135               r1_sjk(:,:,jn) = 0._wp
136               WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
137               ! i-mean T and S, j-Stream-Function, basin
138               zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
139               zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
140               v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 
141               hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 )
142               hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 )
143               DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk )
144               !
145            ENDDO
146            DO jn = 1, nbasin
147               z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW)
148               DO ji = 1, jpi
149                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
150               ENDDO
151            ENDDO
152            CALL iom_put( 'sophtove', z3dtr )
153            DO jn = 1, nbasin
154               z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram !  (conversion in Gg)
155               DO ji = 1, jpi
156                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
157               ENDDO
158            ENDDO
159            CALL iom_put( 'sopstove', z3dtr )
160         ENDIF
161
162         IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN
163            ! Calculate barotropic heat and salt transport here
164            DO jn = 1, nbasin
165               ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) )
166               sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) )
167               r1_sjk(:,1,jn) = 0._wp
168               WHERE( sjk(:,1,jn) /= 0._wp )   r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn)
169               !
170               zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) )
171               ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) )
172               zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) )
173               hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn)
174               hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn)
175               DEALLOCATE( sjk, r1_sjk )
176               !
177            ENDDO
178            DO jn = 1, nbasin
179               z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW)
180               DO ji = 1, jpi
181                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
182               ENDDO
183            ENDDO
184            CALL iom_put( 'sophtbtr', z3dtr )
185            DO jn = 1, nbasin
186               z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram !  (conversion in Gg)
187               DO ji = 1, jpi
188                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
189               ENDDO
190            ENDDO
191            CALL iom_put( 'sopstbtr', z3dtr )
192         ENDIF 
193         !
194      ELSE
195         !
196         zmask(:,:,:) = 0._wp
197         zts(:,:,:,:) = 0._wp
198         IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' )  ) THEN    ! i-mean i-k-surface
199            ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) )
200            DO_3D( 1, 1, 1, 1, 1, jpkm1 )
201               zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm)
202               zmask(ji,jj,jk)      = tmask(ji,jj,jk)      * zsfc
203               zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc
204               zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc
205            END_3D
206            !
207            DO jn = 1, nbasin
208               zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
209               DO ji = 1, jpi
210                  zmask(ji,:,:) = zmask(1,:,:)
211               ENDDO
212               z4d1(:,:,:,jn) = zmask(:,:,:)
213            ENDDO
214            CALL iom_put( 'zosrf', z4d1 )
215            !
216            DO jn = 1, nbasin
217               z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
218                  &            / MAX( z4d1(1,:,:,jn), 10.e-15 )
219               DO ji = 1, jpi
220                  z4d2(ji,:,:,jn) = z4d2(1,:,:,jn)
221               ENDDO
222            ENDDO
223            CALL iom_put( 'zotem', z4d2 )
224            !
225            DO jn = 1, nbasin
226               z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
227                  &            / MAX( z4d1(1,:,:,jn), 10.e-15 )
228               DO ji = 1, jpi
229                  z4d2(ji,:,:,jn) = z4d2(1,:,:,jn)
230               ENDDO
231            ENDDO
232            CALL iom_put( 'zosal', z4d2 )
233            DEALLOCATE( z4d1, z4d2 )
234            !
235         ENDIF
236         !
237         !                                ! Advective and diffusive heat and salt transport
238         IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 
239            !
240            DO jn = 1, nbasin
241               z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW)
242               DO ji = 1, jpi
243                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
244               ENDDO
245            ENDDO
246            CALL iom_put( 'sophtadv', z3dtr )
247            DO jn = 1, nbasin
248               z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram !  (conversion in Gg)
249               DO ji = 1, jpi
250                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
251               ENDDO
252            ENDDO
253            CALL iom_put( 'sopstadv', z3dtr )
254         ENDIF
255         !
256         IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 
257            !
258            DO jn = 1, nbasin
259               z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW)
260               DO ji = 1, jpi
261                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
262               ENDDO
263            ENDDO
264            CALL iom_put( 'sophtldf', z3dtr )
265            DO jn = 1, nbasin
266               z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram !  (conversion in Gg)
267               DO ji = 1, jpi
268                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
269               ENDDO
270            ENDDO
271            CALL iom_put( 'sopstldf', z3dtr )
272         ENDIF
273         !
274         IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 
275            !
276            DO jn = 1, nbasin
277               z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW)
278               DO ji = 1, jpi
279                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
280               ENDDO
281            ENDDO
282            CALL iom_put( 'sophteiv', z3dtr )
283            DO jn = 1, nbasin
284               z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram !  (conversion in Gg)
285               DO ji = 1, jpi
286                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
287               ENDDO
288            ENDDO
289            CALL iom_put( 'sopsteiv', z3dtr )
290         ENDIF
291         !
292         IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN
293            zts(:,:,:,:) = 0._wp
294            DO_3D( 1, 0, 1, 1, 1, jpkm1 )
295               zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)
296               zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc  !Tracers averaged onto V grid
297               zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc
298            END_3D
299             CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) )
300             CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) )
301             DO jn = 1, nbasin
302                z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW)
303                DO ji = 1, jpi
304                   z3dtr(ji,:,jn) = z3dtr(1,:,jn)
305                ENDDO
306             ENDDO
307             CALL iom_put( 'sophtvtr', z3dtr )
308             DO jn = 1, nbasin
309               z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram !  (conversion in Gg)
310               DO ji = 1, jpi
311                  z3dtr(ji,:,jn) = z3dtr(1,:,jn)
312               ENDDO
313            ENDDO
314            CALL iom_put( 'sopstvtr', z3dtr )
315         ENDIF
316         !
317         IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN
318            CALL iom_get_var(  'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml
319            z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 
320            CALL iom_put( 'uocetr_vsum_cumul', z2d )
321         ENDIF
322         !
323      ENDIF
324      !
325      DEALLOCATE( z3dtr )
326      !
327      IF( ln_timing )   CALL timing_stop('dia_ptr')
328      !
329   END SUBROUTINE dia_ptr
330
331
332   SUBROUTINE dia_ptr_init
333      !!----------------------------------------------------------------------
334      !!                  ***  ROUTINE dia_ptr_init  ***
335      !!                   
336      !! ** Purpose :   Initialization
337      !!----------------------------------------------------------------------
338      INTEGER ::  inum, jn           ! local integers
339      !!
340      REAL(wp), DIMENSION(jpi,jpj) :: zmsk
341      !!----------------------------------------------------------------------
342     
343      ! l_diaptr is defined with iom_use
344      !   --> dia_ptr_init must be done after the call to iom_init
345      !   --> cannot be .TRUE. without cpp key: key_iom -->  nbasin define by iom_init is initialized
346      l_diaptr = iom_use( 'zomsf'    ) .OR. iom_use( 'zotem'    ) .OR. iom_use( 'zosal'    ) .OR.  &
347         &       iom_use( 'zosrf'    ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.  &
348         &       iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR.  &
349         &       iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR.  & 
350         &       iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR.  &
351         &       iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 
352 
353      IF(lwp) THEN                     ! Control print
354         WRITE(numout,*)
355         WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
356         WRITE(numout,*) '~~~~~~~~~~~~'
357         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      l_diaptr  = ', l_diaptr
358      ENDIF
359
360      IF( l_diaptr ) THEN 
361         !
362         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
363         !
364         rc_pwatt = rc_pwatt * rho0_rcp          ! conversion from K.s-1 to PetaWatt
365         rc_ggram = rc_ggram * rho0              ! conversion from m3/s to Gg/s
366
367         IF( lk_mpp )   CALL mpp_ini_znl( numout )     ! Define MPI communicator for zonal sum
368
369         btmsk(:,:,1) = tmask_i(:,:)                 
370         IF( nbasin == 5 ) THEN   ! nbasin has been initialized in iom_init to define the axis "basin"
371            CALL iom_open( 'subbasins', inum )
372            CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin
373            CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin
374            CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) )   ! Indian   basin
375            CALL iom_close( inum )
376            btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )            ! Indo-Pacific basin
377         ENDIF
378         DO jn = 2, nbasin
379            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)                 ! interior domain only
380         END DO
381         ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations
382         WHERE( gphit(:,:)*tmask_i(:,:) < -34._wp)
383           zmsk(:,:) = 0._wp      ! mask out Southern Ocean
384         ELSE WHERE                 
385           zmsk(:,:) = ssmask(:,:)
386         END WHERE
387         btmsk34(:,:,1) = btmsk(:,:,1)                 
388         DO jn = 2, nbasin
389            btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:)                  ! interior domain only
390         ENDDO
391
392         ! Initialise arrays to zero because diatpr is called before they are first calculated
393         ! Note that this means diagnostics will not be exactly correct when model run is restarted.
394         hstr_adv(:,:,:) = 0._wp           
395         hstr_ldf(:,:,:) = 0._wp           
396         hstr_eiv(:,:,:) = 0._wp           
397         hstr_ove(:,:,:) = 0._wp           
398         hstr_btr(:,:,:) = 0._wp           !
399         hstr_vtr(:,:,:) = 0._wp           !
400         !
401         ll_init = .FALSE.
402         !
403      ENDIF 
404      !
405   END SUBROUTINE dia_ptr_init
406
407
408   SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx ) 
409      !!----------------------------------------------------------------------
410      !!                    ***  ROUTINE dia_ptr_hst ***
411      !!----------------------------------------------------------------------
412      !! Wrapper for heat and salt transport calculations to calculate them for each basin
413      !! Called from all advection and/or diffusion routines
414      !!----------------------------------------------------------------------
415      INTEGER                         , INTENT(in )  :: ktra  ! tracer index
416      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf'/'eiv'
417      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pvflx   ! 3D input array of advection/diffusion
418      INTEGER                                        :: jn    !
419
420      !
421      IF( cptr == 'adv' ) THEN
422         IF( ktra == jp_tem )  THEN
423             DO jn = 1, nbasin
424                hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
425             ENDDO
426         ENDIF
427         IF( ktra == jp_sal )  THEN
428             DO jn = 1, nbasin
429                hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
430             ENDDO
431         ENDIF
432      ENDIF
433      !
434      IF( cptr == 'ldf' ) THEN
435         IF( ktra == jp_tem )  THEN
436             DO jn = 1, nbasin
437                hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
438             ENDDO
439         ENDIF
440         IF( ktra == jp_sal )  THEN
441             DO jn = 1, nbasin
442                hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
443             ENDDO
444         ENDIF
445      ENDIF
446      !
447      IF( cptr == 'eiv' ) THEN
448         IF( ktra == jp_tem )  THEN
449             DO jn = 1, nbasin
450                hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
451             ENDDO
452         ENDIF
453         IF( ktra == jp_sal )  THEN
454             DO jn = 1, nbasin
455                hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
456             ENDDO
457         ENDIF
458      ENDIF
459      !
460      IF( cptr == 'vtr' ) THEN
461         IF( ktra == jp_tem )  THEN
462             DO jn = 1, nbasin
463                hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
464             ENDDO
465         ENDIF
466         IF( ktra == jp_sal )  THEN
467             DO jn = 1, nbasin
468                hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
469             ENDDO
470         ENDIF
471      ENDIF
472      !
473   END SUBROUTINE dia_ptr_hst
474
475
476   FUNCTION dia_ptr_alloc()
477      !!----------------------------------------------------------------------
478      !!                    ***  ROUTINE dia_ptr_alloc  ***
479      !!----------------------------------------------------------------------
480      INTEGER               ::   dia_ptr_alloc   ! return value
481      INTEGER, DIMENSION(3) ::   ierr
482      !!----------------------------------------------------------------------
483      ierr(:) = 0
484      !
485      ! nbasin has been initialized in iom_init to define the axis "basin"
486      !
487      IF( .NOT. ALLOCATED( btmsk ) ) THEN
488         ALLOCATE( btmsk(jpi,jpj,nbasin)    , btmsk34(jpi,jpj,nbasin),   &
489            &      hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), &
490            &      hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), &
491            &      hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1)  )
492            !
493         ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
494         !
495         dia_ptr_alloc = MAXVAL( ierr )
496         CALL mpp_sum( 'diaptr', dia_ptr_alloc )
497      ENDIF
498      !
499   END FUNCTION dia_ptr_alloc
500
501
502   FUNCTION ptr_sj_3d( pvflx, pmsk )   RESULT ( p_fval )
503      !!----------------------------------------------------------------------
504      !!                    ***  ROUTINE ptr_sj_3d  ***
505      !!
506      !! ** Purpose :   i-k sum computation of a j-flux array
507      !!
508      !! ** Method  : - i-k sum of pvflx using the interior 2D vmask (vmask_i).
509      !!              pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
510      !!
511      !! ** Action  : - p_fval: i-k-mean poleward flux of pvflx
512      !!----------------------------------------------------------------------
513      REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)  ::   pvflx  ! mask flux array at V-point
514      REAL(wp), INTENT(in), DIMENSION(jpi,jpj)      ::   pmsk   ! Optional 2D basin mask
515      !
516      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments
517      INTEGER                  ::   ijpj         ! ???
518      REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value
519      !!--------------------------------------------------------------------
520      !
521      p_fval => p_fval1d
522
523      ijpj = jpj
524      p_fval(:) = 0._wp
525      DO_3D( 0, 0, 0, 0, 1, jpkm1 )
526         p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj)
527      END_3D
528#if defined key_mpp_mpi
529      CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)
530#endif
531      !
532   END FUNCTION ptr_sj_3d
533
534
535   FUNCTION ptr_sj_2d( pvflx, pmsk )   RESULT ( p_fval )
536      !!----------------------------------------------------------------------
537      !!                    ***  ROUTINE ptr_sj_2d  ***
538      !!
539      !! ** Purpose :   "zonal" and vertical sum computation of a j-flux array
540      !!
541      !! ** Method  : - i-k sum of pvflx using the interior 2D vmask (vmask_i).
542      !!      pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
543      !!
544      !! ** Action  : - p_fval: i-k-mean poleward flux of pvflx
545      !!----------------------------------------------------------------------
546      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pvflx  ! mask flux array at V-point
547      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pmsk   ! Optional 2D basin mask
548      !
549      INTEGER                  ::   ji,jj       ! dummy loop arguments
550      INTEGER                  ::   ijpj        ! ???
551      REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
552      !!--------------------------------------------------------------------
553      !
554      p_fval => p_fval1d
555
556      ijpj = jpj
557      p_fval(:) = 0._wp
558      DO_2D( 0, 0, 0, 0 )
559         p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj)
560      END_2D
561#if defined key_mpp_mpi
562      CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )
563#endif
564      !
565   END FUNCTION ptr_sj_2d
566
567   FUNCTION ptr_ci_2d( pva )   RESULT ( p_fval )
568      !!----------------------------------------------------------------------
569      !!                    ***  ROUTINE ptr_ci_2d  ***
570      !!
571      !! ** Purpose :   "meridional" cumulated sum computation of a j-flux array
572      !!
573      !! ** Method  : - j cumulated sum of pva using the interior 2D vmask (umask_i).
574      !!
575      !! ** Action  : - p_fval: j-cumulated sum of pva
576      !!----------------------------------------------------------------------
577      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)  ::   pva   ! mask flux array at V-point
578      !
579      INTEGER                  ::   ji,jj,jc       ! dummy loop arguments
580      INTEGER                  ::   ijpj        ! ???
581      REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value
582      !!--------------------------------------------------------------------
583      !
584      ijpj = jpj  ! ???
585      p_fval(:,:) = 0._wp
586      DO jc = 1, jpnj ! looping over all processors in j axis
587         DO_2D( 0, 0, 0, 0 )
588            p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj)
589         END_2D
590         CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp )
591      END DO
592      !
593   END FUNCTION ptr_ci_2d
594
595
596
597   FUNCTION ptr_sjk( pta, pmsk )   RESULT ( p_fval )
598      !!----------------------------------------------------------------------
599      !!                    ***  ROUTINE ptr_sjk  ***
600      !!
601      !! ** Purpose :   i-sum computation of an array
602      !!
603      !! ** Method  : - i-sum of field using the interior 2D vmask (pmsk).
604      !!
605      !! ** Action  : - p_fval: i-sum of masked field
606      !!----------------------------------------------------------------------
607      !!
608      IMPLICIT none
609      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! mask flux array at V-point
610      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask
611      !!
612      INTEGER                           :: ji, jj, jk ! dummy loop arguments
613      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value
614#if defined key_mpp_mpi
615      INTEGER, DIMENSION(1) ::   ish
616      INTEGER, DIMENSION(2) ::   ish2
617      INTEGER               ::   ijpjjpk
618      REAL(wp), DIMENSION(jpj*jpk) ::   zwork    ! mask flux array at V-point
619#endif
620      !!--------------------------------------------------------------------
621      !
622      p_fval => p_fval2d
623
624      p_fval(:,:) = 0._wp
625      !
626      DO_3D( 0, 0, 0, 0, 1, jpkm1 )
627         p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj)
628      END_3D
629      !
630#if defined key_mpp_mpi
631      ijpjjpk = jpj*jpk
632      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk
633      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
634      CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl )
635      p_fval(:,:) = RESHAPE( zwork, ish2 )
636#endif
637      !
638   END FUNCTION ptr_sjk
639
640
641   !!======================================================================
642END MODULE diaptr
Note: See TracBrowser for help on using the repository browser.