Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

prtctl.F90 @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 6 years ago
Remove svn keywords
File size: 24.8 KB

Rev	Line
[387]	1	MODULE prtctl
[2715]	2	!!======================================================================
[387]	3	!! * MODULE prtctl *
[2715]	4	!! Ocean system : print all SUM trends for each processor domain
	5	!!======================================================================
	6	!! History : 9.0 ! 05-07 (C. Talandier) original code
[3294]	7	!! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE
[2715]	8	!!----------------------------------------------------------------------
[387]	9	USE dom_oce ! ocean space and time domain variables
[3625]	10	#if defined key_nemocice_decomp
	11	USE ice_domain_size, only: nx_global, ny_global
	12	#endif
[387]	13	USE in_out_manager ! I/O manager
	14	USE lib_mpp ! distributed memory computing
[3294]	15	USE wrk_nemo ! work arrays
[387]	16
	17	IMPLICIT NONE
	18	PRIVATE
	19
[2715]	20	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: numid
	21	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlditl , nldjtl ! first, last indoor index for each i-domain
	22	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nleitl , nlejtl ! first, last indoor index for each j-domain
	23	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nimpptl, njmpptl ! i-, j-indexes for each processor
	24	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlcitl , nlcjtl ! dimensions of every subdomain
	25	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: ibonitl, ibonjtl !
[387]	26
[2715]	27	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: t_ctll , s_ctll ! previous tracer trend values
	28	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: u_ctll , v_ctll ! previous velocity trend values
[387]	29
[2715]	30	INTEGER :: ktime ! time step
[516]	31
[387]	32	PUBLIC prt_ctl ! called by all subroutines
	33	PUBLIC prt_ctl_info ! called by all subroutines
	34	PUBLIC prt_ctl_init ! called by opa.F90
[3680]	35	PUBLIC sub_dom ! called by opa.F90
[2715]	36
[387]	37	!!----------------------------------------------------------------------
[2528]	38	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
[9295]	39	!! $Id$
[2715]	40	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[387]	41	!!----------------------------------------------------------------------
	42	CONTAINS
	43
[2715]	44	SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, &
	45	& mask2, clinfo2, ovlap, kdim, clinfo3 )
[387]	46	!!----------------------------------------------------------------------
	47	!! * ROUTINE prt_ctl *
	48	!!
	49	!! ** Purpose : - print sum control of 2D or 3D arrays over the same area
	50	!! in mono and mpp case. This way can be usefull when
	51	!! debugging a new parametrization in mono or mpp.
	52	!!
	53	!! ** Method : 2 possibilities exist when setting the ln_ctl parameter to
	54	!! .true. in the ocean namelist:
	55	!! - to debug a MPI run .vs. a mono-processor one;
	56	!! the control print will be done over each sub-domain.
	57	!! The nictl[se] and njctl[se] parameters in the namelist must
	58	!! be set to zero and [ij]splt to the corresponding splitted
	59	!! domain in MPI along respectively i-, j- directions.
	60	!! - to debug a mono-processor run over the whole domain/a specific area;
	61	!! in the first case the nictl[se] and njctl[se] parameters must be set
	62	!! to zero else to the indices of the area to be controled. In both cases
	63	!! isplt and jsplt must be set to 1.
	64	!! - All arguments of the above calling sequence are optional so their
	65	!! name must be explicitly typed if used. For instance if the 3D
	66	!! array tn(:,:,:) must be passed through the prt_ctl subroutine,
	67	!! it must looks like: CALL prt_ctl(tab3d_1=tn).
	68	!!
	69	!! tab2d_1 : first 2D array
	70	!! tab3d_1 : first 3D array
	71	!! mask1 : mask (3D) to apply to the tab[23]d_1 array
	72	!! clinfo1 : information about the tab[23]d_1 array
	73	!! tab2d_2 : second 2D array
	74	!! tab3d_2 : second 3D array
	75	!! mask2 : mask (3D) to apply to the tab[23]d_2 array
	76	!! clinfo2 : information about the tab[23]d_2 array
	77	!! ovlap : overlap value
	78	!! kdim : k- direction for 3D arrays
	79	!! clinfo3 : additional information
	80	!!----------------------------------------------------------------------
[2715]	81	REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1
	82	REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1
	83	REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1
	84	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo1
	85	REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2
	86	REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2
	87	REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2
	88	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2
	89	INTEGER , INTENT(in), OPTIONAL :: ovlap
	90	INTEGER , INTENT(in), OPTIONAL :: kdim
	91	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo3
	92	!
[387]	93	CHARACTER (len=15) :: cl2
[2715]	94	INTEGER :: overlap, jn, sind, eind, kdir,j_id
[387]	95	REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
[3294]	96	REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d_1, ztab2d_2
	97	REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask1, zmask2, ztab3d_1, ztab3d_2
[387]	98	!!----------------------------------------------------------------------
	99
[3294]	100	CALL wrk_alloc( jpi,jpj, ztab2d_1, ztab2d_2 )
	101	CALL wrk_alloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 )
[2715]	102
[387]	103	! Arrays, scalars initialization
	104	overlap = 0
	105	kdir = jpkm1
	106	cl2 = ''
	107	zsum1 = 0.e0
	108	zsum2 = 0.e0
	109	zvctl1 = 0.e0
	110	zvctl2 = 0.e0
	111	ztab2d_1(:,:) = 0.e0
	112	ztab2d_2(:,:) = 0.e0
	113	ztab3d_1(:,:,:) = 0.e0
	114	ztab3d_2(:,:,:) = 0.e0
	115	zmask1 (:,:,:) = 1.e0
	116	zmask2 (:,:,:) = 1.e0
	117
	118	! Control of optional arguments
[2715]	119	IF( PRESENT(clinfo2) ) cl2 = clinfo2
	120	IF( PRESENT(ovlap) ) overlap = ovlap
	121	IF( PRESENT(kdim) ) kdir = kdim
	122	IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:)
	123	IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:)
[3608]	124	IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir)
	125	IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir)
[2715]	126	IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:)
	127	IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:)
[387]	128
[3294]	129	IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
[387]	130	sind = narea
	131	eind = narea
[3294]	132	ELSE ! processors total number
[387]	133	sind = 1
	134	eind = ijsplt
	135	ENDIF
	136
	137	! Loop over each sub-domain, i.e. the total number of processors ijsplt
	138	DO jn = sind, eind
[624]	139	! Set logical unit
[627]	140	j_id = numid(jn - narea + 1)
[387]	141	! Set indices for the SUM control
	142	IF( .NOT. lsp_area ) THEN
[3294]	143	IF (lk_mpp .AND. jpnij > 1) THEN
[387]	144	nictls = MAX( 1, nlditl(jn) - overlap )
	145	nictle = nleitl(jn) + overlap * MIN( 1, nlcitl(jn) - nleitl(jn))
	146	njctls = MAX( 1, nldjtl(jn) - overlap )
	147	njctle = nlejtl(jn) + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn))
	148	! Do not take into account the bound of the domain
[426]	149	IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
	150	IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
	151	IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1)
	152	IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1)
[387]	153	ELSE
	154	nictls = MAX( 1, nimpptl(jn) + nlditl(jn) - 1 - overlap )
	155	nictle = nimpptl(jn) + nleitl(jn) - 1 + overlap * MIN( 1, nlcitl(jn) - nleitl(jn) )
	156	njctls = MAX( 1, njmpptl(jn) + nldjtl(jn) - 1 - overlap )
	157	njctle = njmpptl(jn) + nlejtl(jn) - 1 + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn) )
	158	! Do not take into account the bound of the domain
[426]	159	IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
	160	IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
	161	IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2)
	162	IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2)
[387]	163	ENDIF
	164	ENDIF
	165
[5025]	166	IF( PRESENT(clinfo3)) THEN
	167	IF ( clinfo3 == 'tra' ) THEN
	168	zvctl1 = t_ctll(jn)
	169	zvctl2 = s_ctll(jn)
	170	ELSEIF ( clinfo3 == 'dyn' ) THEN
	171	zvctl1 = u_ctll(jn)
	172	zvctl2 = v_ctll(jn)
	173	ENDIF
[387]	174	ENDIF
	175
	176	! Compute the sum control
	177	! 2D arrays
	178	IF( PRESENT(tab2d_1) ) THEN
	179	zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
	180	zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
	181	ENDIF
	182
	183	! 3D arrays
	184	IF( PRESENT(tab3d_1) ) THEN
	185	zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
	186	zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
	187	ENDIF
	188
	189	! Print the result
[516]	190	IF( PRESENT(clinfo3) ) THEN
[627]	191	WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
[516]	192	SELECT CASE( clinfo3 )
	193	CASE ( 'tra-ta' )
	194	t_ctll(jn) = zsum1
	195	CASE ( 'tra' )
[387]	196	t_ctll(jn) = zsum1
	197	s_ctll(jn) = zsum2
[516]	198	CASE ( 'dyn' )
[387]	199	u_ctll(jn) = zsum1
	200	v_ctll(jn) = zsum2
[516]	201	END SELECT
	202	ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
[627]	203	WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
[387]	204	ELSE
[627]	205	WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
[387]	206	ENDIF
	207
	208	ENDDO
	209
[3294]	210	CALL wrk_dealloc( jpi,jpj, ztab2d_1, ztab2d_2 )
	211	CALL wrk_dealloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 )
[2715]	212	!
[387]	213	END SUBROUTINE prt_ctl
	214
	215
[516]	216	SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
[387]	217	!!----------------------------------------------------------------------
	218	!! * ROUTINE prt_ctl_info *
	219	!!
	220	!! ** Purpose : - print information without any computation
	221	!!
	222	!! ** Action : - input arguments
	223	!! clinfo1 : information about the ivar1
	224	!! ivar1 : value to print
	225	!! clinfo2 : information about the ivar2
	226	!! ivar2 : value to print
	227	!!----------------------------------------------------------------------
[2715]	228	CHARACTER (len=*), INTENT(in) :: clinfo1
[516]	229	INTEGER , INTENT(in), OPTIONAL :: ivar1
[387]	230	CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2
[516]	231	INTEGER , INTENT(in), OPTIONAL :: ivar2
	232	INTEGER , INTENT(in), OPTIONAL :: itime
[2715]	233	!
[624]	234	INTEGER :: jn, sind, eind, iltime, j_id
[387]	235	!!----------------------------------------------------------------------
	236
[3294]	237	IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
[387]	238	sind = narea
	239	eind = narea
[3294]	240	ELSE ! total number of processors
[387]	241	sind = 1
	242	eind = ijsplt
	243	ENDIF
	244
[516]	245	! Set to zero arrays at each new time step
	246	IF( PRESENT(itime) ) THEN
	247	iltime = itime
	248	IF( iltime > ktime ) THEN
	249	t_ctll(:) = 0.e0 ; s_ctll(:) = 0.e0
	250	u_ctll(:) = 0.e0 ; v_ctll(:) = 0.e0
	251	ktime = iltime
	252	ENDIF
	253	ENDIF
	254
[387]	255	! Loop over each sub-domain, i.e. number of processors ijsplt
	256	DO jn = sind, eind
[2715]	257	!
	258	j_id = numid(jn - narea + 1) ! Set logical unit
	259	!
[387]	260	IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
[627]	261	WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
[387]	262	ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
[627]	263	WRITE(j_id,*)clinfo1, ivar1, clinfo2
[387]	264	ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
[627]	265	WRITE(j_id,*)clinfo1, ivar1, ivar2
[387]	266	ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
[627]	267	WRITE(j_id,*)clinfo1, ivar1
[387]	268	ELSE
[627]	269	WRITE(j_id,*)clinfo1
[387]	270	ENDIF
[2715]	271	!
	272	END DO
	273	!
	274	END SUBROUTINE prt_ctl_info
[387]	275
	276
	277	SUBROUTINE prt_ctl_init
	278	!!----------------------------------------------------------------------
	279	!! * ROUTINE prt_ctl_init *
	280	!!
	281	!! ** Purpose : open ASCII files & compute indices
	282	!!----------------------------------------------------------------------
[624]	283	INTEGER :: jn, sind, eind, j_id
[387]	284	CHARACTER (len=28) :: clfile_out
	285	CHARACTER (len=23) :: clb_name
	286	CHARACTER (len=19) :: cl_run
	287	!!----------------------------------------------------------------------
	288
	289	! Allocate arrays
[2715]	290	ALLOCATE( nlditl(ijsplt) , nleitl(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) , &
	291	& nldjtl(ijsplt) , nlejtl(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) , &
	292	& nlcitl(ijsplt) , t_ctll(ijsplt) , u_ctll (ijsplt) , &
	293	& nlcjtl(ijsplt) , s_ctll(ijsplt) , v_ctll (ijsplt) )
[387]	294
	295	! Initialization
[2715]	296	t_ctll(:) = 0.e0
	297	s_ctll(:) = 0.e0
	298	u_ctll(:) = 0.e0
	299	v_ctll(:) = 0.e0
[516]	300	ktime = 1
[387]	301
[3294]	302	IF( lk_mpp .AND. jpnij > 1 ) THEN
[387]	303	sind = narea
	304	eind = narea
	305	clb_name = "('mpp.output_',I4.4)"
	306	cl_run = 'MULTI processor run'
	307	! use indices for each area computed by mpp_init subroutine
[4520]	308	nlditl(1:jpnij) = nldit(:)
	309	nleitl(1:jpnij) = nleit(:)
	310	nldjtl(1:jpnij) = nldjt(:)
	311	nlejtl(1:jpnij) = nlejt(:)
[387]	312	!
[4520]	313	nimpptl(1:jpnij) = nimppt(:)
	314	njmpptl(1:jpnij) = njmppt(:)
[387]	315	!
[4520]	316	nlcitl(1:jpnij) = nlcit(:)
	317	nlcjtl(1:jpnij) = nlcjt(:)
[387]	318	!
[4520]	319	ibonitl(1:jpnij) = ibonit(:)
	320	ibonjtl(1:jpnij) = ibonjt(:)
[387]	321	ELSE
	322	sind = 1
	323	eind = ijsplt
	324	clb_name = "('mono.output_',I4.4)"
	325	cl_run = 'MONO processor run '
	326	! compute indices for each area as done in mpp_init subroutine
	327	CALL sub_dom
	328	ENDIF
	329
[2715]	330	ALLOCATE( numid(eind-sind+1) )
[624]	331
[387]	332	DO jn = sind, eind
	333	WRITE(clfile_out,FMT=clb_name) jn-1
[1581]	334	CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
[627]	335	j_id = numid(jn -narea + 1)
	336	WRITE(j_id,*)
	337	WRITE(j_id,*) ' L O D Y C - I P S L'
	338	WRITE(j_id,*) ' O P A model'
	339	WRITE(j_id,*) ' Ocean General Circulation Model'
	340	WRITE(j_id,*) ' version OPA 9.0 (2005) '
	341	WRITE(j_id,*)
	342	WRITE(j_id,*) ' PROC number: ', jn
	343	WRITE(j_id,*)
	344	WRITE(j_id,FMT="(19x,a20)")cl_run
[387]	345
	346	! Print the SUM control indices
	347	IF( .NOT. lsp_area ) THEN
[516]	348	nictls = nimpptl(jn) + nlditl(jn) - 1
	349	nictle = nimpptl(jn) + nleitl(jn) - 1
	350	njctls = njmpptl(jn) + nldjtl(jn) - 1
	351	njctle = njmpptl(jn) + nlejtl(jn) - 1
[387]	352	ENDIF
[627]	353	WRITE(j_id,*)
	354	WRITE(j_id,*) 'prt_ctl : Sum control indices'
	355	WRITE(j_id,*) '~~~~~~~'
	356	WRITE(j_id,*)
	357	WRITE(j_id,9000)' nlej = ', nlejtl(jn), ' '
	358	WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
	359	WRITE(j_id,9001)' \| \|'
	360	WRITE(j_id,9001)' \| \|'
	361	WRITE(j_id,9001)' \| \|'
	362	WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
	363	WRITE(j_id,9002)' nldi = ', nlditl(jn), ' nlei = ', nleitl(jn)
	364	WRITE(j_id,9001)' \| \|'
	365	WRITE(j_id,9001)' \| \|'
	366	WRITE(j_id,9001)' \| \|'
	367	WRITE(j_id,9004)' njmpp = ',njmpptl(jn),' ------------- njctls = ', njctls, ' -------------'
	368	WRITE(j_id,9003)' nimpp = ', nimpptl(jn), ' nldj = ', nldjtl(jn), ' '
	369	WRITE(j_id,*)
	370	WRITE(j_id,*)
[387]	371
	372	9000 FORMAT(a41,i4.4,a14)
	373	9001 FORMAT(a59)
	374	9002 FORMAT(a20,i4.4,a36,i3.3)
	375	9003 FORMAT(a20,i4.4,a17,i4.4)
	376	9004 FORMAT(a11,i4.4,a26,i4.4,a14)
[2715]	377	END DO
	378	!
[387]	379	END SUBROUTINE prt_ctl_init
	380
	381
	382	SUBROUTINE sub_dom
	383	!!----------------------------------------------------------------------
	384	!! * ROUTINE sub_dom *
	385	!!
	386	!! ** Purpose : Lay out the global domain over processors.
	387	!! CAUTION:
	388	!! This part has been extracted from the mpp_init
	389	!! subroutine and names of variables/arrays have been
	390	!! slightly changed to avoid confusion but the computation
	391	!! is exactly the same. Any modification about indices of
	392	!! each sub-domain in the mppini.F90 module should be reported
	393	!! here.
	394	!!
	395	!! ** Method : Global domain is distributed in smaller local domains.
	396	!! Periodic condition is a function of the local domain position
	397	!! (global boundary or neighbouring domain) and of the global
	398	!! periodic
	399	!! Type : jperio global periodic condition
	400	!! nperio local periodic condition
	401	!!
	402	!! ** Action : - set domain parameters
	403	!! nimpp : longitudinal index
	404	!! njmpp : latitudinal index
	405	!! nperio : lateral condition type
	406	!! narea : number for local area
	407	!! nlcil : first dimension
	408	!! nlcjl : second dimension
	409	!! nbondil : mark for "east-west local boundary"
	410	!! nbondjl : mark for "north-south local boundary"
	411	!!
	412	!! History :
	413	!! ! 94-11 (M. Guyon) Original code
	414	!! ! 95-04 (J. Escobar, M. Imbard)
	415	!! ! 98-02 (M. Guyon) FETI method
	416	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions
	417	!! 8.5 ! 02-08 (G. Madec) F90 : free form
	418	!!----------------------------------------------------------------------
	419	INTEGER :: ji, jj, jn ! dummy loop indices
	420	INTEGER :: &
	421	ii, ij, & ! temporary integers
	422	irestil, irestjl, & ! " "
	423	ijpi , ijpj, nlcil, & ! temporary logical unit
	424	nlcjl , nbondil, nbondjl, &
	425	nrecil, nrecjl, nldil, nleil, nldjl, nlejl
	426
[3680]	427	INTEGER, POINTER, DIMENSION(:,:) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! workspace
[387]	428	REAL(wp) :: zidom, zjdom ! temporary scalars
	429	!!----------------------------------------------------------------------
	430
[3680]	431	!
	432	CALL wrk_alloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
	433	!
[387]	434	! 1. Dimension arrays for subdomains
	435	! -----------------------------------
	436	! Computation of local domain sizes ilcitl() ilcjtl()
	437	! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
	438	! The subdomains are squares leeser than or equal to the global
	439	! dimensions divided by the number of processors minus the overlap
	440	! array (cf. par_oce.F90).
	441
[3294]	442	#if defined key_nemocice_decomp
[3625]	443	ijpi = ( nx_global+2-2jpreci + (isplt-1) ) / isplt + 2jpreci
	444	ijpj = ( ny_global+2-2jprecj + (jsplt-1) ) / jsplt + 2jprecj
[3294]	445	#else
[3625]	446	ijpi = ( jpiglo-2jpreci + (isplt-1) ) / isplt + 2jpreci
[387]	447	ijpj = ( jpjglo-2jprecj + (jsplt-1) ) / jsplt + 2jprecj
[3294]	448	#endif
[387]	449
	450
	451	nrecil = 2 * jpreci
	452	nrecjl = 2 * jprecj
	453	irestil = MOD( jpiglo - nrecil , isplt )
	454	irestjl = MOD( jpjglo - nrecjl , jsplt )
	455
	456	IF( irestil == 0 ) irestil = isplt
[3294]	457	#if defined key_nemocice_decomp
	458
	459	! In order to match CICE the size of domains in NEMO has to be changed
	460	! The last line of blocks (west) will have fewer points
	461	DO jj = 1, jsplt
	462	DO ji=1, isplt-1
	463	ilcitl(ji,jj) = ijpi
	464	END DO
	465	ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
	466	END DO
	467
	468	#else
	469
[387]	470	DO jj = 1, jsplt
	471	DO ji = 1, irestil
	472	ilcitl(ji,jj) = ijpi
	473	END DO
	474	DO ji = irestil+1, isplt
	475	ilcitl(ji,jj) = ijpi -1
	476	END DO
	477	END DO
[3294]	478
	479	#endif
[387]	480
	481	IF( irestjl == 0 ) irestjl = jsplt
[3294]	482	#if defined key_nemocice_decomp
	483
	484	! Same change to domains in North-South direction as in East-West.
	485	DO ji = 1, isplt
	486	DO jj=1, jsplt-1
	487	ilcjtl(ji,jj) = ijpj
	488	END DO
	489	ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
	490	END DO
	491
	492	#else
	493
[387]	494	DO ji = 1, isplt
	495	DO jj = 1, irestjl
	496	ilcjtl(ji,jj) = ijpj
	497	END DO
	498	DO jj = irestjl+1, jsplt
	499	ilcjtl(ji,jj) = ijpj -1
	500	END DO
	501	END DO
[3294]	502
	503	#endif
[387]	504	zidom = nrecil
	505	DO ji = 1, isplt
	506	zidom = zidom + ilcitl(ji,1) - nrecil
	507	END DO
	508	IF(lwp) WRITE(numout,*)
	509	IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
	510
	511	zjdom = nrecjl
	512	DO jj = 1, jsplt
	513	zjdom = zjdom + ilcjtl(1,jj) - nrecjl
	514	END DO
	515	IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
	516	IF(lwp) WRITE(numout,*)
	517
	518
	519	! 2. Index arrays for subdomains
	520	! -------------------------------
	521
	522	iimpptl(:,:) = 1
	523	ijmpptl(:,:) = 1
	524
	525	IF( isplt > 1 ) THEN
	526	DO jj = 1, jsplt
	527	DO ji = 2, isplt
	528	iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
	529	END DO
	530	END DO
	531	ENDIF
	532
	533	IF( jsplt > 1 ) THEN
	534	DO jj = 2, jsplt
	535	DO ji = 1, isplt
	536	ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
	537	END DO
	538	END DO
	539	ENDIF
	540
	541	! 3. Subdomain description
	542	! ------------------------
	543
	544	DO jn = 1, ijsplt
	545	ii = 1 + MOD( jn-1, isplt )
	546	ij = 1 + (jn-1) / isplt
	547	nimpptl(jn) = iimpptl(ii,ij)
	548	njmpptl(jn) = ijmpptl(ii,ij)
	549	nlcitl (jn) = ilcitl (ii,ij)
	550	nlcil = nlcitl (jn)
	551	nlcjtl (jn) = ilcjtl (ii,ij)
	552	nlcjl = nlcjtl (jn)
	553	nbondjl = -1 ! general case
	554	IF( jn > isplt ) nbondjl = 0 ! first row of processor
	555	IF( jn > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor
	556	IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction
	557	ibonjtl(jn) = nbondjl
	558
	559	nbondil = 0 !
	560	IF( MOD( jn, isplt ) == 1 ) nbondil = -1 !
	561	IF( MOD( jn, isplt ) == 0 ) nbondil = 1 !
	562	IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction
	563	ibonitl(jn) = nbondil
	564
	565	nldil = 1 + jpreci
	566	nleil = nlcil - jpreci
	567	IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1
	568	IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil
	569	nldjl = 1 + jprecj
	570	nlejl = nlcjl - jprecj
	571	IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1
	572	IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl
	573	nlditl(jn) = nldil
	574	nleitl(jn) = nleil
	575	nldjtl(jn) = nldjl
	576	nlejtl(jn) = nlejl
	577	END DO
[2715]	578	!
	579	!
[3680]	580	CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
	581	!
	582	!
[387]	583	END SUBROUTINE sub_dom
	584
[2715]	585	!!======================================================================
[387]	586	END MODULE prtctl

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

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

Context Navigation

source: branches/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 9295

Download in other formats: