source: NEMO/branches/2019/dev_r12072_TOP-01_ENHANCE-11_CEthe/src/OCE/DIA/diaptr.F90 @ 12109

Last change on this file since 12109 was 12109, checked in by cetlod, 8 months ago

check out & merge dev_r11643_ENHANCE-11_CEthe_Shaconemo_diags branch onto dev_r12072_TOP-01_ENHANCE-11_CEthe

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