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

Context Navigation

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

Last change on this file since 1317 was 1317, checked in by smasson, 15 years ago
nwrite = modulo referenced to nit000 in all ouputs, see ticket:339
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 26.1 KB

Rev	Line
[134]	1	MODULE diaptr
	2	!!======================================================================
	3	!! * MODULE diaptr *
	4	!! Ocean physics: brief description of the purpose of the module
	5	!! (please no more than 2 lines)
	6	!!=====================================================================
[508]	7	!! History : 9.0 ! 03-09 (C. Talandir, G. Madec) Original code
	8	!! 9.0 ! 06-01 (A. Biastoch) Allow sub-basins computation
[134]	9	!!----------------------------------------------------------------------
[508]	10
	11	!!----------------------------------------------------------------------
[134]	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_vtjk : "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 ! ???
	23	USE lib_mpp
	24	USE in_out_manager
	25	USE dianam
	26	USE phycst
[508]	27	USE iom
	28	USE ioipsl
[460]	29	USE daymod
[134]	30
	31	IMPLICIT NONE
	32	PRIVATE
	33
	34	INTERFACE ptr_vj
	35	MODULE PROCEDURE ptr_vj_3d, ptr_vj_2d
	36	END INTERFACE
	37
[508]	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
[134]	42
[508]	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	INTEGER , PUBLIC :: nf_ptr = 15 !: frequency of ptr computation
	47
	48	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_adv, pst_adv !: heat and salt poleward transport: advection
	49	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove, pst_ove !: heat and salt poleward transport: overturning
	50	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ldf, pst_ldf !: heat and salt poleward transport: lateral diffusion
[406]	51	#if defined key_diaeiv
[508]	52	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv, pst_eiv !: heat and salt poleward transport: bolus advection
[406]	53	#endif
[508]	54	REAL(wp), PUBLIC, DIMENSION(jpj) :: ht_atl,ht_ind,ht_pac !: heat
	55	REAL(wp), PUBLIC, DIMENSION(jpj) :: st_atl,st_ind,st_pac !: salt
	56
[406]	57
[134]	58
[508]	59	REAL(wp), DIMENSION(jpj,jpk) :: tn_jk , sn_jk , & !: "zonal" mean temperature and salinity
	60	& v_msf_atl , & !: "meridional" Stream-Function
	61	& v_msf_glo , & !: "meridional" Stream-Function
	62	& v_msf_ipc , & !: "meridional" Stream-Function
	63	& surf_jk_r !: inverse of the ocean "zonal" section surface
[134]	64	#if defined key_diaeiv
[508]	65	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv !: bolus "meridional" Stream-Function
[134]	66	#endif
[508]	67	REAL(wp), DIMENSION(jpi,jpj) :: abasin, pbasin, ibasin !: return function value
[134]	68
	69	!! * Substitutions
	70	# include "domzgr_substitute.h90"
	71	# include "vectopt_loop_substitute.h90"
	72	!!----------------------------------------------------------------------
[247]	73	!! OPA 9.0 , LOCEAN-IPSL (2005)
[1152]	74	!! $Id$
[508]	75	!! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
[134]	76	!!----------------------------------------------------------------------
	77
	78	CONTAINS
	79
	80	FUNCTION ptr_vj_3d( pva ) RESULT ( p_fval )
	81	!!----------------------------------------------------------------------
	82	!! * ROUTINE ptr_vj_3d *
	83	!!
	84	!! ** Purpose : "zonal" and vertical sum computation of a "meridional"
	85	!! flux array
	86	!!
	87	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
	88	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
	89	!!
	90	!! ** Action : - p_fval: i-k-mean poleward flux of pva
[508]	91	!!----------------------------------------------------------------------
	92	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
[134]	93	!!
[508]	94	INTEGER :: ji, jj, jk ! dummy loop arguments
	95	INTEGER :: ijpj ! ???
	96	REAL(wp), DIMENSION(jpj) :: p_fval ! function value
[134]	97	!!--------------------------------------------------------------------
[508]	98	!
[389]	99	ijpj = jpj
[134]	100	p_fval(:) = 0.e0
	101	DO jk = 1, jpkm1
	102	DO jj = 2, jpjm1
	103	DO ji = fs_2, fs_jpim1 ! Vector opt.
	104	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj+1) * tmask_i(ji,jj)
	105	END DO
	106	END DO
	107	END DO
[508]	108	!
[134]	109	IF( lk_mpp ) CALL mpp_sum( p_fval, ijpj ) !!bug I presume
[508]	110	!
[134]	111	END FUNCTION ptr_vj_3d
	112
	113
	114	FUNCTION ptr_vj_2d( pva ) RESULT ( p_fval )
	115	!!----------------------------------------------------------------------
	116	!! * ROUTINE ptr_vj_2d *
	117	!!
	118	!! ** Purpose : "zonal" and vertical sum computation of a "meridional"
	119	!! flux array
	120	!!
	121	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
	122	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
	123	!!
	124	!! ** Action : - p_fval: i-k-mean poleward flux of pva
[508]	125	!!----------------------------------------------------------------------
	126	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
[134]	127	!!
[508]	128	INTEGER :: ji,jj ! dummy loop arguments
	129	INTEGER :: ijpj ! ???
	130	REAL(wp), DIMENSION(jpj) :: p_fval ! function value
[134]	131	!!--------------------------------------------------------------------
[508]	132	!
[389]	133	ijpj = jpj
[134]	134	p_fval(:) = 0.e0
	135	DO jj = 2, jpjm1
	136	DO ji = fs_2, fs_jpim1 ! Vector opt.
	137	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj+1) * tmask_i(ji,jj)
	138	END DO
	139	END DO
[508]	140	!
[134]	141	IF( lk_mpp ) CALL mpp_sum( p_fval, ijpj ) !!bug I presume
[508]	142	!
	143	END FUNCTION ptr_vj_2d
[134]	144
	145
	146	FUNCTION ptr_vjk( pva ) RESULT ( p_fval )
	147	!!----------------------------------------------------------------------
	148	!! * ROUTINE ptr_vjk *
	149	!!
	150	!! ** Purpose : "zonal" sum computation of a "meridional" flux array
	151	!!
	152	!! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).
	153	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
	154	!!
	155	!! ** Action : - p_fval: i-k-mean poleward flux of pva
[508]	156	!!----------------------------------------------------------------------
	157	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
[134]	158	!!
[508]	159	INTEGER :: ji, jj, jk ! dummy loop arguments
	160	INTEGER , DIMENSION (1) :: ish
	161	INTEGER , DIMENSION (2) :: ish2
	162	REAL(wp), DIMENSION(jpj*jpk) :: zwork ! temporary vector for mpp_sum
	163	REAL(wp), DIMENSION(jpj,jpk) :: p_fval ! return function value
[134]	164	!!--------------------------------------------------------------------
[508]	165	!
[134]	166	p_fval(:,:) = 0.e0
[508]	167	!
[134]	168	DO jk = 1, jpkm1
	169	DO jj = 2, jpjm1
[406]	170	DO ji = fs_2, fs_jpim1
[460]	171	p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) &
	172	& * tmask_i(ji,jj+1) * tmask_i(ji,jj)
[406]	173	END DO
[134]	174	END DO
	175	END DO
[508]	176	!
[460]	177	IF(lk_mpp) THEN
	178	ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk
	179	zwork(:)= RESHAPE( p_fval, ish )
	180	CALL mpp_sum( zwork, jpj*jpk )
	181	p_fval(:,:)= RESHAPE( zwork, ish2 )
[184]	182	END IF
[508]	183	!
[134]	184	END FUNCTION ptr_vjk
	185
[508]	186
[134]	187	FUNCTION ptr_vtjk( pva ) RESULT ( p_fval )
	188	!!----------------------------------------------------------------------
	189	!! * ROUTINE ptr_vtjk *
	190	!!
	191	!! ** Purpose : "zonal" mean computation of a tracer field
	192	!!
	193	!! ** Method : - i-sum of mj(pva) using the interior 2D vmask (vmask_i)
	194	!! multiplied by the inverse of the surface of the "zonal" ocean
	195	!! section
	196	!!
	197	!! ** Action : - p_fval: i-k-mean poleward flux of pva
[508]	198	!!----------------------------------------------------------------------
	199	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
[134]	200	!!
[508]	201	INTEGER :: ji, jj, jk ! dummy loop arguments
	202	INTEGER, DIMENSION (1) :: ish
	203	INTEGER, DIMENSION (2) :: ish2
	204	REAL(wp),DIMENSION(jpj*jpk) :: zwork ! temporary vector for mpp_sum
	205	REAL(wp),DIMENSION(jpj,jpk) :: p_fval ! return function value
[134]	206	!!--------------------------------------------------------------------
[508]	207	!
[134]	208	p_fval(:,:) = 0.e0
	209	DO jk = 1, jpkm1
	210	DO jj = 2, jpjm1
	211	DO ji = fs_2, fs_jpim1 ! Vector opt.
	212	p_fval(jj,jk) = p_fval(jj,jk) + ( pva(ji,jj,jk) + pva(ji,jj+1,jk) ) &
	213	& * e1v(ji,jj) * fse3v(ji,jj,jk) * vmask(ji,jj,jk) &
	214	& * tmask_i(ji,jj+1) * tmask_i(ji,jj)
	215	END DO
	216	END DO
	217	END DO
	218	p_fval(:,:) = p_fval(:,:) * 0.5
[460]	219	IF(lk_mpp) THEN
	220	ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk
	221	zwork(:)= RESHAPE( p_fval, ish )
	222	CALL mpp_sum( zwork, jpj*jpk )
[406]	223	p_fval(:,:)= RESHAPE(zwork,ish2)
[184]	224	END IF
[508]	225	!
[134]	226	END FUNCTION ptr_vtjk
	227
	228
	229	SUBROUTINE dia_ptr( kt )
	230	!!----------------------------------------------------------------------
	231	!! * ROUTINE dia_ptr *
	232	!!----------------------------------------------------------------------
	233	INTEGER, INTENT(in) :: kt ! ocean time step index
[508]	234	!!
	235	INTEGER :: jk, jj, ji ! dummy loop
	236	REAL(wp) :: zsverdrup, & ! conversion from m3/s to Sverdrup
	237	& zpwatt, & ! conversion from W to PW
	238	& zggram ! conversion from g to Pg
[134]	239
[406]	240	REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
	241	v_atl , v_ipc, &
	242	vt_atl, vt_pac, vt_ind, &
[519]	243	vs_atl, vs_pac, vs_ind
[508]	244	INTEGER :: inum ! temporary logical unit
[134]	245	!!----------------------------------------------------------------------
	246
[1317]	247	IF( kt == nit000 .OR. MOD( kt - nit000 + 1, nf_ptr ) == 0 ) THEN
[134]	248
[406]	249	zsverdrup = 1.e-6
	250	zpwatt = 1.e-15
	251	zggram = 1.e-6
	252
	253	! "zonal" mean temperature and salinity at V-points
	254	tn_jk(:,:) = ptr_vtjk( tn(:,:,:) ) * surf_jk_r(:,:)
	255	sn_jk(:,:) = ptr_vtjk( sn(:,:,:) ) * surf_jk_r(:,:)
	256
	257	!--------------------------------------------------------
	258	! overturning calculation:
	259
	260	IF( ln_subbas ) THEN ! Basins computation
	261
[508]	262	IF( kt == nit000 ) THEN ! load sub-basin mask
	263	CALL iom_open( 'subbasins', inum )
	264	CALL iom_get( inum, jpdom_data, 'atlmsk', abasin ) ! Atlantic basin
	265	CALL iom_get( inum, jpdom_data, 'pacmsk', pbasin ) ! Pacific basin
	266	CALL iom_get( inum, jpdom_data, 'indmsk', ibasin ) ! Indian basin
	267	CALL iom_close( inum )
[406]	268	ENDIF
	269
	270	! basin separation:
	271	DO jj = 1, jpj
	272	DO ji = 1, jpi
	273	! basin separated velocity
[519]	274	v_atl(ji,jj,:) = vn(ji,jj,:)*abasin(ji,jj)
	275	v_ipc(ji,jj,:) = vn(ji,jj,:)*(pbasin(ji,jj)+ibasin(ji,jj))
[406]	276
	277	! basin separated T times V on T points
[519]	278	vt_ind(ji,jj,:) = tn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) )*0.5
[406]	279	vt_atl(ji,jj,:) = vt_ind(ji,jj,:) * abasin(ji,jj)
	280	vt_pac(ji,jj,:) = vt_ind(ji,jj,:) * pbasin(ji,jj)
	281	vt_ind(ji,jj,:) = vt_ind(ji,jj,:) * ibasin(ji,jj)
	282
	283	! basin separated S times V on T points
[519]	284	vs_ind(ji,jj,:) = sn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) )*0.5
[406]	285	vs_atl(ji,jj,:) = vs_ind(ji,jj,:) * abasin(ji,jj)
	286	vs_pac(ji,jj,:) = vs_ind(ji,jj,:) * pbasin(ji,jj)
	287	vs_ind(ji,jj,:) = vs_ind(ji,jj,:) * ibasin(ji,jj)
	288	END DO
	289	END DO
	290
	291	ENDIF
	292
	293	! horizontal integral and vertical dz
	294	v_msf_glo(:,:) = ptr_vjk( vn(:,:,:) )
[134]	295	#if defined key_diaeiv
[406]	296	v_msf_eiv(:,:) = ptr_vjk( v_eiv(:,:,:) )
[134]	297	#endif
[406]	298	IF( ln_subbas ) THEN
[508]	299	v_msf_atl(:,:) = ptr_vjk( v_atl (:,:,:) )
	300	v_msf_ipc(:,:) = ptr_vjk( v_ipc (:,:,:) )
	301	ht_atl(:) = SUM( ptr_vjk( vt_atl(:,:,:)), 2 )
	302	ht_pac(:) = SUM( ptr_vjk( vt_pac(:,:,:)), 2 )
	303	ht_ind(:) = SUM( ptr_vjk( vt_ind(:,:,:)), 2 )
	304	st_atl(:) = SUM( ptr_vjk( vs_atl(:,:,:)), 2 )
	305	st_pac(:) = SUM( ptr_vjk( vs_pac(:,:,:)), 2 )
	306	st_ind(:) = SUM( ptr_vjk( vs_ind(:,:,:)), 2 )
[406]	307	ENDIF
[134]	308
[406]	309	! poleward tracer transports:
	310	! overturning components:
	311	pht_ove(:) = SUM( v_msf_glo(:,:) * tn_jk(:,:), 2 ) ! SUM over jk
	312	pst_ove(:) = SUM( v_msf_glo(:,:) * sn_jk(:,:), 2 ) ! SUM over jk
	313	#if defined key_diaeiv
	314	pht_eiv(:) = SUM( v_msf_eiv(:,:) * tn_jk(:,:), 2 ) ! SUM over jk
	315	pst_eiv(:) = SUM( v_msf_eiv(:,:) * sn_jk(:,:), 2 ) ! SUM over jk
	316	#endif
	317
	318	! conversion in PW and G g
	319	zpwatt = zpwatt * rau0 * rcp
	320	pht_adv(:) = pht_adv(:) * zpwatt
	321	pht_ove(:) = pht_ove(:) * zpwatt
	322	pht_ldf(:) = pht_ldf(:) * zpwatt
	323	pst_adv(:) = pst_adv(:) * zggram
	324	pst_ove(:) = pst_ove(:) * zggram
	325	pst_ldf(:) = pst_ldf(:) * zggram
	326	#if defined key_diaeiv
	327	pht_eiv(:) = pht_eiv(:) * zpwatt
	328	pst_eiv(:) = pst_eiv(:) * zggram
	329	#endif
	330	IF( ln_subbas ) THEN
	331	ht_atl(:) = ht_atl(:) * zpwatt
	332	ht_pac(:) = ht_pac(:) * zpwatt
	333	ht_ind(:) = ht_ind(:) * zpwatt
	334	st_atl(:) = st_atl(:) * zggram
	335	st_pac(:) = st_pac(:) * zggram
	336	st_ind(:) = st_ind(:) * zggram
	337	ENDIF
[134]	338
[406]	339	! "Meridional" Stream-Function
	340	DO jk = 2,jpk
	341	v_msf_glo(:,jk) = v_msf_glo(:,jk-1) + v_msf_glo(:,jk)
	342	END DO
	343	v_msf_glo(:,:) = v_msf_glo(:,:) * zsverdrup
[134]	344
[406]	345	#if defined key_diaeiv
	346	! Bolus "Meridional" Stream-Function
	347	DO jk = 2,jpk
	348	v_msf_eiv(:,jk) = v_msf_eiv(:,jk-1) + v_msf_eiv(:,jk)
	349	END DO
	350	v_msf_eiv(:,:) = v_msf_eiv(:,:) * zsverdrup
	351	#endif
[134]	352
[406]	353	IF( ln_subbas ) THEN
	354	DO jk = 2,jpk
	355	v_msf_atl(:,jk) = v_msf_atl(:,jk-1) + v_msf_atl(:,jk)
	356	v_msf_ipc(:,jk) = v_msf_ipc(:,jk-1) + v_msf_ipc(:,jk)
	357	END DO
	358	v_msf_atl(:,:) = v_msf_atl(:,:) * zsverdrup
	359	v_msf_ipc(:,:) = v_msf_ipc(:,:) * zsverdrup
	360	ENDIF
[134]	361
[406]	362	! outputs
	363	CALL dia_ptr_wri( kt )
	364
	365	ENDIF
	366
	367	! Close the file
	368	IF( kt == nitend ) CALL histclo( numptr )
[508]	369	!
[134]	370	END SUBROUTINE dia_ptr
	371
	372
	373	SUBROUTINE dia_ptr_init
	374	!!----------------------------------------------------------------------
	375	!! * ROUTINE dia_ptr_init *
	376	!!
	377	!! ** Purpose : Initialization, namelist read
	378	!!----------------------------------------------------------------------
[406]	379	REAL(wp), DIMENSION(jpi,jpj,jpk) :: z_1 ! temporary workspace
[134]	380
[406]	381	NAMELIST/namptr/ ln_diaptr, ln_subbas, nf_ptr
[134]	382	!!----------------------------------------------------------------------
	383
	384	! Read Namelist namptr : poleward transport parameters
[289]	385	REWIND ( numnam )
[134]	386	READ ( numnam, namptr )
	387
	388	! Control print
	389	IF(lwp) THEN
	390	WRITE(numout,*)
	391	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
	392	WRITE(numout,*) '~~~~~~~~~~~~'
	393	WRITE(numout,*) ' Namelist namptr : set ptr parameters'
	394	WRITE(numout,*) ' Switch for ptr diagnostic (T) or not (F) ln_diaptr = ', ln_diaptr
[406]	395	WRITE(numout,*) ' Atla/Paci/Ind basins computation ln_subbas = ', ln_subbas
[134]	396	WRITE(numout,*) ' Frequency of computation nf_ptr = ', nf_ptr
	397	ENDIF
	398
	399	! inverse of the ocean "zonal" v-point section
	400	z_1(:,:,:) = 1.e0
	401	surf_jk_r(:,:) = ptr_vtjk( z_1(:,:,:) )
	402	WHERE( surf_jk_r(:,:) /= 0.e0 ) surf_jk_r(:,:) = 1.e0 / surf_jk_r(:,:)
	403
	404	END SUBROUTINE dia_ptr_init
	405
	406
	407	SUBROUTINE dia_ptr_wri( kt )
	408	!!---------------------------------------------------------------------
	409	!! * ROUTINE dia_ptr_wri *
	410	!!
	411	!! ** Purpose : output of poleward fluxes
	412	!!
	413	!! ** Method : NetCDF file
	414	!!----------------------------------------------------------------------
	415	INTEGER, INTENT(in) :: kt ! ocean time-step index
[508]	416	!!
[406]	417	INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw, ndex(1)
[134]	418
[508]	419	CHARACTER (len=40) :: clhstnam, clop ! temporary names
	420	INTEGER :: iline, it, ji !
[1316]	421	REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars
[184]	422	REAL(wp), DIMENSION(jpj) :: zphi, zfoo
[134]	423	!!----------------------------------------------------------------------
	424
	425	! define time axis
	426	it = kt - nit000 + 1
	427
	428	! Initialization
	429	! --------------
	430	IF( kt == nit000 ) THEN
[1316]	431
	432	zdt = rdt
	433	IF( nacc == 1 ) zdt = rdtmin
[134]	434
	435	! Reference latitude
	436	! ------------------
	437	! ! =======================
	438	IF( cp_cfg == "orca" ) THEN ! ORCA configurations
	439	! ! =======================
	440
	441	IF( jp_cfg == 05 ) iline = 192 ! i-line that passes near the North Pole
	442	IF( jp_cfg == 025 ) iline = 384 ! i-line that passes near the North Pole
	443	IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole
	444	IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole
	445	zphi(:) = 0.e0
	446	DO ji = mi0(iline), mi1(iline)
	447	zphi(:) = gphiv(ji,:) ! if iline is in the local domain
[406]	448	! correct highest latitude for ORCA05
	449	IF( jp_cfg == 05 ) zphi(jpj) = zphi(jpjm1) + (zphi(jpjm1)-zphi(jpj-2))/2.
	450	IF( jp_cfg == 05 ) zphi(jpj) = MIN( zphi(jpj), 90.)
	451
[134]	452	END DO
	453	! provide the correct zphi to all local domains
	454	IF( lk_mpp ) CALL mpp_sum( zphi, jpj )
	455
	456	! ! =======================
	457	ELSE ! OTHER configurations
	458	! ! =======================
	459	zphi(:) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line
	460	!
	461	ENDIF
	462
	463	! OPEN netcdf file
	464	! ----------------
	465	! Define frequency of output and means
	466	zsto = nf_ptr * zdt
[1316]	467	IF( ln_mskland ) THEN ; clop = "ave(only(x))" ! put 1.e+20 on land (very expensive!!)
	468	ELSE ; clop = "ave(x)" ! no use of the mask value (require less cpu time)
	469	ENDIF
[134]	470	zout = nf_ptr * zdt
	471	zfoo(:) = 0.e0
	472
	473	! Compute julian date from starting date of the run
	474
[1310]	475	CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )
	476	zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment
[134]	477
[406]	478	CALL dia_nam( clhstnam, nf_ptr, 'diaptr' )
[134]	479	IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file ",clhstnam
	480
	481	! Horizontal grid : zphi()
	482	CALL histbeg(clhstnam, 1, zfoo, jpj, zphi, &
[352]	483	1, 1, 1, jpj, 0, zjulian, zdt, nhoridz, numptr, domain_id=nidom )
[460]	484	! Vertical grids : gdept_0, gdepw_0
[134]	485	CALL histvert( numptr, "deptht", "Vertical T levels", &
[460]	486	"m", jpk, gdept_0, ndepidzt )
[134]	487	CALL histvert( numptr, "depthw", "Vertical W levels", &
[460]	488	"m", jpk, gdepw_0, ndepidzw )
[134]	489
	490	! Zonal mean T and S
	491
	492	CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , &
	493	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	494	CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU" , &
	495	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	496
	497	! Meridional Stream-Function (eulerian and bolus)
	498
[406]	499	CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global","Sv" , &
[134]	500	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
[406]	501	IF( ln_subbas ) THEN
	502	CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic","Sv" , &
	503	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	504	CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific","Sv" ,&
	505	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	506	ENDIF
[134]	507
	508	! Heat transport
	509
	510	CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , &
	511	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	512	CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport" , &
	513	"PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	514	CALL histdef( numptr, "sophtove", "Overturning Heat Transport" , &
	515	"PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[406]	516	IF( ln_subbas ) THEN
	517	CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic" , &
	518	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	519	CALL histdef( numptr, "sohtpac", "Heat Transport Pacific" , &
	520	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	521	CALL histdef( numptr, "sohtind", "Heat Transport Indic" , &
	522	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	523	ENDIF
[134]	524
[406]	525
[134]	526	! Salt transport
	527
	528	CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , &
	529	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	530	CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport" , &
	531	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	532	CALL histdef( numptr, "sopstove", "Overturning Salt Transport" , &
	533	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	534
	535	#if defined key_diaeiv
	536	! Eddy induced velocity
	537	CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global", &
	538	"Sv" , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	539	CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport", &
	540	"PW" , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	541	CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport", &
	542	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	543	#endif
[406]	544	IF( ln_subbas ) THEN
	545	CALL histdef( numptr, "sostatl", "Salt Transport Atlantic" , &
	546	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	547	CALL histdef( numptr, "sostpac", "Salt Transport Pacific" , &
	548	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	549	CALL histdef( numptr, "sostind", "Salt Transport Indic" , &
	550	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	551	ENDIF
	552
[134]	553	CALL histend( numptr )
	554
	555	ENDIF
	556
[1317]	557	IF( MOD( it, nf_ptr ) == 0 ) THEN
[134]	558
[406]	559	IF(lwp) THEN
	560	WRITE(numout,*)
	561	WRITE(numout,*) 'dia_ptr : write Poleward Transports at time-step : ', kt
	562	WRITE(numout,*) '~~~~~~~~'
	563	WRITE(numout,*)
	564	ENDIF
	565
	566	ndex(1) = 0
[134]	567	CALL histwrite( numptr, "zotemglo", it, tn_jk , jpj*jpk, ndex )
	568	CALL histwrite( numptr, "zosalglo", it, sn_jk , jpj*jpk, ndex )
[406]	569	! overturning outputs:
	570	CALL histwrite( numptr, "zomsfglo", it, v_msf_glo , jpj*jpk, ndex )
	571	IF( ln_subbas ) THEN
	572	CALL histwrite( numptr, "zomsfatl", it, v_msf_atl , jpj*jpk, ndex )
	573	CALL histwrite( numptr, "zomsfipc", it, v_msf_ipc , jpj*jpk, ndex )
	574	ENDIF
	575	! heat transport outputs:
	576	IF( ln_subbas ) THEN
	577	CALL histwrite( numptr, "sohtatl", it, ht_atl , jpj, ndex )
	578	CALL histwrite( numptr, "sohtpac", it, ht_pac , jpj, ndex )
	579	CALL histwrite( numptr, "sohtind", it, ht_ind , jpj, ndex )
	580	CALL histwrite( numptr, "sostatl", it, st_atl , jpj, ndex )
	581	CALL histwrite( numptr, "sostpac", it, st_pac , jpj, ndex )
	582	CALL histwrite( numptr, "sostind", it, st_ind , jpj, ndex )
	583	ENDIF
	584
	585	CALL histwrite( numptr, "sophtadv", it, pht_adv , jpj, ndex )
	586	CALL histwrite( numptr, "sophtldf", it, pht_ldf , jpj, ndex )
	587	CALL histwrite( numptr, "sophtove", it, pht_ove , jpj, ndex )
	588	CALL histwrite( numptr, "sopstadv", it, pst_adv , jpj, ndex )
	589	CALL histwrite( numptr, "sopstldf", it, pst_ldf , jpj, ndex )
	590	CALL histwrite( numptr, "sopstove", it, pst_ove , jpj, ndex )
[134]	591	#if defined key_diaeiv
	592	CALL histwrite( numptr, "zomsfeiv", it, v_msf_eiv, jpj*jpk, ndex )
	593	CALL histwrite( numptr, "sophteiv", it, pht_eiv , jpj , ndex )
	594	CALL histwrite( numptr, "sopsteiv", it, pst_eiv , jpj , ndex )
	595	#endif
	596
	597	ENDIF
[508]	598	!
[134]	599	END SUBROUTINE dia_ptr_wri
	600
	601	!!======================================================================
	602	END MODULE diaptr

Note: See TracBrowser for help on using the repository browser.

Download in other formats: