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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/DIA – NEMO

source: NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/DIA/diaptr.F90 @ 13257

Last change on this file since 13257 was 13257, checked in by orioltp, 4 years ago

Updated with trunk at r13245 and small change allocating variables in icb_oce.F90.

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