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 branches/UKMO/dev_r5518_GC3p0_package_v2/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

source: branches/UKMO/dev_r5518_GC3p0_package_v2/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 6679

Last change on this file since 6679 was 6679, checked in by malcolmroberts, 8 years ago

Merged in changes from v3_6_extra_CMIP6_diagnostics up to revision 6674

File size: 25.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   !!----------------------------------------------------------------------
12
13   !!----------------------------------------------------------------------
14   !!   dia_ptr      : Poleward Transport Diagnostics module
15   !!   dia_ptr_init : Initialization, namelist read
16   !!   ptr_sjk      : "zonal" mean computation of a field - tracer or flux array
17   !!   ptr_sj       : "zonal" and vertical sum computation of a "meridional" flux array
18   !!                   (Generic interface to ptr_sj_3d, ptr_sj_2d)
19   !!----------------------------------------------------------------------
20   USE oce              ! ocean dynamics and active tracers
21   USE dom_oce          ! ocean space and time domain
22   USE phycst           ! physical constants
23   USE ldftra_oce 
24   !
25   USE iom              ! IOM library
26   USE in_out_manager   ! I/O manager
27   USE lib_mpp          ! MPP library
28   USE timing           ! preformance summary
29
30   IMPLICIT NONE
31   PRIVATE
32
33   INTERFACE ptr_sj
34      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d
35   END INTERFACE
36
37   PUBLIC   ptr_sj         ! call by tra_ldf & tra_adv routines
38   PUBLIC   ptr_sjk        !
39   PUBLIC   dia_ptr_init   ! call in step module
40   PUBLIC   dia_ptr        ! call in step module
41   PUBLIC   dia_ptr_ohst_components        ! called from tra_ldf/tra_adv routines
42
43   !                                  !!** namelist  namptr  **
44   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_adv, htr_ldf, htr_eiv, htr_vt   !: Heat TRansports (adv, diff, Bolus.)
45   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   str_adv, str_ldf, str_eiv, str_vs   !: Salt TRansports (adv, diff, Bolus.)
46
47   LOGICAL, PUBLIC ::   ln_diaptr   !  Poleward transport flag (T) or not (F)
48   LOGICAL, PUBLIC ::   ln_subbas   !  Atlantic/Pacific/Indian basins calculation
49   INTEGER, PUBLIC ::   nptr        ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)
50
51   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup
52   REAL(wp) ::   rc_pwatt = 1.e-15_wp  ! conversion from W    to PW (further x rau0 x Cp)
53   REAL(wp) ::   rc_ggram = 1.e-6_wp   ! conversion from g    to Pg
54
55   CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:)     :: clsubb
56   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk   ! T-point basin interior masks
57   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   :: btm30   ! mask out Southern Ocean (=0 south of 30°S)
58
59   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)     :: p_fval1d
60   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:)   :: p_fval2d
61
62
63   !! * Substitutions
64#  include "domzgr_substitute.h90"
65#  include "vectopt_loop_substitute.h90"
66   !!----------------------------------------------------------------------
67   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
68   !! $Id$
69   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
70   !!----------------------------------------------------------------------
71CONTAINS
72
73   SUBROUTINE dia_ptr( pvtr )
74      !!----------------------------------------------------------------------
75      !!                  ***  ROUTINE dia_ptr  ***
76      !!----------------------------------------------------------------------
77      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport
78      !
79      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
80      REAL(wp) ::   zv, zsfc               ! local scalar
81      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace
82      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d   ! 3D workspace
83      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace
84      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace
85      CHARACTER( len = 12 )  :: cl1
86      !!----------------------------------------------------------------------
87      !
88      IF( nn_timing == 1 )   CALL timing_start('dia_ptr')
89
90      !
91      IF( PRESENT( pvtr ) ) THEN
92         IF( iom_use("zomsfglo") ) THEN    ! effective MSF
93            z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) )  ! zonal cumulative effective transport
94            DO jk = 2, jpkm1 
95              z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)   ! effective j-Stream-Function (MSF)
96            END DO
97            DO ji = 1, jpi
98               z3d(ji,:,:) = z3d(1,:,:)
99            ENDDO
100            cl1 = TRIM('zomsf'//clsubb(1) )
101            CALL iom_put( cl1, z3d * rc_sv )
102            DO jn = 2, nptr                                    ! by sub-basins
103               z3d(1,:,:) =  ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 
104               DO jk = 2, jpkm1 
105                  z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)    ! effective j-Stream-Function (MSF)
106               END DO
107               DO ji = 1, jpi
108                  z3d(ji,:,:) = z3d(1,:,:)
109               ENDDO
110               cl1 = TRIM('zomsf'//clsubb(jn) )
111               CALL iom_put( cl1, z3d * rc_sv )
112            END DO
113         ENDIF
114         !
115      ELSE
116         !
117         IF( iom_use("zotemglo") ) THEN    ! i-mean i-k-surface
118            DO jk = 1, jpkm1
119               DO jj = 1, jpj
120                  DO ji = 1, jpi
121                     zsfc = e1t(ji,jj) * fse3t(ji,jj,jk)
122                     zmask(ji,jj,jk)      = tmask(ji,jj,jk)      * zsfc
123                     zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc
124                     zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc
125                  ENDDO
126               ENDDO
127            ENDDO
128            DO jn = 1, nptr
129               zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
130               cl1 = TRIM('zosrf'//clsubb(jn) )
131               CALL iom_put( cl1, zmask )
132               !
133               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
134                  &            / MAX( zmask(1,:,:), 10.e-15 )
135               DO ji = 1, jpi
136                  z3d(ji,:,:) = z3d(1,:,:)
137               ENDDO
138               cl1 = TRIM('zotem'//clsubb(jn) )
139               CALL iom_put( cl1, z3d )
140               !
141               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
142                  &            / MAX( zmask(1,:,:), 10.e-15 )
143               DO ji = 1, jpi
144                  z3d(ji,:,:) = z3d(1,:,:)
145               ENDDO
146               cl1 = TRIM('zosal'//clsubb(jn) )
147               CALL iom_put( cl1, z3d )
148            END DO
149         ENDIF
150         !
151         !                                ! Advective and diffusive heat and salt transport
152         IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN   
153            z2d(1,:) = htr_adv(:,1) * rc_pwatt        !  (conversion in PW)
154            DO ji = 1, jpi
155               z2d(ji,:) = z2d(1,:)
156            ENDDO
157            cl1 = 'sophtadv'                 
158            CALL iom_put( TRIM(cl1), z2d )
159            z2d(1,:) = str_adv(:,1) * rc_ggram        ! (conversion in Gg)
160            DO ji = 1, jpi
161               z2d(ji,:) = z2d(1,:)
162            ENDDO
163            cl1 = 'sopstadv'
164            CALL iom_put( TRIM(cl1), z2d )
165            IF( ln_subbas ) THEN
166              DO jn=2,nptr
167               z2d(1,:) = htr_adv(:,jn) * rc_pwatt        !  (conversion in PW)
168               DO ji = 1, jpi
169                 z2d(ji,:) = z2d(1,:)
170               ENDDO
171               cl1 = TRIM('sophtadv_'//clsubb(jn))                 
172               CALL iom_put( cl1, z2d )
173               z2d(1,:) = str_adv(:,jn) * rc_ggram        ! (conversion in Gg)
174               DO ji = 1, jpi
175                  z2d(ji,:) = z2d(1,:)
176               ENDDO
177               cl1 = TRIM('sopstadv_'//clsubb(jn))                 
178               CALL iom_put( cl1, z2d )             
179              ENDDO
180            ENDIF
181         ENDIF
182         !
183         IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN   
184            z2d(1,:) = htr_ldf(:,1) * rc_pwatt        !  (conversion in PW)
185            DO ji = 1, jpi
186               z2d(ji,:) = z2d(1,:)
187            ENDDO
188            cl1 = 'sophtldf'
189            CALL iom_put( TRIM(cl1), z2d )
190            z2d(1,:) = str_ldf(:,1) * rc_ggram        !  (conversion in Gg)
191            DO ji = 1, jpi
192               z2d(ji,:) = z2d(1,:)
193            ENDDO
194            cl1 = 'sopstldf'
195            CALL iom_put( TRIM(cl1), z2d )
196            IF( ln_subbas ) THEN
197              DO jn=2,nptr
198               z2d(1,:) = htr_ldf(:,jn) * rc_pwatt        !  (conversion in PW)
199               DO ji = 1, jpi
200                 z2d(ji,:) = z2d(1,:)
201               ENDDO
202               cl1 = TRIM('sophtldf_'//clsubb(jn))                 
203               CALL iom_put( cl1, z2d )
204               z2d(1,:) = str_ldf(:,jn) * rc_ggram        ! (conversion in Gg)
205               DO ji = 1, jpi
206                  z2d(ji,:) = z2d(1,:)
207               ENDDO
208               cl1 = TRIM('sopstldf_'//clsubb(jn))                 
209               CALL iom_put( cl1, z2d )             
210              ENDDO
211            ENDIF
212         ENDIF
213
214         IF( iom_use("sopht_vt") .OR. iom_use("sopst_vs") ) THEN   
215            z2d(1,:) = htr_vt(:,1) * rc_pwatt        !  (conversion in PW)
216            DO ji = 1, jpi
217               z2d(ji,:) = z2d(1,:)
218            ENDDO
219            cl1 = 'sopht_vt'
220            CALL iom_put( TRIM(cl1), z2d )
221            z2d(1,:) = str_vs(:,1) * rc_ggram        !  (conversion in Gg)
222            DO ji = 1, jpi
223               z2d(ji,:) = z2d(1,:)
224            ENDDO
225            cl1 = 'sopst_vs'
226            CALL iom_put( TRIM(cl1), z2d )
227            IF( ln_subbas ) THEN
228              DO jn=2,nptr
229               z2d(1,:) = htr_vt(:,jn) * rc_pwatt        !  (conversion in PW)
230               DO ji = 1, jpi
231                 z2d(ji,:) = z2d(1,:)
232               ENDDO
233               cl1 = TRIM('sopht_vt_'//clsubb(jn))                 
234               CALL iom_put( cl1, z2d )
235               z2d(1,:) = str_vs(:,jn) * rc_ggram        ! (conversion in Gg)
236               DO ji = 1, jpi
237                  z2d(ji,:) = z2d(1,:)
238               ENDDO
239               cl1 = TRIM('sopst_vs_'//clsubb(jn))                 
240               CALL iom_put( cl1, z2d )             
241              ENDDO
242            ENDIF
243         ENDIF
244
245#ifdef key_diaeiv
246         IF(lk_traldf_eiv) THEN
247            IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN
248               z2d(1,:) = htr_eiv(:,1) * rc_pwatt        !  (conversion in PW)
249               DO ji = 1, jpi
250                  z2d(ji,:) = z2d(1,:)
251               ENDDO
252               cl1 = 'sophteiv'
253               CALL iom_put( TRIM(cl1), z2d )
254               z2d(1,:) = str_eiv(:,1) * rc_ggram        !  (conversion in Gg)
255               DO ji = 1, jpi
256                  z2d(ji,:) = z2d(1,:)
257               ENDDO
258               cl1 = 'sopsteiv'
259               CALL iom_put( TRIM(cl1), z2d )
260               IF( ln_subbas ) THEN
261                  DO jn=2,nptr
262                     z2d(1,:) = htr_eiv(:,jn) * rc_pwatt        !  (conversion in PW)
263                     DO ji = 1, jpi
264                        z2d(ji,:) = z2d(1,:)
265                     ENDDO
266                     cl1 = TRIM('sophteiv_'//clsubb(jn))                 
267                     CALL iom_put( cl1, z2d )
268                     z2d(1,:) = str_eiv(:,jn) * rc_ggram        ! (conversion in Gg)
269                     DO ji = 1, jpi
270                        z2d(ji,:) = z2d(1,:)
271                     ENDDO
272                     cl1 = TRIM('sopsteiv_'//clsubb(jn)) 
273                     CALL iom_put( cl1, z2d )             
274                  ENDDO
275               ENDIF
276            ENDIF
277         ENDIF
278#endif
279         !
280      ENDIF
281      !
282      IF( nn_timing == 1 )   CALL timing_stop('dia_ptr')
283      !
284   END SUBROUTINE dia_ptr
285
286
287   SUBROUTINE dia_ptr_init
288      !!----------------------------------------------------------------------
289      !!                  ***  ROUTINE dia_ptr_init  ***
290      !!                   
291      !! ** Purpose :   Initialization, namelist read
292      !!----------------------------------------------------------------------
293      INTEGER ::  jn           ! local integers
294      INTEGER ::  inum, ierr   ! local integers
295      INTEGER ::  ios          ! Local integer output status for namelist read
296      !!
297      NAMELIST/namptr/ ln_diaptr, ln_subbas
298      !!----------------------------------------------------------------------
299
300      REWIND( numnam_ref )              ! Namelist namptr in reference namelist : Poleward transport
301      READ  ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
302901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp )
303
304      REWIND( numnam_cfg )              ! Namelist namptr in configuration namelist : Poleward transport
305      READ  ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
306902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp )
307      IF(lwm) WRITE ( numond, namptr )
308
309      IF(lwp) THEN                     ! Control print
310         WRITE(numout,*)
311         WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
312         WRITE(numout,*) '~~~~~~~~~~~~'
313         WRITE(numout,*) '   Namelist namptr : set ptr parameters'
314         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      ln_diaptr  = ', ln_diaptr
315         WRITE(numout,*) '      Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins      ln_subbas  = ', ln_subbas
316      ENDIF
317
318      IF( ln_diaptr ) THEN 
319         !
320         IF( ln_subbas ) THEN
321            nptr = 5            ! Global, Atlantic, Pacific, Indian, Indo-Pacific
322            ALLOCATE( clsubb(nptr) )
323            clsubb(1) = 'glo' ;  clsubb(2) = 'atl'  ;  clsubb(3) = 'pac'  ;  clsubb(4) = 'ind'  ;  clsubb(5) = 'ipc'
324         ELSE               
325            nptr = 1       ! Global only
326            ALLOCATE( clsubb(nptr) )
327            clsubb(1) = 'glo' 
328         ENDIF
329
330         !                                      ! allocate dia_ptr arrays
331         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
332
333         rc_pwatt = rc_pwatt * rau0_rcp          ! conversion from K.s-1 to PetaWatt
334
335         IF( lk_mpp )   CALL mpp_ini_znl( numout )     ! Define MPI communicator for zonal sum
336
337         IF( ln_subbas ) THEN                ! load sub-basin mask
338            CALL iom_open( 'subbasins', inum,  ldstop = .FALSE.  )
339            CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin
340            CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin
341            CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) )   ! Indian   basin
342            CALL iom_close( inum )
343            btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )          ! Indo-Pacific basin
344            WHERE( gphit(:,:) < -30._wp)   ;   btm30(:,:) = 0._wp      ! mask out Southern Ocean
345            ELSE WHERE                     ;   btm30(:,:) = ssmask(:,:)
346            END WHERE
347         ENDIF
348   
349         btmsk(:,:,1) = tmask_i(:,:)                                   ! global ocean
350     
351         DO jn = 1, nptr
352            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)               ! interior domain only
353         END DO
354
355         ! Initialise arrays to zero because diatpr is called before they are first calculated
356         ! Note that this means diagnostics will not be exactly correct when model run is restarted.
357         htr_adv(:,:) = 0._wp  ;  str_adv(:,:) =  0._wp 
358         htr_ldf(:,:) = 0._wp  ;  str_ldf(:,:) =  0._wp 
359         htr_eiv(:,:) = 0._wp  ;  str_eiv(:,:) =  0._wp 
360         htr_vt(:,:) = 0._wp  ;   str_vs(:,:) =  0._wp 
361         !
362      ENDIF 
363      !
364   END SUBROUTINE dia_ptr_init
365
366   SUBROUTINE dia_ptr_ohst_components( ktra, cptr, pva ) 
367      !!----------------------------------------------------------------------
368      !!                    ***  ROUTINE dia_ptr_ohst_components  ***
369      !!----------------------------------------------------------------------
370      !! Wrapper for heat and salt transport calculations to calculate them for each basin
371      !! Called from all advection and/or diffusion routines
372      !!----------------------------------------------------------------------
373      INTEGER                         , INTENT(in )  :: ktra  ! tracer index
374      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf'/'eiv'
375      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pva   ! 3D input array of advection/diffusion
376      INTEGER                                        :: jn    !
377
378     
379      IF( cptr == 'adv' ) THEN
380         IF( ktra == jp_tem )  htr_adv(:,1) = ptr_sj( pva(:,:,:) )
381         IF( ktra == jp_sal )  str_adv(:,1) = ptr_sj( pva(:,:,:) )
382      ENDIF
383      IF( cptr == 'ldf' ) THEN
384         IF( ktra == jp_tem )  htr_ldf(:,1) = ptr_sj( pva(:,:,:) )
385         IF( ktra == jp_sal )  str_ldf(:,1) = ptr_sj( pva(:,:,:) )
386      ENDIF
387      IF( cptr == 'eiv' ) THEN
388         IF( ktra == jp_tem )  htr_eiv(:,1) = ptr_sj( pva(:,:,:) )
389         IF( ktra == jp_sal )  str_eiv(:,1) = ptr_sj( pva(:,:,:) )
390      ENDIF
391      IF( cptr == 'vts' ) THEN
392         IF( ktra == jp_tem )  htr_vt(:,1) = ptr_sj( pva(:,:,:) )
393         IF( ktra == jp_sal )  str_vs(:,1) = ptr_sj( pva(:,:,:) )
394      ENDIF
395      !
396      IF( ln_subbas ) THEN
397         !
398         IF( cptr == 'adv' ) THEN
399             IF( ktra == jp_tem ) THEN
400                DO jn = 2, nptr
401                   htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
402                END DO
403             ENDIF
404             IF( ktra == jp_sal ) THEN
405                DO jn = 2, nptr
406                   str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
407                END DO
408             ENDIF
409         ENDIF
410         IF( cptr == 'ldf' ) THEN
411             IF( ktra == jp_tem ) THEN
412                DO jn = 2, nptr
413                    htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
414                 END DO
415             ENDIF
416             IF( ktra == jp_sal ) THEN
417                DO jn = 2, nptr
418                   str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
419                END DO
420             ENDIF
421         ENDIF
422         IF( cptr == 'eiv' ) THEN
423             IF( ktra == jp_tem ) THEN
424                DO jn = 2, nptr
425                    htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
426                 END DO
427             ENDIF
428             IF( ktra == jp_sal ) THEN
429                DO jn = 2, nptr
430                   str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
431                END DO
432             ENDIF
433         ENDIF
434         IF( cptr == 'vts' ) THEN
435             IF( ktra == jp_tem ) THEN
436                DO jn = 2, nptr
437                    htr_vt(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
438                 END DO
439             ENDIF
440             IF( ktra == jp_sal ) THEN
441                DO jn = 2, nptr
442                   str_vs(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
443                END DO
444             ENDIF
445         ENDIF
446         !
447      ENDIF
448
449   END SUBROUTINE
450
451
452   FUNCTION dia_ptr_alloc()
453      !!----------------------------------------------------------------------
454      !!                    ***  ROUTINE dia_ptr_alloc  ***
455      !!----------------------------------------------------------------------
456      INTEGER               ::   dia_ptr_alloc   ! return value
457      INTEGER, DIMENSION(3) ::   ierr
458      !!----------------------------------------------------------------------
459      ierr(:) = 0
460      !
461      ALLOCATE( btmsk(jpi,jpj,nptr) ,           &
462         &      htr_adv(jpj,nptr) , str_adv(jpj,nptr) ,   &
463         &      htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) ,   &
464         &      htr_vt(jpj,nptr)  , str_vs(jpj,nptr)  ,   &
465         &      htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1)  )
466         !
467      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
468      !
469      ALLOCATE( btm30(jpi,jpj), STAT=ierr(3)  )
470
471         !
472      dia_ptr_alloc = MAXVAL( ierr )
473      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc )
474      !
475   END FUNCTION dia_ptr_alloc
476
477
478   FUNCTION ptr_sj_3d( pva, pmsk )   RESULT ( p_fval )
479      !!----------------------------------------------------------------------
480      !!                    ***  ROUTINE ptr_sj_3d  ***
481      !!
482      !! ** Purpose :   i-k sum computation of a j-flux array
483      !!
484      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
485      !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
486      !!
487      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
488      !!----------------------------------------------------------------------
489      REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)       ::   pva   ! mask flux array at V-point
490      REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask
491      !
492      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments
493      INTEGER                  ::   ijpj         ! ???
494      REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value
495      !!--------------------------------------------------------------------
496      !
497      p_fval => p_fval1d
498
499      ijpj = jpj
500      p_fval(:) = 0._wp
501      IF( PRESENT( pmsk ) ) THEN
502         DO jk = 1, jpkm1
503            DO jj = 2, jpjm1
504               DO ji = fs_2, fs_jpim1   ! Vector opt.
505                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj)
506               END DO
507            END DO
508         END DO
509      ELSE
510         DO jk = 1, jpkm1
511            DO jj = 2, jpjm1
512               DO ji = fs_2, fs_jpim1   ! Vector opt.
513                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 
514               END DO
515            END DO
516         END DO
517      ENDIF
518#if defined key_mpp_mpi
519      IF(lk_mpp)   CALL mpp_sum( 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), OPTIONAL ::   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      IF( PRESENT( pmsk ) ) THEN
549         DO jj = 2, jpjm1
550            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
551               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj)
552            END DO
553         END DO
554      ELSE
555         DO jj = 2, jpjm1
556            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
557               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
558            END DO
559         END DO
560      ENDIF
561#if defined key_mpp_mpi
562      CALL mpp_sum( p_fval, ijpj, ncomm_znl )
563#endif
564      !
565   END FUNCTION ptr_sj_2d
566
567
568   FUNCTION ptr_sjk( pta, pmsk )   RESULT ( p_fval )
569      !!----------------------------------------------------------------------
570      !!                    ***  ROUTINE ptr_sjk  ***
571      !!
572      !! ** Purpose :   i-sum computation of an array
573      !!
574      !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i).
575      !!
576      !! ** Action  : - p_fval: i-mean poleward flux of pva
577      !!----------------------------------------------------------------------
578      !!
579      IMPLICIT none
580      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pta    ! mask flux array at V-point
581      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask
582      !!
583      INTEGER                           :: ji, jj, jk ! dummy loop arguments
584      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value
585#if defined key_mpp_mpi
586      INTEGER, DIMENSION(1) ::   ish
587      INTEGER, DIMENSION(2) ::   ish2
588      INTEGER               ::   ijpjjpk
589      REAL(wp), DIMENSION(jpj*jpk) ::   zwork    ! mask flux array at V-point
590#endif
591      !!--------------------------------------------------------------------
592      !
593      p_fval => p_fval2d
594
595      p_fval(:,:) = 0._wp
596      !
597      IF( PRESENT( pmsk ) ) THEN
598         DO jk = 1, jpkm1
599            DO jj = 2, jpjm1
600!!gm here, use of tmask_i  ==> no need of loop over nldi, nlei....
601               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
602                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj)
603               END DO
604            END DO
605         END DO
606      ELSE
607         DO jk = 1, jpkm1
608            DO jj = 2, jpjm1
609               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
610                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj)
611               END DO
612            END DO
613         END DO
614      END IF
615      !
616#if defined key_mpp_mpi
617      ijpjjpk = jpj*jpk
618      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk
619      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
620      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
621      p_fval(:,:) = RESHAPE( zwork, ish2 )
622#endif
623      !
624   END FUNCTION ptr_sjk
625
626
627   !!======================================================================
628END MODULE diaptr
Note: See TracBrowser for help on using the repository browser.