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 trunk/NEMO/OPA_SRC/DIA – NEMO

source: trunk/NEMO/OPA_SRC/DIA/diaptr.F90 @ 1358

Last change on this file since 1358 was 1358, checked in by rblod, 15 years ago

Update diaptr for compatibility with AGRIF
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 45.8 KB
Line 
1MODULE diaptr
2   !!======================================================================
3   !!                       ***  MODULE  diaptr  ***
4   !! Ocean physics:  Computes meridonal transports and zonal means
5   !!=====================================================================
6   !! History :  9.0  !  03-09  (C. Talandier, G. Madec)  Original code
7   !!            9.0  !  06-01  (A. Biastoch)  Allow sub-basins computation
8   !!            9.0  !  03-09  (O. Marti) Add fields
9   !!----------------------------------------------------------------------
10
11   !!----------------------------------------------------------------------
12   !!   dia_ptr      : Poleward Transport Diagnostics module
13   !!   dia_ptr_init : Initialization, namelist read
14   !!   dia_ptr_wri  : Output of poleward fluxes
15   !!   ptr_vjk      : "zonal" sum computation of a "meridional" flux array
16   !!   ptr_tjk      : "zonal" mean computation of a tracer field
17   !!   ptr_vj       : "zonal" and vertical sum computation of a "meridional"
18   !!                : flux array; Generic interface: ptr_vj_3d, ptr_vj_2d
19   !!----------------------------------------------------------------------
20   USE oce           ! ocean dynamics and active tracers
21   USE dom_oce       ! ocean space and time domain
22   USE ldftra_oce    ! ocean active tracers: lateral physics
23   USE lib_mpp
24   USE in_out_manager
25   USE dianam
26   USE phycst
27   USE iom
28   USE ioipsl         
29   USE daymod
30
31   IMPLICIT NONE
32   PRIVATE
33
34   INTERFACE ptr_vj
35      MODULE PROCEDURE ptr_vj_3d, ptr_vj_2d
36   END INTERFACE
37
38   PUBLIC   dia_ptr_init   ! call in opa module
39   PUBLIC   dia_ptr        ! call in step module
40   PUBLIC   ptr_vj         ! call by tra_ldf & tra_adv routines
41   PUBLIC   ptr_vjk        ! call by tra_ldf & tra_adv routines
42
43!!! ** init namelist (namptr)
44   LOGICAL , PUBLIC                 ::   ln_diaptr = .FALSE.   !: Poleward transport flag (T) or not (F)
45   LOGICAL , PUBLIC                 ::   ln_subbas = .FALSE.   !: Atlantic/Pacific/Indian basins calculation
46   LOGICAL , PUBLIC                 ::   ln_diaznl = .FALSE.   !: Add zonal means and meridional stream functions
47   LOGICAL , PUBLIC                 ::   ln_ptrcomp = .FALSE.  !: Add decomposition : overturning (and gyre, soon ...)
48   INTEGER , PUBLIC                 ::   nf_ptr = 15           !: frequency of ptr computation
49   INTEGER , PUBLIC                 ::   nf_ptr_wri = 15       !: frequency of ptr outputs
50
51   REAL(wp), DIMENSION(jpi,jpj), PUBLIC ::   abasin, pbasin, ibasin, dbasin, sbasin !: Sub basin masks
52
53   REAL(wp), PUBLIC, DIMENSION(jpj) ::   pht_adv, pst_adv  !: heat and salt poleward transport: advection
54   REAL(wp), PUBLIC, DIMENSION(jpj) ::   pht_ove_glo, pst_ove_glo, pht_ove_atl, pst_ove_atl, pht_ove_pac, pst_ove_pac, &
55      &        pht_ove_ind, pst_ove_ind, pht_ove_ipc, pst_ove_ipc  !: heat and salt poleward transport: overturning
56   REAL(wp), PUBLIC, DIMENSION(jpj) ::   pht_ldf, pst_ldf      !: heat and salt poleward transport: lateral diffusion
57#if defined key_diaeiv
58   REAL(wp), PUBLIC, DIMENSION(jpj) ::   pht_eiv_glo, pst_eiv_glo, pht_eiv_atl, pst_eiv_atl, pht_eiv_pac, pst_eiv_pac, &
59      &        pht_eiv_ind, pst_eiv_ind, pht_eiv_ipc, pst_eiv_ipc !: heat and salt poleward transport: bolus advection
60#endif
61   REAL(wp), PUBLIC, DIMENSION(jpj) ::   ht_glo,ht_atl,ht_ind,ht_pac,ht_ipc !: heat
62   REAL(wp), PUBLIC, DIMENSION(jpj) ::   st_glo,st_atl,st_ind,st_pac,st_ipc !: salt
63
64   INTEGER :: niter
65
66   REAL(wp), DIMENSION(jpj,jpk) ::   tn_jk_glo, sn_jk_glo,  &  !: "zonal" mean temperature and salinity
67      &                              tn_jk_atl, sn_jk_atl,  &
68      &                              tn_jk_pac, sn_jk_pac,  &
69      &                              tn_jk_ind, sn_jk_ind,  &
70      &                              tn_jk_ipc, sn_jk_ipc,  &
71      &                              v_msf_glo       ,  &  !: "meridional" Stream-Function
72      &                              v_msf_atl       ,  & 
73      &                              v_msf_pac       ,  & 
74      &                              v_msf_ind       ,  & 
75      &                              v_msf_ipc       ,  & 
76      &                              surf_jk_glo     ,  &  !: Ocean "zonal" section surface
77      &                              surf_jk_atl     ,  & 
78      &                              surf_jk_pac     ,  & 
79      &                              surf_jk_ind     ,  &         
80      &                              surf_jk_ipc     ,  & 
81      &                              surf_jk_r_glo   ,  &  !: inverse of the ocean "zonal" section surface
82      &                              surf_jk_r_atl   ,  & 
83      &                              surf_jk_r_pac   ,  & 
84      &                              surf_jk_r_ind   ,  &         
85      &                              surf_jk_r_ipc       
86#if defined key_diaeiv
87   REAL(wp), DIMENSION(jpj,jpk) ::   v_msf_eiv_glo, v_msf_eiv_atl, v_msf_eiv_pac,  &
88      &                              v_msf_eiv_ind, v_msf_eiv_ipc !: bolus "meridional" Stream-Function
89#endif
90 
91   !! * Substitutions
92#  include "domzgr_substitute.h90"
93#  include "vectopt_loop_substitute.h90"
94   !!----------------------------------------------------------------------
95   !!   OPA 9.0 , LOCEAN-IPSL (2005)
96   !! $Id$
97   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
98   !!----------------------------------------------------------------------
99
100CONTAINS
101
102   FUNCTION ptr_vj_3d( pva )   RESULT ( p_fval )
103      !!----------------------------------------------------------------------
104      !!                    ***  ROUTINE ptr_vj_3d  ***
105      !!
106      !! ** Purpose :   "zonal" and vertical sum computation of a "meridional"
107      !!      flux array
108      !!
109      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
110      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
111      !!
112      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
113      !!----------------------------------------------------------------------
114      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point
115      !!
116      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments
117      INTEGER                  ::   ijpj         ! ???
118      REAL(wp), DIMENSION(jpj) ::   p_fval       ! function value
119      !!--------------------------------------------------------------------
120      !
121      ijpj = jpj
122      p_fval(:) = 0.e0
123      DO jk = 1, jpkm1
124         DO jj = 2, jpjm1
125            DO ji = fs_2, fs_jpim1   ! Vector opt.
126               p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj+1) * tmask_i(ji,jj) 
127            END DO
128         END DO
129      END DO
130      !
131#if defined key_mpp_mpi
132      CALL mpp_sum( p_fval, ijpj, ncomm_znl)     !!bug  I presume
133#endif
134      !
135   END FUNCTION ptr_vj_3d
136
137
138   FUNCTION ptr_vj_2d( pva )   RESULT ( p_fval )
139      !!----------------------------------------------------------------------
140      !!                    ***  ROUTINE ptr_vj_2d  ***
141      !!
142      !! ** Purpose :   "zonal" and vertical sum computation of a "meridional"
143      !!      flux array
144      !!
145      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
146      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
147      !!
148      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
149      !!----------------------------------------------------------------------
150      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pva   ! mask flux array at V-point
151      !!
152      INTEGER                  ::   ji,jj    ! dummy loop arguments
153      INTEGER                  ::   ijpj     ! ???
154      REAL(wp), DIMENSION(jpj) ::   p_fval   ! function value
155      !!--------------------------------------------------------------------
156      !
157      ijpj = jpj
158      p_fval(:) = 0.e0
159      DO jj = 2, jpjm1
160         DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
161            p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj+1) * tmask_i(ji,jj)
162         END DO
163      END DO
164      !
165#if defined key_mpp_mpi
166      CALL mpp_sum( p_fval, ijpj, ncomm_znl )     !!bug  I presume
167#endif
168      !
169   END FUNCTION ptr_vj_2d
170
171
172   FUNCTION ptr_vjk( pva, bmask )   RESULT ( p_fval )
173      !!----------------------------------------------------------------------
174      !!                    ***  ROUTINE ptr_vjk  ***
175      !!
176      !! ** Purpose :   "zonal" sum computation of a "meridional" flux array
177      !!
178      !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i).
179      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
180      !!
181      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
182      !!----------------------------------------------------------------------
183      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point
184      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: bmask ! Optional 2D basin mask
185      !!
186      INTEGER                      ::   ji, jj, jk   ! dummy loop arguments
187      INTEGER , DIMENSION (1)      ::   ish
188      INTEGER , DIMENSION (2)      ::   ish2
189      REAL(wp), DIMENSION(jpj*jpk) ::   zwork        ! temporary vector for mpp_sum
190      REAL(wp), DIMENSION(jpj,jpk) ::   p_fval       ! return function value
191      !!--------------------------------------------------------------------
192      !
193      p_fval(:,:) = 0.e0
194      !
195      IF (PRESENT (bmask)) THEN
196         DO jk = 1, jpkm1
197            DO jj = 2, jpjm1
198               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
199                  p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk)   &
200                     &                                          * tmask_i(ji,jj+1) * tmask_i(ji,jj) &
201                     &                                          * bmask(ji,jj)
202               END DO
203            END DO
204         END DO
205      ELSE
206         DO jk = 1, jpkm1
207            DO jj = 2, jpjm1
208               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
209                  p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk)   &
210                     &                                          * tmask_i(ji,jj+1) * tmask_i(ji,jj)
211               END DO
212            END DO
213         END DO
214      END IF
215      !
216#if defined key_mpp_mpi
217      ish(1) = jpj*jpk  ;  ish2(1) = jpj  ;  ish2(2) = jpk
218      zwork(:)= RESHAPE( p_fval, ish )
219      CALL mpp_sum( zwork, jpj*jpk, ncomm_znl )
220      p_fval(:,:)= RESHAPE( zwork, ish2 )
221#endif
222      !
223   END FUNCTION ptr_vjk
224
225   FUNCTION ptr_tjk( pta, bmask )   RESULT ( p_fval )
226      !!----------------------------------------------------------------------
227      !!                    ***  ROUTINE ptr_tjk  ***
228      !!
229      !! ** Purpose :   "zonal" mean computation of a tracer field
230      !!
231      !! ** Method  : - i-sum of mj(pta) using tmask
232      !!      multiplied by the inverse of the surface of the "zonal" ocean
233      !!      section
234      !!
235      !! ** Action  : - p_fval: i-k-mean poleward flux of pta
236      !!----------------------------------------------------------------------
237      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point
238      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: bmask ! Optional 2D basin mask
239      !!
240      INTEGER                     ::   ji, jj, jk   ! dummy loop arguments
241      INTEGER, DIMENSION (1)      ::   ish
242      INTEGER, DIMENSION (2)      ::   ish2
243      REAL(wp),DIMENSION(jpj*jpk) ::   zwork        ! temporary vector for mpp_sum
244      REAL(wp),DIMENSION(jpj,jpk) ::   p_fval       ! return function value
245      !!--------------------------------------------------------------------
246      !
247      p_fval(:,:) = 0.e0
248      IF (PRESENT (bmask)) THEN
249         DO jk = 1, jpkm1
250            DO jj = 2, jpjm1
251               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
252                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk)                  &
253                     &                          * e1t(ji,jj) * fse3t(ji,jj,jk)   &
254                     &                          * tmask_i(ji,jj)                 &
255                     &                          * bmask(ji,jj)
256               END DO
257            END DO
258         END DO
259      ELSE
260         DO jk = 1, jpkm1
261            DO jj = 2, jpjm1
262               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
263                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk)                  &
264                     &                          * e1t(ji,jj) * fse3t(ji,jj,jk)   &
265                     &                          * tmask_i(ji,jj)
266               END DO
267            END DO
268         END DO
269      END IF
270      p_fval(:,:) = p_fval(:,:) * 0.5
271#if defined key_mpp_mpi
272      ish(1) = jpj*jpk   ;   ish2(1) = jpj   ;   ish2(2) = jpk
273      zwork(:)= RESHAPE( p_fval, ish )
274      CALL mpp_sum( zwork, jpj*jpk, ncomm_znl )
275      p_fval(:,:)= RESHAPE(zwork,ish2)
276#endif
277      !
278   END FUNCTION ptr_tjk
279
280
281   SUBROUTINE dia_ptr( kt )
282      !!----------------------------------------------------------------------
283      !!                  ***  ROUTINE dia_ptr  ***
284      !!----------------------------------------------------------------------
285      INTEGER, INTENT(in) ::   kt   ! ocean time step index
286      !!
287      INTEGER  ::   jk, jj, ji               ! dummy loop
288      REAL(wp) ::   zsverdrup,  &              ! conversion from m3/s to Sverdrup
289         &          zpwatt,     &              ! conversion from W    to PW
290         &          zggram                     ! conversion from g    to Pg
291      REAL(wp), DIMENSION(jpi,jpj,jpk) :: vt, vs
292      !!----------------------------------------------------------------------
293
294      IF( kt == nit000 .OR. MOD( kt, nf_ptr ) == 0 )   THEN
295
296         IF ( MOD( kt, nf_ptr ) == 0 ) THEN
297
298            zsverdrup = 1.e-6
299            zpwatt    = 1.e-15
300            zggram    = 1.e-6
301
302            IF ( ln_diaznl ) THEN
303               ! "zonal" mean temperature and salinity at V-points
304               tn_jk_glo(:,:) = ptr_tjk( tn(:,:,:) ) * surf_jk_r_glo(:,:)
305               sn_jk_glo(:,:) = ptr_tjk( sn(:,:,:) ) * surf_jk_r_glo(:,:)
306
307               IF (ln_subbas) THEN
308                  tn_jk_atl(:,:) = ptr_tjk( tn(:,:,:), abasin(:,:) ) * surf_jk_r_atl(:,:)
309                  sn_jk_atl(:,:) = ptr_tjk( sn(:,:,:), abasin(:,:) ) * surf_jk_r_atl(:,:)
310                  tn_jk_pac(:,:) = ptr_tjk( tn(:,:,:), pbasin(:,:) ) * surf_jk_r_pac(:,:)
311                  sn_jk_pac(:,:) = ptr_tjk( sn(:,:,:), pbasin(:,:) ) * surf_jk_r_pac(:,:)
312                  tn_jk_ind(:,:) = ptr_tjk( tn(:,:,:), ibasin(:,:) ) * surf_jk_r_ind(:,:)
313                  sn_jk_ind(:,:) = ptr_tjk( sn(:,:,:), ibasin(:,:) ) * surf_jk_r_ind(:,:)
314                  tn_jk_ipc(:,:) = ptr_tjk( tn(:,:,:), dbasin(:,:) ) * surf_jk_r_ipc(:,:)
315                  sn_jk_ipc(:,:) = ptr_tjk( sn(:,:,:), dbasin(:,:) ) * surf_jk_r_ipc(:,:)
316               ENDIF
317            ENDIF
318
319            !--------------------------------------------------------
320            ! overturning calculation:
321
322            ! horizontal integral and vertical dz
323
324#if defined key_diaeiv
325            v_msf_glo(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:) ) 
326            IF( ln_subbas .AND. ln_diaznl ) THEN
327               v_msf_atl(:,:) = ptr_vjk( vn (:,:,:)+v_eiv(:,:,:), abasin(:,:)*sbasin(:,:) ) 
328               v_msf_pac(:,:) = ptr_vjk( vn (:,:,:)+v_eiv(:,:,:), pbasin(:,:)*sbasin(:,:) ) 
329               v_msf_ind(:,:) = ptr_vjk( vn (:,:,:)+v_eiv(:,:,:), ibasin(:,:)*sbasin(:,:) ) 
330               v_msf_ipc(:,:) = ptr_vjk( vn (:,:,:)+v_eiv(:,:,:), dbasin(:,:)*sbasin(:,:) ) 
331            ENDIF
332#else
333            v_msf_glo(:,:) = ptr_vjk( vn(:,:,:) ) 
334            IF( ln_subbas .AND. ln_diaznl ) THEN
335               v_msf_atl(:,:) = ptr_vjk( vn (:,:,:), abasin(:,:)*sbasin(:,:) ) 
336               v_msf_pac(:,:) = ptr_vjk( vn (:,:,:), pbasin(:,:)*sbasin(:,:) ) 
337               v_msf_ind(:,:) = ptr_vjk( vn (:,:,:), ibasin(:,:)*sbasin(:,:) ) 
338               v_msf_ipc(:,:) = ptr_vjk( vn (:,:,:), dbasin(:,:)*sbasin(:,:) ) 
339            ENDIF
340#endif
341
342#if defined key_diaeiv
343            v_msf_eiv_glo(:,:) = ptr_vjk( v_eiv(:,:,:) )
344            IF (ln_subbas ) THEN
345               v_msf_eiv_atl(:,:) = ptr_vjk( v_eiv(:,:,:), abasin(:,:)*sbasin(:,:) )
346               v_msf_eiv_pac(:,:) = ptr_vjk( v_eiv(:,:,:), pbasin(:,:)*sbasin(:,:) )
347               v_msf_eiv_ind(:,:) = ptr_vjk( v_eiv(:,:,:), ibasin(:,:)*sbasin(:,:) )
348               v_msf_eiv_ipc(:,:) = ptr_vjk( v_eiv(:,:,:), dbasin(:,:)*sbasin(:,:) )
349            END IF
350#endif
351
352            ! "Meridional" Stream-Function
353            DO jk = 2,jpk 
354               v_msf_glo(:,jk) = v_msf_glo(:,jk-1) + v_msf_glo(:,jk)
355            END DO
356            v_msf_glo(:,:) = v_msf_glo(:,:) * zsverdrup
357#if defined key_diaeiv
358            ! Bolus "Meridional" Stream-Function
359            DO jk = 2,jpk
360               v_msf_eiv_glo(:,jk) = v_msf_eiv_glo(:,jk-1) + v_msf_eiv_glo(:,jk)
361            END DO
362            v_msf_eiv_glo(:,:) = v_msf_eiv_glo(:,:) * zsverdrup
363            IF ( ln_subbas ) THEN
364               DO jk = 2,jpk
365                  v_msf_eiv_atl(:,jk) = v_msf_eiv_atl(:,jk-1) + v_msf_eiv_atl(:,jk)
366                  v_msf_eiv_pac(:,jk) = v_msf_eiv_pac(:,jk-1) + v_msf_eiv_pac(:,jk)
367                  v_msf_eiv_ind(:,jk) = v_msf_eiv_ind(:,jk-1) + v_msf_eiv_ind(:,jk)
368                  v_msf_eiv_ipc(:,jk) = v_msf_eiv_ipc(:,jk-1) + v_msf_eiv_ipc(:,jk)
369               END DO
370            ENDIF
371#endif
372            !
373            IF( ln_subbas .AND. ln_diaznl ) THEN
374               DO jk = 2,jpk 
375                  v_msf_atl(:,jk) = v_msf_atl(:,jk-1) + v_msf_atl(:,jk)
376                  v_msf_pac(:,jk) = v_msf_pac(:,jk-1) + v_msf_pac(:,jk)
377                  v_msf_ind(:,jk) = v_msf_ind(:,jk-1) + v_msf_ind(:,jk)
378                  v_msf_ipc(:,jk) = v_msf_ipc(:,jk-1) + v_msf_ipc(:,jk)
379               END DO
380               v_msf_atl(:,:) = v_msf_atl(:,:) * zsverdrup
381               v_msf_pac(:,:) = v_msf_pac(:,:) * zsverdrup
382               v_msf_ind(:,:) = v_msf_ind(:,:) * zsverdrup
383               v_msf_ipc(:,:) = v_msf_ipc(:,:) * zsverdrup
384            ENDIF
385
386            ! Transports
387            ! T times V on T points (include bolus velocities)
388#if defined key_diaeiv 
389            DO jj = 1, jpj
390               DO ji = 1, jpi
391                  vt(ji,jj,:) = tn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) + u_eiv(ji,jj,:) + u_eiv(ji,jj-1,:) )*0.5
392                  vs(ji,jj,:) = sn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) + v_eiv(ji,jj,:) + v_eiv(ji,jj-1,:) )*0.5
393               END DO
394            END DO
395#else
396            DO jj = 1, jpj
397               DO ji = 1, jpi
398                  vt(ji,jj,:) = tn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) )*0.5
399                  vs(ji,jj,:) = sn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:)  )*0.5
400               END DO
401            END DO
402#endif
403
404            ht_glo(:) = SUM( ptr_vjk( vt(:,:,:)), 2 )
405            st_glo(:) = SUM( ptr_vjk( vs(:,:,:)), 2 )
406
407            IF ( ln_subbas ) THEN
408               ht_atl(:) = SUM( ptr_vjk( vt (:,:,:), abasin(:,:)*sbasin(:,:)), 2 )
409               ht_pac(:) = SUM( ptr_vjk( vt (:,:,:), pbasin(:,:)*sbasin(:,:)), 2 )
410               ht_ind(:) = SUM( ptr_vjk( vt (:,:,:), ibasin(:,:)*sbasin(:,:)), 2 )
411               ht_ipc(:) = SUM( ptr_vjk( vt (:,:,:), dbasin(:,:)*sbasin(:,:)), 2 )
412               st_atl(:) = SUM( ptr_vjk( vs (:,:,:), abasin(:,:)*sbasin(:,:)), 2 )
413               st_pac(:) = SUM( ptr_vjk( vs (:,:,:), pbasin(:,:)*sbasin(:,:)), 2 )
414               st_ind(:) = SUM( ptr_vjk( vs (:,:,:), ibasin(:,:)*sbasin(:,:)), 2 )
415               st_ipc(:) = SUM( ptr_vjk( vs (:,:,:), dbasin(:,:)*sbasin(:,:)), 2 )
416            ENDIF
417
418            ! poleward tracer transports:
419            ! overturning components:
420            IF ( ln_ptrcomp ) THEN
421               pht_ove_glo(:) = SUM( v_msf_glo(:,:) * tn_jk_glo(:,:), 2 )   ! SUM over jk
422               pst_ove_glo(:) = SUM( v_msf_glo(:,:) * sn_jk_glo(:,:), 2 ) 
423               IF ( ln_subbas ) THEN
424                  pht_ove_atl(:) = SUM( v_msf_atl(:,:) * tn_jk_atl(:,:), 2 )   ! SUM over jk
425                  pst_ove_atl(:) = SUM( v_msf_atl(:,:) * sn_jk_atl(:,:), 2 ) 
426                  pht_ove_pac(:) = SUM( v_msf_pac(:,:) * tn_jk_pac(:,:), 2 )   ! SUM over jk
427                  pst_ove_pac(:) = SUM( v_msf_pac(:,:) * sn_jk_pac(:,:), 2 ) 
428                  pht_ove_ind(:) = SUM( v_msf_ind(:,:) * tn_jk_ind(:,:), 2 )   ! SUM over jk
429                  pst_ove_ind(:) = SUM( v_msf_ind(:,:) * sn_jk_ind(:,:), 2 ) 
430                  pht_ove_ipc(:) = SUM( v_msf_ipc(:,:) * tn_jk_ipc(:,:), 2 )   ! SUM over jk
431                  pst_ove_ipc(:) = SUM( v_msf_ipc(:,:) * sn_jk_ipc(:,:), 2 ) 
432               END IF
433            END IF
434
435            ! Bolus component
436#if defined key_diaeiv
437            pht_eiv_glo(:) = SUM( v_msf_eiv_glo(:,:) * tn_jk_glo(:,:), 2 )   ! SUM over jk
438            pst_eiv_glo(:) = SUM( v_msf_eiv_glo(:,:) * sn_jk_glo(:,:), 2 )   ! SUM over jk
439            IF ( ln_subbas ) THEN
440               pht_eiv_atl(:) = SUM( v_msf_eiv_glo(:,:) * tn_jk_atl(:,:), 2 )   ! SUM over jk
441               pst_eiv_atl(:) = SUM( v_msf_eiv_glo(:,:) * sn_jk_atl(:,:), 2 )   ! SUM over jk
442               pht_eiv_pac(:) = SUM( v_msf_eiv_pac(:,:) * tn_jk_pac(:,:), 2 )   ! SUM over jk
443               pst_eiv_pac(:) = SUM( v_msf_eiv_pac(:,:) * sn_jk_pac(:,:), 2 )   ! SUM over jk
444               pht_eiv_ind(:) = SUM( v_msf_eiv_ind(:,:) * tn_jk_ind(:,:), 2 )   ! SUM over jk
445               pst_eiv_ind(:) = SUM( v_msf_eiv_ind(:,:) * sn_jk_ind(:,:), 2 )   ! SUM over jk
446               pht_eiv_ipc(:) = SUM( v_msf_eiv_ipc(:,:) * tn_jk_ipc(:,:), 2 )   ! SUM over jk
447               pst_eiv_ipc(:) = SUM( v_msf_eiv_ipc(:,:) * sn_jk_ipc(:,:), 2 )   ! SUM over jk
448            ENDIF
449#endif
450
451            ! conversion in PW and G g
452            zpwatt = zpwatt * rau0 * rcp
453            pht_adv(:) = pht_adv(:) * zpwatt 
454            pht_ldf(:) = pht_ldf(:) * zpwatt
455            pst_adv(:) = pst_adv(:) * zggram
456            pst_ldf(:) = pst_ldf(:) * zggram
457            IF ( ln_ptrcomp ) THEN
458               pht_ove_glo(:) = pht_ove_glo(:) * zpwatt
459               pst_ove_glo(:) = pst_ove_glo(:) * zggram
460            END IF
461#if defined key_diaeiv
462            pht_eiv_glo(:) = pht_eiv_glo(:) * zpwatt
463            pst_eiv_glo(:) = pst_eiv_glo(:) * zggram
464#endif
465            IF( ln_subbas ) THEN
466               ht_atl(:) = ht_atl(:) * zpwatt
467               ht_pac(:) = ht_pac(:) * zpwatt
468               ht_ind(:) = ht_ind(:) * zpwatt
469               ht_ipc(:) = ht_ipc(:) * zpwatt
470               st_atl(:) = st_atl(:) * zggram 
471               st_pac(:) = st_pac(:) * zggram
472               st_ind(:) = st_ind(:) * zggram
473               st_ipc(:) = st_ipc(:) * zggram
474            ENDIF
475         ENDIF
476
477         ! outputs
478         CALL dia_ptr_wri( kt )
479
480      ENDIF
481
482      ! Close the file
483      IF( kt == nitend ) CALL histclo( numptr )
484      !
485   END SUBROUTINE dia_ptr
486
487
488   SUBROUTINE dia_ptr_init
489      !!----------------------------------------------------------------------
490      !!                  ***  ROUTINE dia_ptr_init  ***
491      !!                   
492      !! ** Purpose :   Initialization, namelist read
493      !!----------------------------------------------------------------------
494      NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nf_ptr, nf_ptr_wri
495      INTEGER :: inum       ! temporary logical unit
496      INTEGER, DIMENSION (1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid
497      !!----------------------------------------------------------------------
498
499      ! Read Namelist namptr : poleward transport parameters
500      REWIND ( numnam )
501      READ   ( numnam, namptr )
502
503      ! Control print
504      IF(lwp) THEN
505         WRITE(numout,*)
506         WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
507         WRITE(numout,*) '~~~~~~~~~~~~'
508         WRITE(numout,*) '          Namelist namptr : set ptr parameters'
509         WRITE(numout,*) '             Switch for ptr diagnostic (T) or not (F) ln_diaptr = ', ln_diaptr
510         WRITE(numout,*) '             Atla/Paci/Ind basins computation         ln_subbas = ', ln_subbas
511         WRITE(numout,*) '             Frequency of computation                    nf_ptr = ', nf_ptr
512         WRITE(numout,*) '             Frequency of outputs                    nf_ptr_wri = ', nf_ptr_wri
513      ENDIF
514
515      !
516      ! Define MPI communicator for zonal sum
517      !
518      IF( lk_mpp )  THEN
519         CALL mpp_ini_znl
520      ENDIF
521
522      IF( ln_subbas ) THEN                ! load sub-basin mask
523         CALL iom_open( 'subbasins', inum )
524         CALL iom_get( inum, jpdom_data, 'atlmsk', abasin )      ! Atlantic basin
525         CALL iom_get( inum, jpdom_data, 'pacmsk', pbasin )      ! Pacific basin
526         CALL iom_get( inum, jpdom_data, 'indmsk', ibasin )      ! Indian basin
527         CALL iom_close( inum )
528         dbasin(:,:) = MAX ( pbasin(:,:), ibasin(:,:) )
529         sbasin(:,:) = tmask (:,:,1)
530         WHERE ( gphit (:,:) < -30.e0) sbasin(:,:) = 0.e0
531      ENDIF
532     
533      ! inverse of the ocean "zonal" v-point section
534      surf_jk_glo(:,:) = ptr_tjk( tmask(:,:,:) )
535      surf_jk_r_glo(:,:) = 0.e0
536      WHERE( surf_jk_glo(:,:) /= 0.e0 )   surf_jk_r_glo(:,:) = 1.e0 / surf_jk_glo(:,:)
537     
538      IF (ln_subbas) THEN
539         surf_jk_atl(:,:) = ptr_tjk( tmask (:,:,:), abasin(:,:) )
540         surf_jk_r_atl(:,:) = 0.e0
541         WHERE( surf_jk_atl(:,:) /= 0.e0 )   surf_jk_r_atl(:,:) = 1.e0 / surf_jk_atl(:,:)
542         !
543         surf_jk_pac(:,:) = ptr_tjk( tmask (:,:,:), pbasin(:,:) )
544         surf_jk_r_pac(:,:) = 0.e0
545         WHERE( surf_jk_pac(:,:) /= 0.e0 )   surf_jk_r_pac(:,:) = 1.e0 / surf_jk_pac(:,:)
546         !
547         surf_jk_ind(:,:) = ptr_tjk( tmask (:,:,:), ibasin(:,:) )
548         surf_jk_r_ind(:,:) = 0.e0
549         WHERE( surf_jk_ind(:,:) /= 0.e0 )   surf_jk_r_ind(:,:) = 1.e0 / surf_jk_ind(:,:)
550         !
551         surf_jk_ipc(:,:) = ptr_tjk( tmask (:,:,:), dbasin(:,:) )
552         surf_jk_r_ipc(:,:) = 0.e0
553         WHERE( surf_jk_ipc(:,:) /= 0.e0 )   surf_jk_r_ipc(:,:) = 1.e0 / surf_jk_ipc(:,:)
554      END IF
555
556     
557      !!----------------------------------------------------------------------
558
559      iglo (1) = jpjglo
560      iloc (1) = nlcj
561      iabsf(1) = njmppt(narea)
562      iabsl(:) = iabsf(:) + iloc(:) - 1
563      ihals(1) = nldj - 1
564      ihale(1) = nlcj - nlej
565      idid (1) = 2
566
567!-$$      IF(lwp) THEN
568!-$$          WRITE(numout,*)
569!-$$          WRITE(numout,*) 'dia_ptr_init :   iloc  = ', iloc
570!-$$          WRITE(numout,*) '~~~~~~~~~~~~     iabsf = ', iabsf
571!-$$          WRITE(numout,*) '                 ihals = ', ihals
572!-$$          WRITE(numout,*) '                 ihale = ', ihale
573!-$$      ENDIF
574
575      CALL flio_dom_set ( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)
576     
577   END SUBROUTINE dia_ptr_init
578
579
580   SUBROUTINE dia_ptr_wri( kt )
581      !!---------------------------------------------------------------------
582      !!                ***  ROUTINE dia_ptr_wri  ***
583      !!
584      !! ** Purpose :   output of poleward fluxes
585      !!
586      !! ** Method  :   NetCDF file
587      !!----------------------------------------------------------------------
588      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
589      !!
590      INTEGER, SAVE ::   nhoridz, ndepidzt, ndepidzw
591      INTEGER, SAVE :: ndim  , ndim_atl     , ndim_pac     , ndim_ind     , ndim_ipc
592      INTEGER, SAVE ::         ndim_atl_30  , ndim_pac_30  , ndim_ind_30  , ndim_ipc_30
593      INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30
594      INTEGER, SAVE, DIMENSION (jpj*jpk) :: ndex  , ndex_atl     , ndex_pac     , ndex_ind     , ndex_ipc
595      INTEGER, SAVE, DIMENSION (jpj*jpk) ::         ndex_atl_30  , ndex_pac_30  , ndex_ind_30  , ndex_ipc_30
596      INTEGER, SAVE, DIMENSION (jpj)     :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30
597
598      CHARACTER (len=40)       ::   clhstnam, clop, clop_once, cl_comment   ! temporary names
599      INTEGER                  ::   iline, it, itmod, ji, jj, jk      !
600      REAL(wp)                 ::   zsto, zout, zdt, zjulian   ! temporary scalars
601      REAL(wp), DIMENSION(jpj) ::   zphi, zfoo
602      REAL(wp), DIMENSION(jpj,jpk) :: z_1
603      !!----------------------------------------------------------------------
604
605      ! define time axis
606      it    = kt / nf_ptr
607      itmod = kt - nit000 + 1
608     
609!-$$      IF(lwp) THEN
610!-$$         WRITE(numout,*)
611!-$$         WRITE(numout,*) 'dia_ptr_wri : kt = ', kt, 'it = ', it, ' itmod = ', itmod, ' niter = ', niter
612!-$$         WRITE(numout,*) '~~~~~~~~~~~~'
613!-$$      ENDIF
614
615      ! Initialization
616      ! --------------
617      IF( kt == nit000 ) THEN
618
619         niter = (nit000 - 1) / nf_ptr
620
621!-$$         IF(lwp) THEN
622!-$$            WRITE(numout,*)
623!-$$            WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter
624!-$$            WRITE(numout,*) '~~~~~~~~~~~~'
625!-$$         ENDIF
626
627         zdt = rdt
628         IF( nacc == 1 ) zdt = rdtmin
629
630         ! Reference latitude
631         ! ------------------
632         !                                           ! =======================
633         IF( cp_cfg == "orca" ) THEN                 !   ORCA configurations
634            !                                        ! =======================
635
636            IF( jp_cfg == 05  )   iline = 192   ! i-line that passes near the North Pole
637            IF( jp_cfg == 025 )   iline = 384   ! i-line that passes near the North Pole
638            IF( jp_cfg == 1   )   iline =  96   ! i-line that passes near the North Pole
639            IF( jp_cfg == 2   )   iline =  48   ! i-line that passes near the North Pole
640            IF( jp_cfg == 4   )   iline =  24   ! i-line that passes near the North Pole
641            zphi(:) = 0.e0
642            DO ji = mi0(iline), mi1(iline) 
643               zphi(:) = gphiv(ji,:)         ! if iline is in the local domain
644               ! Correct highest latitude for some configurations - will work if domain is parallelized in J ?
645               IF( jp_cfg == 05 ) THEN
646                  DO jj = mj0(jpjdta), mj1(jpjdta) 
647                     zphi( jj ) = zphi(mj0(jpjdta-1)) + (zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)))/2.
648                     zphi( jj ) = MIN( zphi(jj), 90.)
649                  END DO
650               END IF
651               IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN
652                  DO jj = mj0(jpjdta-1), mj1(jpjdta-1) 
653                     zphi( jj ) = 88.5e0
654                  END DO
655                  DO jj = mj0(jpjdta  ), mj1(jpjdta  ) 
656                     zphi( jj ) = 89.5e0
657                  END DO
658               END IF
659            END DO
660            ! provide the correct zphi to all local domains
661#if defined key_mpp_mpi
662            CALL mpp_sum( zphi, jpj, ncomm_znl )       
663#endif
664
665            !                                        ! =======================
666         ELSE                                        !   OTHER configurations  zjulian = zjulian - adatrj
667            !   set calendar origin to the beginning of the experiment
668            !                                        ! =======================
669            zphi(:) = gphiv(1,:)             ! assume lat/lon coordinate, select the first i-line
670            !
671         ENDIF
672         !
673         ! Work only on westmost processor (will not work if mppini2 is used)
674#if defined key_mpp_mpi
675         IF ( l_znl_root ) THEN 
676#endif
677            !
678            ! OPEN netcdf file
679            ! ----------------
680            ! Define frequency of output and means
681            zsto = nf_ptr * zdt
682            IF( ln_mskland )   THEN    ! put 1.e+20 on land (very expensive!!)
683               clop      = "ave(only(x))"
684               clop_once = "once(only(x))"
685            ELSE                       ! no use of the mask value (require less cpu time)
686               clop      = "ave(x)"       
687               clop_once = "once"
688            ENDIF
689
690            zout = nf_ptr_wri * zdt
691            zfoo(:) = 0.e0
692
693            ! Compute julian date from starting date of the run
694
695            CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )
696            zjulian = zjulian - adatrj   !   set calendar origin to the beginning of the experiment
697
698            CALL dia_nam( clhstnam, nf_ptr_wri, 'diaptr' )
699            IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam
700
701            ! Horizontal grid : zphi()
702            CALL histbeg(clhstnam, 1, zfoo, jpj, zphi,   &
703               1, 1, 1, jpj, niter, zjulian, zdt*nf_ptr, nhoridz, numptr, domain_id=nidom)
704            ! Vertical grids : gdept_0, gdepw_0
705            CALL histvert( numptr, "deptht", "Vertical T levels",   &
706               "m", jpk, gdept_0, ndepidzt, "down" )
707            CALL histvert( numptr, "depthw", "Vertical W levels",   &
708               "m", jpk, gdepw_0, ndepidzw, "down" )
709
710            !
711            CALL wheneq ( jpj*jpk, MIN(surf_jk_glo(:,:), 1.e0), 1, 1., ndex  , ndim  )      ! Lat-Depth
712            CALL wheneq ( jpj    , MIN(surf_jk_glo(:,1), 1.e0), 1, 1., ndex_h, ndim_h )     ! Lat
713
714            IF (ln_subbas) THEN
715               z_1 (:,1) = 1.0e0
716               WHERE ( gphit (jpi/2,:) .LT. -30 ) z_1 (:,1) = 0.e0
717               DO jk = 2, jpk
718                  z_1 (:,jk) = z_1 (:,1)
719               END DO
720
721               CALL wheneq ( jpj*jpk, MIN(surf_jk_atl(:,:)         , 1.e0), 1, 1., ndex_atl     , ndim_atl      ) ! Lat-Depth
722               CALL wheneq ( jpj*jpk, MIN(surf_jk_atl(:,:)*z_1(:,:), 1.e0), 1, 1., ndex_atl_30  , ndim_atl_30   ) ! Lat-Depth
723               CALL wheneq ( jpj    , MIN(surf_jk_atl(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat
724
725               CALL wheneq ( jpj*jpk, MIN(surf_jk_pac(:,:)         , 1.e0), 1, 1., ndex_pac     , ndim_pac      ) ! Lat-Depth
726               CALL wheneq ( jpj*jpk, MIN(surf_jk_pac(:,:)*z_1(:,:), 1.e0), 1, 1., ndex_pac_30  , ndim_pac_30   ) ! Lat-Depth
727               CALL wheneq ( jpj    , MIN(surf_jk_pac(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat
728
729               CALL wheneq ( jpj*jpk, MIN(surf_jk_ind(:,:)         , 1.e0), 1, 1., ndex_ind     , ndim_ind      ) ! Lat-Depth
730               CALL wheneq ( jpj*jpk, MIN(surf_jk_ind(:,:)*z_1(:,:), 1.e0), 1, 1., ndex_ind_30  , ndim_ind_30   ) ! Lat-Depth
731               CALL wheneq ( jpj    , MIN(surf_jk_ind(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat
732
733               CALL wheneq ( jpj*jpk, MIN(surf_jk_ipc(:,:)         , 1.e0), 1, 1., ndex_ipc     , ndim_ipc      ) ! Lat-Depth
734               CALL wheneq ( jpj*jpk, MIN(surf_jk_ipc(:,:)*z_1(:,:), 1.e0), 1, 1., ndex_ipc_30  , ndim_ipc_30   ) ! Lat-Depth
735               CALL wheneq ( jpj    , MIN(surf_jk_ipc(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat
736
737            ENDIF
738
739            !
740#if defined key_diaeiv
741            cl_comment = ' (Bolus part included)'
742#else
743            cl_comment = '                      '
744#endif
745            !  Zonal mean T and S
746
747            IF ( ln_diaznl ) THEN
748               CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" ,   &
749                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
750               CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU"  ,   &
751                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
752
753               CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2"   ,   &
754                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
755
756               IF (ln_subbas) THEN
757                  CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" ,   &
758                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
759                  CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU"  ,   &
760                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
761                  CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2"   ,   &
762                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
763
764                  CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C"  ,   &
765                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
766                  CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU"   ,   &
767                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
768                  CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2"    ,   &
769                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
770
771                  CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C"   ,   &
772                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
773                  CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU"    ,   &
774                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
775                  CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2"     ,   &
776                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
777
778                  CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" ,   &
779                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
780                  CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU"  ,   &
781                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
782                  CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2"   ,   &
783                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
784               ENDIF
785
786            ENDIF
787
788            !  Meridional Stream-Function (Eulerian and Bolus)
789
790            CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" ,   &
791               1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
792            IF( ln_subbas .AND. ln_diaznl ) THEN
793               CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" ,   &
794                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
795               CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv"  ,   &
796                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
797               CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv"   ,   &
798                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
799               CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,&
800                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
801            ENDIF
802
803            !  Heat transport
804
805            CALL histdef( numptr, "sophtadv", "Advective Heat Transport"      ,   &
806               "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
807            CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport"      ,   &
808               "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
809            IF ( ln_ptrcomp ) THEN
810               CALL histdef( numptr, "sophtove", "Overturning Heat Transport"    ,   &
811                  "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
812            END IF
813            IF( ln_subbas ) THEN
814               CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment),  &
815                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
816               CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) ,  &
817                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
818               CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment)  ,  &
819                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
820               CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), &
821                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
822            ENDIF
823
824
825            !  Salt transport
826
827            CALL histdef( numptr, "sopstadv", "Advective Salt Transport"      ,   &
828               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
829            CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport"      ,   &
830               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
831            IF ( ln_ptrcomp ) THEN
832               CALL histdef( numptr, "sopstove", "Overturning Salt Transport"    ,   &
833                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
834            END IF
835#if defined key_diaeiv
836            ! Eddy induced velocity
837            CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global",   &
838               "Sv"      , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
839            CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport",   &
840               "PW"      , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
841            CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport",   &
842               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
843#endif
844            IF( ln_subbas ) THEN
845               CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment)      ,  &
846                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
847               CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment)      ,   &
848                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
849               CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment)      ,    &
850                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
851               CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment),  &
852                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
853            ENDIF
854
855            CALL histend( numptr )
856
857         END IF
858#if defined key_mpp_mpi
859      END IF
860#endif
861
862#if defined key_mpp_mpi
863      IF( MOD( itmod, nf_ptr ) == 0 .AND. l_znl_root ) THEN
864#else
865      IF( MOD( itmod, nf_ptr ) == 0  ) THEN
866#endif
867         niter = niter + 1
868
869!-$$         IF(lwp) THEN
870!-$$            WRITE(numout,*)
871!-$$            WRITE(numout,*) 'dia_ptr_wri : write Poleward Transports at time-step : kt = ', kt, &
872!-$$               & 'it = ', it, ' itmod = ', itmod, ' niter = ', niter
873!-$$            WRITE(numout,*) '~~~~~~~~~~'
874!-$$            WRITE(numout,*)
875!-$$         ENDIF
876
877         IF (ln_diaznl ) THEN
878            CALL histwrite( numptr, "zosrfglo", niter, surf_jk_glo , ndim, ndex )
879            CALL histwrite( numptr, "zotemglo", niter, tn_jk_glo  , ndim, ndex )
880            CALL histwrite( numptr, "zosalglo", niter, sn_jk_glo  , ndim, ndex )
881
882            IF (ln_subbas) THEN
883               CALL histwrite( numptr, "zosrfatl", niter, surf_jk_atl, ndim_atl, ndex_atl )
884               CALL histwrite( numptr, "zosrfpac", niter, surf_jk_pac, ndim_pac, ndex_pac )
885               CALL histwrite( numptr, "zosrfind", niter, surf_jk_ind, ndim_ind, ndex_ind )
886               CALL histwrite( numptr, "zosrfipc", niter, surf_jk_ipc, ndim_ipc, ndex_ipc )
887
888               CALL histwrite( numptr, "zotematl", niter, tn_jk_atl  , ndim_atl, ndex_atl )
889               CALL histwrite( numptr, "zosalatl", niter, sn_jk_atl  , ndim_atl, ndex_atl )
890               CALL histwrite( numptr, "zotempac", niter, tn_jk_pac  , ndim_pac, ndex_pac )
891               CALL histwrite( numptr, "zosalpac", niter, sn_jk_pac  , ndim_pac, ndex_pac )
892               CALL histwrite( numptr, "zotemind", niter, tn_jk_ind  , ndim_ind, ndex_ind )
893               CALL histwrite( numptr, "zosalind", niter, sn_jk_ind  , ndim_ind, ndex_ind )
894               CALL histwrite( numptr, "zotemipc", niter, tn_jk_ipc  , ndim_ipc, ndex_ipc )
895               CALL histwrite( numptr, "zosalipc", niter, sn_jk_ipc  , ndim_ipc, ndex_ipc )
896            END IF
897         ENDIF
898
899         ! overturning outputs:
900         CALL histwrite( numptr, "zomsfglo", niter, v_msf_glo, ndim, ndex )
901         IF( ln_subbas .AND. ln_diaznl ) THEN
902            CALL histwrite( numptr, "zomsfatl", niter, v_msf_atl , ndim_atl_30, ndex_atl_30 )
903            CALL histwrite( numptr, "zomsfpac", niter, v_msf_pac , ndim_pac_30, ndex_pac_30 )
904            CALL histwrite( numptr, "zomsfind", niter, v_msf_ind , ndim_ind_30, ndex_ind_30 )
905            CALL histwrite( numptr, "zomsfipc", niter, v_msf_ipc , ndim_ipc_30, ndex_ipc_30 )
906         ENDIF
907#if defined key_diaeiv
908         CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv_glo, ndim  , ndex   )
909#endif
910
911
912         ! heat transport outputs:
913         IF( ln_subbas ) THEN
914            CALL histwrite( numptr, "sohtatl", niter, ht_atl  , ndim_h_atl_30, ndex_h_atl_30 )
915            CALL histwrite( numptr, "sohtpac", niter, ht_pac  , ndim_h_pac_30, ndex_h_pac_30 )
916            CALL histwrite( numptr, "sohtind", niter, ht_ind  , ndim_h_ind_30, ndex_h_ind_30 )
917            CALL histwrite( numptr, "sohtipc", niter, ht_ipc  , ndim_h_ipc_30, ndex_h_ipc_30 )
918            CALL histwrite( numptr, "sostatl", niter, st_atl  , ndim_h_atl_30, ndex_h_atl_30 )
919            CALL histwrite( numptr, "sostpac", niter, st_pac  , ndim_h_pac_30, ndex_h_pac_30 )
920            CALL histwrite( numptr, "sostind", niter, st_ind  , ndim_h_ind_30, ndex_h_ind_30 )
921            CALL histwrite( numptr, "sostipc", niter, st_ipc  , ndim_h_ipc_30, ndex_h_ipc_30 )
922         ENDIF
923
924         CALL histwrite( numptr, "sophtadv", niter, pht_adv     , ndim_h, ndex_h )
925         CALL histwrite( numptr, "sophtldf", niter, pht_ldf     , ndim_h, ndex_h )
926         CALL histwrite( numptr, "sopstadv", niter, pst_adv     , ndim_h, ndex_h )
927         CALL histwrite( numptr, "sopstldf", niter, pst_ldf     , ndim_h, ndex_h )
928         IF ( ln_ptrcomp ) THEN
929            CALL histwrite( numptr, "sopstove", niter, pst_ove_glo , ndim_h, ndex_h )
930            CALL histwrite( numptr, "sophtove", niter, pht_ove_glo , ndim_h, ndex_h )
931         ENDIF
932#if defined key_diaeiv
933         CALL histwrite( numptr, "sophteiv", niter, pht_eiv_glo  , ndim_h, ndex_h )
934         CALL histwrite( numptr, "sopsteiv", niter, pst_eiv_glo  , ndim_h, ndex_h )
935#endif
936         !
937      ENDIF
938      !
939   END SUBROUTINE dia_ptr_wri
940
941   !!======================================================================
942END MODULE diaptr
Note: See TracBrowser for help on using the repository browser.