Context Navigation

prtctl.F90 @ 2874

Last change on this file since 2874 was 2874, checked in by charris, 13 years ago

Code for running NEMO with CICE (for fully coupled mode this should be used in combination with dev_r2802_UKMO8_sbccpl). Changes are described briefly below.

physct: Constants modified to be consistent with CICE

nemogcm / prtctl / mppini: Changes to NEMO decomposition (activated using key_nemocice_decomp) to produce 'square' options in CICE. Can run without this key / code but this requires a global gather / scatter in the NEMO-CICE coupling which gets very slow on large processors numbers.

sbc_ice: CICE options and arrays added

sbcmod: CICE option added, including calls for initialising and finalising CICE.

sbcblk_core: Make sure necessary forcing field are available for CICE

sbcice_cice: Main CICE coupling code.

Property svn:keywords set to Id

File size: 24.5 KB

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

Download in other formats: