Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mod_oasis_advance.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: 116.1 KB

Line
1	!> Advances the OASIS coupling
2
3	MODULE mod_oasis_advance
4
5	USE mod_oasis_kinds
6	USE mod_oasis_data
7	USE mod_oasis_parameters
8	USE mod_oasis_coupler
9	USE mod_oasis_map
10	USE mod_oasis_part
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 mod_oasis_reprosum
17	USE mod_oasis_load_balancing
18	USE mct_mod
19
20	IMPLICIT NONE
21
22	private
23
24	public oasis_advance_init
25	public oasis_advance_run
26
27	! local private
28
29	logical, parameter :: map_barrier = .false.
30	logical, parameter :: detailed_map_timing = .false.
31
32	contains
33
34	!---------------------------------------------------------------------
35
36	!> Initializes the OASIS fields
37
38	SUBROUTINE oasis_advance_init(kinfo)
39
40	! ----------------------------------------------------------------
41	! This routine handles initial restart and communication
42	! of data for fields with positive lags
43	! ----------------------------------------------------------------
44
45	IMPLICIT none
46	! ----------------------------------------------------------------
47	INTEGER(kind=ip_i4_p), intent(inout) :: kinfo !< status, not used
48	! ----------------------------------------------------------------
49	integer(kind=ip_i4_p) :: cplid,partid,varid,mapid
50	INTEGER(kind=ip_i4_p) :: nf,lsize,nflds,npc
51	integer(kind=ip_i4_p) :: dt,ltime,lag,getput
52	integer(kind=ip_i4_p) :: msec
53	real (kind=ip_r8_p), allocatable :: array(:) ! data
54	real (kind=ip_r8_p), allocatable :: array2(:) ! data
55	real (kind=ip_r8_p), allocatable :: array3(:) ! data
56	real (kind=ip_r8_p), allocatable :: array4(:) ! data
57	real (kind=ip_r8_p), allocatable :: array5(:) ! data
58	logical :: a2on,a3on,a4on,a5on ! data 2-5 logicals
59	integer(kind=ip_i4_p) :: mseclag ! model time + lag
60	character(len=ic_xl) :: rstfile ! restart filename
61	character(len=ic_xxl) :: lstring ! long temporary string
62	integer(kind=ip_i4_p) :: llstring ! len of lstring
63	character(len=ic_med) :: vstring ! temporary string
64	integer(kind=ip_i4_p) :: lvarnum ! local variable bundle number
65	type(mct_string) :: mstring ! mct char type
66	character(len=64) :: vname ! string converted to char
67	type(prism_coupler_type),pointer :: pcpointer
68	character(len=*),parameter :: subname = '(oasis_advance_init)'
69	logical, parameter :: local_timers_on = .false.
70
71	call oasis_debug_enter(subname)
72
73	!----------------------------------------------------------------
74	!> oasis_advance_init does the following
75	!> * Aborts if it's called from non-active tasks
76	!----------------------------------------------------------------
77
78	if (mpi_comm_local == MPI_COMM_NULL) then
79	write(nulprt,*) subname,estr,'called on non coupling task'
80	call oasis_abort(file=__FILE__,line=__LINE__)
81	endif
82
83	kinfo = OASIS_OK
84
85	IF (local_timers_on) call oasis_timer_start ('advance_init')
86
87	!----------------------------------------------------------------
88	!> * Loop over all coupler connections,
89	!> Loop over get and put connections,
90	!> For valid connections
91	!----------------------------------------------------------------
92
93	call oasis_debug_note(subname//' loop over cplid')
94	DO cplid = 1,prism_mcoupler
95	DO npc = 1,2
96	if (npc == 1) pcpointer => prism_coupler_put(cplid)
97	if (npc == 2) pcpointer => prism_coupler_get(cplid)
98	if (pcpointer%valid) then
99	dt = pcpointer%dt
100	lag = pcpointer%lag
101	ltime = pcpointer%ltime
102	getput= pcpointer%getput
103	rstfile=TRIM(pcpointer%rstfile)
104	partid= pcpointer%partID
105	mapid = pcpointer%mapperid
106	msec = 0 ! reasonable default to start with
107	mseclag = msec
108
109	IF (OASIS_Debug >= 2) THEN
110	WRITE(nulprt,*) '----------------------------------------------------------------'
111	WRITE(nulprt,*) subname,' Field cplid :',cplid
112	WRITE(nulprt,*) subname,' read restart:',npc,TRIM(pcpointer%fldlist)
113	WRITE(nulprt,*) subname,' lag prism_mcoupler :',lag,prism_mcoupler
114	WRITE(nulprt,*) subname,' getput , mapid :',getput, mapid
115	WRITE(nulprt,*) '----------------------------------------------------------------'
116	CALL oasis_flush(nulprt)
117	ENDIF
118
119	!------------------------------------------------
120	!> * Checks that lag is reasonable
121	!------------------------------------------------
122
123	IF (lag > dt .OR. lag <= -dt) THEN
124	WRITE(nulprt,*) subname,estr,'lag out of dt range cplid/dt/lag=',cplid,dt,lag
125	call oasis_abort(file=__FILE__,line=__LINE__)
126	ENDIF
127
128	!------------------------------------------------
129	!> * For put fields that need to read a restart file because of a lag,
130	!> call oasis_advance_run and read in the restart file.
131	!> Set readrest to true in oasis_advance_run to indicate it's called from init.
132	! right now, do not know whether any hot map terms are there
133	! assume they are if something is read, otherwise not
134	!------------------------------------------------
135	IF ( (getput == OASIS3_PUT .AND. lag > 0) ) THEN
136	msec=0-lag
137	lsize = mct_aVect_lsize(pcpointer%aVect1)
138	nflds = mct_aVect_nRAttr(pcpointer%aVect1)
139
140	ALLOCATE(array(lsize))
141	ALLOCATE(array2(lsize))
142	ALLOCATE(array3(lsize))
143	ALLOCATE(array4(lsize))
144	ALLOCATE(array5(lsize))
145
146	a2on=.false.
147	a3on=.false.
148	a4on=.false.
149	a5on=.false.
150
151	if (mapid > 0) then
152	if (prism_mapper(mapid)%nwgts >= 2) a2on=.true.
153	if (prism_mapper(mapid)%nwgts >= 3) a3on=.true.
154	if (prism_mapper(mapid)%nwgts >= 4) a4on=.true.
155	if (prism_mapper(mapid)%nwgts >= 5) a5on=.true.
156	endif
157
158	DO nf = 1,nflds
159	varid = pcpointer%varid(nf)
160	call mct_aVect_getRList(mstring,nf,pcpointer%aVect1)
161	vname = mct_string_toChar(mstring)
162	call mct_string_clean(mstring)
163	call oasis_coupler_unbldvarname(varid,vname,lvarnum)
164	CALL oasis_advance_run(OASIS_Out,varid,msec,kinfo,nff=nf, &
165	namid=cplid,array1din=array,&
166	readrest=.TRUE., a2on=a2on,array2=array2, &
167	a3on=a3on,array3=array3, &
168	a4on=a4on,array4=array4,a5on=a5on,array5=array5, &
169	varnum=lvarnum)
170	ENDDO
171	IF (OASIS_Debug >= 2) THEN
172	write(nulprt,*) subname,' advance_run ',cplid,TRIM(pcpointer%fldlist)
173	endif
174
175	DEALLOCATE(array)
176	DEALLOCATE(array2)
177	DEALLOCATE(array3)
178	DEALLOCATE(array4)
179	DEALLOCATE(array5)
180	ENDIF ! put
181	ENDIF ! valid
182	enddo ! npc
183	ENDDO ! cplid
184
185	!----------------------------------------------------------------
186	!> * Loop over all coupler connections,
187	!> Loop over get and put connections,
188	!> For valid connections
189	!----------------------------------------------------------------
190
191	DO cplid=1, prism_mcoupler
192	DO npc = 1,2
193	if (npc == 1) pcpointer => prism_coupler_put(cplid)
194	if (npc == 2) pcpointer => prism_coupler_get(cplid)
195	IF (pcpointer%valid) then
196	dt = pcpointer%dt
197	lag = pcpointer%lag
198	ltime = pcpointer%ltime
199	getput= pcpointer%getput
200	rstfile=TRIM(pcpointer%rstfile)
201	partid= pcpointer%partID
202	msec = 0 ! reasonable default to start with
203	mseclag = msec
204
205	IF (OASIS_Debug >= 2) THEN
206	WRITE(nulprt,*) '----------------------------------------------------------------'
207	WRITE(nulprt,*) subname,' Field cplid :',cplid
208	WRITE(nulprt,*) subname,' loctrans:',npc,TRIM(pcpointer%fldlist)
209	WRITE(nulprt,*) '----------------------------------------------------------------'
210	CALL oasis_flush(nulprt)
211	ENDIF
212
213	!------------------------------------------------
214	!> * Read restart for LOCTRANS fields.
215	!> Do after restart and advance above because prism_advance_run
216	!> fills in the avect with the array info
217	!------------------------------------------------
218
219	call oasis_debug_note(subname//' check for loctrans restart')
220	IF (getput == OASIS3_PUT .AND. pcpointer%trans /= ip_instant) THEN
221	if (len_trim(rstfile) < 1) then
222	write(nulprt,*) subname,estr,'restart undefined'
223	call oasis_abort(file=__FILE__,line=__LINE__)
224	endif
225	if (OASIS_debug >= 2) then
226	lstring = pcpointer%fldlist
227	llstring = len_trim(lstring)
228	if (llstring <= 20) then
229	write(nulprt,*) subname,' at ',msec,mseclag,' RTRN: ', &
230	trim(lstring),' ',trim(rstfile)
231	else
232	write(nulprt,*) subname,' at ',msec,mseclag,' RTRN: ',lstring(1:20), &
233	lstring(21:llstring),' ',trim(rstfile)
234	endif
235	endif
236	lsize = mct_aVect_lsize(pcpointer%aVect1)
237
238	write(vstring,'(a,i6.6,a)') 'loc',pcpointer%namID,'_cnt'
239	call oasis_io_read_array(rstfile,prism_part(partid)%mpicom,iarray=pcpointer%avcnt,&
240	ivarname=trim(vstring),abort=.false.)
241
242	write(vstring,'(a,i6.6,a)') 'loc',pcpointer%namID,'_'
243	call oasis_io_read_avfile(rstfile,pcpointer%avect1,&
244	prism_part(partid)%pgsmap,prism_part(partid)%mpicom, &
245	abort=.false.,nampre=trim(vstring))
246
247	call mct_aVect_init(pcpointer%aVect2,pcpointer%aVect1,lsize)
248	call mct_aVect_zero(pcpointer%aVect2)
249	write(vstring,'(a,i6.6,a)') 'av2loc',pcpointer%namID,'_'
250	call oasis_io_read_avfile(rstfile,pcpointer%avect2,&
251	prism_part(partid)%pgsmap,prism_part(partid)%mpicom, &
252	abort=.false.,nampre=trim(vstring),&
253	didread=pcpointer%aVon(2))
254	if (.not. pcpointer%aVon(2)) then
255	call mct_aVect_clean(pcpointer%avect2)
256	endif
257
258	call mct_aVect_init(pcpointer%aVect3,pcpointer%aVect1,lsize)
259	call mct_aVect_zero(pcpointer%aVect3)
260	write(vstring,'(a,i6.6,a)') 'av3loc',pcpointer%namID,'_'
261	call oasis_io_read_avfile(rstfile,pcpointer%avect3,&
262	prism_part(partid)%pgsmap,prism_part(partid)%mpicom, &
263	abort=.false.,nampre=trim(vstring),&
264	didread=pcpointer%aVon(3))
265	if (.not. pcpointer%aVon(3)) then
266	call mct_aVect_clean(pcpointer%avect3)
267	endif
268
269	call mct_aVect_init(pcpointer%aVect4,pcpointer%aVect1,lsize)
270	call mct_aVect_zero(pcpointer%aVect4)
271	write(vstring,'(a,i6.6,a)') 'av4loc',pcpointer%namID,'_'
272	call oasis_io_read_avfile(rstfile,pcpointer%avect4,&
273	prism_part(partid)%pgsmap,prism_part(partid)%mpicom, &
274	abort=.false.,nampre=trim(vstring),&
275	didread=pcpointer%aVon(4))
276	if (.not. pcpointer%aVon(4)) then
277	call mct_aVect_clean(pcpointer%avect4)
278	endif
279
280	call mct_aVect_init(pcpointer%aVect5,pcpointer%aVect1,lsize)
281	call mct_aVect_zero(pcpointer%aVect5)
282	write(vstring,'(a,i6.6,a)') 'av5loc',pcpointer%namID,'_'
283	call oasis_io_read_avfile(rstfile,pcpointer%avect5,&
284	prism_part(partid)%pgsmap,prism_part(partid)%mpicom, &
285	abort=.false.,nampre=trim(vstring),&
286	didread=pcpointer%aVon(5))
287	if (.not. pcpointer%aVon(5)) then
288	call mct_aVect_clean(pcpointer%avect5)
289	endif
290
291	if (OASIS_debug >= 20) then
292	write(nulprt,*) subname,' DEBUG read loctrans restart',&
293	cplid,pcpointer%avcnt
294	write(nulprt,*) subname,' DEBUG read loctrans restart',cplid,&
295	minval(pcpointer%avect1%rAttr),&
296	maxval(pcpointer%avect1%rAttr)
297	endif
298	endif
299	ENDIF ! valid
300	enddo ! npc
301	ENDDO ! cplid
302	IF (local_timers_on) call oasis_timer_stop ('advance_init')
303
304	call oasis_debug_exit(subname)
305
306	end SUBROUTINE oasis_advance_init
307	!---------------------------------------------------------------------
308
309	!> Advances the OASIS coupling
310
311	!> Only one from array1din, array1dout, or array2dout can be passed in.
312	!> readrest is set to true when called by the oasis_advance_init method.
313	!> Arrays 2 to 5 are for the higher order terms (hot)
314
315	SUBROUTINE oasis_advance_run(mop,varid,msec,kinfo,nff,namid,&
316	array1din,array1dout,array2dout,readrest,&
317	a2on,array2,a3on,array3,a4on,array4,a5on,array5, &
318	writrest,varnum)
319
320	IMPLICIT none
321	! ----------------------------------------------------------------
322	integer(kind=ip_i4_p), intent(in) :: mop !< OASIS_Out or OASIS_In
323	INTEGER(kind=ip_i4_p), intent(in) :: varid !< prism_var id
324	INTEGER(kind=ip_i4_p), intent(in) :: msec !< model time
325	INTEGER(kind=ip_i4_p), intent(inout) :: kinfo !< status
326
327	INTEGER(kind=ip_i4_p), optional :: nff !< specify particular field for restart
328	INTEGER(kind=ip_i4_p), optional :: namid !< only do this namcouple
329	!< method for restart
330	REAL (kind=ip_r8_p), optional :: array1din(:) !< 1D put data
331	REAL (kind=ip_r8_p), optional :: array1dout(:) !< 1D get data
332	REAL (kind=ip_r8_p), optional :: array2dout(:,:) !< 2D get data
333	logical , optional :: readrest !< special flag to indicate this
334	!< is called from the advance_init
335	logical , optional :: a2on !< logical for array2
336	REAL (kind=ip_r8_p), optional :: array2(:) !< hot put data
337	logical , optional :: a3on !< logical for array3
338	REAL (kind=ip_r8_p), optional :: array3(:) !< hot put data
339	logical , optional :: a4on !< logical for array4
340	REAL (kind=ip_r8_p), optional :: array4(:) !< hot put data
341	logical , optional :: a5on !< logical for array5
342	REAL (kind=ip_r8_p), optional :: array5(:) !< hot put data
343	logical , optional :: writrest !< flag to write restart now
344	INTEGER(kind=ip_i4_p), optional :: varnum !< variable bundle number
345	! ----------------------------------------------------------------
346	character(len=ic_lvar):: vname
347	INTEGER(kind=ip_i4_p) :: cplid,rouid,mapid,partid
348	INTEGER(kind=ip_i4_p) :: nfav,nsav,nsa,n,nc,nf,npc
349	INTEGER(kind=ip_i4_p) :: lsize,nflds,ierr
350	integer(kind=ip_i4_p) :: tag,dt,ltime,lag,getput,maxtime,conserv
351	character(len=ic_med) :: consopt
352	logical :: sndrcv,output,input,unpack
353	logical :: snddiag,rcvdiag
354	logical :: arrayon(prism_coupler_avsmax)
355	LOGICAL :: didread, readabort
356	real(kind=ip_double_p):: sndmult,sndadd,rcvmult,rcvadd
357	character(len=ic_xl) :: rstfile ! restart filename
358	character(len=ic_xl) :: rstfile2 ! restart filename
359	character(len=ic_xl) :: inpfile ! input filename
360	integer(kind=ip_i4_p) :: nx,ny
361	integer(kind=ip_i4_p) :: mseclag ! model time + lag
362	integer(kind=ip_i4_p) :: lvarnum ! local variable bundle number
363	real(kind=ip_r8_p) :: rcnt ! 1./cnt
364	character(len=ic_med) :: tstring ! timer label string
365	character(len=ic_med) :: fstring ! output file string
366	character(len=ic_med) :: cstring ! temporary string
367	character(len=ic_med) :: vstring ! temporary string
368	character(len=ic_xxl) :: lstring ! long temporary string
369	integer(kind=ip_i4_p) :: llstring ! len of lstring
370	logical :: comm_now ! time to communicate
371	logical :: time_now ! coupling time
372	logical :: lreadrest ! local readrest
373	logical :: runit ! advance the variable
374	TYPE(mct_avect) :: avtest ! temporary
375	type(mct_avect) :: avtmp ! data read from restart
376	type(mct_avect) :: avtmp2 ! data read from restart
377	type(mct_avect) :: avtmp3 ! data read from restart
378	type(mct_avect) :: avtmp4 ! data read from restart
379	type(mct_avect) :: avtmp5 ! data read from restart
380	type(mct_avect) :: avtmpW ! for writing restart
381	type(prism_coupler_type),pointer :: pcpointer
382	type(prism_coupler_type),pointer :: pcpointmp
383	logical, parameter :: local_timers_on = .false.
384	character(len=*),parameter :: subname = '(oasis_advance_run)'
385	! ----------------------------------------------------------------
386
387	call oasis_debug_enter(subname)
388
389	!----------------------------------------------------------------
390	!> oasis_advance_run does the following
391	!> * Aborts if it's called from non-active tasks
392	!----------------------------------------------------------------
393
394	if (mpi_comm_local == MPI_COMM_NULL) then
395	write(nulprt,*) subname,estr,'called on non coupling task'
396	call oasis_abort(file=__FILE__,line=__LINE__)
397	endif
398
399	kinfo = OASIS_OK
400	if (varid < 1 .or. varid > prism_nvar) then
401	write(nulprt,*) subname,estr,'invalid varid',varid,trim(prism_var(varid)%name),prism_nvar
402	call oasis_abort(file=__FILE__,line=__LINE__)
403	endif
404
405	if (present(varnum)) then
406	lvarnum = varnum
407	else
408	lvarnum = 1
409	endif
410
411	call oasis_coupler_bldvarname(varid,lvarnum,vname)
412	if (OASIS_debug >= 20) then
413	write(nulprt,*) subname,' DEBUG vname ',varid,lvarnum,' ',trim(vname)
414	endif
415
416	lreadrest = .false.
417	if (present(readrest)) then
418	lreadrest = readrest
419	endif
420	if (lreadrest) kinfo = OASIS_fromrest
421
422	!------------------------------------------------
423	!> * Verify field (var) is either In or Out
424	!------------------------------------------------
425
426	if (mop /= OASIS_Out .and. mop /= OASIS_In) then
427	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
428	write(nulprt,*) subname,estr,'mop invalid expecting OASIS_Out or OASIS_In = ',mop
429	call oasis_abort(file=__FILE__,line=__LINE__)
430	endif
431
432	call oasis_debug_note(subname//' loop over var ncpl')
433
434	!------------------------------------------------
435	! Check namid
436	!------------------------------------------------
437
438	if (present(namid)) then
439	IF (OASIS_debug >= 20) THEN
440	write(nulprt,*) subname,'namid',namid,prism_var(varid)%cpl(1:prism_var(varid)%ncpl)
441	endif
442	! verify namid is associated with the variable or abort
443	runit = .false.
444	do nc = 1,prism_var(varid)%ncpl
445	cplid = prism_var(varid)%cpl(nc)
446	if (cplid == namid) runit = .true.
447	enddo
448	if (.not.runit) then
449	WRITE(nulprt,*) subname,estr,'namid not found for var = ',trim(vname)
450	WRITE(nulprt,*) subname,estr,'namid = ',namid
451	call oasis_abort(file=__FILE__,line=__LINE__)
452	endif
453	endif
454
455	!------------------------------------------------
456	! Set arrayon
457	!------------------------------------------------
458
459	arrayon = .false.
460	arrayon(1) = .true.
461	if (present(a2on)) arrayon(2) = a2on
462	if (present(a3on)) arrayon(3) = a3on
463	if (present(a4on)) arrayon(4) = a4on
464	if (present(a5on)) arrayon(5) = a5on
465
466	if (OASIS_debug >= 10) then
467	write(nulprt,*) subname,' lreadrest :',lreadrest,' arrayon = ',arrayon
468	endif
469
470	!------------------------------------------------
471	!> * Loop over all the couplers associated with this var
472	! or if nam is present, just for nc == nam
473	!------------------------------------------------
474
475	DO nc = 1,prism_var(varid)%ncpl
476	cplid = prism_var(varid)%cpl(nc)
477	runit = .true.
478	if (present(namid)) then
479	runit = .false.
480	if (cplid == namid) runit = .true.
481	endif
482	if (runit) then
483	cplid = prism_var(varid)%cpl(nc)
484	if (mop == OASIS_Out) pcpointer => prism_coupler_put(cplid)
485	if (mop == OASIS_In ) pcpointer => prism_coupler_get(cplid)
486
487	!------------------------------------------------
488	!> * check this prism_coupler is valid
489	!------------------------------------------------
490	if (.not.pcpointer%valid) then
491	WRITE(nulprt,*) subname,estr,'invalid prism_coupler for var = ',trim(vname)
492	call oasis_abort(file=__FILE__,line=__LINE__)
493	endif
494
495	!------------------------------------------------
496	!> * check again that model op matches coupler op
497	!------------------------------------------------
498	getput = pcpointer%getput
499	if ((mop == OASIS_Out .and. getput == OASIS3_PUT) .or. &
500	(mop == OASIS_In .and. getput == OASIS3_GET)) then
501	!-continue
502	else
503	write(nulprt,*) subname,estr,'model def_var in-out does not match model get-put call for var = ',trim(vname)
504	call oasis_abort(file=__FILE__,line=__LINE__)
505	endif
506
507	!------------------------------------------------
508	!> * set a bunch of local variables
509	!------------------------------------------------
510	rouid = pcpointer%routerid
511	mapid = pcpointer%mapperid
512	tag = pcpointer%tag
513	dt = pcpointer%dt
514	lag = pcpointer%lag
515	ltime = pcpointer%ltime
516	sndrcv = pcpointer%sndrcv
517	rstfile = TRIM(pcpointer%rstfile)
518	inpfile = TRIM(pcpointer%inpfile)
519	maxtime = pcpointer%maxtime
520	output = pcpointer%output
521	input = pcpointer%input
522	partid = pcpointer%partID
523	conserv = pcpointer%conserv
524	consopt = pcpointer%consopt
525	snddiag = pcpointer%snddiag
526	rcvdiag = pcpointer%rcvdiag
527	sndadd = pcpointer%sndadd
528	sndmult = pcpointer%sndmult
529	rcvadd = pcpointer%rcvadd
530	rcvmult = pcpointer%rcvmult
531
532	! update writrest only if true
533	! never want to switch to false here
534	if (present(writrest)) then
535	if (writrest .and. mop /= OASIS_Out) then
536	write(nulprt,*) subname,estr,'mop must be OASIS_Out if writrest is true, mop=',mop
537	call oasis_abort(file=__FILE__,line=__LINE__)
538	endif
539	if (writrest) pcpointer%writrest = writrest
540	endif
541
542	unpack = (sndrcv .OR. input)
543
544	CALL oasis_debug_note(subname//' set nx and ny')
545	IF (prism_part(partid)%nx >= 1) THEN
546	nx = prism_part(partid)%nx
547	ny = prism_part(partid)%ny
548	ELSE
549	nx = prism_part(partid)%gsize
550	ny = 1
551	ENDIF
552
553	IF (OASIS_debug >= 20) THEN
554	WRITE(nulprt,*) subname,' DEBUG nx, ny = ',nx,ny
555	CALL oasis_flush(nulprt)
556	ENDIF
557
558	!------------------------------------------------
559	!> * check that lag is reasonable
560	!------------------------------------------------
561
562	IF (ABS(lag) > dt) THEN
563	WRITE(nulprt,*) subname,estr,'lag setting greater than dt for var = ',trim(vname)
564	call oasis_abort(file=__FILE__,line=__LINE__)
565	ENDIF
566
567	!------------------------------------------------
568	!> * read restart for call from init phase
569	! right now, do not know whether any hot map terms are there
570	! assume they are if something is read, otherwise not
571	!------------------------------------------------
572
573	call oasis_debug_note(subname//' check for lag restart')
574	IF (getput == OASIS3_PUT .AND. lag > 0 .AND. lreadrest) THEN
575	! effective model time of restart : msec
576	mseclag = msec + lag
577
578	IF (.not.present(nff)) THEN
579	WRITE(nulprt,*) subname,estr,'nff optional argument not passed but expected for var = ',trim(vname)
580	call oasis_abort(file=__FILE__,line=__LINE__)
581	ENDIF
582	IF (LEN_TRIM(rstfile) < 1) THEN
583	WRITE(nulprt,*) subname,estr,'restart file undefined for var = ',trim(vname)
584	call oasis_abort(file=__FILE__,line=__LINE__)
585	ENDIF
586	lsize = mct_aVect_lsize(pcpointer%aVect1)
587	IF (OASIS_debug >= 2) THEN
588	lstring = pcpointer%fldlist
589	llstring = len_trim(lstring)
590	if (llstring <= 20) then
591	WRITE(nulprt,*) subname,' at ',msec,mseclag,' RRST: ', &
592	TRIM(lstring),' ',TRIM(rstfile)
593	else
594	WRITE(nulprt,*) subname,' at ',msec,mseclag,' RRST: ',lstring(1:20),&
595	lstring(21:llstring),' ',TRIM(rstfile)
596	endif
597	ENDIF
598
599	CALL mct_aVect_init(avtmp,rlist=pcpointer%fldlist,lsize=lsize)
600	readabort = .true.
601	if (allow_no_restart) readabort = .false.
602
603	do n = 1,5
604	if (n == 1) then
605	vstring = ""
606	else
607	write(vstring,'(a2,i1.1,a1)') 'av',n,'_'
608	endif
609
610	! NOTES: array* only valid if arrayon(n) is true
611	! if readabort = T and didread = T then will copy values into array*
612	! if readabort = T and didread = F then will abort in io_read_avfile
613	! if readabort = F and didread = T then will copy values into array*
614	! if readabort = F and didread = F then will 0s into array*
615
616	if (arrayon(n)) then
617	avtmp%rAttr(nff,1:lsize) = 0.0
618	CALL oasis_io_read_avfile(TRIM(rstfile),avtmp,prism_part(partid)%pgsmap,prism_part(partid)%mpicom, &
619	abort=readabort,nampre=vstring,didread=didread)
620	if (n == 1) array1din(1:lsize) = avtmp%rAttr(nff,1:lsize)
621	if (n == 2) array2 (1:lsize) = avtmp%rAttr(nff,1:lsize)
622	if (n == 3) array3 (1:lsize) = avtmp%rAttr(nff,1:lsize)
623	if (n == 4) array4 (1:lsize) = avtmp%rAttr(nff,1:lsize)
624	if (n == 5) array5 (1:lsize) = avtmp%rAttr(nff,1:lsize)
625
626	if (.not.readabort .and. .not.didread) then
627	WRITE(nulprt,*) subname,wstr,'restart field missing with readabort = ',readabort
628	WRITE(nulprt,*) subname,wstr,'restart field missing for file = ',trim(rstfile)
629	WRITE(nulprt,*) subname,wstr,'restart field missing for hot = ',n
630	WRITE(nulprt,*) subname,wstr,'restart field missing setting values to zero'
631	endif
632	endif
633	enddo
634	CALL mct_avect_clean(avtmp)
635
636	! In case of OASIS restart file
637	! stop enddef timer since coupling field exchange starts
638	if (ET_debug) CALL oasis_lb_measure(-1,LB_ENDF,msec)
639
640	ENDIF
641
642	!------------------------------------------------
643	!> * compute lag time, only on put side
644	!> * set time_now, is it a coupling period?
645	!------------------------------------------------
646
647	call oasis_debug_note(subname//' set mseclag')
648	if (getput == OASIS3_PUT) then
649	mseclag = msec + lag
650	elseif (getput == OASIS3_GET) then
651	mseclag = msec
652	endif
653
654	if (OASIS_debug >= 20) then
655	write(nulprt,*) subname,' DEBUG msec,mseclag = ',msec,mseclag
656	CALL oasis_flush(nulprt)
657	endif
658
659	time_now = .false.
660	if (mod(mseclag,dt) == 0) time_now = .true.
661
662	!------------------------------------------------
663	!> * check that model hasn't gone past maxtime
664	!------------------------------------------------
665
666	if (msec >= maxtime) then
667	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
668	write(nulprt,*) subname,estr,'model time must be strictly smaller than namcouple $RUNTIME = ',msec,maxtime
669	call oasis_abort(file=__FILE__,line=__LINE__)
670	endif
671
672	!------------------------------------------------
673	!> * check that model isn't going backwards
674	! msec >= 0 does the check only in run mode, not in initialization
675	!------------------------------------------------
676
677	if (pcpointer%ctime /= ispval .and. msec >= 0 .and. msec < pcpointer%ctime) then
678	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
679	write(nulprt,*) subname,estr,'model seems to be running backwards = ',pcpointer%ctime
680	call oasis_abort(file=__FILE__,line=__LINE__)
681	endif
682
683	!------------------------------------------------
684	!> * check that variable didn't miss a coupling period
685	! check only for send recv operations where deadlock
686	! is possible. Allow 1*dt for synchronous operations,
687	! 2*dt for asynchronous operations
688	!------------------------------------------------
689
690	do n = 1,prism_mcoupler
691	do npc = 1,2
692	if (npc == 1) pcpointmp => prism_coupler_put(n)
693	if (npc == 2) pcpointmp => prism_coupler_get(n)
694	if (pcpointmp%valid) then
695	if (prism_part(pcpointmp%partID)%lsize > 0) then
696
697	if (OASIS_debug >= 20) then
698	write(nulprt,'(2a,4i6,2l3,i8)') subname,'deadlock_chkA ',varid,nc,n,npc,sndrcv,pcpointmp%sndrcv,msec
699	write(nulprt,'(2a,1x,a,2i8,1x,a,2i8)') subname,'deadlock_chkB ',trim(pcpointer%fldlist),pcpointer%ltime,pcpointer%dt,trim(pcpointmp%fldlist),pcpointmp%ltime,pcpointmp%dt
700	endif
701
702	if ((sndrcv .and. pcpointmp%sndrcv .and. time_now) .and. &
703	((pcpointmp%ltime /= ispval .and. msec > pcpointmp%ltime + pcpointmp%dt) .or. &
704	(pcpointmp%ltime == ispval .and. pcpointer%ltime /= ispval .and. msec >= pcpointmp%dt ))) then
705	write(nulprt,'(3a)') subname,estr,'coupling skipped at earlier time, potential deadlock '
706	write(nulprt,'(3a,i8,2a)') subname,estr,'my coupler = ',cplid,' variable = ',&
707	trim(pcpointer%fldlist)
708	write(nulprt,'(3a,i12,a,i12)') subname,estr,'current time = ',msec,' mseclag = ',mseclag
709	write(nulprt,'(3a,2i12)') subname,estr,'my coupler last time and dt = ',pcpointer%ltime,pcpointer%dt
710	write(nulprt,'(3a,i8,2a)') subname,estr,'skipped coupler = ',n,' variable = ',&
711	trim(pcpointmp%fldlist)
712	write(nulprt,'(3a,2i12)') subname,estr,'skipped coupler last time and dt = ',&
713	pcpointmp%ltime,pcpointmp%dt
714	call oasis_abort(file=__FILE__,line=__LINE__)
715	endif
716	endif ! part lsize
717	endif ! valid
718	enddo ! npc
719	enddo ! prism_mcoupler
720
721	!------------------------------------------------
722	!> * check that prior sequences weren't missed at this
723	!> step for get (recv) operation.
724	! attempts to trap deadlocks before they happen
725	!------------------------------------------------
726
727	if (sndrcv .and. getput == OASIS3_GET) then
728	if (lastseqtime /= ispval .and. msec == lastseqtime .and. pcpointer%seq < lastseq) then
729	write(nulprt,*) subname,estr,'coupling sequence out of order, potential deadlock '
730	write(nulprt,*) subname,estr,'my coupler = ',cplid,' variable = ',&
731	trim(pcpointer%fldlist)
732	write(nulprt,*) subname,' ERRRO: sequence number = ',pcpointer%seq
733	write(nulprt,*) subname,estr,'current time = ',msec,' mseclag = ',mseclag
734	write(nulprt,*) subname,estr,'last sequence and time = ',lastseq,lastseqtime
735	WRITE(nulprt,*) subname,estr,'model sequence does not match coupling sequence'
736	call oasis_abort(file=__FILE__,line=__LINE__)
737	else
738	lastseq = pcpointer%seq
739	lastseqtime = msec
740	endif
741	if (OASIS_debug >= 20) then
742	write(nulprt,*) subname,' DEBUG sequence ',trim(vname),msec,lastseqtime,lastseq,pcpointer%seq
743	endif
744	endif
745
746	!------------------------------------------------
747	!> * compute field index and check sizes
748	!------------------------------------------------
749
750	call oasis_debug_note(subname//' compute field index and sizes')
751	nfav = mct_avect_indexra(pcpointer%avect1,trim(vname))
752	nsav = mct_avect_lsize(pcpointer%avect1)
753	if (lag > 0 .and. lreadrest) nsa=size(array1din)
754	if (present(array1din )) nsa = size(array1din )
755	if (present(array1dout)) nsa = size(array1dout)
756	if (present(array2dout)) nsa = size(array2dout)
757
758	if (OASIS_debug >= 20) then
759	write(nulprt,*) subname,' DEBUG nfav,nsav,nsa = ',nfav,nsav,nsa
760	endif
761
762	if (nsav /= nsa) then
763	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
764	write(nulprt,*) subname,estr,'in field size passed into get/put compare to expected size ',nsav,nsa
765	call oasis_abort(file=__FILE__,line=__LINE__)
766	endif
767
768	if (nfav < 1 .or. nfav > mct_avect_nRattr(pcpointer%avect1)) then
769	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
770	write(nulprt,*) subname,estr,'ivalid variable name nfav = ',nfav
771	call oasis_abort(file=__FILE__,line=__LINE__)
772	endif
773
774	!------------------------------------------------
775	!> * check for higher order coupling fields
776	!> and get everything ready
777	! arrayon is what's passed this time
778	! optional args only on put side
779	!------------------------------------------------
780
781	if ((getput == OASIS3_GET) .or. &
782	(getput == OASIS3_PUT .and. trim(pcpointer%maploc) == "dst" )) then
783	if (arrayon(2) .or. arrayon(3) .or. &
784	arrayon(4) .or. arrayon(5)) then
785	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
786	write(nulprt,*) subname,estr,'higher order mapping not allowed on get side'
787	write(nulprt,*) subname,estr,'consider changing map location from dst to src'
788	call oasis_abort(file=__FILE__,line=__LINE__)
789	endif
790	endif
791
792	if ((arrayon(2) .and. .not.present(array2)) .or. &
793	(arrayon(3) .and. .not.present(array3)) .or. &
794	(arrayon(4) .and. .not.present(array4)) .or. &
795	(arrayon(5) .and. .not.present(array5))) then
796	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
797	write(nulprt,*) subname,estr,'arrayon true but array not sent'
798	call oasis_abort(file=__FILE__,line=__LINE__)
799	! With the current way of using oasis_advance_run, the above test is useless but we keep the test
800	! as someone might be later adding an interface call that would violate the consistency
801	endif
802
803	! initialize aVect2-5 here if not already allocated
804
805	if (arrayon(2) .and. .not. pcpointer%aVon(2)) then
806	call mct_aVect_init(pcpointer%aVect2,pcpointer%aVect1,nsav)
807	call mct_aVect_zero(pcpointer%aVect2)
808	pcpointer%aVon(2) = .true.
809	if (OASIS_debug >= 2) then
810	write(nulprt,*) subname,' at ',msec,mseclag,' ALLO: ',&
811	trim(vname),' ','aVect2'
812	endif
813	endif
814
815	if (arrayon(3) .and. .not. pcpointer%aVon(3)) then
816	call mct_aVect_init(pcpointer%aVect3,pcpointer%aVect1,nsav)
817	call mct_aVect_zero(pcpointer%aVect3)
818	pcpointer%aVon(3) = .true.
819	if (OASIS_debug >= 2) then
820	write(nulprt,*) subname,' at ',msec,mseclag,' ALLO: ',&
821	trim(vname),' ','aVect3'
822	endif
823	endif
824
825	if (arrayon(4) .and. .not. pcpointer%aVon(4)) then
826	call mct_aVect_init(pcpointer%aVect4,pcpointer%aVect1,nsav)
827	call mct_aVect_zero(pcpointer%aVect4)
828	pcpointer%aVon(4) = .true.
829	if (OASIS_debug >= 2) then
830	write(nulprt,*) subname,' at ',msec,mseclag,' ALLO: ',&
831	trim(vname),' ','aVect4'
832	endif
833	endif
834
835	if (arrayon(5) .and. .not. pcpointer%aVon(5)) then
836	call mct_aVect_init(pcpointer%aVect5,pcpointer%aVect1,nsav)
837	call mct_aVect_zero(pcpointer%aVect5)
838	pcpointer%aVon(5) = .true.
839	if (OASIS_debug >= 2) then
840	write(nulprt,*) subname,' at ',msec,mseclag,' ALLO: ',&
841	trim(vname),' ','aVect5'
842	endif
843	endif
844
845	!------------------------------------------------
846	!> * update avect1-5 on put side and apply appropriate transform
847	!> * if its coupling time, set status of this var to ready
848	!> * write restart if requested by interface
849	! on restart, treat as instant value
850	!------------------------------------------------
851
852	if (getput == OASIS3_PUT) then
853
854	call oasis_debug_note(subname//' loctrans operation')
855	write(tstring,'(A,I3.3)') 'pcpy_',cplid
856
857	if (local_timers_on) call oasis_timer_start(tstring)
858
859	cstring = 'none'
860	if (lreadrest .or. pcpointer%trans == ip_instant) then
861	if (time_now) then
862	cstring = 'instant'
863	do n = 1,nsav
864	pcpointer%avect1%rAttr(nfav,n) = array1din(n)
865	if (pcpointer%aVon(2)) then
866	if (present(array2)) then
867	pcpointer%avect2%rAttr(nfav,n) = array2(n)
868	else
869	pcpointer%avect2%rAttr(nfav,n) = 0.0
870	endif
871	endif
872	if (pcpointer%aVon(3)) then
873	if (present(array3)) then
874	pcpointer%avect3%rAttr(nfav,n) = array3(n)
875	else
876	pcpointer%avect3%rAttr(nfav,n) = 0.0
877	endif
878	endif
879	if (pcpointer%aVon(4)) then
880	if (present(array4)) then
881	pcpointer%avect4%rAttr(nfav,n) = array4(n)
882	else
883	pcpointer%avect4%rAttr(nfav,n) = 0.0
884	endif
885	endif
886	if (pcpointer%aVon(5)) then
887	if (present(array5)) then
888	pcpointer%avect5%rAttr(nfav,n) = array5(n)
889	else
890	pcpointer%avect5%rAttr(nfav,n) = 0.0
891	endif
892	endif
893	enddo
894	pcpointer%avcnt(nfav) = 1
895	endif
896
897	elseif (pcpointer%trans == ip_average) then
898	cstring = 'average'
899	if (kinfo == OASIS_OK) kinfo = OASIS_LocTrans
900	do n = 1,nsav
901	pcpointer%avect1%rAttr(nfav,n) = &
902	pcpointer%avect1%rAttr(nfav,n) + array1din(n)
903	if (pcpointer%aVon(2)) then
904	if (present(array2)) then
905	pcpointer%avect2%rAttr(nfav,n) = &
906	pcpointer%avect2%rAttr(nfav,n) + array2(n)
907	endif
908	endif
909	if (pcpointer%aVon(3)) then
910	if (present(array3)) then
911	pcpointer%avect3%rAttr(nfav,n) = &
912	pcpointer%avect3%rAttr(nfav,n) + array3(n)
913	endif
914	endif
915	if (pcpointer%aVon(4)) then
916	if (present(array4)) then
917	pcpointer%avect4%rAttr(nfav,n) = &
918	pcpointer%avect4%rAttr(nfav,n) + array4(n)
919	endif
920	endif
921	if (pcpointer%aVon(5)) then
922	if (present(array5)) then
923	pcpointer%avect5%rAttr(nfav,n) = &
924	pcpointer%avect5%rAttr(nfav,n) + array5(n)
925	endif
926	endif
927	enddo
928	pcpointer%avcnt(nfav) = pcpointer%avcnt(nfav) + 1
929
930	elseif (pcpointer%trans == ip_accumul) then
931	cstring = 'accumul'
932	if (kinfo == OASIS_OK) kinfo = OASIS_LocTrans
933	do n = 1,nsav
934	pcpointer%avect1%rAttr(nfav,n) = &
935	pcpointer%avect1%rAttr(nfav,n) + array1din(n)
936	if (pcpointer%aVon(2)) then
937	if (present(array2)) then
938	pcpointer%avect2%rAttr(nfav,n) = &
939	pcpointer%avect2%rAttr(nfav,n) + array2(n)
940	endif
941	endif
942	if (pcpointer%aVon(3)) then
943	if (present(array3)) then
944	pcpointer%avect3%rAttr(nfav,n) = &
945	pcpointer%avect3%rAttr(nfav,n) + array3(n)
946	endif
947	endif
948	if (pcpointer%aVon(4)) then
949	if (present(array4)) then
950	pcpointer%avect4%rAttr(nfav,n) = &
951	pcpointer%avect4%rAttr(nfav,n) + array4(n)
952	endif
953	endif
954	if (pcpointer%aVon(5)) then
955	if (present(array5)) then
956	pcpointer%avect5%rAttr(nfav,n) = &
957	pcpointer%avect5%rAttr(nfav,n) + array5(n)
958	endif
959	endif
960	enddo
961	pcpointer%avcnt(nfav) = 1
962
963	elseif (pcpointer%trans == ip_max) then
964	cstring = 'max'
965	if (kinfo == OASIS_OK) kinfo = OASIS_LocTrans
966	if (pcpointer%aVon(2) .or. pcpointer%aVon(3) .or. &
967	pcpointer%aVon(4) .or. pcpointer%aVon(5)) then
968	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
969	write(nulprt,*) subname,estr,'higher order mapping with MAX transform not supported'
970	call oasis_abort(file=__FILE__,line=__LINE__)
971	endif
972	do n = 1,nsav
973	if (pcpointer%avcnt(nfav) == 0) then
974	pcpointer%avect1%rAttr(nfav,n) = array1din(n)
975	else
976	pcpointer%avect1%rAttr(nfav,n) = &
977	max(pcpointer%avect1%rAttr(nfav,n),array1din(n))
978	endif
979	enddo
980	pcpointer%avcnt(nfav) = 1
981
982	elseif (pcpointer%trans == ip_min) then
983	cstring = 'min'
984	if (kinfo == OASIS_OK) kinfo = OASIS_LocTrans
985	if (pcpointer%aVon(2) .or. pcpointer%aVon(3) .or. &
986	pcpointer%aVon(4) .or. pcpointer%aVon(5)) then
987	write(nulprt,*) subname,estr,'at ',msec,mseclag,' for var = ',trim(vname)
988	write(nulprt,*) subname,estr,'higher order mapping with MIN transform not supported'
989	call oasis_abort(file=__FILE__,line=__LINE__)
990	endif
991	do n = 1,nsav
992	if (pcpointer%avcnt(nfav) == 0) then
993	pcpointer%avect1%rAttr(nfav,n) = array1din(n)
994	else
995	pcpointer%avect1%rAttr(nfav,n) = &
996	min(pcpointer%avect1%rAttr(nfav,n),array1din(n))
997	endif
998	enddo
999	pcpointer%avcnt(nfav) = 1
1000
1001	else
1002	write(nulprt,*) subname,estr,'transform not known for var = ',trim(vname),pcpointer%trans
1003	call oasis_abort(file=__FILE__,line=__LINE__)
1004	endif
1005	if (local_timers_on) call oasis_timer_stop(tstring)
1006
1007	if (OASIS_debug >= 2 .and. trim(cstring) /= 'none') then
1008	write(nulprt,*) subname,' at ',msec,mseclag,' PACK: ',&
1009	trim(vname),' ',trim(cstring)
1010	endif
1011
1012	if (OASIS_debug >= 20) then
1013	write(nulprt,*) subname,' DEBUG loctrans update ',cplid,' ',&
1014	trim(cstring),pcpointer%avcnt(nfav)
1015	endif
1016
1017	if (time_now) then
1018	pcpointer%status(nfav) = OASIS_COMM_READY
1019	endif
1020	endif
1021
1022	!------------------------------------------------
1023	!> * decide if it's time to communicate based on time
1024	! also, on the put side, status of all vars
1025	! must be ready which means all vars have called put.
1026	! on get side, all ready means all vars have unpacked
1027	! from last get.
1028	!------------------------------------------------
1029
1030	call oasis_debug_note(subname//' comm_now compute')
1031	comm_now = .false.
1032	if (time_now) then
1033	comm_now = .true.
1034	do nf = 1,pcpointer%nflds
1035	if (pcpointer%status(nf) /= OASIS_COMM_READY) then
1036	comm_now = .false.
1037	if (OASIS_debug >= 15) then
1038	write(nulprt,*) subname,' at ',msec,mseclag,' STAT: ',nf,' NOT READY'
1039	endif
1040	kinfo=OASIS_Waitgroup
1041	else
1042	if (OASIS_debug >= 15) then
1043	write(nulprt,*) subname,' at ',msec,mseclag,' STAT: ',nf,' READY'
1044	endif
1045	endif
1046	enddo
1047	endif
1048
1049	!------------------------------------------------
1050	!> * If it's time to communicate
1051	!------------------------------------------------
1052
1053	if (comm_now) then
1054
1055	call oasis_debug_note(subname//' comm_now')
1056
1057	!------------------------------------------------
1058	!> * check again that time is correct
1059	! this is the time critical bit, we need to make sure the
1060	! model is truly advancing in time when comms are called.
1061	! must ignore the initial call, ltime = 0
1062	!------------------------------------------------
1063
1064	if (pcpointer%ltime /= ispval .and. msec <= pcpointer%ltime) then
1065	write(nulprt,*) subname,estr,'model did not advance in time correctly for var = ',trim(vname)
1066	write(nulprt,*) subname,estr,'msec, ltime = ',msec,pcpointer%ltime
1067	call oasis_abort(file=__FILE__,line=__LINE__)
1068	endif
1069
1070	!------------------------------------------------
1071	!> * average as needed for some transforms
1072	! (not cache friendly yet)
1073	!------------------------------------------------
1074
1075	if (getput == OASIS3_PUT) then
1076	call oasis_debug_note(subname//' loctrans calc')
1077	write(tstring,'(A,I3.3)') 'pavg_',cplid
1078	if (local_timers_on) call oasis_timer_start(tstring)
1079	do nf = 1,pcpointer%nflds
1080	if (pcpointer%avcnt(nf) > 1) then
1081	rcnt = 1.0/pcpointer%avcnt(nf)
1082	do n = 1,nsav
1083	pcpointer%avect1%rAttr(nf,n) = &
1084	pcpointer%avect1%rAttr(nf,n) * rcnt
1085	if (pcpointer%aVon(2)) then
1086	pcpointer%avect2%rAttr(nf,n) = &
1087	pcpointer%avect2%rAttr(nf,n) * rcnt
1088	endif
1089	if (pcpointer%aVon(3)) then
1090	pcpointer%avect3%rAttr(nf,n) = &
1091	pcpointer%avect3%rAttr(nf,n) * rcnt
1092	endif
1093	if (pcpointer%aVon(4)) then
1094	pcpointer%avect4%rAttr(nf,n) = &
1095	pcpointer%avect4%rAttr(nf,n) * rcnt
1096	endif
1097	if (pcpointer%aVon(5)) then
1098	pcpointer%avect5%rAttr(nf,n) = &
1099	pcpointer%avect5%rAttr(nf,n) * rcnt
1100	endif
1101	enddo
1102	endif
1103	if (OASIS_debug >= 20) then
1104	write(nulprt,*) subname,' DEBUG loctrans calc0 = ',cplid,nf,&
1105	pcpointer%avcnt(nf)
1106	write(nulprt,*) subname,' DEBUG loctrans calc1 = ',cplid,nf,&
1107	minval(pcpointer%avect1%rAttr(nf,:)),&
1108	maxval(pcpointer%avect1%rAttr(nf,:))
1109	call oasis_flush(nulprt)
1110	if (pcpointer%aVon(2)) &
1111	write(nulprt,*) subname,' DEBUG loctrans calc2 = ',cplid,nf,&
1112	minval(pcpointer%avect2%rAttr(nf,:)),&
1113	maxval(pcpointer%avect2%rAttr(nf,:))
1114	if (pcpointer%aVon(3)) &
1115	write(nulprt,*) subname,' DEBUG loctrans calc3 = ',cplid,nf,&
1116	minval(pcpointer%avect3%rAttr(nf,:)),&
1117	maxval(pcpointer%avect3%rAttr(nf,:))
1118	if (pcpointer%aVon(4)) &
1119	write(nulprt,*) subname,' DEBUG loctrans calc4 = ',cplid,nf,&
1120	minval(pcpointer%avect4%rAttr(nf,:)),&
1121	maxval(pcpointer%avect4%rAttr(nf,:))
1122	if (pcpointer%aVon(5)) &
1123	write(nulprt,*) subname,' DEBUG loctrans calc5 = ',cplid,nf,&
1124	minval(pcpointer%avect5%rAttr(nf,:)),&
1125	maxval(pcpointer%avect5%rAttr(nf,:))
1126	endif
1127	enddo
1128	if (local_timers_on) call oasis_timer_stop(tstring)
1129	endif
1130
1131	!------------------------------------------------
1132	!> * write to restart file if put and at the end of the run,
1133	!> turn off communication
1134	! past namcouple runtime (maxtime) no communication
1135	! do restart if time+lag = maxtime, this assumes coupling
1136	! period and lag and maxtime are all nicely consistent
1137	!------------------------------------------------
1138
1139	if (mseclag >= maxtime) then
1140	sndrcv = .false. ! turn off communication
1141	unpack = .false. ! nothing to unpack
1142	endif
1143
1144	if (len_trim(rstfile) > 0) then
1145	if ((getput == OASIS3_PUT .and. lag > 0 .and. mseclag == maxtime) .or. &
1146	(getput == OASIS3_PUT .and. pcpointer%writrest)) then
1147	call oasis_debug_note(subname//' lag restart write')
1148
1149	if (lag > 0 .and. mseclag == maxtime) then
1150	kinfo = OASIS_ToRest
1151	rstfile2 = rstfile
1152	else ! writrest
1153	pcpointer%writrest = .false.
1154	write(rstfile2,'(a,i9.9,a,a)') 'TC',msec,'_',trim(rstfile)
1155	endif
1156
1157	write(tstring,'(A,I3.3)') 'wrst_',cplid
1158	if (local_timers_on) call oasis_timer_start(tstring)
1159	if (ET_debug) CALL oasis_lb_measure(cplid,LB_RST,msec)
1160	call oasis_io_write_avfile(rstfile2,pcpointer%avect1, &
1161	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny)
1162	if (pcpointer%aVon(2)) &
1163	call oasis_io_write_avfile(rstfile2,pcpointer%avect2, &
1164	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre='av2_')
1165	if (pcpointer%aVon(3)) &
1166	call oasis_io_write_avfile(rstfile2,pcpointer%avect3, &
1167	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre='av3_')
1168	if (pcpointer%aVon(4)) &
1169	call oasis_io_write_avfile(rstfile2,pcpointer%avect4, &
1170	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre='av4_')
1171	if (pcpointer%aVon(5)) &
1172	call oasis_io_write_avfile(rstfile2,pcpointer%avect5, &
1173	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre='av5_')
1174	if (ET_debug) CALL oasis_lb_measure(cplid,LB_RST,msec)
1175	if (local_timers_on) call oasis_timer_stop(tstring)
1176	if (OASIS_debug >= 2) then
1177	lstring = mct_avect_exportRList2c(pcpointer%avect1)
1178	llstring = len_trim(lstring)
1179	if (llstring <= 20) then
1180	write(nulprt,*) subname,' at ',msec,mseclag,' WRST: ', &
1181	trim(lstring),' ',trim(rstfile2)
1182	else
1183	write(nulprt,*) subname,' at ',msec,mseclag,' WRST: ', lstring(1:20), &
1184	lstring(21:llstring),' ',trim(rstfile2)
1185	endif
1186	call oasis_flush(nulprt)
1187	endif
1188	endif
1189	endif ! len_trim(rstfile)
1190
1191	!------------------------------------------------
1192	!> * map and communicate operations
1193	!------------------------------------------------
1194
1195	if (sndrcv) then
1196	if (getput == OASIS3_PUT) then
1197	kinfo = OASIS_sent
1198	call oasis_debug_note(subname//' put section')
1199	if (OASIS_debug >= 2) then
1200	lstring = mct_avect_exportRList2c(pcpointer%avect1)
1201	llstring = len_trim(lstring)
1202	if (llstring <= 20) then
1203	write(nulprt,*) subname,' at ',msec,mseclag,' SEND: ', &
1204	trim(lstring)
1205	else
1206	write(nulprt,*) subname,' at ',msec,mseclag,' SEND: ',lstring(1:20), &
1207	lstring(21:llstring)
1208	endif
1209	call oasis_flush(nulprt)
1210	endif
1211	if (sndadd /= 0.0_ip_double_p .or. sndmult /= 1.0_ip_double_p) then
1212	call oasis_debug_note(subname//' apply sndmult sndadd')
1213	if (OASIS_debug >= 20) then
1214	write(nulprt,*) subname,' DEBUG sndmult,add = ',sndmult,sndadd
1215	write(nulprt,*) subname,' DEBUG put b4 sndmult,add = ',cplid,&
1216	minval(pcpointer%avect1%rAttr),&
1217	maxval(pcpointer%avect1%rAttr)
1218	endif
1219	pcpointer%avect1%rAttr(:,:) = pcpointer%avect1%rAttr(:,:)*sndmult &
1220	+ sndadd
1221	endif
1222	if (snddiag) call oasis_advance_avdiag(pcpointer%avect1,partid)
1223	if (mapid > 0) then
1224	write(tstring,'(A,I3.3)') 'pmap_',cplid
1225	call oasis_debug_note(subname//' put map')
1226	if (OASIS_debug >= 20) then
1227	write(nulprt,*) subname,' DEBUG put av11 b4 map = ',cplid,&
1228	minval(pcpointer%avect1%rAttr),&
1229	maxval(pcpointer%avect1%rAttr)
1230	if (pcpointer%aVon(2)) &
1231	write(nulprt,*) subname,' DEBUG put av2 b4 map = ',cplid,&
1232	minval(pcpointer%avect2%rAttr),&
1233	maxval(pcpointer%avect2%rAttr)
1234	if (pcpointer%aVon(3)) &
1235	write(nulprt,*) subname,' DEBUG put av3 b4 map = ',cplid,&
1236	minval(pcpointer%avect3%rAttr),&
1237	maxval(pcpointer%avect3%rAttr)
1238	if (pcpointer%aVon(4)) &
1239	write(nulprt,*) subname,' DEBUG put av4 b4 map = ',cplid,&
1240	minval(pcpointer%avect4%rAttr),&
1241	maxval(pcpointer%avect4%rAttr)
1242	if (pcpointer%aVon(5)) &
1243	write(nulprt,*) subname,' DEBUG put av5 b4 map = ',cplid,&
1244	minval(pcpointer%avect5%rAttr),&
1245	maxval(pcpointer%avect5%rAttr)
1246	endif
1247	if (map_barrier .and. prism_part(partid)%mpicom /= MPI_COMM_NULL) then
1248	if (local_timers_on) call oasis_timer_start(trim(tstring)//'_prebarrier')
1249	call oasis_mpi_barrier(prism_part(partid)%mpicom, trim(tstring))
1250	if (local_timers_on) call oasis_timer_stop(trim(tstring)//'_prebarrier')
1251	endif
1252	if (local_timers_on) call oasis_timer_start(tstring)
1253	if (ET_debug) CALL oasis_lb_measure(cplid,LB_MAP,msec)
1254	call mct_avect_zero(pcpointer%avect1m)
1255	if (detailed_map_timing) then
1256	call oasis_advance_map(pcpointer%avect1, &
1257	pcpointer%avect1m,prism_mapper(mapid),conserv,consopt, &
1258	pcpointer%aVon ,pcpointer%avect2, &
1259	pcpointer%avect3,pcpointer%avect4, &
1260	pcpointer%avect5,tstrinp=tstring)
1261	else
1262	call oasis_advance_map(pcpointer%avect1, &
1263	pcpointer%avect1m,prism_mapper(mapid),conserv,consopt, &
1264	pcpointer%aVon ,pcpointer%avect2, &
1265	pcpointer%avect3,pcpointer%avect4, &
1266	pcpointer%avect5)
1267	endif
1268	if (ET_debug) CALL oasis_lb_measure(cplid,LB_MAP,msec)
1269	if (local_timers_on) call oasis_timer_stop(tstring)
1270	write(tstring,'(A,I3.3)') 'psnd_',cplid
1271	call oasis_debug_note(subname//' put send')
1272	if (OASIS_debug >= 20) then
1273	write(nulprt,*) subname,' DEBUG put av1m b4 send = ',cplid,&
1274	minval(pcpointer%avect1m%rAttr),&
1275	maxval(pcpointer%avect1m%rAttr)
1276	endif
1277	if (local_timers_on) call oasis_timer_start(tstring)
1278	if (ET_debug) CALL oasis_lb_measure(cplid,LB_PUT,msec)
1279	call mct_waitsend(prism_router(rouid)%router)
1280	call mct_isend(pcpointer%avect1m,prism_router(rouid)%router,tag)
1281	if (ET_debug) CALL oasis_lb_measure(cplid,LB_PUT,msec)
1282	if (local_timers_on) call oasis_timer_stop(tstring)
1283	ELSE
1284	write(tstring,'(A,I3.3)') 'psnd_',cplid
1285	call oasis_debug_note(subname//' put send')
1286	if (OASIS_debug >= 20) then
1287	write(nulprt,*) subname,' DEBUG put av1 b4 send = ',cplid,&
1288	minval(pcpointer%avect1%rAttr),&
1289	maxval(pcpointer%avect1%rAttr)
1290	endif
1291	if (local_timers_on) call oasis_timer_start(tstring)
1292	if (ET_debug) CALL oasis_lb_measure(cplid,LB_PUT,msec)
1293	call mct_waitsend(prism_router(rouid)%router)
1294	call mct_isend(pcpointer%avect1,prism_router(rouid)%router,tag)
1295	if (ET_debug) CALL oasis_lb_measure(cplid,LB_PUT,msec)
1296	if (local_timers_on) call oasis_timer_stop(tstring)
1297	ENDIF
1298	elseif (getput == OASIS3_GET) then
1299	call oasis_debug_note(subname//' get section')
1300	if (OASIS_debug >= 2 ) then
1301	lstring = mct_avect_exportRList2c(pcpointer%avect1)
1302	llstring = len_trim(lstring)
1303	if (llstring <= 20) then
1304	write(nulprt,*) subname,' at ',msec,mseclag,' RECV: ', &
1305	trim(lstring)
1306	else
1307	write(nulprt,*) subname,' at ',msec,mseclag,' RECV: ',lstring(1:20), &
1308	lstring(21:llstring)
1309	endif
1310	call oasis_flush(nulprt)
1311	endif
1312	if (mapid > 0) then
1313	call oasis_debug_note(subname//' get recv')
1314	write(tstring,'(A,I3.3)') 'grcv_',cplid
1315	if (local_timers_on) call oasis_timer_start(tstring)
1316	call mct_avect_zero(pcpointer%avect1m)
1317	if (ET_debug) CALL oasis_lb_measure(cplid,LB_GET,msec)
1318	call mct_recv(pcpointer%avect1m,prism_router(rouid)%router,tag)
1319	if (ET_debug) CALL oasis_lb_measure(cplid,LB_GET,msec)
1320	if (local_timers_on) call oasis_timer_stop(tstring)
1321	if (OASIS_debug >= 20) then
1322	write(nulprt,*) subname,' DEBUG get af recv = ',cplid,&
1323	minval(pcpointer%avect1m%rAttr),&
1324	maxval(pcpointer%avect1m%rAttr)
1325	endif
1326	call oasis_debug_note(subname//' get map')
1327	write(tstring,'(A,I3.3)') 'gmap_',cplid
1328	if (map_barrier .and. prism_part(partid)%mpicom /= MPI_COMM_NULL) then
1329	if (local_timers_on) call oasis_timer_start(trim(tstring)//'_prebarrier')
1330	call oasis_mpi_barrier(prism_part(partid)%mpicom, trim(tstring))
1331	if (local_timers_on) call oasis_timer_stop(trim(tstring)//'_prebarrier')
1332	endif
1333	if (local_timers_on) call oasis_timer_start(tstring)
1334	if (ET_debug) CALL oasis_lb_measure(cplid,LB_MAP,msec)
1335	call mct_avect_zero(pcpointer%avect1)
1336	if (detailed_map_timing) then
1337	call oasis_advance_map(pcpointer%avect1m, &
1338	pcpointer%avect1,prism_mapper(mapid),conserv,consopt,tstrinp=tstring)
1339	else
1340	call oasis_advance_map(pcpointer%avect1m, &
1341	pcpointer%avect1,prism_mapper(mapid),conserv,consopt)
1342	endif
1343	if (ET_debug) CALL oasis_lb_measure(cplid,LB_MAP,msec)
1344	if (local_timers_on) call oasis_timer_stop(tstring)
1345	if (OASIS_debug >= 20) then
1346	write(nulprt,*) subname,' DEBUG get af map = ',cplid,&
1347	minval(pcpointer%avect1%rAttr),&
1348	maxval(pcpointer%avect1%rAttr)
1349	endif
1350	else
1351	write(tstring,'(A,I3.3)') 'grcv_',cplid
1352	call oasis_debug_note(subname//' get recv')
1353	call mct_avect_zero(pcpointer%avect1)
1354	if (local_timers_on) call oasis_timer_start(tstring)
1355	if (ET_debug) CALL oasis_lb_measure(cplid,LB_GET,msec)
1356	call mct_recv(pcpointer%avect1,prism_router(rouid)%router,tag)
1357	if (ET_debug) CALL oasis_lb_measure(cplid,LB_GET,msec)
1358	if (local_timers_on) call oasis_timer_stop(tstring)
1359	if (OASIS_debug >= 20) then
1360	write(nulprt,*) subname,' DEBUG get af recv = ',cplid,&
1361	minval(pcpointer%avect1%rAttr),&
1362	maxval(pcpointer%avect1%rAttr)
1363	endif
1364	endif
1365	call oasis_debug_note(subname//' apply rcvmult rcvadd')
1366
1367	! BLASNEW local field values
1368	if (rcvadd /= 0.0_ip_double_p .or. rcvmult /= 1.0_ip_double_p) then
1369	pcpointer%avect1%rAttr(:,:) = pcpointer%avect1%rAttr(:,:)*rcvmult &
1370	+ rcvadd
1371	if (OASIS_debug >= 20) then
1372	write(nulprt,*) subname,' DEBUG rcvmult,add = ',rcvmult,rcvadd
1373	write(nulprt,*) subname,' DEBUG get af rcvmult,add = ',cplid,&
1374	minval(pcpointer%avect1%rAttr),&
1375	maxval(pcpointer%avect1%rAttr)
1376	endif
1377	endif
1378
1379	! BLASNEW other fields added
1380	if (pcpointer%rfno > 0) then
1381	call oasis_debug_note(subname//' add more flds from blasnew')
1382	do n = 1,pcpointer%rfno
1383	if (OASIS_debug >= 15) then
1384	write(nulprt,*) subname,' DEBUG blasnew add ',trim(pcpointer%rfna(n)),pcpointer%rfmult(n),pcpointer%rfadd(n)
1385	write(nulprt,*) subname,' DEBUG blasnew add ',minval(prism_coupler_get(pcpointer%rfcpl(n))%avect1p%rAttr(pcpointer%rffnum(n),:)),maxval(prism_coupler_get(pcpointer%rfcpl(n))%avect1p%rAttr(pcpointer%rffnum(n),:))
1386	endif
1387	pcpointer%avect1%rAttr(nfav,:) = pcpointer%avect1%rAttr(nfav,:) + &
1388	(prism_coupler_get(pcpointer%rfcpl(n))%avect1p%rAttr(pcpointer%rffnum(n),:) * pcpointer%rfmult(n) + pcpointer%rfadd(n))
1389	enddo
1390	endif
1391
1392	! save current field states for other BLASNEW sums later
1393	if (pcpointer%blasfld) then
1394	pcpointer%avect1p%rAttr(nfav,:) = pcpointer%avect1%rAttr(nfav,:)
1395	endif
1396
1397	if (rcvdiag) call oasis_advance_avdiag(pcpointer%avect1,partid)
1398	endif ! getput
1399	endif ! sndrcv
1400
1401	!------------------------------------------------
1402	!> * write to output files if output is turned on
1403	!------------------------------------------------
1404
1405	if (output) then
1406	if (kinfo == OASIS_sent) then
1407	kinfo = OASIS_sentout
1408	elseif (kinfo == OASIS_torest) then
1409	kinfo = OASIS_torestout
1410	else
1411	kinfo = OASIS_output
1412	endif
1413	call oasis_debug_note(subname//' output')
1414	write(tstring,'(A,I3.3)') 'wout_',cplid
1415	if (local_timers_on) call oasis_timer_start(tstring)
1416	if (OASIS_debug >= 2) then
1417	lstring = mct_avect_exportRList2c(pcpointer%avect1)
1418	llstring = len_trim(lstring)
1419	if (llstring <= 20) then
1420	write(nulprt,*) subname,' at ',msec,mseclag,' WRIT: ', &
1421	trim(lstring)
1422	else
1423	write(nulprt,*) subname,' at ',msec,mseclag,' WRIT: ',lstring(1:20), &
1424	lstring(21:llstring)
1425	endif
1426	call oasis_flush(nulprt)
1427	endif
1428	write(fstring,'(A,I2.2)') '_'//trim(compnm)//'_',cplid
1429	if (ET_debug) CALL oasis_lb_measure(cplid,LB_OUT,msec)
1430	call oasis_io_write_avfbf(pcpointer%avect1,prism_part(partid)%pgsmap,prism_part(partid)%mpicom, &
1431	nx,ny,msec,fstring)
1432	if (ET_debug) CALL oasis_lb_measure(cplid,LB_OUT,msec)
1433	if (local_timers_on) call oasis_timer_stop(tstring)
1434
1435	if (OASIS_debug >= 30) then
1436	call mct_avect_init(avtest,pcpointer%avect1,&
1437	mct_aVect_lsize(pcpointer%avect1))
1438	write(tstring,'(A,I3.3)') 'rinp_',cplid
1439	if (local_timers_on) call oasis_timer_start(tstring)
1440	call oasis_io_read_avfbf(avtest,prism_part(partid)%pgsmap,prism_part(partid)%mpicom,msec,fstring)
1441	write(nulprt,*) subname,' DEBUG write/read test avfbf should be zero ',&
1442	sum(pcpointer%avect1%rAttr-avtest%rAttr)
1443	call mct_avect_clean(avtest)
1444	if (local_timers_on) call oasis_timer_stop(tstring)
1445	endif
1446
1447	endif
1448
1449	!------------------------------------------------
1450	!> * set avcnt, avect1, ltime, and status
1451	!------------------------------------------------
1452
1453	call oasis_debug_note(subname//' reset status')
1454	if (getput == OASIS3_PUT) then
1455	if (.not.lreadrest) pcpointer%ltime = msec
1456	pcpointer%status(:) = OASIS_COMM_WAIT
1457	pcpointer%avcnt(:) = 0
1458	call mct_avect_zero(pcpointer%avect1)
1459	if (pcpointer%aVon(2)) &
1460	call mct_avect_zero(pcpointer%avect2)
1461	if (pcpointer%aVon(3)) &
1462	call mct_avect_zero(pcpointer%avect3)
1463	if (pcpointer%aVon(4)) &
1464	call mct_avect_zero(pcpointer%avect4)
1465	if (pcpointer%aVon(5)) &
1466	call mct_avect_zero(pcpointer%avect5)
1467	if (OASIS_debug >= 20) then
1468	write(nulprt,*) subname,' DEBUG put reset status = '
1469	endif
1470	elseif (getput == OASIS3_GET) then
1471	if (.not.lreadrest) pcpointer%ltime = msec
1472	pcpointer%status(:) = OASIS_COMM_WAIT
1473	if (OASIS_debug >= 20) then
1474	write(nulprt,*) subname,' DEBUG get reset status = '
1475	endif
1476	endif
1477
1478	else
1479
1480	!------------------------------------------------
1481	! no action, document
1482	!------------------------------------------------
1483
1484	if (OASIS_debug >= 15) then
1485	lstring = mct_avect_exportRList2c(pcpointer%avect1)
1486	llstring = len_trim(lstring)
1487	if (llstring <= 20) then
1488	write(nulprt,*) subname,' at ',msec,mseclag,' SKIP: ', &
1489	trim(lstring)
1490	else
1491	write(nulprt,*) subname,' at ',msec,mseclag,' SKIP: ',lstring(1:20), &
1492	lstring(21:llstring)
1493	endif
1494	call oasis_flush(nulprt)
1495	endif
1496
1497	endif ! comm_now
1498
1499	pcpointer%ctime = msec
1500
1501	!------------------------------------------------
1502	!> * at the end of the run only, save fields associated
1503	!> with non-instant loctrans operations to restart files
1504	!------------------------------------------------
1505
1506	IF ((mseclag + dt >= maxtime .AND. &
1507	getput == OASIS3_PUT .and. pcpointer%trans /= ip_instant .and. &
1508	len_trim(rstfile) > 0) .or. &
1509	(getput == OASIS3_PUT .and. pcpointer%writrest .and. len_trim(rstfile) > 0)) then
1510
1511	if (mseclag + dt >= maxtime) then
1512	rstfile2 = rstfile
1513	else ! writrest
1514	pcpointer%writrest = .false.
1515	write(rstfile2,'(a,i9.9,a,a)') 'TA',msec,'_',trim(rstfile)
1516	endif
1517
1518	call oasis_debug_note(subname//' loctrans restart write')
1519	write(tstring,'(A,I3.3)') 'wtrn_',cplid
1520	if (local_timers_on) call oasis_timer_start(tstring)
1521	if (ET_debug) CALL oasis_lb_measure(cplid,LB_TRN,msec)
1522	WRITE(vstring,'(a,i6.6,a)') 'loc',pcpointer%namID,'_cnt'
1523	CALL oasis_io_write_array(rstfile2,prism_part(partid)%mpicom,iarray=pcpointer%avcnt,&
1524	ivarname=TRIM(vstring))
1525	write(vstring,'(a,i6.6,a)') 'loc',pcpointer%namID,'_'
1526	CALL oasis_io_write_avfile(rstfile2,pcpointer%avect1, &
1527	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre=TRIM(vstring))
1528	if (pcpointer%aVon(2)) then
1529	write(vstring,'(a,i6.6,a)') 'av2loc',pcpointer%namID,'_'
1530	CALL oasis_io_write_avfile(rstfile2,pcpointer%avect2, &
1531	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre=TRIM(vstring))
1532	endif
1533	if (pcpointer%aVon(3)) then
1534	write(vstring,'(a,i6.6,a)') 'av3loc',pcpointer%namID,'_'
1535	CALL oasis_io_write_avfile(rstfile2,pcpointer%avect3, &
1536	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre=TRIM(vstring))
1537	endif
1538	if (pcpointer%aVon(4)) then
1539	write(vstring,'(a,i6.6,a)') 'av4loc',pcpointer%namID,'_'
1540	CALL oasis_io_write_avfile(rstfile2,pcpointer%avect4, &
1541	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre=TRIM(vstring))
1542	endif
1543	if (pcpointer%aVon(5)) then
1544	write(vstring,'(a,i6.6,a)') 'av5loc',pcpointer%namID,'_'
1545	CALL oasis_io_write_avfile(rstfile2,pcpointer%avect5, &
1546	prism_part(partid)%pgsmap,prism_part(partid)%mpicom,nx,ny,nampre=TRIM(vstring))
1547	endif
1548	if (ET_debug) CALL oasis_lb_measure(cplid,LB_TRN,msec)
1549	if (local_timers_on) call oasis_timer_stop(tstring)
1550	if (OASIS_debug >= 2) then
1551	lstring = mct_avect_exportRList2c(pcpointer%avect1)
1552	llstring = len_trim(lstring)
1553	if (llstring <= 20) then
1554	write(nulprt,*) subname,' at ',msec,mseclag,' WTRN: ', &
1555	trim(lstring),' ',trim(rstfile2)
1556	else
1557	write(nulprt,*) subname,' at ',msec,mseclag,' WTRN: ',lstring(1:20), &
1558	lstring(21:llstring),' ',trim(rstfile2)
1559	endif
1560	call oasis_flush(nulprt)
1561	endif
1562	if (OASIS_debug >= 20) then
1563	write(nulprt,*) subname,' DEBUG write loctrans restart',cplid,&
1564	pcpointer%avcnt
1565	write(nulprt,*) subname,' DEBUG write loctrans restart',cplid,&
1566	minval(pcpointer%avect1%rAttr),&
1567	maxval(pcpointer%avect1%rAttr)
1568	endif
1569	ENDIF
1570
1571	!------------------------------------------------
1572	!> * GET only, unpack avect1 if it's newly received
1573	!------------------------------------------------
1574
1575	if (getput == OASIS3_GET) then
1576	IF (time_now .AND. unpack) THEN
1577	if (kinfo == OASIS_output) then
1578	kinfo = OASIS_recvout
1579	elseif (kinfo == OASIS_fromrest) then
1580	kinfo = OASIS_fromrestout
1581	else
1582	kinfo = OASIS_recvd
1583	endif
1584	if (input) then
1585	kinfo = OASIS_input
1586	call oasis_debug_note(subname//' input')
1587	if (OASIS_debug >= 2) then
1588	lstring = mct_avect_exportRList2c(pcpointer%avect1)
1589	llstring = len_trim(lstring)
1590	if (llstring <= 20) then
1591	write(nulprt,*) subname,' at ',msec,mseclag,' READ: ', &
1592	trim(lstring)
1593	else
1594	write(nulprt,*) subname,' at ',msec,mseclag,' READ: ',lstring(1:20), &
1595	lstring(21:llstring)
1596	endif
1597	call oasis_flush(nulprt)
1598	endif
1599	write(tstring,'(A,I3.3)') 'grin_',cplid
1600	if (local_timers_on) call oasis_timer_start(tstring)
1601	if (ET_debug) CALL oasis_lb_measure(cplid,LB_READ,msec)
1602	if (trim(inpfile) /= trim(cspval)) then
1603	call oasis_io_read_avfbf(pcpointer%avect1,prism_part(partid)%pgsmap,prism_part(partid)%mpicom,&
1604	msec,filename=trim(inpfile))
1605	else
1606	fstring = '_'//trim(compnm)
1607	call oasis_io_read_avfbf(pcpointer%avect1,prism_part(partid)%pgsmap,prism_part(partid)%mpicom,&
1608	msec,f_string=fstring)
1609	endif
1610	if (ET_debug) CALL oasis_lb_measure(cplid,LB_READ,msec)
1611	if (local_timers_on) call oasis_timer_stop(tstring)
1612	endif
1613	if (OASIS_debug >= 2) then
1614	write(nulprt,*) subname,' at ',msec,mseclag,' UPCK: ',trim(vname)
1615	endif
1616	write(tstring,'(A,I3.3)') 'gcpy_',cplid
1617	call oasis_debug_note(subname//' get copy to array')
1618	if (local_timers_on) call oasis_timer_start(tstring)
1619	if (present(array1dout)) array1dout(:) = &
1620	pcpointer%avect1%rAttr(nfav,:)
1621	if (present(array2dout)) array2dout(:,:) = &
1622	RESHAPE(pcpointer%avect1%rAttr(nfav,:),SHAPE(array2dout))
1623	if (local_timers_on) call oasis_timer_stop(tstring)
1624	if (OASIS_debug >= 20) then
1625	if (present(array1dout)) write(nulprt,*) subname,' DEBUG array copy = ',&
1626	cplid,minval(array1dout),maxval(array1dout)
1627	if (present(array2dout)) write(nulprt,*) subname,' DEBUG array copy = ',&
1628	cplid,minval(array2dout),maxval(array2dout)
1629	endif
1630	ENDIF
1631	if (time_now) pcpointer%status(nfav) = OASIS_COMM_READY
1632	endif
1633
1634	if (OASIS_debug >= 2) then
1635	write(nulprt,*) subname,' at ',msec,mseclag,' KINF: ',trim(vname),kinfo
1636	endif
1637
1638	endif ! runit
1639	enddo ! nc = 1,var%ncpl
1640
1641	call oasis_debug_exit(subname)
1642
1643	END SUBROUTINE oasis_advance_run
1644
1645
1646	!-------------------------------------------------------------------
1647
1648	!> Provides interpolation functionality
1649
1650	!> Maps (regrids, interpolates) data from av1 to avd.
1651	!> av2-av5 are for higher order mapping (hot).
1652
1653	SUBROUTINE oasis_advance_map(av1,avd,mapper,conserv,consopt,&
1654	avon,av2,av3,av4,av5,tstrinp)
1655
1656	! NOTE: mask = 0 is active point according to oasis3 conserv.f
1657
1658	implicit none
1659	type(mct_aVect) ,intent(in) :: av1 !< source av
1660	type(mct_aVect) ,intent(inout) :: avd !< dst av
1661	type(prism_mapper_type),intent(inout) :: mapper !< prism_mapper
1662	integer(kind=ip_i4_p) ,intent(in),optional :: conserv !< conserv flag
1663	character(len=ic_med) ,intent(in),optional :: consopt !< conserv algorithm option
1664	logical ,intent(in),optional :: avon(:) !< which source hot are on
1665	type(mct_aVect) ,intent(in),optional :: av2 !< source av2 hot
1666	type(mct_aVect) ,intent(in),optional :: av3 !< source av3 hot
1667	type(mct_aVect) ,intent(in),optional :: av4 !< source av4 hot
1668	type(mct_aVect) ,intent(in),optional :: av5 !< source av5 hot
1669	character(len=*) ,intent(in),optional :: tstrinp !< timer label string
1670
1671	integer(kind=ip_i4_p) :: fsize,lsizes,lsized,nf,ni,n,m,k,l,ierr
1672	real(kind=ip_r8_p) :: sumtmp, wts_sums, wts_sumd, zradi, zlagr
1673	real(kind=ip_r8_p) :: wts_sums1(1), wts_sumd1(1)
1674	integer(kind=ip_i4_p),allocatable :: imasks(:),imaskd(:)
1675	real(kind=ip_r8_p),allocatable :: areas(:),aread(:)
1676	real(kind=ip_r8_p),allocatable :: av_sums(:),av_sumd(:) ! local sums
1677	real(kind=ip_r8_p),allocatable :: wts_sumsx(:),wts_sumdx(:) ! local sums for signed conserve
1678	type(mct_aVect) :: avdtmp ! for summing multiple mapping weights
1679	type(mct_aVect) :: av2g ! for bfb sums
1680	type(mct_aVect) :: avone ! for conserve
1681	type(mct_aVect) :: av1x,avdx ! for signed conserve
1682	type(mct_aVect) :: av1xm,avdxm ! for signed conserve masked
1683	character(len=ic_med) :: lconsopt ! conserve algorithm option
1684	character(len=ic_med) :: tstring ! timer string
1685	integer(kind=ip_i4_p),parameter :: avsmax = prism_coupler_avsmax
1686	logical :: locavon(avsmax) ! local avon
1687	integer(kind=ip_i4_p) :: avonsize
1688	integer(kind=ip_i4_p) :: higher_order_check
1689	character(len=*),parameter :: subname = '(oasis_advance_map)'
1690
1691	call oasis_debug_enter(subname)
1692	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_start')
1693
1694	!> oasis_advance_map does the following
1695	!> * check for conservation flags
1696
1697	lconsopt = 'bfb'
1698	if (present(consopt)) then
1699	lconsopt = consopt
1700	endif
1701
1702	!> * check for higher order terms
1703	!--- assume avon and av2-5 are not passed but av1 always is ---
1704	avonsize = 1
1705	locavon = .false.
1706	locavon(1) = .true.
1707
1708	!--- but if avon is passed, use avon flags ---
1709	if (present(avon)) then
1710	avonsize = size(avon)
1711	if (avonsize > avsmax) then
1712	WRITE(nulprt,*) subname,estr,'avon size',avonsize,' passed in is too large',avsmax
1713	call oasis_abort(file=__FILE__,line=__LINE__)
1714	endif
1715	locavon(1:avonsize) = avon(1:avonsize)
1716	else
1717	!--- if avon is not passed, av2-5 should not be ---
1718	if (present(av2) .or. present(av3) .or. present(av4) .or. present(av5)) then
1719	WRITE(nulprt,*) subname,estr,'av2-5 passed but avon not passed'
1720	call oasis_abort(file=__FILE__,line=__LINE__)
1721	endif
1722	endif
1723
1724	!> * check consistency between weights and coupling terms
1725
1726	! tcraig, redmine #709, add this to increase checking consistency, Aug 2016.
1727	higher_order_check = 1
1728
1729	! tcraig, redmine #709, comment this out to increase checking consistency, Aug 2016.
1730	! this section only enforces consistency when bicubic is used
1731	! nwgts=4 assumes bicubic which requires 4 higher order fields
1732	! higher_order_check = 0
1733	! if (mapper%nwgts == 4) higher_order_check = 1
1734
1735	if (higher_order_check == 0) then
1736	! must have weights for each higher order field passed but can have extra weights
1737	do n = 1,avsmax
1738	if (locavon(n) .and. n > mapper%nwgts) then
1739	WRITE(nulprt,*) subname,estr,'higher_order_check = ',higher_order_check
1740	WRITE(nulprt,*) subname,estr,'missing weights for higher order field'
1741	WRITE(nulprt,*) subname,estr,'missing weights output ',n,avsmax,mapper%nwgts,locavon(n)
1742	call oasis_abort(file=__FILE__,line=__LINE__)
1743	endif
1744	enddo
1745	else
1746	! number of higher order fields passed must exactly match the number of higher order weights
1747	do n = 1,avsmax
1748	if ((locavon(n) .and. n > mapper%nwgts) .or. &
1749	(.not. locavon(n) .and. n <= mapper%nwgts)) then
1750	WRITE(nulprt,*) subname,estr,'higher_order_check = ',higher_order_check
1751	WRITE(nulprt,*) subname,estr,'mismatch of higher order fields passed and weights'
1752	WRITE(nulprt,*) subname,estr,'mismatch weights output ',n,avsmax,mapper%nwgts,locavon(n)
1753	call oasis_abort(file=__FILE__,line=__LINE__)
1754	endif
1755	enddo
1756	endif
1757
1758	!> * run mct sparse matrix mapper on data and separately on hot as needed
1759
1760	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_start')
1761
1762	if (locavon(1)) then
1763	if (mct_avect_nRattr(av1) /= mct_avect_nRattr(avd)) then
1764	WRITE(nulprt,*) subname,estr,'in av1 num of flds'
1765	call oasis_abort(file=__FILE__,line=__LINE__)
1766	endif
1767	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_avMult1')
1768	call mct_sMat_avMult(av1, mapper%sMatP(1), avd)
1769	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_avMult1')
1770	endif
1771
1772	if (locavon(2).or.locavon(3).or.locavon(4).or.locavon(5)) then
1773	lsized = mct_avect_lsize(avd)
1774	call mct_aVect_init(avdtmp,avd,lsized)
1775
1776	if (locavon(2)) then
1777	if (mct_avect_nRattr(av2) /= mct_avect_nRattr(avd)) then
1778	WRITE(nulprt,*) subname,estr,'in av2 num of flds'
1779	call oasis_abort(file=__FILE__,line=__LINE__)
1780	endif
1781	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_avMult2')
1782	call mct_sMat_avMult(av2, mapper%sMatP(2), avdtmp)
1783	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_avMult2')
1784	avd%rAttr = avd%rAttr + avdtmp%rAttr
1785	endif
1786
1787	if (locavon(3)) then
1788	if (mct_avect_nRattr(av3) /= mct_avect_nRattr(avd)) then
1789	WRITE(nulprt,*) subname,estr,'in av3 num of flds'
1790	call oasis_abort(file=__FILE__,line=__LINE__)
1791	endif
1792	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_avMult3')
1793	call mct_sMat_avMult(av3, mapper%sMatP(3), avdtmp)
1794	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_avMult3')
1795	avd%rAttr = avd%rAttr + avdtmp%rAttr
1796	endif
1797
1798	if (locavon(4)) then
1799	if (mct_avect_nRattr(av4) /= mct_avect_nRattr(avd)) then
1800	WRITE(nulprt,*) subname,estr,'in av4 num of flds'
1801	call oasis_abort(file=__FILE__,line=__LINE__)
1802	endif
1803	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_avMult4')
1804	call mct_sMat_avMult(av4, mapper%sMatP(4), avdtmp)
1805	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_avMult4')
1806	avd%rAttr = avd%rAttr + avdtmp%rAttr
1807	endif
1808
1809	if (locavon(5)) then
1810	if (mct_avect_nRattr(av5) /= mct_avect_nRattr(avd)) then
1811	WRITE(nulprt,*) subname,estr,'in av5 num of flds'
1812	call oasis_abort(file=__FILE__,line=__LINE__)
1813	endif
1814	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_avMult5')
1815	call mct_sMat_avMult(av5, mapper%sMatP(5), avdtmp)
1816	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_avMult5')
1817	avd%rAttr = avd%rAttr + avdtmp%rAttr
1818	endif
1819
1820	call mct_aVect_clean(avdtmp)
1821	endif
1822
1823	call oasis_debug_note(subname//' map')
1824
1825	!> * enforce conservation
1826
1827	IF (PRESENT(conserv)) THEN
1828	call oasis_debug_note(subname//' conserv')
1829	IF (conserv /= ip_cnone) THEN
1830
1831	!-------------------
1832	! check that conservation can be computed for two partitions on overlapping pes only
1833	! this should be true all the time as the spart and dpart depend on each other and are
1834	! on the same pes in the initialization. add this check in case that changes.
1835	! then run the conserve on only the active pes
1836	!-------------------
1837	if ((prism_part(mapper%spart)%mpicom /= MPI_COMM_NULL .and. prism_part(mapper%dpart)%mpicom == MPI_COMM_NULL) .or. &
1838	(prism_part(mapper%spart)%mpicom == MPI_COMM_NULL .and. prism_part(mapper%dpart)%mpicom /= MPI_COMM_NULL)) then
1839	WRITE(nulprt,*) subname,estr,'illegal conserve on non overlapping pes '
1840	call oasis_abort(file=__FILE__,line=__LINE__)
1841	endif
1842
1843	IF (prism_part(mapper%spart)%mpicom /= MPI_COMM_NULL) then
1844
1845	fsize = mct_avect_nRattr(av1)
1846	allocate(av_sums(fsize),av_sumd(fsize))
1847
1848	zradi = 1./(eradius*eradius)
1849
1850	!-------------------
1851	! extract mask and area and compute sum of masked area for source
1852	! mask is from mask or frac, mask or frac must be set
1853	! area is area*frac, area must be set
1854	!!! REMINDER !!! mask=0 in oasis is an active point mask/=0 is inactive point
1855	!-------------------
1856	lsizes = mct_gsmap_lsize(prism_part(mapper%spart)%pgsmap,prism_part(mapper%spart)%mpicom)
1857	allocate(imasks(lsizes),areas(lsizes))
1858	if (prism_part(mapper%spart)%maskflag) then
1859	imasks(:) = prism_part(mapper%spart)%mask
1860	elseif (prism_part(mapper%spart)%fracflag) then
1861	imasks(:) = 1
1862	do l = 1,lsizes
1863	if (prism_part(mapper%spart)%frac(l) /= 0._ip_double_p) imasks(l) = 0
1864	enddo
1865	else
1866	WRITE(nulprt,*) subname,estr,'CONSERV mask/frac not available for grid ',trim(mapper%srcgrid)
1867	call oasis_abort(file=__FILE__,line=__LINE__)
1868	endif
1869	if (prism_part(mapper%spart)%areaflag) then
1870	areas(:) = prism_part(mapper%spart)%area*zradi
1871	else
1872	WRITE(nulprt,*) subname,estr,'CONSERV area not available for grid ',trim(mapper%srcgrid)
1873	call oasis_abort(file=__FILE__,line=__LINE__)
1874	endif
1875	if (prism_part(mapper%spart)%fracflag) then
1876	areas(:) = areas(:)*prism_part(mapper%spart)%frac
1877	endif
1878
1879	if (map_barrier .and. present(tstrinp)) then
1880	call oasis_timer_start(trim(tstrinp)//'_cons_prebarrier')
1881	call oasis_mpi_barrier(prism_part(mapper%spart)%mpicom, trim(tstrinp))
1882	call oasis_timer_stop(trim(tstrinp)//'_cons_prebarrier')
1883	endif
1884
1885	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_cons1')
1886	call mct_avect_init(avone,rList='one',lsize=lsizes)
1887	avone%rAttr = 1.0_ip_r8_p
1888	call oasis_advance_avsum(avone,wts_sums1,prism_part(mapper%spart)%pgsmap,prism_part(mapper%spart)%mpicom, &
1889	mask=imasks,wts=areas,consopt=lconsopt)
1890	wts_sums = wts_sums1(1)
1891	call mct_avect_clean(avone)
1892	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_cons1')
1893
1894	!-------------------
1895	! extract mask and area and compute sum of masked area for destination
1896	! mask is from mask or frac, mask or frac must be set
1897	! area is area*frac, area must be set
1898	!!! REMINDER !!! mask=0 in oasis is an active point mask/=0 is inactive point
1899	!-------------------
1900	lsized = mct_gsmap_lsize(prism_part(mapper%dpart)%pgsmap,prism_part(mapper%spart)%mpicom)
1901	allocate(imaskd(lsized),aread(lsized))
1902	if (prism_part(mapper%dpart)%maskflag) then
1903	imaskd(:) = prism_part(mapper%dpart)%mask
1904	elseif (prism_part(mapper%dpart)%fracflag) then
1905	imaskd(:) = 1
1906	do l = 1,lsizes
1907	if (prism_part(mapper%dpart)%frac(l) /= 0._ip_double_p) imaskd(l) = 0
1908	enddo
1909	else
1910	WRITE(nulprt,*) subname,estr,'CONSERV mask/frac not available for grid ',trim(mapper%dstgrid)
1911	call oasis_abort(file=__FILE__,line=__LINE__)
1912	endif
1913	if (prism_part(mapper%dpart)%areaflag) then
1914	aread(:) = prism_part(mapper%dpart)%area*zradi
1915	else
1916	WRITE(nulprt,*) subname,estr,'CONSERV area not available for grid ',trim(mapper%dstgrid)
1917	call oasis_abort(file=__FILE__,line=__LINE__)
1918	endif
1919	if (prism_part(mapper%dpart)%fracflag) then
1920	aread(:) = aread(:)*prism_part(mapper%dpart)%frac
1921	endif
1922
1923	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_cons2')
1924	call mct_avect_init(avone,rList='one',lsize=lsized)
1925	avone%rAttr = 1.0_ip_r8_p
1926	call oasis_advance_avsum(avone,wts_sumd1,prism_part(mapper%dpart)%pgsmap,prism_part(mapper%dpart)%mpicom, &
1927	mask=imaskd,wts=aread,consopt=lconsopt)
1928	wts_sumd = wts_sumd1(1)
1929	call mct_avect_clean(avone)
1930	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_cons2')
1931
1932	if (OASIS_debug >= 30) then
1933	write(nulprt,*) subname,' DEBUG conserve src mask ',minval(imasks),&
1934	maxval(imasks),sum(imasks)
1935	write(nulprt,*) subname,' DEBUG conserve dst mask ',minval(imaskd),&
1936	maxval(imaskd),sum(imaskd)
1937	write(nulprt,*) subname,' DEBUG conserve src area ',minval(areas),&
1938	maxval(areas),sum(areas)
1939	write(nulprt,*) subname,' DEBUG conserve dst area ',minval(aread),&
1940	maxval(aread),sum(aread)
1941	write(nulprt,*) subname,' DEBUG conserve wts_sum ',wts_sums,wts_sumd
1942	endif
1943
1944	!-------------------
1945	! compute global sums of av1
1946	! assume av1 is the thing to be conserved
1947	!-------------------
1948	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_avsum')
1949	call oasis_advance_avsum(av1,av_sums,prism_part(mapper%spart)%pgsmap,prism_part(mapper%spart)%mpicom, &
1950	mask=imasks,wts=areas,consopt=lconsopt)
1951	call oasis_advance_avsum(avd,av_sumd,prism_part(mapper%dpart)%pgsmap,prism_part(mapper%dpart)%mpicom, &
1952	mask=imaskd,wts=aread,consopt=lconsopt)
1953	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_avsum')
1954
1955	if (OASIS_debug >= 20) then
1956	if (prism_part(mapper%spart)%mpicom /= MPI_COMM_NULL) write(nulprt,*) subname,' DEBUG src sum b4 conserve ',av_sums
1957	if (prism_part(mapper%dpart)%mpicom /= MPI_COMM_NULL) write(nulprt,*) subname,' DEBUG dst sum b4 conserve ',av_sumd
1958	endif
1959
1960	if (conserv == ip_cglobal) then
1961	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_cglobal')
1962	if (wts_sumd == 0.0_ip_r8_p) then
1963	WRITE(nulprt,*) subname,estr,'global masked area sums to zero '
1964	call oasis_abort(file=__FILE__,line=__LINE__)
1965	endif
1966	do m = 1,fsize
1967	zlagr = (av_sumd(m) - av_sums(m)) / wts_sumd
1968	if (OASIS_debug >= 20) then
1969	write(nulprt,'(2a,g16.9,i5)') subname,' DEBUG conserve global +zlagr ',-zlagr,m
1970	endif
1971	do n = 1,lsized
1972	if (imaskd(n) == 0) avd%rAttr(m,n) = avd%rAttr(m,n) - zlagr
1973	enddo
1974	enddo
1975	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_cglobal')
1976
1977	elseif (conserv == ip_cglbpos) then
1978	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_cglbpos')
1979	do m = 1,fsize
1980	if (av_sumd(m) == 0.0_ip_r8_p .and. av_sums(m) /= 0.0_ip_r8_p) then
1981	WRITE(nulprt,*) subname,estr,'glbpos sumdst is zero but sumsrc is not'
1982	call oasis_abort(file=__FILE__,line=__LINE__)
1983	else
1984	if (av_sumd(m) /= 0.0_ip_r8_p) then
1985	zlagr = av_sums(m) / av_sumd(m)
1986	else
1987	zlagr = 1.0_ip_r8_p
1988	if (OASIS_debug >= 20) then
1989	write(nulprt,'(2a)') subname,' DEBUG conserve glbpos sumdst is zero, set zlagr to 1'
1990	endif
1991	endif
1992	if (OASIS_debug >= 20) then
1993	write(nulprt,'(2a,g16.9,i5)') subname,' DEBUG conserve glbpos *zlagr ',zlagr,m
1994	endif
1995	do n = 1,lsized
1996	if (imaskd(n) == 0) avd%rAttr(m,n) = avd%rAttr(m,n) * zlagr
1997	enddo
1998	endif
1999	enddo
2000	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_cglbpos')
2001
2002	elseif (conserv == ip_cgsspos) then
2003	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_cgsspos')
2004	! temporary AVs
2005	call mct_avect_init(av1x,av1,lsize=lsizes)
2006	call mct_avect_init(avdx,avd,lsize=lsized)
2007
2008	! loop twice over positive and negative values
2009	do k = 1,2
2010	av1x%rAttr = 0.0_ip_r8_p
2011	avdx%rAttr = 0.0_ip_r8_p
2012
2013	! fill postive or negative values on src and dst side
2014	do m = 1,fsize
2015	do n = 1,lsizes
2016	if (k == 1 .and. av1%rAttr(m,n) > 0.0_ip_r8_p) av1x%rAttr(m,n) = av1%rAttr(m,n)
2017	if (k == 2 .and. av1%rAttr(m,n) < 0.0_ip_r8_p) av1x%rAttr(m,n) = av1%rAttr(m,n)
2018	enddo
2019	do n = 1,lsized
2020	if (k == 1 .and. avd%rAttr(m,n) > 0.0_ip_r8_p) avdx%rAttr(m,n) = avd%rAttr(m,n)
2021	if (k == 2 .and. avd%rAttr(m,n) < 0.0_ip_r8_p) avdx%rAttr(m,n) = avd%rAttr(m,n)
2022	enddo
2023	enddo
2024
2025	! compute sums
2026	call oasis_advance_avsum(av1x,av_sums,prism_part(mapper%spart)%pgsmap,prism_part(mapper%spart)%mpicom, &
2027	mask=imasks,wts=areas,consopt=lconsopt)
2028	call oasis_advance_avsum(avdx,av_sumd,prism_part(mapper%dpart)%pgsmap,prism_part(mapper%dpart)%mpicom, &
2029	mask=imaskd,wts=aread,consopt=lconsopt)
2030
2031	! compute correction and apply
2032	do m = 1,fsize
2033	if (av_sumd(m) == 0.0_ip_r8_p .and. av_sums(m) /= 0.0_ip_r8_p) then
2034	WRITE(nulprt,*) subname,estr,'gsspos sumdst is zero but sumsrc is not'
2035	call oasis_abort(file=__FILE__,line=__LINE__)
2036	else
2037	if (av_sumd(m) /= 0.0_ip_r8_p) then
2038	zlagr = av_sums(m) / av_sumd(m)
2039	else
2040	zlagr = 1.0_ip_r8_p
2041	if (OASIS_debug >= 20) then
2042	write(nulprt,'(2a)') subname,' DEBUG conserve gsspos sumdst is zero, set zlagr to 1'
2043	endif
2044	endif
2045	if (OASIS_debug >= 20) then
2046	write(nulprt,'(2a,g16.9,i5,i2)') subname,' DEBUG conserve gsspos *zlagr ',zlagr,m,k
2047	endif
2048	do n = 1,lsized
2049	if (imaskd(n) == 0 .and. &
2050	((k == 1 .and. avd%rAttr(m,n) > 0.0_ip_r8_p) .or. &
2051	(k == 2 .and. avd%rAttr(m,n) < 0.0_ip_r8_p))) then
2052	avd%rAttr(m,n) = avd%rAttr(m,n) * zlagr
2053	endif
2054	enddo
2055	endif
2056	enddo
2057	enddo ! k
2058	call mct_avect_clean(av1x)
2059	call mct_avect_clean(avdx)
2060	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_cgsspos')
2061
2062	elseif (conserv == ip_cbasbal) then
2063	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_cbasbal')
2064	if (wts_sumd == 0.0_ip_r8_p .or. wts_sums == 0.0_ip_r8_p) then
2065	WRITE(nulprt,*) subname,estr,'basbal sum or dst area are zero'
2066	call oasis_abort(file=__FILE__,line=__LINE__)
2067	endif
2068	do m = 1,fsize
2069	zlagr = (av_sumd(m) - (av_sums(m)*(wts_sumd/wts_sums))) / wts_sumd
2070	if (OASIS_debug >= 20) then
2071	write(nulprt,'(2a,g16.9,i5)') subname,' DEBUG conserve basbal +zlagr ',-zlagr,m
2072	endif
2073	do n = 1,lsized
2074	if (imaskd(n) == 0) avd%rAttr(m,n) = avd%rAttr(m,n) - zlagr
2075	enddo
2076	enddo
2077	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_cbasbal')
2078
2079	elseif (conserv == ip_cbaspos) then
2080	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_cbaspos')
2081	do m = 1,fsize
2082	if (av_sumd(m) == 0.0_ip_r8_p .and. av_sums(m) /= 0.0_ip_r8_p) then
2083	WRITE(nulprt,*) subname,estr,'baspos sumdst is zero but sumsrc is not'
2084	call oasis_abort(file=__FILE__,line=__LINE__)
2085	elseif (wts_sumd == 0.0_ip_r8_p .or. wts_sums == 0.0_ip_r8_p) then
2086	WRITE(nulprt,*) subname,estr,'baspos sum or dst area are zero'
2087	call oasis_abort(file=__FILE__,line=__LINE__)
2088	else
2089	if (av_sumd(m) /= 0.0_ip_r8_p) then
2090	zlagr = (av_sums(m)/av_sumd(m)) * (wts_sumd/wts_sums)
2091	else
2092	zlagr = 1.0_ip_r8_p
2093	if (OASIS_debug >= 20) then
2094	write(nulprt,'(2a)') subname,' DEBUG conserve baspos sumdst is zero, set zlagr to 1'
2095	endif
2096	endif
2097	if (OASIS_debug >= 20) then
2098	write(nulprt,'(2a,g16.9,i5)') subname,' DEBUG conserve baspos *zlagr ',zlagr,m
2099	endif
2100	do n = 1,lsized
2101	if (imaskd(n) == 0) avd%rAttr(m,n) = avd%rAttr(m,n) * zlagr
2102	enddo
2103	endif
2104	enddo
2105	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_cbaspos')
2106
2107	elseif (conserv == ip_cbsspos) then
2108	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_cbsspos')
2109	! temporary AVs
2110	call mct_avect_init(av1x,av1,lsize=lsizes)
2111	call mct_avect_init(avdx,avd,lsize=lsized)
2112	call mct_avect_init(av1xm,av1,lsize=lsizes)
2113	call mct_avect_init(avdxm,avd,lsize=lsized)
2114	allocate(wts_sumsx(fsize),wts_sumdx(fsize))
2115
2116	! loop twice over positive and negative values
2117	do k = 1,2
2118	av1x%rAttr = 0.0_ip_r8_p
2119	avdx%rAttr = 0.0_ip_r8_p
2120	av1xm%rAttr = 0.0_ip_r8_p
2121	avdxm%rAttr = 0.0_ip_r8_p
2122
2123	! fill postive or negative values on src and dst side
2124	do m = 1,fsize
2125	do n = 1,lsizes
2126	if (k == 1 .and. av1%rAttr(m,n) > 0.0_ip_r8_p) av1x%rAttr(m,n) = av1%rAttr(m,n)
2127	if (k == 1 .and. av1%rAttr(m,n) > 0.0_ip_r8_p) av1xm%rAttr(m,n) = 1.0_ip_r8_p
2128	if (k == 2 .and. av1%rAttr(m,n) < 0.0_ip_r8_p) av1x%rAttr(m,n) = av1%rAttr(m,n)
2129	if (k == 2 .and. av1%rAttr(m,n) < 0.0_ip_r8_p) av1xm%rAttr(m,n) = 1.0_ip_r8_p
2130	enddo
2131	do n = 1,lsized
2132	if (k == 1 .and. avd%rAttr(m,n) > 0.0_ip_r8_p) avdx%rAttr(m,n) = avd%rAttr(m,n)
2133	if (k == 1 .and. avd%rAttr(m,n) > 0.0_ip_r8_p) avdxm%rAttr(m,n) = 1.0_ip_r8_p
2134	if (k == 2 .and. avd%rAttr(m,n) < 0.0_ip_r8_p) avdx%rAttr(m,n) = avd%rAttr(m,n)
2135	if (k == 2 .and. avd%rAttr(m,n) < 0.0_ip_r8_p) avdxm%rAttr(m,n) = 1.0_ip_r8_p
2136	enddo
2137	enddo
2138
2139	! compute sums
2140	call oasis_advance_avsum(av1x,av_sums,prism_part(mapper%spart)%pgsmap,prism_part(mapper%spart)%mpicom, &
2141	mask=imasks,wts=areas,consopt=lconsopt)
2142	call oasis_advance_avsum(avdx,av_sumd,prism_part(mapper%dpart)%pgsmap,prism_part(mapper%dpart)%mpicom, &
2143	mask=imaskd,wts=aread,consopt=lconsopt)
2144	call oasis_advance_avsum(av1xm,wts_sumsx,prism_part(mapper%spart)%pgsmap,prism_part(mapper%spart)%mpicom, &
2145	mask=imasks,wts=areas,consopt=lconsopt)
2146	call oasis_advance_avsum(avdxm,wts_sumdx,prism_part(mapper%dpart)%pgsmap,prism_part(mapper%dpart)%mpicom, &
2147	mask=imaskd,wts=aread,consopt=lconsopt)
2148
2149	! compute correction and apply
2150	do m = 1,fsize
2151	if (av_sumd(m) == 0.0_ip_r8_p .and. av_sums(m) /= 0.0_ip_r8_p) then
2152	WRITE(nulprt,*) subname,estr,'bsspos sumdst is zero but sumsrc is not'
2153	call oasis_abort(file=__FILE__,line=__LINE__)
2154	elseif (wts_sumdx(m) == 0.0_ip_r8_p .and. wts_sumsx(m) == 0.0_ip_r8_p) then
2155	if (OASIS_debug >= 20) then
2156	write(nulprt,'(2a)') subname,' DEBUG conserve bsspos sumsrc and sumdst both zero, skipping'
2157	endif
2158	elseif (wts_sumdx(m) == 0.0_ip_r8_p .or. wts_sumsx(m) == 0.0_ip_r8_p) then
2159	WRITE(nulprt,*) subname,estr,'bsspos sum or dst area are zero'
2160	call oasis_abort(file=__FILE__,line=__LINE__)
2161	else
2162	if (av_sumd(m) /= 0.0_ip_r8_p) then
2163	zlagr = (av_sums(m)/av_sumd(m)) * (wts_sumdx(m)/wts_sumsx(m))
2164	else
2165	zlagr = 1.0_ip_r8_p
2166	if (OASIS_debug >= 20) then
2167	write(nulprt,'(2a)') subname,' DEBUG conserve bsspos sumdst is zero, set zlagr to 1'
2168	endif
2169	endif
2170	if (OASIS_debug >= 20) then
2171	write(nulprt,'(2a,g16.9,i5,i2)') subname,' DEBUG conserve bsspos *zlagr ',zlagr,m,k
2172	endif
2173	do n = 1,lsized
2174	if (imaskd(n) == 0 .and. &
2175	((k == 1 .and. avd%rAttr(m,n) > 0.0_ip_r8_p) .or. &
2176	(k == 2 .and. avd%rAttr(m,n) < 0.0_ip_r8_p))) then
2177	avd%rAttr(m,n) = avd%rAttr(m,n) * zlagr
2178	endif
2179	enddo
2180	endif
2181	enddo
2182	enddo ! k
2183	call mct_avect_clean(av1x)
2184	call mct_avect_clean(avdx)
2185	call mct_avect_clean(av1xm)
2186	call mct_avect_clean(avdxm)
2187	deallocate(wts_sumsx,wts_sumdx)
2188	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_cbsspos')
2189
2190	else
2191	WRITE(nulprt,*) subname,estr,'conserv option unknown = ',conserv
2192	call oasis_abort(file=__FILE__,line=__LINE__)
2193	endif
2194
2195	if (OASIS_debug >= 20) then
2196	if (present(tstrinp)) call oasis_timer_start(trim(tstrinp)//'_avsumdiag')
2197	call oasis_advance_avsum(av1,av_sums,prism_part(mapper%spart)%pgsmap,prism_part(mapper%spart)%mpicom, &
2198	mask=imasks,wts=areas,consopt=lconsopt)
2199	call oasis_advance_avsum(avd,av_sumd,prism_part(mapper%dpart)%pgsmap,prism_part(mapper%dpart)%mpicom, &
2200	mask=imaskd,wts=aread,consopt=lconsopt)
2201	if (prism_part(mapper%spart)%mpicom /= MPI_COMM_NULL) write(nulprt,*) subname,' DEBUG src sum af conserve ',av_sums
2202	if (prism_part(mapper%dpart)%mpicom /= MPI_COMM_NULL) write(nulprt,*) subname,' DEBUG dst sum af conserve ',av_sumd
2203	CALL oasis_flush(nulprt)
2204	if (present(tstrinp)) call oasis_timer_stop(trim(tstrinp)//'_avsumdiag')
2205	endif
2206
2207	deallocate(imasks,imaskd,areas,aread)
2208	deallocate(av_sums,av_sumd)
2209
2210	ENDIF ! part%mpicom /= MPI_COMM_NULL
2211	ENDIF ! .not. ip_cnone
2212	ENDIF ! present conserve
2213
2214	call oasis_debug_exit(subname)
2215
2216	END SUBROUTINE oasis_advance_map
2217
2218	!-------------------------------------------------------------------
2219
2220	!> A generic method for summing fields in an attribute vector
2221
2222	SUBROUTINE oasis_advance_avsum(av,sum,gsmap,mpicom,mask,wts,consopt)
2223
2224	implicit none
2225	type(mct_aVect) ,intent(in) :: av ! input av
2226	real(kind=ip_r8_p) ,intent(inout) :: sum(:) ! sum of av fields
2227	type(mct_gsMap) ,intent(in) :: gsmap ! gsmap associate with av
2228	integer(kind=ip_i4_p),intent(in) :: mpicom ! mpicom
2229	integer(kind=ip_i4_p),intent(in),optional :: mask(:) ! mask to apply to av
2230	real(kind=ip_r8_p) ,intent(in),optional :: wts(:) ! wts to apply to av
2231	character(len=ic_med),intent(in),optional :: consopt ! conserve algorithm option
2232
2233	integer(kind=ip_i4_p) :: n,m,ierr,mytask
2234	integer(kind=ip_i4_p) :: lsize,fsize ! local size of av, number of flds in av
2235	real(kind=ip_r8_p),allocatable :: lsum(:) ! local sums
2236	real(kind=ip_r8_p),allocatable :: lwts(:) ! local wts taking into account mask and wts
2237	real(kind=ip_r16_p),allocatable :: lsum16(:)! local sums
2238	real(kind=ip_r16_p),allocatable :: sum16(:) ! global sums
2239	real(kind=ip_r8_p),allocatable :: reproarr(:,:) ! array of data and flds for reprosum
2240	type(mct_aVect) :: av1, av1g ! use av1,av1g for gather and bfb sum
2241	character(len=ic_med) :: lconsopt ! local conserve algorithm option
2242	character(len=*),parameter :: subname = '(oasis_advance_avsum)'
2243
2244	call oasis_debug_enter(subname)
2245
2246	if (mpicom == MPI_COMM_NULL) then
2247	call oasis_debug_exit(subname)
2248	return
2249	endif
2250
2251	lconsopt = 'bfb'
2252	if (present(consopt)) then
2253	lconsopt = consopt
2254	endif
2255
2256	fsize = mct_avect_nRattr(av)
2257	lsize = mct_avect_lsize(av)
2258
2259	allocate(lsum(fsize))
2260	lsum = 0.0_ip_r8_p
2261	allocate(lwts(lsize))
2262	lwts = 1.0_ip_r8_p
2263
2264	if (size(sum) /= fsize) then
2265	WRITE(nulprt,*) subname,estr,'size sum ne size av'
2266	call oasis_abort(file=__FILE__,line=__LINE__)
2267	endif
2268
2269	if (present(mask)) then
2270	if (size(mask) /= lsize) then
2271	WRITE(nulprt,*) subname,estr,'size mask ne size av'
2272	call oasis_abort(file=__FILE__,line=__LINE__)
2273	endif
2274	do n = 1,lsize
2275	if (mask(n) /= 0) lwts(n) = 0.0_ip_r8_p
2276	enddo
2277	endif
2278
2279	if (present(wts)) then
2280	if (size(wts) /= lsize) then
2281	WRITE(nulprt,*) subname,estr,'size wts ne size av'
2282	call oasis_abort(file=__FILE__,line=__LINE__)
2283	endif
2284	do n = 1,lsize
2285	lwts(n) = lwts(n) * wts(n)
2286	enddo
2287	endif
2288
2289	if (lconsopt == 'gather') then
2290	call mct_avect_init(av1,av,lsize)
2291	do n = 1,lsize
2292	do m = 1,fsize
2293	av1%rAttr(m,n) = av%rAttr(m,n)*lwts(n)
2294	enddo
2295	enddo
2296	call mct_avect_gather(av1,av1g,gsmap,0,mpicom)
2297	call MPI_COMM_RANK(mpicom,mytask,ierr)
2298	sum = 0.0_ip_r8_p
2299	if (mytask == 0) then
2300	do n = 1,mct_avect_lsize(av1g)
2301	do m = 1,fsize
2302	sum(m) = sum(m) + av1g%rAttr(m,n)
2303	enddo
2304	enddo
2305	endif
2306	call oasis_mpi_bcast(sum,mpicom,subname//" bcast sum")
2307	call mct_avect_clean(av1)
2308	if (mytask == 0) then
2309	call mct_avect_clean(av1g)
2310	endif
2311
2312	elseif (lconsopt == 'lsum8' .or. lconsopt == 'opt') then
2313	lsum = 0.0_ip_r8_p
2314	do n = 1,lsize
2315	do m = 1,fsize
2316	lsum(m) = lsum(m) + av%rAttr(m,n)*lwts(n)
2317	enddo
2318	enddo
2319	call oasis_mpi_sum(lsum,sum,mpicom,string=trim(subname)//':sum',all=.true.)
2320
2321	elseif (lconsopt == 'lsum16') then
2322	#ifdef __NO_16BYTE_REALS
2323	WRITE(nulprt,*) subname,estr,'consopt lsum16 not support with __NO_16BYTE_REALS cpp'
2324	call oasis_abort(file=__FILE__,line=__LINE__)
2325	#endif
2326	allocate(lsum16(fsize))
2327	allocate(sum16(fsize))
2328	lsum16 = 0.0_ip_r16_p
2329	do n = 1,lsize
2330	do m = 1,fsize
2331	lsum16(m) = lsum16(m) + real(av%rAttr(m,n),ip_r16_p)*real(lwts(n),ip_r16_p)
2332	enddo
2333	enddo
2334	call oasis_mpi_sum(lsum16,sum16,mpicom,string=trim(subname)//':sum',all=.true.)
2335	sum = real(sum16,ip_r8_p)
2336	deallocate(lsum16)
2337	deallocate(sum16)
2338
2339	elseif (lconsopt == 'reprosum' .or. lconsopt == 'ddpdd' .or. lconsopt == 'bfb') then
2340	allocate(reproarr(lsize,fsize))
2341	do n = 1,lsize
2342	do m = 1,fsize
2343	reproarr(n,m) = av%rAttr(m,n)*lwts(n)
2344	enddo
2345	enddo
2346	if (lconsopt == 'reprosum' .or. lconsopt == 'bfb') then
2347	call oasis_reprosum_calc(reproarr,sum,lsize,lsize,fsize,ddpdd_sum=.false.,commid=mpicom)
2348	else
2349	call oasis_reprosum_calc(reproarr,sum,lsize,lsize,fsize,ddpdd_sum=.true. ,commid=mpicom)
2350	endif
2351	deallocate(reproarr)
2352
2353	else
2354	WRITE(nulprt,*) subname,estr,'consopt unknown: '//trim(lconsopt)
2355	call oasis_abort(file=__FILE__,line=__LINE__)
2356
2357	endif
2358
2359	deallocate(lsum)
2360	deallocate(lwts)
2361
2362	call oasis_debug_exit(subname)
2363
2364	END SUBROUTINE oasis_advance_avsum
2365
2366	!-------------------------------------------------------------------
2367
2368	!> A generic method for writing the global sums of fields in an attribute vector
2369
2370	SUBROUTINE oasis_advance_avdiag(av,partid)
2371
2372	! We should leverage oasis_advance_avsum if we want more ways to compute the
2373	! global sum. If we're happy with "lsum8", then it's probably a little faster
2374	! to not call oasis_advance_avsum and keep the implementation local.
2375	! (tcraig, May, 2021)
2376
2377	implicit none
2378	type(mct_aVect) ,intent(in) :: av ! input av
2379	integer(kind=ip_i4_p),intent(in) :: partid ! partition id
2380
2381	integer(kind=ip_i4_p) :: n,m,ierr
2382	integer(kind=ip_i4_p) :: mpicom,mype
2383	integer(kind=ip_i4_p) :: lsize,fsize ! local size of av, number of flds in av
2384	integer(kind=ip_i4_p) :: gsize ! global size of av
2385	logical :: first_call
2386	real(kind=ip_r8_p) :: lval ! local temporary
2387	integer(kind=ip_i4_p) :: lcnt ! local count
2388	real(kind=ip_r8_p) :: lswt ! local sum of weights
2389	real(kind=ip_r8_p),allocatable :: lsum(:) ! local sum
2390	real(kind=ip_r8_p),allocatable :: lsxw(:) ! local sum of weighted fld
2391	real(kind=ip_r8_p),allocatable :: lmin(:) ! local min
2392	real(kind=ip_r8_p),allocatable :: lmax(:) ! local max
2393	real(kind=ip_r8_p),allocatable :: lminloc(:) ! local location min
2394	real(kind=ip_r8_p),allocatable :: lmaxloc(:) ! local location max
2395	real(kind=ip_r8_p),allocatable :: lall(:) ! local all global reductions
2396	integer(kind=ip_i4_p) :: gcnt ! global count
2397	real(kind=ip_r8_p) :: gswt ! global sum of weights
2398	real(kind=ip_r8_p),allocatable :: gsum(:) ! global sum
2399	real(kind=ip_r8_p),allocatable :: gsxw(:) ! global sum of weighted fld
2400	real(kind=ip_r8_p),allocatable :: gmin(:) ! global min
2401	real(kind=ip_r8_p),allocatable :: gmax(:) ! global max
2402	real(kind=ip_r8_p),allocatable :: gminloc(:) ! global location min
2403	real(kind=ip_r8_p),allocatable :: gmaxloc(:) ! global location max
2404	real(kind=ip_r8_p),allocatable :: gall(:) ! global all global reductions
2405	real(kind=ip_r8_p),allocatable :: lwts(:) ! local wts taking into account mask and wts
2406	integer(kind=ip_i4_p) :: ngloc, igloc, jgloc ! location indices
2407	logical :: dowsum ! is a weighted sum calculated
2408	type(mct_string) :: mstring ! mct char type
2409	character(len=64):: itemc ! string converted to char
2410	character(len=256) :: notes ! string with diagnostic notes
2411	character(len=*),parameter :: subname = '(oasis_advance_avdiag)'
2412
2413	call oasis_debug_enter(subname)
2414
2415	mpicom = prism_part(partid)%mpicom
2416	if (mpicom == MPI_COMM_NULL) then
2417	call oasis_debug_exit(subname)
2418	return
2419	endif
2420
2421	notes = ''
2422	fsize = mct_avect_nRattr(av)
2423	lsize = mct_avect_lsize(av)
2424
2425	allocate(lsum(fsize))
2426	allocate(lsxw(fsize))
2427	allocate(lmin(fsize))
2428	allocate(lmax(fsize))
2429	allocate(lminloc(fsize))
2430	allocate(lmaxloc(fsize))
2431	allocate(gsum(fsize))
2432	allocate(gsxw(fsize))
2433	allocate(gmin(fsize))
2434	allocate(gmax(fsize))
2435	allocate(gminloc(fsize))
2436	allocate(gmaxloc(fsize))
2437
2438	allocate(lwts(lsize))
2439	lwts = 1.0_ip_r8_p
2440	dowsum = .true.
2441	if (prism_part(partid)%maskflag) then
2442	if (size(prism_part(partid)%mask) /= lsize) then
2443	WRITE(nulprt,*) subname,estr,'size mask ne size av'
2444	call oasis_abort(file=__FILE__,line=__LINE__)
2445	endif
2446	do n = 1,lsize
2447	if (prism_part(partid)%mask(n) /= 0) lwts(n) = 0.0_ip_r8_p
2448	enddo
2449	notes = trim(notes)//':masked'
2450	else
2451	notes = trim(notes)//':no mask'
2452	endif
2453
2454	if (prism_part(partid)%areaflag .or. prism_part(partid)%fracflag) then
2455	if (prism_part(partid)%areaflag) then
2456	if (size(prism_part(partid)%area) /= lsize) then
2457	WRITE(nulprt,*) subname,estr,'size area ne size av'
2458	call oasis_abort(file=__FILE__,line=__LINE__)
2459	endif
2460	do n = 1,lsize
2461	lwts(n) = lwts(n) * prism_part(partid)%area(n)
2462	enddo
2463	notes = trim(notes)//':area weighted'
2464	endif
2465
2466	if (prism_part(partid)%fracflag) then
2467	if (size(prism_part(partid)%frac) /= lsize) then
2468	WRITE(nulprt,*) subname,estr,'size frac ne size av'
2469	call oasis_abort(file=__FILE__,line=__LINE__)
2470	endif
2471	do n = 1,lsize
2472	lwts(n) = lwts(n) * prism_part(partid)%frac(n)
2473	enddo
2474	notes = trim(notes)//':frac weighted'
2475	endif
2476	else
2477	dowsum = .false.
2478	notes = trim(notes)//':unweighted'
2479	endif
2480
2481	lcnt = 0
2482	lsum = 0.0_ip_r8_p
2483	lsxw = 0.0_ip_r8_p
2484	lswt = 0.0_ip_r8_p
2485	lmin = 9.99e36 ! in case lsize is zero
2486	lmax = -9.99e36 ! in case lsize is zero
2487	lminloc = 0.
2488	lmaxloc = 0.
2489	first_call = .true.
2490	do n = 1,lsize
2491	if (lwts(n) /= 0.0_ip_r8_p) then
2492	lswt = lswt + lwts(n)
2493	lcnt = lcnt + 1
2494	do m = 1,fsize
2495	lval = av%rAttr(m,n)
2496	lsum(m) = lsum(m) + lval
2497	lsxw(m) = lsxw(m) + lval*lwts(n)
2498	if (first_call) then
2499	lmin(m) = lval
2500	lminloc(m) = prism_part(partid)%indx(n)
2501	lmax(m) = lval
2502	lmaxloc(m) = prism_part(partid)%indx(n)
2503	else
2504	if (lval < lmin(m)) then
2505	lmin(m) = lval
2506	lminloc(m) = prism_part(partid)%indx(n)
2507	endif
2508	if (lval > lmax(m)) then
2509	lmax(m) = lval
2510	lmaxloc(m) = prism_part(partid)%indx(n)
2511	endif
2512	endif
2513	enddo
2514	first_call = .false.
2515	endif
2516	enddo
2517
2518	mype = -1
2519	call MPI_COMM_RANK(mpicom,mype,ierr)
2520
2521	! aggregate reductions where possible to save time
2522	allocate(lall(2*fsize+3))
2523	allocate(gall(2*fsize+3))
2524	lall=0.
2525	gall=0.
2526	lall(1:fsize) = lsum(1:fsize) ! local unweighted sums
2527	lall(fsize+1:2*fsize) = lsxw(1:fsize) ! local weighted sums
2528	lall(2*fsize+1) = lswt ! local sum of weights
2529	lall(2*fsize+2) = float(lcnt) ! local active number of gridcells
2530	lall(2*fsize+3) = float(lsize) ! local total number of gridcells
2531	! call oasis_mpi_sum(lsum,gsum,mpicom,string=trim(subname)//':sum',all=.false.)
2532	! call oasis_mpi_sum(lsxw,gsxw,mpicom,string=trim(subname)//':sxw',all=.false.)
2533	! call oasis_mpi_sum(lswt,gswt,mpicom,string=trim(subname)//':swt',all=.false.)
2534	! call oasis_mpi_sum(lcnt,gcnt,mpicom,string=trim(subname)//':cnt',all=.false.)
2535	! call oasis_mpi_sum(lsize,gszie,mpicom,string=trim(subname)//':siz',all=.false.)
2536	call oasis_mpi_sum(lall,gall,mpicom,string=trim(subname)//':all',all=.false.)
2537	call oasis_mpi_minloc(lmin,lminloc,gmin,gminloc,mpicom,string=trim(subname)//':min',all=.false.)
2538	call oasis_mpi_maxloc(lmax,lmaxloc,gmax,gmaxloc,mpicom,string=trim(subname)//':max',all=.false.)
2539	! disaggregate reductions as above
2540	gsum(1:fsize) = gall(1:fsize)
2541	gsxw(1:fsize) = gall(fsize+1:2*fsize)
2542	gswt = gall(2*fsize+1)
2543	gcnt = nint(gall(2*fsize+2))
2544	gsize = nint(gall(2*fsize+3))
2545	deallocate(lall)
2546	deallocate(gall)
2547
2548	if (mype == 0) then
2549	write(nulprt,*) ' '
2550	write(nulprt,'(a,1x,a,1x,a)') trim(subname),'CHECK* diags',trim(notes)
2551	write(nulprt,'(a,i12)' ) ' array size = ',gsize
2552	write(nulprt,'(a,i12)' ) ' masked size = ',gcnt
2553	write(nulprt,'(a,g24.16)') ' sum of weights = ',gswt
2554	do m = 1,fsize
2555	call mct_aVect_getRList(mstring,m,av)
2556	itemc = mct_string_toChar(mstring)
2557	call mct_string_clean(mstring)
2558	if (gcnt == 0) then
2559	write(nulprt,'(a,1x,a,1x,a,1x,a)') trim(subname),'CHECK* diags, fld=',trim(itemc),'NO unmasked data so NO DIAGNOSTICS'
2560	else
2561	write(nulprt,'(a,1x,a,1x,a,1x,a)') trim(subname),'CHECK* diags, fld=',trim(itemc),trim(notes)
2562	ngloc = nint(gminloc(m))
2563	igloc = mod(ngloc-1,prism_part(partid)%nx) + 1
2564	jgloc = (ngloc - 1) / prism_part(partid)%nx + 1
2565	write(nulprt,'(a,g24.16,1x,a)') ' minimum value = ',gmin(m),trim(itemc)
2566	write(nulprt,'(a,a1,i6,a1,i6,a1,i9,1x,a)') &
2567	' min val at = ','(',igloc,',',jgloc,')',ngloc,trim(itemc)
2568	ngloc = nint(gmaxloc(m))
2569	igloc = mod(ngloc-1,prism_part(partid)%nx) + 1
2570	jgloc = (ngloc - 1) / prism_part(partid)%nx + 1
2571	write(nulprt,'(a,g24.16,1x,a)') ' maximum value = ',gmax(m),trim(itemc)
2572	write(nulprt,'(a,a1,i6,a1,i6,a1,i9,1x,a)') &
2573	' max val at = ','(',igloc,',',jgloc,')',ngloc,trim(itemc)
2574	write(nulprt,'(a,g24.16,1x,a)') ' unweighted mean = ',gsum(m)/gcnt,trim(itemc)
2575	if (dowsum) &
2576	write(nulprt,'(a,g24.16,1x,a)') ' weighted mean = ',gsxw(m)/gswt,trim(itemc)
2577	write(nulprt,'(a,g24.16,1x,a)') ' unweighted sum = ',gsum(m),trim(itemc)
2578	if (dowsum) &
2579	write(nulprt,'(a,g24.16,1x,a)') ' weighted sum = ',gsxw(m),trim(itemc)
2580	endif
2581	enddo
2582	write(nulprt,*) ' '
2583	endif
2584
2585	deallocate(lsum,lmin,lminloc,lmax,lmaxloc)
2586	deallocate(gsum,gmin,gminloc,gmax,gmaxloc)
2587	deallocate(lwts)
2588
2589	call oasis_debug_exit(subname)
2590
2591	END SUBROUTINE oasis_advance_avdiag
2592
2593	!-------------------------------------------------------------------
2594	END MODULE mod_oasis_advance
2595

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_advance.F90 @ 6331

Download in other formats: