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/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DIA – NEMO

source: NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DIA/diaptr.F90 @ 12709

Last change on this file since 12709 was 12709, checked in by mathiot, 4 years ago

NEMO_4.0.2_ENHANCE-02_ISF_nemo: remove svn keywords

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