source: CONFIG/UNIFORM/v6/IPSLCM6CHT/SOURCES/NEMO/diaptr_oce.F90 @ 2456

Last change on this file since 2456 was 2456, checked in by acosce, 9 years ago

Add new configuration IPSLCM6CHT

File size: 12.9 KB
Line 
1MODULE diaptr_oce
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   !!----------------------------------------------------------------------
11
12   USE par_oce
13   USE dom_oce
14   USE in_out_manager
15   USE lib_mpp
16   USE wrk_nemo
17
18   IMPLICIT NONE
19   PRIVATE
20
21   INTERFACE ptr_vj
22      MODULE PROCEDURE ptr_vj_3d, ptr_vj_2d
23   END INTERFACE
24
25   PUBLIC   ptr_vj         ! call by tra_ldf & tra_adv routines
26   PUBLIC   ptr_vjk        ! call by tra_ldf & tra_adv routines
27   PUBLIC   ptr_tjk        !
28   PUBLIC   dia_ptr_alloc   ! call in opa module
29   !                                  !!** namelist  namptr  **
30   LOGICAL , PUBLIC ::   ln_diaptr     !: Poleward transport flag (T) or not (F)
31   LOGICAL , PUBLIC ::   ln_subbas     !: Atlantic/Pacific/Indian basins calculation
32   LOGICAL , PUBLIC ::   ln_diaznl     !: Add zonal means and meridional stream functions
33   LOGICAL , PUBLIC ::   ln_ptrcomp    !: Add decomposition : overturning (and gyre, soon ...)
34   INTEGER , PUBLIC ::   nn_fptr       !: frequency of ptr computation  [time step]
35   INTEGER , PUBLIC ::   nn_fwri       !: frequency of ptr outputs      [time step]
36
37   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   htr_adv, htr_ldf, htr_ove   !: Heat TRansports (adv, diff, overturn.)
38   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   str_adv, str_ldf, str_ove   !: Salt TRansports (adv, diff, overturn.)
39   
40   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:,:) ::   btmsk                  ! T-point basin interior masks
41   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:)   ::   btm30                  ! mask out Southern Ocean (=0 south of 30°S)
42   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:)   ::   htr  , str             ! adv heat and salt transports (approx)
43   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:,:) ::   tn_jk, sn_jk , v_msf   ! i-mean T and S, j-Stream-Function
44   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:,:) ::   sjk  , r1_sjk          ! i-mean i-k-surface and its inverse       
45   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:)   ::   htr_eiv, str_eiv       ! bolus adv heat ans salt transports ('key_diaeiv')
46   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:,:) ::   v_msf_eiv              ! bolus j-streamfuction              ('key_diaeiv')
47
48
49   INTEGER, SAVE, PUBLIC :: nxline       !
50   INTEGER, PUBLIC ::   niter       !
51   INTEGER, PUBLIC ::   nidom_ptr   !
52   INTEGER, PUBLIC ::   numptr      ! logical unit for Poleward TRansports
53   INTEGER, PUBLIC ::   nptr        ! = 1 (ln_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (ln_subbas=T)
54
55   REAL(wp), PUBLIC ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup
56   REAL(wp), PUBLIC ::   rc_pwatt = 1.e-15_wp  ! conversion from W    to PW (further x rau0 x Cp)
57   REAL(wp), PUBLIC ::   rc_ggram = 1.e-6_wp   ! conversion from g    to Pg
58
59   REAL(wp), PUBLIC, TARGET, DIMENSION(:)  , ALLOCATABLE, SAVE :: p_fval1d
60   REAL(wp), PUBLIC, TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d
61
62   !! Integer, 1D workspace arrays. Not common enough to be implemented in
63   !! wrk_nemo module.
64   INTEGER, ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: ndex  , ndex_atl     , ndex_pac     , ndex_ind     , ndex_ipc
65   INTEGER, ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::         ndex_atl_30  , ndex_pac_30  , ndex_ind_30  , ndex_ipc_30
66   INTEGER, ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30
67
68   !! * Substitutions
69#  include "domzgr_substitute.h90"
70#  include "vectopt_loop_substitute.h90"
71
72CONTAINS
73
74   FUNCTION dia_ptr_alloc()
75      !!----------------------------------------------------------------------
76      !!                    ***  ROUTINE dia_ptr_alloc  ***
77      !!----------------------------------------------------------------------
78      INTEGER               ::   dia_ptr_alloc   ! return value
79      INTEGER, DIMENSION(6) ::   ierr
80      !!----------------------------------------------------------------------
81      ierr(:) = 0
82      !
83      ALLOCATE( btmsk(jpi,jpj,nptr) ,           &
84         &      htr_adv(jpj) , str_adv(jpj) ,   &
85         &      htr_ldf(jpj) , str_ldf(jpj) ,   &
86         &      htr_ove(jpj) , str_ove(jpj),    &
87         &      htr(jpj,nptr) , str(jpj,nptr) , &
88         &      tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , &
89         &      sjk  (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1)  )
90         !
91#if defined key_diaeiv
92      ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , &
93         &      v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) )
94#endif
95      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3))
96      !
97      ALLOCATE( btm30(jpi,jpj), STAT=ierr(4)  )
98
99#if ! defined key_iomput
100      ALLOCATE(ndex(jpj*jpk),        ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), &
101         &     ndex_ind(jpj*jpk),    ndex_ipc(jpj*jpk),                    &
102         &     ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(5))
103
104      ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk),                   &
105         &     ndex_h(jpj),          ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), &
106         &     ndex_h_ind_30(jpj),   ndex_h_ipc_30(jpj), Stat=ierr(6) )
107         !
108#endif
109         !
110      dia_ptr_alloc = MAXVAL( ierr )
111      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc )
112      !
113   END FUNCTION dia_ptr_alloc
114
115
116   FUNCTION ptr_vj_3d( pva )   RESULT ( p_fval )
117      !!----------------------------------------------------------------------
118      !!                    ***  ROUTINE ptr_vj_3d  ***
119      !!
120      !! ** Purpose :   i-k sum computation of a j-flux array
121      !!
122      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
123      !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
124      !!
125      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
126      !!----------------------------------------------------------------------
127      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point
128      !!
129      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments
130      INTEGER                  ::   ijpj         ! ???
131      REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value
132      !!--------------------------------------------------------------------
133      !
134      p_fval => p_fval1d
135
136      ijpj = jpj
137      p_fval(:) = 0._wp
138      DO jk = 1, jpkm1
139         DO jj = 2, jpjm1
140            DO ji = fs_2, fs_jpim1   ! Vector opt.
141               p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 
142            END DO
143         END DO
144      END DO
145#if defined key_mpp_mpi
146      IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl)
147#endif
148      !
149   END FUNCTION ptr_vj_3d
150
151
152   FUNCTION ptr_vj_2d( pva )   RESULT ( p_fval )
153      !!----------------------------------------------------------------------
154      !!                    ***  ROUTINE ptr_vj_2d  ***
155      !!
156      !! ** Purpose :   "zonal" and vertical sum computation of a i-flux array
157      !!
158      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
159      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
160      !!
161      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
162      !!----------------------------------------------------------------------
163      IMPLICIT none
164      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pva   ! mask flux array at V-point
165      !!
166      INTEGER                  ::   ji,jj       ! dummy loop arguments
167      INTEGER                  ::   ijpj        ! ???
168      REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
169      !!--------------------------------------------------------------------
170      !
171      p_fval => p_fval1d
172
173      ijpj = jpj
174      p_fval(:) = 0._wp
175      DO jj = 2, jpjm1
176         DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
177            p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
178         END DO
179      END DO
180#if defined key_mpp_mpi
181      CALL mpp_sum( p_fval, ijpj, ncomm_znl )
182#endif
183      !
184   END FUNCTION ptr_vj_2d
185
186
187   FUNCTION ptr_vjk( pva, pmsk )   RESULT ( p_fval )
188      !!----------------------------------------------------------------------
189      !!                    ***  ROUTINE ptr_vjk  ***
190      !!
191      !! ** Purpose :   i-sum computation of a j-velocity array
192      !!
193      !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i).
194      !!              pva is supposed to be a masked flux (i.e. * vmask)
195      !!
196      !! ** Action  : - p_fval: i-mean poleward flux of pva
197      !!----------------------------------------------------------------------
198      !!
199      IMPLICIT none
200      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pva    ! mask flux array at V-point
201      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask
202      !!
203      INTEGER                           :: ji, jj, jk ! dummy loop arguments
204      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value
205#if defined key_mpp_mpi
206      INTEGER, DIMENSION(1) ::   ish
207      INTEGER, DIMENSION(2) ::   ish2
208      INTEGER               ::   ijpjjpk
209#endif
210#if defined key_mpp_mpi
211      REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point
212#endif
213      !!--------------------------------------------------------------------
214      !
215#if defined key_mpp_mpi
216      ijpjjpk = jpj*jpk
217      CALL wrk_alloc( jpj*jpk, zwork )
218#endif
219
220      p_fval => p_fval2d
221
222      p_fval(:,:) = 0._wp
223      !
224      IF( PRESENT( pmsk ) ) THEN
225         DO jk = 1, jpkm1
226            DO jj = 2, jpjm1
227!!gm here, use of tmask_i  ==> no need of loop over nldi, nlei....
228               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
229                  p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * pmsk(ji,jj)
230               END DO
231            END DO
232         END DO
233      ELSE
234         DO jk = 1, jpkm1
235            DO jj = 2, jpjm1
236               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
237                  p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji,jj)
238               END DO
239            END DO
240         END DO
241      END IF
242      !
243#if defined key_mpp_mpi
244      ijpjjpk = jpj*jpk
245      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk
246      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
247      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
248      p_fval(:,:) = RESHAPE( zwork, ish2 )
249#endif
250      !
251#if defined key_mpp_mpi
252      CALL wrk_dealloc( jpj*jpk, zwork )
253#endif
254      !
255   END FUNCTION ptr_vjk
256
257
258   FUNCTION ptr_tjk( pta, pmsk )   RESULT ( p_fval )
259      !!----------------------------------------------------------------------
260      !!                    ***  ROUTINE ptr_tjk  ***
261      !!
262      !! ** Purpose :   i-sum computation of e1t*e3t * a tracer field
263      !!
264      !! ** Method  : - i-sum of mj(pta) using tmask
265      !!
266      !! ** Action  : - p_fval: i-sum of e1t*e3t*pta
267      !!----------------------------------------------------------------------
268      !!
269      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point
270      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask
271      !!
272      INTEGER                           :: ji, jj, jk   ! dummy loop arguments
273      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval       ! return function value
274#if defined key_mpp_mpi
275      INTEGER, DIMENSION(1) ::   ish
276      INTEGER, DIMENSION(2) ::   ish2
277      INTEGER               ::   ijpjjpk
278#endif
279#if defined key_mpp_mpi
280      REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point
281#endif
282      !!--------------------------------------------------------------------
283      !
284#if defined key_mpp_mpi
285      ijpjjpk = jpj*jpk
286      CALL wrk_alloc( jpj*jpk, zwork )
287#endif
288
289      p_fval => p_fval2d
290
291      p_fval(:,:) = 0._wp
292      DO jk = 1, jpkm1
293         DO jj = 2, jpjm1
294            DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
295               p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj)
296            END DO
297         END DO
298      END DO
299#if defined key_mpp_mpi
300      ijpjjpk = jpj*jpk
301      ish(1) = jpj*jpk   ;   ish2(1) = jpj   ;   ish2(2) = jpk
302      zwork(1:ijpjjpk)= RESHAPE( p_fval, ish )
303      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
304      p_fval(:,:)= RESHAPE( zwork, ish2 )
305#endif
306      !
307#if defined key_mpp_mpi
308      CALL wrk_dealloc( jpj*jpk, zwork )
309#endif
310      !   
311   END FUNCTION ptr_tjk
312
313   !!======================================================================
314END MODULE diaptr_oce
Note: See TracBrowser for help on using the repository browser.