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.

prtctl_trc.F90 in trunk/NEMOGCM/NEMO/TOP_SRC – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 3634

Last change on this file since 3634 was 3294, checked in by rblod, 12 years ago
Merge of 3.4beta into the trunk
Property svn:keywords set to `Id`
File size: 20.1 KB

Rev	Line
[331]	1	MODULE prtctl_trc
[945]	2	!!======================================================================
	3	!! * MODULE prtctl_trc *
	4	!! TOP : print all SUM trends for each processor domain
	5	!!======================================================================
	6	!! History : - ! 2005-07 (C. Talandier) original code for OPA
	7	!! 1.0 ! 2005-10 (C. Ethe ) adapted to passive tracer
	8	!!----------------------------------------------------------------------
	9	#if defined key_top
	10	!!----------------------------------------------------------------------
	11	!! 'key_top' TOP models
	12	!!----------------------------------------------------------------------
	13	!! prt_ctl_trc : control print in mpp for passive tracers
	14	!! prt_ctl_trc_info : ???
	15	!! prt_ctl_trc_init : ???
	16	!!----------------------------------------------------------------------
	17	USE par_trc ! TOP parameters
[331]	18	USE oce_trc ! ocean space and time domain variables
	19
	20	IMPLICIT NONE
	21	PRIVATE
	22
[945]	23	INTEGER , DIMENSION(:), ALLOCATABLE :: numid_trc !: logical unit
	24	INTEGER , DIMENSION(:), ALLOCATABLE :: nlditl , nldjtl !: first, last indoor index for each i-domain
	25	INTEGER , DIMENSION(:), ALLOCATABLE :: nleitl , nlejtl !: first, last indoor index for each j-domain
	26	INTEGER , DIMENSION(:), ALLOCATABLE :: nimpptl, njmpptl !: i-, j-indexes for each processor
	27	INTEGER , DIMENSION(:), ALLOCATABLE :: nlcitl , nlcjtl !: dimensions of every subdomain
	28	INTEGER , DIMENSION(:), ALLOCATABLE :: ibonitl, ibonjtl
[331]	29
[945]	30	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl !: previous trend values
[331]	31
	32	PUBLIC prt_ctl_trc ! called by all subroutines
	33	PUBLIC prt_ctl_trc_info !
	34	PUBLIC prt_ctl_trc_init ! called by opa.F90
[945]	35
[331]	36	CONTAINS
	37
[945]	38	SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
[331]	39	!!----------------------------------------------------------------------
	40	!! * ROUTINE prt_ctl *
	41	!!
	42	!! ** Purpose : - print sum control 3D arrays over the same area
	43	!! in mono and mpp case. This way can be usefull when
	44	!! debugging a new parametrization in mono or mpp.
	45	!!
	46	!! ** Method : 2 possibilities exist when setting the ln_ctl parameter to
	47	!! .true. in the ocean namelist:
	48	!! - to debug a MPI run .vs. a mono-processor one;
	49	!! the control print will be done over each sub-domain.
	50	!! The nictl[se] and njctl[se] parameters in the namelist must
	51	!! be set to zero and [ij]splt to the corresponding splitted
	52	!! domain in MPI along respectively i-, j- directions.
	53	!! - to debug a mono-processor run over the whole domain/a specific area;
	54	!! in the first case the nictl[se] and njctl[se] parameters must be set
	55	!! to zero else to the indices of the area to be controled. In both cases
	56	!! isplt and jsplt must be set to 1.
	57	!! - All arguments of the above calling sequence are optional so their
	58	!! name must be explicitly typed if used. For instance if the mask
	59	!! array tmask(:,:,:) must be passed through the prt_ctl subroutine,
[945]	60	!! it must looks like: CALL prt_ctl( mask=tmask ).
	61	!!----------------------------------------------------------------------
	62	REAL(wp) , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d ! 4D array
	63	REAL(wp) , DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask ! 3D mask to apply to the tab4d array
	64	CHARACTER (len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
	65	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 ! ???
	66	INTEGER , INTENT(in), OPTIONAL :: ovlap ! overlap value
	67	INTEGER , INTENT(in), OPTIONAL :: kdim ! k- direction for 4D arrays
[331]	68	!!
[945]	69	INTEGER :: overlap, jn, js, sind, eind, kdir, j_id
	70	REAL(wp) :: zsum, zvctl
	71	CHARACTER (len=20), DIMENSION(jptra) :: cl
	72	CHARACTER (len=10) :: cl2
[3294]	73	REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask, ztab3d
[331]	74	!!----------------------------------------------------------------------
	75
[3294]	76	CALL wrk_alloc( jpi, jpj, jpk, zmask, ztab3d )
[945]	77	! ! Arrays, scalars initialization
[331]	78	overlap = 0
	79	kdir = jpkm1
	80	zsum = 0.e0
	81	zvctl = 0.e0
	82	cl(:) = ''
	83	cl2 = ''
	84	ztab3d(:,:,:) = 0.e0
	85	zmask (:,:,:) = 1.e0
	86
[945]	87	! ! Control of optional arguments
	88	IF( PRESENT(ovlap) ) overlap = ovlap
	89	IF( PRESENT(kdim) ) kdir = kdim
	90	IF( PRESENT(clinfo ) ) cl(:) = clinfo(:)
	91	IF( PRESENT(clinfo2) ) cl2 = clinfo2
	92	IF( PRESENT(mask) ) zmask (:,:,:) = mask(:,:,:)
[331]	93
[945]	94	IF( lk_mpp ) THEN ! processor number
[331]	95	sind = narea
	96	eind = narea
[945]	97	ELSE ! processors total number
[331]	98	sind = 1
	99	eind = ijsplt
	100	ENDIF
	101
	102	! Loop over each sub-domain, i.e. the total number of processors ijsplt
	103	DO js = sind, eind
[945]	104	!
[625]	105	! Set logical unit
[945]	106	j_id = numid_trc( js - narea + 1 )
[331]	107	! Set indices for the SUM control
	108	IF( .NOT. lsp_area ) THEN
	109	IF (lk_mpp ) THEN
	110	nictls = MAX( 1, nlditl(js) - overlap )
	111	nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js))
	112	njctls = MAX( 1, nldjtl(js) - overlap )
	113	njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
	114	! Do not take into account the bound of the domain
[945]	115	IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
	116	IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nleitl(js) - 1 )
	117	IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
	118	IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, nlejtl(js) - 1 )
[331]	119	ELSE
	120	nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
	121	nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) )
	122	njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
	123	njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) )
	124	! Do not take into account the bound of the domain
[945]	125	IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
	126	IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
	127	IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
	128	IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
[331]	129	ENDIF
	130	ENDIF
[945]	131	!
[331]	132	IF( PRESENT(clinfo2) ) THEN
	133	DO jn = 1, jptra
	134	zvctl = tra_ctl(jn,js)
	135	ztab3d(:,:,:) = tab4d(:,:,:,jn)
[945]	136	zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
	137	& * zmask(nictls:nictle,njctls:njctle,1:kdir) )
[627]	138	WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
[331]	139	tra_ctl(jn,js) = zsum
[945]	140	END DO
[331]	141	ELSE
	142	DO jn = 1, jptra
	143	ztab3d(:,:,:) = tab4d(:,:,:,jn)
[945]	144	zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
	145	& * zmask(nictls:nictle,njctls:njctle,1:kdir) )
[627]	146	WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
[331]	147	END DO
	148	ENDIF
[945]	149	!
	150	END DO
	151	!
[3294]	152	CALL wrk_dealloc( jpi, jpj, jpk, zmask, ztab3d )
[2715]	153	!
[945]	154	END SUBROUTINE prt_ctl_trc
[331]	155
	156
[945]	157	SUBROUTINE prt_ctl_trc_info( clinfo )
[331]	158	!!----------------------------------------------------------------------
	159	!! * ROUTINE prt_ctl_trc_info *
	160	!!
	161	!! ** Purpose : - print information without any computation
	162	!!----------------------------------------------------------------------
[945]	163	CHARACTER (len=*), INTENT(in) :: clinfo ! information to print
	164	!!
	165	INTEGER :: js, sind, eind, j_id
[331]	166	!!----------------------------------------------------------------------
	167
[945]	168	IF( lk_mpp ) THEN ! processor number
[331]	169	sind = narea
	170	eind = narea
[945]	171	ELSE ! total number of processors
[331]	172	sind = 1
	173	eind = ijsplt
	174	ENDIF
	175
	176	! Loop over each sub-domain, i.e. number of processors ijsplt
	177	DO js = sind, eind
[627]	178	j_id = numid_trc(js - narea + 1)
[945]	179	WRITE(j_id,*) clinfo
	180	END DO
	181	!
	182	END SUBROUTINE prt_ctl_trc_info
[331]	183
	184
	185	SUBROUTINE prt_ctl_trc_init
	186	!!----------------------------------------------------------------------
	187	!! * ROUTINE prt_ctl_trc_init *
	188	!!
	189	!! ** Purpose : open ASCII files & compute indices
	190	!!----------------------------------------------------------------------
[945]	191	INTEGER :: js, sind, eind, j_id
[331]	192	CHARACTER (len=31) :: clfile_out
	193	CHARACTER (len=27) :: clb_name
	194	CHARACTER (len=19) :: cl_run
	195	!!----------------------------------------------------------------------
	196
[945]	197	! ! Allocate arrays
	198	ALLOCATE( nlditl (ijsplt) )
	199	ALLOCATE( nldjtl (ijsplt) )
	200	ALLOCATE( nleitl (ijsplt) )
	201	ALLOCATE( nlejtl (ijsplt) )
	202	ALLOCATE( nimpptl(ijsplt) )
	203	ALLOCATE( njmpptl(ijsplt) )
	204	ALLOCATE( nlcitl (ijsplt) )
	205	ALLOCATE( nlcjtl (ijsplt) )
	206	ALLOCATE( tra_ctl(jptra,ijsplt) )
	207	ALLOCATE( ibonitl(ijsplt) )
	208	ALLOCATE( ibonjtl(ijsplt) )
[331]	209
[945]	210	tra_ctl(:,:) = 0.e0 ! Initialization to zero
[331]	211
	212	IF( lk_mpp ) THEN
	213	sind = narea
	214	eind = narea
	215	clb_name = "('mpp.top.output_',I3.3)"
	216	cl_run = 'MULTI processor run'
	217	! use indices for each area computed by mpp_init subroutine
	218	nlditl(:) = nldit(:)
	219	nleitl(:) = nleit(:)
	220	nldjtl(:) = nldjt(:)
	221	nlejtl(:) = nlejt(:)
	222	!
	223	nimpptl(:) = nimppt(:)
	224	njmpptl(:) = njmppt(:)
	225	!
	226	nlcitl(:) = nlcit(:)
	227	nlcjtl(:) = nlcjt(:)
	228	!
	229	ibonitl(:) = ibonit(:)
	230	ibonjtl(:) = ibonjt(:)
	231	ELSE
	232	sind = 1
	233	eind = ijsplt
	234	clb_name = "('mono.top.output_',I3.3)"
[945]	235	cl_run = 'MONO processor run '
[331]	236	! compute indices for each area as done in mpp_init subroutine
	237	CALL sub_dom
	238	ENDIF
	239
[945]	240	ALLOCATE( numid_trc(eind-sind+1) )
[625]	241
[331]	242	DO js = sind, eind
	243	WRITE(clfile_out,FMT=clb_name) js-1
[1581]	244	CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
[627]	245	j_id = numid_trc(js -narea + 1)
	246	WRITE(j_id,*)
	247	WRITE(j_id,*) ' L O D Y C - I P S L'
[945]	248	WRITE(j_id,*) ' N E M 0 '
[627]	249	WRITE(j_id,*) ' Ocean General Circulation Model'
[945]	250	WRITE(j_id,*) ' version TOP 1.0 (2005) '
[627]	251	WRITE(j_id,*)
	252	WRITE(j_id,*) ' PROC number: ', js
	253	WRITE(j_id,*)
[945]	254	WRITE(j_id,FMT="(19x,a20)") cl_run
[331]	255
	256	! Print the SUM control indices
	257	IF( .NOT. lsp_area ) THEN
	258	IF ( lk_mpp ) THEN
	259	nictls = nlditl(js)
	260	nictle = nleitl(js)
	261	njctls = nldjtl(js)
	262	njctle = nlejtl(js)
	263	ELSE
	264	nictls = nimpptl(js) + nlditl(js) - 1
	265	nictle = nimpptl(js) + nleitl(js) - 1
	266	njctls = njmpptl(js) + nldjtl(js) - 1
	267	njctle = njmpptl(js) + nlejtl(js) - 1
	268	ENDIF
	269	ENDIF
[627]	270	WRITE(j_id,*)
	271	WRITE(j_id,*) 'prt_tra_ctl : Sum control indices'
	272	WRITE(j_id,*) '~~~~~~~'
	273	WRITE(j_id,*)
	274	WRITE(j_id,9000)' nlej = ', nlejtl(js), ' '
	275	WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
	276	WRITE(j_id,9001)' \| \|'
	277	WRITE(j_id,9001)' \| \|'
	278	WRITE(j_id,9001)' \| \|'
	279	WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
	280	WRITE(j_id,9002)' nldi = ', nlditl(js), ' nlei = ', nleitl(js)
	281	WRITE(j_id,9001)' \| \|'
	282	WRITE(j_id,9001)' \| \|'
	283	WRITE(j_id,9001)' \| \|'
	284	WRITE(j_id,9004)' njmpp = ',njmpptl(js),' ------------- njctls = ', njctls, ' -------------'
	285	WRITE(j_id,9003)' nimpp = ', nimpptl(js), ' nldj = ', nldjtl(js), ' '
	286	WRITE(j_id,*)
	287	WRITE(j_id,*)
[331]	288
	289	9000 FORMAT(a41,i4.4,a14)
	290	9001 FORMAT(a59)
	291	9002 FORMAT(a20,i4.4,a36,i3.3)
	292	9003 FORMAT(a20,i4.4,a17,i4.4)
	293	9004 FORMAT(a11,i4.4,a26,i4.4,a14)
[945]	294	END DO
	295	!
[331]	296	END SUBROUTINE prt_ctl_trc_init
	297
	298
	299	SUBROUTINE sub_dom
	300	!!----------------------------------------------------------------------
	301	!! * ROUTINE sub_dom *
	302	!!
	303	!! ** Purpose : Lay out the global domain over processors.
	304	!! CAUTION:
	305	!! This part has been extracted from the mpp_init
	306	!! subroutine and names of variables/arrays have been
	307	!! slightly changed to avoid confusion but the computation
	308	!! is exactly the same. Any modification about indices of
	309	!! each sub-domain in the mppini.F90 module should be reported
	310	!! here.
	311	!!
	312	!! ** Method : Global domain is distributed in smaller local domains.
	313	!! Periodic condition is a function of the local domain position
	314	!! (global boundary or neighbouring domain) and of the global
	315	!! periodic
	316	!! Type : jperio global periodic condition
	317	!! nperio local periodic condition
	318	!!
	319	!! ** Action : - set domain parameters
	320	!! nimpp : longitudinal index
	321	!! njmpp : latitudinal index
	322	!! nperio : lateral condition type
	323	!! narea : number for local area
	324	!! nlcil : first dimension
	325	!! nlcjl : second dimension
	326	!! nbondil : mark for "east-west local boundary"
	327	!! nbondjl : mark for "north-south local boundary"
	328	!!----------------------------------------------------------------------
	329	INTEGER :: ji, jj, js ! dummy loop indices
[945]	330	INTEGER :: ii, ij ! temporary integers
	331	INTEGER :: irestil, irestjl ! " "
	332	INTEGER :: ijpi , ijpj, nlcil ! temporary logical unit
	333	INTEGER :: nlcjl , nbondil, nbondjl
	334	INTEGER :: nrecil, nrecjl, nldil, nleil, nldjl, nlejl
[331]	335	REAL(wp) :: zidom, zjdom ! temporary scalars
[3294]	336	INTEGER, POINTER, DIMENSION(:,:) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! temporary workspace
[331]	337	!!----------------------------------------------------------------------
[3294]	338	!
	339	CALL wrk_alloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
	340	!
[945]	341	! Dimension arrays for subdomains
	342	! -------------------------------
[331]	343	! Computation of local domain sizes ilcitl() ilcjtl()
	344	! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
	345	! The subdomains are squares leeser than or equal to the global
	346	! dimensions divided by the number of processors minus the overlap
	347	! array (cf. par_oce.F90).
	348
	349	ijpi = ( jpiglo-2jpreci + (isplt-1) ) / isplt + 2jpreci
	350	ijpj = ( jpjglo-2jprecj + (jsplt-1) ) / jsplt + 2jprecj
	351
	352	nrecil = 2 * jpreci
	353	nrecjl = 2 * jprecj
	354	irestil = MOD( jpiglo - nrecil , isplt )
	355	irestjl = MOD( jpjglo - nrecjl , jsplt )
	356
	357	IF( irestil == 0 ) irestil = isplt
	358	DO jj = 1, jsplt
	359	DO ji = 1, irestil
	360	ilcitl(ji,jj) = ijpi
	361	END DO
	362	DO ji = irestil+1, isplt
	363	ilcitl(ji,jj) = ijpi -1
	364	END DO
	365	END DO
	366
	367	IF( irestjl == 0 ) irestjl = jsplt
	368	DO ji = 1, isplt
	369	DO jj = 1, irestjl
	370	ilcjtl(ji,jj) = ijpj
	371	END DO
	372	DO jj = irestjl+1, jsplt
	373	ilcjtl(ji,jj) = ijpj -1
	374	END DO
	375	END DO
	376
	377	zidom = nrecil
	378	DO ji = 1, isplt
	379	zidom = zidom + ilcitl(ji,1) - nrecil
	380	END DO
	381
	382	zjdom = nrecjl
	383	DO jj = 1, jsplt
	384	zjdom = zjdom + ilcjtl(1,jj) - nrecjl
	385	END DO
	386
[945]	387	! Index arrays for subdomains
	388	! ---------------------------
[331]	389
	390	iimpptl(:,:) = 1
	391	ijmpptl(:,:) = 1
	392
	393	IF( isplt > 1 ) THEN
	394	DO jj = 1, jsplt
	395	DO ji = 2, isplt
	396	iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
	397	END DO
	398	END DO
	399	ENDIF
	400
	401	IF( jsplt > 1 ) THEN
	402	DO jj = 2, jsplt
	403	DO ji = 1, isplt
	404	ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
	405	END DO
	406	END DO
	407	ENDIF
	408
[945]	409	! Subdomain description
	410	! ---------------------
[331]	411
	412	DO js = 1, ijsplt
	413	ii = 1 + MOD( js-1, isplt )
	414	ij = 1 + (js-1) / isplt
	415	nimpptl(js) = iimpptl(ii,ij)
	416	njmpptl(js) = ijmpptl(ii,ij)
	417	nlcitl (js) = ilcitl (ii,ij)
	418	nlcil = nlcitl (js)
	419	nlcjtl (js) = ilcjtl (ii,ij)
	420	nlcjl = nlcjtl (js)
	421	nbondjl = -1 ! general case
	422	IF( js > isplt ) nbondjl = 0 ! first row of processor
	423	IF( js > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor
	424	IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction
	425	ibonjtl(js) = nbondjl
	426
	427	nbondil = 0 !
	428	IF( MOD( js, isplt ) == 1 ) nbondil = -1 !
	429	IF( MOD( js, isplt ) == 0 ) nbondil = 1 !
	430	IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction
	431	ibonitl(js) = nbondil
	432
	433	nldil = 1 + jpreci
	434	nleil = nlcil - jpreci
	435	IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1
	436	IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil
	437	nldjl = 1 + jprecj
	438	nlejl = nlcjl - jprecj
	439	IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1
	440	IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl
	441	nlditl(js) = nldil
	442	nleitl(js) = nleil
	443	nldjtl(js) = nldjl
	444	nlejtl(js) = nlejl
	445	END DO
[945]	446	!
[3294]	447	CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
	448	!
[331]	449	END SUBROUTINE sub_dom
	450
	451	#else
	452	!!----------------------------------------------------------------------
[945]	453	!! Dummy module : NO passive tracer
[331]	454	!!----------------------------------------------------------------------
	455	#endif
[2528]	456
	457	!!----------------------------------------------------------------------
	458	!! NEMO/TOP 3.3 , NEMO Consortium (2010)
	459	!! $Id$
	460	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	461	!!======================================================================
[331]	462	END MODULE prtctl_trc

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

Download in other formats: