Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

prism_init_comp_proto.F @ 1677

Last change on this file since 1677 was 1677, checked in by aclsce, 12 years ago
Imported oasis3 (tag ipslcm5a) from cvs server to svn server (igcmg project).
File size: 29.1 KB

Line
1	SUBROUTINE prism_init_comp_proto(il_mynummod, cdnam, kinfo)
2	c
3	c* * PRISM_init_comp * PRISM 1.0
4	c
5	c purpose:
6	c --------
7	c start models
8	c
9	c interface:
10	c ----------
11	c cdnam : name of the calling model
12	c il_mynummod : model number
13	c kinfo : exit status
14	c
15	c lib mp:
16	c -------
17	c MPI-1 or MPI-2
18	c
19	c author:
20	c -------
21	c Sophie Valcke - CERFACS (08/09/00 -created from CLIM_Init)
22	c Jean Latour - F.S.E. - Version MPMD launch with mpi-1
23	c - implies the use of mpiexec server process on VPPs
24	c or the command mpirun on most platforms
25	c Arnaud Caubel - FECIT (08/02 - created from CLIM_Init - removed
26	c some arguments and added dynamic allocation)
27	c S. Legutke - MPI M&D - cg_clim/def_rstfile initialized
28	c ----------------------------------------------------------------
29	c
30	USE mod_kinds_model
31	USE mod_prism_proto
32	USE mod_comprism_proto
33	#if !defined key_noIO
34	USE mod_psmile_io_interfaces
35	#endif
36	IMPLICIT NONE
37	#include <mpif.h>
38	c ----------------------------------------------------------------
39	CHARACTER() cdnam
40	INTEGER (kind=ip_intwp_p) kinfo
41	c ----------------------------------------------------------------
42	INTEGER (kind=ip_intwp_p) mpi_status(MPI_STATUS_SIZE),
43	$ il_mynummod
44	INTEGER (kind=ip_intwp_p) imodst, iost, ip, iprcou, iprmod
45	INTEGER (kind=ip_intwp_p) il_err, il_rank, il_maxcplproc
46	INTEGER (kind=ip_intwp_p) il_CLIM_Maxport, il_CLIM_MaxLink
47	INTEGER (kind=ip_intwp_p) ji, jj, jl, ir, iremsize,ibuff,
48	$ itagcol, il_size
49	INTEGER (kind=ip_intwp_p) icolor, ikey, iposbuf, info
50	INTEGER (kind=ip_intwp_p) il_start, il_end, il_logrank
51	INTEGER (kind=ip_intwp_p) impi_newcomm2, impi_intercomp1,
52	$ jlocal
53	INTEGER (kind=ip_intwp_p) imaxmodel, iarrb(2)
54	INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE ::
55	$ impi_intercomp
56	INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE ::
57	$ impi_newcomm
58	LOGICAL ll_file
59	PARAMETER (itagcol=9876)
60	REAL (kind=ip_realwp_p) rl_testvar
61	REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: rl_work
62	CHARACTER(len=6) :: cl_comm, cl_argv
63	INTEGER(kind=ip_intwp_p), DIMENSION(1024) :: iarr_err
64	INTEGER(kind=ip_intwp_p) :: integer_byte_size, ii, io_size,
65	$ integer_io_size, il_ibyt, il_int, il_char, il_log, il_rl_work
66	LOGICAL :: ll_log
67	CHARACTER*1 :: cl_char
68	c ----------------------------------------------------------------
69	c
70	rl_testvar = 0.0_ip_realwp_p
71	c
72	c* 1. get arguments and some Initilizations
73	c ----------------------------------------
74	c
75	nexit = 0
76	c
77	kinfo = CLIM_Ok
78	c
79	cmynam=' '
80	cmynam=cdnam
81	c
82	nports = 0
83	nlinks = 0
84	ig_nbpart = 0
85	nbsend = 0
86	nbrecv = 0
87	mpi_status(:)=0
88	iarrb(:)=0
89	ibuff = 0
90	c By default, the number of corners is 4. It will be changed if the
91	c model calls prism_write_corner.
92	ig_noc = 4
93	c
94	c* 2.0 Start global MPI environment for Oasis and models
95	c -----------------------------------------------------
96	c
97	lg_mpiflag = .FALSE.
98	CALL MPI_Initialized ( lg_mpiflag, mpi_err )
99	IF ( .NOT. lg_mpiflag ) THEN
100	CALL MPI_INIT ( mpi_err )
101	WRITE (0,FMT='(A)') 'Calling MPI_Init in prism_init_comp...'
102	ELSE
103	WRITE (0,FMT='(A)') 'No call of MPI_Init in prism_init_comp.'
104	ENDIF
105	c
106	CALL MPI_Comm_Size(MPI_COMM_WORLD,mpi_size,mpi_err)
107	CALL MPI_Comm_Rank(MPI_COMM_WORLD,mpi_rank,mpi_err)
108	c
109	WRITE (0, FMT='(A)') 'Init - CLIM 2.0 / MPI-1'
110	WRITE (0, FMT='(A,A)') 'Init - name of the model: ',
111	* cdnam
112	WRITE(0,*)'Init - - rank = ',mpi_rank,' in global comm'
113	WRITE(0,*)'Init - - size = ',mpi_size,' of global comm'
114	c
115	c* 3.1 Case MPI-1 : Split global communicator into disjoint communicators
116	c* local for each model
117	c* ----------------------------------------------------------------------
118	c
119	#ifdef use_comm_MPI1
120	c
121	c* MPI_COMM_WORLD is the global communicator for all processes
122	c* it includes Oasis and all model processes
123	c* It is duplicated in "mpi_comm" for compatibility with the
124	c* MPI-2 start option that implies multiple MPI_Comm_Spawn.
125	c
126	CALL MPI_COMM_DUP(MPI_COMM_WORLD,mpi_comm,mpi_err)
127	WRITE(0,*)'Init - - comm_dup done= ',mpi_comm
128
129	c
130	c* 3.1.1 generates a "color" from the model name
131	c
132	ALLOCATE (cunames(mpi_size), stat = il_err)
133	IF (il_err.NE.0) WRITE (0,*)
134	$ 'Init - Error in cunames allocation '
135	call MPI_Allgather(cmynam,CLIM_Clength,MPI_CHARACTER,
136	& cunames,CLIM_Clength,MPI_CHARACTER,
137	& mpi_comm,mpi_err)
138	icolor=1
139	do while ((trim(cmynam).ne.trim(cunames(icolor))).and.
140	& (icolor.le.mpi_size))
141	icolor=icolor+1
142	enddo
143	IF (icolor.le.mpi_size) THEN
144	icolor=icolor*100
145	ELSE
146	WRITE (0,*)
147	$ 'Init - - Could not find myself in the model namespace!'
148	WRITE (0,*) 'Init - - Check namcouple and '
149	WRITE (0,*) 'model name tags for consistency !'
150	call MPI_ABORT (mpi_comm, 0, mpi_err)
151	ENDIF
152
153	c
154	c* 3.1.2 split MPI_COMM_WORLD in local, disjoints, communicators
155	c
156	ikey = 1
157	call MPI_COMM_SPLIT(MPI_COMM_WORLD, icolor, ikey,
158	* ig_local_comm, mpi_err)
159	IF(mpi_err .NE. MPI_SUCCESS) GOTO 215
160	c
161	c* 3.1.3 get the model number from Oasis (proc 0 in global comm)
162	c
163	CALL MPI_Send(icolor,1,MPI_INTEGER,0,itagcol,mpi_comm, mpi_err)
164	c
165	CALL MPI_Recv(ibuff,1,MPI_INTEGER,0,itagcol,mpi_comm,
166	* mpi_status, mpi_err)
167	c
168	il_mynummod = ibuff
169	ig_mynummod = il_mynummod
170	nexit = 1
171	WRITE(0,*)'Init - model number : mynummod = ',il_mynummod
172	c
173	c* 3.2 Case MPI-2
174	c* --------------
175	c
176	#else
177	c
178	CALL MPI_Comm_get_parent(impi_intercomp1,mpi_err)
179	WRITE(0,*)'impi_intercomp1 ',impi_intercomp1
180	IF ( mpi_err .NE. MPI_SUCCESS ) THEN
181	WRITE(0,*)'Init_comp - - Error on Intercomm '
182	kinfo = CLIM_Mpi
183	GO TO 1010
184	ENDIF
185	c
186	CALL MPI_Comm_remote_size(impi_intercomp1,iremsize,mpi_err)
187	c
188	CALL MPI_Intercomm_merge(impi_intercomp1, .true.,
189	& impi_newcomm2, mpi_err)
190	CALL MPI_Comm_size(impi_newcomm2, mpi_size, mpi_err)
191	CALL MPI_Comm_rank(impi_newcomm2, mpi_rank, mpi_err)
192	c
193	jlocal=2
194	c
195	STARTMOD : DO
196	c
197	IF (jlocal.eq.2) THEN
198	CALL MPI_BCAST(iarrb,2,MPI_INTEGER,0,
199	& impi_newcomm2,ir)
200	jl=iarrb(1)
201	imaxmodel=iarrb(2)
202	ALLOCATE(impi_intercomp(imaxmodel))
203	ALLOCATE(impi_newcomm(imaxmodel + 1))
204	impi_intercomp(:)=0
205	impi_newcomm(:)=0
206	impi_intercomp(1) = impi_intercomp1
207	impi_newcomm(2) = impi_newcomm2
208	if (jl .gt. imaxmodel ) EXIT STARTMOD
209	cl_comm = 'obione'
210	cl_argv=' '
211	CALL MPI_COMM_SPAWN(cl_comm,cl_argv,1,MPI_INFO_NULL, 0,
212	& impi_newcomm(jlocal), impi_intercomp(jlocal),
213	& iarr_err, mpi_err)
214	c
215	CALL MPI_Intercomm_merge(impi_intercomp(jlocal), .false.,
216	& impi_newcomm(jlocal+1), mpi_err)
217	jlocal=jlocal+1
218	CALL MPI_Comm_size(impi_newcomm(jlocal), mpi_size, mpi_err)
219	CALL MPI_Comm_rank(impi_newcomm(jlocal), mpi_rank, mpi_err)
220	ELSE
221
222	CALL MPI_BCAST(iarrb,2,MPI_INTEGER,0,
223	& impi_newcomm(jlocal),ir)
224	jl=iarrb(1)
225	imaxmodel=iarrb(2)
226
227	if (jl .gt. imaxmodel ) EXIT STARTMOD
228	c
229	cl_comm = 'obione'
230	cl_argv=' '
231	CALL MPI_COMM_SPAWN(cl_comm,cl_argv,1,MPI_INFO_NULL, 0,
232	& impi_newcomm(jlocal), impi_intercomp(jlocal),
233	& iarr_err, mpi_err)
234	c
235	CALL MPI_Intercomm_merge(impi_intercomp(jlocal), .false.,
236	& impi_newcomm(jlocal+1), mpi_err)
237	jlocal=jlocal+1
238	CALL MPI_Comm_size(impi_newcomm(jlocal), mpi_size, mpi_err)
239	CALL MPI_Comm_rank(impi_newcomm(jlocal), mpi_rank, mpi_err)
240	WRITE(0,*)'Init_comp - - rank = ',
241	$ mpi_rank,' in new comm'
242	WRITE(0,*)'Init_comp - - size = ',
243	$ mpi_size,' of new comm'
244	c
245	ENDIF
246	END DO STARTMOD
247	c
248	CALL MPI_COMM_DUP(impi_newcomm(jlocal),mpi_comm,mpi_err)
249	DO jl=2,jlocal
250	call MPI_COMM_FREE(impi_newcomm(jl),mpi_err)
251	ENDDO
252	ig_local_comm = MPI_COMM_WORLD
253	il_mynummod = imaxmodel - jlocal + 2
254	ig_mynummod = il_mynummod
255	nexit = 1
256	WRITE(0,*)'Init - model number : mynummod = ',il_mynummod
257	WRITE(0,*)'Init_comp - - Intercomm with Oasis = ',mpi_comm
258	DEALLOCATE(impi_intercomp)
259	DEALLOCATE(impi_newcomm)
260	#endif
261	c
262	C* 4.0 Receive information from Oasis, allocate global arrays,
263	c initialize global variables and open logfile
264	c ------------------------------------------------------------------
265	CALL MPI_Recv(knmods, 1, MPI_INTEGER, 0, itagcol,
266	$ mpi_comm, mpi_status, mpi_err)
267	IF (mpi_ERR.ne.MPI_SUCCESS) THEN
268	WRITE(UNIT = 0,FMT = *)
269	$ 'Init - Problem with reception of information from Oasis !'
270	WRITE(UNIT = 0,FMT = *)'STOP in PRISM_init_comp'
271	call flush(0)
272	call MPI_ABORT (mpi_comm, 0, mpi_err)
273	ENDIF
274	CALL MPI_Recv(ig_clim_nfield, 1, MPI_INTEGER, 0, itagcol+1,
275	$ mpi_comm, mpi_status, mpi_err)
276	IF (mpi_ERR.ne.MPI_SUCCESS) THEN
277	WRITE(UNIT = 0,FMT = *)
278	$ 'Init - Problem with reception of information from Oasis !'
279	WRITE(UNIT = 0,FMT = *)'STOP in PRISM_init_comp'
280	call flush(0)
281	call MPI_ABORT (mpi_comm, 0, mpi_err)
282	ENDIF
283	c
284	ALLOCATE(kbcplproc(knmods))
285	ALLOCATE(kbtotproc(knmods))
286	ALLOCATE(iga_unitmod(knmods))
287	ALLOCATE(cg_modnam(knmods))
288	c
289	integer_byte_size = BIT_SIZE(ii)/8
290	INQUIRE (iolength=io_size) ii
291	integer_io_size = io_size
292	il_int = io_size/integer_io_size*integer_byte_size
293	INQUIRE (iolength=io_size) rl_testvar
294	il_ibyt = io_size/integer_io_size*integer_byte_size
295	INQUIRE (iolength=io_size) cl_char
296	il_char = io_size/integer_io_size*integer_byte_size
297	INQUIRE (iolength=io_size) ll_log
298	il_log = io_size/integer_io_size*integer_byte_size
299	il_rl_work = (29 + 64ig_clim_nfield) (il_char/il_ibyt + 1) +
300	$ (9 + 3knmods + 9ig_clim_nfield) * (il_int/il_ibyt + 1) +
301	$ 3 * (il_log/il_ibyt + 1)
302	ALLOCATE (rl_work(il_rl_work), stat=il_err)
303	c
304	kbcplproc(:)=0
305	kbtotproc(:)=0
306	rl_work(:)=0
307	il_size = il_rl_work * il_ibyt
308	il_CLIM_Maxport = ig_clim_nfield *2
309	c
310	ALLOCATE (cg_cnaminp(ig_clim_nfield), stat=il_err)
311	IF (il_err.ne.0) WRITE(0,*)
312	$ 'Error in cg_cnaminp allocation in PRISM_init_comp routine!'
313	cg_cnaminp(:)=' '
314	ALLOCATE (cg_cnamout(ig_clim_nfield), stat=il_err)
315	IF (il_err.ne.0) WRITE(0,*)
316	$ 'Error in cg_cnamout allocation in PRISM_init_comp routine!'
317	cg_cnamout(:)=' '
318	ALLOCATE (ig_clim_lag(ig_clim_nfield), stat=il_err)
319	IF (il_err.ne.0) WRITE(0,*)
320	$ 'Error in ig_clim_lag allocation in PRISM_init_comp routine!'
321	ig_clim_lag(:)=0
322	ALLOCATE (ig_clim_reverse(ig_clim_nfield), stat=il_err)
323	IF (il_err.ne.0) WRITE(0,*)
324	$ 'Error ig_clim_reverse allocation in PRISM_init_comp routine!'
325	ig_clim_reverse(:)=0
326	ALLOCATE (ig_clim_invert(ig_clim_nfield), stat=il_err)
327	IF (il_err.ne.0) WRITE(0,*)
328	$ 'Error ig_clim_invert allocation in PRISM_init_comp routine!'
329	ig_clim_invert(:)=0
330	ALLOCATE (ig_def_lag(il_CLIM_Maxport), stat=il_err)
331	IF (il_err.ne.0) WRITE(0,*)
332	$ 'Error in ig_def_lag allocation in PRISM_init_comp routine!'
333	ig_def_lag(:)=0
334	ALLOCATE (ig_def_reverse(il_CLIM_Maxport), stat=il_err)
335	IF (il_err.ne.0) WRITE(0,*)
336	$ 'Error ig_def_reverse allocation in PRISM_init_comp routine!'
337	ig_def_reverse(:)=0
338	ALLOCATE (ig_def_invert(il_CLIM_Maxport), stat=il_err)
339	IF (il_err.ne.0) WRITE(0,*)
340	$ 'Error ig_def_invert allocation in PRISM_init_comp routine!'
341	ig_def_invert(:)=0
342	ALLOCATE (ig_clim_freq(ig_clim_nfield), stat=il_err)
343	IF (il_err.ne.0) WRITE(0,*)
344	$ 'Error in ig_clim_freq allocation in PRISM_init_comp routine!'
345	ig_clim_freq(:)=0
346	ALLOCATE (ig_def_freq(il_CLIM_Maxport), stat=il_err)
347	IF (il_err.ne.0) WRITE(0,*)
348	$ 'Error in ig_def_freq allocation in PRISM_init_comp routine!'
349	ig_def_freq (:) = 0
350	ALLOCATE (ig_clim_seq(ig_clim_nfield), stat=il_err)
351	IF (il_err.ne.0) WRITE(0,*)
352	$ 'Error in ig_clim_seq allocation in PRISM_init_comp routine!'
353	ig_clim_seq(:)=0
354	ALLOCATE (ig_def_seq(il_CLIM_Maxport), stat=il_err)
355	IF (il_err.ne.0) WRITE(0,*)
356	$ 'Error in ig_def_seq allocation in PRISM_init_comp routine!'
357	ig_def_seq(:)=0
358	ALLOCATE (cg_clim_rstfile(ig_clim_nfield), stat=il_err)
359	IF (il_err.ne.0) WRITE(0,*)
360	$'Error in cg_clim_rstfile allocation in PRISM_init_comp routine!'
361	cg_clim_rstfile(:)=' '
362	ALLOCATE (cg_def_rstfile(il_CLIM_Maxport), stat=il_err)
363	IF (il_err.ne.0) WRITE(0,*)
364	$ 'Error in cg_def_rstfile allocation in PRISM_init_comp routine!'
365	cg_def_rstfile(:)=' '
366	ALLOCATE (ig_clim_norstfile(ig_clim_nfield), stat=il_err)
367	IF (il_err.ne.0) WRITE(0,*)
368	$ 'Error in ig_clim_norstfile alloc in PRISM_init_comp routine!'
369	ig_clim_norstfile(:)=0
370	ALLOCATE (ig_def_norstfile(il_CLIM_Maxport), stat=il_err)
371	IF (il_err.ne.0) WRITE(0,*)
372	$ 'Error in ig_def_norstfile alloc in PRISM_init_comp routine!'
373	ig_def_norstfile(:)=0
374	ALLOCATE (ig_clim_state(ig_clim_nfield), stat=il_err)
375	IF (il_err.ne.0) WRITE(0,*)
376	$ 'Error in ig_clim_state allocation in PRISM_init_comp routine!'
377	ig_clim_state(:)=0
378	ALLOCATE (ig_def_state(il_CLIM_Maxport), stat=il_err)
379	IF (il_err.ne.0) WRITE(0,*)
380	$ 'Error in ig_def_state allocation in PRISM_init_comp routine!'
381	ig_def_state(:)=0
382	ALLOCATE (ig_clim_trans(ig_clim_nfield), stat=il_err)
383	IF (il_err.ne.0) WRITE(0,*)
384	$ 'Error in ig_clim_trans allocation in PRISM_init_comp routine!'
385	ig_clim_trans(:)=0
386	ALLOCATE (ig_clim_numlab(ig_clim_nfield), stat=il_err)
387	IF (il_err.ne.0) WRITE(0,*)
388	$ 'Error in ig_clim_numlab allocation in PRISM_init_comp routine!'
389	ig_clim_numlab(:)=0
390	ALLOCATE (ig_def_trans(il_CLIM_Maxport), stat=il_err)
391	IF (il_err.ne.0) WRITE(0,*)
392	$ 'Error in ig_def_trans allocation in PRISM_init_comp routine!'
393	ig_def_trans(:)=0
394	ALLOCATE (cg_clim_inpfile(ig_clim_nfield), stat=il_err)
395	IF (il_err.ne.0) WRITE(0,*)
396	$ 'Error in ig_clim_inpfile allocation in PRISM_init_comp routine!'
397	cg_clim_inpfile(:)=' '
398	ALLOCATE (cg_def_inpfile(il_CLIM_Maxport), stat=il_err)
399	IF (il_err.ne.0) WRITE(0,*)
400	$ 'Error in ig_def_inpfile allocation in PRISM_init_comp routine!'
401	cg_def_inpfile(:)=' '
402	ALLOCATE (cg_ignout_field(il_CLIM_Maxport), stat=il_err)
403	IF (il_err.ne.0) WRITE(0,*)
404	$ 'Error in cd_ignout_field allocation in PRISM_init_comp routine!'
405	cg_ignout_field(:)=' '
406	ALLOCATE (ig_def_numlab(il_clim_Maxport), stat=il_err)
407	IF (il_err.ne.0) WRITE(0,*)
408	$ 'Error in ig_def_numlab allocation in PRISM_init_comp routine!'
409	ig_def_numlab(:)=0
410	ALLOCATE (cga_clim_locatorbf(ig_clim_nfield), stat=il_err)
411	IF (il_err.ne.0) WRITE(0,*)
412	$ 'Error in cga_clim_locatorbf allocation in PRISM_init_comp!'
413	cga_clim_locatorbf(:)=' '
414	ALLOCATE (cga_clim_locatoraf(ig_clim_nfield), stat=il_err)
415	IF (il_err.ne.0) WRITE(0,*)
416	$ 'Error in cga_clim_locatoraf allocation in PRISM_init_comp!'
417	cga_clim_locatoraf(:)=' '
418	ALLOCATE (cga_clim_locator(il_clim_Maxport), stat=il_err)
419	IF (il_err.ne.0) WRITE(0,*)
420	$ 'Error in cga_clim_locator allocation in PRISM_init_comp!'
421	cga_clim_locator(:)=' '
422	c
423	CALL MPI_Recv ( rl_work, il_size, MPI_PACKED, 0,
424	$ itagcol+2, mpi_comm, mpi_status, mpi_err )
425	c
426	iposbuf = 0
427	call MPI_Unpack (rl_work, il_size, iposbuf, cgroup, 8,
428	$ MPI_CHARACTER, mpi_comm, info)
429	call MPI_Unpack (rl_work, il_size, iposbuf, ig_ntime, 1,
430	$ MPI_INTEGER, mpi_comm, info)
431	call MPI_Unpack (rl_work, il_size, iposbuf,kbcplproc, knmods,
432	$ MPI_INTEGER, mpi_comm, info)
433	call MPI_Unpack (rl_work, il_size, iposbuf, kbtotproc, knmods,
434	$ MPI_INTEGER, mpi_comm, info)
435	call MPI_Unpack (rl_work, il_size, iposbuf, iga_unitmod, knmods,
436	$ MPI_INTEGER, mpi_comm, info)
437	call MPI_Unpack (rl_work, il_size, iposbuf, ig_frqmin, 1,
438	$ MPI_INTEGER, mpi_comm, info)
439	call MPI_Unpack (rl_work, il_size, iposbuf, cg_cnaminp,
440	$ 8*ig_clim_nfield,MPI_CHARACTER, mpi_comm, info)
441	call MPI_Unpack (rl_work, il_size, iposbuf, cg_cnamout,
442	$ 8*ig_clim_nfield,MPI_CHARACTER, mpi_comm, info)
443	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_lag,
444	$ ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
445	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_reverse,
446	$ ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
447	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_invert,
448	$ ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
449	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_freq,
450	$ ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
451	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_seq,
452	$ ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
453	call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_rstfile,
454	$ 8*ig_clim_nfield,MPI_CHARACTER, mpi_comm, info)
455	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_norstfile,
456	$ ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
457	call MPI_Unpack (rl_work, il_size, iposbuf, ig_nbr_rstfile, 1,
458	$ MPI_INTEGER, mpi_comm, info)
459	call MPI_Unpack (rl_work, il_size, iposbuf, lg_ncdfrst, 1,
460	$ MPI_LOGICAL, mpi_comm, info)
461	call MPI_Unpack (rl_work, il_size, iposbuf, lg_oasis_field, 1,
462	$ MPI_LOGICAL, mpi_comm, info)
463	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_state,
464	$ ig_clim_nfield, MPI_INTEGER, mpi_comm, info)
465	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_trans,
466	$ ig_clim_nfield, MPI_INTEGER, mpi_comm, info)
467	call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_inpfile,
468	$ 32*ig_clim_nfield, MPI_CHARACTER, mpi_comm, info)
469	call MPI_Unpack (rl_work, il_size, iposbuf, ig_inidate,
470	$ 6, MPI_INTEGER, mpi_comm, info)
471	call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_numlab,
472	$ ig_clim_nfield, MPI_INTEGER, mpi_comm, info)
473	CSV>>
474	call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_cgrdnam,
475	$ 5, MPI_CHARACTER, mpi_comm, info)
476	call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_lonsuf,
477	$ 4, MPI_CHARACTER, mpi_comm, info)
478	call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_latsuf,
479	$ 4, MPI_CHARACTER, mpi_comm, info)
480	call MPI_Unpack (rl_work, il_size, iposbuf, crn_clim_lonsuf,
481	$ 4, MPI_CHARACTER, mpi_comm, info)
482	call MPI_Unpack (rl_work, il_size, iposbuf, crn_clim_latsuf,
483	$ 4, MPI_CHARACTER, mpi_comm, info)
484	call MPI_Unpack (rl_work, il_size, iposbuf, cga_clim_locatorbf,
485	$ 4*ig_clim_nfield, MPI_CHARACTER, mpi_comm, info)
486	call MPI_Unpack (rl_work, il_size, iposbuf, cga_clim_locatoraf,
487	$ 4*ig_clim_nfield, MPI_CHARACTER, mpi_comm, info)
488	call MPI_Unpack (rl_work, il_size, iposbuf, lg_clim_bsend, 1,
489	$ MPI_LOGICAL, mpi_comm, info)
490	CSV<<
491	il_maxcplproc = 1
492	DO ji = 1, knmods
493	IF (il_maxcplproc.lt.kbcplproc(ji))
494	$ il_maxcplproc = kbcplproc(ji)
495	END DO
496	ig_CLIMmax = 3 + CLIM_Clength + il_CLIM_Maxport *
497	$ (CLIM_Clength + 5 + CLIM_ParSize)
498	c
499	c* open trace file
500	c ---------------
501	c
502	iost = 0
503	nulprt = iga_unitmod(il_mynummod)
504	INQUIRE (nulprt,OPENED = ll_file)
505	DO WHILE (ll_file)
506	nulprt = nulprt + 1
507	INQUIRE (nulprt,OPENED = ll_file)
508	END DO
509	#ifdef use_comm_MPI1
510	CALL MPI_Comm_Rank(ig_local_comm, il_logrank, mpi_err)
511	#else
512	CALL MPI_Comm_Rank(MPI_COMM_WORLD, il_logrank, mpi_err)
513	#endif
514	IF(il_logrank .le. 9) THEN
515	WRITE(cnaprt, FMT='(A,''.prt'',I1)') cdnam, il_logrank
516	ELSE IF (il_logrank .le. 99) THEN
517	WRITE(cnaprt, FMT='(A,''.prt'',I2)') cdnam, il_logrank
518	ELSE IF (il_logrank .le. 999) THEN
519	WRITE(cnaprt, FMT='(A,''.prt'',I3)') cdnam, il_logrank
520	ELSE IF (il_logrank .le. 9999) THEN
521	WRITE(cnaprt, FMT='(A,''.prt'',I4)') cdnam, il_logrank
522	ELSE IF (il_logrank .gt. 99999) THEN
523	WRITE(0, *)'Cannot create the name of the trace file'
524	WRITE(0, *)'if more than 99999 processes for the model'
525	CALL MPI_ABORT (mpi_comm, 0, mpi_err)
526	ENDIF
527	OPEN (UNIT=nulprt, FILE=cnaprt, STATUS='UNKNOWN',
528	* FORM='FORMATTED', ERR=110, IOSTAT=iost)
529	WRITE(nulprt, *)'ig_clim_numlab', ig_clim_numlab(:)
530	c
531	110 CONTINUE
532	IF (iost.ne.0) THEN
533	WRITE(0,*) 'ABORT in Init - unable to open trace file ',
534	* iost
535	WRITE(0,*) nulprt, ' ', cnaprt
536	CALL MPI_ABORT (mpi_comm, 0, mpi_err)
537	ENDIF
538	WRITE(nulprt,*)'iga_unitmod, nulprt',
539	$ iga_unitmod(il_mynummod), nulprt
540
541	C
542	C* 4.1 Define ncplprocs, the total number of processes involved
543	C* in the coupling, initialize il_CLIM_MaxLink and allocate "modtid"
544	C -----------------------------------------------------------------
545	c
546	c For oasis monoprocessor and involved in the coupling : ncplprocs = 1
547	IF (lg_oasis_field) THEN
548	ncplprocs=1
549	ELSE
550	ncplprocs=0
551	ENDIF
552	DO 3 ji = 1, knmods
553	ncplprocs = ncplprocs + kbcplproc(ji)
554	3 CONTINUE
555	WRITE(nulprt,*)'Init - - ncplprocs = ', ncplprocs
556	IF (lg_oasis_field) THEN
557	il_start = 0
558	il_end = ncplprocs-1
559	ELSE
560	il_start = 1
561	il_end = ncplprocs
562	ENDIF
563	il_CLIM_MaxLink = ncplprocs * il_CLIM_Maxport
564
565	ALLOCATE (modtid(il_start:il_end), stat=il_err)
566	IF (il_err.ne.0) WRITE(nulprt,*)
567	$ 'Error in modtid allocation in PRISM_init_comp routine!'
568	modtid(:)=0
569
570	DO 10 ip = il_start, il_end
571	modtid(ip) = -1
572	10 CONTINUE
573
574
575	C* 4.2 Define modtid, the vector giving, for each process involved
576	C* in the coupling, its number in mpi_com (i.e in all model
577	C* processes involved OR NOT in the coupling)
578	C -----------------------------------------------------------
579	c
580	c For coupler
581	iprcou = 0
582	imodst = 0
583	IF (lg_oasis_field) modtid(0) = 0
584	c For models
585	DO 5 ji = 1, knmods
586	IF (ji .eq. 1) THEN
587	imodst = 1
588	ELSE
589	imodst = imodst + kbtotproc(ji-1)
590	ENDIF
591	iprmod = 0
592	DO 7 jj = 1, kbcplproc(ji)
593	iprcou = iprcou + 1
594	iprmod = iprmod + 1
595	modtid(iprcou) = imodst + iprmod - 1
596	7 CONTINUE
597	5 CONTINUE
598	c
599	C 4.3 Allocate and initialize arrays defined in mod_comprism MODULE
600	c --------------------------------------------------------------
601
602
603	CALL MPI_Comm_Rank(mpi_comm,il_rank,mpi_err)
604	c
605	DO ji = 1, il_end
606	IF (il_rank.eq.modtid(ji)) THEN
607	ALLOCATE (ncode(il_start:il_end), stat=il_err)
608	IF (il_err.ne.0) WRITE(nulprt,*)
609	$ 'Error in ncode allocation in PRISM_init_comp routine!'
610	ncode(:)=0
611	ALLOCATE (delta(il_start:il_end), stat=il_err)
612	IF (il_err.ne.0) WRITE(nulprt,*)
613	$ 'Error in delta allocation in PRISM_init_comp routine!'
614	delta(:)=0
615	ALLOCATE (delte(il_start:il_end), stat=il_err)
616	IF (il_err.ne.0) WRITE(nulprt,*)
617	$ 'Error in delte allocation in PRISM_init_comp routine!'
618	delte(:)=0
619	ALLOCATE (cnames(il_start:il_end), stat=il_err)
620	IF (il_err.ne.0) WRITE(nulprt,*)
621	$ 'Error in cnames allocation in PRISM_init_comp routine!'
622	cnames(:)=' '
623	ALLOCATE (myport(5+il_maxcplproc,il_CLIM_Maxport),
624	$ stat = il_err)
625	IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
626	$ ' Problem in myport allocation in PRISM_init_comp!'
627	myport(:,:)=0
628	ALLOCATE (mydist(CLIM_ParSize, il_CLIM_Maxport),
629	$ stat = il_err)
630	IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
631	$ ' Problem in mydist allocation in PRISM_init_comp!'
632	mydist(:,:)=0
633	ALLOCATE (cports(il_CLIM_Maxport), stat = il_err)
634	IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
635	$ ' Problem in cports allocation in PRISM_init_comp!'
636	cports(:)=' '
637	ALLOCATE(clrport(il_CLIM_Maxport), stat = il_err)
638	IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
639	$ 'Error in clrport allocation in PRISM_init_comp!'
640	clrport(:)=' '
641	ALLOCATE(irdist(CLIM_ParSize, il_CLIM_Maxport),
642	$ stat = il_err)
643	IF (il_err.ne.0) WRITE(nulprt,*)
644	$ 'Error in irdist allocation in PRISM_init_comp'
645	irdist(:,:)=0
646	ALLOCATE(irport(5,il_CLIM_Maxport ), stat = il_err)
647	IF (il_err.ne.0) WRITE(nulprt,*)
648	$ 'Error in irport allocation in PRISM_init_comp'
649	irport(:,:)=0
650	ALLOCATE (mylink(4+CLIM_ParSize, il_CLIM_MaxLink),
651	$ stat = il_err)
652	IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
653	$ ' Problem in mylink allocation in PRISM_init_comp!'
654	mylink(:,:)=0
655	ALLOCATE (pkwork(ig_CLIMmax), stat = il_err)
656	IF (il_err.ne.0) WRITE(nulprt,*)
657	$ 'Error in pkwork allocation in PRISM_init_comp'
658	pkwork(:)=0
659	ALLOCATE (ig_def_part(CLIM_ParSize, ig_clim_nfield),
660	$ stat = il_err)
661	IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
662	$ ' Problem in ig_def_part allocation in PRISM_init_comp!'
663	ig_def_part(:,:)=0
664	ALLOCATE (ig_length_part(ig_clim_nfield), stat = il_err)
665	IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
666	$ ' Problem in ig_def_part allocation in PRISM_init_comp!'
667	ig_length_part(:)=0
668	c
669	DO ip = il_start, il_end
670	cnames(ip) = ' '
671	ENDDO
672	ENDIF
673	END DO
674	c
675	c
676	C* 4.4 Define mynum, the number of the actual processor
677	c in all processors involved in the coupling
678	c If actual process is NOT involved in the coupling
679	c it will NOT call CLIM_Start
680	C -----------------------------------------------------------
681	c
682	CALL MPI_Comm_Size(ig_local_comm, mpi_size, mpi_err)
683	CALL MPI_Comm_Rank(ig_local_comm, mpi_rank, mpi_err)
684	c
685	c For model with il_mynummod=1, imodst=1
686	imodst = 1
687	IF (il_mynummod .gt. 1) then
688	DO 8 ji = 2, il_mynummod
689	imodst = imodst + kbcplproc(ji-1)
690	WRITE(nulprt,*)'imodst :',imodst
691	8 CONTINUE
692	ENDIF
693	c
694	mynum = imodst + mpi_rank
695	C
696	WRITE(nulprt,*)'Init - - mynummod = ', il_mynummod
697	WRITE(nulprt,*)'Init - - mynum = ', mynum
698	WRITE(nulprt,*)'Init - - modtid() = ', modtid
699
700	DEALLOCATE(rl_work)
701
702	cg_modnam(il_mynummod) = cdnam
703
704	#if !defined key_noIO
705	call psmile_io_init_comp(il_err)
706	#endif
707	cvg>>>
708	C* 4.5 Initialization of grids writing
709	C -----------------------------------
710	c
711	c-- Receive flag 'grids_start' stating whether or not grids writing is needed
712	c
713	WRITE (nulprt,*) 'Recv - grids_start'
714	CALL MPI_Recv (grids_start, 1, MPI_INTEGER, 0, itagcol+3,
715	$ mpi_comm, mpi_status, mpi_err)
716	IF (mpi_err == MPI_SUCCESS) THEN
717	WRITE(nulprt,*) 'Recv - <from:0> <comm:',mpi_comm,'> <len:1>
718	$ <type:',MPI_INTEGER,'> <tag:',itagcol,'+3> :: ',
719	$ grids_start
720	CALL FLUSH(nulprt)
721	ELSE
722	WRITE (nulprt,*) ' '
723	WRITE (nulprt,*) 'prism_init_comp: an error occured'
724	WRITE (nulprt,*) 'prism_init_comp: err= ', mpi_err
725	WRITE (nulprt,*) 'prism_init_comp: STOP'
726	call MPI_ABORT (mpi_comm, 0, mpi_err)
727	ENDIF
728	cvg<<<
729
730	c
731	C* 5. Normal EXIT
732	C
733	1010 CONTINUE
734
735	WRITE (nulprt,FMT='(A)') 'Init - -'
736	CALL FLUSH(nulprt)
737	RETURN
738	C
739	C* 6. Error STOP
740	C
741	215 CONTINUE
742	WRITE (UNIT = nulprt,FMT = ) ' WARNING*'
743	WRITE (UNIT = nulprt,FMT = *)
744	$ ' Problem with MPI_Comm_Split function !!! '
745	WRITE (UNIT = nulprt,FMT = *) ' Mpi error code = ',mpi_err
746	WRITE (UNIT = nulprt,FMT = *) ' '
747	WRITE (UNIT = nulprt,FMT = *) ' '
748	WRITE (UNIT = nulprt,FMT = *) 'STOP in PRISM_init_comp'
749	call MPI_ABORT (mpi_comm, 0, mpi_err)
750	C
751	RETURN
752	END
753
754

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

Context Navigation

source: CPL/oasis3/trunk/src/lib/psmile/src/prism_init_comp_proto.F @ 1677

Download in other formats: