Context Navigation

prtctl_trc.F90 @ 7881

Last change on this file since 7881 was 7881, checked in by cetlod, 7 years ago
trunk: minor corrections to be able to compile and run ORCA2_LIM3 configuration referenced to ORCA2_LIM3_PISCES
Property svn:keywords set to `Id`
File size: 13.5 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	!! prt_ctl_trc : control print in mpp for passive tracers
	10	!! prt_ctl_trc_info : ???
	11	!! prt_ctl_trc_init : ???
	12	!!----------------------------------------------------------------------
	13	USE par_trc ! TOP parameters
[331]	14	USE oce_trc ! ocean space and time domain variables
[3680]	15	USE prtctl ! print control for OPA
[331]	16
	17	IMPLICIT NONE
	18	PRIVATE
	19
[945]	20	INTEGER , DIMENSION(:), ALLOCATABLE :: numid_trc !: logical unit
	21	INTEGER , DIMENSION(:), ALLOCATABLE :: nlditl , nldjtl !: first, last indoor index for each i-domain
	22	INTEGER , DIMENSION(:), ALLOCATABLE :: nleitl , nlejtl !: first, last indoor index for each j-domain
	23	INTEGER , DIMENSION(:), ALLOCATABLE :: nimpptl, njmpptl !: i-, j-indexes for each processor
	24	INTEGER , DIMENSION(:), ALLOCATABLE :: nlcitl , nlcjtl !: dimensions of every subdomain
	25	INTEGER , DIMENSION(:), ALLOCATABLE :: ibonitl, ibonjtl
[331]	26
[945]	27	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl !: previous trend values
[331]	28
	29	PUBLIC prt_ctl_trc ! called by all subroutines
	30	PUBLIC prt_ctl_trc_info !
	31	PUBLIC prt_ctl_trc_init ! called by opa.F90
[945]	32
[331]	33	CONTAINS
	34
[945]	35	SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
[331]	36	!!----------------------------------------------------------------------
	37	!! * ROUTINE prt_ctl *
	38	!!
	39	!! ** Purpose : - print sum control 3D arrays over the same area
	40	!! in mono and mpp case. This way can be usefull when
	41	!! debugging a new parametrization in mono or mpp.
	42	!!
	43	!! ** Method : 2 possibilities exist when setting the ln_ctl parameter to
	44	!! .true. in the ocean namelist:
	45	!! - to debug a MPI run .vs. a mono-processor one;
	46	!! the control print will be done over each sub-domain.
	47	!! The nictl[se] and njctl[se] parameters in the namelist must
	48	!! be set to zero and [ij]splt to the corresponding splitted
	49	!! domain in MPI along respectively i-, j- directions.
	50	!! - to debug a mono-processor run over the whole domain/a specific area;
	51	!! in the first case the nictl[se] and njctl[se] parameters must be set
	52	!! to zero else to the indices of the area to be controled. In both cases
	53	!! isplt and jsplt must be set to 1.
	54	!! - All arguments of the above calling sequence are optional so their
	55	!! name must be explicitly typed if used. For instance if the mask
	56	!! array tmask(:,:,:) must be passed through the prt_ctl subroutine,
[945]	57	!! it must looks like: CALL prt_ctl( mask=tmask ).
	58	!!----------------------------------------------------------------------
	59	REAL(wp) , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d ! 4D array
	60	REAL(wp) , DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask ! 3D mask to apply to the tab4d array
	61	CHARACTER (len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
	62	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 ! ???
	63	INTEGER , INTENT(in), OPTIONAL :: ovlap ! overlap value
	64	INTEGER , INTENT(in), OPTIONAL :: kdim ! k- direction for 4D arrays
[331]	65	!!
[945]	66	INTEGER :: overlap, jn, js, sind, eind, kdir, j_id
	67	REAL(wp) :: zsum, zvctl
[7646]	68	CHARACTER (len=20), ALLOCATABLE, DIMENSION(:) :: cl
[945]	69	CHARACTER (len=10) :: cl2
[3294]	70	REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask, ztab3d
[331]	71	!!----------------------------------------------------------------------
	72
[3294]	73	CALL wrk_alloc( jpi, jpj, jpk, zmask, ztab3d )
[7646]	74	ALLOCATE( cl(jptra) )
[945]	75	! ! Arrays, scalars initialization
[331]	76	overlap = 0
	77	kdir = jpkm1
	78	zsum = 0.e0
	79	zvctl = 0.e0
	80	cl(:) = ''
	81	cl2 = ''
	82	ztab3d(:,:,:) = 0.e0
	83	zmask (:,:,:) = 1.e0
	84
[945]	85	! ! Control of optional arguments
	86	IF( PRESENT(ovlap) ) overlap = ovlap
	87	IF( PRESENT(kdim) ) kdir = kdim
	88	IF( PRESENT(clinfo ) ) cl(:) = clinfo(:)
	89	IF( PRESENT(clinfo2) ) cl2 = clinfo2
	90	IF( PRESENT(mask) ) zmask (:,:,:) = mask(:,:,:)
[331]	91
[945]	92	IF( lk_mpp ) THEN ! processor number
[331]	93	sind = narea
	94	eind = narea
[945]	95	ELSE ! processors total number
[331]	96	sind = 1
	97	eind = ijsplt
	98	ENDIF
	99
	100	! Loop over each sub-domain, i.e. the total number of processors ijsplt
	101	DO js = sind, eind
[945]	102	!
[625]	103	! Set logical unit
[945]	104	j_id = numid_trc( js - narea + 1 )
[331]	105	! Set indices for the SUM control
	106	IF( .NOT. lsp_area ) THEN
	107	IF (lk_mpp ) THEN
	108	nictls = MAX( 1, nlditl(js) - overlap )
	109	nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js))
	110	njctls = MAX( 1, nldjtl(js) - overlap )
	111	njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
	112	! Do not take into account the bound of the domain
[945]	113	IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
	114	IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nleitl(js) - 1 )
	115	IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
	116	IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, nlejtl(js) - 1 )
[331]	117	ELSE
	118	nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
	119	nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) )
	120	njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
	121	njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) )
	122	! Do not take into account the bound of the domain
[945]	123	IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
	124	IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
	125	IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
	126	IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
[331]	127	ENDIF
	128	ENDIF
[945]	129	!
[331]	130	IF( PRESENT(clinfo2) ) THEN
	131	DO jn = 1, jptra
	132	zvctl = tra_ctl(jn,js)
	133	ztab3d(:,:,:) = tab4d(:,:,:,jn)
[945]	134	zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
	135	& * zmask(nictls:nictle,njctls:njctle,1:kdir) )
[627]	136	WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
[331]	137	tra_ctl(jn,js) = zsum
[945]	138	END DO
[331]	139	ELSE
	140	DO jn = 1, jptra
	141	ztab3d(:,:,:) = tab4d(:,:,:,jn)
[945]	142	zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
	143	& * zmask(nictls:nictle,njctls:njctle,1:kdir) )
[627]	144	WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
[331]	145	END DO
	146	ENDIF
[945]	147	!
	148	END DO
	149	!
[3294]	150	CALL wrk_dealloc( jpi, jpj, jpk, zmask, ztab3d )
[7646]	151	DEALLOCATE( cl )
[2715]	152	!
[945]	153	END SUBROUTINE prt_ctl_trc
[331]	154
	155
[945]	156	SUBROUTINE prt_ctl_trc_info( clinfo )
[331]	157	!!----------------------------------------------------------------------
	158	!! * ROUTINE prt_ctl_trc_info *
	159	!!
	160	!! ** Purpose : - print information without any computation
	161	!!----------------------------------------------------------------------
[945]	162	CHARACTER (len=*), INTENT(in) :: clinfo ! information to print
	163	!!
	164	INTEGER :: js, sind, eind, j_id
[331]	165	!!----------------------------------------------------------------------
	166
[945]	167	IF( lk_mpp ) THEN ! processor number
[331]	168	sind = narea
	169	eind = narea
[945]	170	ELSE ! total number of processors
[331]	171	sind = 1
	172	eind = ijsplt
	173	ENDIF
	174
	175	! Loop over each sub-domain, i.e. number of processors ijsplt
	176	DO js = sind, eind
[627]	177	j_id = numid_trc(js - narea + 1)
[945]	178	WRITE(j_id,*) clinfo
	179	END DO
	180	!
	181	END SUBROUTINE prt_ctl_trc_info
[331]	182
	183
	184	SUBROUTINE prt_ctl_trc_init
	185	!!----------------------------------------------------------------------
	186	!! * ROUTINE prt_ctl_trc_init *
	187	!!
	188	!! ** Purpose : open ASCII files & compute indices
	189	!!----------------------------------------------------------------------
[945]	190	INTEGER :: js, sind, eind, j_id
[331]	191	CHARACTER (len=31) :: clfile_out
	192	CHARACTER (len=27) :: clb_name
	193	CHARACTER (len=19) :: cl_run
	194	!!----------------------------------------------------------------------
	195
[945]	196	! ! Allocate arrays
	197	ALLOCATE( nlditl (ijsplt) )
	198	ALLOCATE( nldjtl (ijsplt) )
	199	ALLOCATE( nleitl (ijsplt) )
	200	ALLOCATE( nlejtl (ijsplt) )
	201	ALLOCATE( nimpptl(ijsplt) )
	202	ALLOCATE( njmpptl(ijsplt) )
	203	ALLOCATE( nlcitl (ijsplt) )
	204	ALLOCATE( nlcjtl (ijsplt) )
	205	ALLOCATE( tra_ctl(jptra,ijsplt) )
	206	ALLOCATE( ibonitl(ijsplt) )
	207	ALLOCATE( ibonjtl(ijsplt) )
[331]	208
[945]	209	tra_ctl(:,:) = 0.e0 ! Initialization to zero
[331]	210
	211	IF( lk_mpp ) THEN
	212	sind = narea
	213	eind = narea
	214	clb_name = "('mpp.top.output_',I3.3)"
	215	cl_run = 'MULTI processor run'
	216	! use indices for each area computed by mpp_init subroutine
[4520]	217	nlditl(1:jpnij) = nldit(:)
	218	nleitl(1:jpnij) = nleit(:)
	219	nldjtl(1:jpnij) = nldjt(:)
	220	nlejtl(1:jpnij) = nlejt(:)
[331]	221	!
[4520]	222	nimpptl(1:jpnij) = nimppt(:)
	223	njmpptl(1:jpnij) = njmppt(:)
[331]	224	!
[4520]	225	nlcitl(1:jpnij) = nlcit(:)
	226	nlcjtl(1:jpnij) = nlcjt(:)
[331]	227	!
[4520]	228	ibonitl(1:jpnij) = ibonit(:)
	229	ibonjtl(1:jpnij) = ibonjt(:)
[331]	230	ELSE
	231	sind = 1
	232	eind = ijsplt
	233	clb_name = "('mono.top.output_',I3.3)"
[945]	234	cl_run = 'MONO processor run '
[331]	235	! compute indices for each area as done in mpp_init subroutine
	236	CALL sub_dom
	237	ENDIF
	238
[945]	239	ALLOCATE( numid_trc(eind-sind+1) )
[625]	240
[331]	241	DO js = sind, eind
	242	WRITE(clfile_out,FMT=clb_name) js-1
[1581]	243	CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
[627]	244	j_id = numid_trc(js -narea + 1)
	245	WRITE(j_id,*)
	246	WRITE(j_id,*) ' L O D Y C - I P S L'
[945]	247	WRITE(j_id,*) ' N E M 0 '
[627]	248	WRITE(j_id,*) ' Ocean General Circulation Model'
[945]	249	WRITE(j_id,*) ' version TOP 1.0 (2005) '
[627]	250	WRITE(j_id,*)
	251	WRITE(j_id,*) ' PROC number: ', js
	252	WRITE(j_id,*)
[945]	253	WRITE(j_id,FMT="(19x,a20)") cl_run
[331]	254
	255	! Print the SUM control indices
	256	IF( .NOT. lsp_area ) THEN
	257	IF ( lk_mpp ) THEN
	258	nictls = nlditl(js)
	259	nictle = nleitl(js)
	260	njctls = nldjtl(js)
	261	njctle = nlejtl(js)
	262	ELSE
	263	nictls = nimpptl(js) + nlditl(js) - 1
	264	nictle = nimpptl(js) + nleitl(js) - 1
	265	njctls = njmpptl(js) + nldjtl(js) - 1
	266	njctle = njmpptl(js) + nlejtl(js) - 1
	267	ENDIF
	268	ENDIF
[627]	269	WRITE(j_id,*)
	270	WRITE(j_id,*) 'prt_tra_ctl : Sum control indices'
	271	WRITE(j_id,*) '~~~~~~~'
	272	WRITE(j_id,*)
	273	WRITE(j_id,9000)' nlej = ', nlejtl(js), ' '
	274	WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
	275	WRITE(j_id,9001)' \| \|'
	276	WRITE(j_id,9001)' \| \|'
	277	WRITE(j_id,9001)' \| \|'
	278	WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
	279	WRITE(j_id,9002)' nldi = ', nlditl(js), ' nlei = ', nleitl(js)
	280	WRITE(j_id,9001)' \| \|'
	281	WRITE(j_id,9001)' \| \|'
	282	WRITE(j_id,9001)' \| \|'
	283	WRITE(j_id,9004)' njmpp = ',njmpptl(js),' ------------- njctls = ', njctls, ' -------------'
	284	WRITE(j_id,9003)' nimpp = ', nimpptl(js), ' nldj = ', nldjtl(js), ' '
	285	WRITE(j_id,*)
	286	WRITE(j_id,*)
[331]	287
	288	9000 FORMAT(a41,i4.4,a14)
	289	9001 FORMAT(a59)
	290	9002 FORMAT(a20,i4.4,a36,i3.3)
	291	9003 FORMAT(a20,i4.4,a17,i4.4)
	292	9004 FORMAT(a11,i4.4,a26,i4.4,a14)
[945]	293	END DO
	294	!
[331]	295	END SUBROUTINE prt_ctl_trc_init
	296
	297	END MODULE prtctl_trc

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

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

Download in other formats: