Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mod_oasis_auxiliary_routines.F90 @ 6331

Last change on this file since 6331 was 6331, checked in by aclsce, 17 months ago
Moved oasis-mct_5.0 in oasis3-mct/branches directory.
File size: 27.8 KB

Line
1
2	!> Auxiliary OASIS user interfaces
3
4	MODULE mod_oasis_auxiliary_routines
5	!---------------------------------------------------------------------
6
7	USE mod_oasis_kinds
8	USE mod_oasis_data
9	USE mod_oasis_parameters
10	USE mod_oasis_coupler
11	USE mod_oasis_timer
12	USE mod_oasis_var
13	USE mod_oasis_sys
14	USE mod_oasis_io
15	USE mod_oasis_mpi
16	USE mct_mod
17
18	implicit none
19	private
20
21	public oasis_get_localcomm
22	public oasis_set_couplcomm
23	public oasis_create_couplcomm
24	public oasis_get_debug
25	public oasis_set_debug
26	public oasis_get_intercomm
27	public oasis_get_intracomm
28	public oasis_get_multi_intracomm
29	public oasis_get_ncpl
30	public oasis_put_inquire
31	public oasis_get_freqs
32
33	#include "oasis_os.h"
34
35	integer(kind=ip_i4_p) istatus(MPI_STATUS_SIZE)
36
37	!---------------------------------------------------------------------
38	CONTAINS
39	!---------------------------------------------------------------------
40
41	!> OASIS user query for the local MPI communicator
42
43	SUBROUTINE oasis_get_localcomm(localcomm,kinfo)
44
45	IMPLICIT NONE
46
47	INTEGER (kind=ip_intwp_p),intent(out) :: localcomm !< MPI communicator
48	INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo !< return code
49	! ---------------------------------------------------------
50	character(len=*),parameter :: subname = '(oasis_get_localcomm)'
51	! ---------------------------------------------------------
52
53	call oasis_debug_enter(subname)
54	if (present(kinfo)) then
55	kinfo = OASIS_OK
56	endif
57
58	! from prism_data
59	localcomm = mpi_comm_local
60	IF (OASIS_debug >= 2) THEN
61	WRITE(nulprt,*) 'localcomm :',localcomm
62	CALL oasis_FLUSH(nulprt)
63	ENDIF
64
65	call oasis_debug_exit(subname)
66
67	END SUBROUTINE oasis_get_localcomm
68	!----------------------------------------------------------------------
69
70	!> OASIS user call to specify a local communicator
71
72	SUBROUTINE oasis_set_couplcomm(localcomm,kinfo)
73
74	IMPLICIT NONE
75
76	INTEGER (kind=ip_intwp_p),intent(in) :: localcomm !< MPI communicator
77	INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo !< return code
78	! ---------------------------------------------------------
79	integer(kind=ip_intwp_p) :: ierr
80	character(len=*),parameter :: subname = '(oasis_set_couplcomm)'
81	! ---------------------------------------------------------
82
83	call oasis_debug_enter(subname)
84	if (present(kinfo)) then
85	kinfo = OASIS_OK
86	endif
87
88	!------------------------
89	!--- update mpi_comm_local from component
90	!------------------------
91
92	mpi_comm_local = localcomm
93
94	!------------------------
95	!--- and now update necessary info
96	!------------------------
97
98	mpi_size_local = -1
99	mpi_rank_local = -1
100	if (mpi_comm_local /= MPI_COMM_NULL) then
101	CALL MPI_Comm_Size(mpi_comm_local,mpi_size_local,ierr)
102	call oasis_mpi_chkerr(ierr,trim(subname)//' size')
103	CALL MPI_Comm_Rank(mpi_comm_local,mpi_rank_local,ierr)
104	call oasis_mpi_chkerr(ierr,trim(subname)//' rank')
105	mpi_root_local = 0
106	endif
107
108	call oasis_debug_exit(subname)
109
110	END SUBROUTINE oasis_set_couplcomm
111	!----------------------------------------------------------------------
112
113	!> OASIS user call to create a new communicator
114
115	SUBROUTINE oasis_create_couplcomm(icpl,allcomm,cplcomm,kinfo)
116
117	IMPLICIT NONE
118
119	INTEGER (kind=ip_intwp_p),intent(in) :: icpl !< coupling process flag
120	INTEGER (kind=ip_intwp_p),intent(in) :: allcomm !< input MPI communicator
121	INTEGER (kind=ip_intwp_p),intent(out) :: cplcomm !< reduced MPI communicator
122	INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo !< return code
123	! ---------------------------------------------------------
124	integer(kind=ip_intwp_p) :: ierr
125	character(len=*),parameter :: subname = '(oasis_create_couplcomm)'
126	! ---------------------------------------------------------
127
128	call oasis_debug_enter(subname)
129	if (present(kinfo)) then
130	kinfo = OASIS_OK
131	endif
132
133	!------------------------
134	!--- generate cplcomm from allcomm and icpl
135	!------------------------
136
137	CALL MPI_COMM_Split(allcomm,icpl,1,cplcomm,ierr)
138	call oasis_mpi_chkerr(ierr,trim(subname)//' split')
139
140	!------------------------
141	!--- update mpi_comm_local from component
142	!------------------------
143
144	call oasis_set_couplcomm(cplcomm)
145
146	IF (OASIS_debug >= 2) THEN
147	WRITE (nulprt,*) 'New local coupling comm =',cplcomm
148	CALL oasis_flush(nulprt)
149	ENDIF
150
151	call oasis_debug_exit(subname)
152
153	END SUBROUTINE oasis_create_couplcomm
154	!----------------------------------------------------------------------
155
156	!> OASIS user interface to query debug level
157
158	SUBROUTINE oasis_get_debug(debug,kinfo)
159
160	IMPLICIT NONE
161
162	INTEGER (kind=ip_intwp_p),intent(out) :: debug !< debug level
163	INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo !< return code
164	! ---------------------------------------------------------
165	character(len=*),parameter :: subname = '(oasis_get_debug)'
166	! ---------------------------------------------------------
167
168	call oasis_debug_enter(subname)
169	if (present(kinfo)) then
170	kinfo = OASIS_OK
171	endif
172
173	debug = OASIS_debug
174
175	call oasis_debug_exit(subname)
176
177	END SUBROUTINE oasis_get_debug
178	!----------------------------------------------------------------------
179
180	!> OASIS user interface to set debug level
181
182	SUBROUTINE oasis_set_debug(debug,kinfo)
183
184	IMPLICIT NONE
185
186	INTEGER (kind=ip_intwp_p),intent(in) :: debug !< debug level
187	INTEGER (kind=ip_intwp_p),intent(inout),optional :: kinfo !< return code
188	! ---------------------------------------------------------
189	character(len=*),parameter :: subname = '(oasis_set_debug)'
190	! ---------------------------------------------------------
191
192	call oasis_debug_enter(subname)
193	if (present(kinfo)) then
194	kinfo = OASIS_OK
195	endif
196
197	OASIS_debug = debug
198	if (OASIS_debug >= 2) then
199	write(nulprt,*) subname,' set OASIS_debug to ',OASIS_debug
200	CALL oasis_flush(nulprt)
201	endif
202
203	call oasis_debug_exit(subname)
204
205	END SUBROUTINE oasis_set_debug
206	!----------------------------------------------------------------------
207
208	!> OASIS user interface to establish an MPI intercomm communicator between two models
209
210	SUBROUTINE oasis_get_intercomm(new_comm, cdnam, kinfo)
211
212	IMPLICIT NONE
213
214	INTEGER (kind=ip_intwp_p),intent(out) :: new_comm !< out MPI communicator
215	CHARACTER(len=*),intent(in) :: cdnam !< other model name to link with
216	INTEGER (kind=ip_intwp_p),intent(out),optional :: kinfo !< return code
217
218	INTEGER (kind=ip_intwp_p) :: n, il, ierr, tag, i_me
219	INTEGER (KIND=MPI_ADDRESS_KIND) :: imax_tag_mpi
220	LOGICAL :: found, ferr
221	! ---------------------------------------------------------
222	character(len=*),parameter :: subname = '(oasis_get_intercomm)'
223	! ---------------------------------------------------------
224
225	call oasis_debug_enter(subname)
226	if (present(kinfo)) then
227	kinfo = OASIS_OK
228	endif
229
230	found = .false.
231	do n = 1,prism_amodels
232	if (trim(cdnam) == trim(prism_modnam(n))) then
233	if (found) then
234	write(nulprt,*) subname,estr,'found same model name twice: ',trim(prism_modnam(n))
235	call oasis_abort(file=__FILE__,line=__LINE__)
236	endif
237	il = n
238	found = .true.
239	endif
240	if (trim(compnm) == trim(prism_modnam(n))) then
241	i_me = n
242	endif
243	enddo
244
245	if (.not. found) then
246	write(nulprt,*) subname,estr,'input model name not found'
247	call oasis_abort(file=__FILE__,line=__LINE__)
248	endif
249
250	IF (OASIS_debug >= 2) THEN
251	WRITE(nulprt,*) subname, 'cdnam :',trim(cdnam),' il :',il, &
252	'mpi_root_global(il) :',mpi_root_global(il),&
253	'mpi_comm_local :',mpi_comm_local
254	CALL oasis_flush(nulprt)
255	ENDIF
256
257	! Definition of a MPI tag that must be unique for each
258	! intercommunicator
259	!
260	! Note: this is not the case if the oasis_get_intercomm routine
261	! is called twice with the same component couple
262
263	tag = prime_nbs(il) * prime_nbs(i_me)
264
265	! The MPI standard guarantees that the tag upper bound value (MPI_TAG_UB)
266	! must be at least 32767, which is the case in this implementation,
267	! given that the maximum tag value is equal to
268	! prime_nbs(prism_nmodels-1) * prime_nbs(prism_nmodels) = 67x71 = 4757
269	!
270	! For that reason, the test below is not mandatory and can be commented in
271	! case of portability issues
272
273	CALL mpi_comm_get_attr(mpi_comm_local, MPI_TAG_UB, imax_tag_mpi, ferr, ierr)
274
275	IF ( ierr == 0 .and. ferr ) THEN
276	IF ( tag >= imax_tag_mpi ) THEN
277	WRITE(nulprt,*) subname, ' Incorrect value of MPI tag (', tag, &
278	') bigger than max value : ', imax_tag_mpi
279	CALL oasis_abort(file=__FILE__,line=__LINE__)
280	ELSEIF ( OASIS_debug >= 2 ) THEN
281	WRITE(nulprt,*) subname, ' MPI tag value and limit : ', tag, imax_tag_mpi
282	CALL oasis_flush(nulprt)
283	ENDIF
284	ENDIF
285
286	IF ( OASIS_debug >= 2 ) THEN
287	WRITE(nulprt,*) subname, 'Tag intercomm :', tag
288	CALL oasis_flush(nulprt)
289	ENDIF
290
291	CALL mpi_intercomm_create(mpi_comm_local, 0, mpi_comm_global, &
292	mpi_root_global(il), tag, new_comm, ierr)
293
294	call oasis_mpi_chkerr(ierr,trim(subname)//' intercomm_create')
295
296	call oasis_debug_exit(subname)
297
298	END SUBROUTINE oasis_get_intercomm
299	!----------------------------------------------------------------------
300
301	!> OASIS user interface to establish an intracomm communicator between two components
302
303	SUBROUTINE oasis_get_intracomm(new_comm, cdnam, kinfo)
304
305	IMPLICIT NONE
306
307	INTEGER (kind=ip_intwp_p),intent(out) :: new_comm !< output MPI communicator
308	CHARACTER(len=*),intent(in) :: cdnam !< other model name
309	INTEGER (kind=ip_intwp_p),intent(out),optional :: kinfo !< return code
310
311	INTEGER (kind=ip_intwp_p) :: tmp_intercomm, ierr
312	! ---------------------------------------------------------
313	character(len=*),parameter :: subname = '(oasis_get_intracomm)'
314	! ---------------------------------------------------------
315
316	call oasis_debug_enter(subname)
317	if (present(kinfo)) then
318	kinfo = OASIS_OK
319	endif
320
321	call oasis_get_intercomm(tmp_intercomm, cdnam, kinfo)
322
323	CALL mpi_intercomm_merge(tmp_intercomm,.FALSE., new_comm, ierr)
324	call oasis_mpi_chkerr(ierr,trim(subname)//' intercomm_merge')
325
326	call oasis_debug_exit(subname)
327
328	END SUBROUTINE oasis_get_intracomm
329
330	!----------------------------------------------------------------------
331
332	!> OASIS user interface to establish an intracomm communicator between two or more components
333
334	SUBROUTINE oasis_get_multi_intracomm(new_comm, cdnam, root_ranks, kinfo)
335
336	IMPLICIT NONE
337
338	INTEGER (kind=ip_intwp_p),intent(out) :: new_comm !< output MPI communicator
339	CHARACTER(len=*) ,intent(in) :: cdnam(:) !< other model names
340	INTEGER (kind=ip_intwp_p),intent(out) :: root_ranks(:) !< root rank of each model in cdnam in new comm
341	INTEGER (kind=ip_intwp_p),intent(out) :: kinfo !< return code
342
343	INTEGER (kind=ip_intwp_p) :: tmp_comm, inter_comm, tmpsize, tmprank
344	INTEGER (kind=ip_intwp_p),allocatable :: cdnum(:),rranks(:)
345	INTEGER (kind=ip_intwp_p) :: n, k, k2, ierr, tag, icnt, remote_leader
346	LOGICAL :: found, found_myself, inter_high
347	! ---------------------------------------------------------
348	character(len=*),parameter :: subname = '(oasis_get_multi_intracomm)'
349	! ---------------------------------------------------------
350
351	call oasis_debug_enter(subname)
352	kinfo = OASIS_OK
353
354	if (size(cdnam) /= size(root_ranks)) then
355	write(nulprt,*) subname,estr,'cdnam and root_ranks sizes not the same'
356	call oasis_abort(file=__FILE__,line=__LINE__)
357	endif
358
359	allocate(cdnum(size(cdnam)))
360
361	! error check list of cdnam values
362	! create list of components involved, cdnum
363	found_myself=.false.
364	icnt = 0
365	do k = 1,size(cdnam)
366	!--- skip blank lines
367	if (len_trim(cdnam(k)) > 0) then
368	!--- must contain me at some point
369	if (trim(cdnam(k)) == trim(compnm)) then
370	found_myself = .true.
371	endif
372	!--- must not contain redundant values
373	do k2 = k+1 ,size(cdnam)
374	if (trim(cdnam(k)) == trim(cdnam(k2))) then
375	write(nulprt,*) subname,estr,'model name duplicated in cdnam list: ',trim(cdnam(k))
376	call oasis_abort(file=__FILE__,line=__LINE__)
377	endif
378	enddo
379	!--- must contain only valid model names
380	found = .false.
381	do n = 1,prism_amodels
382	if (trim(cdnam(k)) == trim(prism_modnam(n))) then
383	if (found) then
384	write(nulprt,*) subname,estr,'found model name twice in cdnam list: ',trim(cdnam(k))
385	call oasis_abort(file=__FILE__,line=__LINE__)
386	endif
387	found = .true.
388	icnt = icnt + 1
389	cdnum(icnt) = n
390	endif
391	enddo
392	if (.not.found) then
393	write(nulprt,*) subname,estr,'model name does not exist: ',trim(cdnam(k))
394	call oasis_abort(file=__FILE__,line=__LINE__)
395	endif
396	endif
397	enddo
398
399	! check that my component name was in cdnam
400	if (.not. found_myself) then
401	write(nulprt,*) subname,estr,'must include my model name when calling',trim(compnm)
402	call oasis_abort(file=__FILE__,line=__LINE__)
403	endif
404
405	! check there is at least one other valid model to connect to
406	if (icnt <= 1) then
407	write(nulprt,*) subname,estr,'must have at least 2 model names: ',icnt,cdnam
408	call oasis_abort(file=__FILE__,line=__LINE__)
409	endif
410
411	! now sort cdnum so all components are going to call the mpi ops in the same order consistently
412	do k = 1,icnt
413	do k2 = k+1,icnt
414	if (cdnum(k2) < cdnum(k)) then
415	n = cdnum(k)
416	cdnum(k) = cdnum(k2)
417	cdnum(k2) = n
418	endif
419	enddo
420	enddo
421	if (OASIS_debug >= 2) then
422	write(nulprt,*) subname, 'cdnum=',cdnum(1:icnt)
423	call oasis_flush(nulprt)
424	endif
425
426	! order calls by model number via cdnum
427	! create pairwise calls from lower to higher comp ids
428	! don't need to check here, checks above will trap inconsistencies
429	! including each value in cdnam is not repeated and is valid
430	! compute rranks
431
432	allocate(rranks(icnt))
433	rranks=-1
434	rranks(1)=0
435	call MPI_comm_dup(mpi_comm_local, tmp_comm, ierr)
436	call oasis_mpi_chkerr(ierr,trim(subname)//' comm_dup local')
437	do k = 2,icnt
438	n = cdnum(k)
439	rranks(k) = rranks(k-1) + mpi_comp_size(cdnum(k-1))
440	tag=8000+n
441	if (compid == n) then
442	remote_leader = mpi_root_global(cdnum(1)) ! root of 1st model
443	inter_high = .true.
444	else
445	remote_leader = mpi_root_global(n) ! root of model k
446	inter_high = .false.
447	endif
448	if (compid <= n) then
449	if (OASIS_debug >= 2) then
450	write(nulprt,'(2a,2i4,a,i6,a,i8)') subname,' k,n =',k,n, &
451	' remote_leader=',remote_leader, ' tag=',tag
452	call MPI_Comm_Size(tmp_comm,tmpsize,ierr)
453	call oasis_mpi_chkerr(ierr,trim(subname)//' size')
454	call MPI_Comm_Rank(tmp_comm,tmprank,ierr)
455	call oasis_mpi_chkerr(ierr,trim(subname)//' rank')
456	write(nulprt,*) subname,' tmp_comm size,rank=',tmpsize,tmprank
457	call oasis_flush(nulprt)
458	endif
459	! inter_comm = tmp_comm + remote_comm
460	call MPI_intercomm_create(tmp_comm, 0, mpi_comm_global, &
461	remote_leader, tag, inter_comm, ierr)
462	call oasis_mpi_chkerr(ierr,trim(subname)//' intercomm_create')
463	call MPI_comm_free(tmp_comm,ierr)
464	call oasis_mpi_chkerr(ierr,trim(subname)//' comm_free tmp_comm')
465	! tmp_comm = inter2intra(inter_comm)
466	call MPI_intercomm_merge(inter_comm, inter_high, tmp_comm, ierr)
467	call oasis_mpi_chkerr(ierr,trim(subname)//' intercomm_merge')
468	call MPI_comm_free(inter_comm,ierr)
469	call oasis_mpi_chkerr(ierr,trim(subname)//' comm_free inter_comm')
470	endif
471	enddo
472
473	new_comm = tmp_comm
474	root_ranks = -1
475	do n = 1,icnt
476	do k = 1,size(cdnam)
477	if (cdnam(k) == prism_modnam(cdnum(n))) then
478	root_ranks(k) = rranks(n)
479	endif
480	enddo
481	enddo
482	if (OASIS_debug >= 2) then
483	do k = 1,size(cdnam)
484	write(nulprt,'(2a,i4,3a,i8)') subname,' k =',k, &
485	' cdnam = ',trim(cdnam(k)), &
486	' root_rank = ',root_ranks(k)
487	enddo
488	call oasis_flush(nulprt)
489	endif
490
491	deallocate(rranks)
492	deallocate(cdnum)
493
494	call oasis_debug_exit(subname)
495
496	END SUBROUTINE oasis_get_multi_intracomm
497	!----------------------------------------------------------------------
498
499	!> OASIS user query for the number of unique couplings associated with a variable
500
501	SUBROUTINE oasis_get_ncpl(varid, ncpl, kinfo)
502
503	IMPLICIT none
504	!-------------------------------------
505	INTEGER(kind=ip_i4_p) , INTENT(in) :: varid !< variable id
506	INTEGER(kind=ip_i4_p) , INTENT(out) :: ncpl !< number of namcouple couplings
507	INTEGER(kind=ip_i4_p) , INTENT(out) :: kinfo !< return code
508	!-------------------------------------
509	CHARACTER(len=ic_lvar) :: vname
510	CHARACTER(len=*),PARAMETER :: subname = 'oasis_get_ncpl'
511	!-------------------------------------
512
513	CALL oasis_debug_enter(subname)
514
515	IF (mpi_comm_local == MPI_COMM_NULL) THEN
516	WRITE(nulprt,*) subname,estr,'called on non coupling task'
517	call oasis_abort(file=__FILE__,line=__LINE__)
518	ENDIF
519
520	kinfo = OASIS_OK
521	vname = prism_var(varid)%name
522
523	IF (varid == OASIS_Var_Uncpl) THEN
524	WRITE(nulprt,*) subname,estr,'Routine is called for an invalid varid'
525	call oasis_abort(file=__FILE__,line=__LINE__)
526	ENDIF
527
528	ncpl = prism_var(varid)%ncpl
529
530	IF (ncpl <= 0) THEN
531	IF (OASIS_debug >= 2) WRITE(nulprt,*) subname,' Variable not coupled ',&
532	TRIM(vname)
533	ELSE
534	IF (OASIS_debug >= 2) WRITE(nulprt,*) subname,' Variable: ',TRIM(vname),&
535	' used in ',ncpl,' couplings'
536	ENDIF
537
538	CALL oasis_debug_exit(subname)
539
540	END SUBROUTINE oasis_get_ncpl
541	!---------------------------------------------------------------------
542
543	!> OASIS user query for the coupling periods for a given variable
544
545	SUBROUTINE oasis_get_freqs(varid, mop, ncpl, cpl_freqs, kinfo)
546
547	IMPLICIT none
548	!-------------------------------------
549	INTEGER(kind=ip_i4_p) , INTENT(in) :: varid !< variable id
550	INTEGER(kind=ip_i4_p) , INTENT(in) :: mop !< OASIS_Out or OASIS_In type
551	INTEGER(kind=ip_i4_p) , INTENT(in) :: ncpl !< number of namcouple couplings
552	INTEGER(kind=ip_i4_p) , INTENT(out) :: cpl_freqs(ncpl)!< coupling period (sec)
553	INTEGER(kind=ip_i4_p) , INTENT(out) :: kinfo !< return code
554	!-------------------------------------
555	CHARACTER(len=ic_lvar) :: vname
556	INTEGER(kind=ip_i4_p) :: ncpl_calc, cplid, nc
557	CHARACTER(len=*),PARAMETER :: subname = 'oasis_get_freqs'
558	!-------------------------------------
559
560	CALL oasis_debug_enter(subname)
561
562	IF (mpi_comm_local == MPI_COMM_NULL) THEN
563	WRITE(nulprt,*) subname,estr,'called on non coupling task'
564	call oasis_abort(file=__FILE__,line=__LINE__)
565	ENDIF
566
567	kinfo = OASIS_OK
568	vname = prism_var(varid)%name
569
570	IF (varid == OASIS_Var_Uncpl) THEN
571	WRITE(nulprt,*) subname,estr,'Routine is called for an invalid varid'
572	call oasis_abort(file=__FILE__,line=__LINE__)
573	ENDIF
574
575	ncpl_calc = prism_var(varid)%ncpl
576
577	IF (ncpl_calc /= ncpl) THEN
578	WRITE(nulprt,*) subname,estr,' Wrong number of couplings for variable: ',TRIM(vname), &
579	ncpl_calc, ncpl
580	call oasis_abort(file=__FILE__,line=__LINE__)
581	ENDIF
582
583	IF (ncpl <= 0) THEN
584	IF (OASIS_debug >= 2) WRITE(nulprt,*) subname,' variable not coupled ',&
585	TRIM(vname)
586	ENDIF
587
588	DO nc = 1,ncpl
589	cplid = prism_var(varid)%cpl(nc)
590	IF (mop == OASIS_Out) THEN
591	cpl_freqs(nc) = prism_coupler_put(cplid)%dt
592	ENDIF
593	IF (mop == OASIS_In ) THEN
594	cpl_freqs(nc) = prism_coupler_get(cplid)%dt
595	ENDIF
596
597	IF (OASIS_Debug >=2 ) THEN
598	WRITE(nulprt,*) subname,' Coupling frequency of this field ',TRIM(vname),&
599	' for coupling ',nc, ' is ',cpl_freqs(nc)
600	ENDIF
601
602	IF (cpl_freqs(nc) .le. 0) THEN
603	WRITE(nulprt,*) subname,estr,' The coupling frequency is < or equal to 0'
604	call oasis_abort(file=__FILE__,line=__LINE__)
605	ENDIF
606	ENDDO
607
608	CALL oasis_debug_exit(subname)
609
610	END SUBROUTINE oasis_get_freqs
611	!---------------------------------------------------------------------
612
613	!> OASIS user query to indicate put return code expected at a specified time for a given variable
614
615	SUBROUTINE oasis_put_inquire(varid,msec,kinfo)
616
617	IMPLICIT none
618	!-------------------------------------
619	integer(kind=ip_i4_p) , intent(in) :: varid !< variable id
620	integer(kind=ip_i4_p) , intent(in) :: msec !< model time in seconds
621	integer(kind=ip_i4_p) , intent(out) :: kinfo !< return code
622	!-------------------------------------
623	character(len=ic_lvar) :: vname
624	INTEGER(kind=ip_i4_p) :: ncpl, nc, cplid
625	INTEGER(kind=ip_i4_p) :: lag, mseclag, trans, dt, getput, maxtime
626	LOGICAL :: time_now, sndrcv, output
627	character(len=*),parameter :: subname = 'oasis_put_inquire'
628	!-------------------------------------
629
630	CALL oasis_debug_enter(subname)
631
632	IF (mpi_comm_local == MPI_COMM_NULL) THEN
633	WRITE(nulprt,*) subname,estr,'called on non coupling task'
634	call oasis_abort(file=__FILE__,line=__LINE__)
635	ENDIF
636
637	kinfo = OASIS_OK
638	vname = prism_var(varid)%name
639
640	IF (varid == OASIS_Var_Uncpl) THEN
641	WRITE(nulprt,*) subname,estr, &
642	'Routine oasis_put is called for a variable not in namcouple: it will not be sent'
643	call oasis_abort(file=__FILE__,line=__LINE__)
644	ENDIF
645
646	ncpl = prism_var(varid)%ncpl
647
648	IF (ncpl <= 0) THEN
649	IF (OASIS_debug >= 2) WRITE(nulprt,*) subname,' variable not coupled ',&
650	TRIM(vname)
651	ENDIF
652
653	DO nc = 1,ncpl
654
655	cplid = prism_var(varid)%cpl(nc)
656	dt = prism_coupler_put(cplid)%dt
657	lag = prism_coupler_put(cplid)%lag
658	getput = prism_coupler_put(cplid)%getput
659	sndrcv = prism_coupler_put(cplid)%sndrcv
660	maxtime = prism_coupler_put(cplid)%maxtime
661	output = prism_coupler_put(cplid)%output
662	trans = prism_coupler_put(cplid)%trans
663
664	!------------------------------------------------
665	! check that lag is reasonable
666	!------------------------------------------------
667
668	IF (ABS(lag) > dt) THEN
669	WRITE(nulprt,*) subname,estr,' ERROR lag gt dt for cplid',cplid
670	call oasis_abort(file=__FILE__,line=__LINE__)
671	ENDIF
672
673	!------------------------------------------------
674	! check that field is OASIS_PUT
675	!------------------------------------------------
676
677	IF (getput == OASIS3_GET) THEN
678	WRITE(nulprt,*) subname,estr,'routine can only be called for OASIS_PUT variable'
679	call oasis_abort(file=__FILE__,line=__LINE__)
680	ENDIF
681
682	CALL oasis_debug_note(subname//' set mseclag')
683	IF (getput == OASIS3_PUT) THEN
684	mseclag = msec + lag
685	ENDIF
686
687	!------------------------------------------------
688	! check that model hasn't gone past maxtime
689	!------------------------------------------------
690
691	if (msec >= maxtime) then
692	write(nulprt,*) subname,' at ',msec,mseclag,' ERROR: ',trim(vname)
693	write(nulprt,*) subname,estr,'model time must be strictly smaller than namcouple $RUNTIME =',&
694	msec,maxtime
695	call oasis_abort(file=__FILE__,line=__LINE__)
696	endif
697
698	time_now = .FALSE.
699	IF (MOD(mseclag,dt) == 0) time_now = .TRUE.
700
701	!-------------------------------------------------------------------
702	! Test what is the current status of the field if time_now = .TRUE.
703	!-------------------------------------------------------------------
704
705	IF (time_now .EQV. .TRUE.) THEN
706
707	IF (OASIS_debug >= 2) THEN
708	WRITE(nulprt,*) subname,' Coupling time for : ',trim(vname)
709	WRITE(nulprt,*) subname,' Coupling time for var for nc : ',&
710	TRIM(mct_avect_exportRList2c(prism_coupler_put(cplid)%avect1)),nc
711	WRITE(nulprt,*) subname,' dt,msec,mseclag = ',dt,msec,mseclag
712	CALL oasis_flush(nulprt)
713	ENDIF
714
715	IF ( (trans == ip_average) .OR. (trans == ip_accumul) .OR. (trans == ip_max) &
716	.OR. (trans == ip_min) ) THEN
717	IF (kinfo == OASIS_OK) kinfo = OASIS_LocTrans
718	IF (OASIS_debug >= 2) THEN
719	WRITE(nulprt,*) subname,' status at ',msec,mseclag,' WTRN '
720	CALL oasis_flush(nulprt)
721	ENDIF
722	ENDIF
723
724	!-------------------------------------------------------------------
725	! past namcouple runtime (maxtime) no communication
726	! do restart if time+lag = maxtime, this assumes coupling
727	! period and lag and maxtime are all nicely consistent
728	!-------------------------------------------------------------------
729	IF (mseclag >= maxtime) THEN
730	IF (getput == OASIS3_PUT .AND. lag > 0 .AND. mseclag == maxtime) THEN
731	kinfo = OASIS_ToRest
732	IF (OASIS_debug >= 2) THEN
733	WRITE(nulprt,*) subname,' status at ',msec,mseclag,' WRST '
734	CALL oasis_flush(nulprt)
735	ENDIF
736	ENDIF
737	ENDIF
738
739	!------------------------------------------------
740	! communication
741	!------------------------------------------------
742	IF (sndrcv) THEN
743	IF (getput == OASIS3_PUT) THEN
744	kinfo = OASIS_sent
745	IF (OASIS_debug >= 2) THEN
746	WRITE(nulprt,*) subname,' status at ',msec,mseclag,' will be SENT '
747	CALL oasis_flush(nulprt)
748	ENDIF
749	ENDIF
750	ENDIF
751
752	!------------------------------------------------
753	! save debug file if EXPOUT or OUTPUT
754	!------------------------------------------------
755	IF (output) THEN
756	IF (kinfo == OASIS_sent) THEN
757	kinfo = OASIS_sentout
758	ELSEIF (kinfo == OASIS_torest) THEN
759	kinfo = OASIS_torestout
760	ELSE
761	kinfo = OASIS_output
762	ENDIF
763	IF (OASIS_debug >= 2) THEN
764	WRITE(nulprt,*) subname,' status at ',msec,mseclag,' will be WRIT '
765	CALL oasis_flush(nulprt)
766	ENDIF
767	ENDIF
768
769	!------------------------------------------------
770	! sav non-instant loctrans operations for future restart
771	! at the end of the run only
772	!------------------------------------------------
773
774	IF (mseclag + dt >= maxtime .AND. &
775	getput == OASIS3_PUT .and. trans /= ip_instant) then
776	IF (OASIS_debug >= 2) THEN
777	WRITE(nulprt,*) subname,' at ',msec,mseclag,' will be WTRN: '
778	CALL oasis_flush(nulprt)
779	ENDIF
780	ENDIF
781	ELSE
782	IF (OASIS_Debug >=2) THEN
783	WRITE(nulprt,*) 'Nothing to do'
784	ENDIF
785	ENDIF ! time_now
786
787	IF (OASIS_debug >= 2) THEN
788	WRITE(nulprt,*) subname,' kinfo: ',kinfo
789	CALL oasis_flush(nulprt)
790	ENDIF
791	ENDDO ! nc
792
793	CALL oasis_debug_exit(subname)
794
795	END SUBROUTINE oasis_put_inquire
796
797	!---------------------------------------------------------------------------------
798	END MODULE mod_oasis_auxiliary_routines
799

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

Context Navigation

source: CPL/oasis3-mct/branches/OASIS3-MCT_5.0_branch/lib/psmile/src/mod_oasis_auxiliary_routines.F90 @ 6331

Download in other formats: